Markdown.hs

-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

-- | A small Markdown eDSL.
module Util.Markdown
  ( Markdown
  , HeaderLevel (..)
  , Anchor (..)
  , ToAnchor (..)
  , nextHeaderLevel
  , mdHeader
  , mdToc
  , mdSubsection
  , mdSubsectionTitle
  , mdBold
  , mdItalic
  , mdTicked
  , mdRef
  , mdLocalRef
  , mdEscapeAnchor
  , mdAnchor
  , mdSeparator
  , mdSpoiler
  , mdComment
  , md
  ) where

import qualified Data.String.Interpolate.IsString as Interpolate
import Data.String.Interpolate.Util (unindent)
import Fmt (Builder, build, (+|), (|+))

import Language.Haskell.TH.Quote (QuasiQuoter(..))

-- | A piece of markdown document.
--
-- This is opposed to 'Text' type, which in turn is not supposed to contain
-- markup elements.
type Markdown = Builder

-- | Level of header, starting from 1.
newtype HeaderLevel = HeaderLevel Int

-- | Anchor with given text.
newtype Anchor = Anchor { unAnchor :: Text }

instance IsString Anchor where
  -- Avoiding collision with names assigned by autodoc engine
  fromString = Anchor . fromString . ("manual-" <>)

-- | Picking anchor for various things.
class ToAnchor anchor where
  toAnchor :: anchor -> Anchor

instance ToAnchor Anchor where
  toAnchor = id

instance ToAnchor Text where
  toAnchor = Anchor

nextHeaderLevel :: HeaderLevel -> HeaderLevel
nextHeaderLevel (HeaderLevel l) = HeaderLevel (l + 1)

mdHeader :: HeaderLevel -> Markdown -> Markdown
mdHeader (HeaderLevel lvl) text =
  mconcat (replicate lvl "#") +| " " +| text |+ "\n\n"

mdToc :: ToAnchor anchor => HeaderLevel -> Markdown -> anchor -> Markdown
mdToc (HeaderLevel lvl) text anchor =
  mconcat (replicate (lvl - 2) "  ") +|
    "- " +| mdLocalRef text anchor |+ "\n"

mdSubsectionTitle :: Markdown -> Markdown
mdSubsectionTitle title = mdBold (title <> ":")

mdSubsection :: Markdown -> Markdown -> Markdown
mdSubsection name txt = mdSubsectionTitle name <> " " <> txt

mdBold :: Markdown -> Markdown
mdBold x = "**" <> x <> "**"

mdItalic :: Markdown -> Markdown
mdItalic x = "*" <> x <> "*"

mdTicked :: Markdown -> Markdown
mdTicked x = "`" +| x |+ "`"

mdEscapeAnchorS :: String -> Markdown
mdEscapeAnchorS = \case
  [] -> ""
  ' ' : s -> "-" <> mdEscapeAnchorS s
  '(' : s -> "lparen" <> mdEscapeAnchorS s
  ')' : s -> "rparen" <> mdEscapeAnchorS s
  '[' : s -> "lbracket" <> mdEscapeAnchorS s
  ']' : s -> "rbracket" <> mdEscapeAnchorS s
  '{' : s -> "lbrace" <> mdEscapeAnchorS s
  '}' : s -> "rbrace" <> mdEscapeAnchorS s
  ',' : s -> "comma" <> mdEscapeAnchorS s
  ';' : s -> "semicolon" <> mdEscapeAnchorS s
  ':' : s -> "colon" <> mdEscapeAnchorS s
  '#' : s -> "hash" <> mdEscapeAnchorS s
  c : s -> build (toText [c]) <> mdEscapeAnchorS s

-- | Turn text into valid anchor. Human-readability is not preserved.
mdEscapeAnchor :: ToAnchor anchor => anchor -> Markdown
mdEscapeAnchor = mdEscapeAnchorS . toString . unAnchor . toAnchor

mdRef :: Markdown -> Markdown -> Markdown
mdRef txt ref = "[" <> txt <> "](" <> ref <> ")"

mdLocalRef :: ToAnchor anchor => Markdown -> anchor -> Markdown
mdLocalRef txt anchor = mdRef txt ("#" <> mdEscapeAnchor anchor)

mdAnchor :: ToAnchor anchor => anchor -> Markdown
mdAnchor name = "<a name=\"" <> mdEscapeAnchor name <> "\"></a>\n\n"

mdSeparator :: Markdown
mdSeparator = "---\n\n"

-- | Text which is hidden until clicked.
mdSpoiler :: Markdown -> Markdown -> Markdown
mdSpoiler name contents =
  mconcat $ intersperse "\n"
    [ "<details>"
    , "  <summary>" <> htmlBold (build name) <> "</summary>"
    , contents
    , "</details>"
    , "<p>"
    ]
  where
    -- Markdown's bold does not always work within spoiler header
    htmlBold txt = "<b>" <> txt <> "</b>"

mdComment :: Builder -> Builder
mdComment commentText =
  "<!---\n" +| commentText |+ "\n-->"

-- | Quasi quoter for Markdown.
--
-- This supports interpolation via @#{expression}@ syntax.
md :: QuasiQuoter
md = QuasiQuoter
  { quoteExp = \s -> [|fromString @Markdown $ unindent $(quoteExp Interpolate.i s) |]
  , quotePat = \_ -> fail "Cannot be used at pattern position"
  , quoteType = \_ -> fail "Cannot be used at type position"
  , quoteDec = \_ -> fail "Cannot be used as declaration"
  }