-- 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 (Builder, 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 = 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
. (String
"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 Int
l) = Int -> HeaderLevel
HeaderLevel (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

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

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

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

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

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

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

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

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

-- | Turn text into valid anchor. Human-readability is not preserved.
mdEscapeAnchor :: ToAnchor anchor => anchor -> Markdown
mdEscapeAnchor :: forall anchor. ToAnchor anchor => anchor -> Builder
mdEscapeAnchor = String -> Builder
mdEscapeAnchorS (String -> Builder) -> (anchor -> String) -> anchor -> Builder
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 :: Builder -> Builder -> Builder
mdRef Builder
txt Builder
ref = Builder
"[" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
txt Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"](" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
ref Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
")"

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

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

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

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

mdComment :: Builder -> Builder
mdComment :: Builder -> Builder
mdComment Builder
commentText =
  Builder
"<!---\n" Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Builder
commentText Builder -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"\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 :: QuasiQuoter
md = QuasiQuoter
iub