--------------------------------------------------------------------------------
{-# 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
(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
        , 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 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 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
    , 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]


--------------------------------------------------------------------------------
newtype Style = Style {Style -> [SGR]
unStyle :: [Ansi.SGR]}
    deriving (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
        [String]
names <- Value -> Parser [String]
forall a. FromJSON a => Value -> Parser a
A.parseJSON Value
val
        [SGR]
sgrs  <- (String -> Parser SGR) -> [String] -> Parser [SGR]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> Parser SGR
forall {m :: * -> *}. MonadFail m => String -> m SGR
toSgr [String]
names
        Style -> Parser Style
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Style -> Parser Style) -> Style -> Parser Style
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 -> 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 (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
$
    (\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) 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")

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

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

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

sgrToString (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
$
    (\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) 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)
  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

sgrToString SGR
_ = Maybe String
forall a. Maybe a
Nothing


--------------------------------------------------------------------------------
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]]


--------------------------------------------------------------------------------
newtype SyntaxHighlighting = SyntaxHighlighting
    { SyntaxHighlighting -> Map String Style
unSyntaxHighlighting :: M.Map String Style
    } deriving (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] -> Value
[SyntaxHighlighting] -> Encoding
SyntaxHighlighting -> Bool
SyntaxHighlighting -> Value
SyntaxHighlighting -> Encoding
(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
        Map String Style
styleMap <- Value -> Parser (Map String Style)
forall a. FromJSON a => Value -> Parser a
A.parseJSON Value
val
        [String] -> (String -> Parser ()) -> Parser ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map String Style -> [String]
forall k a. Map k a -> [k]
M.keys Map String Style
styleMap) ((String -> Parser ()) -> Parser ())
-> (String -> Parser ()) -> Parser ()
forall a b. (a -> b) -> a -> b
$ \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
        SyntaxHighlighting -> Parser SyntaxHighlighting
forall a. a -> Parser a
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 (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]


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


--------------------------------------------------------------------------------
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
    String -> Map String Style -> Maybe Style
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)