-- | A small Markdown eDSL.
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(..))

-- | 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

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

-- | Turn text into valid anchor. Human-readability is not preserved.
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"

-- | 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.
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"
  }