From 870e921a8e95a70a7220233aebf956b30166f998 Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Fri, 3 Feb 2023 00:37:13 -0800 Subject: [PATCH] Add HtmlMod --- .../src/Commonmark/Extensions/Emoji.hs | 4 + .../src/Commonmark/Extensions/Footnote.hs | 6 + .../src/Commonmark/Extensions/PipeTable.hs | 9 ++ .../Commonmark/Extensions/Strikethrough.hs | 4 + .../src/Commonmark/Extensions/TaskList.hs | 7 + commonmark/commonmark.cabal | 1 + commonmark/src/Commonmark/HtmlMod.hs | 150 ++++++++++++++++++ 7 files changed, 181 insertions(+) create mode 100644 commonmark/src/Commonmark/HtmlMod.hs diff --git a/commonmark-extensions/src/Commonmark/Extensions/Emoji.hs b/commonmark-extensions/src/Commonmark/Extensions/Emoji.hs index 00c9080a..dad2f480 100644 --- a/commonmark-extensions/src/Commonmark/Extensions/Emoji.hs +++ b/commonmark-extensions/src/Commonmark/Extensions/Emoji.hs @@ -11,6 +11,7 @@ import Commonmark.Inlines import Commonmark.SourceMap import Commonmark.TokParsers import Commonmark.Html +import Commonmark.HtmlMod import Text.Emoji (emojiFromAlias) import Text.Parsec import Data.Text (Text) @@ -31,6 +32,9 @@ instance HasEmoji (Html a) where addAttribute ("data-emoji", kw) $ htmlInline "span" $ Just $ htmlText t +instance HasEmoji (HtmlMod a) where + emoji kw t = HtmlMod $ pure $ emoji kw t + instance (HasEmoji i, Monoid i) => HasEmoji (WithSourceMap i) where emoji kw t = emoji kw t <$ addName "emoji" diff --git a/commonmark-extensions/src/Commonmark/Extensions/Footnote.hs b/commonmark-extensions/src/Commonmark/Extensions/Footnote.hs index da35c7e3..b055996a 100644 --- a/commonmark-extensions/src/Commonmark/Extensions/Footnote.hs +++ b/commonmark-extensions/src/Commonmark/Extensions/Footnote.hs @@ -12,6 +12,7 @@ where import Commonmark.Tokens import Commonmark.Types import Commonmark.Html +import Commonmark.HtmlMod import Commonmark.Syntax import Commonmark.Blocks import Commonmark.Inlines @@ -164,6 +165,11 @@ instance Rangeable (Html a) => HasFootnote (Html a) (Html a) where addAttribute ("id", "fnref-" <> lab) $ htmlInline "a" $ Just (htmlText x) +instance Rangeable (Html a) => HasFootnote (HtmlMod a) (HtmlMod a) where + footnote num lab' bl = withHtmlMod $ \mods -> footnote num lab' (runHtmlMod mods bl) + footnoteList bls = withHtmlMod $ \mods -> footnoteList (map (runHtmlMod mods) bls) + footnoteRef num lab' bl = withHtmlMod $ \mods -> footnoteRef num lab' (runHtmlMod mods bl) + instance (HasFootnote il bl, Semigroup bl, Semigroup il) => HasFootnote (WithSourceMap il) (WithSourceMap bl) where footnote num lab' x = (footnote num lab' <$> x) <* addName "footnote" diff --git a/commonmark-extensions/src/Commonmark/Extensions/PipeTable.hs b/commonmark-extensions/src/Commonmark/Extensions/PipeTable.hs index d9cae8d2..c116aae3 100644 --- a/commonmark-extensions/src/Commonmark/Extensions/PipeTable.hs +++ b/commonmark-extensions/src/Commonmark/Extensions/PipeTable.hs @@ -20,6 +20,7 @@ import Commonmark.TokParsers import Commonmark.Blocks import Commonmark.SourceMap import Commonmark.Html +import Commonmark.HtmlMod import Text.Parsec import Data.Dynamic import Data.Tree @@ -66,6 +67,14 @@ instance HasPipeTable (Html a) (Html a) where (alignToAttr align $ htmlInline constructor $ Just cell) <> htmlRaw "\n" +instance HasPipeTable (HtmlMod a) (HtmlMod a) where + pipeTable cols headers rows = + withHtmlMod $ \mods -> + pipeTable + cols + (map (runHtmlMod mods) headers) + (map (map (runHtmlMod mods)) rows) + instance (HasPipeTable i b, Monoid b) => HasPipeTable (WithSourceMap i) (WithSourceMap b) where pipeTable aligns headerCells rows = do diff --git a/commonmark-extensions/src/Commonmark/Extensions/Strikethrough.hs b/commonmark-extensions/src/Commonmark/Extensions/Strikethrough.hs index b9e74841..846f2bc7 100644 --- a/commonmark-extensions/src/Commonmark/Extensions/Strikethrough.hs +++ b/commonmark-extensions/src/Commonmark/Extensions/Strikethrough.hs @@ -9,6 +9,7 @@ import Commonmark.Syntax import Commonmark.Inlines import Commonmark.SourceMap import Commonmark.Html +import Commonmark.HtmlMod strikethroughSpec :: (Monad m, IsBlock il bl, IsInline il, HasStrikethrough il) => SyntaxSpec m il bl @@ -24,6 +25,9 @@ class HasStrikethrough a where instance HasStrikethrough (Html a) where strikethrough x = htmlInline "del" (Just x) +instance HasStrikethrough (HtmlMod a) where + strikethrough a = withHtmlMod $ \mods -> strikethrough (runHtmlMod mods a) + instance (HasStrikethrough i, Monoid i) => HasStrikethrough (WithSourceMap i) where strikethrough x = (strikethrough <$> x) <* addName "strikethrough" diff --git a/commonmark-extensions/src/Commonmark/Extensions/TaskList.hs b/commonmark-extensions/src/Commonmark/Extensions/TaskList.hs index c011cee7..ecc09e64 100644 --- a/commonmark-extensions/src/Commonmark/Extensions/TaskList.hs +++ b/commonmark-extensions/src/Commonmark/Extensions/TaskList.hs @@ -17,6 +17,7 @@ import Commonmark.Blocks import Commonmark.SourceMap import Commonmark.TokParsers import Commonmark.Html +import Commonmark.HtmlMod import Control.Monad (mzero) import Control.Monad (when, guard) import Data.List (sort) @@ -222,6 +223,12 @@ addCheckbox (checked, x) = (if checked then addAttribute ("checked","") else id) $ htmlInline "input" Nothing) <> x +instance Rangeable (Html a) => HasTaskList (HtmlMod a) (HtmlMod a) where + taskList lType lSpacing items = + withHtmlMod $ \mods -> + taskList lType lSpacing $ + map (fmap (runHtmlMod mods)) items + instance (HasTaskList il bl, Semigroup bl, Semigroup il) => HasTaskList (WithSourceMap il) (WithSourceMap bl) where taskList lt spacing items = diff --git a/commonmark/commonmark.cabal b/commonmark/commonmark.cabal index 95a0df8a..a81aea9e 100644 --- a/commonmark/commonmark.cabal +++ b/commonmark/commonmark.cabal @@ -67,6 +67,7 @@ library Commonmark.Parser Commonmark.Types Commonmark.Html + Commonmark.HtmlMod Commonmark.Syntax Commonmark.ReferenceMap Commonmark.Tokens diff --git a/commonmark/src/Commonmark/HtmlMod.hs b/commonmark/src/Commonmark/HtmlMod.hs new file mode 100644 index 00000000..3e9c44b3 --- /dev/null +++ b/commonmark/src/Commonmark/HtmlMod.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +module Commonmark.HtmlMod + ( HtmlMod (..) + , runHtmlMod + , HtmlModifiers (..) + -- * Helpers for defining instances + , withHtmlMod + ) +where +import Commonmark.Html +import Commonmark.Types +import Control.Monad.Trans.Reader (Reader, ReaderT (..), asks, runReader) +import Data.Text (Text) + +-- | A type for modifying HTML rendering. +-- +-- Usage: +-- +-- > -- change strong elements from "" to "" +-- > let mods = mempty{onStrong = \_ -> htmlInline "b" . Just} +-- > runHtmlMod mods <$> commonmark fp text +newtype HtmlMod a = HtmlMod + { unHtmlMod :: Reader (HtmlModifiers a) (Html a) + } + +runHtmlMod :: HtmlModifiers a -> HtmlMod a -> Html a +runHtmlMod mods = (`runReader` mods) . unHtmlMod + +instance Show (HtmlMod a) where + show = show . runHtmlMod mempty + +instance Semigroup (HtmlMod a) where + HtmlMod mod1 <> HtmlMod mod2 = + HtmlMod . ReaderT $ \r -> + pure $ runReader mod1 r <> runReader mod2 r + +instance Monoid (HtmlMod a) where + mempty = HtmlMod $ pure mempty + +instance Rangeable (Html a) => Rangeable (HtmlMod a) where + ranged range a = withHtmlMod $ \mods -> ranged range (runHtmlMod mods a) + +instance HasAttributes (HtmlMod a) where + addAttributes attrs a = withHtmlMod $ \mods -> addAttributes attrs (runHtmlMod mods a) + +instance ToPlainText (HtmlMod a) where + toPlainText a = toPlainText $ runHtmlMod mempty a + +instance Rangeable (Html a) => IsInline (HtmlMod a) where + lineBreak = withHtmlMod $ \mods -> onLineBreak mods lineBreak + softBreak = withHtmlMod $ \mods -> onSoftBreak mods softBreak + str t = withHtmlMod $ \mods -> onStr mods str t + entity t = withHtmlMod $ \mods -> onEntity mods entity t + escapedChar c = withHtmlMod $ \mods -> onEscapedChar mods escapedChar c + emph a = withHtmlMod $ \mods -> onEmph mods emph (runHtmlMod mods a) + strong a = withHtmlMod $ \mods -> onStrong mods strong (runHtmlMod mods a) + link dest title a = withHtmlMod $ \mods -> onLink mods link dest title (runHtmlMod mods a) + image src title a = withHtmlMod $ \mods -> onImage mods image src title (runHtmlMod mods a) + code t = withHtmlMod $ \mods -> onCode mods code t + rawInline fmt t = withHtmlMod $ \mods -> onRawInline mods rawInline fmt t + +instance Rangeable (Html a) => IsBlock (HtmlMod a) (HtmlMod a) where + paragraph il = withHtmlMod $ \mods -> onParagraph mods paragraph (runHtmlMod mods il) + plain il = withHtmlMod $ \mods -> onPlain mods plain (runHtmlMod mods il) + thematicBreak = withHtmlMod $ \mods -> onThematicBreak mods thematicBreak + blockQuote b = withHtmlMod $ \mods -> onBlockQuote mods blockQuote (runHtmlMod mods b) + codeBlock info t = withHtmlMod $ \mods -> onCodeBlock mods codeBlock info t + heading level il = withHtmlMod $ \mods -> onHeading mods heading level (runHtmlMod mods il) + rawBlock fmt t = withHtmlMod $ \mods -> onRawBlock mods rawBlock fmt t + referenceLinkDefinition label dest = withHtmlMod $ \mods -> onReferenceLinkDefinition mods referenceLinkDefinition label dest + list lType lSpacing items = withHtmlMod $ \mods -> onList mods list lType lSpacing (map (runHtmlMod mods) items) + +withHtmlMod :: (HtmlModifiers a -> Html a) -> HtmlMod a +withHtmlMod f = HtmlMod $ asks f + +data HtmlModifiers a = HtmlModifiers + { onLineBreak :: Html a -> Html a + , onSoftBreak :: Html a -> Html a + , onStr :: (Text -> Html a) -> (Text -> Html a) + , onEntity :: (Text -> Html a) -> (Text -> Html a) + , onEscapedChar :: (Char -> Html a) -> (Char -> Html a) + , onEmph :: (Html a -> Html a) -> (Html a -> Html a) + , onStrong :: (Html a -> Html a) -> (Html a -> Html a) + , onLink :: (Text -> Text -> Html a -> Html a) -> (Text -> Text -> Html a -> Html a) + , onImage :: (Text -> Text -> Html a -> Html a) -> (Text -> Text -> Html a -> Html a) + , onCode :: (Text -> Html a) -> (Text -> Html a) + , onRawInline :: (Format -> Text -> Html a) -> (Format -> Text -> Html a) + , onParagraph :: (Html a -> Html a) -> (Html a -> Html a) + , onPlain :: (Html a -> Html a) -> (Html a -> Html a) + , onThematicBreak :: Html a -> Html a + , onBlockQuote :: (Html a -> Html a) -> (Html a -> Html a) + , onCodeBlock :: (Text -> Text -> Html a) -> (Text -> Text -> Html a) + , onHeading :: (Int -> Html a -> Html a) -> (Int -> Html a -> Html a) + , onRawBlock :: (Format -> Text -> Html a) -> (Format -> Text -> Html a) + , onReferenceLinkDefinition :: (Text -> (Text, Text) -> Html a) -> (Text -> (Text, Text) -> Html a) + , onList :: (ListType -> ListSpacing -> [Html a] -> Html a) -> (ListType -> ListSpacing -> [Html a] -> Html a) + } + +instance Semigroup (HtmlModifiers a) where + mod1 <> mod2 = + HtmlModifiers + { onLineBreak = onLineBreak mod1 . onLineBreak mod2 + , onSoftBreak = onSoftBreak mod1 . onSoftBreak mod2 + , onStr = onStr mod1 . onStr mod2 + , onEntity = onEntity mod1 . onEntity mod2 + , onEscapedChar = onEscapedChar mod1 . onEscapedChar mod2 + , onEmph = onEmph mod1 . onEmph mod2 + , onStrong = onStrong mod1 . onStrong mod2 + , onLink = onLink mod1 . onLink mod2 + , onImage = onImage mod1 . onImage mod2 + , onCode = onCode mod1 . onCode mod2 + , onRawInline = onRawInline mod1 . onRawInline mod2 + , onParagraph = onParagraph mod1 . onParagraph mod2 + , onPlain = onPlain mod1 . onPlain mod2 + , onThematicBreak = onThematicBreak mod1 . onThematicBreak mod2 + , onBlockQuote = onBlockQuote mod1 . onBlockQuote mod2 + , onCodeBlock = onCodeBlock mod1 . onCodeBlock mod2 + , onHeading = onHeading mod1 . onHeading mod2 + , onRawBlock = onRawBlock mod1 . onRawBlock mod2 + , onReferenceLinkDefinition = onReferenceLinkDefinition mod1 . onReferenceLinkDefinition mod2 + , onList = onList mod1 . onList mod2 + } + +instance Monoid (HtmlModifiers a) where + mempty = + HtmlModifiers + { onLineBreak = id + , onSoftBreak = id + , onStr = id + , onEntity = id + , onEscapedChar = id + , onEmph = id + , onStrong = id + , onLink = id + , onImage = id + , onCode = id + , onRawInline = id + , onParagraph = id + , onPlain = id + , onThematicBreak = id + , onBlockQuote = id + , onCodeBlock = id + , onHeading = id + , onRawBlock = id + , onReferenceLinkDefinition = id + , onList = id + } +