generator/Utils/Pandoc.hs

   1 module Utils.Pandoc where
   2
   3 import Data.List qualified as List
   4 import Relude
   5 import Text.Pandoc.Definition
   6 import Text.Pandoc.Walk (query)
   7
   8 trimWhiteInlines :: [Inline] -> [Inline]
   9 trimWhiteInlines =
  10   List.dropWhile isWhite .
  11   List.dropWhileEnd isWhite
  12   where
  13   isWhite Space = True
  14   isWhite SoftBreak = True
  15   isWhite _ = False
  16
  17 {-
  18 renderPandocBlock :: B.Block -> H.Html
  19 renderPandocBlock = \case
  20   B.BlockQuote bs ->
  21     H.blockquote $ forM_ bs renderPandocBlock
  22   B.BulletList bss ->
  23     H.ul ! A.class_ (listStyle <> " list-disc") $
  24       forM_ bss $ \bs ->
  25         H.li ! A.class_ listItemStyle $ forM_ bs renderPandocBlock
  26   B.CodeBlock (id', classes, attrs) s ->
  27     -- Prism friendly classes
  28     let classes' = flip List.concatMap classes $ \classes -> [classes, "language-" <> classes]
  29      in H.div
  30           ! A.class_ "py-0.5 text-sm"
  31           $ H.pre
  32             ! renderPandocAttr (id', classes', attrs)
  33             $ H.code
  34               ! renderPandocAttr ("", classes', [])
  35               $ H.text s
  36   B.DefinitionList defs ->
  37     H.dl $
  38       forM_ defs $ \(term, descList) -> do
  39         forM_ term renderPandocInline
  40         forM_ descList $ \desc ->
  41           H.dd $ forM_ desc renderPandocBlock
  42   B.Div attr bs ->
  43     H.div ! renderPandocAttr attr $ forM_ bs renderPandocBlock
  44   B.Header level attr is ->
  45     renderHeader level ! renderPandocAttr attr $ do
  46       fromString $ show attr
  47       forM_ is renderPandocInline
  48   B.HorizontalRule -> H.hr
  49   B.LineBlock iss ->
  50     forM_ iss $ \is ->
  51       forM_ is renderPandocInline >> "\n"
  52   B.Null -> pure ()
  53   B.OrderedList _ bss ->
  54     H.ol ! A.class_ (listStyle <> " list-decimal") $
  55       forM_ bss $ \bs ->
  56         H.li ! A.class_ listItemStyle $
  57           forM_ bs renderPandocBlock
  58   B.Para is ->
  59     H.p ! A.class_ "my-2" $ forM_ is renderPandocInline
  60   B.Plain is ->
  61     forM_ is renderPandocInline
  62   B.RawBlock (B.Format fmt) html
  63     | fmt == "html" -> H.unsafeByteString $ encodeUtf8 html
  64     | otherwise -> throw Unsupported
  65   B.Table{} ->
  66     throw Unsupported
  67   where
  68     listStyle = "list-inside ml-2 space-y-1 "
  69     listItemStyle = ""
  70
  71 renderHeader :: Int -> H.Html -> H.Html
  72 renderHeader = \case
  73   1 -> H.h1 ! classes ("text-xl":cs)
  74   2 -> H.h2 ! classes ("text-xl":cs)
  75   3 -> H.h3 ! classes ("text-lg":cs)
  76   4 -> H.h4 ! classes ("text-lg":cs)
  77   5 -> H.h5 ! classes ("text-lg":cs)
  78   6 -> H.h6 ! classes ("text-lg":cs)
  79   _ -> error "Invalid pandoc header level"
  80   where
  81     cs = ["mt-4", "mb-2", "font-bold"]
  82
  83 renderPandocInline :: B.Inline -> H.Html
  84 renderPandocInline = \case
  85   B.Code attr s ->
  86     H.code ! renderPandocAttr attr $ H.toHtml s
  87   B.Emph is ->
  88     H.em $ forM_ is renderPandocInline
  89   B.Image attr is (url, title) ->
  90     H.img ! A.src (H.textValue url) ! A.title (H.textValue title) ! A.alt (H.textValue $ Markdown.plainify is) ! renderPandocAttr attr
  91   B.Link attr is (url, title) -> do
  92     let (classes, target) =
  93           if "://" `T.isInfixOf` url
  94             then ("text-blue-600 hover:underline", targetBlank)
  95             else ("text-blue-600 hover:bg-blue-50", mempty)
  96     H.a
  97       ! A.class_ classes
  98       ! A.href (H.textValue url)
  99       ! A.title (H.textValue title)
 100       ! target
 101       ! renderPandocAttr attr
 102       $ forM_ is renderPandocInline
 103   B.LineBreak -> H.br
 104   B.Math _ _ ->
 105     throw Unsupported
 106   B.Note _ ->
 107     throw Unsupported
 108   B.Quoted qt is ->
 109     flip inQuotes qt $ forM_ is renderPandocInline
 110   B.RawInline _fmt s ->
 111     H.pre $ H.toHtml s
 112   B.SoftBreak -> " "
 113   B.Space -> " "
 114   B.Span attr is ->
 115     H.span ! renderPandocAttr attr $ forM_ is renderPandocInline
 116   B.Str s -> H.toHtml s
 117   B.Strikeout is ->
 118     H.del $ forM_ is renderPandocInline
 119   B.Strong is ->
 120     H.strong $ forM_ is renderPandocInline
 121   B.Subscript is ->
 122     H.sub $ forM_ is renderPandocInline
 123   B.Superscript is ->
 124     H.sup $ forM_ is renderPandocInline
 125   B.Underline is ->
 126     H.u $ forM_ is renderPandocInline
 127   x ->
 128     H.pre $ H.toHtml $ show @Text x
 129   where
 130     inQuotes :: H.Html -> B.QuoteType -> H.Html
 131     inQuotes w = \case
 132       B.SingleQuote -> "‘" >> w <* "’"
 133       B.DoubleQuote -> "“" >> w <* "”"
 134
 135 targetBlank :: H.Attribute
 136 targetBlank = A.target "_blank" <> A.rel "noopener"
 137
 138 renderPandocAttr :: B.Attr -> H.Attribute
 139 renderPandocAttr (id_, classes, attrs) =
 140   unlessNull id_ (A.id (H.textValue id_))
 141     <> unlessNull class_ (A.class_ (H.textValue class_))
 142     <> foldMap (\(k, v) -> H.dataAttribute (H.textTag k) (H.textValue v)) attrs
 143   where
 144     class_ = T.intercalate " " classes
 145     unlessNull x f
 146       | T.null x = mempty
 147       | otherwise = f
 148
 149 data Unsupported = Unsupported
 150   deriving (Show, Exception)
 151 -}