Markdown.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wall #-}

{- | The markdown of the RePL training manual template, and its Flat ODF text
in the styles of the document templates.

The markdown is a small part of markdown: headings (@#@ to @####@),
paragraphs, bulleted lists (@-@, nested by two spaces), numbered lists
(@1.@), pipe tables with a header row, @**strong**@, @*emphasis*@, and a
backslash before a character to write it as it is.
-}
module ReOC.Render.Markdown (
  parseMarkdown,
  escapeMarkdown,
  inline,
  renderBlocks,
) where

import Data.Char (isDigit, isSpace)
import Data.Maybe (isJust, mapMaybe)
import Data.Text (Text)
import qualified Data.Text as Text
import ReOC.Render.Markdown.Block (Block (..))
import ReOC.Render.Text (escapeXml)

{- $setup
>>> :set -XOverloadedStrings
-}

{- | Text written so that markdown shows it as it is.

>>> escapeMarkdown "a*b|c"
"a\\*b\\|c"
-}
escapeMarkdown :: Text -> Text
escapeMarkdown =
  Text.concatMap
    ( \c ->
        if c `elem` ("\\*|#-." :: String)
          then Text.pack ['\\', c]
          else if c == '\n' || c == '\r' then " " else Text.singleton c
    )

{- | The blocks of markdown.

>>> parseMarkdown "# Title\n\nSome *text*.\n\n- one\n  - two\n\n| a | b |\n|---|---|\n| 1 | 2 |\n"
[Heading 1 "Title",Paragraph "Some *text*.",Bullets [(0,"one"),(1,"two")],Table ["a","b"] [["1","2"]]]
-}
parseMarkdown :: Text -> [Block]
parseMarkdown =
  go . Text.lines
 where
  go = \case
    [] -> []
    l : ls
      | Text.all isSpace l -> go ls
      | Just (n, t) <- heading l -> Heading n t : go ls
      | Just _ <- bullet l ->
          let (items, rest) = span (isJust . bullet) (l : ls)
           in Bullets (mapMaybe bullet items) : go rest
      | Just _ <- number l ->
          let (items, rest) = span (isJust . number) (l : ls)
           in Numbered (mapMaybe number items) : go rest
      | "|" `Text.isPrefixOf` Text.stripStart l ->
          let (rows, rest) = span (\x -> "|" `Text.isPrefixOf` Text.stripStart x) (l : ls)
           in table rows : go rest
      | otherwise ->
          let (para, rest) = break ends (l : ls)
           in Paragraph (Text.unwords (map Text.strip para)) : go rest
  ends x =
    Text.all isSpace x || isJust (heading x) || isJust (bullet x) || isJust (number x) || "|" `Text.isPrefixOf` Text.stripStart x
  heading l =
    let (hashes, rest) = Text.span (== '#') l
        n = Text.length hashes
     in if n >= 1 && n <= 6 && " " `Text.isPrefixOf` rest then Just (min 4 n, Text.strip rest) else Nothing
  bullet l =
    let (indent, rest) = Text.span (== ' ') l
     in case Text.uncons rest of
          Just (c, r) | c `elem` ("-*" :: String), " " `Text.isPrefixOf` r -> Just (Text.length indent `div` 2, Text.strip r)
          _ -> Nothing
  number l =
    let (digits, rest) = Text.span isDigit (Text.stripStart l)
     in if not (Text.null digits) && ". " `Text.isPrefixOf` rest then Just (Text.strip (Text.drop 2 rest)) else Nothing
  table rows =
    let cells = map splitRow rows
        isRule = all (\c -> not (Text.null c) && Text.all (`elem` ("-: " :: String)) c)
     in case cells of
          h : r : rest | isRule r -> Table h rest
          h : rest -> Table h (filter (not . isRule) rest)
          [] -> Table [] []
  splitRow r =
    let inner = Text.dropWhileEnd (== '|') (Text.dropWhile (== '|') (Text.strip r))
     in map Text.strip (splitUnescaped inner)
  splitUnescaped t =
    case Text.uncons t of
      Nothing -> [""]
      Just ('\\', rest) ->
        case Text.uncons rest of
          Just (c, more) -> prepend (Text.pack ['\\', c]) (splitUnescaped more)
          Nothing -> ["\\"]
      Just ('|', rest) -> "" : splitUnescaped rest
      Just (c, rest) -> prepend (Text.singleton c) (splitUnescaped rest)
  prepend p = \case
    x : xs -> (p <> x) : xs
    [] -> [p]

{- | Inline markdown as Flat ODF text.

>>> inline "a **b** *c* \\* & d"
"a <text:span text:style-name=\"Strong_20_Emphasis\">b</text:span> <text:span text:style-name=\"Emphasis\">c</text:span> * &amp; d"
-}
inline :: Text -> Text
inline =
  go False False
 where
  go strong em t =
    case Text.uncons t of
      Nothing -> close strong em
      Just ('\\', rest) | Just (c, more) <- Text.uncons rest -> escapeXml (Text.singleton c) <> go strong em more
      Just ('*', rest)
        | "*" `Text.isPrefixOf` rest -> (if strong then "</text:span>" else "<text:span text:style-name=\"Strong_20_Emphasis\">") <> go (not strong) em (Text.drop 1 rest)
        | otherwise -> (if em then "</text:span>" else "<text:span text:style-name=\"Emphasis\">") <> go strong (not em) rest
      Just (c, rest) -> escapeXml (Text.singleton c) <> go strong em rest
  close strong em =
    Text.replicate (fromEnum strong + fromEnum em) "</text:span>"

{- | Blocks as Flat ODF text: the body, and the entries of its table of
contents (its headings of levels 1 and 2), which link to the headings.
-}
renderBlocks :: [Block] -> (Text, Text)
renderBlocks blocks =
  let numbered = zip [1 :: Int ..] blocks
      body = Text.concat (map block numbered)
      contents =
        Text.concat
          [ "<text:p text:style-name=\"Contents_20_" <> Text.pack (show n) <> "\"><text:a xlink:type=\"simple\" xlink:href=\"#" <> anchor i <> "\" text:style-name=\"Index_20_Link\" text:visited-style-name=\"Index_20_Link\">" <> inline t <> "</text:a></text:p>"
          | (i, Heading n t) <- numbered
          , n <= 2
          ]
   in (body, contents)
 where
  anchor i =
    "RTHeading" <> Text.pack (show i)
  block (i, b) =
    case b of
      Heading n t ->
        let l = Text.pack (show n)
         in "<text:h text:style-name=\"Heading_20_" <> l <> "\" text:outline-level=\"" <> l <> "\"><text:bookmark text:name=\"" <> anchor i <> "\"/>" <> inline t <> "</text:h>"
      Paragraph t ->
        "<text:p text:style-name=\"Standard\">" <> inline t <> "</text:p>"
      Bullets items ->
        bullets 0 items
      Numbered items ->
        "<text:list text:style-name=\"WWNum7\">"
          <> Text.concat ["<text:list-item><text:p text:style-name=\"RTNumbered\">" <> inline t <> "</text:p></text:list-item>" | t <- items]
          <> "</text:list>"
      Table header rows ->
        let width = maximum (length header : map length rows)
            pad r = take width (r <> repeat "")
            cell style pstyle t = "<table:table-cell table:style-name=\"" <> style <> "\" office:value-type=\"string\"><text:p text:style-name=\"" <> pstyle <> "\">" <> inline t <> "</text:p></table:table-cell>"
            row style pstyle r = "<table:table-row>" <> Text.concat (map (cell style pstyle) (pad r)) <> "</table:table-row>"
            headerRow =
              if all Text.null header
                then ""
                else "<table:table-header-rows>" <> row "RTHeadCell" "Table_20_Header" header <> "</table:table-header-rows>"
         in "<table:table table:name=\"RTTable"
              <> Text.pack (show i)
              <> "\" table:style-name=\"RTTable\"><table:table-column table:number-columns-repeated=\""
              <> Text.pack (show width)
              <> "\"/>"
              <> headerRow
              <> Text.concat (map (row "RTCell" "Table_20_text") rows)
              <> "</table:table>"
  -- a list of the items at a level, each with the items under it
  bullets :: Int -> [(Int, Text)] -> Text
  bullets level items =
    "<text:list" <> (if level == 0 then " text:style-name=\"WWNum3\"" else "") <> ">" <> Text.concat (items' level items) <> "</text:list>"
  items' level = \case
    [] -> []
    (_, t) : rest ->
      let (under, after) = span (\(l, _) -> l > level) rest
          style = if level == 0 then "P101" else "P102"
       in ("<text:list-item><text:p text:style-name=\"" <> style <> "\">" <> inline t <> "</text:p>" <> (if null under then "" else bullets (level + 1) under) <> "</text:list-item>")
            : items' level after