--------------------------------------------------------------------------------
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE TemplateHaskell            #-}
module Patat.Theme
    ( Style (..)
    , HeaderAlign (..)
    , HeaderTheme (..)
    , HeaderThemes (..)
    , Theme (..)
    , defaultTheme
    , themeForHeader

    , SyntaxHighlighting (..)
    , defaultSyntaxHighlighting
    , syntaxHighlight
    ) where


--------------------------------------------------------------------------------
import           Control.Monad          (forM_, mplus)
import qualified Data.Aeson             as A
import qualified Data.Aeson.TH.Extended as A
import           Data.Char              (toLower, toUpper)
import           Data.Colour.SRGB       (RGB (..), sRGB24reads, toSRGB24)
import           Data.List              (intercalate, isPrefixOf, isSuffixOf)
import qualified Data.Map               as M
import           Data.Maybe             (mapMaybe, maybeToList)
import qualified Data.Text              as T
import           Numeric                (showHex)
import           Prelude
import qualified Skylighting            as Skylighting
import qualified System.Console.ANSI    as Ansi
import           Text.Read              (readMaybe)


--------------------------------------------------------------------------------
newtype Style = Style {Style -> [SGR]
unStyle :: [Ansi.SGR]}
    deriving (Style -> Style -> Bool
(Style -> Style -> Bool) -> (Style -> Style -> Bool) -> Eq Style
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Style -> Style -> Bool
== :: Style -> Style -> Bool
$c/= :: Style -> Style -> Bool
/= :: Style -> Style -> Bool
Eq, Semigroup Style
Style
Semigroup Style =>
Style
-> (Style -> Style -> Style) -> ([Style] -> Style) -> Monoid Style
[Style] -> Style
Style -> Style -> Style
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: Style
mempty :: Style
$cmappend :: Style -> Style -> Style
mappend :: Style -> Style -> Style
$cmconcat :: [Style] -> Style
mconcat :: [Style] -> Style
Monoid, NonEmpty Style -> Style
Style -> Style -> Style
(Style -> Style -> Style)
-> (NonEmpty Style -> Style)
-> (forall b. Integral b => b -> Style -> Style)
-> Semigroup Style
forall b. Integral b => b -> Style -> Style
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: Style -> Style -> Style
<> :: Style -> Style -> Style
$csconcat :: NonEmpty Style -> Style
sconcat :: NonEmpty Style -> Style
$cstimes :: forall b. Integral b => b -> Style -> Style
stimes :: forall b. Integral b => b -> Style -> Style
Semigroup, Int -> Style -> ShowS
[Style] -> ShowS
Style -> String
(Int -> Style -> ShowS)
-> (Style -> String) -> ([Style] -> ShowS) -> Show Style
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Style -> ShowS
showsPrec :: Int -> Style -> ShowS
$cshow :: Style -> String
show :: Style -> String
$cshowList :: [Style] -> ShowS
showList :: [Style] -> ShowS
Show)


--------------------------------------------------------------------------------
instance A.ToJSON Style where
    toJSON :: Style -> Value
toJSON = [String] -> Value
forall a. ToJSON a => a -> Value
A.toJSON ([String] -> Value) -> (Style -> [String]) -> Style -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SGR -> Maybe String) -> [SGR] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe SGR -> Maybe String
sgrToString ([SGR] -> [String]) -> (Style -> [SGR]) -> Style -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Style -> [SGR]
unStyle


--------------------------------------------------------------------------------
instance A.FromJSON Style where
    parseJSON :: Value -> Parser Style
parseJSON Value
val = do
        names <- Value -> Parser [String]
forall a. FromJSON a => Value -> Parser a
A.parseJSON Value
val
        sgrs  <- mapM toSgr names
        return $! Style sgrs
      where
        toSgr :: String -> m SGR
toSgr String
name = case String -> Maybe SGR
stringToSgr String
name of
            Just SGR
sgr -> SGR -> m SGR
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return SGR
sgr
            Maybe SGR
Nothing  -> String -> m SGR
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m SGR) -> String -> m SGR
forall a b. (a -> b) -> a -> b
$!
                String
"Unknown style: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
". Known styles are: " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " (ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
forall a. Show a => a -> String
show ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ Map String SGR -> [String]
forall k a. Map k a -> [k]
M.keys Map String SGR
namedSgrs) String -> ShowS
forall a. [a] -> [a] -> [a]
++
                String
", or \"rgb#RrGgBb\" and \"onRgb#RrGgBb\" where 'Rr', " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                String
"'Gg' and 'Bb' are hexadecimal bytes (e.g. \"rgb#f08000\")."


--------------------------------------------------------------------------------
stringToSgr :: String -> Maybe Ansi.SGR
stringToSgr :: String -> Maybe SGR
stringToSgr String
s
    | String
"rgb#"   String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s = ConsoleLayer -> String -> Maybe SGR
rgbToSgr ConsoleLayer
Ansi.Foreground (String -> Maybe SGR) -> String -> Maybe SGR
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
4 String
s
    | String
"onRgb#" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s = ConsoleLayer -> String -> Maybe SGR
rgbToSgr ConsoleLayer
Ansi.Background (String -> Maybe SGR) -> String -> Maybe SGR
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
6 String
s
    | Bool
otherwise               = String -> Map String SGR -> Maybe SGR
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
s Map String SGR
namedSgrs


--------------------------------------------------------------------------------
rgbToSgr :: Ansi.ConsoleLayer -> String -> Maybe Ansi.SGR
rgbToSgr :: ConsoleLayer -> String -> Maybe SGR
rgbToSgr ConsoleLayer
layer String
rgbHex =
    case ReadS (Colour Float)
forall b. (Ord b, Floating b) => ReadS (Colour b)
sRGB24reads String
rgbHex of
        [(Colour Float
color, String
"")] -> SGR -> Maybe SGR
forall a. a -> Maybe a
Just (SGR -> Maybe SGR) -> SGR -> Maybe SGR
forall a b. (a -> b) -> a -> b
$ ConsoleLayer -> Colour Float -> SGR
Ansi.SetRGBColor ConsoleLayer
layer Colour Float
color
        [(Colour Float, String)]
_             -> Maybe SGR
forall a. Maybe a
Nothing


--------------------------------------------------------------------------------
sgrToString :: Ansi.SGR -> Maybe String
sgrToString :: SGR -> Maybe String
sgrToString SGR
sgr = case SGR
sgr of
    Ansi.SetColor ConsoleLayer
layer ColorIntensity
intensity Color
color -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ ConsoleLayer -> ShowS
layerPrefix ConsoleLayer
layer ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
        (case ColorIntensity
intensity of
            ColorIntensity
Ansi.Dull  -> String
"dull"
            ColorIntensity
Ansi.Vivid -> String
"vivid") String -> ShowS
forall a. [a] -> [a] -> [a]
++
        (case Color
color of
            Color
Ansi.Black   -> String
"Black"
            Color
Ansi.Red     -> String
"Red"
            Color
Ansi.Green   -> String
"Green"
            Color
Ansi.Yellow  -> String
"Yellow"
            Color
Ansi.Blue    -> String
"Blue"
            Color
Ansi.Magenta -> String
"Magenta"
            Color
Ansi.Cyan    -> String
"Cyan"
            Color
Ansi.White   -> String
"White")

    Ansi.SetUnderlining Underlining
Ansi.SingleUnderline -> String -> Maybe String
forall a. a -> Maybe a
Just String
"underline"

    Ansi.SetConsoleIntensity ConsoleIntensity
Ansi.BoldIntensity -> String -> Maybe String
forall a. a -> Maybe a
Just String
"bold"

    Ansi.SetItalicized Bool
True -> String -> Maybe String
forall a. a -> Maybe a
Just String
"italic"

    Ansi.SetRGBColor ConsoleLayer
layer Colour Float
color -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ ConsoleLayer -> ShowS
layerPrefix ConsoleLayer
layer ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
        String
"rgb#" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (RGB Word8 -> String
forall {a}. Integral a => RGB a -> String
toRGBHex (RGB Word8 -> String) -> RGB Word8 -> String
forall a b. (a -> b) -> a -> b
$ Colour Float -> RGB Word8
forall b. (RealFrac b, Floating b) => Colour b -> RGB Word8
toSRGB24 Colour Float
color)

    SGR
_ -> Maybe String
forall a. Maybe a
Nothing
  where
    toRGBHex :: RGB a -> String
toRGBHex (RGB a
r a
g a
b) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map a -> String
forall {a}. Integral a => a -> String
toHexByte [a
r, a
g, a
b]
    toHexByte :: a -> String
toHexByte a
x = a -> ShowS
forall {a}. Integral a => a -> ShowS
showHex2 a
x String
""
    showHex2 :: a -> ShowS
showHex2 a
x | a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
0xf = (String
"0" String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ShowS
forall {a}. Integral a => a -> ShowS
showHex a
x
               | Bool
otherwise = a -> ShowS
forall {a}. Integral a => a -> ShowS
showHex a
x

    layerPrefix :: ConsoleLayer -> ShowS
layerPrefix ConsoleLayer
layer String
str = case ConsoleLayer
layer of
        ConsoleLayer
Ansi.Foreground -> String
str
        ConsoleLayer
Ansi.Background -> String
"on" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
capitalize String
str
        ConsoleLayer
Ansi.Underlining -> String
"underline" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
capitalize String
str


--------------------------------------------------------------------------------
nameForTokenType :: Skylighting.TokenType -> String
nameForTokenType :: TokenType -> String
nameForTokenType =
    ShowS
unCapitalize ShowS -> (TokenType -> String) -> TokenType -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
dropTok ShowS -> (TokenType -> String) -> TokenType -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TokenType -> String
forall a. Show a => a -> String
show
  where
    unCapitalize :: ShowS
unCapitalize (Char
x : String
xs) = Char -> Char
toLower Char
x Char -> ShowS
forall a. a -> [a] -> [a]
: String
xs
    unCapitalize String
xs       = String
xs

    dropTok :: String -> String
    dropTok :: ShowS
dropTok String
str
        | String
"Tok" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
str = Int -> ShowS
forall a. Int -> [a] -> [a]
take (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3) String
str
        | Bool
otherwise              = String
str


--------------------------------------------------------------------------------
nameToTokenType :: String -> Maybe Skylighting.TokenType
nameToTokenType :: String -> Maybe TokenType
nameToTokenType = String -> Maybe TokenType
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe TokenType) -> ShowS -> String -> Maybe TokenType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
capitalize ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Tok")


--------------------------------------------------------------------------------
capitalize :: String -> String
capitalize :: ShowS
capitalize String
""       = String
""
capitalize (Char
x : String
xs) = Char -> Char
toUpper Char
x Char -> ShowS
forall a. a -> [a] -> [a]
: String
xs


--------------------------------------------------------------------------------
namedSgrs :: M.Map String Ansi.SGR
namedSgrs :: Map String SGR
namedSgrs = [(String, SGR)] -> Map String SGR
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
    [ (String
name, SGR
sgr)
    | SGR
sgr  <- [SGR]
knownSgrs
    , String
name <- Maybe String -> [String]
forall a. Maybe a -> [a]
maybeToList (SGR -> Maybe String
sgrToString SGR
sgr)
    ]
  where
    -- It doesn't really matter if we generate "too much" SGRs here since
    -- 'sgrToString' will only pick the ones we support.
    knownSgrs :: [SGR]
knownSgrs =
        [ ConsoleLayer -> ColorIntensity -> Color -> SGR
Ansi.SetColor ConsoleLayer
l ColorIntensity
i Color
c
        | ConsoleLayer
l <- [ConsoleLayer
forall a. Bounded a => a
minBound .. ConsoleLayer
forall a. Bounded a => a
maxBound]
        , ColorIntensity
i <- [ColorIntensity
forall a. Bounded a => a
minBound .. ColorIntensity
forall a. Bounded a => a
maxBound]
        , Color
c <- [Color
forall a. Bounded a => a
minBound .. Color
forall a. Bounded a => a
maxBound]
        ] [SGR] -> [SGR] -> [SGR]
forall a. [a] -> [a] -> [a]
++
        [Underlining -> SGR
Ansi.SetUnderlining      Underlining
u | Underlining
u <- [Underlining
forall a. Bounded a => a
minBound .. Underlining
forall a. Bounded a => a
maxBound]] [SGR] -> [SGR] -> [SGR]
forall a. [a] -> [a] -> [a]
++
        [ConsoleIntensity -> SGR
Ansi.SetConsoleIntensity ConsoleIntensity
c | ConsoleIntensity
c <- [ConsoleIntensity
forall a. Bounded a => a
minBound .. ConsoleIntensity
forall a. Bounded a => a
maxBound]] [SGR] -> [SGR] -> [SGR]
forall a. [a] -> [a] -> [a]
++
        [Bool -> SGR
Ansi.SetItalicized       Bool
i | Bool
i <- [Bool
forall a. Bounded a => a
minBound .. Bool
forall a. Bounded a => a
maxBound]]


--------------------------------------------------------------------------------
data HeaderAlign = LeftHeaderAlign | CenterHeaderAlign
    deriving (HeaderAlign -> HeaderAlign -> Bool
(HeaderAlign -> HeaderAlign -> Bool)
-> (HeaderAlign -> HeaderAlign -> Bool) -> Eq HeaderAlign
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HeaderAlign -> HeaderAlign -> Bool
== :: HeaderAlign -> HeaderAlign -> Bool
$c/= :: HeaderAlign -> HeaderAlign -> Bool
/= :: HeaderAlign -> HeaderAlign -> Bool
Eq, Int -> HeaderAlign -> ShowS
[HeaderAlign] -> ShowS
HeaderAlign -> String
(Int -> HeaderAlign -> ShowS)
-> (HeaderAlign -> String)
-> ([HeaderAlign] -> ShowS)
-> Show HeaderAlign
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HeaderAlign -> ShowS
showsPrec :: Int -> HeaderAlign -> ShowS
$cshow :: HeaderAlign -> String
show :: HeaderAlign -> String
$cshowList :: [HeaderAlign] -> ShowS
showList :: [HeaderAlign] -> ShowS
Show)


--------------------------------------------------------------------------------
instance A.ToJSON HeaderAlign where
    toJSON :: HeaderAlign -> Value
toJSON HeaderAlign
LeftHeaderAlign   = Value
"left"
    toJSON HeaderAlign
CenterHeaderAlign = Value
"center"


--------------------------------------------------------------------------------
instance A.FromJSON HeaderAlign where
    parseJSON :: Value -> Parser HeaderAlign
parseJSON = String
-> (Text -> Parser HeaderAlign) -> Value -> Parser HeaderAlign
forall a. String -> (Text -> Parser a) -> Value -> Parser a
A.withText String
"FromJSON HeaderAlign" ((Text -> Parser HeaderAlign) -> Value -> Parser HeaderAlign)
-> (Text -> Parser HeaderAlign) -> Value -> Parser HeaderAlign
forall a b. (a -> b) -> a -> b
$ \Text
txt -> case Text
txt of
        Text
"left"   -> HeaderAlign -> Parser HeaderAlign
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HeaderAlign
LeftHeaderAlign
        Text
"center" -> HeaderAlign -> Parser HeaderAlign
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HeaderAlign
CenterHeaderAlign
        Text
_        -> String -> Parser HeaderAlign
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser HeaderAlign) -> String -> Parser HeaderAlign
forall a b. (a -> b) -> a -> b
$ String
"Unknown align: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
txt


--------------------------------------------------------------------------------
data HeaderTheme = HeaderTheme
    { HeaderTheme -> Maybe Style
htStyle     :: !(Maybe Style)
    , HeaderTheme -> Maybe Text
htPrefix    :: !(Maybe T.Text)
    , HeaderTheme -> Maybe Text
htUnderline :: !(Maybe T.Text)
    , HeaderTheme -> Maybe HeaderAlign
htAlign     :: !(Maybe HeaderAlign)
    } deriving (HeaderTheme -> HeaderTheme -> Bool
(HeaderTheme -> HeaderTheme -> Bool)
-> (HeaderTheme -> HeaderTheme -> Bool) -> Eq HeaderTheme
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HeaderTheme -> HeaderTheme -> Bool
== :: HeaderTheme -> HeaderTheme -> Bool
$c/= :: HeaderTheme -> HeaderTheme -> Bool
/= :: HeaderTheme -> HeaderTheme -> Bool
Eq, Int -> HeaderTheme -> ShowS
[HeaderTheme] -> ShowS
HeaderTheme -> String
(Int -> HeaderTheme -> ShowS)
-> (HeaderTheme -> String)
-> ([HeaderTheme] -> ShowS)
-> Show HeaderTheme
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HeaderTheme -> ShowS
showsPrec :: Int -> HeaderTheme -> ShowS
$cshow :: HeaderTheme -> String
show :: HeaderTheme -> String
$cshowList :: [HeaderTheme] -> ShowS
showList :: [HeaderTheme] -> ShowS
Show)


--------------------------------------------------------------------------------
$(A.deriveJSON A.dropPrefixOptions ''HeaderTheme)


--------------------------------------------------------------------------------
instance Semigroup HeaderTheme where
    HeaderTheme
l <> :: HeaderTheme -> HeaderTheme -> HeaderTheme
<> HeaderTheme
r = HeaderTheme
        { htStyle :: Maybe Style
htStyle     = HeaderTheme -> Maybe Style
htStyle     HeaderTheme
l Maybe Style -> Maybe Style -> Maybe Style
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` HeaderTheme -> Maybe Style
htStyle     HeaderTheme
r
        , htPrefix :: Maybe Text
htPrefix    = HeaderTheme -> Maybe Text
htPrefix    HeaderTheme
l Maybe Text -> Maybe Text -> Maybe Text
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` HeaderTheme -> Maybe Text
htPrefix    HeaderTheme
r
        , htUnderline :: Maybe Text
htUnderline = HeaderTheme -> Maybe Text
htUnderline HeaderTheme
l Maybe Text -> Maybe Text -> Maybe Text
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` HeaderTheme -> Maybe Text
htUnderline HeaderTheme
r
        , htAlign :: Maybe HeaderAlign
htAlign     = HeaderTheme -> Maybe HeaderAlign
htAlign     HeaderTheme
l Maybe HeaderAlign -> Maybe HeaderAlign -> Maybe HeaderAlign
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` HeaderTheme -> Maybe HeaderAlign
htAlign     HeaderTheme
r
        }


--------------------------------------------------------------------------------
newtype HeaderThemes = HeaderThemes (M.Map String HeaderTheme)
    deriving (HeaderThemes -> HeaderThemes -> Bool
(HeaderThemes -> HeaderThemes -> Bool)
-> (HeaderThemes -> HeaderThemes -> Bool) -> Eq HeaderThemes
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HeaderThemes -> HeaderThemes -> Bool
== :: HeaderThemes -> HeaderThemes -> Bool
$c/= :: HeaderThemes -> HeaderThemes -> Bool
/= :: HeaderThemes -> HeaderThemes -> Bool
Eq, Int -> HeaderThemes -> ShowS
[HeaderThemes] -> ShowS
HeaderThemes -> String
(Int -> HeaderThemes -> ShowS)
-> (HeaderThemes -> String)
-> ([HeaderThemes] -> ShowS)
-> Show HeaderThemes
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HeaderThemes -> ShowS
showsPrec :: Int -> HeaderThemes -> ShowS
$cshow :: HeaderThemes -> String
show :: HeaderThemes -> String
$cshowList :: [HeaderThemes] -> ShowS
showList :: [HeaderThemes] -> ShowS
Show, Maybe HeaderThemes
Value -> Parser [HeaderThemes]
Value -> Parser HeaderThemes
(Value -> Parser HeaderThemes)
-> (Value -> Parser [HeaderThemes])
-> Maybe HeaderThemes
-> FromJSON HeaderThemes
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser HeaderThemes
parseJSON :: Value -> Parser HeaderThemes
$cparseJSONList :: Value -> Parser [HeaderThemes]
parseJSONList :: Value -> Parser [HeaderThemes]
$comittedField :: Maybe HeaderThemes
omittedField :: Maybe HeaderThemes
A.FromJSON, [HeaderThemes] -> Encoding
[HeaderThemes] -> Value
HeaderThemes -> Bool
HeaderThemes -> Encoding
HeaderThemes -> Value
(HeaderThemes -> Value)
-> (HeaderThemes -> Encoding)
-> ([HeaderThemes] -> Value)
-> ([HeaderThemes] -> Encoding)
-> (HeaderThemes -> Bool)
-> ToJSON HeaderThemes
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: HeaderThemes -> Value
toJSON :: HeaderThemes -> Value
$ctoEncoding :: HeaderThemes -> Encoding
toEncoding :: HeaderThemes -> Encoding
$ctoJSONList :: [HeaderThemes] -> Value
toJSONList :: [HeaderThemes] -> Value
$ctoEncodingList :: [HeaderThemes] -> Encoding
toEncodingList :: [HeaderThemes] -> Encoding
$comitField :: HeaderThemes -> Bool
omitField :: HeaderThemes -> Bool
A.ToJSON)


--------------------------------------------------------------------------------
instance Semigroup HeaderThemes where
    HeaderThemes Map String HeaderTheme
l <> :: HeaderThemes -> HeaderThemes -> HeaderThemes
<> HeaderThemes Map String HeaderTheme
r = Map String HeaderTheme -> HeaderThemes
HeaderThemes (Map String HeaderTheme -> HeaderThemes)
-> Map String HeaderTheme -> HeaderThemes
forall a b. (a -> b) -> a -> b
$ (HeaderTheme -> HeaderTheme -> HeaderTheme)
-> Map String HeaderTheme
-> Map String HeaderTheme
-> Map String HeaderTheme
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith HeaderTheme -> HeaderTheme -> HeaderTheme
forall a. Semigroup a => a -> a -> a
(<>) Map String HeaderTheme
l Map String HeaderTheme
r


--------------------------------------------------------------------------------
data Theme = Theme
    { Theme -> Maybe Style
themeBorders            :: !(Maybe Style)
    , Theme -> Maybe Style
themeHeader             :: !(Maybe Style)
    , Theme -> Maybe HeaderThemes
themeHeaders            :: !(Maybe HeaderThemes)
    , Theme -> Maybe Style
themeCodeBlock          :: !(Maybe Style)
    , Theme -> Maybe Style
themeBulletList         :: !(Maybe Style)
    , Theme -> Maybe Text
themeBulletListMarkers  :: !(Maybe T.Text)
    , Theme -> Maybe Style
themeOrderedList        :: !(Maybe Style)
    , Theme -> Maybe Style
themeBlockQuote         :: !(Maybe Style)
    , Theme -> Maybe Style
themeDefinitionTerm     :: !(Maybe Style)
    , Theme -> Maybe Style
themeDefinitionList     :: !(Maybe Style)
    , Theme -> Maybe Style
themeTableHeader        :: !(Maybe Style)
    , Theme -> Maybe Style
themeTableSeparator     :: !(Maybe Style)
    , Theme -> Maybe Style
themeLineBlock          :: !(Maybe Style)
    , Theme -> Maybe Style
themeEmph               :: !(Maybe Style)
    , Theme -> Maybe Style
themeStrong             :: !(Maybe Style)
    , Theme -> Maybe Style
themeUnderline          :: !(Maybe Style)
    , Theme -> Maybe Style
themeCode               :: !(Maybe Style)
    , Theme -> Maybe Style
themeLinkText           :: !(Maybe Style)
    , Theme -> Maybe Style
themeLinkTarget         :: !(Maybe Style)
    , Theme -> Maybe Style
themeStrikeout          :: !(Maybe Style)
    , Theme -> Maybe Style
themeQuoted             :: !(Maybe Style)
    , Theme -> Maybe Style
themeMath               :: !(Maybe Style)
    , Theme -> Maybe Style
themeImageText          :: !(Maybe Style)
    , Theme -> Maybe Style
themeImageTarget        :: !(Maybe Style)
    , Theme -> Maybe SyntaxHighlighting
themeSyntaxHighlighting :: !(Maybe SyntaxHighlighting)
    } deriving (Theme -> Theme -> Bool
(Theme -> Theme -> Bool) -> (Theme -> Theme -> Bool) -> Eq Theme
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Theme -> Theme -> Bool
== :: Theme -> Theme -> Bool
$c/= :: Theme -> Theme -> Bool
/= :: Theme -> Theme -> Bool
Eq, Int -> Theme -> ShowS
[Theme] -> ShowS
Theme -> String
(Int -> Theme -> ShowS)
-> (Theme -> String) -> ([Theme] -> ShowS) -> Show Theme
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Theme -> ShowS
showsPrec :: Int -> Theme -> ShowS
$cshow :: Theme -> String
show :: Theme -> String
$cshowList :: [Theme] -> ShowS
showList :: [Theme] -> ShowS
Show)


--------------------------------------------------------------------------------
instance Semigroup Theme where
    Theme
l <> :: Theme -> Theme -> Theme
<> Theme
r = Theme
        { themeBorders :: Maybe Style
themeBorders            = (Theme -> Maybe Style) -> Maybe Style
forall {m :: * -> *} {a}. MonadPlus m => (Theme -> m a) -> m a
mplusOn   Theme -> Maybe Style
themeBorders
        , themeHeader :: Maybe Style
themeHeader             = (Theme -> Maybe Style) -> Maybe Style
forall {m :: * -> *} {a}. MonadPlus m => (Theme -> m a) -> m a
mplusOn   Theme -> Maybe Style
themeHeader
        , themeHeaders :: Maybe HeaderThemes
themeHeaders            = (Theme -> Maybe HeaderThemes) -> Maybe HeaderThemes
forall {a}. Monoid a => (Theme -> a) -> a
mappendOn Theme -> Maybe HeaderThemes
themeHeaders
        , themeCodeBlock :: Maybe Style
themeCodeBlock          = (Theme -> Maybe Style) -> Maybe Style
forall {m :: * -> *} {a}. MonadPlus m => (Theme -> m a) -> m a
mplusOn   Theme -> Maybe Style
themeCodeBlock
        , themeBulletList :: Maybe Style
themeBulletList         = (Theme -> Maybe Style) -> Maybe Style
forall {m :: * -> *} {a}. MonadPlus m => (Theme -> m a) -> m a
mplusOn   Theme -> Maybe Style
themeBulletList
        , themeBulletListMarkers :: Maybe Text
themeBulletListMarkers  = (Theme -> Maybe Text) -> Maybe Text
forall {m :: * -> *} {a}. MonadPlus m => (Theme -> m a) -> m a
mplusOn   Theme -> Maybe Text
themeBulletListMarkers
        , themeOrderedList :: Maybe Style
themeOrderedList        = (Theme -> Maybe Style) -> Maybe Style
forall {m :: * -> *} {a}. MonadPlus m => (Theme -> m a) -> m a
mplusOn   Theme -> Maybe Style
themeOrderedList
        , themeBlockQuote :: Maybe Style
themeBlockQuote         = (Theme -> Maybe Style) -> Maybe Style
forall {m :: * -> *} {a}. MonadPlus m => (Theme -> m a) -> m a
mplusOn   Theme -> Maybe Style
themeBlockQuote
        , themeDefinitionTerm :: Maybe Style
themeDefinitionTerm     = (Theme -> Maybe Style) -> Maybe Style
forall {m :: * -> *} {a}. MonadPlus m => (Theme -> m a) -> m a
mplusOn   Theme -> Maybe Style
themeDefinitionTerm
        , themeDefinitionList :: Maybe Style
themeDefinitionList     = (Theme -> Maybe Style) -> Maybe Style
forall {m :: * -> *} {a}. MonadPlus m => (Theme -> m a) -> m a
mplusOn   Theme -> Maybe Style
themeDefinitionList
        , themeTableHeader :: Maybe Style
themeTableHeader        = (Theme -> Maybe Style) -> Maybe Style
forall {m :: * -> *} {a}. MonadPlus m => (Theme -> m a) -> m a
mplusOn   Theme -> Maybe Style
themeTableHeader
        , themeTableSeparator :: Maybe Style
themeTableSeparator     = (Theme -> Maybe Style) -> Maybe Style
forall {m :: * -> *} {a}. MonadPlus m => (Theme -> m a) -> m a
mplusOn   Theme -> Maybe Style
themeTableSeparator
        , themeLineBlock :: Maybe Style
themeLineBlock          = (Theme -> Maybe Style) -> Maybe Style
forall {m :: * -> *} {a}. MonadPlus m => (Theme -> m a) -> m a
mplusOn   Theme -> Maybe Style
themeLineBlock
        , themeEmph :: Maybe Style
themeEmph               = (Theme -> Maybe Style) -> Maybe Style
forall {m :: * -> *} {a}. MonadPlus m => (Theme -> m a) -> m a
mplusOn   Theme -> Maybe Style
themeEmph
        , themeStrong :: Maybe Style
themeStrong             = (Theme -> Maybe Style) -> Maybe Style
forall {m :: * -> *} {a}. MonadPlus m => (Theme -> m a) -> m a
mplusOn   Theme -> Maybe Style
themeStrong
        , themeUnderline :: Maybe Style
themeUnderline          = (Theme -> Maybe Style) -> Maybe Style
forall {m :: * -> *} {a}. MonadPlus m => (Theme -> m a) -> m a
mplusOn   Theme -> Maybe Style
themeUnderline
        , themeCode :: Maybe Style
themeCode               = (Theme -> Maybe Style) -> Maybe Style
forall {m :: * -> *} {a}. MonadPlus m => (Theme -> m a) -> m a
mplusOn   Theme -> Maybe Style
themeCode
        , themeLinkText :: Maybe Style
themeLinkText           = (Theme -> Maybe Style) -> Maybe Style
forall {m :: * -> *} {a}. MonadPlus m => (Theme -> m a) -> m a
mplusOn   Theme -> Maybe Style
themeLinkText
        , themeLinkTarget :: Maybe Style
themeLinkTarget         = (Theme -> Maybe Style) -> Maybe Style
forall {m :: * -> *} {a}. MonadPlus m => (Theme -> m a) -> m a
mplusOn   Theme -> Maybe Style
themeLinkTarget
        , themeStrikeout :: Maybe Style
themeStrikeout          = (Theme -> Maybe Style) -> Maybe Style
forall {m :: * -> *} {a}. MonadPlus m => (Theme -> m a) -> m a
mplusOn   Theme -> Maybe Style
themeStrikeout
        , themeQuoted :: Maybe Style
themeQuoted             = (Theme -> Maybe Style) -> Maybe Style
forall {m :: * -> *} {a}. MonadPlus m => (Theme -> m a) -> m a
mplusOn   Theme -> Maybe Style
themeQuoted
        , themeMath :: Maybe Style
themeMath               = (Theme -> Maybe Style) -> Maybe Style
forall {m :: * -> *} {a}. MonadPlus m => (Theme -> m a) -> m a
mplusOn   Theme -> Maybe Style
themeMath
        , themeImageText :: Maybe Style
themeImageText          = (Theme -> Maybe Style) -> Maybe Style
forall {m :: * -> *} {a}. MonadPlus m => (Theme -> m a) -> m a
mplusOn   Theme -> Maybe Style
themeImageText
        , themeImageTarget :: Maybe Style
themeImageTarget        = (Theme -> Maybe Style) -> Maybe Style
forall {m :: * -> *} {a}. MonadPlus m => (Theme -> m a) -> m a
mplusOn   Theme -> Maybe Style
themeImageTarget
        , themeSyntaxHighlighting :: Maybe SyntaxHighlighting
themeSyntaxHighlighting = (Theme -> Maybe SyntaxHighlighting) -> Maybe SyntaxHighlighting
forall {a}. Monoid a => (Theme -> a) -> a
mappendOn Theme -> Maybe SyntaxHighlighting
themeSyntaxHighlighting
        }
      where
        mplusOn :: (Theme -> m a) -> m a
mplusOn   Theme -> m a
f = Theme -> m a
f Theme
l m a -> m a -> m a
forall a. m a -> m a -> m a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`   Theme -> m a
f Theme
r
        mappendOn :: (Theme -> a) -> a
mappendOn Theme -> a
f = Theme -> a
f Theme
l a -> a -> a
forall a. Monoid a => a -> a -> a
`mappend` Theme -> a
f Theme
r


--------------------------------------------------------------------------------
instance Monoid Theme where
    mappend :: Theme -> Theme -> Theme
mappend = Theme -> Theme -> Theme
forall a. Semigroup a => a -> a -> a
(<>)
    mempty :: Theme
mempty  = Maybe Style
-> Maybe Style
-> Maybe HeaderThemes
-> Maybe Style
-> Maybe Style
-> Maybe Text
-> Maybe Style
-> Maybe Style
-> Maybe Style
-> Maybe Style
-> Maybe Style
-> Maybe Style
-> Maybe Style
-> Maybe Style
-> Maybe Style
-> Maybe Style
-> Maybe Style
-> Maybe Style
-> Maybe Style
-> Maybe Style
-> Maybe Style
-> Maybe Style
-> Maybe Style
-> Maybe Style
-> Maybe SyntaxHighlighting
-> Theme
Theme
        Maybe Style
forall a. Maybe a
Nothing Maybe Style
forall a. Maybe a
Nothing Maybe HeaderThemes
forall a. Maybe a
Nothing Maybe Style
forall a. Maybe a
Nothing Maybe Style
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing Maybe Style
forall a. Maybe a
Nothing Maybe Style
forall a. Maybe a
Nothing Maybe Style
forall a. Maybe a
Nothing
        Maybe Style
forall a. Maybe a
Nothing Maybe Style
forall a. Maybe a
Nothing Maybe Style
forall a. Maybe a
Nothing Maybe Style
forall a. Maybe a
Nothing Maybe Style
forall a. Maybe a
Nothing Maybe Style
forall a. Maybe a
Nothing Maybe Style
forall a. Maybe a
Nothing Maybe Style
forall a. Maybe a
Nothing Maybe Style
forall a. Maybe a
Nothing
        Maybe Style
forall a. Maybe a
Nothing Maybe Style
forall a. Maybe a
Nothing Maybe Style
forall a. Maybe a
Nothing Maybe Style
forall a. Maybe a
Nothing Maybe Style
forall a. Maybe a
Nothing Maybe Style
forall a. Maybe a
Nothing Maybe SyntaxHighlighting
forall a. Maybe a
Nothing

--------------------------------------------------------------------------------
defaultTheme :: Theme
defaultTheme :: Theme
defaultTheme = Theme
    { themeBorders :: Maybe Style
themeBorders            = Color -> Maybe Style
dull Color
Ansi.Yellow
    , themeHeader :: Maybe Style
themeHeader             = Color -> Maybe Style
dull Color
Ansi.Blue
    , themeHeaders :: Maybe HeaderThemes
themeHeaders            = HeaderThemes -> Maybe HeaderThemes
forall a. a -> Maybe a
Just (HeaderThemes -> Maybe HeaderThemes)
-> HeaderThemes -> Maybe HeaderThemes
forall a b. (a -> b) -> a -> b
$ Map String HeaderTheme -> HeaderThemes
HeaderThemes (Map String HeaderTheme -> HeaderThemes)
-> Map String HeaderTheme -> HeaderThemes
forall a b. (a -> b) -> a -> b
$ [(String, HeaderTheme)] -> Map String HeaderTheme
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(String, HeaderTheme)] -> Map String HeaderTheme)
-> [(String, HeaderTheme)] -> Map String HeaderTheme
forall a b. (a -> b) -> a -> b
$ do
        n <- [Int
1 .. Int
6]
        let prefix = Int -> Text -> Text
T.replicate Int
n Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
        pure ("h" <> show n, HeaderTheme Nothing (Just prefix) Nothing Nothing)
    , themeCodeBlock :: Maybe Style
themeCodeBlock          = Color -> Maybe Style
dull Color
Ansi.White Maybe Style -> Maybe Style -> Maybe Style
forall a. Monoid a => a -> a -> a
`mappend` Color -> Maybe Style
ondull Color
Ansi.Black
    , themeBulletList :: Maybe Style
themeBulletList         = Color -> Maybe Style
dull Color
Ansi.Magenta
    , themeBulletListMarkers :: Maybe Text
themeBulletListMarkers  = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"-*"
    , themeOrderedList :: Maybe Style
themeOrderedList        = Color -> Maybe Style
dull Color
Ansi.Magenta
    , themeBlockQuote :: Maybe Style
themeBlockQuote         = Color -> Maybe Style
dull Color
Ansi.Green
    , themeDefinitionTerm :: Maybe Style
themeDefinitionTerm     = Color -> Maybe Style
dull Color
Ansi.Blue
    , themeDefinitionList :: Maybe Style
themeDefinitionList     = Color -> Maybe Style
dull Color
Ansi.Magenta
    , themeTableHeader :: Maybe Style
themeTableHeader        = Color -> Maybe Style
dull Color
Ansi.Magenta Maybe Style -> Maybe Style -> Maybe Style
forall a. Monoid a => a -> a -> a
`mappend` Maybe Style
bold
    , themeTableSeparator :: Maybe Style
themeTableSeparator     = Color -> Maybe Style
dull Color
Ansi.Magenta
    , themeLineBlock :: Maybe Style
themeLineBlock          = Color -> Maybe Style
dull Color
Ansi.Magenta
    , themeEmph :: Maybe Style
themeEmph               = Color -> Maybe Style
dull Color
Ansi.Green
    , themeStrong :: Maybe Style
themeStrong             = Color -> Maybe Style
dull Color
Ansi.Red Maybe Style -> Maybe Style -> Maybe Style
forall a. Monoid a => a -> a -> a
`mappend` Maybe Style
bold
    , themeUnderline :: Maybe Style
themeUnderline          = Color -> Maybe Style
dull Color
Ansi.Red Maybe Style -> Maybe Style -> Maybe Style
forall a. Monoid a => a -> a -> a
`mappend` Maybe Style
underline
    , themeCode :: Maybe Style
themeCode               = Color -> Maybe Style
dull Color
Ansi.White Maybe Style -> Maybe Style -> Maybe Style
forall a. Monoid a => a -> a -> a
`mappend` Color -> Maybe Style
ondull Color
Ansi.Black
    , themeLinkText :: Maybe Style
themeLinkText           = Color -> Maybe Style
dull Color
Ansi.Green
    , themeLinkTarget :: Maybe Style
themeLinkTarget         = Color -> Maybe Style
dull Color
Ansi.Cyan Maybe Style -> Maybe Style -> Maybe Style
forall a. Monoid a => a -> a -> a
`mappend` Maybe Style
underline
    , themeStrikeout :: Maybe Style
themeStrikeout          = Color -> Maybe Style
ondull Color
Ansi.Red
    , themeQuoted :: Maybe Style
themeQuoted             = Color -> Maybe Style
dull Color
Ansi.Green
    , themeMath :: Maybe Style
themeMath               = Color -> Maybe Style
dull Color
Ansi.Green
    , themeImageText :: Maybe Style
themeImageText          = Color -> Maybe Style
dull Color
Ansi.Green
    , themeImageTarget :: Maybe Style
themeImageTarget        = Color -> Maybe Style
dull Color
Ansi.Cyan Maybe Style -> Maybe Style -> Maybe Style
forall a. Monoid a => a -> a -> a
`mappend` Maybe Style
underline
    , themeSyntaxHighlighting :: Maybe SyntaxHighlighting
themeSyntaxHighlighting = SyntaxHighlighting -> Maybe SyntaxHighlighting
forall a. a -> Maybe a
Just SyntaxHighlighting
defaultSyntaxHighlighting
    }
  where
    dull :: Color -> Maybe Style
dull   Color
c  = Style -> Maybe Style
forall a. a -> Maybe a
Just (Style -> Maybe Style) -> Style -> Maybe Style
forall a b. (a -> b) -> a -> b
$ [SGR] -> Style
Style [ConsoleLayer -> ColorIntensity -> Color -> SGR
Ansi.SetColor ConsoleLayer
Ansi.Foreground ColorIntensity
Ansi.Dull Color
c]
    ondull :: Color -> Maybe Style
ondull Color
c  = Style -> Maybe Style
forall a. a -> Maybe a
Just (Style -> Maybe Style) -> Style -> Maybe Style
forall a b. (a -> b) -> a -> b
$ [SGR] -> Style
Style [ConsoleLayer -> ColorIntensity -> Color -> SGR
Ansi.SetColor ConsoleLayer
Ansi.Background ColorIntensity
Ansi.Dull Color
c]
    bold :: Maybe Style
bold      = Style -> Maybe Style
forall a. a -> Maybe a
Just (Style -> Maybe Style) -> Style -> Maybe Style
forall a b. (a -> b) -> a -> b
$ [SGR] -> Style
Style [ConsoleIntensity -> SGR
Ansi.SetConsoleIntensity ConsoleIntensity
Ansi.BoldIntensity]
    underline :: Maybe Style
underline = Style -> Maybe Style
forall a. a -> Maybe a
Just (Style -> Maybe Style) -> Style -> Maybe Style
forall a b. (a -> b) -> a -> b
$ [SGR] -> Style
Style [Underlining -> SGR
Ansi.SetUnderlining Underlining
Ansi.SingleUnderline]


--------------------------------------------------------------------------------
themeForHeader :: Int -> Theme -> HeaderTheme
themeForHeader :: Int -> Theme -> HeaderTheme
themeForHeader Int
n Theme
theme = HeaderTheme
-> (HeaderTheme -> HeaderTheme) -> Maybe HeaderTheme -> HeaderTheme
forall b a. b -> (a -> b) -> Maybe a -> b
maybe HeaderTheme
def (HeaderTheme -> HeaderTheme -> HeaderTheme
forall a. Semigroup a => a -> a -> a
<> HeaderTheme
def) (Maybe HeaderTheme -> HeaderTheme)
-> Maybe HeaderTheme -> HeaderTheme
forall a b. (a -> b) -> a -> b
$ do
    HeaderThemes m <- Theme -> Maybe HeaderThemes
themeHeaders Theme
theme
    M.lookup ("h" ++ show n) m
  where
    def :: HeaderTheme
def = Maybe Style
-> Maybe Text -> Maybe Text -> Maybe HeaderAlign -> HeaderTheme
HeaderTheme (Theme -> Maybe Style
themeHeader Theme
theme) Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing Maybe HeaderAlign
forall a. Maybe a
Nothing


--------------------------------------------------------------------------------
newtype SyntaxHighlighting = SyntaxHighlighting
    { SyntaxHighlighting -> Map String Style
unSyntaxHighlighting :: M.Map String Style
    } deriving (SyntaxHighlighting -> SyntaxHighlighting -> Bool
(SyntaxHighlighting -> SyntaxHighlighting -> Bool)
-> (SyntaxHighlighting -> SyntaxHighlighting -> Bool)
-> Eq SyntaxHighlighting
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SyntaxHighlighting -> SyntaxHighlighting -> Bool
== :: SyntaxHighlighting -> SyntaxHighlighting -> Bool
$c/= :: SyntaxHighlighting -> SyntaxHighlighting -> Bool
/= :: SyntaxHighlighting -> SyntaxHighlighting -> Bool
Eq, Semigroup SyntaxHighlighting
SyntaxHighlighting
Semigroup SyntaxHighlighting =>
SyntaxHighlighting
-> (SyntaxHighlighting -> SyntaxHighlighting -> SyntaxHighlighting)
-> ([SyntaxHighlighting] -> SyntaxHighlighting)
-> Monoid SyntaxHighlighting
[SyntaxHighlighting] -> SyntaxHighlighting
SyntaxHighlighting -> SyntaxHighlighting -> SyntaxHighlighting
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: SyntaxHighlighting
mempty :: SyntaxHighlighting
$cmappend :: SyntaxHighlighting -> SyntaxHighlighting -> SyntaxHighlighting
mappend :: SyntaxHighlighting -> SyntaxHighlighting -> SyntaxHighlighting
$cmconcat :: [SyntaxHighlighting] -> SyntaxHighlighting
mconcat :: [SyntaxHighlighting] -> SyntaxHighlighting
Monoid, NonEmpty SyntaxHighlighting -> SyntaxHighlighting
SyntaxHighlighting -> SyntaxHighlighting -> SyntaxHighlighting
(SyntaxHighlighting -> SyntaxHighlighting -> SyntaxHighlighting)
-> (NonEmpty SyntaxHighlighting -> SyntaxHighlighting)
-> (forall b.
    Integral b =>
    b -> SyntaxHighlighting -> SyntaxHighlighting)
-> Semigroup SyntaxHighlighting
forall b.
Integral b =>
b -> SyntaxHighlighting -> SyntaxHighlighting
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: SyntaxHighlighting -> SyntaxHighlighting -> SyntaxHighlighting
<> :: SyntaxHighlighting -> SyntaxHighlighting -> SyntaxHighlighting
$csconcat :: NonEmpty SyntaxHighlighting -> SyntaxHighlighting
sconcat :: NonEmpty SyntaxHighlighting -> SyntaxHighlighting
$cstimes :: forall b.
Integral b =>
b -> SyntaxHighlighting -> SyntaxHighlighting
stimes :: forall b.
Integral b =>
b -> SyntaxHighlighting -> SyntaxHighlighting
Semigroup, Int -> SyntaxHighlighting -> ShowS
[SyntaxHighlighting] -> ShowS
SyntaxHighlighting -> String
(Int -> SyntaxHighlighting -> ShowS)
-> (SyntaxHighlighting -> String)
-> ([SyntaxHighlighting] -> ShowS)
-> Show SyntaxHighlighting
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SyntaxHighlighting -> ShowS
showsPrec :: Int -> SyntaxHighlighting -> ShowS
$cshow :: SyntaxHighlighting -> String
show :: SyntaxHighlighting -> String
$cshowList :: [SyntaxHighlighting] -> ShowS
showList :: [SyntaxHighlighting] -> ShowS
Show, [SyntaxHighlighting] -> Encoding
[SyntaxHighlighting] -> Value
SyntaxHighlighting -> Bool
SyntaxHighlighting -> Encoding
SyntaxHighlighting -> Value
(SyntaxHighlighting -> Value)
-> (SyntaxHighlighting -> Encoding)
-> ([SyntaxHighlighting] -> Value)
-> ([SyntaxHighlighting] -> Encoding)
-> (SyntaxHighlighting -> Bool)
-> ToJSON SyntaxHighlighting
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: SyntaxHighlighting -> Value
toJSON :: SyntaxHighlighting -> Value
$ctoEncoding :: SyntaxHighlighting -> Encoding
toEncoding :: SyntaxHighlighting -> Encoding
$ctoJSONList :: [SyntaxHighlighting] -> Value
toJSONList :: [SyntaxHighlighting] -> Value
$ctoEncodingList :: [SyntaxHighlighting] -> Encoding
toEncodingList :: [SyntaxHighlighting] -> Encoding
$comitField :: SyntaxHighlighting -> Bool
omitField :: SyntaxHighlighting -> Bool
A.ToJSON)


--------------------------------------------------------------------------------
instance A.FromJSON SyntaxHighlighting where
    parseJSON :: Value -> Parser SyntaxHighlighting
parseJSON Value
val = do
        styleMap <- Value -> Parser (Map String Style)
forall a. FromJSON a => Value -> Parser a
A.parseJSON Value
val
        forM_ (M.keys styleMap) $ \String
k -> case String -> Maybe TokenType
nameToTokenType String
k of
            Just TokenType
_  -> () -> Parser ()
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Maybe TokenType
Nothing -> String -> Parser ()
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser ()) -> String -> Parser ()
forall a b. (a -> b) -> a -> b
$ String
"Unknown token type: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
k
        return (SyntaxHighlighting styleMap)


--------------------------------------------------------------------------------
defaultSyntaxHighlighting :: SyntaxHighlighting
defaultSyntaxHighlighting :: SyntaxHighlighting
defaultSyntaxHighlighting = [(TokenType, Style)] -> SyntaxHighlighting
mkSyntaxHighlighting
    [ (TokenType
Skylighting.KeywordTok,        Color -> Style
dull Color
Ansi.Yellow)
    , (TokenType
Skylighting.ControlFlowTok,    Color -> Style
dull Color
Ansi.Yellow)

    , (TokenType
Skylighting.DataTypeTok,       Color -> Style
dull Color
Ansi.Green)

    , (TokenType
Skylighting.DecValTok,         Color -> Style
dull Color
Ansi.Red)
    , (TokenType
Skylighting.BaseNTok,          Color -> Style
dull Color
Ansi.Red)
    , (TokenType
Skylighting.FloatTok,          Color -> Style
dull Color
Ansi.Red)
    , (TokenType
Skylighting.ConstantTok,       Color -> Style
dull Color
Ansi.Red)
    , (TokenType
Skylighting.CharTok,           Color -> Style
dull Color
Ansi.Red)
    , (TokenType
Skylighting.SpecialCharTok,    Color -> Style
dull Color
Ansi.Red)
    , (TokenType
Skylighting.StringTok,         Color -> Style
dull Color
Ansi.Red)
    , (TokenType
Skylighting.VerbatimStringTok, Color -> Style
dull Color
Ansi.Red)
    , (TokenType
Skylighting.SpecialStringTok,  Color -> Style
dull Color
Ansi.Red)

    , (TokenType
Skylighting.CommentTok,        Color -> Style
dull Color
Ansi.Blue)
    , (TokenType
Skylighting.DocumentationTok,  Color -> Style
dull Color
Ansi.Blue)
    , (TokenType
Skylighting.AnnotationTok,     Color -> Style
dull Color
Ansi.Blue)
    , (TokenType
Skylighting.CommentVarTok,     Color -> Style
dull Color
Ansi.Blue)

    , (TokenType
Skylighting.ImportTok,         Color -> Style
dull Color
Ansi.Cyan)
    , (TokenType
Skylighting.OperatorTok,       Color -> Style
dull Color
Ansi.Cyan)
    , (TokenType
Skylighting.FunctionTok,       Color -> Style
dull Color
Ansi.Cyan)
    , (TokenType
Skylighting.PreprocessorTok,   Color -> Style
dull Color
Ansi.Cyan)
    ]
  where
    dull :: Color -> Style
dull Color
c = [SGR] -> Style
Style [ConsoleLayer -> ColorIntensity -> Color -> SGR
Ansi.SetColor ConsoleLayer
Ansi.Foreground ColorIntensity
Ansi.Dull Color
c]

    mkSyntaxHighlighting :: [(TokenType, Style)] -> SyntaxHighlighting
mkSyntaxHighlighting [(TokenType, Style)]
ls = Map String Style -> SyntaxHighlighting
SyntaxHighlighting (Map String Style -> SyntaxHighlighting)
-> Map String Style -> SyntaxHighlighting
forall a b. (a -> b) -> a -> b
$
        [(String, Style)] -> Map String Style
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(TokenType -> String
nameForTokenType TokenType
tt, Style
s) | (TokenType
tt, Style
s) <- [(TokenType, Style)]
ls]


--------------------------------------------------------------------------------
syntaxHighlight :: Theme -> Skylighting.TokenType -> Maybe Style
syntaxHighlight :: Theme -> TokenType -> Maybe Style
syntaxHighlight Theme
theme TokenType
tokenType = do
    sh <- Theme -> Maybe SyntaxHighlighting
themeSyntaxHighlighting Theme
theme
    M.lookup (nameForTokenType tokenType) (unSyntaxHighlighting sh)


--------------------------------------------------------------------------------
$(A.deriveJSON A.dropPrefixOptions ''Theme)