heist-extra (empty) → 0.1.0.0

raw patch · 13 files changed

+935/−0 lines, 13 filesdep +basedep +data-defaultdep +filepath

Dependencies added: base, data-default, filepath, heist-emanote, map-syntax, mtl, pandoc-types, relude, xmlhtml

Files

• LICENSE +21/−0
• README.md +16/−0
• heist-extra.cabal +96/−0
• src/Heist/Extra.hs +45/−0
• src/Heist/Extra/Splices/List.hs +15/−0
• src/Heist/Extra/Splices/Pandoc.hs +42/−0
• src/Heist/Extra/Splices/Pandoc/Attr.hs +24/−0
• src/Heist/Extra/Splices/Pandoc/Ctx.hs +133/−0
• src/Heist/Extra/Splices/Pandoc/Footnotes.hs +61/−0
• src/Heist/Extra/Splices/Pandoc/Render.hs +291/−0
• src/Heist/Extra/Splices/Pandoc/TaskList.hs +27/−0
• src/Heist/Extra/Splices/Tree.hs +32/−0
• src/Heist/Extra/TemplateState.hs +132/−0

@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2021 Sridhar Ratnakumar++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.

@@ -0,0 +1,16 @@+# heist-extra++Extensions on top of [heist](https://srid.ca/heist-start), that are especially useful for [Ema](https://ema.srid.ca/) apps.++## Getting Started++*tldr: Install Nix, enable Flakes, open in VSCode and run `bin/run`.*++For details, see: https://srid.ca/haskell-template/start++## Examples++| Example                                   | Use cases                                  |+| ----------------------------------------- | ------------------------------------------ |+| https://github.com/EmaApps/timedot-invoice | Template file management                   |+| https://github.com/EmaApps/emanote        | Template file management; Pandoc rendering |

@@ -0,0 +1,96 @@+cabal-version:      2.4+name:               heist-extra+version:            0.1.0.0+license:            MIT+copyright:          2022 Sridhar Ratnakumar+maintainer:         srid@srid.ca+author:             Sridhar Ratnakumar+category:           Web+synopsis:           Extra heist functionality+description:+  Extra heist functionality for template management and Pandoc rendering.++bug-reports:        https://github.com/srid/heist-extra+extra-source-files:+  LICENSE+  README.md++common shared+  ghc-options:+    -Wall -Wincomplete-record-updates -Wincomplete-uni-patterns+    -Wmissing-deriving-strategies -Wunused-foralls -Wunused-foralls+    -fprint-explicit-foralls -fprint-explicit-kinds++  mixins:+    base hiding (Prelude),+    relude (Relude as Prelude, Relude.Container.One),+    relude++  default-extensions:+    NoStarIsType+    BangPatterns+    ConstraintKinds+    DataKinds+    DeriveDataTypeable+    DeriveFoldable+    DeriveFunctor+    DeriveGeneric+    DeriveLift+    DeriveTraversable+    DerivingStrategies+    DerivingVia+    EmptyCase+    EmptyDataDecls+    EmptyDataDeriving+    ExistentialQuantification+    ExplicitForAll+    FlexibleContexts+    FlexibleInstances+    GADTSyntax+    GeneralisedNewtypeDeriving+    ImportQualifiedPost+    KindSignatures+    LambdaCase+    MultiParamTypeClasses+    MultiWayIf+    NumericUnderscores+    OverloadedStrings+    PolyKinds+    PostfixOperators+    RankNTypes+    ScopedTypeVariables+    StandaloneDeriving+    StandaloneKindSignatures+    TupleSections+    TypeApplications+    TypeFamilies+    TypeOperators+    ViewPatterns++  build-depends:+    , base           >=4.13.0.0 && <=4.18.0.0+    , data-default+    , filepath+    , heist-emanote  >=1.2.1+    , map-syntax+    , mtl+    , pandoc-types+    , relude         >=1.0+    , xmlhtml++  hs-source-dirs:     src+  default-language:   Haskell2010++library+  import:          shared+  exposed-modules:+    Heist.Extra+    Heist.Extra.Splices.List+    Heist.Extra.Splices.Pandoc+    Heist.Extra.Splices.Pandoc.Attr+    Heist.Extra.Splices.Pandoc.Ctx+    Heist.Extra.Splices.Pandoc.Footnotes+    Heist.Extra.Splices.Pandoc.Render+    Heist.Extra.Splices.Pandoc.TaskList+    Heist.Extra.Splices.Tree+    Heist.Extra.TemplateState

@@ -0,0 +1,45 @@+module Heist.Extra where++import Data.Text qualified as T+import Heist qualified as H+import Heist.Common qualified as H+import Heist.Internal.Types qualified as HT+import Heist.Interpreted qualified as HI+import Text.XmlHtml qualified as X++-- | Useful for running a splice against an arbitrary node (such as that pulled from pandoc.tpl)+runCustomNode :: X.Node -> H.Splices (HI.Splice Identity) -> HI.Splice Identity+runCustomNode node splices =+  H.localHS (HI.bindSplices splices) $ do+    HI.runNode node <&> \case+      [resNode]+        | X.elementTag resNode == X.elementTag node ->+          -- Get rid of the `node` itself.+          X.elementChildren resNode+      res ->+        res++runCustomTemplate :: HT.Template -> H.Splices (HI.Splice Identity) -> HI.Splice Identity+runCustomTemplate nodes splices =+  H.localHS (HI.bindSplices splices) $ do+    HI.runNodeList nodes++lookupHtmlTemplate :: Monad n => ByteString -> HT.HeistT m n (Maybe HT.Template)+lookupHtmlTemplate name = do+  st <- HT.getHS+  pure $ do+    X.HtmlDocument _ _ nodes <- H.dfDoc . fst <$> H.lookupTemplate name st HT._templateMap+    pure nodes++lookupHtmlTemplateMust :: forall m n. Monad n => ByteString -> HT.HeistT m n HT.Template+lookupHtmlTemplateMust name =+  lookupHtmlTemplate name >>= \case+    Nothing -> do+      st <- HT.getHS+      error $ "heist: " <> decodeUtf8 name <> " not found ... among: " <> T.intercalate ", " (availableTemplates st)+    Just tpl ->+      pure tpl++availableTemplates :: HT.HeistState n -> [Text]+availableTemplates st =+  sort $ H.templateNames st <&> T.intercalate "/" . reverse . fmap (decodeUtf8 @Text)

@@ -0,0 +1,15 @@+module Heist.Extra.Splices.List where++import Data.Map.Syntax ((##))+import Heist qualified as H+import Heist.Interpreted qualified as HI++-- | A splice that applies a non-empty list+listSplice :: [a] -> Text -> (a -> H.Splices (HI.Splice Identity)) -> HI.Splice Identity+listSplice xs childTag childSplice = do+  if null xs+    then pure mempty+    else HI.runChildrenWith $ do+      childTag+        ## (HI.runChildrenWith . childSplice)+          `foldMapM` xs

@@ -0,0 +1,42 @@+module Heist.Extra.Splices.Pandoc (+  RenderCtx (..),+  pandocSplice,+  -- | To delegate rendering of blocks and inlines from a custom splice.+  rpBlock,+  rpInline,+) where++import Heist.Extra.Splices.Pandoc.Ctx (+  RenderCtx (..),+  concatSpliceFunc,+ )+import Heist.Extra.Splices.Pandoc.Footnotes (+  footnoteRefSplice,+  gatherFootnotes,+  renderFootnotesWith,+ )+import Heist.Extra.Splices.Pandoc.Render (+  renderPandocWith,+  rpBlock,+  rpInline,+ )+import Heist.Interpreted qualified as HI+import Text.Pandoc.Definition (Pandoc (..))++-- | A splice to render a Pandoc AST+pandocSplice ::+  RenderCtx ->+  Pandoc ->+  HI.Splice Identity+pandocSplice ctx doc = do+  -- Create a new context to render footnote references+  let footnotes = gatherFootnotes doc+      docCtx =+        ctx+          { inlineSplice = concatSpliceFunc (inlineSplice ctx) (footnoteRefSplice docCtx footnotes)+          }+  -- Render main document+  docNodes <- renderPandocWith docCtx doc+  -- Render footnotes themselves, but without recursing into inner footnotes.+  footnotesNodes <- renderFootnotesWith ctx footnotes+  pure $ docNodes <> footnotesNodes

@@ -0,0 +1,24 @@+module Heist.Extra.Splices.Pandoc.Attr where++import Data.Text qualified as T+import Text.Pandoc.Definition qualified as B++-- | Convert Pandoc attributes to XmlHtml attributes+rpAttr :: B.Attr -> [(Text, Text)]+rpAttr (id', classes, attrs) =+  let cls = T.intercalate " " classes+   in unlessNull id' [("id", id')]+        <> unlessNull cls [("class", cls)]+        <> concat (mapMaybe (\(k, v) -> unlessNull v $ pure [(k, v)]) attrs)+  where+    unlessNull x f =+      if T.null x then mempty else f++-- | Merge two XmlHtml attributes set+concatAttr :: B.Attr -> B.Attr -> B.Attr+concatAttr (id1, cls1, attr1) (id2, cls2, attr2) =+  (pickNonNull id1 id2, cls1 <> cls2, attr1 <> attr2)+  where+    pickNonNull x "" = x+    pickNonNull "" x = x+    pickNonNull _ _ = ""

@@ -0,0 +1,133 @@+{-# LANGUAGE RecordWildCards #-}++module Heist.Extra.Splices.Pandoc.Ctx (+  RenderCtx (..),+  mkRenderCtx,+  emptyRenderCtx,+  rewriteClass,+  ctxSansCustomSplicing,+  concatSpliceFunc,+) where++import Data.Map.Strict qualified as Map+import Data.Text qualified as T+import Heist qualified as H+import Heist.Extra.Splices.Pandoc.Attr (concatAttr)+import Heist.Interpreted qualified as HI+import Text.Pandoc.Builder qualified as B+import Text.XmlHtml qualified as X++{- | The configuration context under which we must render a `Pandoc` document+ using the given Heist template.+-}+data RenderCtx = RenderCtx+  { -- The XML node which contains individual AST rendering definitions+    -- This corresponds to pandoc.tpl+    rootNode :: Maybe X.Node+  , -- Attributes for a given AST node.+    bAttr :: B.Block -> B.Attr+  , iAttr :: B.Inline -> B.Attr+  , -- Class attribute rewrite rules+    classMap :: Map Text Text+  , -- Custom render functions for AST nodes.+    blockSplice :: B.Block -> Maybe (HI.Splice Identity)+  , inlineSplice :: B.Inline -> Maybe (HI.Splice Identity)+  }++mkRenderCtx ::+  (Monad m) =>+  Map Text Text ->+  (RenderCtx -> B.Block -> Maybe (HI.Splice Identity)) ->+  (RenderCtx -> B.Inline -> Maybe (HI.Splice Identity)) ->+  H.HeistT Identity m RenderCtx+mkRenderCtx classMap bS iS = do+  node <- H.getParamNode+  pure $+    mkRenderCtxWith+      node+      classMap+      bS+      iS++mkRenderCtxWith ::+  X.Node ->+  -- | How to replace classes in Div and Span nodes.+  Map Text Text ->+  -- | Custom handling of AST block nodes+  (RenderCtx -> B.Block -> Maybe (HI.Splice Identity)) ->+  -- | Custom handling of AST inline nodes+  (RenderCtx -> B.Inline -> Maybe (HI.Splice Identity)) ->+  RenderCtx+mkRenderCtxWith node classMap bS iS = do+  let ctx =+        RenderCtx+          (Just node)+          (blockLookupAttr node)+          (inlineLookupAttr node)+          classMap+          (bS ctx)+          (iS ctx)+   in ctx++emptyRenderCtx :: RenderCtx+emptyRenderCtx =+  RenderCtx Nothing (const B.nullAttr) (const B.nullAttr) mempty (const Nothing) (const Nothing)++-- | Strip any custom splicing out of the given render context+ctxSansCustomSplicing :: RenderCtx -> RenderCtx+ctxSansCustomSplicing ctx =+  ctx+    { blockSplice = const Nothing+    , inlineSplice = const Nothing+    }++concatSpliceFunc :: Alternative f => (t -> f a) -> (t -> f a) -> t -> f a+concatSpliceFunc f g x =+  asum+    [ f x+    , g x+    ]++rewriteClass :: RenderCtx -> B.Attr -> B.Attr+rewriteClass RenderCtx {..} (id', classes, attr) =+  (id', rewrite classMap <$> classes, attr)+  where+    rewrite :: Ord a => Map a a -> a -> a+    rewrite rules x =+      fromMaybe x $ Map.lookup x rules++blockLookupAttr :: X.Node -> B.Block -> B.Attr+blockLookupAttr node = \case+  B.Para {} -> childTagAttr node "Para"+  B.BulletList {} -> childTagAttr node "BulletList"+  B.OrderedList {} -> childTagAttr node "OrderedList"+  B.CodeBlock {} -> childTagAttr node "CodeBlock"+  B.BlockQuote {} -> childTagAttr node "BlockQuote"+  B.Header level _ _ ->+    fromMaybe B.nullAttr $ do+      header <- X.childElementTag "Header" node+      pure $ childTagAttr header ("h" <> show level)+  _ -> B.nullAttr++inlineLookupAttr :: X.Node -> B.Inline -> B.Attr+inlineLookupAttr node = \case+  B.Code {} -> childTagAttr node "Code"+  B.Note _ ->+    childTagAttr node "Note"+  B.Link _ _ (url, _) ->+    fromMaybe B.nullAttr $ do+      link <- X.childElementTag "PandocLink" node+      let innerTag = if "://" `T.isInfixOf` url then "External" else "Internal"+      pure $ attrFromNode link `concatAttr` childTagAttr link innerTag+  _ -> B.nullAttr++childTagAttr :: X.Node -> Text -> B.Attr+childTagAttr x name =+  maybe B.nullAttr attrFromNode $ X.childElementTag name x++attrFromNode :: X.Node -> B.Attr+attrFromNode node =+  let mClass = maybe mempty words $ X.getAttribute "class" node+      id' = fromMaybe "" $ X.getAttribute "id" node+      attrs = filter ((/= "class") . fst) $ X.elementAttrs node+   in (id', mClass, attrs)

@@ -0,0 +1,61 @@+module Heist.Extra.Splices.Pandoc.Footnotes where++import Data.List qualified as List+import Data.Map.Syntax ((##))+import Heist qualified as H+import Heist.Extra (runCustomNode)+import Heist.Extra.Splices.Pandoc.Ctx (RenderCtx (rootNode))+import Heist.Extra.Splices.Pandoc.Render (renderPandocWith)+import Heist.Interpreted qualified as HI+import Text.Pandoc.Builder qualified as B+import Text.Pandoc.Definition (Pandoc (..))+import Text.Pandoc.Walk qualified as W+import Text.XmlHtml qualified as X++type Footnotes = [[B.Block]]++gatherFootnotes :: Pandoc -> Footnotes+gatherFootnotes = List.nub . W.query queryFootnotes+  where+    queryFootnotes = \case+      B.Note footnote ->+        [footnote]+      _ ->+        []++lookupFootnote :: HasCallStack => [B.Block] -> Footnotes -> Int+lookupFootnote note fs =+  fromMaybe (error $ "Missing footnote: " <> show note) $ do+    (+ 1) <$> List.elemIndex note fs++renderFootnotesWith :: RenderCtx -> Footnotes -> HI.Splice Identity+renderFootnotesWith ctx fs' =+  fromMaybe (pure []) $ do+    fs <- viaNonEmpty toList fs'+    renderNode <- viaNonEmpty head $ maybe [] (X.childElementsTag "Note:List") $ rootNode ctx+    let footnotesWithIdx = zip [1 :: Int ..] fs+    Just $+      runCustomNode renderNode $ do+        "footnote"+          ## (HI.runChildrenWith . uncurry (footnoteSplices ctx)) `foldMapM` footnotesWithIdx++footnoteSplices :: RenderCtx -> Int -> [B.Block] -> H.Splices (HI.Splice Identity)+footnoteSplices ctx idx bs = do+  let footnoteDoc = Pandoc mempty $ case bs of+        [B.Para is] ->+          -- Optimize for the most usual case, by discarding the paragraph,+          -- which adds unnecessary styling (thus margins).+          one $ B.Plain is+        _ ->+          bs+  "footnote:idx" ## HI.textSplice (show idx)+  "footnote:content" ## renderPandocWith ctx footnoteDoc++footnoteRefSplice :: RenderCtx -> [[B.Block]] -> B.Inline -> Maybe (HI.Splice Identity)+footnoteRefSplice ctx footnotes inline = do+  B.Note bs <- pure inline+  let idx = lookupFootnote bs footnotes+  renderNode <- viaNonEmpty head $ maybe [] (X.childElementsTag "Note:Ref") (rootNode ctx)+  Just $+    runCustomNode renderNode $+      footnoteSplices ctx idx bs

@@ -0,0 +1,291 @@+{-# LANGUAGE RecordWildCards #-}++module Heist.Extra.Splices.Pandoc.Render (+  renderPandocWith,+  rpBlock,+  rpInline,+  rpBlock',+  rpInline',+) where++import Data.Map.Strict qualified as Map+import Data.Map.Syntax ((##))+import Data.Text qualified as T+import Heist qualified as H+import Heist.Extra (runCustomNode)+import Heist.Extra.Splices.Pandoc.Attr (concatAttr, rpAttr)+import Heist.Extra.Splices.Pandoc.Ctx (+  RenderCtx (..),+  rewriteClass,+ )+import Heist.Extra.Splices.Pandoc.TaskList qualified as TaskList+import Heist.Interpreted qualified as HI+import Text.Pandoc.Builder qualified as B+import Text.Pandoc.Definition (Pandoc (..))+import Text.Pandoc.Walk as W+import Text.XmlHtml qualified as X++renderPandocWith :: RenderCtx -> Pandoc -> HI.Splice Identity+renderPandocWith ctx (Pandoc _meta blocks) =+  foldMapM (rpBlock ctx) blocks++rpBlock :: RenderCtx -> B.Block -> HI.Splice Identity+rpBlock ctx@RenderCtx {..} b = do+  fromMaybe (rpBlock' ctx b) $ blockSplice b++-- | Render using user override in pandoc.tpl, falling back to default HTML.+withTplTag :: RenderCtx -> Text -> H.Splices (HI.Splice Identity) -> HI.Splice Identity -> HI.Splice Identity+withTplTag RenderCtx {..} name splices default_ =+  case X.childElementTag name =<< rootNode of+    Nothing -> default_+    Just node -> runCustomNode node splices++rpBlock' :: RenderCtx -> B.Block -> HI.Splice Identity+rpBlock' ctx@RenderCtx {..} b = case b of+  B.Plain is ->+    rpInlineWithTasks ctx is+  B.Para is -> do+    let innerSplice = rpInlineWithTasks ctx is+    withTplTag ctx "Para" ("inlines" ## innerSplice) $+      one . X.Element "p" mempty <$> innerSplice+  B.LineBlock iss ->+    flip foldMapM iss $ \is ->+      foldMapM (rpInline ctx) is >> pure [X.TextNode "\n"]+  B.CodeBlock (id', mkLangClass -> classes, attrs) s -> do+    pure $+      one . X.Element "div" (rpAttr $ bAttr b) $+        one . X.Element "pre" mempty $+          one . X.Element "code" (rpAttr (id', classes, attrs)) $+            one $ X.TextNode s+  B.RawBlock (B.Format fmt) s -> do+    pure $ case fmt of+      "html" ->+        rawNode "div" s+      "video" ->+        -- HACK format. TODO: replace with ![[foo.mp4]]+        one . X.Element "video" [("autoplay", ""), ("loop", ""), ("muted", "")] $+          one . X.Element "source" [("src", T.strip s)] $+            one . X.Element "p" mempty $+              [ X.TextNode "Your browser doesn't support HTML5 video. Here is a "+              , X.Element "a" [("href", T.strip s)] $+                  one . X.TextNode $ "link to the video"+              , X.TextNode " instead."+              ]+      _ ->+        one . X.Element "pre" [("class", "pandoc-raw-" <> show fmt)] $ one . X.TextNode $ s+  B.BlockQuote bs ->+    withTplTag ctx "BlockQuote" ("blocks" ## rpBlock ctx `foldMapM` bs) $+      one . X.Element "blockquote" mempty <$> foldMapM (rpBlock ctx) bs+  B.OrderedList _ bss ->+    withTplTag ctx "OrderedList" (pandocListSplices "OrderedList" bss) $ do+      fmap (one . X.Element "ol" (rpAttr $ bAttr b)) $+        flip foldMapM bss $+          fmap (one . X.Element "li" mempty) . foldMapM (rpBlock ctx)+  B.BulletList bss ->+    withTplTag ctx "BulletList" (pandocListSplices "BulletList" bss) $ do+      fmap (one . X.Element "ul" (rpAttr $ bAttr b)) $+        flip foldMapM bss $+          fmap (one . X.Element "li" mempty) . foldMapM (rpBlock ctx)+  B.DefinitionList defs ->+    withTplTag ctx "DefinitionList" (definitionListSplices defs) $+      fmap (one . X.Element "dl" mempty) $+        flip foldMapM defs $ \(term, descList) -> do+          a <- foldMapM (rpInline ctx) term+          as <-+            flip foldMapM descList $+              fmap (one . X.Element "dd" mempty) . foldMapM (rpBlock ctx)+          pure $ a <> as+  B.Header level attr is ->+    one . X.Element (headerTag level) (rpAttr $ concatAttr attr $ bAttr b)+      <$> foldMapM (rpInline ctx) is+  B.HorizontalRule ->+    withTplTag ctx "HorizontalRule" mempty (pure $ one $ X.Element "hr" mempty mempty)+  B.Table attr _captions _colSpec (B.TableHead _ hrows) tbodys _tfoot -> do+    -- TODO: Move tailwind styles to pandoc.tpl+    let borderStyle = "border-gray-300"+        rowStyle = [("class", "border-b-2 border-t-2 " <> borderStyle)]+        cellStyle = [("class", "py-2 px-2 align-top border-r-2 border-l-2 " <> borderStyle)]+        tableAttr = ("", ["mb-3"], mempty)+    -- TODO: Apply captions, colSpec, etc.+    fmap (one . X.Element "table" (rpAttr $ concatAttr attr tableAttr)) $ do+      thead <- fmap (one . X.Element "thead" mempty) $+        flip foldMapM hrows $ \(B.Row _ cells) ->+          fmap (one . X.Element "tr" rowStyle) $+            flip foldMapM cells $ \(B.Cell _ _ _ _ blks) ->+              one . X.Element "th" cellStyle <$> foldMapM (rpBlock ctx) blks+      tbody <- fmap (one . X.Element "tbody" mempty) $+        flip foldMapM tbodys $ \(B.TableBody _ _ _ rows) ->+          flip foldMapM rows $ \(B.Row _ cells) ->+            fmap (one . X.Element "tr" rowStyle) $+              flip foldMapM cells $ \(B.Cell _ _ _ _ blks) ->+                one . X.Element "td" cellStyle <$> foldMapM (rpBlock ctx) blks+      pure $ thead <> tbody+  B.Div attr bs ->+    one . X.Element (getTag "div" attr) (rpAttr $ rewriteClass ctx attr)+      <$> foldMapM (rpBlock ctx) bs+  B.Null ->+    pure []+  where+    getTag defaultTag (_, _, Map.fromList -> attrs) =+      Map.lookup "tag" attrs & fromMaybe defaultTag+    mkLangClass classes' =+      -- Tag code block with "foo language-foo" classes, if the user specified+      -- "foo" as the language identifier. This enables external syntax+      -- highlighters to detect the language.+      --+      -- If no language is specified, use "language-none" as the language This+      -- works at least on prism.js,[1] in that - syntax highlighting is turned+      -- off all the while background styling is applied, to be consistent with+      -- code blocks with language set.+      --+      -- [1] https://github.com/PrismJS/prism/pull/2738+      fromMaybe ["language-none"] $ do+        classes <- nonEmpty classes'+        let lang = head classes+        pure $ lang : ("language-" <> lang) : tail classes++    definitionListSplices :: [([B.Inline], [[B.Block]])] -> H.Splices (HI.Splice Identity)+    definitionListSplices defs = do+      "DefinitionList:Items" ## (HI.runChildrenWith . uncurry itemsSplices) `foldMapM` defs+      where+        itemsSplices :: [B.Inline] -> [[B.Block]] -> H.Splices (HI.Splice Identity)+        itemsSplices term descriptions = do+          "DefinitionList:Item:Term" ## foldMapM (rpInline ctx) term+          "DefinitionList:Item:DescList" ## (HI.runChildrenWith . descListSplices) `foldMapM` descriptions+        descListSplices :: [B.Block] -> H.Splices (HI.Splice Identity)+        descListSplices bs = "DefinitionList:Item:Desc" ## rpBlock ctx `foldMapM` bs++    pandocListSplices :: Text -> [[B.Block]] -> H.Splices (HI.Splice Identity)+    pandocListSplices tagPrefix bss =+      (tagPrefix <> ":Items") ## (HI.runChildrenWith . itemsSplices) `foldMapM` bss+      where+        itemsSplices :: [B.Block] -> H.Splices (HI.Splice Identity)+        itemsSplices bs = do+          (tagPrefix <> ":Item") ## foldMapM (rpBlock ctx) bs++headerTag :: HasCallStack => Int -> Text+headerTag n =+  if n >= 1 && n <= 6+    then "h" <> show n+    else error "Invalid pandoc header level"++rpInline :: RenderCtx -> B.Inline -> HI.Splice Identity+rpInline ctx@RenderCtx {..} i = do+  fromMaybe (rpInline' ctx i) $ inlineSplice i++rpInline' :: RenderCtx -> B.Inline -> HI.Splice Identity+rpInline' ctx@RenderCtx {..} i = case i of+  B.Str s ->+    pure $ one . X.TextNode $ s+  B.Emph is ->+    one . X.Element "em" mempty <$> foldMapM (rpInline ctx) is+  B.Strong is ->+    one . X.Element "strong" mempty <$> foldMapM (rpInline ctx) is+  B.Underline is ->+    one . X.Element "u" mempty <$> foldMapM (rpInline ctx) is+  B.Strikeout is ->+    one . X.Element "s" mempty <$> foldMapM (rpInline ctx) is+  B.Superscript is ->+    one . X.Element "sup" mempty <$> foldMapM (rpInline ctx) is+  B.Subscript is ->+    one . X.Element "sub" mempty <$> foldMapM (rpInline ctx) is+  B.Quoted qt is ->+    flip inQuotes qt $ foldMapM (rpInline ctx) is+  B.Code attr s ->+    pure $+      one . X.Element "code" (rpAttr $ concatAttr attr $ iAttr i) $+        one . X.TextNode $ s+  B.Space -> pure $ one . X.TextNode $ " "+  B.SoftBreak -> pure $ one . X.TextNode $ " "+  B.LineBreak ->+    pure $ one $ X.Element "br" mempty mempty+  B.RawInline (B.Format fmt) s ->+    if fmt == "html"+      then pure $ rawNode "span" s+      else+        pure $+          one . X.Element "pre" [("class", "pandoc-raw-" <> show fmt)] $+            one . X.TextNode $ s+  B.Math mathType s ->+    case mathType of+      B.InlineMath ->+        pure $+          one . X.Element "span" [("class", "math inline")] $+            one . X.TextNode $ "\\(" <> s <> "\\)"+      B.DisplayMath ->+        pure $+          one . X.Element "span" [("class", "math display")] $+            one . X.TextNode $ "$$" <> s <> "$$"+  B.Link attr is (url, tit) -> do+    let attrs =+          catMaybes [Just ("href", url), guard (not $ T.null tit) >> pure ("title", tit)]+            <> rpAttr (concatAttr attr $ iAttr i)+    one . X.Element "a" attrs <$> foldMapM (rpInline ctx) is+  B.Image attr is (url, tit) -> do+    let attrs =+          catMaybes+            [ pure ("src", url)+            , guard (not $ T.null tit) >> pure ("title", tit)+            , pure ("alt", plainify is)+            ]+            <> rpAttr (rewriteClass ctx attr)+    pure $ one . X.Element "img" attrs $ mempty+  B.Note _bs -> do+    -- Footnotes are to be handled separately; see Footenotes.hs+    pure $ one $ X.Element "sup" mempty $ one $ X.TextNode "*"+  B.Span attr is -> do+    one . X.Element "span" (rpAttr $ rewriteClass ctx attr) <$> foldMapM (rpInline ctx) is+  B.SmallCaps is ->+    foldMapM (rpInline ctx) is+  B.Cite _citations is ->+    -- TODO: What to do with _citations here?+    withTplTag ctx "Cite" ("inlines" ## rpInline ctx `foldMapM` is) $+      one . X.Element "cite" mempty <$> foldMapM (rpInline ctx) is+  where+    inQuotes :: HI.Splice Identity -> B.QuoteType -> HI.Splice Identity+    inQuotes w = \case+      B.SingleQuote ->+        w <&> \nodes ->+          [X.TextNode "‘"] <> nodes <> [X.TextNode "’"]+      B.DoubleQuote ->+        w <&> \nodes ->+          [X.TextNode "“"] <> nodes <> [X.TextNode "”"]++-- | Like rpInline', but supports task checkbox in the given inlines.+rpInlineWithTasks :: RenderCtx -> [B.Inline] -> HI.Splice Identity+rpInlineWithTasks ctx is =+  rpTask ctx is $+    rpInline ctx `foldMapM` is++rpTask :: RenderCtx -> [B.Inline] -> HI.Splice Identity -> HI.Splice Identity+rpTask ctx is default_ =+  maybe default_ render (TaskList.parseTaskFromInlines is)+  where+    render (checked, taskInlines) = do+      let tag = bool "Task:Unchecked" "Task:Checked" checked+      withTplTag+        ctx+        tag+        ("inlines" ## rpInline ctx `foldMapM` taskInlines)+        default_++rawNode :: Text -> Text -> [X.Node]+rawNode wrapperTag s =+  one . X.Element wrapperTag (one ("xmlhtmlRaw", "")) $+    one . X.TextNode $ s++-- | Convert Pandoc AST inlines to raw text.+plainify :: [B.Inline] -> Text+plainify = W.query $ \case+  B.Str x -> x+  B.Code _attr x -> x+  B.Space -> " "+  B.SoftBreak -> " "+  B.LineBreak -> " "+  -- TODO: if fmt is html, we should strip the html tags+  B.RawInline _fmt s -> s+  -- Ignore "wrapper" inlines like span.+  B.Span _ _ -> ""+  -- TODO: How to wrap math stuff here?+  B.Math _mathTyp s -> s+  _ -> ""

@@ -0,0 +1,27 @@+-- GFM Task List, https://github.github.com/gfm/#task-list-items-extension-+module Heist.Extra.Splices.Pandoc.TaskList (+  parseTaskFromInlines,+  queryTasks,+) where++import Text.Pandoc.Builder qualified as B+import Text.Pandoc.Walk qualified as W++parseTaskFromInlines :: [B.Inline] -> Maybe (Bool, [B.Inline])+parseTaskFromInlines = \case+  B.Str "[" : B.Space : B.Str "]" : B.Space : taskInlines ->+    pure (False, taskInlines)+  B.Str "[x]" : B.Space : taskInlines ->+    pure (True, taskInlines)+  _ ->+    Nothing++queryTasks :: W.Walkable B.Block b => b -> [(Bool, [B.Inline])]+queryTasks =+  W.query $ \case+    B.Plain is ->+      maybeToList $ parseTaskFromInlines is+    B.Para is ->+      maybeToList $ parseTaskFromInlines is+    _ ->+      mempty

@@ -0,0 +1,32 @@+module Heist.Extra.Splices.Tree (treeSplice) where++import Data.Map.Syntax ((##))+import Data.Tree (Tree (..))+import Heist qualified as H+import Heist.Interpreted qualified as HI+import Heist.Splices qualified as Heist++treeSplice ::+  forall a sortKey.+  (Ord sortKey) =>+  -- | How to sort children+  (NonEmpty a -> sortKey) ->+  -- | Input tree+  [Tree a] ->+  -- | How to render a (sub-)tree root+  (NonEmpty a -> [Tree a] -> H.Splices (HI.Splice Identity)) ->+  HI.Splice Identity+treeSplice =+  go []+  where+    go :: [a] -> (NonEmpty a -> sortKey) -> [Tree a] -> (NonEmpty a -> [Tree a] -> H.Splices (HI.Splice Identity)) -> HI.Splice Identity+    go pars sortKey trees childSplice = do+      let extendPars x = maybe (one x) (<> one x) $ nonEmpty pars+      flip foldMapM (sortOn (sortKey . extendPars . rootLabel) trees) $ \(Node lbl children) -> do+        HI.runChildrenWith $ do+          let herePath = extendPars lbl+          childSplice herePath children+          "has-children" ## Heist.ifElseISplice (not . null $ children)+          let childrenSorted = sortOn (sortKey . (herePath <>) . one . rootLabel) children+          "children"+            ## go (toList herePath) sortKey childrenSorted childSplice

@@ -0,0 +1,132 @@+{-# LANGUAGE RecordWildCards #-}++module Heist.Extra.TemplateState (+  TemplateState,+  TemplateName,+  emptyTemplateState,+  addTemplateFile,+  removeTemplateFile,+  renderHeistTemplate,+) where++import Control.Monad.Except (MonadError (throwError), runExcept)+import Data.ByteString.Builder (toLazyByteString)+import Data.Default (Default (..))+import Data.HashMap.Strict qualified as HM+import Data.Map.Strict qualified as Map+import Data.Text qualified as T+import GHC.IO.Unsafe (unsafePerformIO)+import Heist qualified as H+import Heist.Common qualified as H+import Heist.Internal.Types qualified as HT+import Heist.Interpreted qualified as HI+import System.FilePath (splitExtension)+import Text.XmlHtml qualified as XmlHtml++type TemplateName = ByteString++-- | Holds a set of Heist template files that are importing one another.+data TemplateState = TemplateState (H.HeistState Identity) TemplateErrors++instance Default TemplateState where+  def = unsafePerformIO emptyTemplateState++emptyTemplateState :: MonadIO m => m TemplateState+emptyTemplateState = do+  let heistCfg :: H.HeistConfig Identity =+        H.emptyHeistConfig+          & H.hcNamespace (const $ Identity "")+          & runIdentity+  eSt <- liftIO $ H.initHeist heistCfg+  let st = either (error . T.intercalate "," . fmap toText) id eSt+  pure $ TemplateState st mempty++getTemplateState :: MonadError Text m => TemplateState -> m (HT.HeistState Identity)+getTemplateState (TemplateState st errs) =+  if not $ null errs+    then throwError $ showErrors errs+    else pure st++addTemplate :: TemplateName -> FilePath -> TemplateState -> Either Text HT.Template -> TemplateState+addTemplate name fp (TemplateState st errs) = \case+  Left err ->+    TemplateState st (assignError name err errs)+  Right doc ->+    let newSt = HI.addTemplate name doc (Just fp) st+     in TemplateState newSt (clearError name errs)++addTemplateFile ::+  HasCallStack =>+  -- | Absolute path+  FilePath ->+  -- | Relative path (to template base)+  FilePath ->+  -- | Contents of the .tmpl file+  ByteString ->+  TemplateState ->+  TemplateState+addTemplateFile fp (tmplName -> name) s tmplSt =+  addTemplate name fp tmplSt $+    XmlHtml.parseHTML fp s & \case+      Left (toText -> err) ->+        Left err+      Right XmlHtml.XmlDocument {} ->+        Left "Xml unsupported"+      Right XmlHtml.HtmlDocument {..} ->+        Right docContent++removeTemplate :: HasCallStack => TemplateName -> TemplateState -> TemplateState+removeTemplate name (TemplateState st errs) =+  let tpath = H.splitPathWith '/' name+      newSt = st {HT._templateMap = HM.delete tpath (HT._templateMap st)}+   in TemplateState newSt (clearError name errs)++removeTemplateFile :: HasCallStack => FilePath -> TemplateState -> TemplateState+removeTemplateFile (tmplName -> name) = removeTemplate name++tmplName :: HasCallStack => String -> TemplateName+tmplName fp = fromMaybe (error "Not a .tpl file") $ do+  let (base, ext) = splitExtension fp+  guard $ ext == ".tpl"+  pure $ encodeUtf8 base++renderHeistTemplate ::+  HasCallStack =>+  TemplateName ->+  H.Splices (HI.Splice Identity) ->+  TemplateState ->+  Either Text LByteString+renderHeistTemplate name splices tmplSt =+  runExcept $ do+    st <- getTemplateState tmplSt+    (builder, _mimeType) <-+      tryJust ("Unable to render template '" <> decodeUtf8 name <> "'") $+        runIdentity $+          HI.renderTemplate (HI.bindSplices splices st) name+    pure $ toLazyByteString builder+  where+    -- A 'fromJust' that fails in the 'ExceptT' monad+    tryJust :: Monad m => e -> Maybe a -> ExceptT e m a+    tryJust e = hoistEither . maybeToRight e++-- | Type to track errors on a per template basis+type TemplateErrors = Map TemplateName Text++showErrors :: TemplateErrors -> Text+showErrors m =+  T.intercalate "\n" $+    Map.toList m <&> \(k, v) ->+      decodeUtf8 k <> ":\n" <> unlines (indent <$> lines v)+  where+    indent :: Text -> Text+    indent s = "\t" <> s++-- | Assign a new error for the given template+assignError :: TemplateName -> Text -> TemplateErrors -> TemplateErrors+assignError =+  Map.insert++-- | Indicate that the given template has no errors+clearError :: TemplateName -> TemplateErrors -> TemplateErrors+clearError =+  Map.delete