Markdown.hs

-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

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

import Prelude hiding (try)

import Data.Char (isAscii)
import Fmt (Doc, build, (+|), (|+))
import Language.Haskell.TH.Quote (QuasiQuoter)

import Morley.Util.Interpolate (iub)

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

-- | 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.
--
-- What you want here is potentially adding some prefix to ensure anchors uniqueness.
-- It is not necessary to preprocess the text to fit anchor format - that will happen
-- when the anchor is embedded into 'Markdown'.
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
  [] -> ""
  c : s -> escapeChar c <> mdEscapeAnchorS s
  where
    escapeChar = \case
      ' ' -> "-"
      '(' -> "lparen"
      ')' -> "rparen"
      '[' -> "lbracket"
      ']' -> "rbracket"
      '{' -> "lbrace"
      '}' -> "rbrace"
      ',' -> "comma"
      ';' -> "semicolon"
      ':' -> "colon"
      '#' -> "hash"
      c | not (isAscii c) -> "c" <> build (fromEnum c)
        | otherwise -> build [c]

-- | 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"
    [ "<p>"
    , "<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 :: Doc -> Doc
mdComment commentText =
  "<!---\n" +| commentText |+ "\n-->"

-- | Quasi quoter for Markdown.
--
-- This supports interpolation via @#{name}@ syntax.
--
-- Please note that we previously supported expressions inside interpolated splices. This is
-- no longer the case. Only literal variable names can be used.
--
-- 'md' is implemented in terms of 'iub', see "Morley.Util.Interpolate" for more
-- information on how interpolation works.
md :: QuasiQuoter
md = iub