patat-0.15.2.0: lib/Patat/Theme.hs
--------------------------------------------------------------------------------
{-# 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 {unStyle :: [Ansi.SGR]}
deriving (Eq, Monoid, Semigroup, Show)
--------------------------------------------------------------------------------
instance A.ToJSON Style where
toJSON = A.toJSON . mapMaybe sgrToString . unStyle
--------------------------------------------------------------------------------
instance A.FromJSON Style where
parseJSON val = do
names <- A.parseJSON val
sgrs <- mapM toSgr names
return $! Style sgrs
where
toSgr name = case stringToSgr name of
Just sgr -> return sgr
Nothing -> fail $!
"Unknown style: " ++ show name ++ ". Known styles are: " ++
intercalate ", " (map show $ M.keys namedSgrs) ++
", or \"rgb#RrGgBb\" and \"onRgb#RrGgBb\" where 'Rr', " ++
"'Gg' and 'Bb' are hexadecimal bytes (e.g. \"rgb#f08000\")."
--------------------------------------------------------------------------------
stringToSgr :: String -> Maybe Ansi.SGR
stringToSgr s
| "rgb#" `isPrefixOf` s = rgbToSgr Ansi.Foreground $ drop 4 s
| "onRgb#" `isPrefixOf` s = rgbToSgr Ansi.Background $ drop 6 s
| otherwise = M.lookup s namedSgrs
--------------------------------------------------------------------------------
rgbToSgr :: Ansi.ConsoleLayer -> String -> Maybe Ansi.SGR
rgbToSgr layer rgbHex =
case sRGB24reads rgbHex of
[(color, "")] -> Just $ Ansi.SetRGBColor layer color
_ -> Nothing
--------------------------------------------------------------------------------
sgrToString :: Ansi.SGR -> Maybe String
sgrToString sgr = case sgr of
Ansi.SetColor layer intensity color -> Just $ layerPrefix layer $
(case intensity of
Ansi.Dull -> "dull"
Ansi.Vivid -> "vivid") ++
(case color of
Ansi.Black -> "Black"
Ansi.Red -> "Red"
Ansi.Green -> "Green"
Ansi.Yellow -> "Yellow"
Ansi.Blue -> "Blue"
Ansi.Magenta -> "Magenta"
Ansi.Cyan -> "Cyan"
Ansi.White -> "White")
Ansi.SetUnderlining Ansi.SingleUnderline -> Just "underline"
Ansi.SetConsoleIntensity Ansi.BoldIntensity -> Just "bold"
Ansi.SetItalicized True -> Just "italic"
Ansi.SetRGBColor layer color -> Just $ layerPrefix layer $
"rgb#" ++ (toRGBHex $ toSRGB24 color)
_ -> Nothing
where
toRGBHex (RGB r g b) = concat $ map toHexByte [r, g, b]
toHexByte x = showHex2 x ""
showHex2 x | x <= 0xf = ("0" ++) . showHex x
| otherwise = showHex x
layerPrefix layer str = case layer of
Ansi.Foreground -> str
Ansi.Background -> "on" ++ capitalize str
Ansi.Underlining -> "underline" ++ capitalize str
--------------------------------------------------------------------------------
nameForTokenType :: Skylighting.TokenType -> String
nameForTokenType =
unCapitalize . dropTok . show
where
unCapitalize (x : xs) = toLower x : xs
unCapitalize xs = xs
dropTok :: String -> String
dropTok str
| "Tok" `isSuffixOf` str = take (length str - 3) str
| otherwise = str
--------------------------------------------------------------------------------
nameToTokenType :: String -> Maybe Skylighting.TokenType
nameToTokenType = readMaybe . capitalize . (++ "Tok")
--------------------------------------------------------------------------------
capitalize :: String -> String
capitalize "" = ""
capitalize (x : xs) = toUpper x : xs
--------------------------------------------------------------------------------
namedSgrs :: M.Map String Ansi.SGR
namedSgrs = M.fromList
[ (name, sgr)
| sgr <- knownSgrs
, name <- maybeToList (sgrToString sgr)
]
where
-- It doesn't really matter if we generate "too much" SGRs here since
-- 'sgrToString' will only pick the ones we support.
knownSgrs =
[ Ansi.SetColor l i c
| l <- [minBound .. maxBound]
, i <- [minBound .. maxBound]
, c <- [minBound .. maxBound]
] ++
[Ansi.SetUnderlining u | u <- [minBound .. maxBound]] ++
[Ansi.SetConsoleIntensity c | c <- [minBound .. maxBound]] ++
[Ansi.SetItalicized i | i <- [minBound .. maxBound]]
--------------------------------------------------------------------------------
data HeaderAlign = LeftHeaderAlign | CenterHeaderAlign
deriving (Eq, Show)
--------------------------------------------------------------------------------
instance A.ToJSON HeaderAlign where
toJSON LeftHeaderAlign = "left"
toJSON CenterHeaderAlign = "center"
--------------------------------------------------------------------------------
instance A.FromJSON HeaderAlign where
parseJSON = A.withText "FromJSON HeaderAlign" $ \txt -> case txt of
"left" -> pure LeftHeaderAlign
"center" -> pure CenterHeaderAlign
_ -> fail $ "Unknown align: " ++ show txt
--------------------------------------------------------------------------------
data HeaderTheme = HeaderTheme
{ htStyle :: !(Maybe Style)
, htPrefix :: !(Maybe T.Text)
, htUnderline :: !(Maybe T.Text)
, htAlign :: !(Maybe HeaderAlign)
} deriving (Eq, Show)
--------------------------------------------------------------------------------
$(A.deriveJSON A.dropPrefixOptions ''HeaderTheme)
--------------------------------------------------------------------------------
instance Semigroup HeaderTheme where
l <> r = HeaderTheme
{ htStyle = htStyle l `mplus` htStyle r
, htPrefix = htPrefix l `mplus` htPrefix r
, htUnderline = htUnderline l `mplus` htUnderline r
, htAlign = htAlign l `mplus` htAlign r
}
--------------------------------------------------------------------------------
newtype HeaderThemes = HeaderThemes (M.Map String HeaderTheme)
deriving (Eq, Show, A.FromJSON, A.ToJSON)
--------------------------------------------------------------------------------
instance Semigroup HeaderThemes where
HeaderThemes l <> HeaderThemes r = HeaderThemes $ M.unionWith (<>) l r
--------------------------------------------------------------------------------
data Theme = Theme
{ themeBorders :: !(Maybe Style)
, themeHeader :: !(Maybe Style)
, themeHeaders :: !(Maybe HeaderThemes)
, themeCodeBlock :: !(Maybe Style)
, themeBulletList :: !(Maybe Style)
, themeBulletListMarkers :: !(Maybe T.Text)
, themeOrderedList :: !(Maybe Style)
, themeBlockQuote :: !(Maybe Style)
, themeDefinitionTerm :: !(Maybe Style)
, themeDefinitionList :: !(Maybe Style)
, themeTableHeader :: !(Maybe Style)
, themeTableSeparator :: !(Maybe Style)
, themeLineBlock :: !(Maybe Style)
, themeEmph :: !(Maybe Style)
, themeStrong :: !(Maybe Style)
, themeUnderline :: !(Maybe Style)
, themeCode :: !(Maybe Style)
, themeLinkText :: !(Maybe Style)
, themeLinkTarget :: !(Maybe Style)
, themeStrikeout :: !(Maybe Style)
, themeQuoted :: !(Maybe Style)
, themeMath :: !(Maybe Style)
, themeImageText :: !(Maybe Style)
, themeImageTarget :: !(Maybe Style)
, themeSyntaxHighlighting :: !(Maybe SyntaxHighlighting)
} deriving (Eq, Show)
--------------------------------------------------------------------------------
instance Semigroup Theme where
l <> r = Theme
{ themeBorders = mplusOn themeBorders
, themeHeader = mplusOn themeHeader
, themeHeaders = mappendOn themeHeaders
, themeCodeBlock = mplusOn themeCodeBlock
, themeBulletList = mplusOn themeBulletList
, themeBulletListMarkers = mplusOn themeBulletListMarkers
, themeOrderedList = mplusOn themeOrderedList
, themeBlockQuote = mplusOn themeBlockQuote
, themeDefinitionTerm = mplusOn themeDefinitionTerm
, themeDefinitionList = mplusOn themeDefinitionList
, themeTableHeader = mplusOn themeTableHeader
, themeTableSeparator = mplusOn themeTableSeparator
, themeLineBlock = mplusOn themeLineBlock
, themeEmph = mplusOn themeEmph
, themeStrong = mplusOn themeStrong
, themeUnderline = mplusOn themeUnderline
, themeCode = mplusOn themeCode
, themeLinkText = mplusOn themeLinkText
, themeLinkTarget = mplusOn themeLinkTarget
, themeStrikeout = mplusOn themeStrikeout
, themeQuoted = mplusOn themeQuoted
, themeMath = mplusOn themeMath
, themeImageText = mplusOn themeImageText
, themeImageTarget = mplusOn themeImageTarget
, themeSyntaxHighlighting = mappendOn themeSyntaxHighlighting
}
where
mplusOn f = f l `mplus` f r
mappendOn f = f l `mappend` f r
--------------------------------------------------------------------------------
instance Monoid Theme where
mappend = (<>)
mempty = Theme
Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
Nothing Nothing Nothing Nothing Nothing Nothing Nothing
--------------------------------------------------------------------------------
defaultTheme :: Theme
defaultTheme = Theme
{ themeBorders = dull Ansi.Yellow
, themeHeader = dull Ansi.Blue
, themeHeaders = Just $ HeaderThemes $ M.fromList $ do
n <- [1 .. 6]
let prefix = T.replicate n "#" <> " "
pure ("h" <> show n, HeaderTheme Nothing (Just prefix) Nothing Nothing)
, themeCodeBlock = dull Ansi.White `mappend` ondull Ansi.Black
, themeBulletList = dull Ansi.Magenta
, themeBulletListMarkers = Just "-*"
, themeOrderedList = dull Ansi.Magenta
, themeBlockQuote = dull Ansi.Green
, themeDefinitionTerm = dull Ansi.Blue
, themeDefinitionList = dull Ansi.Magenta
, themeTableHeader = dull Ansi.Magenta `mappend` bold
, themeTableSeparator = dull Ansi.Magenta
, themeLineBlock = dull Ansi.Magenta
, themeEmph = dull Ansi.Green
, themeStrong = dull Ansi.Red `mappend` bold
, themeUnderline = dull Ansi.Red `mappend` underline
, themeCode = dull Ansi.White `mappend` ondull Ansi.Black
, themeLinkText = dull Ansi.Green
, themeLinkTarget = dull Ansi.Cyan `mappend` underline
, themeStrikeout = ondull Ansi.Red
, themeQuoted = dull Ansi.Green
, themeMath = dull Ansi.Green
, themeImageText = dull Ansi.Green
, themeImageTarget = dull Ansi.Cyan `mappend` underline
, themeSyntaxHighlighting = Just defaultSyntaxHighlighting
}
where
dull c = Just $ Style [Ansi.SetColor Ansi.Foreground Ansi.Dull c]
ondull c = Just $ Style [Ansi.SetColor Ansi.Background Ansi.Dull c]
bold = Just $ Style [Ansi.SetConsoleIntensity Ansi.BoldIntensity]
underline = Just $ Style [Ansi.SetUnderlining Ansi.SingleUnderline]
--------------------------------------------------------------------------------
themeForHeader :: Int -> Theme -> HeaderTheme
themeForHeader n theme = maybe def (<> def) $ do
HeaderThemes m <- themeHeaders theme
M.lookup ("h" ++ show n) m
where
def = HeaderTheme (themeHeader theme) Nothing Nothing Nothing
--------------------------------------------------------------------------------
newtype SyntaxHighlighting = SyntaxHighlighting
{ unSyntaxHighlighting :: M.Map String Style
} deriving (Eq, Monoid, Semigroup, Show, A.ToJSON)
--------------------------------------------------------------------------------
instance A.FromJSON SyntaxHighlighting where
parseJSON val = do
styleMap <- A.parseJSON val
forM_ (M.keys styleMap) $ \k -> case nameToTokenType k of
Just _ -> return ()
Nothing -> fail $ "Unknown token type: " ++ show k
return (SyntaxHighlighting styleMap)
--------------------------------------------------------------------------------
defaultSyntaxHighlighting :: SyntaxHighlighting
defaultSyntaxHighlighting = mkSyntaxHighlighting
[ (Skylighting.KeywordTok, dull Ansi.Yellow)
, (Skylighting.ControlFlowTok, dull Ansi.Yellow)
, (Skylighting.DataTypeTok, dull Ansi.Green)
, (Skylighting.DecValTok, dull Ansi.Red)
, (Skylighting.BaseNTok, dull Ansi.Red)
, (Skylighting.FloatTok, dull Ansi.Red)
, (Skylighting.ConstantTok, dull Ansi.Red)
, (Skylighting.CharTok, dull Ansi.Red)
, (Skylighting.SpecialCharTok, dull Ansi.Red)
, (Skylighting.StringTok, dull Ansi.Red)
, (Skylighting.VerbatimStringTok, dull Ansi.Red)
, (Skylighting.SpecialStringTok, dull Ansi.Red)
, (Skylighting.CommentTok, dull Ansi.Blue)
, (Skylighting.DocumentationTok, dull Ansi.Blue)
, (Skylighting.AnnotationTok, dull Ansi.Blue)
, (Skylighting.CommentVarTok, dull Ansi.Blue)
, (Skylighting.ImportTok, dull Ansi.Cyan)
, (Skylighting.OperatorTok, dull Ansi.Cyan)
, (Skylighting.FunctionTok, dull Ansi.Cyan)
, (Skylighting.PreprocessorTok, dull Ansi.Cyan)
]
where
dull c = Style [Ansi.SetColor Ansi.Foreground Ansi.Dull c]
mkSyntaxHighlighting ls = SyntaxHighlighting $
M.fromList [(nameForTokenType tt, s) | (tt, s) <- ls]
--------------------------------------------------------------------------------
syntaxHighlight :: Theme -> Skylighting.TokenType -> Maybe Style
syntaxHighlight theme tokenType = do
sh <- themeSyntaxHighlighting theme
M.lookup (nameForTokenType tokenType) (unSyntaxHighlighting sh)
--------------------------------------------------------------------------------
$(A.deriveJSON A.dropPrefixOptions ''Theme)