Markdone.hs

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}

-- | A subset of markdown that only supports @#headings@ and code
-- fences.
--
-- All content must be in section headings with proper hierarchy,
-- anything else is rejected.

module Markdone where

import           Control.DeepSeq
import           Control.Monad.Catch
import           Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as S8
import           Data.Char
import           Data.Typeable
import           GHC.Generics

-- | A markdone token.
data Token
  = Heading !Int
            !ByteString
  | PlainLine !ByteString
  | BeginFence !ByteString
  | EndFence
  deriving (Show)

-- | A markdone document.
data Markdone
  = Section !ByteString
            ![Markdone]
  | CodeFence !ByteString
              !ByteString
  | PlainText !ByteString
  deriving (Show,Generic)
instance NFData Markdone

-- | Parse error.
data MarkdownError = NoFenceEnd | ExpectedSection
  deriving (Typeable,Show)
instance Exception MarkdownError

-- | Tokenize the bytestring.
tokenize :: ByteString -> [Token]
tokenize = map token . S8.lines
  where
    token line =
      if S8.isPrefixOf "#" line
        then let (hashes,title) = S8.span (== '#') line
             in Heading (S8.length hashes) (S8.dropWhile isSpace title)
        else if S8.isPrefixOf "```" line
               then if line == "```"
                      then EndFence
                      else BeginFence
                             (S8.dropWhile
                                (\c ->
                                    c == '`' || c == ' ')
                                line)
               else PlainLine line

-- | Parse into a forest.
parse :: (Functor m,MonadThrow m) => [Token] -> m [Markdone]
parse = go (0 :: Int)
  where
    go level =
      \case
        (Heading n label:rest) ->
          let (children,rest') =
                span
                  (\case
                     Heading nextN _ -> nextN > n
                     _ -> True)
                  rest
          in do childs <- go (level + 1) children
                siblings <- go level rest'
                return (Section label childs : siblings)
        (BeginFence label:rest)
          | level > 0 ->
            let (content,rest') =
                  (span
                     (\case
                        PlainLine {} -> True
                        _ -> False)
                     rest)
            in case rest' of
                 (EndFence:rest'') ->
                   fmap
                     (CodeFence
                        label
                        (S8.intercalate "\n" (map getPlain content)) :)
                     (go level rest'')
                 _ -> throwM NoFenceEnd
        PlainLine p:rest
          | level > 0 ->
            let (content,rest') =
                  (span
                     (\case
                        PlainLine {} -> True
                        _ -> False)
                     (PlainLine p : rest))
            in fmap
                 (PlainText
                    (S8.intercalate
                       "\n"
                       (filter (not . S8.null) (map getPlain content))) :)
                 (go level rest')
        [] -> return []
        _ -> throwM ExpectedSection
    getPlain (PlainLine x) = x
    getPlain _ = ""