{-# LANGUAGE OverloadedStrings #-}
module Cheapskate.Parse (
         markdown
       ) where
import Cheapskate.ParserCombinators
import Cheapskate.Util
import Cheapskate.Inlines
import Cheapskate.Types
import Data.Char hiding (Space)
import qualified Data.Set as Set
import Prelude hiding (takeWhile)
import Data.Maybe (mapMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Monoid
import Data.Foldable (toList)
import Data.Sequence ((|>), viewr, ViewR(..), singleton, Seq)
import qualified Data.Sequence as Seq
import Control.Monad.RWS
import Control.Applicative
import Control.Monad
import qualified Data.Map as M
import Data.List (intercalate)

import Debug.Trace

-- | Parses the input as a markdown document.  Note that 'Doc' is an instance
-- of 'ToMarkup', so the document can be converted to 'Html' using 'toHtml'.
-- A simple 'Text' to 'Html' filter would be
--
-- > markdownToHtml :: Text -> Html
-- > markdownToHtml = toHtml . markdown def
markdown :: Options -> Text -> Doc
markdown :: Options -> Text -> Doc
markdown Options
opts
  | Options -> Bool
debug Options
opts = (\(Container, ReferenceMap)
x -> [Char] -> Doc -> Doc
forall a. [Char] -> a -> a
trace ((Container, ReferenceMap) -> [Char]
forall a. Show a => a -> [Char]
show (Container, ReferenceMap)
x) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Options -> Blocks -> Doc
Doc Options
opts Blocks
forall a. Monoid a => a
mempty) ((Container, ReferenceMap) -> Doc)
-> (Text -> (Container, ReferenceMap)) -> Text -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> (Container, ReferenceMap)
processLines
  | Bool
otherwise  = Options -> Blocks -> Doc
Doc Options
opts (Blocks -> Doc) -> (Text -> Blocks) -> Text -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Container, ReferenceMap) -> Blocks
processDocument ((Container, ReferenceMap) -> Blocks)
-> (Text -> (Container, ReferenceMap)) -> Text -> Blocks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> (Container, ReferenceMap)
processLines

-- General parsing strategy:
--
-- Step 1:  processLines
--
-- We process the input line by line.  Each line modifies the
-- container stack, by adding a leaf to the current open container,
-- sometimes after closing old containers and/or opening new ones.
--
-- To open a container is to add it to the top of the container stack,
-- so that new content will be added under this container.
-- To close a container is to remove it from the container stack and
-- make it a child of the container above it on the container stack.
--
-- When all the input has been processed, we close all open containers
-- except the root (Document) container.  At this point we should also
-- have a ReferenceMap containing any defined link references.
--
-- Step 2:  processDocument
--
-- We then convert this container structure into an AST.  This principally
-- involves (a) gathering consecutive ListItem containers into lists, (b)
-- gathering TextLine nodes that don't belong to verbatim containers into
-- paragraphs, and (c) parsing the inline contents of non-verbatim TextLines.

--------

-- Container stack definitions:

data ContainerStack =
  ContainerStack Container {- top -} [Container] {- rest -}

type LineNumber   = Int

-- Generic type for a container or a leaf.
data Elt = C Container
         | L LineNumber Leaf
         deriving Int -> Elt -> ShowS
[Elt] -> ShowS
Elt -> [Char]
(Int -> Elt -> ShowS)
-> (Elt -> [Char]) -> ([Elt] -> ShowS) -> Show Elt
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Elt -> ShowS
showsPrec :: Int -> Elt -> ShowS
$cshow :: Elt -> [Char]
show :: Elt -> [Char]
$cshowList :: [Elt] -> ShowS
showList :: [Elt] -> ShowS
Show

data Container = Container{
                     Container -> ContainerType
containerType :: ContainerType
                   , Container -> Seq Elt
children      :: Seq Elt
                   }

data ContainerType = Document
                   | BlockQuote
                   | ListItem { ContainerType -> Int
markerColumn :: Int
                              , ContainerType -> Int
padding      :: Int
                              , ContainerType -> ListType
listType     :: ListType }
                   | FencedCode { ContainerType -> Int
startColumn :: Int
                                , ContainerType -> Text
fence :: Text
                                , ContainerType -> Text
info :: Text }
                   | IndentedCode
                   | RawHtmlBlock
                   | Reference
                   deriving (ContainerType -> ContainerType -> Bool
(ContainerType -> ContainerType -> Bool)
-> (ContainerType -> ContainerType -> Bool) -> Eq ContainerType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ContainerType -> ContainerType -> Bool
== :: ContainerType -> ContainerType -> Bool
$c/= :: ContainerType -> ContainerType -> Bool
/= :: ContainerType -> ContainerType -> Bool
Eq, Int -> ContainerType -> ShowS
[ContainerType] -> ShowS
ContainerType -> [Char]
(Int -> ContainerType -> ShowS)
-> (ContainerType -> [Char])
-> ([ContainerType] -> ShowS)
-> Show ContainerType
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ContainerType -> ShowS
showsPrec :: Int -> ContainerType -> ShowS
$cshow :: ContainerType -> [Char]
show :: ContainerType -> [Char]
$cshowList :: [ContainerType] -> ShowS
showList :: [ContainerType] -> ShowS
Show)

instance Show Container where
  show :: Container -> [Char]
show Container
c = ContainerType -> [Char]
forall a. Show a => a -> [Char]
show (Container -> ContainerType
containerType Container
c) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
    Int -> ShowS
nest Int
2 ([Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n" ((Elt -> [Char]) -> [Elt] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Elt -> [Char]
showElt ([Elt] -> [[Char]]) -> [Elt] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ Seq Elt -> [Elt]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq Elt -> [Elt]) -> Seq Elt -> [Elt]
forall a b. (a -> b) -> a -> b
$ Container -> Seq Elt
children Container
c))

nest :: Int -> String -> String
nest :: Int -> ShowS
nest Int
num = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n" ([[Char]] -> [Char]) -> ([Char] -> [[Char]]) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate Int
num Char
' ') [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++) ([[Char]] -> [[Char]])
-> ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
lines

showElt :: Elt -> String
showElt :: Elt -> [Char]
showElt (C Container
c) = Container -> [Char]
forall a. Show a => a -> [Char]
show Container
c
showElt (L Int
_ (TextLine Text
s)) = Text -> [Char]
forall a. Show a => a -> [Char]
show Text
s
showElt (L Int
_ Leaf
lf) = Leaf -> [Char]
forall a. Show a => a -> [Char]
show Leaf
lf

-- Scanners that must be satisfied if the current open container
-- is to be continued on a new line (ignoring lazy continuations).
containerContinue :: Container -> Scanner
containerContinue :: Container -> Scanner
containerContinue Container
c =
  case Container -> ContainerType
containerType Container
c of
       ContainerType
BlockQuote     -> Scanner
scanNonindentSpace Scanner -> Scanner -> Scanner
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Scanner
scanBlockquoteStart
       ContainerType
IndentedCode   -> Scanner
scanIndentSpace
       FencedCode{startColumn :: ContainerType -> Int
startColumn = Int
col} ->
                         Int -> Scanner
scanSpacesToColumn Int
col
       ContainerType
RawHtmlBlock   -> Scanner -> Scanner
forall a. Parser a -> Scanner
nfb Scanner
scanBlankline
       li :: ContainerType
li@ListItem{}  -> Scanner
scanBlankline
                         Scanner -> Scanner -> Scanner
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                         (do Int -> Scanner
scanSpacesToColumn
                                (ContainerType -> Int
markerColumn ContainerType
li Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                             Int -> (Char -> Bool) -> Parser Text
upToCountChars (ContainerType -> Int
padding ContainerType
li Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                                (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
' ')
                             () -> Scanner
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
       Reference{}    -> Scanner -> Scanner
forall a. Parser a -> Scanner
nfb Scanner
scanBlankline Scanner -> Scanner -> Scanner
forall a b. Parser a -> Parser b -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                         Scanner -> Scanner
forall a. Parser a -> Scanner
nfb (Scanner
scanNonindentSpace Scanner -> Scanner -> Scanner
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Scanner
scanReference)
       ContainerType
_              -> () -> Scanner
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
{-# INLINE containerContinue #-}

-- Defines parsers that open new containers.
containerStart :: Bool -> Parser ContainerType
containerStart :: Bool -> Parser ContainerType
containerStart Bool
_lastLineIsText = Scanner
scanNonindentSpace Scanner -> Parser ContainerType -> Parser ContainerType
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
   (  (ContainerType
BlockQuote ContainerType -> Scanner -> Parser ContainerType
forall a b. a -> Parser b -> Parser a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Scanner
scanBlockquoteStart)
  Parser ContainerType
-> Parser ContainerType -> Parser ContainerType
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ContainerType
parseListMarker
   )

-- Defines parsers that open new verbatim containers (containers
-- that take only TextLine and BlankLine as children).
verbatimContainerStart :: Bool -> Parser ContainerType
verbatimContainerStart :: Bool -> Parser ContainerType
verbatimContainerStart Bool
lastLineIsText = Scanner
scanNonindentSpace Scanner -> Parser ContainerType -> Parser ContainerType
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
   (  Parser ContainerType
parseCodeFence
  Parser ContainerType
-> Parser ContainerType -> Parser ContainerType
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Bool -> Scanner
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not Bool
lastLineIsText) Scanner -> Parser ContainerType -> Parser ContainerType
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (ContainerType
IndentedCode ContainerType -> Parser Char -> Parser ContainerType
forall a b. a -> Parser b -> Parser a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser Char
char Char
' ' Parser ContainerType -> Scanner -> Parser ContainerType
forall a b. Parser a -> Parser b -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Scanner -> Scanner
forall a. Parser a -> Scanner
nfb Scanner
scanBlankline))
  Parser ContainerType
-> Parser ContainerType -> Parser ContainerType
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Bool -> Scanner
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not Bool
lastLineIsText) Scanner -> Parser ContainerType -> Parser ContainerType
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (ContainerType
RawHtmlBlock ContainerType -> Scanner -> Parser ContainerType
forall a b. a -> Parser b -> Parser a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Scanner
parseHtmlBlockStart))
  Parser ContainerType
-> Parser ContainerType -> Parser ContainerType
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Bool -> Scanner
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not Bool
lastLineIsText) Scanner -> Parser ContainerType -> Parser ContainerType
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (ContainerType
Reference ContainerType -> Scanner -> Parser ContainerType
forall a b. a -> Parser b -> Parser a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Scanner
scanReference))
   )

-- Leaves of the container structure (they don't take children).
data Leaf = TextLine Text
          | BlankLine Text
          | ATXHeader Int Text
          | SetextHeader Int Text
          | Rule
          deriving (Int -> Leaf -> ShowS
[Leaf] -> ShowS
Leaf -> [Char]
(Int -> Leaf -> ShowS)
-> (Leaf -> [Char]) -> ([Leaf] -> ShowS) -> Show Leaf
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Leaf -> ShowS
showsPrec :: Int -> Leaf -> ShowS
$cshow :: Leaf -> [Char]
show :: Leaf -> [Char]
$cshowList :: [Leaf] -> ShowS
showList :: [Leaf] -> ShowS
Show)

type ContainerM = RWS () ReferenceMap ContainerStack

-- Close the whole container stack, leaving only the root Document container.
closeStack :: ContainerM Container
closeStack :: ContainerM Container
closeStack = do
  ContainerStack Container
top [Container]
rest  <- RWST () ReferenceMap ContainerStack Identity ContainerStack
forall s (m :: * -> *). MonadState s m => m s
get
  if [Container] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Container]
rest
     then Container -> ContainerM Container
forall a. a -> RWST () ReferenceMap ContainerStack Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Container
top
     else ContainerM ()
closeContainer ContainerM () -> ContainerM Container -> ContainerM Container
forall a b.
RWST () ReferenceMap ContainerStack Identity a
-> RWST () ReferenceMap ContainerStack Identity b
-> RWST () ReferenceMap ContainerStack Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ContainerM Container
closeStack

-- Close the top container on the stack.  If the container is a Reference
-- container, attempt to parse the reference and update the reference map.
-- If it is a list item container, move a final BlankLine outside the list
-- item.
closeContainer :: ContainerM ()
closeContainer :: ContainerM ()
closeContainer = do
  ContainerStack Container
top [Container]
rest <- RWST () ReferenceMap ContainerStack Identity ContainerStack
forall s (m :: * -> *). MonadState s m => m s
get
  case Container
top of
       (Container Reference{} Seq Elt
cs'') ->
         case Parser (Text, Text, Text)
-> Text -> Either ParseError (Text, Text, Text)
forall a. Parser a -> Text -> Either ParseError a
parse Parser (Text, Text, Text)
pReference
               (Text -> Text
T.strip (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
joinLines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Elt -> Text) -> [Elt] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Elt -> Text
extractText ([Elt] -> [Text]) -> [Elt] -> [Text]
forall a b. (a -> b) -> a -> b
$ Seq Elt -> [Elt]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Elt
cs'') of
              Right (Text
lab, Text
lnk, Text
tit) -> do
                ReferenceMap -> ContainerM ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Text -> (Text, Text) -> ReferenceMap
forall k a. k -> a -> Map k a
M.singleton (Text -> Text
normalizeReference Text
lab) (Text
lnk, Text
tit))
                case [Container]
rest of
                    (Container ContainerType
ct' Seq Elt
cs' : [Container]
rs) ->
                      ContainerStack -> ContainerM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ContainerStack -> ContainerM ())
-> ContainerStack -> ContainerM ()
forall a b. (a -> b) -> a -> b
$ Container -> [Container] -> ContainerStack
ContainerStack (ContainerType -> Seq Elt -> Container
Container ContainerType
ct' (Seq Elt
cs' Seq Elt -> Elt -> Seq Elt
forall a. Seq a -> a -> Seq a
|> Container -> Elt
C Container
top)) [Container]
rs
                    [] -> () -> ContainerM ()
forall a. a -> RWST () ReferenceMap ContainerStack Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              Left ParseError
_ -> -- pass over in silence if ref doesn't parse?
                        case [Container]
rest of
                             (Container
c:[Container]
cs) -> ContainerStack -> ContainerM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ContainerStack -> ContainerM ())
-> ContainerStack -> ContainerM ()
forall a b. (a -> b) -> a -> b
$ Container -> [Container] -> ContainerStack
ContainerStack Container
c [Container]
cs
                             []     -> () -> ContainerM ()
forall a. a -> RWST () ReferenceMap ContainerStack Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
       (Container li :: ContainerType
li@ListItem{} Seq Elt
cs'') ->
         case [Container]
rest of
              -- move final BlankLine outside of list item
              (Container ContainerType
ct' Seq Elt
cs' : [Container]
rs) ->
                       case Seq Elt -> ViewR Elt
forall a. Seq a -> ViewR a
viewr Seq Elt
cs'' of
                            (Seq Elt
zs :> b :: Elt
b@(L Int
_ BlankLine{})) ->
                              ContainerStack -> ContainerM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ContainerStack -> ContainerM ())
-> ContainerStack -> ContainerM ()
forall a b. (a -> b) -> a -> b
$ Container -> [Container] -> ContainerStack
ContainerStack
                                   (if Seq Elt -> Bool
forall a. Seq a -> Bool
Seq.null Seq Elt
zs
                                       then ContainerType -> Seq Elt -> Container
Container ContainerType
ct' (Seq Elt
cs' Seq Elt -> Elt -> Seq Elt
forall a. Seq a -> a -> Seq a
|> Container -> Elt
C (ContainerType -> Seq Elt -> Container
Container ContainerType
li Seq Elt
zs))
                                       else ContainerType -> Seq Elt -> Container
Container ContainerType
ct' (Seq Elt
cs' Seq Elt -> Elt -> Seq Elt
forall a. Seq a -> a -> Seq a
|>
                                               Container -> Elt
C (ContainerType -> Seq Elt -> Container
Container ContainerType
li Seq Elt
zs) Seq Elt -> Elt -> Seq Elt
forall a. Seq a -> a -> Seq a
|> Elt
b)) [Container]
rs
                            ViewR Elt
_ -> ContainerStack -> ContainerM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ContainerStack -> ContainerM ())
-> ContainerStack -> ContainerM ()
forall a b. (a -> b) -> a -> b
$ Container -> [Container] -> ContainerStack
ContainerStack (ContainerType -> Seq Elt -> Container
Container ContainerType
ct' (Seq Elt
cs' Seq Elt -> Elt -> Seq Elt
forall a. Seq a -> a -> Seq a
|> Container -> Elt
C Container
top)) [Container]
rs
              [] -> () -> ContainerM ()
forall a. a -> RWST () ReferenceMap ContainerStack Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
       Container
_ -> case [Container]
rest of
             (Container ContainerType
ct' Seq Elt
cs' : [Container]
rs) ->
                 ContainerStack -> ContainerM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ContainerStack -> ContainerM ())
-> ContainerStack -> ContainerM ()
forall a b. (a -> b) -> a -> b
$ Container -> [Container] -> ContainerStack
ContainerStack (ContainerType -> Seq Elt -> Container
Container ContainerType
ct' (Seq Elt
cs' Seq Elt -> Elt -> Seq Elt
forall a. Seq a -> a -> Seq a
|> Container -> Elt
C Container
top)) [Container]
rs
             [] -> () -> ContainerM ()
forall a. a -> RWST () ReferenceMap ContainerStack Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- Add a leaf to the top container.
addLeaf :: LineNumber -> Leaf -> ContainerM ()
addLeaf :: Int -> Leaf -> ContainerM ()
addLeaf Int
lineNum Leaf
lf = do
  ContainerStack Container
top [Container]
rest <- RWST () ReferenceMap ContainerStack Identity ContainerStack
forall s (m :: * -> *). MonadState s m => m s
get
  case (Container
top, Leaf
lf) of
        (Container ct :: ContainerType
ct@(ListItem{}) Seq Elt
cs, BlankLine{}) ->
          case Seq Elt -> ViewR Elt
forall a. Seq a -> ViewR a
viewr Seq Elt
cs of
            (Seq Elt
_ :> L Int
_ BlankLine{}) -> -- two blanks break out of list item:
                 ContainerM ()
closeContainer ContainerM () -> ContainerM () -> ContainerM ()
forall a b.
RWST () ReferenceMap ContainerStack Identity a
-> RWST () ReferenceMap ContainerStack Identity b
-> RWST () ReferenceMap ContainerStack Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Leaf -> ContainerM ()
addLeaf Int
lineNum Leaf
lf
            ViewR Elt
_ -> ContainerStack -> ContainerM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ContainerStack -> ContainerM ())
-> ContainerStack -> ContainerM ()
forall a b. (a -> b) -> a -> b
$ Container -> [Container] -> ContainerStack
ContainerStack (ContainerType -> Seq Elt -> Container
Container ContainerType
ct (Seq Elt
cs Seq Elt -> Elt -> Seq Elt
forall a. Seq a -> a -> Seq a
|> Int -> Leaf -> Elt
L Int
lineNum Leaf
lf)) [Container]
rest
        (Container ContainerType
ct Seq Elt
cs, Leaf
_) ->
                 ContainerStack -> ContainerM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ContainerStack -> ContainerM ())
-> ContainerStack -> ContainerM ()
forall a b. (a -> b) -> a -> b
$ Container -> [Container] -> ContainerStack
ContainerStack (ContainerType -> Seq Elt -> Container
Container ContainerType
ct (Seq Elt
cs Seq Elt -> Elt -> Seq Elt
forall a. Seq a -> a -> Seq a
|> Int -> Leaf -> Elt
L Int
lineNum Leaf
lf)) [Container]
rest

-- Add a container to the container stack.
addContainer :: ContainerType -> ContainerM ()
addContainer :: ContainerType -> ContainerM ()
addContainer ContainerType
ct = (ContainerStack -> ContainerStack) -> ContainerM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ContainerStack -> ContainerStack) -> ContainerM ())
-> (ContainerStack -> ContainerStack) -> ContainerM ()
forall a b. (a -> b) -> a -> b
$ \(ContainerStack Container
top [Container]
rest) ->
  Container -> [Container] -> ContainerStack
ContainerStack (ContainerType -> Seq Elt -> Container
Container ContainerType
ct Seq Elt
forall a. Monoid a => a
mempty) (Container
topContainer -> [Container] -> [Container]
forall a. a -> [a] -> [a]
:[Container]
rest)

-- Step 2

-- Convert Document container and reference map into an AST.
processDocument :: (Container, ReferenceMap) -> Blocks
processDocument :: (Container, ReferenceMap) -> Blocks
processDocument (Container ContainerType
ct Seq Elt
cs, ReferenceMap
refmap) =
  case ContainerType
ct of
    ContainerType
Document -> ReferenceMap -> [Elt] -> Blocks
processElts ReferenceMap
refmap (Seq Elt -> [Elt]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Elt
cs)
    ContainerType
_        -> [Char] -> Blocks
forall a. HasCallStack => [Char] -> a
error [Char]
"top level container is not Document"

-- Turn the result of `processLines` into a proper AST.
-- This requires grouping text lines into paragraphs
-- and list items into lists, handling blank lines,
-- parsing inline contents of texts and resolving referencess.
processElts :: ReferenceMap -> [Elt] -> Blocks
processElts :: ReferenceMap -> [Elt] -> Blocks
processElts ReferenceMap
_ [] = Blocks
forall a. Monoid a => a
mempty

processElts ReferenceMap
refmap (L Int
_lineNumber Leaf
lf : [Elt]
rest) =
  case Leaf
lf of
    -- Gobble text lines and make them into a Para:
    TextLine Text
t -> Block -> Blocks
forall a. a -> Seq a
singleton (Inlines -> Block
Para (Inlines -> Block) -> Inlines -> Block
forall a b. (a -> b) -> a -> b
$ ReferenceMap -> Text -> Inlines
parseInlines ReferenceMap
refmap Text
txt) Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<>
                  ReferenceMap -> [Elt] -> Blocks
processElts ReferenceMap
refmap [Elt]
rest'
               where txt :: Text
txt = Text -> Text
T.stripEnd (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
joinLines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
T.stripStart
                           ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text
t Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Elt -> Text) -> [Elt] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Elt -> Text
extractText [Elt]
textlines
                     ([Elt]
textlines, [Elt]
rest') = (Elt -> Bool) -> [Elt] -> ([Elt], [Elt])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Elt -> Bool
isTextLine [Elt]
rest
                     isTextLine :: Elt -> Bool
isTextLine (L Int
_ (TextLine Text
_)) = Bool
True
                     isTextLine Elt
_ = Bool
False

    -- Blanks at outer level are ignored:
    BlankLine{} -> ReferenceMap -> [Elt] -> Blocks
processElts ReferenceMap
refmap [Elt]
rest

    -- Headers:
    ATXHeader Int
lvl Text
t -> Block -> Blocks
forall a. a -> Seq a
singleton (Int -> Inlines -> Block
Header Int
lvl (Inlines -> Block) -> Inlines -> Block
forall a b. (a -> b) -> a -> b
$ ReferenceMap -> Text -> Inlines
parseInlines ReferenceMap
refmap Text
t) Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<>
                       ReferenceMap -> [Elt] -> Blocks
processElts ReferenceMap
refmap [Elt]
rest
    SetextHeader Int
lvl Text
t -> Block -> Blocks
forall a. a -> Seq a
singleton (Int -> Inlines -> Block
Header Int
lvl (Inlines -> Block) -> Inlines -> Block
forall a b. (a -> b) -> a -> b
$ ReferenceMap -> Text -> Inlines
parseInlines ReferenceMap
refmap Text
t) Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<>
                          ReferenceMap -> [Elt] -> Blocks
processElts ReferenceMap
refmap [Elt]
rest

    -- Horizontal rule:
    Leaf
Rule -> Block -> Blocks
forall a. a -> Seq a
singleton Block
HRule Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<> ReferenceMap -> [Elt] -> Blocks
processElts ReferenceMap
refmap [Elt]
rest

processElts ReferenceMap
refmap (C (Container ContainerType
ct Seq Elt
cs) : [Elt]
rest) =
  case ContainerType
ct of
    ContainerType
Document -> [Char] -> Blocks
forall a. HasCallStack => [Char] -> a
error [Char]
"Document container found inside Document"

    ContainerType
BlockQuote -> Block -> Blocks
forall a. a -> Seq a
singleton (Blocks -> Block
Blockquote (Blocks -> Block) -> Blocks -> Block
forall a b. (a -> b) -> a -> b
$ ReferenceMap -> [Elt] -> Blocks
processElts ReferenceMap
refmap (Seq Elt -> [Elt]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Elt
cs)) Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<>
                  ReferenceMap -> [Elt] -> Blocks
processElts ReferenceMap
refmap [Elt]
rest

    -- List item?  Gobble up following list items of the same type
    -- (skipping blank lines), determine whether the list is tight or
    -- loose, and generate a List.
    ListItem { listType :: ContainerType -> ListType
listType = ListType
listType' } ->
        Block -> Blocks
forall a. a -> Seq a
singleton (Bool -> ListType -> [Blocks] -> Block
List Bool
isTight ListType
listType' [Blocks]
items') Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<> ReferenceMap -> [Elt] -> Blocks
processElts ReferenceMap
refmap [Elt]
rest'
              where xs :: [Elt]
xs = [Elt] -> [Elt]
takeListItems [Elt]
rest

                    rest' :: [Elt]
rest' = Int -> [Elt] -> [Elt]
forall a. Int -> [a] -> [a]
drop ([Elt] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Elt]
xs) [Elt]
rest

                    -- take list items as long as list type matches and we
                    -- don't hit two blank lines:
                    takeListItems :: [Elt] -> [Elt]
takeListItems
                      (C c :: Container
c@(Container ListItem { listType :: ContainerType -> ListType
listType = ListType
lt' } Seq Elt
_) : [Elt]
zs)
                      | ListType -> ListType -> Bool
listTypesMatch ListType
lt' ListType
listType' = Container -> Elt
C Container
c Elt -> [Elt] -> [Elt]
forall a. a -> [a] -> [a]
: [Elt] -> [Elt]
takeListItems [Elt]
zs
                    takeListItems (lf :: Elt
lf@(L Int
_ (BlankLine Text
_)) :
                      c :: Elt
c@(C (Container ListItem { listType :: ContainerType -> ListType
listType = ListType
lt' } Seq Elt
_)) : [Elt]
zs)
                      | ListType -> ListType -> Bool
listTypesMatch ListType
lt' ListType
listType' = Elt
lf Elt -> [Elt] -> [Elt]
forall a. a -> [a] -> [a]
: Elt
c Elt -> [Elt] -> [Elt]
forall a. a -> [a] -> [a]
: [Elt] -> [Elt]
takeListItems [Elt]
zs
                    takeListItems [Elt]
_ = []

                    listTypesMatch :: ListType -> ListType -> Bool
listTypesMatch (Bullet Char
c1) (Bullet Char
c2) = Char
c1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c2
                    listTypesMatch (Numbered NumWrapper
w1 Int
_) (Numbered NumWrapper
w2 Int
_) = NumWrapper
w1 NumWrapper -> NumWrapper -> Bool
forall a. Eq a => a -> a -> Bool
== NumWrapper
w2
                    listTypesMatch ListType
_ ListType
_ = Bool
False

                    items :: [[Elt]]
items = (Container -> Maybe [Elt]) -> [Container] -> [[Elt]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Container -> Maybe [Elt]
getItem (ContainerType -> Seq Elt -> Container
Container ContainerType
ct Seq Elt
cs Container -> [Container] -> [Container]
forall a. a -> [a] -> [a]
: [Container
c | C Container
c <- [Elt]
xs])

                    getItem :: Container -> Maybe [Elt]
getItem (Container ListItem{} Seq Elt
cs') = [Elt] -> Maybe [Elt]
forall a. a -> Maybe a
Just ([Elt] -> Maybe [Elt]) -> [Elt] -> Maybe [Elt]
forall a b. (a -> b) -> a -> b
$ Seq Elt -> [Elt]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Elt
cs'
                    getItem Container
_                          = Maybe [Elt]
forall a. Maybe a
Nothing

                    items' :: [Blocks]
items' = ([Elt] -> Blocks) -> [[Elt]] -> [Blocks]
forall a b. (a -> b) -> [a] -> [b]
map (ReferenceMap -> [Elt] -> Blocks
processElts ReferenceMap
refmap) [[Elt]]
items

                    isTight :: Bool
isTight = [Elt] -> Bool
tightListItem [Elt]
xs Bool -> Bool -> Bool
&& ([Elt] -> Bool) -> [[Elt]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all [Elt] -> Bool
tightListItem [[Elt]]
items

    FencedCode Int
_ Text
_ Text
info' -> Block -> Blocks
forall a. a -> Seq a
singleton (CodeAttr -> Text -> Block
CodeBlock CodeAttr
attr Text
txt) Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<>
                               ReferenceMap -> [Elt] -> Blocks
processElts ReferenceMap
refmap [Elt]
rest
                  where txt :: Text
txt = [Text] -> Text
joinLines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Elt -> Text) -> [Elt] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Elt -> Text
extractText ([Elt] -> [Text]) -> [Elt] -> [Text]
forall a b. (a -> b) -> a -> b
$ Seq Elt -> [Elt]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Elt
cs
                        attr :: CodeAttr
attr = Text -> Text -> CodeAttr
CodeAttr Text
x (Text -> Text
T.strip Text
y)
                        (Text
x,Text
y) = (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
' ') Text
info'

    ContainerType
IndentedCode -> Block -> Blocks
forall a. a -> Seq a
singleton (CodeAttr -> Text -> Block
CodeBlock (Text -> Text -> CodeAttr
CodeAttr Text
"" Text
"") Text
txt)
                    Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<> ReferenceMap -> [Elt] -> Blocks
processElts ReferenceMap
refmap [Elt]
rest'
                  where txt :: Text
txt = [Text] -> Text
joinLines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
stripTrailingEmpties
                              ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Elt -> [Text]) -> [Elt] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Elt -> [Text]
extractCode [Elt]
cbs

                        stripTrailingEmpties :: [Text] -> [Text]
stripTrailingEmpties = [Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                          (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((Char -> Bool) -> Text -> Bool
T.all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
' ')) ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
forall a. [a] -> [a]
reverse

                        -- explanation for next line:  when we parsed
                        -- the blank line, we dropped 0-3 spaces.
                        -- but for this, code block context, we want
                        -- to have dropped 4 spaces. we simply drop
                        -- one more:
                        extractCode :: Elt -> [Text]
extractCode (L Int
_ (BlankLine Text
t)) = [Int -> Text -> Text
T.drop Int
1 Text
t]
                        extractCode (C (Container ContainerType
IndentedCode Seq Elt
cs')) =
                          (Elt -> Text) -> [Elt] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Elt -> Text
extractText ([Elt] -> [Text]) -> [Elt] -> [Text]
forall a b. (a -> b) -> a -> b
$ Seq Elt -> [Elt]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Elt
cs'
                        extractCode Elt
_ = []

                        ([Elt]
cbs, [Elt]
rest') = (Elt -> Bool) -> [Elt] -> ([Elt], [Elt])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Elt -> Bool
isIndentedCodeOrBlank
                                       (Container -> Elt
C (ContainerType -> Seq Elt -> Container
Container ContainerType
ct Seq Elt
cs) Elt -> [Elt] -> [Elt]
forall a. a -> [a] -> [a]
: [Elt]
rest)

                        isIndentedCodeOrBlank :: Elt -> Bool
isIndentedCodeOrBlank (L Int
_ BlankLine{}) = Bool
True
                        isIndentedCodeOrBlank (C (Container ContainerType
IndentedCode Seq Elt
_))
                                                              = Bool
True
                        isIndentedCodeOrBlank Elt
_               = Bool
False

    ContainerType
RawHtmlBlock -> Block -> Blocks
forall a. a -> Seq a
singleton (Text -> Block
HtmlBlock Text
txt) Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<> ReferenceMap -> [Elt] -> Blocks
processElts ReferenceMap
refmap [Elt]
rest
                  where txt :: Text
txt = [Text] -> Text
joinLines ((Elt -> Text) -> [Elt] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Elt -> Text
extractText (Seq Elt -> [Elt]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Elt
cs))

    -- References have already been taken into account in the reference map,
    -- so we just skip.
    Reference{} -> ReferenceMap -> [Elt] -> Blocks
processElts ReferenceMap
refmap [Elt]
rest

   where isBlankLine :: Elt -> Bool
isBlankLine (L Int
_ BlankLine{}) = Bool
True
         isBlankLine Elt
_ = Bool
False

         tightListItem :: [Elt] -> Bool
tightListItem [] = Bool
True
         tightListItem [Elt]
xs = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Elt -> Bool) -> [Elt] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Elt -> Bool
isBlankLine [Elt]
xs

extractText :: Elt -> Text
extractText :: Elt -> Text
extractText (L Int
_ (TextLine Text
t)) = Text
t
extractText Elt
_ = Text
forall a. Monoid a => a
mempty

-- Step 1

processLines :: Text -> (Container, ReferenceMap)
processLines :: Text -> (Container, ReferenceMap)
processLines Text
t = (Container
doc, ReferenceMap
refmap)
  where
  (Container
doc, ReferenceMap
refmap) = ContainerM Container
-> () -> ContainerStack -> (Container, ReferenceMap)
forall r w s a. RWS r w s a -> r -> s -> (a, w)
evalRWS (((Int, Text) -> ContainerM ()) -> [(Int, Text)] -> ContainerM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Int, Text) -> ContainerM ()
processLine [(Int, Text)]
lns ContainerM () -> ContainerM Container -> ContainerM Container
forall a b.
RWST () ReferenceMap ContainerStack Identity a
-> RWST () ReferenceMap ContainerStack Identity b
-> RWST () ReferenceMap ContainerStack Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ContainerM Container
closeStack) () ContainerStack
startState
  lns :: [(Int, Text)]
lns        = [Int] -> [Text] -> [(Int, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
tabFilter ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.lines Text
t)
  startState :: ContainerStack
startState = Container -> [Container] -> ContainerStack
ContainerStack (ContainerType -> Seq Elt -> Container
Container ContainerType
Document Seq Elt
forall a. Monoid a => a
mempty) []

-- The main block-parsing function.
-- We analyze a line of text and modify the container stack accordingly,
-- adding a new leaf, or closing or opening containers.
processLine :: (LineNumber, Text) -> ContainerM ()
processLine :: (Int, Text) -> ContainerM ()
processLine (Int
lineNumber, Text
txt) = do
  ContainerStack top :: Container
top@(Container ContainerType
ct Seq Elt
cs) [Container]
rest <- RWST () ReferenceMap ContainerStack Identity ContainerStack
forall s (m :: * -> *). MonadState s m => m s
get

  -- Apply the line-start scanners appropriate for each nested container.
  -- Return the remainder of the string, and the number of unmatched
  -- containers.
  let (Text
t', Int
numUnmatched) = [Container] -> Text -> (Text, Int)
tryOpenContainers ([Container] -> [Container]
forall a. [a] -> [a]
reverse ([Container] -> [Container]) -> [Container] -> [Container]
forall a b. (a -> b) -> a -> b
$ Container
topContainer -> [Container] -> [Container]
forall a. a -> [a] -> [a]
:[Container]
rest) Text
txt

  -- Some new containers can be started only after a blank.
  let lastLineIsText :: Bool
lastLineIsText = Int
numUnmatched Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&&
                       case Seq Elt -> ViewR Elt
forall a. Seq a -> ViewR a
viewr Seq Elt
cs of
                            (Seq Elt
_ :> L Int
_ (TextLine Text
_)) -> Bool
True
                            ViewR Elt
_                       -> Bool
False

  -- Process the rest of the line in a way that makes sense given
  -- the container type at the top of the stack (ct):
  case ContainerType
ct of
    -- If it's a verbatim line container, add the line.
    RawHtmlBlock{} | Int
numUnmatched Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 -> Int -> Leaf -> ContainerM ()
addLeaf Int
lineNumber (Text -> Leaf
TextLine Text
t')
    ContainerType
IndentedCode   | Int
numUnmatched Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 -> Int -> Leaf -> ContainerM ()
addLeaf Int
lineNumber (Text -> Leaf
TextLine Text
t')
    FencedCode{ fence :: ContainerType -> Text
fence = Text
fence' } ->
    -- here we don't check numUnmatched because we allow laziness
      if Text
fence' Text -> Text -> Bool
`T.isPrefixOf` Text
t'
         -- closing code fence
         then ContainerM ()
closeContainer
         else Int -> Leaf -> ContainerM ()
addLeaf Int
lineNumber (Text -> Leaf
TextLine Text
t')

    -- otherwise, parse the remainder to see if we have new container starts:
    ContainerType
_ -> case Bool -> Int -> Text -> ([ContainerType], Leaf)
tryNewContainers Bool
lastLineIsText (Text -> Int
T.length Text
txt Int -> Int -> Int
forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
t') Text
t' of

       -- lazy continuation: text line, last line was text, no new containers,
       -- some unmatched containers:
       ([], TextLine Text
t)
           | Int
numUnmatched Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
           , case Seq Elt -> ViewR Elt
forall a. Seq a -> ViewR a
viewr Seq Elt
cs of
                  (Seq Elt
_ :> L Int
_ (TextLine Text
_)) -> Bool
True
                  ViewR Elt
_                       -> Bool
False
           , ContainerType
ct ContainerType -> ContainerType -> Bool
forall a. Eq a => a -> a -> Bool
/= ContainerType
IndentedCode -> Int -> Leaf -> ContainerM ()
addLeaf Int
lineNumber (Text -> Leaf
TextLine Text
t)

       -- if it's a setext header line and the top container has a textline
       -- as last child, add a setext header:
       ([], SetextHeader Int
lev Text
_) | Int
numUnmatched Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 ->
           case Seq Elt -> ViewR Elt
forall a. Seq a -> ViewR a
viewr Seq Elt
cs of
             (Seq Elt
cs' :> L Int
_ (TextLine Text
t)) -> -- replace last text line with setext header
               ContainerStack -> ContainerM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ContainerStack -> ContainerM ())
-> ContainerStack -> ContainerM ()
forall a b. (a -> b) -> a -> b
$ Container -> [Container] -> ContainerStack
ContainerStack (ContainerType -> Seq Elt -> Container
Container ContainerType
ct
                        (Seq Elt
cs' Seq Elt -> Elt -> Seq Elt
forall a. Seq a -> a -> Seq a
|> Int -> Leaf -> Elt
L Int
lineNumber (Int -> Text -> Leaf
SetextHeader Int
lev Text
t))) [Container]
rest
               -- Note: the following case should not occur, since
               -- we don't add a SetextHeader leaf unless lastLineIsText.
             ViewR Elt
_ -> [Char] -> ContainerM ()
forall a. HasCallStack => [Char] -> a
error [Char]
"setext header line without preceding text line"

       -- otherwise, close all the unmatched containers, add the new
       -- containers, and finally add the new leaf:
       ([ContainerType]
ns, Leaf
lf) -> do -- close unmatched containers, add new ones
           Int
-> ContainerM ()
-> RWST () ReferenceMap ContainerStack Identity [()]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
numUnmatched ContainerM ()
closeContainer
           (ContainerType -> ContainerM ())
-> [ContainerType] -> ContainerM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ContainerType -> ContainerM ()
addContainer [ContainerType]
ns
           case ([ContainerType] -> [ContainerType]
forall a. [a] -> [a]
reverse [ContainerType]
ns, Leaf
lf) of
             -- don't add extra blank at beginning of fenced code block
             (FencedCode{}:[ContainerType]
_,  BlankLine{}) -> () -> ContainerM ()
forall a. a -> RWST () ReferenceMap ContainerStack Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
             ([ContainerType], Leaf)
_ -> Int -> Leaf -> ContainerM ()
addLeaf Int
lineNumber Leaf
lf

-- Try to match the scanners corresponding to any currently open containers.
-- Return remaining text after matching scanners, plus the number of open
-- containers whose scanners did not match.  (These will be closed unless
-- we have a lazy text line.)
tryOpenContainers :: [Container] -> Text -> (Text, Int)
tryOpenContainers :: [Container] -> Text -> (Text, Int)
tryOpenContainers [Container]
cs Text
t = case Parser (Text, Int) -> Text -> Either ParseError (Text, Int)
forall a. Parser a -> Text -> Either ParseError a
parse ([Scanner] -> Parser (Text, Int)
forall {a}. [Parser a] -> Parser (Text, Int)
scanners ([Scanner] -> Parser (Text, Int))
-> [Scanner] -> Parser (Text, Int)
forall a b. (a -> b) -> a -> b
$ (Container -> Scanner) -> [Container] -> [Scanner]
forall a b. (a -> b) -> [a] -> [b]
map Container -> Scanner
containerContinue [Container]
cs) Text
t of
                         Right (Text
t', Int
n)  -> (Text
t', Int
n)
                         Left ParseError
e         -> [Char] -> (Text, Int)
forall a. HasCallStack => [Char] -> a
error ([Char] -> (Text, Int)) -> [Char] -> (Text, Int)
forall a b. (a -> b) -> a -> b
$ [Char]
"error parsing scanners: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
                                            ParseError -> [Char]
forall a. Show a => a -> [Char]
show ParseError
e
  where scanners :: [Parser a] -> Parser (Text, Int)
scanners [] = (,) (Text -> Int -> (Text, Int))
-> Parser Text -> Parser (Int -> (Text, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
takeText Parser (Int -> (Text, Int)) -> Parser Int -> Parser (Text, Int)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Parser Int
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0
        scanners (Parser a
p:[Parser a]
ps) = (Parser a
p Parser a -> Parser (Text, Int) -> Parser (Text, Int)
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Parser a] -> Parser (Text, Int)
scanners [Parser a]
ps)
                      Parser (Text, Int) -> Parser (Text, Int) -> Parser (Text, Int)
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((,) (Text -> Int -> (Text, Int))
-> Parser Text -> Parser (Int -> (Text, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
takeText Parser (Int -> (Text, Int)) -> Parser Int -> Parser (Text, Int)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Parser Int
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Parser a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Parser a
pParser a -> [Parser a] -> [Parser a]
forall a. a -> [a] -> [a]
:[Parser a]
ps)))

-- Try to match parsers for new containers.  Return list of new
-- container types, and the leaf to add inside the new containers.
tryNewContainers :: Bool -> Int -> Text -> ([ContainerType], Leaf)
tryNewContainers :: Bool -> Int -> Text -> ([ContainerType], Leaf)
tryNewContainers Bool
lastLineIsText Int
offset Text
t =
  case Parser ([ContainerType], Leaf)
-> Text -> Either ParseError ([ContainerType], Leaf)
forall a. Parser a -> Text -> Either ParseError a
parse Parser ([ContainerType], Leaf)
newContainers Text
t of
       Right ([ContainerType]
cs,Leaf
t') -> ([ContainerType]
cs, Leaf
t')
       Left ParseError
err      -> [Char] -> ([ContainerType], Leaf)
forall a. HasCallStack => [Char] -> a
error (ParseError -> [Char]
forall a. Show a => a -> [Char]
show ParseError
err)
  where newContainers :: Parser ([ContainerType], Leaf)
newContainers = do
          Parser Position
getPosition Parser Position -> (Position -> Scanner) -> Scanner
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Position
pos -> Position -> Scanner
setPosition Position
pos{ column = offset + 1 }
          [ContainerType]
regContainers <- Parser ContainerType -> Parser [ContainerType]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Bool -> Parser ContainerType
containerStart Bool
lastLineIsText)
          [ContainerType]
verbatimContainers <- [ContainerType] -> Parser [ContainerType] -> Parser [ContainerType]
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option []
                            (Parser [ContainerType] -> Parser [ContainerType])
-> Parser [ContainerType] -> Parser [ContainerType]
forall a b. (a -> b) -> a -> b
$ Int -> Parser ContainerType -> Parser [ContainerType]
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
1 (Bool -> Parser ContainerType
verbatimContainerStart Bool
lastLineIsText)
          if [ContainerType] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ContainerType]
verbatimContainers
             then (,) ([ContainerType] -> Leaf -> ([ContainerType], Leaf))
-> Parser [ContainerType]
-> Parser (Leaf -> ([ContainerType], Leaf))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ContainerType] -> Parser [ContainerType]
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ContainerType]
regContainers Parser (Leaf -> ([ContainerType], Leaf))
-> Parser Leaf -> Parser ([ContainerType], Leaf)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> Parser Leaf
leaf Bool
lastLineIsText
             else (,) ([ContainerType] -> Leaf -> ([ContainerType], Leaf))
-> Parser [ContainerType]
-> Parser (Leaf -> ([ContainerType], Leaf))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ContainerType] -> Parser [ContainerType]
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ContainerType]
regContainers [ContainerType] -> [ContainerType] -> [ContainerType]
forall a. [a] -> [a] -> [a]
++ [ContainerType]
verbatimContainers) Parser (Leaf -> ([ContainerType], Leaf))
-> Parser Leaf -> Parser ([ContainerType], Leaf)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
                            Parser Leaf
textLineOrBlank

textLineOrBlank :: Parser Leaf
textLineOrBlank :: Parser Leaf
textLineOrBlank = Text -> Leaf
consolidate (Text -> Leaf) -> Parser Text -> Parser Leaf
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
takeText
  where consolidate :: Text -> Leaf
consolidate Text
ts | (Char -> Bool) -> Text -> Bool
T.all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
' ') Text
ts = Text -> Leaf
BlankLine Text
ts
                       | Bool
otherwise        = Text -> Leaf
TextLine  Text
ts

-- Parse a leaf node.
leaf :: Bool -> Parser Leaf
leaf :: Bool -> Parser Leaf
leaf Bool
lastLineIsText = Scanner
scanNonindentSpace Scanner -> Parser Leaf -> Parser Leaf
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (
     (Int -> Text -> Leaf
ATXHeader (Int -> Text -> Leaf) -> Parser Int -> Parser (Text -> Leaf)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Int
parseAtxHeaderStart Parser (Text -> Leaf) -> Parser Text -> Parser Leaf
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
         (Text -> Text
T.strip (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
removeATXSuffix (Text -> Text) -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
takeText))
   Parser Leaf -> Parser Leaf -> Parser Leaf
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Bool -> Scanner
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
lastLineIsText Scanner -> Parser Leaf -> Parser Leaf
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Int -> Text -> Leaf
SetextHeader (Int -> Text -> Leaf) -> Parser Int -> Parser (Text -> Leaf)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Int
parseSetextHeaderLine Parser (Text -> Leaf) -> Parser Text -> Parser Leaf
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Parser Text
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
forall a. Monoid a => a
mempty))
   Parser Leaf -> Parser Leaf -> Parser Leaf
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Leaf
Rule Leaf -> Scanner -> Parser Leaf
forall a b. a -> Parser b -> Parser a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Scanner
scanHRuleLine)
   Parser Leaf -> Parser Leaf -> Parser Leaf
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Leaf
textLineOrBlank
  )
  where removeATXSuffix :: Text -> Text
removeATXSuffix Text
t = case (Char -> Bool) -> Text -> Text
T.dropWhileEnd (Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char]
" #" :: String)) Text
t of
                                 Text
t' | Text -> Bool
T.null Text
t' -> Text
t'
                                      -- an escaped \#
                                    | HasCallStack => Text -> Char
Text -> Char
T.last Text
t' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\' -> Text
t' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"#"
                                    | Bool
otherwise -> Text
t'

-- Scanners

scanReference :: Scanner
scanReference :: Scanner
scanReference = () () -> Scanner -> Scanner
forall a b. a -> Parser b -> Parser a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Scanner -> Scanner
forall a. Parser a -> Parser a
lookAhead (Parser Text
pLinkLabel Parser Text -> Scanner -> Scanner
forall a b. Parser a -> Parser b -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Scanner
scanChar Char
':')

-- Scan the beginning of a blockquote:  up to three
-- spaces indent, the `>` character, and an optional space.
scanBlockquoteStart :: Scanner
scanBlockquoteStart :: Scanner
scanBlockquoteStart = Char -> Scanner
scanChar Char
'>' Scanner -> Scanner -> Scanner
forall a b. Parser a -> Parser b -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> Scanner -> Scanner
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option () (Char -> Scanner
scanChar Char
' ')

-- Parse the sequence of `#` characters that begins an ATX
-- header, and return the number of characters.  We require
-- a space after the initial string of `#`s, as not all markdown
-- implementations do. This is because (a) the ATX reference
-- implementation requires a space, and (b) since we're allowing
-- headers without preceding blank lines, requiring the space
-- avoids accidentally capturing a line like `#8 toggle bolt` as
-- a header.
parseAtxHeaderStart :: Parser Int
parseAtxHeaderStart :: Parser Int
parseAtxHeaderStart = do
  Char -> Parser Char
char Char
'#'
  Text
hashes <- Int -> (Char -> Bool) -> Parser Text
upToCountChars Int
5 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'#')
  -- hashes must be followed by space unless empty header:
  Scanner -> Scanner
forall a. Parser a -> Scanner
notFollowedBy ((Char -> Bool) -> Scanner
skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' '))
  Int -> Parser Int
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Parser Int) -> Int -> Parser Int
forall a b. (a -> b) -> a -> b
$ Text -> Int
T.length Text
hashes Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1

parseSetextHeaderLine :: Parser Int
parseSetextHeaderLine :: Parser Int
parseSetextHeaderLine = do
  Char
d <- (Char -> Bool) -> Parser Char
satisfy (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'=')
  let lev :: Int
lev = if Char
d Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'=' then Int
1 else Int
2
  (Char -> Bool) -> Scanner
skipWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
d)
  Scanner
scanBlankline
  Int -> Parser Int
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
lev

-- Scan a horizontal rule line: "...three or more hyphens, asterisks,
-- or underscores on a line by themselves. If you wish, you may use
-- spaces between the hyphens or asterisks."
scanHRuleLine :: Scanner
scanHRuleLine :: Scanner
scanHRuleLine = do
  Char
c <- (Char -> Bool) -> Parser Char
satisfy (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'*' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-')
  Int -> Scanner -> Parser [()]
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
2 (Scanner -> Parser [()]) -> Scanner -> Parser [()]
forall a b. (a -> b) -> a -> b
$ Scanner
scanSpaces Scanner -> Scanner -> Scanner
forall a b. Parser a -> Parser b -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> Bool) -> Scanner
skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c)
  (Char -> Bool) -> Scanner
skipWhile (\Char
x -> Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c)
  Scanner
endOfInput

-- Parse an initial code fence line, returning
-- the fence part and the rest (after any spaces).
parseCodeFence :: Parser ContainerType
parseCodeFence :: Parser ContainerType
parseCodeFence = do
  Int
col <- Position -> Int
column (Position -> Int) -> Parser Position -> Parser Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Position
getPosition
  Text
cs <- (Char -> Bool) -> Parser Text
takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'`') Parser Text -> Parser Text -> Parser Text
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char -> Bool) -> Parser Text
takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'~')
  Bool -> Scanner
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Scanner) -> Bool -> Scanner
forall a b. (a -> b) -> a -> b
$ Text -> Int
T.length Text
cs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
3
  Scanner
scanSpaces
  Text
rawattr <- (Char -> Bool) -> Parser Text
takeWhile (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'`' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'~')
  Scanner
endOfInput
  ContainerType -> Parser ContainerType
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (ContainerType -> Parser ContainerType)
-> ContainerType -> Parser ContainerType
forall a b. (a -> b) -> a -> b
$ FencedCode { startColumn :: Int
startColumn = Int
col
                      , fence :: Text
fence = Text
cs
                      , info :: Text
info = Text
rawattr }

-- Parse the start of an HTML block:  either an HTML tag or an
-- HTML comment, with no indentation.
parseHtmlBlockStart :: Parser ()
parseHtmlBlockStart :: Scanner
parseHtmlBlockStart = () () -> Parser Text -> Scanner
forall a b. a -> Parser b -> Parser a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parser Text -> Parser Text
forall a. Parser a -> Parser a
lookAhead
     ((do (HtmlTagType, Text)
t <- Parser (HtmlTagType, Text)
pHtmlTag
          Bool -> Scanner
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Scanner) -> Bool -> Scanner
forall a b. (a -> b) -> a -> b
$ HtmlTagType -> Bool
f (HtmlTagType -> Bool) -> HtmlTagType -> Bool
forall a b. (a -> b) -> a -> b
$ (HtmlTagType, Text) -> HtmlTagType
forall a b. (a, b) -> a
fst (HtmlTagType, Text)
t
          Text -> Parser Text
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Parser Text) -> Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ (HtmlTagType, Text) -> Text
forall a b. (a, b) -> b
snd (HtmlTagType, Text)
t)
    Parser Text -> Parser Text -> Parser Text
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser Text
string Text
"<!--"
    Parser Text -> Parser Text -> Parser Text
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser Text
string Text
"-->"
     )
 where f :: HtmlTagType -> Bool
f (Opening Text
name) = Text
name Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
blockHtmlTags
       f (SelfClosing Text
name) = Text
name Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
blockHtmlTags
       f (Closing Text
name) = Text
name Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
blockHtmlTags

-- List of block level tags for HTML 5.
blockHtmlTags :: Set.Set Text
blockHtmlTags :: Set Text
blockHtmlTags = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList
 [ Text
"article", Text
"header", Text
"aside", Text
"hgroup", Text
"blockquote", Text
"hr",
   Text
"body", Text
"li", Text
"br", Text
"map", Text
"button", Text
"object", Text
"canvas", Text
"ol",
   Text
"caption", Text
"output", Text
"col", Text
"p", Text
"colgroup", Text
"pre", Text
"dd",
   Text
"progress", Text
"div", Text
"section", Text
"dl", Text
"table", Text
"dt", Text
"tbody",
   Text
"embed", Text
"textarea", Text
"fieldset", Text
"tfoot", Text
"figcaption", Text
"th",
   Text
"figure", Text
"thead", Text
"footer", Text
"footer", Text
"tr", Text
"form", Text
"ul",
   Text
"h1", Text
"h2", Text
"h3", Text
"h4", Text
"h5", Text
"h6", Text
"video"]

-- Parse a list marker and return the list type.
parseListMarker :: Parser ContainerType
parseListMarker :: Parser ContainerType
parseListMarker = do
  Int
col <- Position -> Int
column (Position -> Int) -> Parser Position -> Parser Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Position
getPosition
  ListType
ty <- Parser ListType
parseBullet Parser ListType -> Parser ListType -> Parser ListType
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ListType
parseListNumber
  -- padding is 1 if list marker followed by a blank line
  -- or indented code.  otherwise it's the length of the
  -- whitespace between the list marker and the following text:
  Int
padding' <- (Int
1 Int -> Scanner -> Parser Int
forall a b. a -> Parser b -> Parser a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Scanner
scanBlankline)
          Parser Int -> Parser Int -> Parser Int
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Int
1 Int -> Parser [Char] -> Parser Int
forall a b. a -> Parser b -> Parser a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ((Char -> Bool) -> Scanner
skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
' ') Scanner -> Parser [Char] -> Parser [Char]
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser [Char] -> Parser [Char]
forall a. Parser a -> Parser a
lookAhead (Int -> Parser Char -> Parser [Char]
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
4 (Char -> Parser Char
char Char
' '))))
          Parser Int -> Parser Int -> Parser Int
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Text -> Int
T.length (Text -> Int) -> Parser Text -> Parser Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
' '))
  -- text can't immediately follow the list marker:
  Bool -> Scanner
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Scanner) -> Bool -> Scanner
forall a b. (a -> b) -> a -> b
$ Int
padding' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
  ContainerType -> Parser ContainerType
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (ContainerType -> Parser ContainerType)
-> ContainerType -> Parser ContainerType
forall a b. (a -> b) -> a -> b
$ ListItem { listType :: ListType
listType = ListType
ty
                    , markerColumn :: Int
markerColumn = Int
col
                    , padding :: Int
padding = Int
padding' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ListType -> Int
listMarkerWidth ListType
ty
                    }

listMarkerWidth :: ListType -> Int
listMarkerWidth :: ListType -> Int
listMarkerWidth (Bullet Char
_) = Int
1
listMarkerWidth (Numbered NumWrapper
_ Int
n) | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
10    = Int
2
                               | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
100   = Int
3
                               | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1000  = Int
4
                               | Bool
otherwise = Int
5

-- Parse a bullet and return list type.
parseBullet :: Parser ListType
parseBullet :: Parser ListType
parseBullet = do
  Char
c <- (Char -> Bool) -> Parser Char
satisfy (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'+' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'*' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-')
  Bool -> Scanner -> Scanner
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'+')
    (Scanner -> Scanner) -> Scanner -> Scanner
forall a b. (a -> b) -> a -> b
$ Scanner -> Scanner
forall a. Parser a -> Scanner
nfb (Scanner -> Scanner) -> Scanner -> Scanner
forall a b. (a -> b) -> a -> b
$ (Int -> Scanner -> Parser [()]
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
2 (Scanner -> Parser [()]) -> Scanner -> Parser [()]
forall a b. (a -> b) -> a -> b
$ Scanner
scanSpaces Scanner -> Scanner -> Scanner
forall a b. Parser a -> Parser b -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> Bool) -> Scanner
skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c)) Parser [()] -> Scanner -> Scanner
forall a b. Parser a -> Parser b -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
          (Char -> Bool) -> Scanner
skipWhile (\Char
x -> Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c) Scanner -> Scanner -> Scanner
forall a b. Parser a -> Parser b -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Scanner
endOfInput -- hrule
  ListType -> Parser ListType
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (ListType -> Parser ListType) -> ListType -> Parser ListType
forall a b. (a -> b) -> a -> b
$ Char -> ListType
Bullet Char
c

-- Parse a list number marker and return list type.
parseListNumber :: Parser ListType
parseListNumber :: Parser ListType
parseListNumber = do
    Int
num <- ([Char] -> Int
forall a. Read a => [Char] -> a
read ([Char] -> Int) -> (Text -> [Char]) -> Text -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack) (Text -> Int) -> Parser Text -> Parser Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text
takeWhile1 Char -> Bool
isDigit
    NumWrapper
wrap <-  NumWrapper
PeriodFollowing NumWrapper -> Scanner -> Parser NumWrapper
forall a b. a -> Parser b -> Parser a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Char -> Bool) -> Scanner
skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.')
         Parser NumWrapper -> Parser NumWrapper -> Parser NumWrapper
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> NumWrapper
ParenFollowing NumWrapper -> Scanner -> Parser NumWrapper
forall a b. a -> Parser b -> Parser a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Char -> Bool) -> Scanner
skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
')')
    ListType -> Parser ListType
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (ListType -> Parser ListType) -> ListType -> Parser ListType
forall a b. (a -> b) -> a -> b
$ NumWrapper -> Int -> ListType
Numbered NumWrapper
wrap Int
num