module Util.Markdown
( Markdown
, HeaderLevel (..)
, nextHeaderLevel
, mdHeader
, mdSubsection
, mdSubsectionTitle
, mdBold
, mdItalic
, mdTicked
, mdRef
, mdLocalRef
, 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(..))
type Markdown = Builder
newtype HeaderLevel = HeaderLevel Int
nextHeaderLevel :: HeaderLevel -> HeaderLevel
nextHeaderLevel (HeaderLevel l) = HeaderLevel (l + 1)
mdHeader :: HeaderLevel -> Markdown -> Markdown
mdHeader (HeaderLevel lvl) text =
mconcat (replicate lvl "#") +| " " +| text |+ "\n\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
mdEscapeAnchor :: Text -> Markdown
mdEscapeAnchor = mdEscapeAnchorS . toString
mdRef :: Markdown -> Markdown -> Markdown
mdRef txt ref = "[" <> txt <> "](" <> ref <> ")"
mdLocalRef :: Markdown -> Text -> Markdown
mdLocalRef txt anchor = mdRef txt ("#" <> mdEscapeAnchor anchor)
mdAnchor :: Text -> Markdown
mdAnchor name = "<a name=\"" <> mdEscapeAnchor name <> "\"></a>\n\n"
mdSeparator :: Markdown
mdSeparator = "---\n\n"
mdSpoiler :: Markdown -> Markdown -> Markdown
mdSpoiler name contents =
mconcat $ intersperse "\n"
[ "<details>"
, " <summary>" <> htmlBold (build name) <> "</summary>"
, contents
, "</details>"
, "<p>"
]
where
htmlBold txt = "<b>" <> txt <> "</b>"
mdComment :: Builder -> Builder
mdComment commentText =
"<!---\n" +| commentText |+ "\n-->"
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"
}