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