-- 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 = " mdEscapeAnchor name <> "\">\n\n"
mdSeparator :: Markdown
mdSeparator = "---\n\n"
-- | Text which is hidden until clicked.
mdSpoiler :: Markdown -> Markdown -> Markdown
mdSpoiler name contents =
mconcat $ intersperse "\n"
[ "" <> htmlBold (build name) <> "
"
, contents
, "
" ] where -- Markdown's bold does not always work within spoiler header htmlBold txt = "" <> txt <> "" mdComment :: Builder -> Builder mdComment commentText = "" -- | 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" }