patat 0.15.1.0 → 0.15.2.0

raw patch · 11 files changed

+330/−172 lines, 11 filesdep +case-insensitivedep ~QuickCheckdep ~containersdep ~hashablePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: case-insensitive

Dependency ranges changed: QuickCheck, containers, hashable, pandoc, random

API changes (from Hackage documentation)

Files

• CHANGELOG.md +23/−0
• README.md +18/−0
• lib/Patat/Eval.hs +8/−6
• lib/Patat/Eval/Internal.hs +7/−9
• lib/Patat/Presentation/Display.hs +46/−18
• lib/Patat/Presentation/Display/CodeBlock.hs +8/−4
• lib/Patat/Presentation/Internal.hs +1/−1
• lib/Patat/Presentation/Settings.hs +15/−4
• lib/Patat/Presentation/Syntax.hs +5/−2
• lib/Patat/Theme.hs +197/−127
• patat.cabal +2/−1

@@ -1,5 +1,28 @@ # Changelog +## 0.15.2.0 (2025-08-06)++ *  Fix case-insensitivity of class names for `eval` code blocks (#192).+    Class names are case-insensitive (like in HTML), but we were treating them+    as case-sensitive.++ *  Under `theme:`, individual headers can now also be customized (#162).++    The configuration blocks under `headers` accepts a `style` list, a `prefix`+    string and an `underline` string that is repeated match the width of the+    header. `align: center` can be used to horizontally center the header.++    ```yaml+    patat:+      theme:+        headers:+          h3:+            style: [vividRed]+            prefix: '### '+            underline: '-~-~'+            align: center+    ```+ ## 0.15.1.0 (2025-04-26)   *  Add a `syntax` option for `eval` blocks (#187).  This allows you to set

@@ -527,6 +527,24 @@         strong: [underline, underlineVividBlue] ``` +#### Theming headers++In addition to `header`, individual headers can also be customized.  The+configuration blocks under `headers` accepts a `style` list, a `prefix` string+and an `underline` string that is repeated match the width of the header.+`align: center` can be used to horizontally center the header.++```yaml+patat:+  theme:+    headers:+      h3:+        style: [vividRed]+        prefix: '### '+        underline: '-~-~'+        align: center+```+ ### Syntax Highlighting  `patat` uses [Kate] Syntax Highlighting files.  `patat` ships with support for

@@ -16,6 +16,8 @@ import           Control.Monad               (foldM, when) import           Control.Monad.State         (StateT, runStateT, state) import           Control.Monad.Writer        (Writer, runWriter, tell)+import           Data.CaseInsensitive        (CI)+import qualified Data.CaseInsensitive        as CI import           Data.Foldable               (for_) import qualified Data.HashMap.Strict         as HMS import qualified Data.IORef                  as IORef@@ -48,8 +50,8 @@   ---------------------------------------------------------------------------------lookupSettings :: [T.Text] -> EvalSettingsMap -> [EvalSettings]-lookupSettings classes settings = do+lookupSettings :: [CI T.Text] -> EvalSettingsMap -> [EvalSettings]+lookupSettings classes (EvalSettingsMap settings) = do     c <- classes     maybeToList $ HMS.lookup c settings @@ -73,10 +75,10 @@ evalBlock     :: EvalSettingsMap -> Block     -> ExtractEvalM [Block]-evalBlock settings orig@(CodeBlock attr@(_, classes, _) txt)+evalBlock settings orig@(CodeBlock classes txt)     | [s@EvalSettings {..}] <- lookupSettings classes settings = do         var <- Var <$> state freshUnique-        tell $ HMS.singleton var $ EvalBlock s attr txt Nothing+        tell $ HMS.singleton var $ EvalBlock s classes txt Nothing         case (evalReveal, evalReplace) of             (False, True) -> pure [VarBlock var]             (False, False) -> pure [orig, VarBlock var]@@ -98,8 +100,8 @@                     ]     | _ : _ : _ <- lookupSettings classes settings =         let msg = "patat eval matched multiple settings for " <>-                T.intercalate "," classes in-        pure [CodeBlock attr msg]+                T.intercalate "," (map CI.original classes) in+        pure [CodeBlock classes msg] evalBlock _ block =     pure [block] 

@@ -8,12 +8,12 @@   ---------------------------------------------------------------------------------import qualified Control.Concurrent.Async       as Async-import qualified Data.HashMap.Strict            as HMS-import qualified Data.Text                      as T+import qualified Control.Concurrent.Async    as Async+import           Data.CaseInsensitive        (CI)+import qualified Data.HashMap.Strict         as HMS+import qualified Data.Text                   as T import           Patat.Presentation.Settings import           Patat.Presentation.Syntax-import qualified Text.Pandoc                    as Pandoc   --------------------------------------------------------------------------------@@ -24,7 +24,7 @@ -- | Block that needs to be evaluated. data EvalBlock = EvalBlock     { ebSettings :: !EvalSettings-    , ebAttr     :: !Pandoc.Attr+    , ebClasses  :: ![CI T.Text]     , ebInput    :: !T.Text     , ebAsync    :: !(Maybe (Async.Async ()))     }@@ -33,7 +33,7 @@ -------------------------------------------------------------------------------- renderEvalBlock :: EvalBlock -> T.Text -> [Block] renderEvalBlock EvalBlock {..} out = case evalContainer ebSettings of-    EvalContainerCode   -> [CodeBlock ("", classes, []) out]+    EvalContainerCode   -> [CodeBlock classes out]     EvalContainerNone   -> [RawBlock fmt out]     EvalContainerInline -> [Plain [RawInline fmt out]]   where@@ -41,6 +41,4 @@      -- The classes for the new code block are copied from the old one if     -- unspecified, or the syntax specified in the eval settings.-    classes = case evalSyntax ebSettings of-        Nothing        -> let (_, cs, _) = ebAttr in cs-        Just outSyntax -> [outSyntax]+    classes = maybe ebClasses pure $ evalSyntax ebSettings

@@ -29,7 +29,7 @@ import           Patat.Presentation.Settings import qualified Patat.Presentation.SpeakerNotes      as SpeakerNotes import           Patat.Presentation.Syntax-import           Patat.PrettyPrint                    ((<$$>), (<+>))+import           Patat.PrettyPrint                    ((<$$>)) import qualified Patat.PrettyPrint                    as PP import           Patat.Size import           Patat.Theme                          (Theme (..))@@ -191,15 +191,16 @@         refs ->             let doc0        = PP.vcat refs                 size@(r, _) = PP.dimensions doc0 in-            [(horizontalIndent size $ horizontalWrap doc0, r)]+            [(horizontalIndent size gmargins $ horizontalWrap gmargins doc0, r)]   where     Size rows columns = dsSize ds-    Margins {..} = dsMargins ds+    gmargins = dsMargins ds      -- For every block, calculate the size based on its last fragment.     blockSize block =-        let revealState = blocksRevealLastStep [block] in-        PP.dimensions $ deindent $ horizontalWrap $+        let revealState = blocksRevealLastStep [block]+            bmargins    = marginsFor block+        in PP.dimensions $ deindent bmargins $ horizontalWrap bmargins $             prettyBlock ds {dsRevealState = revealState} block      -- Vertically align some blocks by adding spaces in front of it.@@ -208,7 +209,7 @@     vertical :: [(PP.Doc, Int)] -> PP.Doc     vertical docs0 = mconcat (replicate top PP.hardline) <> doc       where-        top = case mTop of+        top = case mTop gmargins of             Auto      -> (rows - actual) `div` 2             NotAuto x -> x @@ -236,13 +237,18 @@                 revealToBlocks (dsRevealState ds) ConcatWrapper reveal in         (PP.vcat fblocks, fst (blockSize b))     horizontal block =-        let size@(r, _) = blockSize block in-        (horizontalIndent size $ horizontalWrap $ prettyBlock ds block, r)+        let size@(r, _) = blockSize block+            bmargins    = marginsFor block in+        ( horizontalIndent size bmargins $ horizontalWrap bmargins $+            prettyBlock ds block+        , r+        ) -    horizontalIndent :: (Int, Int) -> PP.Doc -> PP.Doc-    horizontalIndent (_, dcols) doc0 = PP.indent indentation indentation doc1+    horizontalIndent :: (Int, Int) -> Margins -> PP.Doc -> PP.Doc+    horizontalIndent (_, dcols) dmargins@Margins {..} doc0 =+        PP.indent indentation indentation doc1       where-        doc1 = deindent doc0+        doc1 = deindent dmargins doc0         left = case mLeft of             NotAuto x -> x             Auto      -> case mRight of@@ -251,13 +257,13 @@         indentation = PP.Indentation left mempty      -- Strip leading spaces to horizontally align code blocks etc.-    deindent doc0 = case (mLeft, mRight) of+    deindent Margins {..} doc0 = case (mLeft, mRight) of         (Auto, Auto) -> PP.deindent doc0         _            -> doc0      -- Rearranges lines to fit into the wrap settings.-    horizontalWrap :: PP.Doc -> PP.Doc-    horizontalWrap doc0 = case dsWrap ds of+    horizontalWrap :: Margins -> PP.Doc -> PP.Doc+    horizontalWrap Margins {..} doc0 = case dsWrap ds of         NoWrap     -> doc0         AutoWrap   -> PP.wrapAt (Just $ columns - right - left) doc0         WrapAt col -> PP.wrapAt (Just col) doc0@@ -269,7 +275,16 @@             Auto      -> 0             NotAuto x -> x +    -- Find the right margins for the specific block.  Currently, only headers+    -- can have different margins.+    marginsFor :: Block -> Margins+    marginsFor (Header n _ _) = fromMaybe gmargins $ do+        align <- Theme.htAlign $ Theme.themeForHeader n (dsTheme ds)+        guard $ align == Theme.CenterHeaderAlign+        pure gmargins {mLeft = Auto, mRight = Auto}+    marginsFor _ = gmargins + -------------------------------------------------------------------------------- prettyBlock :: DisplaySettings -> Block -> PP.Doc @@ -278,11 +293,24 @@ prettyBlock ds (Para inlines) =     prettyInlines ds inlines <> PP.hardline -prettyBlock ds (Header i _ inlines) =-    themed ds themeHeader (PP.string (replicate i '#') <+> prettyInlines ds inlines) <>-    PP.hardline+prettyBlock ds (Header n _ inlines) =+    themed ds style content <> PP.hardline <>+    (case underline of+        Just t | t /= "" ->+            themed ds style (PP.string $ take cols $ cycle $ T.unpack t) <>+            PP.hardline+        _ -> mempty)+  where+    prefix    = fromMaybe mempty $ Theme.htPrefix headerTheme+    content   = PP.text prefix <> prettyInlines ds inlines+    (_, cols) = PP.dimensions content+    underline = Theme.htUnderline headerTheme -prettyBlock ds (CodeBlock (_, classes, _) txt) =+    headerTheme = Theme.themeForHeader n (dsTheme ds)++    style _ = Theme.htStyle headerTheme++prettyBlock ds (CodeBlock classes txt) =     prettyCodeBlock ds classes txt  prettyBlock ds (BulletList bss) = PP.vcat

@@ -8,6 +8,8 @@   --------------------------------------------------------------------------------+import           Data.CaseInsensitive                (CI)+import qualified Data.CaseInsensitive                as CI import           Data.Char.WCWidth.Extended          (wcstrwidth, wcwidth) import           Data.Maybe                          (mapMaybe) import qualified Data.Text                           as T@@ -20,7 +22,8 @@  -------------------------------------------------------------------------------- highlight-    :: Skylighting.SyntaxMap -> [T.Text] -> T.Text -> [Skylighting.SourceLine]+    :: Skylighting.SyntaxMap -> [CI T.Text] -> T.Text+    -> [Skylighting.SourceLine] highlight extraSyntaxMap classes rawCodeBlock =     case mapMaybe getSyntax classes of         []        -> zeroHighlight rawCodeBlock@@ -29,8 +32,9 @@                 Left  _  -> zeroHighlight rawCodeBlock                 Right sl -> sl   where-    getSyntax :: T.Text -> Maybe Skylighting.Syntax-    getSyntax c = Skylighting.lookupSyntax c syntaxMap+    -- Note that SyntaxMap always uses lowercase keys.+    getSyntax :: CI T.Text -> Maybe Skylighting.Syntax+    getSyntax c = Skylighting.lookupSyntax (T.toLower $ CI.original c) syntaxMap      config :: Skylighting.TokenizerConfig     config = Skylighting.TokenizerConfig@@ -70,7 +74,7 @@   ---------------------------------------------------------------------------------prettyCodeBlock :: DisplaySettings -> [T.Text] -> T.Text -> PP.Doc+prettyCodeBlock :: DisplaySettings -> [CI T.Text] -> T.Text -> PP.Doc prettyCodeBlock ds classes rawCodeBlock =     PP.vcat (map blockified sourceLines) <> PP.hardline   where

@@ -17,7 +17,7 @@      , ImageSettings (..) -    , EvalSettingsMap+    , EvalSettingsMap (..)     , EvalSettings (..)      , Slide (..)

@@ -16,7 +16,7 @@      , ImageSettings (..) -    , EvalSettingsMap+    , EvalSettingsMap (..)     , EvalSettingsContainer (..)     , EvalSettings (..) @@ -35,6 +35,9 @@ import           Control.Monad          (mplus, unless) import qualified Data.Aeson.Extended    as A import qualified Data.Aeson.TH.Extended as A+import           Data.Bifunctor         (first)+import           Data.CaseInsensitive   (CI)+import qualified Data.CaseInsensitive   as CI import qualified Data.Foldable          as Foldable import           Data.Function          (on) import qualified Data.HashMap.Strict    as HMS@@ -227,10 +230,18 @@   ---------------------------------------------------------------------------------type EvalSettingsMap = HMS.HashMap T.Text EvalSettings+newtype EvalSettingsMap = EvalSettingsMap (HMS.HashMap (CI T.Text) EvalSettings)+    deriving (Eq, Show, Semigroup)   --------------------------------------------------------------------------------+instance A.FromJSON EvalSettingsMap where+    parseJSON =+        fmap (EvalSettingsMap . HMS.fromList . map (first CI.mk) . HMS.toList) .+        A.parseJSON+++-------------------------------------------------------------------------------- data EvalSettingsContainer     = EvalContainerCode     | EvalContainerNone@@ -257,7 +268,7 @@     , evalReveal    :: !Bool     , evalContainer :: !EvalSettingsContainer     , evalStderr    :: !Bool-    , evalSyntax    :: !(Maybe T.Text)+    , evalSyntax    :: !(Maybe (CI T.Text))     } deriving (Eq, Show)  @@ -269,7 +280,7 @@         <*> deprecated "fragment" "reveal" True o         <*> deprecated "wrap" "container" EvalContainerCode o         <*> o A..:? "stderr" A..!= True-        <*> o A..:? "syntax"+        <*> (fmap CI.mk <$> o A..:? "syntax")       where         deprecated old new def obj = do             mo <- obj A..:? old

@@ -38,6 +38,8 @@ import           Control.Monad.Identity      (runIdentity) import           Control.Monad.State         (State, execState, modify) import           Control.Monad.Writer        (Writer, execWriter, tell)+import           Data.CaseInsensitive        (CI)+import qualified Data.CaseInsensitive        as CI import           Data.Hashable               (Hashable) import qualified Data.HashSet                as HS import           Data.List                   (foldl')@@ -68,7 +70,7 @@     = Plain ![Inline]     | Para ![Inline]     | LineBlock ![[Inline]]-    | CodeBlock !Pandoc.Attr !T.Text+    | CodeBlock ![CI T.Text] !T.Text     | RawBlock !Pandoc.Format !T.Text     | BlockQuote ![Block]     | OrderedList !Pandoc.ListAttributes ![[Block]]@@ -194,7 +196,8 @@ fromPandocBlock (Pandoc.Para xs) = [Para (fromPandocInlines xs)] fromPandocBlock (Pandoc.LineBlock xs) =     [LineBlock (map fromPandocInlines xs)]-fromPandocBlock (Pandoc.CodeBlock attrs body) = [CodeBlock attrs body]+fromPandocBlock (Pandoc.CodeBlock (_, classes, _) body) =+    [CodeBlock (map CI.mk classes) body] fromPandocBlock (Pandoc.RawBlock fmt body)     -- Parse config blocks.     | fmt == "html"

@@ -3,10 +3,13 @@ {-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE TemplateHaskell            #-} module Patat.Theme-    ( Theme (..)+    ( Style (..)+    , HeaderAlign (..)+    , HeaderTheme (..)+    , HeaderThemes (..)+    , Theme (..)     , defaultTheme--    , Style (..)+    , themeForHeader      , SyntaxHighlighting (..)     , defaultSyntaxHighlighting@@ -32,9 +35,189 @@   --------------------------------------------------------------------------------+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)@@ -65,6 +248,7 @@     l <> r = Theme         { themeBorders            = mplusOn   themeBorders         , themeHeader             = mplusOn   themeHeader+        , themeHeaders            = mappendOn themeHeaders         , themeCodeBlock          = mplusOn   themeCodeBlock         , themeBulletList         = mplusOn   themeBulletList         , themeBulletListMarkers  = mplusOn   themeBulletListMarkers@@ -99,13 +283,17 @@     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 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 "-*"@@ -137,105 +325,12 @@   ---------------------------------------------------------------------------------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------------------------------------------------------------------------------------namedSgrs :: M.Map String Ansi.SGR-namedSgrs = M.fromList-    [ (name, sgr)-    | sgr  <- knownSgrs-    , name <- maybeToList (sgrToString sgr)-    ]+themeForHeader :: Int -> Theme -> HeaderTheme+themeForHeader n theme = maybe def (<> def) $ do+    HeaderThemes m <- themeHeaders theme+    M.lookup ("h" ++ show n) m   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]]+    def = HeaderTheme (themeHeader theme) Nothing Nothing Nothing   --------------------------------------------------------------------------------@@ -287,31 +382,6 @@      mkSyntaxHighlighting ls = SyntaxHighlighting $         M.fromList [(nameForTokenType tt, s) | (tt, s) <- ls]------------------------------------------------------------------------------------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   --------------------------------------------------------------------------------

@@ -1,5 +1,5 @@ Name:          patat-Version:       0.15.1.0+Version:       0.15.2.0 Synopsis:      Terminal-based presentations using Pandoc Description:   Terminal-based presentations using Pandoc. License:       GPL-2@@ -39,6 +39,7 @@     base                 >= 4.9   && < 5,     base64-bytestring    >= 1.0   && < 1.3,     bytestring           >= 0.10  && < 0.13,+    case-insensitive     >= 1.2   && < 1.3,     colour               >= 2.3   && < 2.4,     containers           >= 0.5   && < 0.7,     directory            >= 1.2   && < 1.4,