content: {-# LANGUAGE DeriveGeneric #-}
  
  {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE OverloadedStrings #-}
  
  -- | 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.Char
  import           Data.Monoid            ( (<>) )
  import           Data.Text.Lazy         ( Text )
  import qualified Data.Text.Lazy         as TL
  import qualified Data.Text.Lazy.Builder as TB
  import qualified Data.Text.Lazy.IO      as TIO
  import           Data.Typeable
  
  import           GHC.Generics
  
  -- | A markdone token.
  data Token = Heading !Int !Text | PlainLine !Text | BeginFence !Text | EndFence
      deriving ( Show )
  
  -- | A markdone document.
  data Markdone =
      Section !Text ![Markdone] | CodeFence !Text !Text | PlainText !Text
      deriving ( Show, Generic )
  
  instance NFData Markdone
  
  -- | Parse error.
  data MarkdownError = NoFenceEnd | ExpectedSection
      deriving ( Typeable, Show )
  
  instance Exception MarkdownError
  
  -- | Tokenize the bytestring.
  tokenize :: Text -> [Token]
  tokenize = map token . TL.lines
    where
      token line
          | TL.isPrefixOf "#" line = let (hashes, title) = TL.span (== '#') line
                                     in
                                         Heading (fromIntegral $ TL.length hashes)
                                                 (TL.dropWhile isSpace title)
          | TL.isPrefixOf "```" line =
              if line == "```"
              then EndFence
              else BeginFence (TL.dropWhile (\c -> c == '`' || c == ' ') line)
          | otherwise = PlainLine line
  
  -- | Parse into a forest.
  parse :: 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
                                              (TL.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 (TL.intercalate "\n" (map getPlain content)) :)
                           (go level rest')
          [] -> return []
          _ -> throwM ExpectedSection
  
      getPlain (PlainLine x) = x
      getPlain _ = ""
  
  print :: [Markdone] -> TB.Builder
  print = mconcat . map (go 0)
    where
      go level = \case
          (Section heading children) ->
              let level' = level + 1
              in
                  TB.fromLazyText (TL.replicate level' "#") <> TB.singleton ' '
                  <> TB.fromLazyText heading <> TB.fromString "\n"
                  <> mconcat (map (go level') children)
          (CodeFence lang code) ->
              TB.fromString "``` " <> TB.fromLazyText lang <> TB.singleton '\n'
              <> TB.fromLazyText code <> TB.fromString "\n```\n"
          (PlainText text) -> TB.fromLazyText text <> TB.fromString "\n"
  