1{-# LANGUAGE DeriveGeneric #-}
2
3{-# LANGUAGE LambdaCase #-}
4{-# LANGUAGE OverloadedStrings #-}
5
6-- | A subset of markdown that only supports @#headings@ and code
7-- fences.
8--
9-- All content must be in section headings with proper hierarchy,
10-- anything else is rejected.
11module Markdone where
12
13import           Control.DeepSeq
14import           Control.Monad.Catch
15
16import           Data.ByteString.Builder    as B
17import qualified Data.ByteString.Char8      as S8
18import           Data.ByteString.Lazy       ( ByteString )
19import qualified Data.ByteString.Lazy.Char8 as L8
20import           Data.Char
21import           Data.Monoid                ( (<>) )
22import           Data.Typeable
23
24import           GHC.Generics
25
26-- | A markdone token.
27data Token = Heading !Int !ByteString
28           | PlainLine !ByteString
29           | BeginFence !ByteString
30           | EndFence
31    deriving ( Show )
32
33-- | A markdone document.
34data Markdone = Section !ByteString ![Markdone]
35              | CodeFence !ByteString !ByteString
36              | PlainText !ByteString
37    deriving ( Show, Generic )
38
39instance NFData Markdone
40
41-- | Parse error.
42data MarkdownError = NoFenceEnd | ExpectedSection
43    deriving ( Typeable, Show )
44
45instance Exception MarkdownError
46
47-- | Tokenize the bytestring.
48tokenize :: ByteString -> [Token]
49tokenize = map token . L8.lines
50  where
51    token line
52        | L8.isPrefixOf "#" line = let (hashes, title) = L8.span (== '#') line
53                                   in
54                                       Heading (fromIntegral $ L8.length hashes)
55                                               (L8.dropWhile isSpace title)
56        | L8.isPrefixOf "```" line =
57            if line == "```"
58            then EndFence
59            else BeginFence (L8.dropWhile (\c -> c == '`' || c == ' ') line)
60        | otherwise = PlainLine line
61
62-- | Parse into a forest.
63parse :: MonadThrow m => [Token] -> m [Markdone]
64parse = go (0 :: Int)
65  where
66    go level = \case
67        (Heading n label : rest) ->
68            let (children, rest') = span (\case
69                                              Heading nextN _ -> nextN > n
70                                              _ -> True)
71                                         rest
72            in
73                do
74                    childs <- go (level + 1) children
75                    siblings <- go level rest'
76                    return (Section label childs : siblings)
77        (BeginFence label : rest)
78            | level > 0 ->
79                let (content, rest') = span (\case
80                                                 PlainLine{} -> True
81                                                 _ -> False)
82                                            rest
83                in
84                    case rest' of
85                        (EndFence : rest'') ->
86                            fmap (CodeFence label
87                                            (L8.intercalate "\n"
88                                                            (map getPlain
89                                                                 content)) :)
90                                 (go level rest'')
91                        _ -> throwM NoFenceEnd
92        PlainLine p : rest
93            | level > 0 ->
94                let (content, rest') = span (\case
95                                                 PlainLine{} -> True
96                                                 _ -> False)
97                                            (PlainLine p : rest)
98                in
99                    fmap (PlainText (L8.intercalate "\n" (map getPlain content)) :)
100                         (go level rest')
101        [] -> return []
102        _ -> throwM ExpectedSection
103
104    getPlain (PlainLine x) = x
105    getPlain _ = ""
106
107print :: [Markdone] -> B.Builder
108print = mconcat . map (go (0 :: Int))
109  where
110    go level = \case
111        (Section heading children) ->
112            let level' = level + 1
113            in
114                B.byteString (S8.replicate level' '#') <> B.char7 ' '
115                <> B.lazyByteString heading <> B.byteString "\n"
116                <> mconcat (map (go level') children)
117        (CodeFence lang code) -> B.byteString "``` " <> B.lazyByteString lang
118            <> B.char7 '\n' <> B.lazyByteString code <> B.byteString "\n```\n"
119        (PlainText text) -> B.lazyByteString text <> B.byteString "\n"
120