<commit_before>{-# LANGUAGE FlexibleContexts   #-}
{-# LANGUAGE FlexibleInstances  #-}


-- | Everything concerning rendering and processing Markdown.
--
-- Currently we use the @cmark@ package as the Markdown parser.
module Guide.Markdown
(
  -- * Types
  MarkdownInline(..),
  MarkdownInlineLenses(..),
  MarkdownBlock(..),
  MarkdownBlockLenses(..),
  MarkdownTree(..),
  MarkdownTreeLenses(..),
  Heading(..),

  -- * Converting text to Markdown
  toMarkdownInline,
  toMarkdownBlock,
  toMarkdownTree,

  -- * Misc
  renderMD,
  extractPreface,
  addTargetBlank,
)
where

-- Shared imports
import Imports hiding (some)
-- Parsing
import Text.Megaparsec hiding (State)
import Text.Megaparsec.Char
-- HTML
import Lucid
import Text.HTML.SanitizeXSS
-- Containers
import Data.Tree
-- Markdown
import CMark hiding (Node)
import CMark.Highlight
import CMark.Sections
import ShortcutLinks
import ShortcutLinks.All (hackage)
-- acid-state
import Data.SafeCopy

import Guide.Utils

import qualified CMark as MD
import qualified Data.Aeson as Aeson
import qualified Data.ByteString as BS
import qualified Data.Set as S
import qualified Data.Text as T


data MarkdownInline = MarkdownInline {
  markdownInlineSource   :: Text,
  markdownInlineHtml     :: ByteString,
  markdownInlineMarkdown :: ![MD.Node] }
  deriving (Generic, Data, Eq)

data MarkdownBlock = MarkdownBlock {
  markdownBlockSource   :: Text,
  markdownBlockHtml     :: ByteString,
  markdownBlockMarkdown :: ![MD.Node] }
  deriving (Generic, Data, Eq)

data MarkdownTree = MarkdownTree {
  markdownTreeSource    :: Text,
  markdownTreeStructure :: !(Document Text ByteString),
  markdownTreeIdPrefix  :: Text,
  markdownTreeTOC       :: Forest Heading }
  deriving (Generic, Data, Eq)

-- | Table-of-contents heading
data Heading = Heading
    { headingMarkdown :: MarkdownInline
    , headingSlug :: Text
    } deriving (Generic, Data, Eq)

makeClassWithLenses ''MarkdownInline
makeClassWithLenses ''MarkdownBlock
makeClassWithLenses ''MarkdownTree

parseMD :: Text -> [MD.Node]
parseMD s =
  let MD.Node _ DOCUMENT ns =
        highlightNode . shortcutLinks . commonmarkToNode [optSafe] $ s
  in  ns

renderMD :: [MD.Node] -> ByteString
renderMD ns
  -- See https://github.com/jgm/cmark/issues/147
  | any isInlineNode ns
      = toUtf8ByteString
      . sanitize
      . T.concat
      . map (nodeToHtml [] . addTargetBlank)
      $ ns
  | otherwise
      = toUtf8ByteString
      . sanitize
      . nodeToHtml []
      . addTargetBlank
      $ MD.Node Nothing DOCUMENT ns

isInlineNode :: MD.Node -> Bool
isInlineNode (MD.Node _ tp _) = case tp of
  EMPH              -> True
  STRONG            -> True
  LINK _ _          -> True
  IMAGE _ _         -> True
  CUSTOM_INLINE _ _ -> True
  SOFTBREAK         -> True
  LINEBREAK         -> True
  TEXT _            -> True
  CODE _            -> True
  HTML_INLINE _     -> True
  _other            -> False

-- | Convert a Markdown structure to a string with formatting removed.
stringify :: [MD.Node] -> Text
stringify = T.concat . map go
  where
    go (MD.Node _ tp ns) = case tp of
      DOCUMENT          -> stringify ns
      THEMATIC_BREAK    -> stringify ns
      PARAGRAPH         -> stringify ns
      BLOCK_QUOTE       -> stringify ns
      CUSTOM_BLOCK _ _  -> stringify ns
      HEADING _         -> stringify ns
      LIST _            -> stringify ns
      ITEM              -> stringify ns
      EMPH              -> stringify ns
      STRONG            -> stringify ns
      LINK _ _          -> stringify ns
      IMAGE _ _         -> stringify ns
      CUSTOM_INLINE _ _ -> stringify ns
      CODE         xs   -> xs
      CODE_BLOCK _ xs   -> xs
      TEXT         xs   -> xs
      SOFTBREAK         -> " "
      LINEBREAK         -> " "
      HTML_BLOCK _      -> ""
      HTML_INLINE _     -> ""

-- | Extract everything before the first heading.
--
-- Note that if you render 'markdownBlockSource' of the produced Markdown
-- block, it won't necessarily parse into 'markdownBlockHtml' from the same
-- block. It's because rendered Markdown might depend on links that are
-- defined further in the tree.
extractPreface :: MarkdownTree -> MarkdownBlock
extractPreface = mkBlock . preface . markdownTreeStructure
  where
    mkBlock x = MarkdownBlock {
      markdownBlockSource   = getSource x,
      markdownBlockHtml     = renderMD (stripSource x),
      markdownBlockMarkdown = stripSource x }

-- | Flatten Markdown by concatenating all block elements.
extractInlines :: [MD.Node] -> [MD.Node]
extractInlines = concatMap go
  where
    go node@(MD.Node _ tp ns) = case tp of
      -- Block containers
      DOCUMENT          -> extractInlines ns
      BLOCK_QUOTE       -> extractInlines ns
      CUSTOM_BLOCK _ _  -> extractInlines ns
      LIST _            -> extractInlines ns
      ITEM              -> extractInlines ns
      -- Inline containers
      PARAGRAPH         -> ns
      HEADING _         -> ns
      IMAGE _ _         -> ns
      -- Inlines
      EMPH              -> [node]
      STRONG            -> [node]
      LINK _ _          -> [node]
      CUSTOM_INLINE _ _ -> [node]
      SOFTBREAK         -> [node]
      LINEBREAK         -> [node]
      TEXT _            -> [node]
      CODE _            -> [node]
      -- Other stuff
      THEMATIC_BREAK    -> []
      HTML_BLOCK xs     -> [MD.Node Nothing (CODE xs) []]
      HTML_INLINE xs    -> [MD.Node Nothing (CODE xs) []]
      CODE_BLOCK _ xs   -> [MD.Node Nothing (CODE xs) []]

-- | Convert LINK to HTML_INLINE with 'target="_blank"' attribute added.
--
-- It is necessary that the rendered html page be opened in a new tab.
addTargetBlank :: MD.Node -> MD.Node
addTargetBlank (MD.Node pos (LINK url title) ns) =
    MD.Node pos (HTML_INLINE blankLink) []
  where
    blankLink = toText $ renderText
      $ a_ ([href_ url, target_ "_blank"] ++ [title_ title | title /= ""])
      $ toHtmlRaw $ renderMD ns
addTargetBlank (MD.Node pos tp ns) = MD.Node pos tp (map addTargetBlank ns)

shortcutLinks :: MD.Node -> MD.Node
shortcutLinks node@(MD.Node pos (LINK url title) ns) | "@" <- T.take 1 url =
  -- %20s are possibly introduced by cmark (Pandoc definitely adds them,
  -- no idea about cmark but better safe than sorry) and so they need to
  -- be converted back to spaces
  case parseLink (T.replace "%20" " " url) of
    Left _err -> MD.Node pos (LINK url title) (map shortcutLinks ns)
    Right (shortcut, opt, text) -> do
      let text' = fromMaybe (stringify [node]) text
      let shortcuts = (["hk"], hackage) : allShortcuts
      case useShortcutFrom shortcuts shortcut opt text' of
        Success link ->
          MD.Node pos (LINK link title) (map shortcutLinks ns)
        Warning warnings link ->
          let warningText = "[warnings when processing shortcut link: " <>
                            toText (intercalate ", " warnings) <> "]"
              warningNode = MD.Node Nothing (TEXT warningText) []
          in  MD.Node pos (LINK link title)
                             (warningNode : map shortcutLinks ns)
        Failure err ->
          let errorText = "[error when processing shortcut link: " <>
                          toText err <> "]"
          in  MD.Node Nothing (TEXT errorText) []
shortcutLinks (MD.Node pos tp ns) =
  MD.Node pos tp (map shortcutLinks ns)

-- TODO: this should be in the shortcut-links package itself

-- | Parse a shortcut link. Allowed formats:
--
-- @
-- \@name
-- \@name:text
-- \@name(option)
-- \@name(option):text
-- @
parseLink :: Text -> Either String (Text, Maybe Text, Maybe Text)
parseLink = either (Left . show) Right . parse p ""
  where
    shortcut = some (alphaNumChar <|> char '-')
    opt      = char '(' *> some (noneOf [')']) <* char ')'
    text     = char ':' *> some anyChar
    p :: Parsec Void Text (Text, Maybe Text, Maybe Text)
    p = do
      _ <- char '@'
      (,,) <$> (toText <$> shortcut)
           <*> optional (toText <$> opt)
           <*> optional (toText <$> text)

toMarkdownInline :: Text -> MarkdownInline
toMarkdownInline s = MarkdownInline {
  markdownInlineSource   = s,
  markdownInlineHtml     = html,
  markdownInlineMarkdown = inlines }
  where
    inlines = extractInlines (parseMD s)
    html = renderMD inlines

toMarkdownBlock :: Text -> MarkdownBlock
toMarkdownBlock s = MarkdownBlock {
  markdownBlockSource   = s,
  markdownBlockHtml     = html,
  markdownBlockMarkdown = doc }
  where
    doc = parseMD s
    html = renderMD doc

toMarkdownTree :: Text -> Text -> MarkdownTree
toMarkdownTree idPrefix s = MarkdownTree {
  markdownTreeSource    = s,
  markdownTreeIdPrefix  = idPrefix,
  markdownTreeStructure = tree,
  markdownTreeTOC       = toc }
  where
    blocks :: [MD.Node]
    blocks = parseMD s
    --
    slugify :: Text -> Text
    slugify x = idPrefix <> makeSlug x
    --
    tree :: Document Text ByteString
    tree = renderContents . slugifyDocument slugify $
             nodesToDocument (WithSource s blocks)
    --
    toc :: Forest Heading
    toc = sections tree
            & each.each
            %~ (\Section{..} -> Heading (nodesToMdInline heading) headingAnn)

    nodesToMdInline :: WithSource [MD.Node] -> MarkdownInline
    nodesToMdInline (WithSource src nodes) = MarkdownInline
        { markdownInlineSource   = src
        , markdownInlineHtml     = html
        , markdownInlineMarkdown = inlines
        }
      where
        inlines = extractInlines nodes
        html = renderMD inlines

renderContents :: Document a b -> Document a ByteString
renderContents doc = doc {
  prefaceAnn = renderMD (stripSource (preface doc)),
  sections = over (each.each) renderSection (sections doc) }
  where
    renderSection sec = sec {
      contentAnn = renderMD (stripSource (content sec)) }

slugifyDocument :: (Text -> Text) -> Document a b -> Document Text b
slugifyDocument slugify doc = doc {
  sections = evalState ((each.each) process (sections doc)) mempty }
  where
    process :: Section a b -> State (Set Text) (Section Text b)
    process sec = do
      previousIds <- get
      let slug = until (`S.notMember` previousIds) (<> "_")
                   (slugify (stringify (stripSource (heading sec))))
      modify (S.insert slug)
      return sec{headingAnn = slug}

instance Show MarkdownInline where
  show = show . markdownInlineSource
instance Show MarkdownBlock where
  show = show . markdownBlockSource
instance Show MarkdownTree where
  show = show . markdownTreeSource
deriving instance Show Heading

instance Aeson.ToJSON MarkdownInline where
  toJSON md = Aeson.object [
    "text" Aeson..= markdownInlineSource md,
    "html" Aeson..= utf8ToText (markdownInlineHtml md) ]
instance Aeson.ToJSON MarkdownBlock where
  toJSON md = Aeson.object [
    "text" Aeson..= markdownBlockSource md,
    "html" Aeson..= utf8ToText (markdownBlockHtml md) ]
instance Aeson.ToJSON MarkdownTree where
  toJSON md = Aeson.object [
    "text" Aeson..= markdownTreeSource md ]

instance ToHtml MarkdownInline where
  toHtmlRaw = toHtml
  toHtml    = toHtmlRaw . markdownInlineHtml
instance ToHtml MarkdownBlock where
  toHtmlRaw = toHtml
  toHtml    = toHtmlRaw . markdownBlockHtml
instance ToHtml MarkdownTree where
  toHtmlRaw = toHtml
  toHtml    = toHtmlRaw . renderDoc . markdownTreeStructure
    where
      renderDoc Document{..} = BS.concat $
        prefaceAnn :
        map renderSection (concatMap flatten sections)
      renderSection Section{..} = toByteString . renderBS $ do
        mkH $ do
          span_ [id_ headingAnn] ""
          toHtmlRaw (renderMD (stripSource heading))
        toHtmlRaw contentAnn
        where
          mkH = case level of
            1 -> h1_; 2 -> h2_; 3 -> h3_;
            4 -> h4_; 5 -> h5_; 6 -> h6_;
            _other -> error "Markdown.toHtml: level > 6"

instance SafeCopy MarkdownInline where
  version = 0
  kind = base
  putCopy = contain . safePut . markdownInlineSource
  getCopy = contain $ toMarkdownInline <$> safeGet
instance SafeCopy MarkdownBlock where
  version = 0
  kind = base
  putCopy = contain . safePut . markdownBlockSource
  getCopy = contain $ toMarkdownBlock <$> safeGet
instance SafeCopy MarkdownTree where
  version = 0
  kind = base
  putCopy md = contain $ do
    safePut (markdownTreeIdPrefix md)
    safePut (markdownTreeSource md)
  getCopy = contain $
    toMarkdownTree <$> safeGet <*> safeGet
<commit_msg>Change 'addTargetBlank' comment (#407)<commit_after>{-# LANGUAGE FlexibleContexts   #-}
{-# LANGUAGE FlexibleInstances  #-}


-- | Everything concerning rendering and processing Markdown.
--
-- Currently we use the @cmark@ package as the Markdown parser.
module Guide.Markdown
(
  -- * Types
  MarkdownInline(..),
  MarkdownInlineLenses(..),
  MarkdownBlock(..),
  MarkdownBlockLenses(..),
  MarkdownTree(..),
  MarkdownTreeLenses(..),
  Heading(..),

  -- * Converting text to Markdown
  toMarkdownInline,
  toMarkdownBlock,
  toMarkdownTree,

  -- * Misc
  renderMD,
  extractPreface,
  addTargetBlank,
)
where

-- Shared imports
import Imports hiding (some)
-- Parsing
import Text.Megaparsec hiding (State)
import Text.Megaparsec.Char
-- HTML
import Lucid
import Text.HTML.SanitizeXSS
-- Containers
import Data.Tree
-- Markdown
import CMark hiding (Node)
import CMark.Highlight
import CMark.Sections
import ShortcutLinks
import ShortcutLinks.All (hackage)
-- acid-state
import Data.SafeCopy

import Guide.Utils

import qualified CMark as MD
import qualified Data.Aeson as Aeson
import qualified Data.ByteString as BS
import qualified Data.Set as S
import qualified Data.Text as T


data MarkdownInline = MarkdownInline {
  markdownInlineSource   :: Text,
  markdownInlineHtml     :: ByteString,
  markdownInlineMarkdown :: ![MD.Node] }
  deriving (Generic, Data, Eq)

data MarkdownBlock = MarkdownBlock {
  markdownBlockSource   :: Text,
  markdownBlockHtml     :: ByteString,
  markdownBlockMarkdown :: ![MD.Node] }
  deriving (Generic, Data, Eq)

data MarkdownTree = MarkdownTree {
  markdownTreeSource    :: Text,
  markdownTreeStructure :: !(Document Text ByteString),
  markdownTreeIdPrefix  :: Text,
  markdownTreeTOC       :: Forest Heading }
  deriving (Generic, Data, Eq)

-- | Table-of-contents heading
data Heading = Heading
    { headingMarkdown :: MarkdownInline
    , headingSlug :: Text
    } deriving (Generic, Data, Eq)

makeClassWithLenses ''MarkdownInline
makeClassWithLenses ''MarkdownBlock
makeClassWithLenses ''MarkdownTree

parseMD :: Text -> [MD.Node]
parseMD s =
  let MD.Node _ DOCUMENT ns =
        highlightNode . shortcutLinks . commonmarkToNode [optSafe] $ s
  in  ns

renderMD :: [MD.Node] -> ByteString
renderMD ns
  -- See https://github.com/jgm/cmark/issues/147
  | any isInlineNode ns
      = toUtf8ByteString
      . sanitize
      . T.concat
      . map (nodeToHtml [] . addTargetBlank)
      $ ns
  | otherwise
      = toUtf8ByteString
      . sanitize
      . nodeToHtml []
      . addTargetBlank
      $ MD.Node Nothing DOCUMENT ns

isInlineNode :: MD.Node -> Bool
isInlineNode (MD.Node _ tp _) = case tp of
  EMPH              -> True
  STRONG            -> True
  LINK _ _          -> True
  IMAGE _ _         -> True
  CUSTOM_INLINE _ _ -> True
  SOFTBREAK         -> True
  LINEBREAK         -> True
  TEXT _            -> True
  CODE _            -> True
  HTML_INLINE _     -> True
  _other            -> False

-- | Convert a Markdown structure to a string with formatting removed.
stringify :: [MD.Node] -> Text
stringify = T.concat . map go
  where
    go (MD.Node _ tp ns) = case tp of
      DOCUMENT          -> stringify ns
      THEMATIC_BREAK    -> stringify ns
      PARAGRAPH         -> stringify ns
      BLOCK_QUOTE       -> stringify ns
      CUSTOM_BLOCK _ _  -> stringify ns
      HEADING _         -> stringify ns
      LIST _            -> stringify ns
      ITEM              -> stringify ns
      EMPH              -> stringify ns
      STRONG            -> stringify ns
      LINK _ _          -> stringify ns
      IMAGE _ _         -> stringify ns
      CUSTOM_INLINE _ _ -> stringify ns
      CODE         xs   -> xs
      CODE_BLOCK _ xs   -> xs
      TEXT         xs   -> xs
      SOFTBREAK         -> " "
      LINEBREAK         -> " "
      HTML_BLOCK _      -> ""
      HTML_INLINE _     -> ""

-- | Extract everything before the first heading.
--
-- Note that if you render 'markdownBlockSource' of the produced Markdown
-- block, it won't necessarily parse into 'markdownBlockHtml' from the same
-- block. It's because rendered Markdown might depend on links that are
-- defined further in the tree.
extractPreface :: MarkdownTree -> MarkdownBlock
extractPreface = mkBlock . preface . markdownTreeStructure
  where
    mkBlock x = MarkdownBlock {
      markdownBlockSource   = getSource x,
      markdownBlockHtml     = renderMD (stripSource x),
      markdownBlockMarkdown = stripSource x }

-- | Flatten Markdown by concatenating all block elements.
extractInlines :: [MD.Node] -> [MD.Node]
extractInlines = concatMap go
  where
    go node@(MD.Node _ tp ns) = case tp of
      -- Block containers
      DOCUMENT          -> extractInlines ns
      BLOCK_QUOTE       -> extractInlines ns
      CUSTOM_BLOCK _ _  -> extractInlines ns
      LIST _            -> extractInlines ns
      ITEM              -> extractInlines ns
      -- Inline containers
      PARAGRAPH         -> ns
      HEADING _         -> ns
      IMAGE _ _         -> ns
      -- Inlines
      EMPH              -> [node]
      STRONG            -> [node]
      LINK _ _          -> [node]
      CUSTOM_INLINE _ _ -> [node]
      SOFTBREAK         -> [node]
      LINEBREAK         -> [node]
      TEXT _            -> [node]
      CODE _            -> [node]
      -- Other stuff
      THEMATIC_BREAK    -> []
      HTML_BLOCK xs     -> [MD.Node Nothing (CODE xs) []]
      HTML_INLINE xs    -> [MD.Node Nothing (CODE xs) []]
      CODE_BLOCK _ xs   -> [MD.Node Nothing (CODE xs) []]

-- | Convert 'LINK' to 'HTML_INLINE' with @target="_blank"@ attribute added.
--
-- It will cause the link to be opened in a new tab, which is the behavior
-- we want for links in user-submitted content.
addTargetBlank :: MD.Node -> MD.Node
addTargetBlank (MD.Node pos (LINK url title) ns) =
    MD.Node pos (HTML_INLINE blankLink) []
  where
    blankLink = toText $ renderText
      $ a_ ([href_ url, target_ "_blank"] ++ [title_ title | title /= ""])
      $ toHtmlRaw $ renderMD ns
addTargetBlank (MD.Node pos tp ns) = MD.Node pos tp (map addTargetBlank ns)

shortcutLinks :: MD.Node -> MD.Node
shortcutLinks node@(MD.Node pos (LINK url title) ns) | "@" <- T.take 1 url =
  -- %20s are possibly introduced by cmark (Pandoc definitely adds them,
  -- no idea about cmark but better safe than sorry) and so they need to
  -- be converted back to spaces
  case parseLink (T.replace "%20" " " url) of
    Left _err -> MD.Node pos (LINK url title) (map shortcutLinks ns)
    Right (shortcut, opt, text) -> do
      let text' = fromMaybe (stringify [node]) text
      let shortcuts = (["hk"], hackage) : allShortcuts
      case useShortcutFrom shortcuts shortcut opt text' of
        Success link ->
          MD.Node pos (LINK link title) (map shortcutLinks ns)
        Warning warnings link ->
          let warningText = "[warnings when processing shortcut link: " <>
                            toText (intercalate ", " warnings) <> "]"
              warningNode = MD.Node Nothing (TEXT warningText) []
          in  MD.Node pos (LINK link title)
                             (warningNode : map shortcutLinks ns)
        Failure err ->
          let errorText = "[error when processing shortcut link: " <>
                          toText err <> "]"
          in  MD.Node Nothing (TEXT errorText) []
shortcutLinks (MD.Node pos tp ns) =
  MD.Node pos tp (map shortcutLinks ns)

-- TODO: this should be in the shortcut-links package itself

-- | Parse a shortcut link. Allowed formats:
--
-- @
-- \@name
-- \@name:text
-- \@name(option)
-- \@name(option):text
-- @
parseLink :: Text -> Either String (Text, Maybe Text, Maybe Text)
parseLink = either (Left . show) Right . parse p ""
  where
    shortcut = some (alphaNumChar <|> char '-')
    opt      = char '(' *> some (noneOf [')']) <* char ')'
    text     = char ':' *> some anyChar
    p :: Parsec Void Text (Text, Maybe Text, Maybe Text)
    p = do
      _ <- char '@'
      (,,) <$> (toText <$> shortcut)
           <*> optional (toText <$> opt)
           <*> optional (toText <$> text)

toMarkdownInline :: Text -> MarkdownInline
toMarkdownInline s = MarkdownInline {
  markdownInlineSource   = s,
  markdownInlineHtml     = html,
  markdownInlineMarkdown = inlines }
  where
    inlines = extractInlines (parseMD s)
    html = renderMD inlines

toMarkdownBlock :: Text -> MarkdownBlock
toMarkdownBlock s = MarkdownBlock {
  markdownBlockSource   = s,
  markdownBlockHtml     = html,
  markdownBlockMarkdown = doc }
  where
    doc = parseMD s
    html = renderMD doc

toMarkdownTree :: Text -> Text -> MarkdownTree
toMarkdownTree idPrefix s = MarkdownTree {
  markdownTreeSource    = s,
  markdownTreeIdPrefix  = idPrefix,
  markdownTreeStructure = tree,
  markdownTreeTOC       = toc }
  where
    blocks :: [MD.Node]
    blocks = parseMD s
    --
    slugify :: Text -> Text
    slugify x = idPrefix <> makeSlug x
    --
    tree :: Document Text ByteString
    tree = renderContents . slugifyDocument slugify $
             nodesToDocument (WithSource s blocks)
    --
    toc :: Forest Heading
    toc = sections tree
            & each.each
            %~ (\Section{..} -> Heading (nodesToMdInline heading) headingAnn)

    nodesToMdInline :: WithSource [MD.Node] -> MarkdownInline
    nodesToMdInline (WithSource src nodes) = MarkdownInline
        { markdownInlineSource   = src
        , markdownInlineHtml     = html
        , markdownInlineMarkdown = inlines
        }
      where
        inlines = extractInlines nodes
        html = renderMD inlines

renderContents :: Document a b -> Document a ByteString
renderContents doc = doc {
  prefaceAnn = renderMD (stripSource (preface doc)),
  sections = over (each.each) renderSection (sections doc) }
  where
    renderSection sec = sec {
      contentAnn = renderMD (stripSource (content sec)) }

slugifyDocument :: (Text -> Text) -> Document a b -> Document Text b
slugifyDocument slugify doc = doc {
  sections = evalState ((each.each) process (sections doc)) mempty }
  where
    process :: Section a b -> State (Set Text) (Section Text b)
    process sec = do
      previousIds <- get
      let slug = until (`S.notMember` previousIds) (<> "_")
                   (slugify (stringify (stripSource (heading sec))))
      modify (S.insert slug)
      return sec{headingAnn = slug}

instance Show MarkdownInline where
  show = show . markdownInlineSource
instance Show MarkdownBlock where
  show = show . markdownBlockSource
instance Show MarkdownTree where
  show = show . markdownTreeSource
deriving instance Show Heading

instance Aeson.ToJSON MarkdownInline where
  toJSON md = Aeson.object [
    "text" Aeson..= markdownInlineSource md,
    "html" Aeson..= utf8ToText (markdownInlineHtml md) ]
instance Aeson.ToJSON MarkdownBlock where
  toJSON md = Aeson.object [
    "text" Aeson..= markdownBlockSource md,
    "html" Aeson..= utf8ToText (markdownBlockHtml md) ]
instance Aeson.ToJSON MarkdownTree where
  toJSON md = Aeson.object [
    "text" Aeson..= markdownTreeSource md ]

instance ToHtml MarkdownInline where
  toHtmlRaw = toHtml
  toHtml    = toHtmlRaw . markdownInlineHtml
instance ToHtml MarkdownBlock where
  toHtmlRaw = toHtml
  toHtml    = toHtmlRaw . markdownBlockHtml
instance ToHtml MarkdownTree where
  toHtmlRaw = toHtml
  toHtml    = toHtmlRaw . renderDoc . markdownTreeStructure
    where
      renderDoc Document{..} = BS.concat $
        prefaceAnn :
        map renderSection (concatMap flatten sections)
      renderSection Section{..} = toByteString . renderBS $ do
        mkH $ do
          span_ [id_ headingAnn] ""
          toHtmlRaw (renderMD (stripSource heading))
        toHtmlRaw contentAnn
        where
          mkH = case level of
            1 -> h1_; 2 -> h2_; 3 -> h3_;
            4 -> h4_; 5 -> h5_; 6 -> h6_;
            _other -> error "Markdown.toHtml: level > 6"

instance SafeCopy MarkdownInline where
  version = 0
  kind = base
  putCopy = contain . safePut . markdownInlineSource
  getCopy = contain $ toMarkdownInline <$> safeGet
instance SafeCopy MarkdownBlock where
  version = 0
  kind = base
  putCopy = contain . safePut . markdownBlockSource
  getCopy = contain $ toMarkdownBlock <$> safeGet
instance SafeCopy MarkdownTree where
  version = 0
  kind = base
  putCopy md = contain $ do
    safePut (markdownTreeIdPrefix md)
    safePut (markdownTreeSource md)
  getCopy = contain $
    toMarkdownTree <$> safeGet <*> safeGet

{'fraction_non_alphanumeric': 0.09362782636733707, 'fraction_numerical': 0.002377977509975414, 'mean_word_length': 2.3937901791820546, 'pattern_counts': {'":': 0, '<': 45, '<?xml version=': 0, '>': 211, 'https://': 2, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '2196935', 'n_tokens_mistral': 7618, 'n_tokens_neox': 7364, 'n_words': 2294}