{-# LANGUAGE NoImplicitPrelude          #-}

module RIO.PrettyPrint.StylesUpdate
  ( StylesUpdate (..)
  , parseStylesUpdateFromString
  , HasStylesUpdate (..)
  ) where

import           Data.Aeson ( FromJSON (..), withText )
import           Data.Array.IArray ( assocs )
import           Data.Colour.SRGB ( Colour, sRGB24 )
import           Data.Text as T ( pack, unpack )
import           RIO
import           RIO.PrettyPrint.DefaultStyles ( defaultStyles )
import           RIO.PrettyPrint.Types ( Style, StyleSpec )
import           System.Console.ANSI.Types
                   ( BlinkSpeed (..), Color (..), ColorIntensity (..)
                   , ConsoleIntensity (..), ConsoleLayer (..), SGR (..)
                   , Underlining (..)
                   )

-- | Updates to 'Styles'

newtype StylesUpdate = StylesUpdate { StylesUpdate -> [(Style, (Text, [SGR]))]
stylesUpdate :: [(Style, StyleSpec)] }
  deriving (StylesUpdate -> StylesUpdate -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StylesUpdate -> StylesUpdate -> Bool
$c/= :: StylesUpdate -> StylesUpdate -> Bool
== :: StylesUpdate -> StylesUpdate -> Bool
$c== :: StylesUpdate -> StylesUpdate -> Bool
Eq, Int -> StylesUpdate -> ShowS
[StylesUpdate] -> ShowS
StylesUpdate -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StylesUpdate] -> ShowS
$cshowList :: [StylesUpdate] -> ShowS
show :: StylesUpdate -> String
$cshow :: StylesUpdate -> String
showsPrec :: Int -> StylesUpdate -> ShowS
$cshowsPrec :: Int -> StylesUpdate -> ShowS
Show)

-- | The first styles update overrides the second one.

instance Semigroup StylesUpdate where
  -- See module "Data.IArray.Array" of package @array@: this depends on GHC's

  -- implementation of '(//)' being such that the last value specified for a

  -- duplicated index is used.

  StylesUpdate [(Style, (Text, [SGR]))]
s1 <> :: StylesUpdate -> StylesUpdate -> StylesUpdate
<> StylesUpdate [(Style, (Text, [SGR]))]
s2 = [(Style, (Text, [SGR]))] -> StylesUpdate
StylesUpdate ([(Style, (Text, [SGR]))]
s2 forall a. Semigroup a => a -> a -> a
<> [(Style, (Text, [SGR]))]
s1)

instance Monoid StylesUpdate where
  mempty :: StylesUpdate
mempty = [(Style, (Text, [SGR]))] -> StylesUpdate
StylesUpdate []
  mappend :: StylesUpdate -> StylesUpdate -> StylesUpdate
mappend = forall a. Semigroup a => a -> a -> a
(<>) -- This needs to be specified as, before package

                 -- @base-4.11.0.0@ (GHC 8.4.2, March 2018), the default is

                 -- 'mappend = (++)'.


instance FromJSON StylesUpdate where
  parseJSON :: Value -> Parser StylesUpdate
parseJSON = forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"StylesUpdate" forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StylesUpdate
parseStylesUpdateFromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

-- |Parse a string that is a colon-delimited sequence of key=value, where 'key'

-- is a style name and 'value' is a semicolon-delimited list of 'ANSI' SGR

-- (Select Graphic Rendition) control codes (in decimal). Keys that are not

-- present in 'defaultStyles' are ignored. Items in the semicolon-delimited

-- list that are not recognised as valid control codes are ignored.

parseStylesUpdateFromString :: String -> StylesUpdate
parseStylesUpdateFromString :: String -> StylesUpdate
parseStylesUpdateFromString String
s = [(Style, (Text, [SGR]))] -> StylesUpdate
StylesUpdate forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Text, [SGR]) -> Maybe (Style, (Text, [SGR]))
process [(Text, [SGR])]
table
 where
  table :: [(Text, [SGR])]
table = do
    String
w <- Char -> String -> [String]
split Char
':' String
s
    let (String
k, String
v') = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'=') String
w
    case String
v' of
      Char
'=' : String
v -> forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Text
T.pack String
k, String -> [SGR]
parseCodes String
v)
      String
_ -> []

  process :: StyleSpec -> Maybe (Style, StyleSpec)
  process :: (Text, [SGR]) -> Maybe (Style, (Text, [SGR]))
process (Text
k, [SGR]
sgrs) = do
    Style
style <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
k [(Text, Style)]
styles
    forall (m :: * -> *) a. Monad m => a -> m a
return (Style
style, (Text
k, [SGR]
sgrs))

styles :: [(Text, Style)]
styles :: [(Text, Style)]
styles = forall a b. (a -> b) -> [a] -> [b]
map (\(Style
s, (Text
k, [SGR]
_)) -> (Text
k, Style
s)) forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)]
assocs Styles
defaultStyles

parseCodes :: String -> [SGR]
parseCodes :: String -> [SGR]
parseCodes [] = []
parseCodes String
s = [Word8] -> [SGR]
parseCodes' [Word8]
c
 where
  s' :: [String]
s' = Char -> String -> [String]
split Char
';' String
s
  c :: [Word8]
  c :: [Word8]
c = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a. Read a => String -> Maybe a
readMaybe [String]
s'

parseCodes' :: [Word8] -> [SGR]
parseCodes' :: [Word8] -> [SGR]
parseCodes' [Word8]
c = case [Word8] -> (Maybe SGR, [Word8])
codeToSGR [Word8]
c of
  (Maybe SGR
Nothing, []) -> []
  (Just SGR
sgr, []) -> [SGR
sgr]
  (Maybe SGR
Nothing, [Word8]
cs) -> [Word8] -> [SGR]
parseCodes' [Word8]
cs
  (Just SGR
sgr, [Word8]
cs) -> SGR
sgr forall a. a -> [a] -> [a]
: [Word8] -> [SGR]
parseCodes' [Word8]
cs

split :: Char -> String -> [String]
split :: Char -> String -> [String]
split Char
c String
s = case String
rest of
  []     -> [String
chunk]
  Char
_:String
rest1 -> String
chunk forall a. a -> [a] -> [a]
: Char -> String -> [String]
split Char
c String
rest1
 where
  (String
chunk, String
rest) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
==Char
c) String
s

-- |This function is, essentially, the inverse of 'sgrToCode' exported by

-- module "System.Console.ANSI.Codes" of the @ansi-terminal@ package. The

-- \'ANSI\' standards refer to (1) standard ECMA-48 \`Control Functions for

-- Coded Character Sets\' (5th edition, 1991); (2) extensions in ITU-T

-- Recommendation (previously CCITT Recommendation) T.416 (03/93) \'Information

-- Technology – Open Document Architecture (ODA) and Interchange Format:

-- Character Content Architectures\` (also published as ISO/IEC International

-- Standard 8613-6); and (3) further extensions used by \'XTerm\', a terminal

-- emulator for the X Window System. The escape codes are described in a

-- Wikipedia article at <http://en.wikipedia.org/wiki/ANSI_escape_code> and

-- those codes supported on current versions of Windows at

-- <https://docs.microsoft.com/en-us/windows/console/console-virtual-terminal-sequences>.

codeToSGR :: [Word8] -> (Maybe SGR, [Word8])
codeToSGR :: [Word8] -> (Maybe SGR, [Word8])
codeToSGR [] = (forall a. Maybe a
Nothing, [])
codeToSGR (Word8
c:[Word8]
cs)
  | Word8
c forall a. Eq a => a -> a -> Bool
==  Word8
0 = (forall a. a -> Maybe a
Just SGR
Reset, [Word8]
cs)
  | Word8
c forall a. Eq a => a -> a -> Bool
==  Word8
1 = (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
BoldIntensity, [Word8]
cs)
  | Word8
c forall a. Eq a => a -> a -> Bool
==  Word8
2 = (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
FaintIntensity, [Word8]
cs)
  | Word8
c forall a. Eq a => a -> a -> Bool
==  Word8
3 = (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Bool -> SGR
SetItalicized Bool
True, [Word8]
cs)
  | Word8
c forall a. Eq a => a -> a -> Bool
==  Word8
4 = (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Underlining -> SGR
SetUnderlining Underlining
SingleUnderline, [Word8]
cs)
  | Word8
c forall a. Eq a => a -> a -> Bool
==  Word8
5 = (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ BlinkSpeed -> SGR
SetBlinkSpeed BlinkSpeed
SlowBlink, [Word8]
cs)
  | Word8
c forall a. Eq a => a -> a -> Bool
==  Word8
6 = (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ BlinkSpeed -> SGR
SetBlinkSpeed BlinkSpeed
RapidBlink, [Word8]
cs)
  | Word8
c forall a. Eq a => a -> a -> Bool
==  Word8
7 = (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Bool -> SGR
SetSwapForegroundBackground Bool
True, [Word8]
cs)
  | Word8
c forall a. Eq a => a -> a -> Bool
==  Word8
8 = (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Bool -> SGR
SetVisible Bool
False, [Word8]
cs)
  | Word8
c forall a. Eq a => a -> a -> Bool
== Word8
21 = (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Underlining -> SGR
SetUnderlining Underlining
DoubleUnderline, [Word8]
cs)
  | Word8
c forall a. Eq a => a -> a -> Bool
== Word8
22 = (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
NormalIntensity, [Word8]
cs)
  | Word8
c forall a. Eq a => a -> a -> Bool
== Word8
23 = (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Bool -> SGR
SetItalicized Bool
False, [Word8]
cs)
  | Word8
c forall a. Eq a => a -> a -> Bool
== Word8
24 = (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Underlining -> SGR
SetUnderlining Underlining
NoUnderline, [Word8]
cs)
  | Word8
c forall a. Eq a => a -> a -> Bool
== Word8
25 = (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ BlinkSpeed -> SGR
SetBlinkSpeed BlinkSpeed
NoBlink, [Word8]
cs)
  | Word8
c forall a. Eq a => a -> a -> Bool
== Word8
27 = (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Bool -> SGR
SetSwapForegroundBackground Bool
False, [Word8]
cs)
  | Word8
c forall a. Eq a => a -> a -> Bool
== Word8
28 = (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Bool -> SGR
SetVisible Bool
True, [Word8]
cs)
  | Word8
c forall a. Ord a => a -> a -> Bool
>= Word8
30 Bool -> Bool -> Bool
&& Word8
c forall a. Ord a => a -> a -> Bool
<= Word8
37 =
    (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull forall a b. (a -> b) -> a -> b
$ Word8 -> Color
codeToColor (Word8
c forall a. Num a => a -> a -> a
- Word8
30), [Word8]
cs)
  | Word8
c forall a. Eq a => a -> a -> Bool
== Word8
38 = case [Word8] -> (Maybe (Colour Float), [Word8])
codeToRGB [Word8]
cs of
    (Maybe (Colour Float)
Nothing, [Word8]
cs') -> (forall a. Maybe a
Nothing, [Word8]
cs')
    (Just Colour Float
color, [Word8]
cs') -> (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ConsoleLayer -> Colour Float -> SGR
SetRGBColor ConsoleLayer
Foreground Colour Float
color, [Word8]
cs')
  | Word8
c forall a. Ord a => a -> a -> Bool
>= Word8
40 Bool -> Bool -> Bool
&& Word8
c forall a. Ord a => a -> a -> Bool
<= Word8
47 =
    (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Background ColorIntensity
Dull forall a b. (a -> b) -> a -> b
$ Word8 -> Color
codeToColor (Word8
c forall a. Num a => a -> a -> a
- Word8
40), [Word8]
cs)
  | Word8
c forall a. Eq a => a -> a -> Bool
== Word8
48 = case [Word8] -> (Maybe (Colour Float), [Word8])
codeToRGB [Word8]
cs of
    (Maybe (Colour Float)
Nothing, [Word8]
cs') -> (forall a. Maybe a
Nothing, [Word8]
cs')
    (Just Colour Float
color, [Word8]
cs') -> (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ConsoleLayer -> Colour Float -> SGR
SetRGBColor ConsoleLayer
Background Colour Float
color, [Word8]
cs')
  | Word8
c forall a. Ord a => a -> a -> Bool
>= Word8
90 Bool -> Bool -> Bool
&& Word8
c forall a. Ord a => a -> a -> Bool
<= Word8
97 =
    (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid forall a b. (a -> b) -> a -> b
$ Word8 -> Color
codeToColor (Word8
c forall a. Num a => a -> a -> a
- Word8
90), [Word8]
cs)
  | Word8
c forall a. Ord a => a -> a -> Bool
>= Word8
100 Bool -> Bool -> Bool
&& Word8
c forall a. Ord a => a -> a -> Bool
<= Word8
107 =
    (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Background ColorIntensity
Vivid forall a b. (a -> b) -> a -> b
$ Word8 -> Color
codeToColor (Word8
c forall a. Num a => a -> a -> a
- Word8
100), [Word8]
cs)
  | Bool
otherwise = (forall a. Maybe a
Nothing, [Word8]
cs)

-- |This function is, essentially, the inverse of 'colorToCode' exported by

-- module "System.Console.ANSI.Codes" of the @ansi-terminal@ package. The

-- \'ANSI\' standards refer to eight named colours in a specific order. The code

-- is a 0-based index of those colours.

codeToColor :: Word8 -> Color
codeToColor :: Word8 -> Color
codeToColor Word8
c
  -- 'toEnum' is not used because the @ansi-terminal@ package does not

  -- /guarantee/ the order of the data constructors of type 'Color' will be the

  -- same as that of the \'ANSI\' standards (although it currently is). (The

  -- 'colorToCode' function itself does not use 'fromEnum'.)

  | Word8
c forall a. Eq a => a -> a -> Bool
== Word8
0 = Color
Black
  | Word8
c forall a. Eq a => a -> a -> Bool
== Word8
1 = Color
Red
  | Word8
c forall a. Eq a => a -> a -> Bool
== Word8
2 = Color
Green
  | Word8
c forall a. Eq a => a -> a -> Bool
== Word8
3 = Color
Yellow
  | Word8
c forall a. Eq a => a -> a -> Bool
== Word8
4 = Color
Blue
  | Word8
c forall a. Eq a => a -> a -> Bool
== Word8
5 = Color
Magenta
  | Word8
c forall a. Eq a => a -> a -> Bool
== Word8
6 = Color
Cyan
  | Word8
c forall a. Eq a => a -> a -> Bool
== Word8
7 = Color
White
  | Bool
otherwise = forall a. HasCallStack => String -> a
error String
"Error: codeToColor, code outside 0 to 7."

codeToRGB :: [Word8] -> (Maybe (Colour Float), [Word8])
codeToRGB :: [Word8] -> (Maybe (Colour Float), [Word8])
codeToRGB [] = (forall a. Maybe a
Nothing, [])
codeToRGB (Word8
2:Word8
r:Word8
g:Word8
b:[Word8]
cs) = (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall b.
(Ord b, Floating b) =>
Word8 -> Word8 -> Word8 -> Colour b
sRGB24 Word8
r Word8
g Word8
b, [Word8]
cs)
codeToRGB [Word8]
cs = (forall a. Maybe a
Nothing, [Word8]
cs)

-- | Environment values with a styles update.

--

-- @since 0.1.0.0

class HasStylesUpdate env where
  stylesUpdateL :: Lens' env StylesUpdate
instance HasStylesUpdate StylesUpdate where
  stylesUpdateL :: Lens' StylesUpdate StylesUpdate
stylesUpdateL = forall a. a -> a
id