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 (Doc, build, (+|), (|+))
import Language.Haskell.TH.Quote (QuasiQuoter)
import Morley.Util.Interpolate (iub)
type Markdown = Doc
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) Doc
text =
[Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat (Int -> Doc -> [Doc]
forall a. Int -> a -> [a]
replicate Int
lvl Doc
"#") Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| Doc
" " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| Doc
text Doc -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
"\n\n"
mdToc :: ToAnchor anchor => HeaderLevel -> Markdown -> anchor -> Markdown
mdToc :: forall anchor.
ToAnchor anchor =>
HeaderLevel -> Doc -> anchor -> Doc
mdToc (HeaderLevel Int
lvl) Doc
text anchor
anchor =
[Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat (Int -> Doc -> [Doc]
forall a. Int -> a -> [a]
replicate (Int
lvl Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) Doc
" ") Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+|
Doc
"- " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| Doc -> anchor -> Doc
forall anchor. ToAnchor anchor => Doc -> anchor -> Doc
mdLocalRef Doc
text anchor
anchor Doc -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
"\n"
mdSubsectionTitle :: Markdown -> Markdown
mdSubsectionTitle :: Doc -> Doc
mdSubsectionTitle Doc
title = Doc -> Doc
mdBold (Doc
title Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
":")
mdSubsection :: Markdown -> Markdown -> Markdown
mdSubsection :: Doc -> Doc -> Doc
mdSubsection Doc
name Doc
txt = Doc -> Doc
mdSubsectionTitle Doc
name Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
" " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
txt
mdBold :: Markdown -> Markdown
mdBold :: Doc -> Doc
mdBold Doc
x = Doc
"**" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
x Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"**"
mdItalic :: Markdown -> Markdown
mdItalic :: Doc -> Doc
mdItalic Doc
x = Doc
"*" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
x Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"*"
mdTicked :: Markdown -> Markdown
mdTicked :: Doc -> Doc
mdTicked Doc
x = Doc
"`" Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| Doc
x Doc -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
"`"
mdEscapeAnchorS :: String -> Markdown
mdEscapeAnchorS :: String -> Doc
mdEscapeAnchorS = \case
[] -> Doc
""
Char
c : String
s -> Char -> Doc
escapeChar Char
c Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
mdEscapeAnchorS String
s
where
escapeChar :: Char -> Doc
escapeChar = \case
Char
' ' -> Doc
"-"
Char
'(' -> Doc
"lparen"
Char
')' -> Doc
"rparen"
Char
'[' -> Doc
"lbracket"
Char
']' -> Doc
"rbracket"
Char
'{' -> Doc
"lbrace"
Char
'}' -> Doc
"rbrace"
Char
',' -> Doc
"comma"
Char
';' -> Doc
"semicolon"
Char
':' -> Doc
"colon"
Char
'#' -> Doc
"hash"
Char
c | Bool -> Bool
forall a. Boolean a => a -> a
not (Char -> Bool
isAscii Char
c) -> Doc
"c" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Int -> Doc
forall a. Buildable a => a -> Doc
build (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c)
| Bool
otherwise -> String -> Doc
forall a. Buildable a => a -> Doc
build [Char
c]
mdEscapeAnchor :: ToAnchor anchor => anchor -> Markdown
mdEscapeAnchor :: forall anchor. ToAnchor anchor => anchor -> Doc
mdEscapeAnchor = String -> Doc
mdEscapeAnchorS (String -> Doc) -> (anchor -> String) -> anchor -> Doc
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 :: Doc -> Doc -> Doc
mdRef Doc
txt Doc
ref = Doc
"[" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
txt Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"](" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
ref Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
")"
mdLocalRef :: ToAnchor anchor => Markdown -> anchor -> Markdown
mdLocalRef :: forall anchor. ToAnchor anchor => Doc -> anchor -> Doc
mdLocalRef Doc
txt anchor
anchor = Doc -> Doc -> Doc
mdRef Doc
txt (Doc
"#" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> anchor -> Doc
forall anchor. ToAnchor anchor => anchor -> Doc
mdEscapeAnchor anchor
anchor)
mdAnchor :: ToAnchor anchor => anchor -> Markdown
mdAnchor :: forall anchor. ToAnchor anchor => anchor -> Doc
mdAnchor anchor
name = Doc
"<a name=\"" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> anchor -> Doc
forall anchor. ToAnchor anchor => anchor -> Doc
mdEscapeAnchor anchor
name Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"\"></a>\n\n"
mdSeparator :: Markdown
mdSeparator :: Doc
mdSeparator = Doc
"---\n\n"
mdSpoiler :: Markdown -> Markdown -> Markdown
mdSpoiler :: Doc -> Doc -> Doc
mdSpoiler Doc
name Doc
contents =
[Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse Doc
"\n"
[ Doc
"<p>"
, Doc
"<details>"
, Doc
" <summary>" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
forall {a}. (Semigroup a, IsString a) => a -> a
htmlBold (Doc -> Doc
forall a. Buildable a => a -> Doc
build Doc
name) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"</summary>"
, Doc
contents
, Doc
"</details>"
, Doc
"</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 :: Doc -> Doc
Doc
commentText =
Doc
"<!---\n" Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| Doc
commentText Doc -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
"\n-->"
md :: QuasiQuoter
md :: QuasiQuoter
md = QuasiQuoter
iub