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(..))
type Markdown = Builder
newtype = Int
newtype Anchor = Anchor { Anchor -> Text
unAnchor :: Text }
instance IsString Anchor where
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
<>)
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
(HeaderLevel Int
l) = Int -> HeaderLevel
HeaderLevel (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
mdHeader :: HeaderLevel -> Markdown -> Markdown
(HeaderLevel Int
lvl) 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 -> Markdown
forall b. FromBuilder b => Markdown -> Markdown -> b
+| Markdown
" " 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
|+ Markdown
"\n\n"
mdToc :: ToAnchor anchor => HeaderLevel -> Markdown -> anchor -> Markdown
mdToc :: HeaderLevel -> Markdown -> anchor -> Markdown
mdToc (HeaderLevel Int
lvl) Markdown
text 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
- Int
2) Markdown
" ") Markdown -> Markdown -> Markdown
forall b. FromBuilder b => Markdown -> Markdown -> b
+|
Markdown
"- " 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
|+ Markdown
"\n"
mdSubsectionTitle :: Markdown -> Markdown
mdSubsectionTitle :: Markdown -> Markdown
mdSubsectionTitle Markdown
title = Markdown -> Markdown
mdBold (Markdown
title Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
":")
mdSubsection :: Markdown -> Markdown -> Markdown
mdSubsection :: Markdown -> Markdown -> Markdown
mdSubsection Markdown
name Markdown
txt = Markdown -> Markdown
mdSubsectionTitle Markdown
name Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
" " Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
txt
mdBold :: Markdown -> Markdown
mdBold :: Markdown -> Markdown
mdBold Markdown
x = Markdown
"**" Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
x Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
"**"
mdItalic :: Markdown -> Markdown
mdItalic :: Markdown -> Markdown
mdItalic Markdown
x = Markdown
"*" Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
x Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
"*"
mdTicked :: Markdown -> Markdown
mdTicked :: Markdown -> Markdown
mdTicked Markdown
x = Markdown
"`" 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
|+ Markdown
"`"
mdEscapeAnchorS :: String -> Markdown
mdEscapeAnchorS :: String -> Markdown
mdEscapeAnchorS = \case
[] -> Markdown
""
Char
c : 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
Char
' ' -> Markdown
"-"
Char
'(' -> Markdown
"lparen"
Char
')' -> Markdown
"rparen"
Char
'[' -> Markdown
"lbracket"
Char
']' -> Markdown
"rbracket"
Char
'{' -> Markdown
"lbrace"
Char
'}' -> Markdown
"rbrace"
Char
',' -> Markdown
"comma"
Char
';' -> Markdown
"semicolon"
Char
':' -> Markdown
"colon"
Char
'#' -> Markdown
"hash"
Char
c | Bool -> Bool
not (Char -> Bool
isAscii Char
c) -> Markdown
"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]
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 Markdown
txt Markdown
ref = Markdown
"[" 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 -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
ref Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
")"
mdLocalRef :: ToAnchor anchor => Markdown -> anchor -> Markdown
mdLocalRef :: Markdown -> anchor -> Markdown
mdLocalRef Markdown
txt anchor
anchor = Markdown -> Markdown -> Markdown
mdRef Markdown
txt (Markdown
"#" 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 anchor
name = Markdown
"<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
<> Markdown
"\"></a>\n\n"
mdSeparator :: Markdown
mdSeparator :: Markdown
mdSeparator = Markdown
"---\n\n"
mdSpoiler :: Markdown -> Markdown -> Markdown
mdSpoiler :: Markdown -> Markdown -> Markdown
mdSpoiler Markdown
name 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 Markdown
"\n"
[ Markdown
"<details>"
, Markdown
" <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
<> Markdown
"</summary>"
, Markdown
contents
, Markdown
"</details>"
, Markdown
"<p>"
]
where
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
Markdown
commentText =
Markdown
"<!---\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
|+ Markdown
"\n-->"
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 = \String
s -> [|fromString @Markdown $ unindent $(quoteExp Interpolate.i s) |]
, quotePat :: String -> Q Pat
quotePat = \String
_ -> String -> Q Pat
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot be used at pattern position"
, quoteType :: String -> Q Type
quoteType = \String
_ -> String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot be used at type position"
, quoteDec :: String -> Q [Dec]
quoteDec = \String
_ -> String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot be used as declaration"
}