{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Djot.Blocks
( parseDoc
, toIdentifier
)
where

import Prelude hiding (div)
import Text.Read (readMaybe)
import Data.Maybe (fromMaybe)
import Data.Char (ord, isAsciiLower, isAsciiUpper, isAscii, isAlphaNum, isDigit)
import Data.Foldable as F
import Djot.Parse
import Djot.AST
import Djot.Inlines (parseInlines, parseTableCells)
import Djot.Options (ParseOptions(..), SourcePosOption(..))
import Djot.Attributes (parseAttributes, AttrParserState, AttrParseResult(..))
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import Data.ByteString (ByteString)
import Control.Monad (replicateM_, void, mzero, unless, when, guard, foldM)
import Data.List.NonEmpty (NonEmpty(..))
import Data.List (intercalate)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Set (Set)
import qualified Data.Set as Set
import Control.Applicative
import Data.Typeable (Typeable)
-- import Debug.Trace

parseDoc :: ParseOptions -> ByteString -> Either String Doc
parseDoc :: ParseOptions -> ByteString -> Either [Char] Doc
parseDoc ParseOptions
opts ByteString
bs = do
  case Parser PState Doc -> PState -> [Chunk] -> Maybe Doc
forall s a. Parser s a -> s -> [Chunk] -> Maybe a
parse Parser PState Doc
pDoc PState{ psParseOptions :: ParseOptions
psParseOptions = ParseOptions
opts
                        , psContainerStack :: NonEmpty Container
psContainerStack =
                            [Container] -> NonEmpty Container
forall a. HasCallStack => [a] -> NonEmpty a
NonEmpty.fromList
                             [Container
emptyContainer{ containerSpec = docSpec }]
                        , psReferenceMap :: ReferenceMap
psReferenceMap = ReferenceMap
forall a. Monoid a => a
mempty
                        , psAutoReferenceMap :: ReferenceMap
psAutoReferenceMap = ReferenceMap
forall a. Monoid a => a
mempty
                        , psNoteMap :: NoteMap
psNoteMap = NoteMap
forall a. Monoid a => a
mempty
                        , psAttributes :: Attr
psAttributes = Attr
forall a. Monoid a => a
mempty
                        , psAttrParserState :: Maybe AttrParserState
psAttrParserState = Maybe AttrParserState
forall a. Maybe a
Nothing
                        , psIds :: Set ByteString
psIds = Set ByteString
forall a. Monoid a => a
mempty
                        , psAutoIds :: Set ByteString
psAutoIds = Set ByteString
forall a. Monoid a => a
mempty
                        , psLastColumnPrevLine :: Int
psLastColumnPrevLine = Int
0
                        , psLastLine :: Int
psLastLine = Int
1
                        } [Chunk{ chunkLine :: Int
chunkLine = Int
1, chunkColumn :: Int
chunkColumn = Int
1, chunkBytes :: ByteString
chunkBytes = ByteString
bs }] of
    Just Doc
doc -> Doc -> Either [Char] Doc
forall a b. b -> Either a b
Right Doc
doc
    Maybe Doc
Nothing -> [Char] -> Either [Char] Doc
forall a b. a -> Either a b
Left [Char]
"Parse failure."

data BlockType =
  Normal | ListItem | CaptionBlock | Document
  deriving (Int -> BlockType -> ShowS
[BlockType] -> ShowS
BlockType -> [Char]
(Int -> BlockType -> ShowS)
-> (BlockType -> [Char])
-> ([BlockType] -> ShowS)
-> Show BlockType
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BlockType -> ShowS
showsPrec :: Int -> BlockType -> ShowS
$cshow :: BlockType -> [Char]
show :: BlockType -> [Char]
$cshowList :: [BlockType] -> ShowS
showList :: [BlockType] -> ShowS
Show, BlockType -> BlockType -> Bool
(BlockType -> BlockType -> Bool)
-> (BlockType -> BlockType -> Bool) -> Eq BlockType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BlockType -> BlockType -> Bool
== :: BlockType -> BlockType -> Bool
$c/= :: BlockType -> BlockType -> Bool
/= :: BlockType -> BlockType -> Bool
Eq)

data BlockSpec =
  BlockSpec
  { -- | Descriptive name
    BlockSpec -> [Char]
blockName :: String
  , -- | Type of block
    BlockSpec -> BlockType
blockType :: BlockType
    -- | Parser for start of this block type
  , BlockSpec -> P ()
blockStart :: P ()
    -- | Parser that must return True if this block is to continue
  , BlockSpec -> Container -> P Bool
blockContinue :: Container -> P Bool
    -- | Just blockType if it can contain that type of block
  , BlockSpec -> Maybe BlockType
blockContainsBlock :: Maybe BlockType
    -- | True if it can accept text lines
  , BlockSpec -> Bool
blockContainsLines :: Bool
    -- | Parser that runs when block is closed, possibly
    -- updating the container.
  , BlockSpec -> Container -> P Container
blockClose :: Container -> P Container
    -- | Parser that runs when the document is closed, creating the
    -- block AST element.
  , BlockSpec -> Container -> Blocks
blockFinalize :: Container -> Blocks
  }

docSpec :: BlockSpec
docSpec :: BlockSpec
docSpec =
  BlockSpec
  { blockName :: [Char]
blockName = [Char]
"Doc"
  , blockType :: BlockType
blockType = BlockType
Document
  , blockStart :: P ()
blockStart = P ()
forall a. Parser PState a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  , blockContinue :: Container -> P Bool
blockContinue = \Container
_ -> Bool -> P Bool
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  , blockContainsBlock :: Maybe BlockType
blockContainsBlock = BlockType -> Maybe BlockType
forall a. a -> Maybe a
Just BlockType
Normal
  , blockContainsLines :: Bool
blockContainsLines = Bool
False
  , blockClose :: Container -> P Container
blockClose = Container -> P Container
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  , blockFinalize :: Container -> Blocks
blockFinalize = Container -> Blocks
finalizeChildren
  }

listItemSpec :: BlockSpec
listItemSpec :: BlockSpec
listItemSpec =
  BlockSpec
  { blockName :: [Char]
blockName = [Char]
"ListItem"
  , blockType :: BlockType
blockType = BlockType
ListItem
  , blockStart :: P ()
blockStart = do
      Int
ind <- Parser PState Int
forall st. Parser st Int
sourceColumn
      [ListType]
ltypes <- P [ListType]
pListStart
      P () -> P ()
forall s a. Parser s a -> Parser s ()
skipMany P ()
forall s. Parser s ()
spaceOrTab
      Container
tip :| [Container]
_ <- PState -> NonEmpty Container
psContainerStack (PState -> NonEmpty Container)
-> Parser PState PState -> Parser PState (NonEmpty Container)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser PState PState
forall s. Parser s s
getState
      case BlockSpec -> Maybe BlockType
blockContainsBlock (Container -> BlockSpec
containerSpec Container
tip) of
        Just BlockType
ListItem -> () -> P ()
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Maybe BlockType
_ -> BlockSpec -> Int -> ContainerData -> P ()
addContainer BlockSpec
listSpec Int
ind ContainerData
NoData
      BlockSpec -> Int -> ContainerData -> P ()
addContainer BlockSpec
listItemSpec Int
ind (Int -> [ListType] -> Bool -> ContainerData
ListItemData Int
ind [ListType]
ltypes Bool
False)
  , blockContinue :: Container -> P Bool
blockContinue = \Container
container -> do
          Bool
True Bool -> P () -> P Bool
forall a b. a -> Parser PState b -> Parser PState a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ P () -> P ()
forall s a. Parser s a -> Parser s ()
fails
            (do P () -> P ()
forall s a. Parser s a -> Parser s ()
skipMany P ()
forall s. Parser s ()
spaceOrTab
                Int
curind <- Parser PState Int
forall st. Parser st Int
sourceColumn
                let liIndent :: Int
liIndent = case Container -> ContainerData
containerData Container
container of
                                 ListItemData Int
i [ListType]
_ Bool
_ -> Int
i
                                 ContainerData
_ -> [Char] -> Int
forall a. HasCallStack => [Char] -> a
error [Char]
"Missing ListItemData"
                Container
tip :| [Container]
_ <- PState -> NonEmpty Container
psContainerStack (PState -> NonEmpty Container)
-> Parser PState PState -> Parser PState (NonEmpty Container)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser PState PState
forall s. Parser s s
getState
                Bool -> P ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
curind Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
liIndent)
                case BlockSpec -> [Char]
blockName (Container -> BlockSpec
containerSpec Container
tip) of
                  [Char]
"Para" -> P [ListType] -> P ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void P [ListType]
pListStart
                  [Char]
_ -> () -> P ()
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
        P Bool -> P Bool -> P Bool
forall a. Parser PState a -> Parser PState a -> Parser PState a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool
True Bool -> P () -> P Bool
forall a b. a -> Parser PState b -> Parser PState a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ P ()
forall s. Parser s ()
followedByBlankLine
        P Bool -> P Bool -> P Bool
forall a. Parser PState a -> Parser PState a -> Parser PState a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> P Bool
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  , blockContainsBlock :: Maybe BlockType
blockContainsBlock = BlockType -> Maybe BlockType
forall a. a -> Maybe a
Just BlockType
Normal
  , blockContainsLines :: Bool
blockContainsLines = Bool
False
  , blockClose :: Container -> P Container
blockClose = Container -> P Container
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  , blockFinalize :: Container -> Blocks
blockFinalize = Container -> Blocks
finalizeChildren
  }

pListStart :: P [ListType]
pListStart :: P [ListType]
pListStart = P [ListType]
pBulletListStart P [ListType] -> P [ListType] -> P [ListType]
forall a. Parser PState a -> Parser PState a -> Parser PState a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P [ListType]
pDefinitionListStart P [ListType] -> P [ListType] -> P [ListType]
forall a. Parser PState a -> Parser PState a -> Parser PState a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P [ListType]
pOrderedListStart

pBulletListStart :: P [ListType]
pBulletListStart :: P [ListType]
pBulletListStart = do
  Char
bulletchar <- (Char -> Bool) -> Parser PState Char
forall s. (Char -> Bool) -> Parser s Char
satisfyByte (\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
'*')
  P ()
forall s. Parser s ()
followedByWhitespace
  (do P () -> P ()
forall s a. Parser s a -> Parser s ()
skipMany P ()
forall s. Parser s ()
spaceOrTab
      Char -> P ()
forall s. Char -> Parser s ()
asciiChar Char
'['
      TaskStatus
status <- (TaskStatus
Complete TaskStatus -> P () -> Parser PState TaskStatus
forall a b. a -> Parser PState b -> Parser PState a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> P ()
forall s. ByteString -> Parser s ()
byteString ByteString
"x]")
            Parser PState TaskStatus
-> Parser PState TaskStatus -> Parser PState TaskStatus
forall a. Parser PState a -> Parser PState a -> Parser PState a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (TaskStatus
Complete TaskStatus -> P () -> Parser PState TaskStatus
forall a b. a -> Parser PState b -> Parser PState a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> P ()
forall s. ByteString -> Parser s ()
byteString ByteString
"X]")
            Parser PState TaskStatus
-> Parser PState TaskStatus -> Parser PState TaskStatus
forall a. Parser PState a -> Parser PState a -> Parser PState a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (TaskStatus
Incomplete TaskStatus -> P () -> Parser PState TaskStatus
forall a b. a -> Parser PState b -> Parser PState a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> P ()
forall s. ByteString -> Parser s ()
byteString ByteString
" ]")
      P ()
forall s. Parser s ()
followedByWhitespace
      [ListType] -> P [ListType]
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [TaskStatus -> ListType
Task TaskStatus
status])
   P [ListType] -> P [ListType] -> P [ListType]
forall a. Parser PState a -> Parser PState a -> Parser PState a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [ListType] -> P [ListType]
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char -> ListType
Bullet Char
bulletchar]

pDefinitionListStart :: P [ListType]
pDefinitionListStart :: P [ListType]
pDefinitionListStart = do
  Char -> P ()
forall s. Char -> Parser s ()
asciiChar Char
':'
  P ()
forall s. Parser s ()
followedByWhitespace
  [ListType] -> P [ListType]
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ListType
Definition]

groupLists :: Seq Container -> Seq ([ListType], Seq Container)
groupLists :: Seq Container -> Seq ([ListType], Seq Container)
groupLists = ([ListType], Seq ([ListType], Seq Container))
-> Seq ([ListType], Seq Container)
forall a b. (a, b) -> b
snd (([ListType], Seq ([ListType], Seq Container))
 -> Seq ([ListType], Seq Container))
-> (Seq Container -> ([ListType], Seq ([ListType], Seq Container)))
-> Seq Container
-> Seq ([ListType], Seq Container)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([ListType], Seq ([ListType], Seq Container))
 -> Container -> ([ListType], Seq ([ListType], Seq Container)))
-> ([ListType], Seq ([ListType], Seq Container))
-> Seq Container
-> ([ListType], Seq ([ListType], Seq Container))
forall b a. (b -> a -> b) -> b -> Seq a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([ListType], Seq ([ListType], Seq Container))
-> Container -> ([ListType], Seq ([ListType], Seq Container))
go ([], Seq ([ListType], Seq Container)
forall a. Monoid a => a
mempty)
 where
   go :: ([ListType], Seq ([ListType], Seq Container))
      -> Container
      -> ([ListType], Seq ([ListType], Seq Container))
   go :: ([ListType], Seq ([ListType], Seq Container))
-> Container -> ([ListType], Seq ([ListType], Seq Container))
go ([ListType]
curtypes, Seq ([ListType], Seq Container)
lists) Container
cont =
     case Seq ([ListType], Seq Container)
-> ViewR ([ListType], Seq Container)
forall a. Seq a -> ViewR a
Seq.viewr Seq ([ListType], Seq Container)
lists of
       ViewR ([ListType], Seq Container)
Seq.EmptyR -> (Container -> [ListType]
getListTypes Container
cont,
                       ([ListType], Seq Container) -> Seq ([ListType], Seq Container)
forall a. a -> Seq a
Seq.singleton (Container -> [ListType]
getListTypes Container
cont, Container -> Seq Container
forall a. a -> Seq a
Seq.singleton Container
cont))
       Seq ([ListType], Seq Container)
rest Seq.:> ([ListType]
_, Seq Container
cur) ->
         let lt :: [ListType]
lt = Container -> [ListType]
getListTypes Container
cont
             matchedTypes :: [ListType]
matchedTypes = [ListType
ty | ListType
ty <- [ListType]
curtypes, (ListType -> Bool) -> [ListType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ListType
ty ListType -> ListType -> Bool
`matches`) [ListType]
lt]
         in if [ListType] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ListType]
matchedTypes
               then (Container -> [ListType]
getListTypes Container
cont, Seq ([ListType], Seq Container)
lists Seq ([ListType], Seq Container)
-> ([ListType], Seq Container) -> Seq ([ListType], Seq Container)
forall a. Seq a -> a -> Seq a
Seq.|> (Container -> [ListType]
getListTypes Container
cont, Container -> Seq Container
forall a. a -> Seq a
Seq.singleton Container
cont)) -- new list
               else ([ListType]
matchedTypes, Seq ([ListType], Seq Container)
rest Seq ([ListType], Seq Container)
-> ([ListType], Seq Container) -> Seq ([ListType], Seq Container)
forall a. Seq a -> a -> Seq a
Seq.|> ([ListType]
matchedTypes, Seq Container
cur Seq Container -> Container -> Seq Container
forall a. Seq a -> a -> Seq a
Seq.|> Container
cont))

   matches :: ListType -> ListType -> Bool
   matches :: ListType -> ListType -> Bool
matches (Bullet Char
b1) (Bullet Char
b2) = Char
b1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
b2
   matches (Ordered OrderedListAttributes
o1) (Ordered OrderedListAttributes
o2) =
     OrderedListAttributes -> OrderedListStyle
orderedListStyle OrderedListAttributes
o1 OrderedListStyle -> OrderedListStyle -> Bool
forall a. Eq a => a -> a -> Bool
== OrderedListAttributes -> OrderedListStyle
orderedListStyle OrderedListAttributes
o2 Bool -> Bool -> Bool
&&
     OrderedListAttributes -> OrderedListDelim
orderedListDelim OrderedListAttributes
o1 OrderedListDelim -> OrderedListDelim -> Bool
forall a. Eq a => a -> a -> Bool
== OrderedListAttributes -> OrderedListDelim
orderedListDelim OrderedListAttributes
o2
   matches ListType
Definition ListType
Definition = Bool
True
   matches Task{} Task{} = Bool
True
   matches ListType
_ ListType
_ = Bool
False


getListTypes :: Container -> [ListType]
getListTypes :: Container -> [ListType]
getListTypes Container
cont = case Container -> ContainerData
containerData Container
cont of
                      ListItemData Int
_ [ListType]
tys Bool
_ -> [ListType]
tys
                      ContainerData
_ -> [Char] -> [ListType]
forall a. HasCallStack => [Char] -> a
error [Char]
"Missing ListItemData"

pOrderedListStart :: P [ListType]
pOrderedListStart :: P [ListType]
pOrderedListStart = do
  Bool
openParen <- (Bool
True Bool -> P () -> P Bool
forall a b. a -> Parser PState b -> Parser PState a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> P ()
forall s. Char -> Parser s ()
asciiChar Char
'(') P Bool -> P Bool -> P Bool
forall a. Parser PState a -> Parser PState a -> Parser PState a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> P Bool
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  P () -> P ()
forall s a. Parser s a -> Parser s a
lookahead (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$ do
    P () -> P ()
forall s a. Parser s a -> Parser s ()
skipSome (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> P ()
forall s. (Char -> Bool) -> Parser s ()
skipSatisfyByte (\Char
c -> Char -> Bool
isAscii Char
c Bool -> Bool -> Bool
&& Char -> Bool
isAlphaNum Char
c)
    (Char -> Bool) -> P ()
forall s. (Char -> Bool) -> Parser s ()
skipSatisfyByte (\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
')')
  [(OrderedListStyle, Int)]
stylesAndStarts <- Parser PState [(OrderedListStyle, Int)]
forall {s}. Parser s [(OrderedListStyle, Int)]
decimalStart Parser PState [(OrderedListStyle, Int)]
-> Parser PState [(OrderedListStyle, Int)]
-> Parser PState [(OrderedListStyle, Int)]
forall a. Parser PState a -> Parser PState a -> Parser PState a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser PState [(OrderedListStyle, Int)]
romanStart Parser PState [(OrderedListStyle, Int)]
-> Parser PState [(OrderedListStyle, Int)]
-> Parser PState [(OrderedListStyle, Int)]
forall a. Parser PState a -> Parser PState a -> Parser PState a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser PState [(OrderedListStyle, Int)]
forall {s}. Parser s [(OrderedListStyle, Int)]
letterStart
  OrderedListDelim
delimType <-
    if Bool
openParen
       then OrderedListDelim
LeftRightParen OrderedListDelim -> P () -> Parser PState OrderedListDelim
forall a b. a -> Parser PState b -> Parser PState a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> P ()
forall s. Char -> Parser s ()
asciiChar Char
')'
       else (OrderedListDelim
RightParen OrderedListDelim -> P () -> Parser PState OrderedListDelim
forall a b. a -> Parser PState b -> Parser PState a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> P ()
forall s. Char -> Parser s ()
asciiChar Char
')') Parser PState OrderedListDelim
-> Parser PState OrderedListDelim -> Parser PState OrderedListDelim
forall a. Parser PState a -> Parser PState a -> Parser PState a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (OrderedListDelim
RightPeriod OrderedListDelim -> P () -> Parser PState OrderedListDelim
forall a b. a -> Parser PState b -> Parser PState a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> P ()
forall s. Char -> Parser s ()
asciiChar Char
'.')
  P ()
forall s. Parser s ()
followedByWhitespace
  [ListType] -> P [ListType]
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ListType] -> P [ListType]) -> [ListType] -> P [ListType]
forall a b. (a -> b) -> a -> b
$ ((OrderedListStyle, Int) -> ListType)
-> [(OrderedListStyle, Int)] -> [ListType]
forall a b. (a -> b) -> [a] -> [b]
map
    (\(OrderedListStyle
style, Int
start) -> OrderedListAttributes -> ListType
Ordered
        OrderedListAttributes
        { orderedListStyle :: OrderedListStyle
orderedListStyle = OrderedListStyle
style
        , orderedListDelim :: OrderedListDelim
orderedListDelim = OrderedListDelim
delimType
        , orderedListStart :: Int
orderedListStart = Int
start }) [(OrderedListStyle, Int)]
stylesAndStarts
 where
  decimalStart :: Parser s [(OrderedListStyle, Int)]
decimalStart = do
    [Char]
digits <- Parser s Char -> Parser s [Char]
forall a. Parser s a -> Parser s [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ((Char -> Bool) -> Parser s Char
forall s. (Char -> Bool) -> Parser s Char
satisfyByte Char -> Bool
isDigit)
    case [Char] -> Maybe Int
forall a. Read a => [Char] -> Maybe a
readMaybe [Char]
digits of
      Just Int
n -> [(OrderedListStyle, Int)] -> Parser s [(OrderedListStyle, Int)]
forall a. a -> Parser s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(OrderedListStyle
Decimal, Int
n)]
      Maybe Int
Nothing -> Parser s [(OrderedListStyle, Int)]
forall a. Parser s a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  letterStart :: Parser s [(OrderedListStyle, Int)]
letterStart = do
    Char
c <- (Char -> Bool) -> Parser s Char
forall s. (Char -> Bool) -> Parser s Char
satisfyByte (\Char
c -> Char -> Bool
isAsciiLower Char
c Bool -> Bool -> Bool
|| Char -> Bool
isAsciiUpper Char
c)
    if Char -> Bool
isAsciiLower Char
c
       then [(OrderedListStyle, Int)] -> Parser s [(OrderedListStyle, Int)]
forall a. a -> Parser s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(OrderedListStyle
LetterLower, Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'a'))]
       else [(OrderedListStyle, Int)] -> Parser s [(OrderedListStyle, Int)]
forall a. a -> Parser s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(OrderedListStyle
LetterUpper, Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'A'))]
  romanStart :: Parser PState [(OrderedListStyle, Int)]
romanStart = do
    (Int
n, Case
lettercase) <- P (Int, Case)
pRomanNumeral
    let sty :: OrderedListStyle
sty = if Case
lettercase Case -> Case -> Bool
forall a. Eq a => a -> a -> Bool
== Case
Uppercase then OrderedListStyle
RomanUpper else OrderedListStyle
RomanLower
    let altsty :: OrderedListStyle
altsty = if Case
lettercase Case -> Case -> Bool
forall a. Eq a => a -> a -> Bool
== Case
Uppercase then OrderedListStyle
LetterUpper else OrderedListStyle
LetterLower
    [(OrderedListStyle, Int)]
-> Parser PState [(OrderedListStyle, Int)]
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(OrderedListStyle, Int)]
 -> Parser PState [(OrderedListStyle, Int)])
-> [(OrderedListStyle, Int)]
-> Parser PState [(OrderedListStyle, Int)]
forall a b. (a -> b) -> a -> b
$ (OrderedListStyle
sty, Int
n) (OrderedListStyle, Int)
-> [(OrderedListStyle, Int)] -> [(OrderedListStyle, Int)]
forall a. a -> [a] -> [a]
:
      case Int
n of
        Int
1 -> [(OrderedListStyle
altsty, Int
9)]
        Int
5 -> [(OrderedListStyle
altsty, Int
22)]
        Int
10 -> [(OrderedListStyle
altsty, Int
24)]
        Int
50 -> [(OrderedListStyle
altsty, Int
12)]
        Int
100 -> [(OrderedListStyle
altsty, Int
3)]
        Int
500 -> [(OrderedListStyle
altsty, Int
4)]
        Int
1000 -> [(OrderedListStyle
altsty, Int
13)]
        Int
_ -> []

data Case = Uppercase | Lowercase
  deriving (Case -> Case -> Bool
(Case -> Case -> Bool) -> (Case -> Case -> Bool) -> Eq Case
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Case -> Case -> Bool
== :: Case -> Case -> Bool
$c/= :: Case -> Case -> Bool
/= :: Case -> Case -> Bool
Eq)

pRomanNumeral :: P (Int, Case)
pRomanNumeral :: P (Int, Case)
pRomanNumeral = do
  let isUpperRomanChar :: Char -> Bool
isUpperRomanChar Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'I' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'V' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'X' Bool -> Bool -> Bool
||
                           Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'L' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'C' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'D' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'M'
  let isLowerRomanChar :: Char -> Bool
isLowerRomanChar Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'i' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'v' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'x' Bool -> Bool -> Bool
||
                           Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'l' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'c' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'd' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'm'
  let isRomanChar :: Char -> Bool
isRomanChar Char
c = Char -> Bool
isUpperRomanChar Char
c Bool -> Bool -> Bool
|| Char -> Bool
isLowerRomanChar Char
c
  Case
lettercase <- Parser PState Case -> Parser PState Case
forall s a. Parser s a -> Parser s a
lookahead (Parser PState Case -> Parser PState Case)
-> Parser PState Case -> Parser PState Case
forall a b. (a -> b) -> a -> b
$ do
    Char
c <- (Char -> Bool) -> Parser PState Char
forall s. (Char -> Bool) -> Parser s Char
satisfyByte Char -> Bool
isRomanChar
    let lettercase :: Case
lettercase = if Char -> Bool
isUpperRomanChar Char
c then Case
Uppercase else Case
Lowercase
    P () -> P ()
forall s a. Parser s a -> Parser s ()
skipMany (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> P ()
forall s. (Char -> Bool) -> Parser s ()
skipSatisfyByte ((Char -> Bool) -> P ()) -> (Char -> Bool) -> P ()
forall a b. (a -> b) -> a -> b
$
      case Case
lettercase of
        Case
Uppercase -> Char -> Bool
isUpperRomanChar
        Case
Lowercase -> Char -> Bool
isLowerRomanChar
    (Char -> Bool) -> P ()
forall s. (Char -> Bool) -> Parser s ()
skipSatisfyByte (\Char
d -> Char
d Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
')' Bool -> Bool -> Bool
|| Char
d Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.')
    Case -> Parser PState Case
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Case
lettercase
  let rchar :: Char -> Char -> Parser s Char
rchar Char
uc Char
lc = (Char -> Bool) -> Parser s Char
forall s. (Char -> Bool) -> Parser s Char
satisfyByte ((Char -> Bool) -> Parser s Char)
-> (Char -> Bool) -> Parser s Char
forall a b. (a -> b) -> a -> b
$ if Case
lettercase Case -> Case -> Bool
forall a. Eq a => a -> a -> Bool
== Case
Uppercase
                                       then (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
uc)
                                       else (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
lc)
  let one :: Parser s Char
one         = Char -> Char -> Parser s Char
forall {s}. Char -> Char -> Parser s Char
rchar Char
'I' Char
'i'
  let five :: Parser s Char
five        = Char -> Char -> Parser s Char
forall {s}. Char -> Char -> Parser s Char
rchar Char
'V' Char
'v'
  let ten :: Parser s Char
ten         = Char -> Char -> Parser s Char
forall {s}. Char -> Char -> Parser s Char
rchar Char
'X' Char
'x'
  let fifty :: Parser s Char
fifty       = Char -> Char -> Parser s Char
forall {s}. Char -> Char -> Parser s Char
rchar Char
'L' Char
'l'
  let hundred :: Parser s Char
hundred     = Char -> Char -> Parser s Char
forall {s}. Char -> Char -> Parser s Char
rchar Char
'C' Char
'c'
  let fivehundred :: Parser s Char
fivehundred = Char -> Char -> Parser s Char
forall {s}. Char -> Char -> Parser s Char
rchar Char
'D' Char
'd'
  let thousand :: Parser s Char
thousand    = Char -> Char -> Parser s Char
forall {s}. Char -> Char -> Parser s Char
rchar Char
'M' Char
'm'
  Int
thousands <- (Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
*) (Int -> Int) -> ([Char] -> Int) -> [Char] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Char] -> Int) -> Parser PState [Char] -> Parser PState Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser PState Char -> Parser PState [Char]
forall a. Parser PState a -> Parser PState [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser PState Char
forall {s}. Parser s Char
thousand
  Int
ninehundreds <- Int -> Parser PState Int -> Parser PState Int
forall {f :: * -> *} {a}. Alternative f => a -> f a -> f a
option Int
0 (Parser PState Int -> Parser PState Int)
-> Parser PState Int -> Parser PState Int
forall a b. (a -> b) -> a -> b
$ Parser PState Char
forall {s}. Parser s Char
hundred Parser PState Char -> Parser PState Char -> Parser PState Char
forall a b. Parser PState a -> Parser PState b -> Parser PState b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser PState Char
forall {s}. Parser s Char
thousand Parser PState Char -> Parser PState Int -> Parser PState Int
forall a b. Parser PState a -> Parser PState b -> Parser PState b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Parser PState Int
forall a. a -> Parser PState a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
900
  Int
fivehundreds <- Int -> Parser PState Int -> Parser PState Int
forall {f :: * -> *} {a}. Alternative f => a -> f a -> f a
option Int
0 (Parser PState Int -> Parser PState Int)
-> Parser PState Int -> Parser PState Int
forall a b. (a -> b) -> a -> b
$ Int
500 Int -> Parser PState Char -> Parser PState Int
forall a b. a -> Parser PState b -> Parser PState a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parser PState Char
forall {s}. Parser s Char
fivehundred
  Int
fourhundreds <- Int -> Parser PState Int -> Parser PState Int
forall {f :: * -> *} {a}. Alternative f => a -> f a -> f a
option Int
0 (Parser PState Int -> Parser PState Int)
-> Parser PState Int -> Parser PState Int
forall a b. (a -> b) -> a -> b
$ Parser PState Char
forall {s}. Parser s Char
hundred Parser PState Char -> Parser PState Char -> Parser PState Char
forall a b. Parser PState a -> Parser PState b -> Parser PState b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser PState Char
forall {s}. Parser s Char
fivehundred Parser PState Char -> Parser PState Int -> Parser PState Int
forall a b. Parser PState a -> Parser PState b -> Parser PState b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Parser PState Int
forall a. a -> Parser PState a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
400
  Int
hundreds <- (Int
100 Int -> Int -> Int
forall a. Num a => a -> a -> a
*) (Int -> Int) -> ([Char] -> Int) -> [Char] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Char] -> Int) -> Parser PState [Char] -> Parser PState Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser PState Char -> Parser PState [Char]
forall a. Parser PState a -> Parser PState [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser PState Char
forall {s}. Parser s Char
hundred
  Int
nineties <- Int -> Parser PState Int -> Parser PState Int
forall {f :: * -> *} {a}. Alternative f => a -> f a -> f a
option Int
0 (Parser PState Int -> Parser PState Int)
-> Parser PState Int -> Parser PState Int
forall a b. (a -> b) -> a -> b
$ Parser PState Char
forall {s}. Parser s Char
ten Parser PState Char -> Parser PState Char -> Parser PState Char
forall a b. Parser PState a -> Parser PState b -> Parser PState b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser PState Char
forall {s}. Parser s Char
hundred Parser PState Char -> Parser PState Int -> Parser PState Int
forall a b. Parser PState a -> Parser PState b -> Parser PState b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Parser PState Int
forall a. a -> Parser PState a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
90
  Int
fifties <- Int -> Parser PState Int -> Parser PState Int
forall {f :: * -> *} {a}. Alternative f => a -> f a -> f a
option Int
0 (Int
50 Int -> Parser PState Char -> Parser PState Int
forall a b. a -> Parser PState b -> Parser PState a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parser PState Char
forall {s}. Parser s Char
fifty)
  Int
forties <- Int -> Parser PState Int -> Parser PState Int
forall {f :: * -> *} {a}. Alternative f => a -> f a -> f a
option Int
0 (Parser PState Int -> Parser PState Int)
-> Parser PState Int -> Parser PState Int
forall a b. (a -> b) -> a -> b
$ Parser PState Char
forall {s}. Parser s Char
ten Parser PState Char -> Parser PState Char -> Parser PState Char
forall a b. Parser PState a -> Parser PState b -> Parser PState b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser PState Char
forall {s}. Parser s Char
fifty Parser PState Char -> Parser PState Int -> Parser PState Int
forall a b. Parser PState a -> Parser PState b -> Parser PState b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Parser PState Int
forall a. a -> Parser PState a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
40
  Int
tens <- (Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
*) (Int -> Int) -> ([Char] -> Int) -> [Char] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Char] -> Int) -> Parser PState [Char] -> Parser PState Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser PState Char -> Parser PState [Char]
forall a. Parser PState a -> Parser PState [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser PState Char
forall {s}. Parser s Char
ten
  Int
nines <- Int -> Parser PState Int -> Parser PState Int
forall {f :: * -> *} {a}. Alternative f => a -> f a -> f a
option Int
0 (Parser PState Int -> Parser PState Int)
-> Parser PState Int -> Parser PState Int
forall a b. (a -> b) -> a -> b
$ Parser PState Char
forall {s}. Parser s Char
one Parser PState Char -> Parser PState Char -> Parser PState Char
forall a b. Parser PState a -> Parser PState b -> Parser PState b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser PState Char
forall {s}. Parser s Char
ten Parser PState Char -> Parser PState Int -> Parser PState Int
forall a b. Parser PState a -> Parser PState b -> Parser PState b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Parser PState Int
forall a. a -> Parser PState a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
9
  Int
fives <- Int -> Parser PState Int -> Parser PState Int
forall {f :: * -> *} {a}. Alternative f => a -> f a -> f a
option Int
0 (Int
5 Int -> Parser PState Char -> Parser PState Int
forall a b. a -> Parser PState b -> Parser PState a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parser PState Char
forall {s}. Parser s Char
five)
  Int
fours <- Int -> Parser PState Int -> Parser PState Int
forall {f :: * -> *} {a}. Alternative f => a -> f a -> f a
option Int
0 (Parser PState Int -> Parser PState Int)
-> Parser PState Int -> Parser PState Int
forall a b. (a -> b) -> a -> b
$ Parser PState Char
forall {s}. Parser s Char
one Parser PState Char -> Parser PState Char -> Parser PState Char
forall a b. Parser PState a -> Parser PState b -> Parser PState b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser PState Char
forall {s}. Parser s Char
five Parser PState Char -> Parser PState Int -> Parser PState Int
forall a b. Parser PState a -> Parser PState b -> Parser PState b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Parser PState Int
forall a. a -> Parser PState a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
4
  Int
ones <- [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Char] -> Int) -> Parser PState [Char] -> Parser PState Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser PState Char -> Parser PState [Char]
forall a. Parser PState a -> Parser PState [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser PState Char
forall {s}. Parser s Char
one
  let total :: Int
total = Int
thousands Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ninehundreds Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
fivehundreds Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
fourhundreds Int -> Int -> Int
forall a. Num a => a -> a -> a
+
              Int
hundreds Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
nineties Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
fifties Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
forties Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
tens Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
nines Int -> Int -> Int
forall a. Num a => a -> a -> a
+
              Int
fives Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
fours Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ones
  if Int
total Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
     then P (Int, Case)
forall a. Parser PState a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
     else (Int, Case) -> P (Int, Case)
forall a. a -> Parser PState a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
total, Case
lettercase)
 where
   option :: a -> f a -> f a
option a
defval f a
p = f a
p f a -> f a -> f a
forall a. f a -> f a -> f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> a -> f a
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
defval

listSpec :: BlockSpec
listSpec :: BlockSpec
listSpec =
  BlockSpec
  { blockName :: [Char]
blockName = [Char]
"List"
  , blockType :: BlockType
blockType = BlockType
Normal
  , blockStart :: P ()
blockStart = P ()
forall a. Parser PState a
forall (m :: * -> *) a. MonadPlus m => m a
mzero -- added in listItemSpec
  , blockContinue :: Container -> P Bool
blockContinue = \Container
_ -> Bool -> P Bool
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  , blockContainsBlock :: Maybe BlockType
blockContainsBlock = BlockType -> Maybe BlockType
forall a. a -> Maybe a
Just BlockType
ListItem
  , blockContainsLines :: Bool
blockContainsLines = Bool
False
  , blockClose :: Container -> P Container
blockClose = Container -> P Container
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  , blockFinalize :: Container -> Blocks
blockFinalize = (([ListType], Seq Container) -> Blocks)
-> Seq ([ListType], Seq Container) -> Blocks
forall m a. Monoid m => (a -> m) -> Seq a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ([ListType], Seq Container) -> Blocks
itemsToList (Seq ([ListType], Seq Container) -> Blocks)
-> (Container -> Seq ([ListType], Seq Container))
-> Container
-> Blocks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq Container -> Seq ([ListType], Seq Container)
groupLists (Seq Container -> Seq ([ListType], Seq Container))
-> (Container -> Seq Container)
-> Container
-> Seq ([ListType], Seq Container)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Container -> Seq Container
containerChildren
  }

itemsToList :: ([ListType], Seq Container) -> Blocks
itemsToList :: ([ListType], Seq Container) -> Blocks
itemsToList ([ListType]
ltypes, Seq Container
containers) =
  case Seq Container
containers of
    Seq Container
Seq.Empty -> Blocks
forall a. Monoid a => a
mempty
    Seq Container
_ ->
       let spacing :: ListSpacing
spacing =
             case Seq Container -> ViewR Container
forall a. Seq a -> ViewR a
Seq.viewr Seq Container
containers of
               ViewR Container
Seq.EmptyR -> ListSpacing
Tight
               Seq Container
as Seq.:> Container
_ | (Container -> Bool) -> Seq Container -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Container -> Bool
itemEndsWithBlank Seq Container
as Bool -> Bool -> Bool
||
                             (Container -> Bool) -> Seq Container -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Container -> Bool
hasChildrenSeparatedWithBlank Seq Container
containers
                          -> ListSpacing
Loose
               ViewR Container
_ -> ListSpacing
Tight
           items' :: [Blocks]
items' = [Blocks] -> [Blocks]
forall a. [a] -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [Blocks]
items
           taskListStatus :: [TaskStatus]
taskListStatus = (Container -> TaskStatus) -> [Container] -> [TaskStatus]
forall a b. (a -> b) -> [a] -> [b]
map Container -> TaskStatus
getTaskStatus (Seq Container -> [Container]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Container
containers)
           pos :: Pos
pos = case (Seq Container -> ViewL Container
forall a. Seq a -> ViewL a
Seq.viewl Seq Container
containers, Seq Container -> ViewR Container
forall a. Seq a -> ViewR a
Seq.viewr Seq Container
containers) of
                    (Container
s Seq.:< Seq Container
_, Seq Container
_ Seq.:> Container
e) | Container -> Bool
containerSourcePos Container
s ->
                      Int -> Int -> Int -> Int -> Pos
Pos (Container -> Int
containerStartLine Container
s) (Container -> Int
containerStartColumn Container
s)
                          (Container -> Int
containerEndLine Container
e) (Container -> Int
containerEndColumn Container
e)
                    (ViewL Container, ViewR Container)
_ -> Pos
NoPos
       in Pos -> Node Block -> Node Block
forall a. Pos -> Node a -> Node a
addPos Pos
pos (Node Block -> Node Block) -> Blocks -> Blocks
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
          case [ListType]
ltypes of
            Bullet{} : [ListType]
_-> ListSpacing -> [Blocks] -> Blocks
bulletList ListSpacing
spacing [Blocks]
items'
            Ordered OrderedListAttributes
_ : [ListType]
_->
              OrderedListAttributes -> ListSpacing -> [Blocks] -> Blocks
orderedList ([ListType] -> OrderedListAttributes
chooseOrderedAttr [ListType]
ltypes) ListSpacing
spacing [Blocks]
items'
            ListType
Definition : [ListType]
_ -> ListSpacing -> [(Inlines, Blocks)] -> Blocks
definitionList ListSpacing
spacing ([(Inlines, Blocks)] -> Blocks) -> [(Inlines, Blocks)] -> Blocks
forall a b. (a -> b) -> a -> b
$ (Blocks -> (Inlines, Blocks)) -> [Blocks] -> [(Inlines, Blocks)]
forall a b. (a -> b) -> [a] -> [b]
map Blocks -> (Inlines, Blocks)
toDefinition [Blocks]
items'
            Task TaskStatus
_ : [ListType]
_ -> ListSpacing -> [(TaskStatus, Blocks)] -> Blocks
taskList ListSpacing
spacing ([(TaskStatus, Blocks)] -> Blocks)
-> [(TaskStatus, Blocks)] -> Blocks
forall a b. (a -> b) -> a -> b
$ [TaskStatus] -> [Blocks] -> [(TaskStatus, Blocks)]
forall a b. [a] -> [b] -> [(a, b)]
zip [TaskStatus]
taskListStatus [Blocks]
items'
            [] -> Blocks
forall a. Monoid a => a
mempty
 where
   items :: [Blocks]
items = (Container -> Blocks) -> [Container] -> [Blocks]
forall a b. (a -> b) -> [a] -> [b]
map Container -> Blocks
finalize ([Container] -> [Blocks]) -> [Container] -> [Blocks]
forall a b. (a -> b) -> a -> b
$ Seq Container -> [Container]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Container
containers
   getTaskStatus :: Container -> TaskStatus
getTaskStatus Container
cont = case Container -> [ListType]
getListTypes Container
cont of
                           ([Task TaskStatus
stat] :: [ListType]) -> TaskStatus
stat
                           [ListType]
_ -> [Char] -> TaskStatus
forall a. HasCallStack => [Char] -> a
error [Char]
"getTaskStatus: wrong shape"
   -- when ambiguous between roman and lettered list, choose roman if start number is 1,
   -- otherwise lettered
   chooseOrderedAttr :: [ListType] -> OrderedListAttributes
chooseOrderedAttr [ListType]
os =
     case [OrderedListAttributes
at | Ordered OrderedListAttributes
at <- [ListType]
os, OrderedListAttributes -> Bool
isRomanStartOne OrderedListAttributes
at] of
       (OrderedListAttributes
a:[OrderedListAttributes]
_) -> OrderedListAttributes
a
       [OrderedListAttributes]
_ -> case [OrderedListAttributes
at | Ordered OrderedListAttributes
at <- [ListType]
os, OrderedListAttributes -> Bool
isLettered OrderedListAttributes
at] of
         (OrderedListAttributes
a:[OrderedListAttributes]
_)  -> OrderedListAttributes
a
         [OrderedListAttributes]
_ -> case [OrderedListAttributes
at | Ordered OrderedListAttributes
at <- [ListType]
os] of
           (OrderedListAttributes
a:[OrderedListAttributes]
_) -> OrderedListAttributes
a
           [] -> [Char] -> OrderedListAttributes
forall a. HasCallStack => [Char] -> a
error [Char]
"chooseOrderedAttr on empty list"
   isRomanStartOne :: OrderedListAttributes -> Bool
isRomanStartOne OrderedListAttributes
at = (OrderedListAttributes -> OrderedListStyle
orderedListStyle OrderedListAttributes
at OrderedListStyle -> OrderedListStyle -> Bool
forall a. Eq a => a -> a -> Bool
== OrderedListStyle
RomanUpper Bool -> Bool -> Bool
||
                         OrderedListAttributes -> OrderedListStyle
orderedListStyle OrderedListAttributes
at OrderedListStyle -> OrderedListStyle -> Bool
forall a. Eq a => a -> a -> Bool
== OrderedListStyle
RomanLower) Bool -> Bool -> Bool
&&
                         OrderedListAttributes -> Int
orderedListStart OrderedListAttributes
at Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
   isLettered :: OrderedListAttributes -> Bool
isLettered OrderedListAttributes
at = OrderedListAttributes -> OrderedListStyle
orderedListStyle OrderedListAttributes
at OrderedListStyle -> OrderedListStyle -> Bool
forall a. Eq a => a -> a -> Bool
== OrderedListStyle
LetterUpper Bool -> Bool -> Bool
||
                   OrderedListAttributes -> OrderedListStyle
orderedListStyle OrderedListAttributes
at OrderedListStyle -> OrderedListStyle -> Bool
forall a. Eq a => a -> a -> Bool
== OrderedListStyle
LetterLower

-- | We determine whether a list item ends with a blank line by
-- comparing its end line with the end line of its last child.
itemEndsWithBlank :: Container -> Bool
itemEndsWithBlank :: Container -> Bool
itemEndsWithBlank Container
li =
  case Seq Container -> ViewR Container
forall a. Seq a -> ViewR a
Seq.viewr (Container -> Seq Container
containerChildren Container
li) of
    ViewR Container
Seq.EmptyR -> Bool
False
    Seq Container
_ Seq.:> Container
lastChild -> Container -> Int
containerEndLine Container
li Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Container -> Int
containerEndLine Container
lastChild

-- | We don't count blanks before lists, because
-- otherwise it would be impossible to have nested tight lists.
hasChildrenSeparatedWithBlank :: Container -> Bool
hasChildrenSeparatedWithBlank :: Container -> Bool
hasChildrenSeparatedWithBlank Container
cont =
  Seq Bool -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or (Seq Bool -> Bool) -> Seq Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Container -> Container -> Bool)
-> Seq Container -> Seq Container -> Seq Bool
forall a b c. (a -> b -> c) -> Seq a -> Seq b -> Seq c
Seq.zipWith Container -> Container -> Bool
check Seq Container
children (Int -> Seq Container -> Seq Container
forall a. Int -> Seq a -> Seq a
Seq.drop Int
1 Seq Container
children)
 where
   children :: Seq Container
children = (if ListType
Definition ListType -> [ListType] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ListType]
liTypes then Int -> Seq Container -> Seq Container
forall a. Int -> Seq a -> Seq a
Seq.drop Int
1 else Seq Container -> Seq Container
forall a. a -> a
id) (Seq Container -> Seq Container) -> Seq Container -> Seq Container
forall a b. (a -> b) -> a -> b
$
                  Container -> Seq Container
containerChildren Container
cont
   check :: Container -> Container -> Bool
check Container
x Container
y = (BlockSpec -> [Char]
blockName (Container -> BlockSpec
containerSpec Container
y) [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char]
"List") Bool -> Bool -> Bool
&&
               (Container -> Int
containerStartLine Container
y Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Container -> Int
containerEndLine Container
x)
   liTypes :: [ListType]
liTypes = Container -> [ListType]
getListTypes Container
cont

toDefinition :: Blocks -> (Inlines, Blocks)
toDefinition :: Blocks -> (Inlines, Blocks)
toDefinition Blocks
bs =
  case Seq (Node Block) -> ViewL (Node Block)
forall a. Seq a -> ViewL a
Seq.viewl Seq (Node Block)
bs' of
    Node Pos
_ Attr
_ (Para Inlines
ils) Seq.:< Seq (Node Block)
_ -> (Inlines
ils, Seq (Node Block) -> Blocks
forall a. Seq a -> Many a
Many (Int -> Seq (Node Block) -> Seq (Node Block)
forall a. Int -> Seq a -> Seq a
Seq.drop Int
1 Seq (Node Block)
bs'))
    ViewL (Node Block)
_ -> (Inlines
forall a. Monoid a => a
mempty, Blocks
bs)
  where
   bs' :: Seq (Node Block)
bs' = Blocks -> Seq (Node Block)
forall a. Many a -> Seq a
unMany Blocks
bs

sectionSpec :: BlockSpec
sectionSpec :: BlockSpec
sectionSpec =
  BlockSpec
  { blockName :: [Char]
blockName = [Char]
"Section"
  , blockType :: BlockType
blockType = BlockType
Normal
  , blockStart :: P ()
blockStart = P ()
forall a. Parser PState a
forall (m :: * -> *) a. MonadPlus m => m a
mzero  -- these containers are added by headingSpec
  , blockContinue :: Container -> P Bool
blockContinue = \Container
_ -> Bool -> P Bool
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True  -- these are closed by headingSpec
  , blockContainsBlock :: Maybe BlockType
blockContainsBlock = BlockType -> Maybe BlockType
forall a. a -> Maybe a
Just BlockType
Normal
  , blockContainsLines :: Bool
blockContainsLines = Bool
False
  , blockClose :: Container -> P Container
blockClose = \Container
container -> do
      case Container -> Seq Container
containerChildren Container
container of
        Container
h Seq.:<| Seq Container
_
          | BlockSpec -> [Char]
blockName (Container -> BlockSpec
containerSpec Container
h) [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"Heading" -> do
             let lev :: Int
lev = case Container -> ContainerData
containerData Container
container of
                         SectionData Int
n Maybe ByteString
_ -> Int
n
                         ContainerData
_ -> [Char] -> Int
forall a. HasCallStack => [Char] -> a
error [Char]
"Missing SectionData"
             let ils :: Inlines
ils = case Container -> ContainerData
containerData Container
h of
                         HeadingData Int
_ Inlines
xs -> Inlines
xs
                         ContainerData
_ -> [Char] -> Inlines
forall a. HasCallStack => [Char] -> a
error [Char]
"Missing HeadingData"
             (ByteString
secid, Attr
attr, ByteString
label) <- do
               let bs :: ByteString
bs = Inlines -> ByteString
inlinesToByteString Inlines
ils
               let Attr [(ByteString, ByteString)]
ats = Container -> Attr
containerAttr Container
container
               case ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"id" [(ByteString, ByteString)]
ats of
                 Just ByteString
id' -> (ByteString, Attr, ByteString)
-> Parser PState (ByteString, Attr, ByteString)
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString
id', Attr
forall a. Monoid a => a
mempty, ByteString -> ByteString
normalizeLabel ByteString
bs)
                 Maybe ByteString
Nothing -> do -- generate id from title
                   let generateId :: Int -> ByteString -> Parser PState ByteString
generateId (Int
n :: Int) ByteString
base = do
                         let candidate :: ByteString
candidate
                               | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = ByteString
base
                               | Bool
otherwise = ByteString
base ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"-" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> [Char] -> ByteString
B8.pack (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n)
                         Set ByteString
ids <- PState -> Set ByteString
psIds (PState -> Set ByteString)
-> Parser PState PState -> Parser PState (Set ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser PState PState
forall s. Parser s s
getState
                         if ByteString
candidate ByteString -> Set ByteString -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set ByteString
ids
                            then Int -> ByteString -> Parser PState ByteString
generateId (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) ByteString
base
                            else do
                              (PState -> PState) -> P ()
forall s. (s -> s) -> Parser s ()
updateState ((PState -> PState) -> P ()) -> (PState -> PState) -> P ()
forall a b. (a -> b) -> a -> b
$ \PState
st ->
                                PState
st{ psIds = Set.insert candidate (psIds st)
                                  , psAutoIds = Set.insert candidate
                                                   (psAutoIds st) }
                              ByteString -> Parser PState ByteString
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
candidate
                   ByteString
ident <- Int -> ByteString -> Parser PState ByteString
generateId Int
0 (ByteString -> ByteString
toIdentifier ByteString
bs)
                   (ByteString, Attr, ByteString)
-> Parser PState (ByteString, Attr, ByteString)
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString
ident, Attr
forall a. Monoid a => a
mempty, ByteString -> ByteString
normalizeLabel ByteString
bs)
             -- add implicit reference
             let dest :: ByteString
dest = ByteString
"#" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
secid
             (PState -> PState) -> P ()
forall s. (s -> s) -> Parser s ()
updateState ((PState -> PState) -> P ()) -> (PState -> PState) -> P ()
forall a b. (a -> b) -> a -> b
$ \PState
st -> PState
st{ psAutoReferenceMap = insertReference label
                                     (dest, Attr []) (psAutoReferenceMap st) }

             Container -> P Container
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Container
container{ containerData =
                               SectionData lev (Just secid)
                           , containerAttr = containerAttr container <> attr }
        Seq Container
_ -> Container -> P Container
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Container
container
  , blockFinalize :: Container -> Blocks
blockFinalize = \Container
container ->
      let blocks :: Blocks
blocks = Container -> Blocks
finalizeChildren Container
container
          secid :: Maybe ByteString
secid = case Container -> ContainerData
containerData Container
container of
                    SectionData Int
_ Maybe ByteString
ident -> Maybe ByteString
ident
                    ContainerData
_ -> [Char] -> Maybe ByteString
forall a. HasCallStack => [Char] -> a
error [Char]
"Missing SectionData"
      in Container -> Blocks -> Blocks
addSourcePos Container
container (Blocks -> Blocks) -> Blocks -> Blocks
forall a b. (a -> b) -> a -> b
$
          (Node Block -> Node Block)
-> (ByteString -> Node Block -> Node Block)
-> Maybe ByteString
-> Node Block
-> Node Block
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Node Block -> Node Block
forall a. a -> a
id (\ByteString
ident -> Attr -> Node Block -> Node Block
forall a. Attr -> Node a -> Node a
addAttr ([(ByteString, ByteString)] -> Attr
Attr [(ByteString
"id", ByteString
ident)])) Maybe ByteString
secid
           (Node Block -> Node Block) -> Blocks -> Blocks
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Blocks -> Blocks
section Blocks
blocks
  }

blockQuoteSpec :: BlockSpec
blockQuoteSpec :: BlockSpec
blockQuoteSpec =
  BlockSpec
  { blockName :: [Char]
blockName = [Char]
"BlockQuote"
  , blockType :: BlockType
blockType = BlockType
Normal
  , blockStart :: P ()
blockStart = do
      Int
ind <- Parser PState Int
forall st. Parser st Int
sourceColumn
      Char -> P ()
forall s. Char -> Parser s ()
asciiChar Char
'>'
      P ()
forall s. Parser s ()
followedByWhitespace
      P () -> P ()
forall s a. Parser s a -> Parser s ()
skipMany P ()
forall s. Parser s ()
spaceOrTab
      BlockSpec -> Int -> ContainerData -> P ()
addContainer BlockSpec
blockQuoteSpec Int
ind ContainerData
NoData
  , blockContinue :: Container -> P Bool
blockContinue = \Container
_ -> do
      P () -> P ()
forall s a. Parser s a -> Parser s ()
skipMany P ()
forall s. Parser s ()
spaceOrTab
      Char -> P ()
forall s. Char -> Parser s ()
asciiChar Char
'>'
      P ()
forall s. Parser s ()
followedByWhitespace
      P () -> P ()
forall s a. Parser s a -> Parser s ()
skipMany P ()
forall s. Parser s ()
spaceOrTab
      Bool -> P Bool
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  , blockContainsBlock :: Maybe BlockType
blockContainsBlock = BlockType -> Maybe BlockType
forall a. a -> Maybe a
Just BlockType
Normal
  , blockContainsLines :: Bool
blockContainsLines = Bool
False
  , blockClose :: Container -> P Container
blockClose = Container -> P Container
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  , blockFinalize :: Container -> Blocks
blockFinalize = \Container
container ->
      Container -> Blocks -> Blocks
addSourcePos Container
container (Blocks -> Blocks) -> Blocks -> Blocks
forall a b. (a -> b) -> a -> b
$ Blocks -> Blocks
blockQuote (Blocks -> Blocks) -> Blocks -> Blocks
forall a b. (a -> b) -> a -> b
$ Container -> Blocks
finalizeChildren Container
container
  }

tableSpec :: BlockSpec
tableSpec :: BlockSpec
tableSpec =
  BlockSpec
  { blockName :: [Char]
blockName = [Char]
"Table"
  , blockType :: BlockType
blockType = BlockType
Normal
  , blockStart :: P ()
blockStart = do
      P () -> P ()
forall s a. Parser s a -> Parser s a
lookahead P ()
pRawTableRow
      Int
ind <- Parser PState Int
forall st. Parser st Int
sourceColumn
      BlockSpec -> Int -> ContainerData -> P ()
addContainer BlockSpec
tableSpec Int
ind ([[Cell]] -> ContainerData
TableData [[Cell]]
forall a. Monoid a => a
mempty)
  , blockContinue :: Container -> P Bool
blockContinue = \Container
container -> do
      P () -> P ()
forall s a. Parser s a -> Parser s ()
skipMany P ()
forall s. Parser s ()
spaceOrTab
      -- TODO: this is inefficient; we parse the inline contents
      -- twice. Find a better way.
      let parsedBlankOrCaption :: Bool
parsedBlankOrCaption =
            case Seq Chunk -> ViewR Chunk
forall a. Seq a -> ViewR a
Seq.viewr (Container -> Seq Chunk
containerText Container
container) of
              Seq Chunk
_ Seq.:> Chunk
c -> Bool -> Bool
not ((Char -> Bool) -> ByteString -> Bool
B8.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'|') (Chunk -> ByteString
chunkBytes Chunk
c))
              ViewR Chunk
Seq.EmptyR -> Bool
False
      (Bool
True Bool -> P () -> P Bool
forall a b. a -> Parser PState b -> Parser PState a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ -- if we just parsed a blank or caption line, no more table rows
          (Bool -> P ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not Bool
parsedBlankOrCaption) P () -> P () -> P ()
forall a b. Parser PState a -> Parser PState b -> Parser PState a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* P () -> P ()
forall s a. Parser s a -> Parser s a
lookahead P ()
pRawTableRow))
      P Bool -> P Bool -> P Bool
forall a. Parser PState a -> Parser PState a -> Parser PState a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Bool
True Bool -> P () -> P Bool
forall a b. a -> Parser PState b -> Parser PState a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ P ()
forall s. Parser s ()
followedByBlankLine)
      P Bool -> P Bool -> P Bool
forall a. Parser PState a -> Parser PState a -> Parser PState a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Bool
True Bool -> P () -> P Bool
forall a b. a -> Parser PState b -> Parser PState a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$
            (P () -> P ()
forall s a. Parser s a -> Parser s ()
skipMany P ()
forall s. Parser s ()
spaceOrTab P () -> P () -> P ()
forall a b. Parser PState a -> Parser PState b -> Parser PState b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> P () -> P ()
forall s a. Parser s a -> Parser s a
lookahead (Char -> P ()
forall s. Char -> Parser s ()
asciiChar Char
'^' P () -> P () -> P ()
forall a b. Parser PState a -> Parser PState b -> Parser PState b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> P ()
forall s. Parser s ()
spaceOrTab)))
      P Bool -> P Bool -> P Bool
forall a. Parser PState a -> Parser PState a -> Parser PState a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Bool
True Bool -> P () -> P Bool
forall a b. a -> Parser PState b -> Parser PState a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> P ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (Seq Container -> Bool
forall a. Seq a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Container -> Seq Container
containerChildren Container
container))))
  , blockContainsBlock :: Maybe BlockType
blockContainsBlock = BlockType -> Maybe BlockType
forall a. a -> Maybe a
Just BlockType
CaptionBlock
  , blockContainsLines :: Bool
blockContainsLines = Bool
True
  , blockClose :: Container -> P Container
blockClose = \Container
container -> do
      let lns :: Seq Chunk
lns = Container -> Seq Chunk
containerText Container
container
      [[Cell]]
rows <- [[Cell]] -> [[Cell]]
forall a. [a] -> [a]
reverse ([[Cell]] -> [[Cell]])
-> (([Align], [[Cell]]) -> [[Cell]])
-> ([Align], [[Cell]])
-> [[Cell]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Align], [[Cell]]) -> [[Cell]]
forall a b. (a, b) -> b
snd (([Align], [[Cell]]) -> [[Cell]])
-> Parser PState ([Align], [[Cell]]) -> Parser PState [[Cell]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (([Align], [[Cell]]) -> Chunk -> Parser PState ([Align], [[Cell]]))
-> ([Align], [[Cell]])
-> Seq Chunk
-> Parser PState ([Align], [[Cell]])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ([Align], [[Cell]]) -> Chunk -> Parser PState ([Align], [[Cell]])
parseTableRow ([], []) Seq Chunk
lns
      Container -> P Container
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Container -> P Container) -> Container -> P Container
forall a b. (a -> b) -> a -> b
$ Container
container{ containerData = TableData rows }
  , blockFinalize :: Container -> Blocks
blockFinalize = \Container
container ->
      let rows :: [[Cell]]
rows = case Container -> ContainerData
containerData Container
container of
                   TableData [[Cell]]
rs -> [[Cell]]
rs
                   ContainerData
_ -> [Char] -> [[Cell]]
forall a. HasCallStack => [Char] -> a
error [Char]
"Missing TableData"
          mbCaption :: Maybe Caption
mbCaption =
            case Seq Container -> ViewR Container
forall a. Seq a -> ViewR a
Seq.viewr (Container -> Seq Container
containerChildren Container
container) of
              ViewR Container
Seq.EmptyR -> Maybe Caption
forall a. Maybe a
Nothing
              Seq Container
_ Seq.:> Container
x -> Caption -> Maybe Caption
forall a. a -> Maybe a
Just (Caption -> Maybe Caption)
-> (Blocks -> Caption) -> Blocks -> Maybe Caption
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blocks -> Caption
Caption (Blocks -> Maybe Caption) -> Blocks -> Maybe Caption
forall a b. (a -> b) -> a -> b
$ BlockSpec -> Container -> Blocks
blockFinalize (Container -> BlockSpec
containerSpec Container
x) Container
x
      in  Container -> Blocks -> Blocks
addSourcePos Container
container (Blocks -> Blocks) -> Blocks -> Blocks
forall a b. (a -> b) -> a -> b
$ Maybe Caption -> [[Cell]] -> Blocks
table Maybe Caption
mbCaption [[Cell]]
rows
  }

parseTableRow :: ([Align], [[Cell]])
              -> Chunk
              -> P ([Align], [[Cell]])
parseTableRow :: ([Align], [[Cell]]) -> Chunk -> Parser PState ([Align], [[Cell]])
parseTableRow ([Align]
aligns, [[Cell]]
rows) Chunk
chunk =
  case ByteString -> Maybe (Char, ByteString)
B8.uncons (ByteString -> ByteString
B8.strip (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Chunk -> ByteString
chunkBytes Chunk
chunk) of
    Just (Char
'|',ByteString
_) -> do
      Either [Align] [Cell]
res <- [Align] -> Chunk -> P (Either [Align] [Cell])
pTableCells [Align]
aligns Chunk
chunk
      case Either [Align] [Cell]
res of
        Left [Align]
aligns' -> ([Align], [[Cell]]) -> Parser PState ([Align], [[Cell]])
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Align]
aligns',
                               case [[Cell]]
rows of
                                 [Cell]
r:[[Cell]]
rs -> (Align -> Cell -> Cell) -> [Align] -> [Cell] -> [Cell]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Align -> Cell -> Cell
toHeadCell [Align]
aligns' [Cell]
r [Cell] -> [[Cell]] -> [[Cell]]
forall a. a -> [a] -> [a]
: [[Cell]]
rs
                                 [] -> [] )
        Right [Cell]
cells -> ([Align], [[Cell]]) -> Parser PState ([Align], [[Cell]])
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Align]
aligns, [Cell]
cells [Cell] -> [[Cell]] -> [[Cell]]
forall a. a -> [a] -> [a]
: [[Cell]]
rows)
    Maybe (Char, ByteString)
Nothing -> ([Align], [[Cell]]) -> Parser PState ([Align], [[Cell]])
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Align]
aligns, [[Cell]]
rows)
    Just (Char
_,ByteString
_) -> Parser PState ([Align], [[Cell]])
forall a. Parser PState a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
 where
   toHeadCell :: Align -> Cell -> Cell
toHeadCell Align
align' (Cell CellType
_ Align
_ Inlines
ils) = CellType -> Align -> Inlines -> Cell
Cell CellType
HeadCell Align
align' Inlines
ils

pTableCells :: [Align] -> Chunk -> P (Either [Align] [Cell])
pTableCells :: [Align] -> Chunk -> P (Either [Align] [Cell])
pTableCells [Align]
aligns Chunk
chunk =
  case Parser () [Align] -> () -> [Chunk] -> Maybe [Align]
forall s a. Parser s a -> s -> [Chunk] -> Maybe a
parse Parser () [Align]
pTableSeps () [Chunk
chunk] of
    Just [Align]
aligns' -> Either [Align] [Cell] -> P (Either [Align] [Cell])
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [Align] [Cell] -> P (Either [Align] [Cell]))
-> Either [Align] [Cell] -> P (Either [Align] [Cell])
forall a b. (a -> b) -> a -> b
$ [Align] -> Either [Align] [Cell]
forall a b. a -> Either a b
Left [Align]
aligns'
    Maybe [Align]
Nothing -> do
      ParseOptions
opts <- PState -> ParseOptions
psParseOptions (PState -> ParseOptions)
-> Parser PState PState -> Parser PState ParseOptions
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser PState PState
forall s. Parser s s
getState
      case ParseOptions -> Chunk -> Either [Char] [Inlines]
parseTableCells ParseOptions
opts Chunk
chunk of
        Right [Inlines]
cs ->
          Either [Align] [Cell] -> P (Either [Align] [Cell])
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [Align] [Cell] -> P (Either [Align] [Cell]))
-> Either [Align] [Cell] -> P (Either [Align] [Cell])
forall a b. (a -> b) -> a -> b
$ [Cell] -> Either [Align] [Cell]
forall a b. b -> Either a b
Right ([Cell] -> Either [Align] [Cell])
-> [Cell] -> Either [Align] [Cell]
forall a b. (a -> b) -> a -> b
$
            (Align -> Inlines -> Cell) -> [Align] -> [Inlines] -> [Cell]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (CellType -> Align -> Inlines -> Cell
Cell CellType
BodyCell) ([Align]
aligns [Align] -> [Align] -> [Align]
forall a. [a] -> [a] -> [a]
++ Align -> [Align]
forall a. a -> [a]
repeat Align
AlignDefault) [Inlines]
cs
        Left [Char]
_ -> P (Either [Align] [Cell])
forall a. Parser PState a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

pTableSeps :: Parser () [Align]
pTableSeps :: Parser () [Align]
pTableSeps = do
  Parser () () -> Parser () ()
forall s a. Parser s a -> Parser s ()
skipMany Parser () ()
forall s. Parser s ()
spaceOrTab
  Char -> Parser () ()
forall s. Char -> Parser s ()
asciiChar Char
'|'
  Parser () Align -> Parser () [Align]
forall a. Parser () a -> Parser () [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser () Align
forall {s}. Parser s Align
pTableSep Parser () [Align] -> Parser () () -> Parser () [Align]
forall a b. Parser () a -> Parser () b -> Parser () a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser () () -> Parser () ()
forall s a. Parser s a -> Parser s ()
skipMany Parser () ()
forall s. Parser s ()
ws Parser () [Align] -> Parser () () -> Parser () [Align]
forall a b. Parser () a -> Parser () b -> Parser () a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser () ()
forall s. Parser s ()
eof
 where
   pTableSep :: Parser s Align
pTableSep = do
     Parser s () -> Parser s ()
forall s a. Parser s a -> Parser s ()
skipMany Parser s ()
forall s. Parser s ()
spaceOrTab
     Bool
start <- (Bool
True Bool -> Parser s () -> Parser s Bool
forall a b. a -> Parser s b -> Parser s a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser s ()
forall s. Char -> Parser s ()
asciiChar Char
':') Parser s Bool -> Parser s Bool -> Parser s Bool
forall a. Parser s a -> Parser s a -> Parser s a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> Parser s Bool
forall a. a -> Parser s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
     Parser s () -> Parser s ()
forall s a. Parser s a -> Parser s ()
skipSome (Char -> Parser s ()
forall s. Char -> Parser s ()
asciiChar Char
'-')
     Bool
end <- (Bool
True Bool -> Parser s () -> Parser s Bool
forall a b. a -> Parser s b -> Parser s a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser s ()
forall s. Char -> Parser s ()
asciiChar Char
':') Parser s Bool -> Parser s Bool -> Parser s Bool
forall a. Parser s a -> Parser s a -> Parser s a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> Parser s Bool
forall a. a -> Parser s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
     Parser s () -> Parser s ()
forall s a. Parser s a -> Parser s ()
skipMany Parser s ()
forall s. Parser s ()
spaceOrTab
     Char -> Parser s ()
forall s. Char -> Parser s ()
asciiChar Char
'|'
     Align -> Parser s Align
forall a. a -> Parser s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Align -> Parser s Align) -> Align -> Parser s Align
forall a b. (a -> b) -> a -> b
$ case (Bool
start, Bool
end) of
              (Bool
True, Bool
True) -> Align
AlignCenter
              (Bool
True, Bool
False) -> Align
AlignLeft
              (Bool
False, Bool
True) -> Align
AlignRight
              (Bool
False, Bool
False) -> Align
AlignDefault

pRawTableRow :: P ()
pRawTableRow :: P ()
pRawTableRow = do
  P () -> P ()
forall s a. Parser s a -> Parser s a
lookahead (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$ Char -> P ()
forall s. Char -> Parser s ()
asciiChar Char
'|'
  Int
curline <- Parser PState Int
forall st. Parser st Int
sourceLine
  Int
curcolumn <- Parser PState Int
forall st. Parser st Int
sourceColumn
  ByteString
bs <- Parser PState ByteString
forall s. Parser s ByteString
restOfLine
  Parser PState ([Align], [[Cell]]) -> P ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser PState ([Align], [[Cell]]) -> P ())
-> Parser PState ([Align], [[Cell]]) -> P ()
forall a b. (a -> b) -> a -> b
$ ([Align], [[Cell]]) -> Chunk -> Parser PState ([Align], [[Cell]])
parseTableRow ([],[]) Chunk{ chunkLine :: Int
chunkLine = Int
curline
                                    , chunkColumn :: Int
chunkColumn = Int
curcolumn
                                    , chunkBytes :: ByteString
chunkBytes = ByteString
bs }

captionSpec :: BlockSpec
captionSpec :: BlockSpec
captionSpec =
  BlockSpec
  { blockName :: [Char]
blockName = [Char]
"Caption"
  , blockType :: BlockType
blockType = BlockType
CaptionBlock
  , blockStart :: P ()
blockStart = do
      Int
ind <- Parser PState Int
forall st. Parser st Int
sourceColumn
      Char -> P ()
forall s. Char -> Parser s ()
asciiChar Char
'^'
      P () -> P ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void P ()
forall s. Parser s ()
spaceOrTab
      BlockSpec -> Int -> ContainerData -> P ()
addContainer BlockSpec
captionSpec Int
ind (ContainerData -> P ()) -> ContainerData -> P ()
forall a b. (a -> b) -> a -> b
$ Int -> ContainerData
CaptionData Int
ind
  , blockContinue :: Container -> P Bool
blockContinue = \Container
container -> (do
      P () -> P ()
forall s a. Parser s a -> Parser s ()
skipMany P ()
forall s. Parser s ()
spaceOrTab
      Int
curind <- Parser PState Int
forall st. Parser st Int
sourceColumn
      let ind :: Int
ind = case Container -> ContainerData
containerData Container
container of
                  CaptionData Int
i -> Int
i
                  ContainerData
_ -> [Char] -> Int
forall a. HasCallStack => [Char] -> a
error [Char]
"Missing CaptionData"
      Bool -> P ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
curind Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
ind) P () -> P () -> P ()
forall a. Parser PState a -> Parser PState a -> Parser PState a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P ()
forall s. Parser s ()
followedByBlankLine
      Bool -> P Bool
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True) P Bool -> P Bool -> P Bool
forall a. Parser PState a -> Parser PState a -> Parser PState a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> P Bool
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  , blockContainsBlock :: Maybe BlockType
blockContainsBlock = BlockType -> Maybe BlockType
forall a. a -> Maybe a
Just BlockType
Normal
  , blockContainsLines :: Bool
blockContainsLines = Bool
False
  , blockClose :: Container -> P Container
blockClose = Container -> P Container
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  , blockFinalize :: Container -> Blocks
blockFinalize = Container -> Blocks
finalizeChildren
  }


thematicBreakSpec :: BlockSpec
thematicBreakSpec :: BlockSpec
thematicBreakSpec =
  BlockSpec
  { blockName :: [Char]
blockName = [Char]
"ThematicBreak"
  , blockType :: BlockType
blockType = BlockType
Normal
  , blockStart :: P ()
blockStart = do
      let breakChar :: Parser s ()
breakChar = (Char -> Bool) -> Parser s ()
forall s. (Char -> Bool) -> Parser s ()
skipSatisfyByte (\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
'*')
                        Parser s () -> Parser s () -> Parser s ()
forall a b. Parser s a -> Parser s b -> Parser s b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser s () -> Parser s ()
forall s a. Parser s a -> Parser s ()
skipMany Parser s ()
forall s. Parser s ()
spaceOrTab
      Int
ind <- Parser PState Int
forall st. Parser st Int
sourceColumn
      P ()
forall s. Parser s ()
breakChar P () -> P () -> P ()
forall a b. Parser PState a -> Parser PState b -> Parser PState b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> P ()
forall s. Parser s ()
breakChar P () -> P () -> P ()
forall a b. Parser PState a -> Parser PState b -> Parser PState b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> P ()
forall s. Parser s ()
breakChar P () -> P () -> P ()
forall a b. Parser PState a -> Parser PState b -> Parser PState b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> P () -> P ()
forall s a. Parser s a -> Parser s ()
skipMany P ()
forall s. Parser s ()
breakChar
      P () -> P ()
forall s a. Parser s a -> Parser s a
lookahead P ()
forall s. Parser s ()
endline
      BlockSpec -> Int -> ContainerData -> P ()
addContainer BlockSpec
thematicBreakSpec Int
ind ContainerData
NoData
  , blockContinue :: Container -> P Bool
blockContinue = \Container
_ -> Bool -> P Bool
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  , blockContainsBlock :: Maybe BlockType
blockContainsBlock = Maybe BlockType
forall a. Maybe a
Nothing
  , blockContainsLines :: Bool
blockContainsLines = Bool
True
  , blockClose :: Container -> P Container
blockClose = Container -> P Container
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  , blockFinalize :: Container -> Blocks
blockFinalize = \Container
container -> Container -> Blocks -> Blocks
addSourcePos Container
container Blocks
thematicBreak
  }

headingSpec :: BlockSpec
headingSpec :: BlockSpec
headingSpec =
  BlockSpec
  { blockName :: [Char]
blockName = [Char]
"Heading"
  , blockType :: BlockType
blockType = BlockType
Normal
  , blockStart :: P ()
blockStart = do
      Int
ind <- Parser PState Int
forall st. Parser st Int
sourceColumn
      Int
lev <- [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([()] -> Int) -> Parser PState [()] -> Parser PState Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P () -> Parser PState [()]
forall a. Parser PState a -> Parser PState [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (Char -> P ()
forall s. Char -> Parser s ()
asciiChar Char
'#')
      P ()
forall s. Parser s ()
followedByWhitespace
      P () -> P ()
forall s a. Parser s a -> Parser s ()
skipMany P ()
forall s. Parser s ()
spaceOrTab
      Int -> P ()
closeContainingSections Int
lev
      BlockSpec -> Int -> ContainerData -> P ()
addContainer BlockSpec
sectionSpec Int
ind (ContainerData -> P ()) -> ContainerData -> P ()
forall a b. (a -> b) -> a -> b
$ Int -> Maybe ByteString -> ContainerData
SectionData Int
lev Maybe ByteString
forall a. Maybe a
Nothing
      BlockSpec -> Int -> ContainerData -> P ()
addContainer BlockSpec
headingSpec Int
ind (ContainerData -> P ()) -> ContainerData -> P ()
forall a b. (a -> b) -> a -> b
$ Int -> Inlines -> ContainerData
HeadingData Int
lev Inlines
forall a. Monoid a => a
mempty
  , blockContinue :: Container -> P Bool
blockContinue = \Container
container -> do
       do P () -> P ()
forall s a. Parser s a -> Parser s ()
skipMany P ()
forall s. Parser s ()
spaceOrTab
          let lev :: Int
lev = case Container -> ContainerData
containerData Container
container of
                      HeadingData Int
n Inlines
_ -> Int
n
                      ContainerData
_ -> [Char] -> Int
forall a. HasCallStack => [Char] -> a
error [Char]
"Missing HeadingData"
          (Bool
True Bool -> P () -> P Bool
forall a b. a -> Parser PState b -> Parser PState a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (do Int
lev' <- [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([()] -> Int) -> Parser PState [()] -> Parser PState Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P () -> Parser PState [()]
forall a. Parser PState a -> Parser PState [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (Char -> P ()
forall s. Char -> Parser s ()
asciiChar Char
'#')
                       Bool -> P ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
lev' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
lev)
                       P () -> P ()
forall s a. Parser s a -> Parser s ()
skipMany P ()
forall s. Parser s ()
spaceOrTab))
            P Bool -> P Bool -> P Bool
forall a. Parser PState a -> Parser PState a -> Parser PState a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Bool
False Bool -> P () -> P Bool
forall a b. a -> Parser PState b -> Parser PState a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ do
                    P () -> P ()
forall s a. Parser s a -> Parser s a
lookahead (Char -> P ()
forall s. Char -> Parser s ()
asciiChar Char
'#' P () -> P () -> P ()
forall a. Parser PState a -> Parser PState a -> Parser PState a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P ()
forall s. Parser s ()
endline P () -> P () -> P ()
forall a. Parser PState a -> Parser PState a -> Parser PState a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P ()
forall s. Parser s ()
eof))
            P Bool -> P Bool -> P Bool
forall a. Parser PState a -> Parser PState a -> Parser PState a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> P Bool
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  , blockContainsBlock :: Maybe BlockType
blockContainsBlock = Maybe BlockType
forall a. Maybe a
Nothing
  , blockContainsLines :: Bool
blockContainsLines = Bool
True
  , blockClose :: Container -> P Container
blockClose = \Container
container -> do
      Inlines
ils <- Container -> P Inlines
parseTextLines Container
container
      let lev :: Int
lev = case Container -> ContainerData
containerData Container
container of
                  HeadingData Int
n Inlines
_ -> Int
n
                  ContainerData
_ -> [Char] -> Int
forall a. HasCallStack => [Char] -> a
error [Char]
"Missing HeadingData"
      Container -> P Container
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Container -> P Container) -> Container -> P Container
forall a b. (a -> b) -> a -> b
$ Container
container{ containerData = HeadingData lev ils }
  , blockFinalize :: Container -> Blocks
blockFinalize = \Container
container ->
      let (Int
lev, Inlines
title) =
            case Container -> ContainerData
containerData Container
container of
              HeadingData Int
l Inlines
t -> (Int
l, Inlines
t)
              ContainerData
_ -> [Char] -> (Int, Inlines)
forall a. HasCallStack => [Char] -> a
error [Char]
"Missing HeadingData"
      in  Container -> Blocks -> Blocks
addSourcePos Container
container (Blocks -> Blocks) -> Blocks -> Blocks
forall a b. (a -> b) -> a -> b
$ Int -> Inlines -> Blocks
heading Int
lev Inlines
title
  }

codeBlockSpec :: BlockSpec
codeBlockSpec :: BlockSpec
codeBlockSpec =
  BlockSpec
  { blockName :: [Char]
blockName = [Char]
"CodeBlock"
  , blockType :: BlockType
blockType = BlockType
Normal
  , blockStart :: P ()
blockStart = do
      Int
indent <- Parser PState Int
forall st. Parser st Int
sourceColumn
      ByteString
ticks <- P () -> Parser PState ByteString
forall s a. Parser s a -> Parser s ByteString
byteStringOf (P () -> Parser PState ByteString)
-> P () -> Parser PState ByteString
forall a b. (a -> b) -> a -> b
$ Char -> P ()
forall s. Char -> Parser s ()
asciiChar Char
'`' P () -> P () -> P ()
forall a b. Parser PState a -> Parser PState b -> Parser PState b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> P ()
forall s. Char -> Parser s ()
asciiChar Char
'`' P () -> P () -> P ()
forall a b. Parser PState a -> Parser PState b -> Parser PState b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> P () -> P ()
forall s a. Parser s a -> Parser s ()
skipSome (Char -> P ()
forall s. Char -> Parser s ()
asciiChar Char
'`')
      P () -> P ()
forall s a. Parser s a -> Parser s ()
skipMany P ()
forall s. Parser s ()
spaceOrTab
      ByteString
lang <- (P () -> Parser PState ByteString
forall s a. Parser s a -> Parser s ByteString
byteStringOf
                 (P () -> P ()
forall s a. Parser s a -> Parser s ()
skipSome (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> P ()
forall s. (Char -> Bool) -> Parser s ()
skipSatisfyByte (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'`' Bool -> Bool -> Bool
&& Bool -> Bool
not (Char -> Bool
isWs Char
c)))
                  Parser PState ByteString -> P () -> Parser PState ByteString
forall a b. Parser PState a -> Parser PState b -> Parser PState a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* P () -> P ()
forall s a. Parser s a -> Parser s ()
skipMany P ()
forall s. Parser s ()
spaceOrTab)
             Parser PState ByteString
-> Parser PState ByteString -> Parser PState ByteString
forall a. Parser PState a -> Parser PState a -> Parser PState a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser PState ByteString
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
""
      P () -> P ()
forall s a. Parser s a -> Parser s a
lookahead P ()
forall s. Parser s ()
endline
      BlockSpec -> Int -> ContainerData -> P ()
addContainer BlockSpec
codeBlockSpec Int
indent (ByteString -> ByteString -> Int -> ContainerData
CodeBlockData ByteString
ticks ByteString
lang Int
indent)
  , blockContinue :: Container -> P Bool
blockContinue = \Container
container -> do
      let (ByteString
ticks, Int
indent) = case Container -> ContainerData
containerData Container
container of
                              CodeBlockData ByteString
t ByteString
_ Int
i -> (ByteString
t, Int
i)
                              ContainerData
_ -> [Char] -> (ByteString, Int)
forall a. HasCallStack => [Char] -> a
error [Char]
"Missing CodeBlockData"
      Int -> P ()
gobbleSpaceToIndent Int
indent
      (do P () -> P ()
forall s a. Parser s a -> Parser s ()
skipMany P ()
forall s. Parser s ()
spaceOrTab
          ByteString -> P ()
forall s. ByteString -> Parser s ()
byteString ByteString
ticks
          P () -> P ()
forall s a. Parser s a -> Parser s ()
skipMany (Char -> P ()
forall s. Char -> Parser s ()
asciiChar Char
'`')
          P () -> P ()
forall s a. Parser s a -> Parser s ()
skipMany P ()
forall s. Parser s ()
spaceOrTab
          P () -> P ()
forall s a. Parser s a -> Parser s a
lookahead P ()
forall s. Parser s ()
endline
          Bool -> P Bool
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)
        P Bool -> P Bool -> P Bool
forall a. Parser PState a -> Parser PState a -> Parser PState a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> P Bool
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  , blockContainsBlock :: Maybe BlockType
blockContainsBlock = Maybe BlockType
forall a. Maybe a
Nothing
  , blockContainsLines :: Bool
blockContainsLines = Bool
True
  , blockClose :: Container -> P Container
blockClose = Container -> P Container
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  , blockFinalize :: Container -> Blocks
blockFinalize = \Container
container ->
      let lang :: ByteString
lang = case Container -> ContainerData
containerData Container
container of
                   CodeBlockData ByteString
_ ByteString
l Int
_ -> ByteString
l
                   ContainerData
_ -> [Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error [Char]
"Missing CodeBlockData"
      -- drop first line which should be empty
          bs :: ByteString
bs = (Chunk -> ByteString) -> Seq Chunk -> ByteString
forall m a. Monoid m => (a -> m) -> Seq a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Chunk -> ByteString
chunkBytes (Int -> Seq Chunk -> Seq Chunk
forall a. Int -> Seq a -> Seq a
Seq.drop Int
1 (Seq Chunk -> Seq Chunk) -> Seq Chunk -> Seq Chunk
forall a b. (a -> b) -> a -> b
$ Container -> Seq Chunk
containerText Container
container)
      in  Container -> Blocks -> Blocks
addSourcePos Container
container (Blocks -> Blocks) -> Blocks -> Blocks
forall a b. (a -> b) -> a -> b
$
          case ByteString -> Maybe (Char, ByteString)
B8.uncons ByteString
lang of
            Just (Char
'=', ByteString
fmt) -> Format -> ByteString -> Blocks
rawBlock (ByteString -> Format
Format ByteString
fmt) ByteString
bs
            Maybe (Char, ByteString)
_ -> ByteString -> ByteString -> Blocks
codeBlock ByteString
lang ByteString
bs
  }

divSpec :: BlockSpec
divSpec :: BlockSpec
divSpec =
  BlockSpec
  { blockName :: [Char]
blockName = [Char]
"Div"
  , blockType :: BlockType
blockType = BlockType
Normal
  , blockStart :: P ()
blockStart = do
      Int
ind <- Parser PState Int
forall st. Parser st Int
sourceColumn
      ByteString
colons <- P () -> Parser PState ByteString
forall s a. Parser s a -> Parser s ByteString
byteStringOf (P () -> Parser PState ByteString)
-> P () -> Parser PState ByteString
forall a b. (a -> b) -> a -> b
$
        Char -> P ()
forall s. Char -> Parser s ()
asciiChar Char
':' P () -> P () -> P ()
forall a b. Parser PState a -> Parser PState b -> Parser PState b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> P ()
forall s. Char -> Parser s ()
asciiChar Char
':' P () -> P () -> P ()
forall a b. Parser PState a -> Parser PState b -> Parser PState b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> P () -> P ()
forall s a. Parser s a -> Parser s ()
skipSome (Char -> P ()
forall s. Char -> Parser s ()
asciiChar Char
':')
      P () -> P ()
forall s a. Parser s a -> Parser s ()
skipMany P ()
forall s. Parser s ()
spaceOrTab
      ByteString
label <- P () -> Parser PState ByteString
forall s a. Parser s a -> Parser s ByteString
byteStringOf (P () -> Parser PState ByteString)
-> P () -> Parser PState ByteString
forall a b. (a -> b) -> a -> b
$ P () -> P ()
forall s a. Parser s a -> Parser s ()
skipMany (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> P ()
forall s. (Char -> Bool) -> Parser s ()
skipSatisfyByte (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isWs)
      P () -> P ()
forall s a. Parser s a -> Parser s ()
skipMany P ()
forall s. Parser s ()
spaceOrTab
      P () -> P ()
forall s a. Parser s a -> Parser s a
lookahead P ()
forall s. Parser s ()
endline
      BlockSpec -> Int -> ContainerData -> P ()
addContainer BlockSpec
divSpec Int
ind (ByteString -> ByteString -> ContainerData
DivData ByteString
colons ByteString
label)
  , blockContinue :: Container -> P Bool
blockContinue = \Container
container -> (do
      Container
tip <- P Container
getTip
      -- see jgm/djot.js#109
      Bool -> P ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> P ()) -> Bool -> P ()
forall a b. (a -> b) -> a -> b
$ BlockSpec -> [Char]
blockName (Container -> BlockSpec
containerSpec Container
tip) [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char]
"CodeBlock"
      P () -> P ()
forall s a. Parser s a -> Parser s ()
skipMany P ()
forall s. Parser s ()
spaceOrTab
      let colons :: ByteString
colons = case Container -> ContainerData
containerData Container
container of
                     DivData ByteString
c ByteString
_ -> ByteString
c
                     ContainerData
_ -> [Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error [Char]
"Missing DivData"
      ByteString -> P ()
forall s. ByteString -> Parser s ()
byteString ByteString
colons
      P () -> P ()
forall s a. Parser s a -> Parser s ()
skipMany (Char -> P ()
forall s. Char -> Parser s ()
asciiChar Char
':')
      P () -> P ()
forall s a. Parser s a -> Parser s ()
skipMany P ()
forall s. Parser s ()
spaceOrTab
      P () -> P ()
forall s a. Parser s a -> Parser s a
lookahead P ()
forall s. Parser s ()
endline
      Bool -> P Bool
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False) P Bool -> P Bool -> P Bool
forall a. Parser PState a -> Parser PState a -> Parser PState a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> P Bool
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  , blockContainsBlock :: Maybe BlockType
blockContainsBlock = BlockType -> Maybe BlockType
forall a. a -> Maybe a
Just BlockType
Normal
  , blockContainsLines :: Bool
blockContainsLines = Bool
False
  , blockClose :: Container -> P Container
blockClose = Container -> P Container
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  , blockFinalize :: Container -> Blocks
blockFinalize = \Container
container ->
      let label :: ByteString
label = case Container -> ContainerData
containerData Container
container of
                     DivData ByteString
_ ByteString
l -> ByteString
l
                     ContainerData
_ -> [Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error [Char]
"Missing DivData"
      -- drop first line which should be empty
          bls :: Blocks
bls = Container -> Blocks
finalizeChildren Container
container
      in  (if ByteString -> Bool
B.null ByteString
label
              then Node Block -> Node Block
forall a. a -> a
id
              else Attr -> Node Block -> Node Block
forall a. Attr -> Node a -> Node a
addAttr ([(ByteString, ByteString)] -> Attr
Attr [(ByteString
"class", ByteString
label)])) (Node Block -> Node Block) -> Blocks -> Blocks
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
          Container -> Blocks -> Blocks
addSourcePos Container
container (Blocks -> Blocks
div Blocks
bls)
  }

attrSpec :: BlockSpec
attrSpec :: BlockSpec
attrSpec =
  BlockSpec
  { blockName :: [Char]
blockName = [Char]
"Attributes"
  , blockType :: BlockType
blockType = BlockType
Normal
  , blockStart :: P ()
blockStart = do
      Int
ind <- Parser PState Int
forall st. Parser st Int
sourceColumn
      P () -> P ()
forall s a. Parser s a -> Parser s a
lookahead (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$ Char -> P ()
forall s. Char -> Parser s ()
asciiChar Char
'{'
      BlockSpec -> Int -> ContainerData -> P ()
addContainer BlockSpec
attrSpec Int
ind (ContainerData -> P ()) -> ContainerData -> P ()
forall a b. (a -> b) -> a -> b
$ Int -> ContainerData
AttributeData Int
ind
  , blockContinue :: Container -> P Bool
blockContinue = \Container
container -> do
      let ind :: Int
ind = case Container -> ContainerData
containerData Container
container of
                  AttributeData Int
i -> Int
i
                  ContainerData
_ -> [Char] -> Int
forall a. HasCallStack => [Char] -> a
error [Char]
"Missing AttributeData"
      P () -> P ()
forall s a. Parser s a -> Parser s ()
skipMany P ()
forall s. Parser s ()
spaceOrTab
      Int
curind <- Parser PState Int
forall st. Parser st Int
sourceColumn
      Maybe AttrParserState
mbapstate <- PState -> Maybe AttrParserState
psAttrParserState (PState -> Maybe AttrParserState)
-> Parser PState PState -> Parser PState (Maybe AttrParserState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser PState PState
forall s. Parser s s
getState
      if Int
curind Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
ind
         then Bool -> P Bool
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
         else do
           let lastLine :: ByteString
lastLine = case Seq Chunk -> ViewR Chunk
forall a. Seq a -> ViewR a
Seq.viewr (Container -> Seq Chunk
containerText Container
container) of
                             Seq Chunk
_ Seq.:> Chunk
ll -> Chunk -> ByteString
chunkBytes Chunk
ll
                             ViewR Chunk
_ -> ByteString
forall a. Monoid a => a
mempty
           case Maybe AttrParserState -> ByteString -> AttrParseResult
parseAttributes Maybe AttrParserState
mbapstate ByteString
lastLine of
             Done (Attr, Int)
_ -> Bool -> P Bool
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
             Partial AttrParserState
apstate' -> do
               (PState -> PState) -> P ()
forall s. (s -> s) -> Parser s ()
updateState ((PState -> PState) -> P ()) -> (PState -> PState) -> P ()
forall a b. (a -> b) -> a -> b
$ \PState
st -> PState
st{ psAttrParserState = Just apstate' }
               Bool -> P Bool
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
             Failed Int
_ -> Bool -> P Bool
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True -- not yet: keep going!
  , blockContainsBlock :: Maybe BlockType
blockContainsBlock = Maybe BlockType
forall a. Maybe a
Nothing
  , blockContainsLines :: Bool
blockContainsLines = Bool
True
  , blockClose :: Container -> P Container
blockClose = \Container
container -> do
      let bs :: ByteString
bs = (Chunk -> ByteString) -> Seq Chunk -> ByteString
forall m a. Monoid m => (a -> m) -> Seq a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Chunk -> ByteString
chunkBytes (Seq Chunk -> ByteString) -> Seq Chunk -> ByteString
forall a b. (a -> b) -> a -> b
$ Container -> Seq Chunk
containerText Container
container
      case Maybe AttrParserState -> ByteString -> AttrParseResult
parseAttributes Maybe AttrParserState
forall a. Maybe a
Nothing ByteString
bs of
        Done (Attr
attr, Int
off)
          | (Char -> Bool) -> ByteString -> Bool
B8.all Char -> Bool
isWs (Int -> ByteString -> ByteString
B8.drop Int
off ByteString
bs) -> do
             (PState -> PState) -> P ()
forall s. (s -> s) -> Parser s ()
updateState ((PState -> PState) -> P ()) -> (PState -> PState) -> P ()
forall a b. (a -> b) -> a -> b
$ \PState
st -> PState
st{ psAttributes = psAttributes st <> attr }
             Container -> P Container
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Container
container
          | Bool
otherwise -> do
             Inlines
ils <- Container -> P Inlines
parseTextLines Container
container
             Container -> P Container
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Container -> P Container) -> Container -> P Container
forall a b. (a -> b) -> a -> b
$ Container
container{ containerSpec = paraSpec
                             , containerInlines = ils }
        AttrParseResult
_ -> do  -- could not parse lines as attribute, treat as Para
          Inlines
ils <- Container -> P Inlines
parseTextLines Container
container
          Container -> P Container
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Container -> P Container) -> Container -> P Container
forall a b. (a -> b) -> a -> b
$ Container
container{ containerSpec = paraSpec
                          , containerInlines = ils }
  , blockFinalize :: Container -> Blocks
blockFinalize = Blocks -> Container -> Blocks
forall a b. a -> b -> a
const Blocks
forall a. Monoid a => a
mempty
  }

referenceDefinitionSpec :: BlockSpec
referenceDefinitionSpec :: BlockSpec
referenceDefinitionSpec =
  BlockSpec
  { blockName :: [Char]
blockName = [Char]
"ReferenceDefinition"
  , blockType :: BlockType
blockType = BlockType
Normal
  , blockStart :: P ()
blockStart = do
      Int
ind <- Parser PState Int
forall st. Parser st Int
sourceColumn
      Char -> P ()
forall s. Char -> Parser s ()
asciiChar Char
'['
      P () -> P ()
forall s a. Parser s a -> Parser s ()
fails (Char -> P ()
forall s. Char -> Parser s ()
asciiChar Char
'^') -- footnote
      ByteString
label <- Parser PState [()] -> Parser PState ByteString
forall s a. Parser s a -> Parser s ByteString
byteStringOf
                (P () -> Parser PState [()]
forall a. Parser PState a -> Parser PState [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ((Char -> Bool) -> P ()
forall s. (Char -> Bool) -> Parser s ()
skipSatisfyByte (\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
'\n')))
      Char -> P ()
forall s. Char -> Parser s ()
asciiChar Char
']'
      Char -> P ()
forall s. Char -> Parser s ()
asciiChar Char
':'
      P () -> P ()
forall s a. Parser s a -> Parser s ()
skipMany P ()
forall s. Parser s ()
spaceOrTab
      BlockSpec -> Int -> ContainerData -> P ()
addContainer BlockSpec
referenceDefinitionSpec Int
ind
        (ByteString -> ContainerData
ReferenceData (ByteString -> ByteString
normalizeLabel ByteString
label))
  , blockContinue :: Container -> P Bool
blockContinue = \Container
_ ->
      Bool
True Bool -> P () -> P Bool
forall a b. a -> Parser PState b -> Parser PState a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ P () -> P ()
forall s a. Parser s a -> Parser s ()
skipSome P ()
forall s. Parser s ()
spaceOrTab P () -> P () -> P ()
forall s a b. Parser s a -> Parser s b -> Parser s a
`notFollowedBy` P ()
forall s. Parser s ()
endline
  , blockContainsBlock :: Maybe BlockType
blockContainsBlock = Maybe BlockType
forall a. Maybe a
Nothing
  , blockContainsLines :: Bool
blockContainsLines = Bool
True
  , blockClose :: Container -> P Container
blockClose = \Container
container -> do
      let label :: ByteString
label = case Container -> ContainerData
containerData Container
container of
                    ReferenceData ByteString
l -> ByteString
l
                    ContainerData
_ -> [Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error [Char]
"Missing ReferenceData"
      let attr :: Attr
attr = Container -> Attr
containerAttr Container
container
      let dest :: ByteString
dest = (Word8 -> Bool) -> ByteString -> ByteString
B.filter (Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
> Word8
32) (ByteString -> ByteString)
-> (Seq Chunk -> ByteString) -> Seq Chunk -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Chunk -> ByteString) -> Seq Chunk -> ByteString
forall m a. Monoid m => (a -> m) -> Seq a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Chunk -> ByteString
chunkBytes (Seq Chunk -> ByteString) -> Seq Chunk -> ByteString
forall a b. (a -> b) -> a -> b
$ Container -> Seq Chunk
containerText Container
container
      (PState -> PState) -> P ()
forall s. (s -> s) -> Parser s ()
updateState ((PState -> PState) -> P ()) -> (PState -> PState) -> P ()
forall a b. (a -> b) -> a -> b
$ \PState
st ->
        PState
st{ psReferenceMap = insertReference label (dest, attr)
                                 (psReferenceMap st) }
      Container -> P Container
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Container
container
  , blockFinalize :: Container -> Blocks
blockFinalize = Blocks -> Container -> Blocks
forall a b. a -> b -> a
const Blocks
forall a. Monoid a => a
mempty
  }

footnoteSpec :: BlockSpec
footnoteSpec :: BlockSpec
footnoteSpec =
  BlockSpec
  { blockName :: [Char]
blockName = [Char]
"Footnote"
  , blockType :: BlockType
blockType = BlockType
Normal
  , blockStart :: P ()
blockStart = do
      Int
ind <- Parser PState Int
forall st. Parser st Int
sourceColumn
      Char -> P ()
forall s. Char -> Parser s ()
asciiChar Char
'['
      Char -> P ()
forall s. Char -> Parser s ()
asciiChar Char
'^'
      ByteString
label <- Parser PState [()] -> Parser PState ByteString
forall s a. Parser s a -> Parser s ByteString
byteStringOf
                (P () -> Parser PState [()]
forall a. Parser PState a -> Parser PState [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ((Char -> Bool) -> P ()
forall s. (Char -> Bool) -> Parser s ()
skipSatisfyByte (\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
'\n')))
      Char -> P ()
forall s. Char -> Parser s ()
asciiChar Char
']'
      Char -> P ()
forall s. Char -> Parser s ()
asciiChar Char
':'
      P () -> P ()
forall s a. Parser s a -> Parser s ()
skipMany P ()
forall s. Parser s ()
spaceOrTab
      BlockSpec -> Int -> ContainerData -> P ()
addContainer BlockSpec
footnoteSpec Int
ind (ContainerData -> P ()) -> ContainerData -> P ()
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ContainerData
FootnoteData Int
ind (ByteString -> ByteString
normalizeLabel ByteString
label)
  , blockContinue :: Container -> P Bool
blockContinue = \Container
container -> (do
      P () -> P ()
forall s a. Parser s a -> Parser s ()
skipMany P ()
forall s. Parser s ()
spaceOrTab
      Int
curind <- Parser PState Int
forall st. Parser st Int
sourceColumn
      let ind :: Int
ind = case Container -> ContainerData
containerData Container
container of
                  FootnoteData Int
i ByteString
_ -> Int
i
                  ContainerData
_ -> [Char] -> Int
forall a. HasCallStack => [Char] -> a
error [Char]
"Missing FootnoteData"
      Bool -> P ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
curind Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
ind) P () -> P () -> P ()
forall a. Parser PState a -> Parser PState a -> Parser PState a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P ()
forall s. Parser s ()
followedByBlankLine
      Bool -> P Bool
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True) P Bool -> P Bool -> P Bool
forall a. Parser PState a -> Parser PState a -> Parser PState a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> P Bool
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  , blockContainsBlock :: Maybe BlockType
blockContainsBlock = BlockType -> Maybe BlockType
forall a. a -> Maybe a
Just BlockType
Normal
  , blockContainsLines :: Bool
blockContainsLines = Bool
True
  , blockClose :: Container -> P Container
blockClose = \Container
container -> do
      let label :: ByteString
label = case Container -> ContainerData
containerData Container
container of
                     FootnoteData Int
_ ByteString
l -> ByteString
l
                     ContainerData
_ -> [Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error [Char]
"Missing FootnoteData"
      let bls :: Blocks
bls = Container -> Blocks
finalizeChildren Container
container
      (PState -> PState) -> P ()
forall s. (s -> s) -> Parser s ()
updateState ((PState -> PState) -> P ()) -> (PState -> PState) -> P ()
forall a b. (a -> b) -> a -> b
$ \PState
st -> PState
st{ psNoteMap = insertNote label bls (psNoteMap st) }
      Container -> P Container
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Container
container
  , blockFinalize :: Container -> Blocks
blockFinalize = Blocks -> Container -> Blocks
forall a b. a -> b -> a
const Blocks
forall a. Monoid a => a
mempty
  }


paraSpec :: BlockSpec
paraSpec :: BlockSpec
paraSpec =
  BlockSpec
  { blockName :: [Char]
blockName = [Char]
"Para"
  , blockType :: BlockType
blockType = BlockType
Normal
  , blockStart :: P ()
blockStart = do
      P () -> P ()
forall s a. Parser s a -> Parser s ()
fails P ()
forall s. Parser s ()
followedByBlankLine
      Int
ind <- Parser PState Int
forall st. Parser st Int
sourceColumn
      BlockSpec -> Int -> ContainerData -> P ()
addContainer BlockSpec
paraSpec Int
ind ContainerData
NoData
  , blockContinue :: Container -> P Bool
blockContinue = \Container
_ -> do
      P () -> P ()
forall s a. Parser s a -> Parser s ()
skipMany P ()
forall s. Parser s ()
spaceOrTab
      (Bool
False Bool -> P () -> P Bool
forall a b. a -> Parser PState b -> Parser PState a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ P () -> P ()
forall s a. Parser s a -> Parser s a
lookahead (P ()
forall s. Parser s ()
endline P () -> P () -> P ()
forall a. Parser PState a -> Parser PState a -> Parser PState a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P ()
forall s. Parser s ()
eof)) P Bool -> P Bool -> P Bool
forall a. Parser PState a -> Parser PState a -> Parser PState a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> P Bool
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  , blockContainsBlock :: Maybe BlockType
blockContainsBlock = Maybe BlockType
forall a. Maybe a
Nothing
  , blockContainsLines :: Bool
blockContainsLines = Bool
True
  , blockClose :: Container -> P Container
blockClose = \Container
container -> do
      Inlines
ils <- Container -> P Inlines
parseTextLines Container
container
      Container -> P Container
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Container -> P Container) -> Container -> P Container
forall a b. (a -> b) -> a -> b
$ Container
container{ containerInlines = ils }
  , blockFinalize :: Container -> Blocks
blockFinalize = \Container
container ->
      Container -> Blocks -> Blocks
addSourcePos Container
container (Blocks -> Blocks) -> (Inlines -> Blocks) -> Inlines -> Blocks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inlines -> Blocks
para (Inlines -> Blocks) -> Inlines -> Blocks
forall a b. (a -> b) -> a -> b
$ Container -> Inlines
containerInlines Container
container
  }

parseTextLines :: Container -> P Inlines
parseTextLines :: Container -> P Inlines
parseTextLines Container
cont = do
  ParseOptions
opts <- PState -> ParseOptions
psParseOptions (PState -> ParseOptions)
-> Parser PState PState -> Parser PState ParseOptions
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser PState PState
forall s. Parser s s
getState
  ([Char] -> P Inlines)
-> (Inlines -> P Inlines) -> Either [Char] Inlines -> P Inlines
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> P Inlines
forall a. HasCallStack => [Char] -> a
error Inlines -> P Inlines
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [Char] Inlines -> P Inlines)
-> (Seq Chunk -> Either [Char] Inlines) -> Seq Chunk -> P Inlines
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseOptions -> Seq Chunk -> Either [Char] Inlines
parseInlines ParseOptions
opts (Seq Chunk -> P Inlines) -> Seq Chunk -> P Inlines
forall a b. (a -> b) -> a -> b
$ Container -> Seq Chunk
containerText Container
cont

emptyContainer :: Container
emptyContainer :: Container
emptyContainer =
  Container { containerSpec :: BlockSpec
containerSpec = BlockSpec
docSpec
            , containerChildren :: Seq Container
containerChildren = Seq Container
forall a. Monoid a => a
mempty
            , containerText :: Seq Chunk
containerText = Seq Chunk
forall a. Monoid a => a
mempty
            , containerInlines :: Inlines
containerInlines = Inlines
forall a. Monoid a => a
mempty
            , containerStartLine :: Int
containerStartLine = Int
1
            , containerStartColumn :: Int
containerStartColumn = Int
0
            , containerEndLine :: Int
containerEndLine = Int
1
            , containerEndColumn :: Int
containerEndColumn = Int
0
            , containerData :: ContainerData
containerData = ContainerData
NoData
            , containerAttr :: Attr
containerAttr = Attr
forall a. Monoid a => a
mempty
            , containerSourcePos :: Bool
containerSourcePos = Bool
False
            }

data Container =
  Container
  { Container -> BlockSpec
containerSpec      :: BlockSpec
  , Container -> Seq Container
containerChildren  :: Seq Container
  , Container -> Seq Chunk
containerText :: Seq Chunk
  , Container -> Inlines
containerInlines :: Inlines
  , Container -> Int
containerStartLine :: Int
  , Container -> Int
containerStartColumn :: Int
  , Container -> Int
containerEndLine :: Int
  , Container -> Int
containerEndColumn :: Int
  , Container -> ContainerData
containerData :: ContainerData
  , Container -> Attr
containerAttr :: Attr
  , Container -> Bool
containerSourcePos :: Bool
  }

data ContainerData =
    NoData
  | ListItemData Int [ListType] Bool
  | SectionData Int (Maybe ByteString)
  | HeadingData Int Inlines
  | CodeBlockData ByteString ByteString Int
  | DivData ByteString ByteString
  | FootnoteData Int ByteString
  | TableData [[Cell]]
  | CaptionData Int
  | AttributeData Int
  | ReferenceData ByteString
  deriving (Int -> ContainerData -> ShowS
[ContainerData] -> ShowS
ContainerData -> [Char]
(Int -> ContainerData -> ShowS)
-> (ContainerData -> [Char])
-> ([ContainerData] -> ShowS)
-> Show ContainerData
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ContainerData -> ShowS
showsPrec :: Int -> ContainerData -> ShowS
$cshow :: ContainerData -> [Char]
show :: ContainerData -> [Char]
$cshowList :: [ContainerData] -> ShowS
showList :: [ContainerData] -> ShowS
Show, ContainerData -> ContainerData -> Bool
(ContainerData -> ContainerData -> Bool)
-> (ContainerData -> ContainerData -> Bool) -> Eq ContainerData
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ContainerData -> ContainerData -> Bool
== :: ContainerData -> ContainerData -> Bool
$c/= :: ContainerData -> ContainerData -> Bool
/= :: ContainerData -> ContainerData -> Bool
Eq, Eq ContainerData
Eq ContainerData =>
(ContainerData -> ContainerData -> Ordering)
-> (ContainerData -> ContainerData -> Bool)
-> (ContainerData -> ContainerData -> Bool)
-> (ContainerData -> ContainerData -> Bool)
-> (ContainerData -> ContainerData -> Bool)
-> (ContainerData -> ContainerData -> ContainerData)
-> (ContainerData -> ContainerData -> ContainerData)
-> Ord ContainerData
ContainerData -> ContainerData -> Bool
ContainerData -> ContainerData -> Ordering
ContainerData -> ContainerData -> ContainerData
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ContainerData -> ContainerData -> Ordering
compare :: ContainerData -> ContainerData -> Ordering
$c< :: ContainerData -> ContainerData -> Bool
< :: ContainerData -> ContainerData -> Bool
$c<= :: ContainerData -> ContainerData -> Bool
<= :: ContainerData -> ContainerData -> Bool
$c> :: ContainerData -> ContainerData -> Bool
> :: ContainerData -> ContainerData -> Bool
$c>= :: ContainerData -> ContainerData -> Bool
>= :: ContainerData -> ContainerData -> Bool
$cmax :: ContainerData -> ContainerData -> ContainerData
max :: ContainerData -> ContainerData -> ContainerData
$cmin :: ContainerData -> ContainerData -> ContainerData
min :: ContainerData -> ContainerData -> ContainerData
Ord, Typeable)

data ListType =
    Bullet Char
  | Ordered OrderedListAttributes
  | Definition
  | Task TaskStatus
  deriving (Int -> ListType -> ShowS
[ListType] -> ShowS
ListType -> [Char]
(Int -> ListType -> ShowS)
-> (ListType -> [Char]) -> ([ListType] -> ShowS) -> Show ListType
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ListType -> ShowS
showsPrec :: Int -> ListType -> ShowS
$cshow :: ListType -> [Char]
show :: ListType -> [Char]
$cshowList :: [ListType] -> ShowS
showList :: [ListType] -> ShowS
Show, Eq ListType
Eq ListType =>
(ListType -> ListType -> Ordering)
-> (ListType -> ListType -> Bool)
-> (ListType -> ListType -> Bool)
-> (ListType -> ListType -> Bool)
-> (ListType -> ListType -> Bool)
-> (ListType -> ListType -> ListType)
-> (ListType -> ListType -> ListType)
-> Ord ListType
ListType -> ListType -> Bool
ListType -> ListType -> Ordering
ListType -> ListType -> ListType
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ListType -> ListType -> Ordering
compare :: ListType -> ListType -> Ordering
$c< :: ListType -> ListType -> Bool
< :: ListType -> ListType -> Bool
$c<= :: ListType -> ListType -> Bool
<= :: ListType -> ListType -> Bool
$c> :: ListType -> ListType -> Bool
> :: ListType -> ListType -> Bool
$c>= :: ListType -> ListType -> Bool
>= :: ListType -> ListType -> Bool
$cmax :: ListType -> ListType -> ListType
max :: ListType -> ListType -> ListType
$cmin :: ListType -> ListType -> ListType
min :: ListType -> ListType -> ListType
Ord, ListType -> ListType -> Bool
(ListType -> ListType -> Bool)
-> (ListType -> ListType -> Bool) -> Eq ListType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ListType -> ListType -> Bool
== :: ListType -> ListType -> Bool
$c/= :: ListType -> ListType -> Bool
/= :: ListType -> ListType -> Bool
Eq)

data PState =
  PState
  { PState -> ParseOptions
psParseOptions :: ParseOptions
  , PState -> NonEmpty Container
psContainerStack :: NonEmpty Container
  , PState -> ReferenceMap
psReferenceMap :: ReferenceMap
  , PState -> ReferenceMap
psAutoReferenceMap :: ReferenceMap
  , PState -> NoteMap
psNoteMap :: NoteMap
  , PState -> Attr
psAttributes :: Attr
  , PState -> Maybe AttrParserState
psAttrParserState :: Maybe AttrParserState
  , PState -> Set ByteString
psIds :: Set ByteString
  , PState -> Set ByteString
psAutoIds :: Set ByteString
  , PState -> Int
psLastColumnPrevLine :: Int
  , PState -> Int
psLastLine :: Int
  }

type P = Parser PState

pDoc :: P Doc
pDoc :: Parser PState Doc
pDoc = do
  Blocks
bls <- P Blocks
pBlocks P Blocks -> P () -> P Blocks
forall a b. Parser PState a -> Parser PState b -> Parser PState a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* P ()
forall s. Parser s ()
eof
  PState
st <- Parser PState PState
forall s. Parser s s
getState
  Doc -> Parser PState Doc
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc -> Parser PState Doc) -> Doc -> Parser PState Doc
forall a b. (a -> b) -> a -> b
$ Doc{ docBlocks :: Blocks
docBlocks = Blocks
bls
            , docFootnotes :: NoteMap
docFootnotes = PState -> NoteMap
psNoteMap PState
st
            , docReferences :: ReferenceMap
docReferences = PState -> ReferenceMap
psReferenceMap PState
st
            , docAutoReferences :: ReferenceMap
docAutoReferences = PState -> ReferenceMap
psAutoReferenceMap PState
st
            , docAutoIdentifiers :: Set ByteString
docAutoIdentifiers = PState -> Set ByteString
psAutoIds PState
st }

pBlocks :: P Blocks
pBlocks :: P Blocks
pBlocks = P ()
processLines P () -> P Blocks -> P Blocks
forall a b. Parser PState a -> Parser PState b -> Parser PState b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> P Blocks
finalizeDocument

-- | Return value is True if all continuations match.
checkContinuations :: NonEmpty Container -> P Bool
checkContinuations :: NonEmpty Container -> P Bool
checkContinuations = [Container] -> P Bool
go ([Container] -> P Bool)
-> (NonEmpty Container -> [Container])
-> NonEmpty Container
-> P Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Container] -> [Container]
forall a. [a] -> [a]
reverse ([Container] -> [Container])
-> (NonEmpty Container -> [Container])
-> NonEmpty Container
-> [Container]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Container -> [Container]
forall a. NonEmpty a -> [a]
NonEmpty.toList
 where
   go :: [Container] -> P Bool
go [] = Bool -> P Bool
forall a. a -> Parser PState a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
   go (Container
c:[Container]
cs) = do Maybe Bool
continue <- (Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Bool -> Maybe Bool) -> P Bool -> Parser PState (Maybe Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockSpec -> Container -> P Bool
blockContinue (Container -> BlockSpec
containerSpec Container
c) Container
c)
                                  Parser PState (Maybe Bool)
-> Parser PState (Maybe Bool) -> Parser PState (Maybe Bool)
forall a. Parser PState a -> Parser PState a -> Parser PState a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Bool -> Parser PState (Maybe Bool)
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Bool
forall a. Maybe a
Nothing
                  Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Bool
continue Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False) (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$ do -- early exit
                     Int
curline <- Parser PState Int
forall st. Parser st Int
sourceLine
                     Int
curcol <- Parser PState Int
forall st. Parser st Int
sourceColumn
                     (PState -> PState) -> P ()
forall s. (s -> s) -> Parser s ()
updateState ((PState -> PState) -> P ()) -> (PState -> PState) -> P ()
forall a b. (a -> b) -> a -> b
$ \PState
st ->
                                     PState
st{ psLastLine = curline
                                       , psLastColumnPrevLine = curcol - 1 }
                  if Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False Maybe Bool
continue
                     then [Container] -> P Bool
go [Container]
cs
                     else Bool
False Bool -> P () -> P Bool
forall a b. a -> Parser PState b -> Parser PState a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ -- close len (c:cs) containers
                          Int -> P () -> P ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ ([Container] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Container
cContainer -> [Container] -> [Container]
forall a. a -> [a] -> [a]
:[Container]
cs)) P ()
closeCurrentContainer


{-# INLINE processLines #-}
processLines :: P ()
processLines :: P ()
processLines = do
  -- check continuations for open containers and close any that don't match
  NonEmpty Container
containers <- PState -> NonEmpty Container
psContainerStack (PState -> NonEmpty Container)
-> Parser PState PState -> Parser PState (NonEmpty Container)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser PState PState
forall s. Parser s s
getState
  Bool
allContainersMatch <- NonEmpty Container -> P Bool
checkContinuations NonEmpty Container
containers

  -- check for new container starts and open if needed
  Bool
newContainersAdded <- P Bool
tryContainerStarts

  P ()
forall s. Parser s ()
followedByBlankLine P () -> P () -> P ()
forall a. Parser PState a -> Parser PState a -> Parser PState a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> do
    -- determine if we have a lazy line
    let isLazy :: Bool
isLazy = Bool -> Bool
not (Bool
allContainersMatch Bool -> Bool -> Bool
|| Bool
newContainersAdded) Bool -> Bool -> Bool
&&
                 BlockSpec -> [Char]
blockName (Container -> BlockSpec
containerSpec (NonEmpty Container -> Container
forall a. NonEmpty a -> a
NonEmpty.head NonEmpty Container
containers)) [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"Para"

    Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isLazy (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$ -- restore original containers
       (PState -> PState) -> P ()
forall s. (s -> s) -> Parser s ()
updateState (\PState
st -> PState
st{ psContainerStack = containers })

    Container
tip <- P Container
getTip

    case BlockSpec -> Maybe BlockType
blockContainsBlock (Container -> BlockSpec
containerSpec Container
tip) of
      Just BlockType
bt | BlockType
bt BlockType -> BlockType -> Bool
forall a. Eq a => a -> a -> Bool
== BlockType
Normal Bool -> Bool -> Bool
|| BlockType
bt BlockType -> BlockType -> Bool
forall a. Eq a => a -> a -> Bool
== BlockType
ListItem -> do
        -- add a paragraph container
        P () -> P ()
forall s a. Parser s a -> Parser s ()
skipMany P ()
forall s. Parser s ()
spaceOrTab
        BlockSpec -> P ()
blockStart BlockSpec
paraSpec
      Maybe BlockType
_ -> () -> P ()
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  !Int
curline <- Parser PState Int
forall st. Parser st Int
sourceLine
  !Int
curcolumn <- Parser PState Int
forall st. Parser st Int
sourceColumn
  ByteString
restline <- P () -> Parser PState ByteString
forall s a. Parser s a -> Parser s ByteString
byteStringOf (P () -> Parser PState ByteString)
-> P () -> Parser PState ByteString
forall a b. (a -> b) -> a -> b
$ do
     P () -> P ()
forall s a. Parser s a -> Parser s ()
skipMany ((Char -> Bool) -> P ()
forall s. (Char -> Bool) -> Parser s ()
skipSatisfyByte (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r'))
     !Int
lastcolumn <- Parser PState Int
forall st. Parser st Int
sourceColumn
     P () -> P ()
forall s a. Parser s a -> Parser s ()
optional_ P ()
forall s. Parser s ()
endline
     (PState -> PState) -> P ()
forall s. (s -> s) -> Parser s ()
updateState ((PState -> PState) -> P ()) -> (PState -> PState) -> P ()
forall a b. (a -> b) -> a -> b
$ \PState
st -> PState
st{ psLastColumnPrevLine = lastcolumn - 1
                            , psLastLine = curline }

  -- if current container is a line container, add remainder of line
  (NonEmpty Container -> NonEmpty Container) -> P ()
modifyContainers ((NonEmpty Container -> NonEmpty Container) -> P ())
-> (NonEmpty Container -> NonEmpty Container) -> P ()
forall a b. (a -> b) -> a -> b
$
    \(Container
c :| [Container]
rest) ->
       if BlockSpec -> Bool
blockContainsLines (Container -> BlockSpec
containerSpec Container
c)
          then Container
c{ containerText = containerText c Seq.|>
                    Chunk{ chunkLine = curline
                         , chunkColumn = curcolumn
                         , chunkBytes = restline } } Container -> [Container] -> NonEmpty Container
forall a. a -> [a] -> NonEmpty a
:| [Container]
rest
          else Container
c Container -> [Container] -> NonEmpty Container
forall a. a -> [a] -> NonEmpty a
:| [Container]
rest

  P ()
forall s. Parser s ()
eof P () -> P () -> P ()
forall a. Parser PState a -> Parser PState a -> Parser PState a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P ()
processLines

-- True if new container was started
tryContainerStarts :: P Bool
tryContainerStarts :: P Bool
tryContainerStarts = do
  (Container
c :| [Container]
_) <- PState -> NonEmpty Container
psContainerStack (PState -> NonEmpty Container)
-> Parser PState PState -> Parser PState (NonEmpty Container)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser PState PState
forall s. Parser s s
getState
  case BlockSpec -> Maybe BlockType
blockContainsBlock (Container -> BlockSpec
containerSpec Container
c) of
    Just BlockType
bt -> (do
      Char
nextc <- Parser PState Char -> Parser PState Char
forall s a. Parser s a -> Parser s a
lookahead ((Char -> Bool) -> Parser PState Char
forall s. (Char -> Bool) -> Parser s Char
satisfyByte Char -> Bool
isAscii)
      Char
next <- if Char
nextc Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
nextc Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\t'
                 then P () -> P ()
forall s a. Parser s a -> Parser s ()
skipMany P ()
forall s. Parser s ()
spaceOrTab P () -> Parser PState Char -> Parser PState Char
forall a b. Parser PState a -> Parser PState b -> Parser PState b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser PState Char -> Parser PState Char
forall s a. Parser s a -> Parser s a
lookahead ((Char -> Bool) -> Parser PState Char
forall s. (Char -> Bool) -> Parser s Char
satisfyByte Char -> Bool
isAscii)
                 else Char -> Parser PState Char
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
nextc
      case Char
next of
        Char
'>' -> BlockSpec -> P ()
blockStart BlockSpec
blockQuoteSpec
        Char
'#' -> BlockSpec -> P ()
blockStart BlockSpec
headingSpec
        Char
':' -> BlockSpec -> P ()
blockStart BlockSpec
divSpec P () -> P () -> P ()
forall a. Parser PState a -> Parser PState a -> Parser PState a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> BlockSpec -> P ()
blockStart BlockSpec
listItemSpec
        Char
'*' -> BlockSpec -> P ()
blockStart BlockSpec
thematicBreakSpec P () -> P () -> P ()
forall a. Parser PState a -> Parser PState a -> Parser PState a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> BlockSpec -> P ()
blockStart BlockSpec
listItemSpec
        Char
'-' -> BlockSpec -> P ()
blockStart BlockSpec
thematicBreakSpec P () -> P () -> P ()
forall a. Parser PState a -> Parser PState a -> Parser PState a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> BlockSpec -> P ()
blockStart BlockSpec
listItemSpec
        Char
'`' -> BlockSpec -> P ()
blockStart BlockSpec
codeBlockSpec
        Char
'{' -> BlockSpec -> P ()
blockStart BlockSpec
attrSpec
        Char
'[' -> BlockSpec -> P ()
blockStart BlockSpec
referenceDefinitionSpec P () -> P () -> P ()
forall a. Parser PState a -> Parser PState a -> Parser PState a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> BlockSpec -> P ()
blockStart BlockSpec
footnoteSpec
        Char
'|' | BlockType
bt BlockType -> BlockType -> Bool
forall a. Eq a => a -> a -> Bool
/= BlockType
CaptionBlock -> BlockSpec -> P ()
blockStart BlockSpec
tableSpec
        Char
'^' | BlockType
bt BlockType -> BlockType -> Bool
forall a. Eq a => a -> a -> Bool
== BlockType
CaptionBlock -> BlockSpec -> P ()
blockStart BlockSpec
captionSpec
        Char
_ -> BlockSpec -> P ()
blockStart BlockSpec
listItemSpec
      Bool
True Bool -> P Bool -> P Bool
forall a b. a -> Parser PState b -> Parser PState a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ P Bool
tryContainerStarts) P Bool -> P Bool -> P Bool
forall a. Parser PState a -> Parser PState a -> Parser PState a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> P Bool
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Maybe BlockType
_ -> Bool -> P Bool
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

-- | Close and finalize containers, returning Blocks.
finalizeDocument :: P Blocks
finalizeDocument :: P Blocks
finalizeDocument = do
  NonEmpty Container
cs <- PState -> NonEmpty Container
psContainerStack (PState -> NonEmpty Container)
-> Parser PState PState -> Parser PState (NonEmpty Container)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser PState PState
forall s. Parser s s
getState
  case NonEmpty Container
cs of
    Container
_ :| [] -> P ()
closeCurrentContainer P () -> P Blocks -> P Blocks
forall a b. Parser PState a -> Parser PState b -> Parser PState b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Container -> Blocks
finalize (Container -> Blocks) -> P Container -> P Blocks
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Container
getTip
    NonEmpty Container
_ -> P ()
closeCurrentContainer P () -> P Blocks -> P Blocks
forall a b. Parser PState a -> Parser PState b -> Parser PState b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> P Blocks
finalizeDocument

{-# INLINE closeCurrentContainer #-}
-- | Close container and add to parent container.
closeCurrentContainer :: P ()
closeCurrentContainer :: P ()
closeCurrentContainer = do
  NonEmpty Container
cs <- PState -> NonEmpty Container
psContainerStack (PState -> NonEmpty Container)
-> Parser PState PState -> Parser PState (NonEmpty Container)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser PState PState
forall s. Parser s s
getState
  NonEmpty Container
cs' <- case NonEmpty Container
cs of
           Container
_ :| [] -> NonEmpty Container -> Parser PState (NonEmpty Container)
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NonEmpty Container
cs
           Container
c :| [Container]
rest -> do
             case Container -> Attr
containerAttr Container
c of
               Attr [(ByteString, ByteString)]
as | Just ByteString
ident <- ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"id" [(ByteString, ByteString)]
as
                 -> (PState -> PState) -> P ()
forall s. (s -> s) -> Parser s ()
updateState ((PState -> PState) -> P ()) -> (PState -> PState) -> P ()
forall a b. (a -> b) -> a -> b
$ \PState
st -> PState
st{ psIds = Set.insert ident (psIds st) }
               Attr
_ -> () -> P ()
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
             Container
c' <- BlockSpec -> Container -> P Container
blockClose (Container -> BlockSpec
containerSpec Container
c) Container
c
             NonEmpty Container -> Parser PState (NonEmpty Container)
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Container
c'Container -> [Container] -> NonEmpty Container
forall a. a -> [a] -> NonEmpty a
:|[Container]
rest)
  case NonEmpty Container
cs' of
    Container
c :| (Container
d:[Container]
rest) -> (PState -> PState) -> P ()
forall s. (s -> s) -> Parser s ()
updateState ((PState -> PState) -> P ()) -> (PState -> PState) -> P ()
forall a b. (a -> b) -> a -> b
$
        \PState
st -> PState
st{ psContainerStack =
                   d{ containerChildren = containerChildren d Seq.|>
                        c{ containerEndLine = psLastLine st
                         , containerEndColumn = psLastColumnPrevLine st } }
                   :| rest }
    Container
c :| [] -> (PState -> PState) -> P ()
forall s. (s -> s) -> Parser s ()
updateState ((PState -> PState) -> P ()) -> (PState -> PState) -> P ()
forall a b. (a -> b) -> a -> b
$
        \PState
st -> PState
st{ psContainerStack =
                     c{ containerEndLine = psLastLine st
                      , containerEndColumn = psLastColumnPrevLine st } :| [] }

{-# INLINE modifyContainers #-}
modifyContainers :: (NonEmpty Container -> NonEmpty Container) -> P ()
modifyContainers :: (NonEmpty Container -> NonEmpty Container) -> P ()
modifyContainers NonEmpty Container -> NonEmpty Container
f =
  (PState -> PState) -> P ()
forall s. (s -> s) -> Parser s ()
updateState ((PState -> PState) -> P ()) -> (PState -> PState) -> P ()
forall a b. (a -> b) -> a -> b
$ \PState
st -> PState
st{ psContainerStack = f (psContainerStack st) }

{-# INLINE addContainer #-}
addContainer :: BlockSpec -> Int -> ContainerData -> P ()
addContainer :: BlockSpec -> Int -> ContainerData -> P ()
addContainer BlockSpec
bspec Int
curcol ContainerData
bdata = do
  Int
curline <- Parser PState Int
forall st. Parser st Int
sourceLine
  Attr
attr <- PState -> Attr
psAttributes (PState -> Attr) -> Parser PState PState -> Parser PState Attr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser PState PState
forall s. Parser s s
getState
  ParseOptions
opts <- PState -> ParseOptions
psParseOptions (PState -> ParseOptions)
-> Parser PState PState -> Parser PState ParseOptions
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser PState PState
forall s. Parser s s
getState
  let newcontainer :: Container
newcontainer = Container
emptyContainer { containerSpec = bspec
                                    , containerStartLine = curline
                                    , containerStartColumn = curcol
                                    , containerEndLine = curline
                                    , containerEndColumn = curcol
                                    , containerData = bdata
                                    , containerAttr = attr
                                    , containerSourcePos = sourcePositions opts /= NoSourcePos }
  Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (BlockSpec -> [Char]
blockName BlockSpec
bspec [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"Attributes") (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$
    (PState -> PState) -> P ()
forall s. (s -> s) -> Parser s ()
updateState ((PState -> PState) -> P ()) -> (PState -> PState) -> P ()
forall a b. (a -> b) -> a -> b
$ \PState
st -> PState
st{ psAttributes = mempty }
  BlockSpec -> P ()
closeInappropriateContainers BlockSpec
bspec
  (NonEmpty Container -> NonEmpty Container) -> P ()
modifyContainers (Container
newcontainer Container -> NonEmpty Container -> NonEmpty Container
forall a. a -> NonEmpty a -> NonEmpty a
NonEmpty.<|)

closeInappropriateContainers :: BlockSpec -> P ()
closeInappropriateContainers :: BlockSpec -> P ()
closeInappropriateContainers BlockSpec
spec = do
  -- close containers until we get one that can accept this type of container
  NonEmpty Container
cs <- PState -> NonEmpty Container
psContainerStack (PState -> NonEmpty Container)
-> Parser PState PState -> Parser PState (NonEmpty Container)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser PState PState
forall s. Parser s s
getState
  case NonEmpty Container
cs of
    Container
c :| [Container]
_
      | BlockSpec -> Maybe BlockType
blockContainsBlock (Container -> BlockSpec
containerSpec Container
c) Maybe BlockType -> Maybe BlockType -> Bool
forall a. Eq a => a -> a -> Bool
== BlockType -> Maybe BlockType
forall a. a -> Maybe a
Just (BlockSpec -> BlockType
blockType BlockSpec
spec) ->
              () -> P ()
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
otherwise -> P ()
closeCurrentContainer P () -> P () -> P ()
forall a b. Parser PState a -> Parser PState b -> Parser PState b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> BlockSpec -> P ()
closeInappropriateContainers BlockSpec
spec


finalize :: Container -> Blocks
finalize :: Container -> Blocks
finalize Container
cont =
  Attr -> Node Block -> Node Block
forall a. Attr -> Node a -> Node a
addAttr (Container -> Attr
containerAttr Container
cont)
    (Node Block -> Node Block) -> Blocks -> Blocks
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockSpec -> Container -> Blocks
blockFinalize (Container -> BlockSpec
containerSpec Container
cont) Container
cont

addSourcePos :: Container -> Blocks -> Blocks
addSourcePos :: Container -> Blocks -> Blocks
addSourcePos Container
cont =
   if Container -> Bool
containerSourcePos Container
cont
      then (Node Block -> Node Block) -> Blocks -> Blocks
forall a b. (a -> b) -> Many a -> Many b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
           (Pos -> Node Block -> Node Block
forall a. Pos -> Node a -> Node a
addPos (Int -> Int -> Int -> Int -> Pos
Pos (Container -> Int
containerStartLine Container
cont) (Container -> Int
containerStartColumn Container
cont)
                         (Container -> Int
containerEndLine Container
cont) (Container -> Int
containerEndColumn Container
cont)))
      else Blocks -> Blocks
forall a. a -> a
id

finalizeChildren :: Container -> Blocks
finalizeChildren :: Container -> Blocks
finalizeChildren = (Container -> Blocks) -> Seq Container -> Blocks
forall m a. Monoid m => (a -> m) -> Seq a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Container -> Blocks
finalize (Seq Container -> Blocks)
-> (Container -> Seq Container) -> Container -> Blocks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Container -> Seq Container
containerChildren

-- Gobble as much space as possible up to indent.
gobbleSpaceToIndent :: Int -> P ()
gobbleSpaceToIndent :: Int -> P ()
gobbleSpaceToIndent Int
indent = do
  Int
curindent <- Parser PState Int
forall st. Parser st Int
sourceColumn
  Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
curindent Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
indent) (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$
     P () -> P ()
forall s a. Parser s a -> Parser s ()
optional_ (P ()
forall s. Parser s ()
spaceOrTab P () -> P () -> P ()
forall a b. Parser PState a -> Parser PState b -> Parser PState b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> P ()
gobbleSpaceToIndent Int
indent)

{-# INLINE getTip #-}
-- Get tip of container stack.
getTip :: P Container
getTip :: P Container
getTip = NonEmpty Container -> Container
forall a. NonEmpty a -> a
NonEmpty.head (NonEmpty Container -> Container)
-> (PState -> NonEmpty Container) -> PState -> Container
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PState -> NonEmpty Container
psContainerStack (PState -> Container) -> Parser PState PState -> P Container
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser PState PState
forall s. Parser s s
getState

closeContainingSections :: Int -> P ()
closeContainingSections :: Int -> P ()
closeContainingSections Int
lev = do
  Container
tip <- P Container
getTip
  case Container -> ContainerData
containerData Container
tip of
    SectionData Int
lev' Maybe ByteString
_ | Int
lev' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
lev ->
      P ()
closeCurrentContainer P () -> P () -> P ()
forall a b. Parser PState a -> Parser PState b -> Parser PState b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
      Int -> P ()
closeContainingSections Int
lev
    ContainerData
_ -> () -> P ()
forall a. a -> Parser PState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- TODO avoid detour through String
toIdentifier :: ByteString -> ByteString
toIdentifier :: ByteString -> ByteString
toIdentifier ByteString
bs =
  if [[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
parts
     then ByteString
"sec"
     else [Char] -> ByteString
strToUtf8 ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"-" [[Char]]
parts
 where
   isSym :: Char -> Bool
isSym = (Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char]
"][~!@#$%^&*(){}`,.<>\\|=+/" :: [Char]))
   parts :: [[Char]]
parts = [Char] -> [[Char]]
words ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> if Char -> Bool
isSym Char
c then Char
' ' else Char
c) ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
utf8ToStr ByteString
bs