--------------------------------------------------------------------------------
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE TemplateHaskell            #-}
module Patat.Theme
    ( Theme (..)
    , defaultTheme

    , Style (..)

    , 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)


--------------------------------------------------------------------------------
data Theme = Theme
    { Theme -> Maybe Style
themeBorders            :: !(Maybe Style)
    , Theme -> Maybe Style
themeHeader             :: !(Maybe Style)
    , 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 (Int -> Theme -> ShowS
[Theme] -> ShowS
Theme -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Theme] -> ShowS
$cshowList :: [Theme] -> ShowS
show :: Theme -> String
$cshow :: Theme -> String
showsPrec :: Int -> Theme -> ShowS
$cshowsPrec :: Int -> Theme -> ShowS
Show)


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


--------------------------------------------------------------------------------
instance Monoid Theme where
    mappend :: Theme -> Theme -> Theme
mappend = forall a. Semigroup a => a -> a -> a
(<>)
    mempty :: Theme
mempty  = Maybe Style
-> Maybe Style
-> 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
        forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing
        forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing
        forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing 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
    , themeCodeBlock :: Maybe Style
themeCodeBlock          = Color -> Maybe Style
dull Color
Ansi.White 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  = 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 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 forall a. Monoid a => a -> a -> a
`mappend` Maybe Style
bold
    , themeUnderline :: Maybe Style
themeUnderline          = Color -> Maybe Style
dull Color
Ansi.Red forall a. Monoid a => a -> a -> a
`mappend` Maybe Style
underline
    , themeCode :: Maybe Style
themeCode               = Color -> Maybe Style
dull Color
Ansi.White 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 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 forall a. Monoid a => a -> a -> a
`mappend` Maybe Style
underline
    , themeSyntaxHighlighting :: Maybe SyntaxHighlighting
themeSyntaxHighlighting = forall a. a -> Maybe a
Just SyntaxHighlighting
defaultSyntaxHighlighting
    }
  where
    dull :: Color -> Maybe Style
dull   Color
c  = forall a. a -> Maybe a
Just 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  = forall a. a -> Maybe a
Just 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      = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [SGR] -> Style
Style [ConsoleIntensity -> SGR
Ansi.SetConsoleIntensity ConsoleIntensity
Ansi.BoldIntensity]
    underline :: Maybe Style
underline = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [SGR] -> Style
Style [Underlining -> SGR
Ansi.SetUnderlining Underlining
Ansi.SingleUnderline]


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


--------------------------------------------------------------------------------
instance A.ToJSON Style where
    toJSON :: Style -> Value
toJSON = forall a. ToJSON a => a -> Value
A.toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe SGR -> Maybe String
sgrToString 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
        [String]
names <- forall a. FromJSON a => Value -> Parser a
A.parseJSON Value
val
        [SGR]
sgrs  <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {m :: * -> *}. MonadFail m => String -> m SGR
toSgr [String]
names
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! [SGR] -> Style
Style [SGR]
sgrs
      where
        toSgr :: String -> m SGR
toSgr String
name = case String -> Maybe SGR
stringToSgr String
name of
            Just SGR
sgr -> forall (m :: * -> *) a. Monad m => a -> m a
return SGR
sgr
            Maybe SGR
Nothing  -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$!
                String
"Unknown style: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
name forall a. [a] -> [a] -> [a]
++ String
". Known styles are: " forall a. [a] -> [a] -> [a]
++
                forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
M.keys Map String SGR
namedSgrs) forall a. [a] -> [a] -> [a]
++
                String
", or \"rgb#RrGgBb\" and \"onRgb#RrGgBb\" where 'Rr', " 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#"   forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s = ConsoleLayer -> String -> Maybe SGR
rgbToSgr ConsoleLayer
Ansi.Foreground forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
4 String
s
    | String
"onRgb#" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s = ConsoleLayer -> String -> Maybe SGR
rgbToSgr ConsoleLayer
Ansi.Background forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
6 String
s
    | Bool
otherwise               = 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 forall b. (Ord b, Floating b) => ReadS (Colour b)
sRGB24reads String
rgbHex of
        [(Colour Float
color, String
"")] -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ConsoleLayer -> Colour Float -> SGR
Ansi.SetRGBColor ConsoleLayer
layer Colour Float
color
        [(Colour Float, String)]
_             -> forall a. Maybe a
Nothing


--------------------------------------------------------------------------------
sgrToString :: Ansi.SGR -> Maybe String
sgrToString :: SGR -> Maybe String
sgrToString (Ansi.SetColor ConsoleLayer
layer ColorIntensity
intensity Color
color) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
    (\String
str -> case ConsoleLayer
layer of
        ConsoleLayer
Ansi.Foreground -> String
str
        ConsoleLayer
Ansi.Background -> String
"on" forall a. [a] -> [a] -> [a]
++ ShowS
capitalize String
str) forall a b. (a -> b) -> a -> b
$
    (case ColorIntensity
intensity of
        ColorIntensity
Ansi.Dull  -> String
"dull"
        ColorIntensity
Ansi.Vivid -> String
"vivid") 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")

sgrToString (Ansi.SetUnderlining Underlining
Ansi.SingleUnderline) = forall a. a -> Maybe a
Just String
"underline"

sgrToString (Ansi.SetConsoleIntensity ConsoleIntensity
Ansi.BoldIntensity) = forall a. a -> Maybe a
Just String
"bold"

sgrToString (Ansi.SetItalicized Bool
True) = forall a. a -> Maybe a
Just String
"italic"

sgrToString (Ansi.SetRGBColor ConsoleLayer
layer Colour Float
color) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
    (\String
str -> case ConsoleLayer
layer of
        ConsoleLayer
Ansi.Foreground -> String
str
        ConsoleLayer
Ansi.Background -> String
"on" forall a. [a] -> [a] -> [a]
++ ShowS
capitalize String
str) forall a b. (a -> b) -> a -> b
$
    String
"rgb#" forall a. [a] -> [a] -> [a]
++ (forall {a}. (Integral a, Show a) => RGB a -> String
toRGBHex forall a b. (a -> b) -> a -> b
$ forall b. (RealFrac b, Floating b) => Colour b -> RGB Word8
toSRGB24 Colour Float
color)
  where
    toRGBHex :: RGB a -> String
toRGBHex (RGB a
r a
g a
b) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a}. (Integral a, Show a) => a -> String
toHexByte [a
r, a
g, a
b]
    toHexByte :: a -> String
toHexByte a
x = forall {a}. (Integral a, Show a) => a -> ShowS
showHex2 a
x String
""
    showHex2 :: a -> ShowS
showHex2 a
x | a
x forall a. Ord a => a -> a -> Bool
<= a
0xf = (String
"0" forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. (Integral a, Show a) => a -> ShowS
showHex a
x
               | Bool
otherwise = forall {a}. (Integral a, Show a) => a -> ShowS
showHex a
x

sgrToString SGR
_ = forall a. Maybe a
Nothing


--------------------------------------------------------------------------------
namedSgrs :: M.Map String Ansi.SGR
namedSgrs :: Map String SGR
namedSgrs = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
    [ (String
name, SGR
sgr)
    | SGR
sgr  <- [SGR]
knownSgrs
    , String
name <- 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 <- [forall a. Bounded a => a
minBound .. forall a. Bounded a => a
maxBound]
        , ColorIntensity
i <- [forall a. Bounded a => a
minBound .. forall a. Bounded a => a
maxBound]
        , Color
c <- [forall a. Bounded a => a
minBound .. forall a. Bounded a => a
maxBound]
        ] forall a. [a] -> [a] -> [a]
++
        [Underlining -> SGR
Ansi.SetUnderlining      Underlining
u | Underlining
u <- [forall a. Bounded a => a
minBound .. forall a. Bounded a => a
maxBound]] forall a. [a] -> [a] -> [a]
++
        [ConsoleIntensity -> SGR
Ansi.SetConsoleIntensity ConsoleIntensity
c | ConsoleIntensity
c <- [forall a. Bounded a => a
minBound .. forall a. Bounded a => a
maxBound]] forall a. [a] -> [a] -> [a]
++
        [Bool -> SGR
Ansi.SetItalicized       Bool
i | Bool
i <- [forall a. Bounded a => a
minBound .. forall a. Bounded a => a
maxBound]]


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


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


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

    dropTok :: String -> String
    dropTok :: ShowS
dropTok String
str
        | String
"Tok" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
str = forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str 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 = forall a. Read a => String -> Maybe a
readMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
capitalize forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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 forall a. a -> [a] -> [a]
: String
xs


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


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