-- 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 Data.Char (isAscii)
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 { Anchor -> Text
unAnchor :: Text }

instance IsString Anchor where
  -- Avoiding collision with names assigned by autodoc engine
  fromString :: String -> Anchor
fromString = Text -> Anchor
Anchor (Text -> Anchor) -> (String -> Text) -> String -> Anchor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> (String -> String) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("manual-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>)

-- | 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 :: Anchor -> Anchor
toAnchor = Anchor -> Anchor
forall a. a -> a
id

instance ToAnchor Text where
  toAnchor :: Text -> Anchor
toAnchor = Text -> Anchor
Anchor

nextHeaderLevel :: HeaderLevel -> HeaderLevel
nextHeaderLevel :: HeaderLevel -> HeaderLevel
nextHeaderLevel (HeaderLevel l :: Int
l) = Int -> HeaderLevel
HeaderLevel (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)

mdHeader :: HeaderLevel -> Markdown -> Markdown
mdHeader :: HeaderLevel -> Markdown -> Markdown
mdHeader (HeaderLevel lvl :: Int
lvl) text :: Markdown
text =
  [Markdown] -> Markdown
forall a. Monoid a => [a] -> a
mconcat (Int -> Markdown -> [Markdown]
forall a. Int -> a -> [a]
replicate Int
lvl "#") Markdown -> Markdown -> Markdown
forall b. FromBuilder b => Markdown -> Markdown -> b
+| " " Markdown -> Markdown -> Markdown
forall b. FromBuilder b => Markdown -> Markdown -> b
+| Markdown
text Markdown -> Markdown -> Markdown
forall a b. (Buildable a, FromBuilder b) => a -> Markdown -> b
|+ "\n\n"

mdToc :: ToAnchor anchor => HeaderLevel -> Markdown -> anchor -> Markdown
mdToc :: HeaderLevel -> Markdown -> anchor -> Markdown
mdToc (HeaderLevel lvl :: Int
lvl) text :: Markdown
text anchor :: anchor
anchor =
  [Markdown] -> Markdown
forall a. Monoid a => [a] -> a
mconcat (Int -> Markdown -> [Markdown]
forall a. Int -> a -> [a]
replicate (Int
lvl Int -> Int -> Int
forall a. Num a => a -> a -> a
- 2) "  ") Markdown -> Markdown -> Markdown
forall b. FromBuilder b => Markdown -> Markdown -> b
+|
    "- " Markdown -> Markdown -> Markdown
forall b. FromBuilder b => Markdown -> Markdown -> b
+| Markdown -> anchor -> Markdown
forall anchor. ToAnchor anchor => Markdown -> anchor -> Markdown
mdLocalRef Markdown
text anchor
anchor Markdown -> Markdown -> Markdown
forall a b. (Buildable a, FromBuilder b) => a -> Markdown -> b
|+ "\n"

mdSubsectionTitle :: Markdown -> Markdown
mdSubsectionTitle :: Markdown -> Markdown
mdSubsectionTitle title :: Markdown
title = Markdown -> Markdown
mdBold (Markdown
title Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> ":")

mdSubsection :: Markdown -> Markdown -> Markdown
mdSubsection :: Markdown -> Markdown -> Markdown
mdSubsection name :: Markdown
name txt :: Markdown
txt = Markdown -> Markdown
mdSubsectionTitle Markdown
name Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> " " Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
txt

mdBold :: Markdown -> Markdown
mdBold :: Markdown -> Markdown
mdBold x :: Markdown
x = "**" Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
x Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> "**"

mdItalic :: Markdown -> Markdown
mdItalic :: Markdown -> Markdown
mdItalic x :: Markdown
x = "*" Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
x Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> "*"

mdTicked :: Markdown -> Markdown
mdTicked :: Markdown -> Markdown
mdTicked x :: Markdown
x = "`" Markdown -> Markdown -> Markdown
forall b. FromBuilder b => Markdown -> Markdown -> b
+| Markdown
x Markdown -> Markdown -> Markdown
forall a b. (Buildable a, FromBuilder b) => a -> Markdown -> b
|+ "`"

mdEscapeAnchorS :: String -> Markdown
mdEscapeAnchorS :: String -> Markdown
mdEscapeAnchorS = \case
  [] -> ""
  c :: Char
c : s :: String
s -> Char -> Markdown
escapeChar Char
c Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> String -> Markdown
mdEscapeAnchorS String
s
  where
    escapeChar :: Char -> Markdown
escapeChar = \case
      ' ' -> "-"
      '(' -> "lparen"
      ')' -> "rparen"
      '[' -> "lbracket"
      ']' -> "rbracket"
      '{' -> "lbrace"
      '}' -> "rbrace"
      ',' -> "comma"
      ';' -> "semicolon"
      ':' -> "colon"
      '#' -> "hash"
      c :: Char
c | Bool -> Bool
not (Char -> Bool
isAscii Char
c) -> "c" Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Int -> Markdown
forall p. Buildable p => p -> Markdown
build (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c)
        | Bool
otherwise -> String -> Markdown
forall p. Buildable p => p -> Markdown
build [Char
c]

-- | Turn text into valid anchor. Human-readability is not preserved.
mdEscapeAnchor :: ToAnchor anchor => anchor -> Markdown
mdEscapeAnchor :: anchor -> Markdown
mdEscapeAnchor = String -> Markdown
mdEscapeAnchorS (String -> Markdown) -> (anchor -> String) -> anchor -> Markdown
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> (anchor -> Text) -> anchor -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Anchor -> Text
unAnchor (Anchor -> Text) -> (anchor -> Anchor) -> anchor -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. anchor -> Anchor
forall anchor. ToAnchor anchor => anchor -> Anchor
toAnchor

mdRef :: Markdown -> Markdown -> Markdown
mdRef :: Markdown -> Markdown -> Markdown
mdRef txt :: Markdown
txt ref :: Markdown
ref = "[" Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
txt Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> "](" Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
ref Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> ")"

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

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

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

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

mdComment :: Builder -> Builder
mdComment :: Markdown -> Markdown
mdComment commentText :: Markdown
commentText =
  "<!---\n" Markdown -> Markdown -> Markdown
forall b. FromBuilder b => Markdown -> Markdown -> b
+| Markdown
commentText Markdown -> Markdown -> Markdown
forall a b. (Buildable a, FromBuilder b) => a -> Markdown -> b
|+ "\n-->"

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