{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}

module AsciiDoc.Parse
  ( parseDocument
  ) where

import Prelude hiding (takeWhile)
import Text.HTML.TagSoup.Entity (lookupNamedEntity)
import Data.Maybe (isNothing, listToMaybe, fromMaybe, catMaybes)
import Data.Bifunctor (first)
import Data.Either (lefts, rights)
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Data.Text.Read as TR
import Data.Text (Text)
import Data.List (foldl', intersperse, isPrefixOf)
import qualified Data.Attoparsec.Text as A
import System.FilePath
import Control.Applicative
import Control.Monad
import Control.Monad.State
import Control.Monad.Reader
import Data.Char (isAlphaNum, isAscii, isSpace, isLetter, isPunctuation, chr, isDigit,
                  isUpper, isLower, ord)
import AsciiDoc.AST
import AsciiDoc.Generic
-- import Debug.Trace

-- | Parse an AsciiDoc document into an AST.
parseDocument :: Monad m
              => (FilePath -> m Text)
                  -- ^ Get contents of an included file
              -> (FilePath -> Int -> String -> m Document)
                  -- ^ Raise an error given source pos and message
              -> FilePath
                  -- ^ Path of file containing the text
              -> Text -- ^ Text to convert
              -> m Document
parseDocument :: forall (m :: * -> *).
Monad m =>
(FilePath -> m Text)
-> (FilePath -> Int -> FilePath -> m Document)
-> FilePath
-> Text
-> m Document
parseDocument FilePath -> m Text
getFileContents FilePath -> Int -> FilePath -> m Document
raiseError FilePath
path Text
t =
   Either ParseError Document -> m Document
handleResult (P Document -> FilePath -> Text -> Either ParseError Document
forall a. P a -> FilePath -> Text -> Either ParseError a
parse P Document
pDocument FilePath
path Text
t) m Document -> (Document -> m Document) -> m Document
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Document -> m Document
handleIncludes
     m Document -> (Document -> m Document) -> m Document
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Document -> m Document
forall {m :: * -> *}. Monad m => Document -> m Document
resolveAttributeReferences (Document -> m Document)
-> (Document -> Document) -> Document -> m Document
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Document -> Document
addIdentifiers
     m Document -> (Document -> m Document) -> m Document
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Document -> m Document
forall {a} {m :: * -> *}.
(HasInlines a, Monad m, HasBlocks a) =>
a -> m a
resolveCrossReferences
 where
  handleResult :: Either ParseError Document -> m Document
handleResult (Left ParseError
err) =
    FilePath -> Int -> FilePath -> m Document
raiseError FilePath
path (ParseError -> Int
errorPosition ParseError
err) (ParseError -> FilePath
errorMessage ParseError
err)
  handleResult (Right Document
r) = Document -> m Document
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Document
r

  toAnchorMap :: a -> Map Text [Inline]
toAnchorMap a
d =
    (Block -> Map Text [Inline]) -> a -> Map Text [Inline]
forall m. Monoid m => (Block -> m) -> a -> m
forall a m. (HasBlocks a, Monoid m) => (Block -> m) -> a -> m
foldBlocks Block -> Map Text [Inline]
blockAnchor a
d Map Text [Inline] -> Map Text [Inline] -> Map Text [Inline]
forall a. Semigroup a => a -> a -> a
<> (Inline -> Map Text [Inline]) -> a -> Map Text [Inline]
forall m. Monoid m => (Inline -> m) -> a -> m
forall a m. (HasInlines a, Monoid m) => (Inline -> m) -> a -> m
foldInlines Inline -> Map Text [Inline]
inlineAnchor a
d

  blockAnchor :: Block -> Map Text [Inline]
blockAnchor (Block (Attr [Text]
_ Map Text Text
kvs) Maybe BlockTitle
_ (Section Level
_ [Inline]
ils [Block]
_))
    | Just Text
ident <- Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
"id" Map Text Text
kvs = Text -> [Inline] -> Map Text [Inline]
forall k a. k -> a -> Map k a
M.singleton Text
ident [Inline]
ils
  blockAnchor Block
_ = Map Text [Inline]
forall a. Monoid a => a
mempty

  inlineAnchor :: Inline -> Map Text [Inline]
inlineAnchor (Inline Attr
_ (InlineAnchor Text
ident [Inline]
ils)) = Text -> [Inline] -> Map Text [Inline]
forall k a. k -> a -> Map k a
M.singleton Text
ident [Inline]
ils
  inlineAnchor (Inline Attr
_ (BibliographyAnchor Text
ident [Inline]
ils)) = Text -> [Inline] -> Map Text [Inline]
forall k a. k -> a -> Map k a
M.singleton Text
ident [Inline]
ils
  inlineAnchor Inline
_ = Map Text [Inline]
forall a. Monoid a => a
mempty

  resolveCrossReferences :: a -> m a
resolveCrossReferences a
d = (Inline -> m Inline) -> a -> m a
forall a (m :: * -> *).
(HasInlines a, Monad m) =>
(Inline -> m Inline) -> a -> m a
forall (m :: * -> *). Monad m => (Inline -> m Inline) -> a -> m a
mapInlines (Map Text [Inline] -> Inline -> m Inline
forall {f :: * -> *}.
Applicative f =>
Map Text [Inline] -> Inline -> f Inline
resolveCrossReference (a -> Map Text [Inline]
forall {a}. (HasBlocks a, HasInlines a) => a -> Map Text [Inline]
toAnchorMap a
d)) a
d
  resolveCrossReference :: Map Text [Inline] -> Inline -> f Inline
resolveCrossReference Map Text [Inline]
anchorMap
   x :: Inline
x@(Inline Attr
attr (CrossReference Text
ident Maybe [Inline]
Nothing)) =
    let ident' :: Text
ident' = (Char -> Bool) -> Text -> Text
T.takeWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'#') Text
ident -- strip off file part
    in case Text -> Map Text [Inline] -> Maybe [Inline]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
ident' Map Text [Inline]
anchorMap of
        Just [Inline]
ils -> Inline -> f Inline
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Inline -> f Inline) -> Inline -> f Inline
forall a b. (a -> b) -> a -> b
$ Attr -> InlineType -> Inline
Inline Attr
attr (Text -> Maybe [Inline] -> InlineType
CrossReference Text
ident' ([Inline] -> Maybe [Inline]
forall a. a -> Maybe a
Just [Inline]
ils))
        Maybe [Inline]
_ -> Inline -> f Inline
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Inline
x
  resolveCrossReference Map Text [Inline]
_ Inline
x = Inline -> f Inline
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Inline
x

  resolveAttributeReferences :: Document -> m Document
resolveAttributeReferences Document
doc =
    (Inline -> m Inline) -> Document -> m Document
forall a (m :: * -> *).
(HasInlines a, Monad m) =>
(Inline -> m Inline) -> a -> m a
forall (m :: * -> *).
Monad m =>
(Inline -> m Inline) -> Document -> m Document
mapInlines (Map Text Text -> Inline -> m Inline
forall {m :: * -> *}.
Monad m =>
Map Text Text -> Inline -> m Inline
goAttref (Meta -> Map Text Text
docAttributes (Document -> Meta
docMeta Document
doc))) Document
doc

  goAttref :: Map Text Text -> Inline -> m Inline
goAttref Map Text Text
atts il :: Inline
il@(Inline Attr
attr (AttributeReference (AttributeName Text
at))) =
     case Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
at Map Text Text
atts of
       Maybe Text
Nothing -> Inline -> m Inline
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Inline
il
       Just Text
x -> Inline -> m Inline
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Inline -> m Inline) -> Inline -> m Inline
forall a b. (a -> b) -> a -> b
$ Attr -> InlineType -> Inline
Inline Attr
attr (Text -> InlineType
Str Text
x)
  goAttref Map Text Text
_ Inline
il = Inline -> m Inline
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Inline
il

  handleIncludes :: Document -> m Document
handleIncludes = (Block -> m Block) -> Document -> m Document
forall a (m :: * -> *).
(HasBlocks a, Monad m) =>
(Block -> m Block) -> a -> m a
forall (m :: * -> *).
Monad m =>
(Block -> m Block) -> Document -> m Document
mapBlocks Block -> m Block
handleIncludeBlock

  handleIncludeBlock :: Block -> m Block
handleIncludeBlock (Block Attr
attr Maybe BlockTitle
mbtitle (Include FilePath
fp Maybe [Block]
Nothing)) =
    (do contents <- FilePath -> m Text
getFileContents FilePath
fp
        Block attr mbtitle . Include fp . Just . docBlocks <$>
          handleResult (parse pDocument fp contents))
      m Block -> (Block -> m Block) -> m Block
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Block -> m Block) -> Block -> m Block
forall a (m :: * -> *).
(HasBlocks a, Monad m) =>
(Block -> m Block) -> a -> m a
forall (m :: * -> *).
Monad m =>
(Block -> m Block) -> Block -> m Block
mapBlocks Block -> m Block
handleIncludeBlock
  handleIncludeBlock (Block Attr
attr Maybe BlockTitle
mbtitle
                         (IncludeListing Maybe Language
mblang FilePath
fp Maybe [SourceLine]
Nothing)) =
    (do contents <- FilePath -> m Text
getFileContents FilePath
fp
        pure $ Block attr mbtitle $ IncludeListing mblang fp
             $ Just (map (`SourceLine` []) (T.lines contents)))
      m Block -> (Block -> m Block) -> m Block
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Block -> m Block) -> Block -> m Block
forall a (m :: * -> *).
(HasBlocks a, Monad m) =>
(Block -> m Block) -> a -> m a
forall (m :: * -> *).
Monad m =>
(Block -> m Block) -> Block -> m Block
mapBlocks Block -> m Block
handleIncludeBlock
  handleIncludeBlock Block
x = Block -> m Block
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Block
x

-- | Make a relative path relative to a parent's directory.
-- Leaves absolute paths alone.
resolvePath :: FilePath -> FilePath -> FilePath
resolvePath :: FilePath -> FilePath -> FilePath
resolvePath FilePath
parentPath FilePath
fp
  | FilePath -> Bool
isRelative FilePath
fp =
      FilePath -> FilePath
normalise (FilePath -> FilePath
takeDirectory FilePath
parentPath FilePath -> FilePath -> FilePath
</> FilePath
fp)
  | Bool
otherwise = FilePath
fp

--- Wrapped parser type:

newtype P a = P { forall a.
P a -> ReaderT ParserConfig (StateT ParserState (Parser Text)) a
unP :: ReaderT ParserConfig (StateT ParserState A.Parser) a }
  deriving ((forall a b. (a -> b) -> P a -> P b)
-> (forall a b. a -> P b -> P a) -> Functor P
forall a b. a -> P b -> P a
forall a b. (a -> b) -> P a -> P b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> P a -> P b
fmap :: forall a b. (a -> b) -> P a -> P b
$c<$ :: forall a b. a -> P b -> P a
<$ :: forall a b. a -> P b -> P a
Functor, Functor P
Functor P =>
(forall a. a -> P a)
-> (forall a b. P (a -> b) -> P a -> P b)
-> (forall a b c. (a -> b -> c) -> P a -> P b -> P c)
-> (forall a b. P a -> P b -> P b)
-> (forall a b. P a -> P b -> P a)
-> Applicative P
forall a. a -> P a
forall a b. P a -> P b -> P a
forall a b. P a -> P b -> P b
forall a b. P (a -> b) -> P a -> P b
forall a b c. (a -> b -> c) -> P a -> P b -> P c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> P a
pure :: forall a. a -> P a
$c<*> :: forall a b. P (a -> b) -> P a -> P b
<*> :: forall a b. P (a -> b) -> P a -> P b
$cliftA2 :: forall a b c. (a -> b -> c) -> P a -> P b -> P c
liftA2 :: forall a b c. (a -> b -> c) -> P a -> P b -> P c
$c*> :: forall a b. P a -> P b -> P b
*> :: forall a b. P a -> P b -> P b
$c<* :: forall a b. P a -> P b -> P a
<* :: forall a b. P a -> P b -> P a
Applicative, Applicative P
Applicative P =>
(forall a. P a)
-> (forall a. P a -> P a -> P a)
-> (forall a. P a -> P [a])
-> (forall a. P a -> P [a])
-> Alternative P
forall a. P a
forall a. P a -> P [a]
forall a. P a -> P a -> P a
forall (f :: * -> *).
Applicative f =>
(forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
$cempty :: forall a. P a
empty :: forall a. P a
$c<|> :: forall a. P a -> P a -> P a
<|> :: forall a. P a -> P a -> P a
$csome :: forall a. P a -> P [a]
some :: forall a. P a -> P [a]
$cmany :: forall a. P a -> P [a]
many :: forall a. P a -> P [a]
Alternative, Applicative P
Applicative P =>
(forall a b. P a -> (a -> P b) -> P b)
-> (forall a b. P a -> P b -> P b)
-> (forall a. a -> P a)
-> Monad P
forall a. a -> P a
forall a b. P a -> P b -> P b
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. P a -> (a -> P b) -> P b
>>= :: forall a b. P a -> (a -> P b) -> P b
$c>> :: forall a b. P a -> P b -> P b
>> :: forall a b. P a -> P b -> P b
$creturn :: forall a. a -> P a
return :: forall a. a -> P a
Monad, Monad P
Alternative P
(Alternative P, Monad P) =>
(forall a. P a) -> (forall a. P a -> P a -> P a) -> MonadPlus P
forall a. P a
forall a. P a -> P a -> P a
forall (m :: * -> *).
(Alternative m, Monad m) =>
(forall a. m a) -> (forall a. m a -> m a -> m a) -> MonadPlus m
$cmzero :: forall a. P a
mzero :: forall a. P a
$cmplus :: forall a. P a -> P a -> P a
mplus :: forall a. P a -> P a -> P a
MonadPlus,
            Monad P
Monad P => (forall a. FilePath -> P a) -> MonadFail P
forall a. FilePath -> P a
forall (m :: * -> *).
Monad m =>
(forall a. FilePath -> m a) -> MonadFail m
$cfail :: forall a. FilePath -> P a
fail :: forall a. FilePath -> P a
MonadFail, MonadReader ParserConfig, MonadState ParserState)

data ParserState = ParserState
                     { ParserState -> Map Text (CounterType, Int)
counterMap :: M.Map Text (CounterType, Int)
                     , ParserState -> Map Text Text
docAttrs :: M.Map Text Text
                     }
        deriving (Int -> ParserState -> FilePath -> FilePath
[ParserState] -> FilePath -> FilePath
ParserState -> FilePath
(Int -> ParserState -> FilePath -> FilePath)
-> (ParserState -> FilePath)
-> ([ParserState] -> FilePath -> FilePath)
-> Show ParserState
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> ParserState -> FilePath -> FilePath
showsPrec :: Int -> ParserState -> FilePath -> FilePath
$cshow :: ParserState -> FilePath
show :: ParserState -> FilePath
$cshowList :: [ParserState] -> FilePath -> FilePath
showList :: [ParserState] -> FilePath -> FilePath
Show)

defaultDocAttrs :: M.Map Text Text
defaultDocAttrs :: Map Text Text
defaultDocAttrs = Text -> Text -> Map Text Text -> Map Text Text
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
"sectids" Text
"" Map Text Text
forall a. Monoid a => a
mempty

data ParserConfig = ParserConfig
                    { ParserConfig -> FilePath
filePath :: FilePath
                    , ParserConfig -> [BlockContext]
blockContexts :: [BlockContext]
                    , ParserConfig -> Bool
hardBreaks :: Bool
                    } deriving (Int -> ParserConfig -> FilePath -> FilePath
[ParserConfig] -> FilePath -> FilePath
ParserConfig -> FilePath
(Int -> ParserConfig -> FilePath -> FilePath)
-> (ParserConfig -> FilePath)
-> ([ParserConfig] -> FilePath -> FilePath)
-> Show ParserConfig
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> ParserConfig -> FilePath -> FilePath
showsPrec :: Int -> ParserConfig -> FilePath -> FilePath
$cshow :: ParserConfig -> FilePath
show :: ParserConfig -> FilePath
$cshowList :: [ParserConfig] -> FilePath -> FilePath
showList :: [ParserConfig] -> FilePath -> FilePath
Show)

data ParseError = ParseError { ParseError -> Int
errorPosition :: Int
                             , ParseError -> FilePath
errorMessage :: String
                             } deriving (Int -> ParseError -> FilePath -> FilePath
[ParseError] -> FilePath -> FilePath
ParseError -> FilePath
(Int -> ParseError -> FilePath -> FilePath)
-> (ParseError -> FilePath)
-> ([ParseError] -> FilePath -> FilePath)
-> Show ParseError
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> ParseError -> FilePath -> FilePath
showsPrec :: Int -> ParseError -> FilePath -> FilePath
$cshow :: ParseError -> FilePath
show :: ParseError -> FilePath
$cshowList :: [ParseError] -> FilePath -> FilePath
showList :: [ParseError] -> FilePath -> FilePath
Show)

parse :: P a -> FilePath -> T.Text -> Either ParseError a
parse :: forall a. P a -> FilePath -> Text -> Either ParseError a
parse P a
p FilePath
fp = ParserConfig -> ParserState -> P a -> Text -> Either ParseError a
forall a.
ParserConfig -> ParserState -> P a -> Text -> Either ParseError a
parse' (ParserConfig{ filePath :: FilePath
filePath = FilePath
fp
                                 , blockContexts :: [BlockContext]
blockContexts = []
                                 , hardBreaks :: Bool
hardBreaks = Bool
False
                                 })
                    (ParserState { counterMap :: Map Text (CounterType, Int)
counterMap = Map Text (CounterType, Int)
forall a. Monoid a => a
mempty
                                 , docAttrs :: Map Text Text
docAttrs = Map Text Text
defaultDocAttrs
                                 })
                    P a
p

parse' :: ParserConfig -> ParserState
       -> P a -> T.Text -> Either ParseError a
parse' :: forall a.
ParserConfig -> ParserState -> P a -> Text -> Either ParseError a
parse' ParserConfig
cfg ParserState
st P a
p Text
t =
  IResult Text a -> Either ParseError a
forall {b}. IResult Text b -> Either ParseError b
go (IResult Text a -> Either ParseError a)
-> IResult Text a -> Either ParseError a
forall a b. (a -> b) -> a -> b
$ Parser a -> Text -> IResult Text a
forall a. Parser a -> Text -> Result a
A.parse (StateT ParserState (Parser Text) a -> ParserState -> Parser a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT ( ReaderT ParserConfig (StateT ParserState (Parser Text)) a
-> ParserConfig -> StateT ParserState (Parser Text) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (P a -> ReaderT ParserConfig (StateT ParserState (Parser Text)) a
forall a.
P a -> ReaderT ParserConfig (StateT ParserState (Parser Text)) a
unP P a
p) ParserConfig
cfg ) ParserState
st) Text
t
 where
  go :: IResult Text b -> Either ParseError b
go (A.Fail Text
i [FilePath]
_ FilePath
msg) = ParseError -> Either ParseError b
forall a b. a -> Either a b
Left (ParseError -> Either ParseError b)
-> ParseError -> Either ParseError b
forall a b. (a -> b) -> a -> b
$ Int -> FilePath -> ParseError
ParseError (Text -> Int
T.length Text
t Int -> Int -> Int
forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
i)
                             (FilePath -> ParseError) -> FilePath -> ParseError
forall a b. (a -> b) -> a -> b
$ if FilePath
"endOfInput" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
msg
                                  then FilePath
"Unexpected " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
forall a. Show a => a -> FilePath
show (Int -> Text -> Text
T.take Int
20 Text
i)
                                  else FilePath
msg
  go (A.Partial Text -> IResult Text b
continue) = IResult Text b -> Either ParseError b
go (Text -> IResult Text b
continue Text
"")
  go (A.Done Text
_i b
r) = b -> Either ParseError b
forall a b. b -> Either a b
Right b
r

localP :: (ParserConfig -> ParserConfig) -> P a -> P a
localP :: forall a. (ParserConfig -> ParserConfig) -> P a -> P a
localP ParserConfig -> ParserConfig
f (P ReaderT ParserConfig (StateT ParserState (Parser Text)) a
p) = ReaderT ParserConfig (StateT ParserState (Parser Text)) a -> P a
forall a.
ReaderT ParserConfig (StateT ParserState (Parser Text)) a -> P a
P ((ParserConfig -> ParserConfig)
-> ReaderT ParserConfig (StateT ParserState (Parser Text)) a
-> ReaderT ParserConfig (StateT ParserState (Parser Text)) a
forall a.
(ParserConfig -> ParserConfig)
-> ReaderT ParserConfig (StateT ParserState (Parser Text)) a
-> ReaderT ParserConfig (StateT ParserState (Parser Text)) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ParserConfig -> ParserConfig
f ReaderT ParserConfig (StateT ParserState (Parser Text)) a
p)

withBlockContext :: BlockContext -> P a -> P a
withBlockContext :: forall a. BlockContext -> P a -> P a
withBlockContext BlockContext
bc =
  (ParserConfig -> ParserConfig) -> P a -> P a
forall a. (ParserConfig -> ParserConfig) -> P a -> P a
localP (\ParserConfig
conf -> ParserConfig
conf{ blockContexts = bc : blockContexts conf })

withHardBreaks :: P a -> P a
withHardBreaks :: forall a. P a -> P a
withHardBreaks = (ParserConfig -> ParserConfig) -> P a -> P a
forall a. (ParserConfig -> ParserConfig) -> P a -> P a
localP (\ParserConfig
conf -> ParserConfig
conf{ hardBreaks = True })

liftP :: A.Parser a -> P a
liftP :: forall a. Parser a -> P a
liftP = ReaderT ParserConfig (StateT ParserState (Parser Text)) a -> P a
forall a.
ReaderT ParserConfig (StateT ParserState (Parser Text)) a -> P a
P (ReaderT ParserConfig (StateT ParserState (Parser Text)) a -> P a)
-> (Parser a
    -> ReaderT ParserConfig (StateT ParserState (Parser Text)) a)
-> Parser a
-> P a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT ParserState (Parser Text) a
-> ReaderT ParserConfig (StateT ParserState (Parser Text)) a
forall (m :: * -> *) a. Monad m => m a -> ReaderT ParserConfig m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT ParserState (Parser Text) a
 -> ReaderT ParserConfig (StateT ParserState (Parser Text)) a)
-> (Parser a -> StateT ParserState (Parser Text) a)
-> Parser a
-> ReaderT ParserConfig (StateT ParserState (Parser Text)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser a -> StateT ParserState (Parser Text) a
forall (m :: * -> *) a. Monad m => m a -> StateT ParserState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

vchar :: Char -> P ()
vchar :: Char -> P ()
vchar = Parser () -> P ()
forall a. Parser a -> P a
liftP (Parser () -> P ()) -> (Char -> Parser ()) -> Char -> P ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser Text Char -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text Char -> Parser ())
-> (Char -> Parser Text Char) -> Char -> Parser ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Parser Text Char
A.char

char :: Char -> P Char
char :: Char -> P Char
char = Parser Text Char -> P Char
forall a. Parser a -> P a
liftP (Parser Text Char -> P Char)
-> (Char -> Parser Text Char) -> Char -> P Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Parser Text Char
A.char

peekChar :: P (Maybe Char)
peekChar :: P (Maybe Char)
peekChar = Parser (Maybe Char) -> P (Maybe Char)
forall a. Parser a -> P a
liftP Parser (Maybe Char)
A.peekChar

peekChar' :: P Char
peekChar' :: P Char
peekChar' = Parser Text Char -> P Char
forall a. Parser a -> P a
liftP Parser Text Char
A.peekChar'

anyChar :: P Char
anyChar :: P Char
anyChar = Parser Text Char -> P Char
forall a. Parser a -> P a
liftP Parser Text Char
A.anyChar

satisfy :: (Char -> Bool) -> P Char
satisfy :: (Char -> Bool) -> P Char
satisfy = Parser Text Char -> P Char
forall a. Parser a -> P a
liftP (Parser Text Char -> P Char)
-> ((Char -> Bool) -> Parser Text Char) -> (Char -> Bool) -> P Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Parser Text Char
A.satisfy

space :: P Char
space :: P Char
space = Parser Text Char -> P Char
forall a. Parser a -> P a
liftP Parser Text Char
A.space

isEndOfLine :: Char -> Bool
isEndOfLine :: Char -> Bool
isEndOfLine = Char -> Bool
A.isEndOfLine

match :: P a -> P (T.Text, a)
match :: forall a. P a -> P (Text, a)
match P a
p = ReaderT ParserConfig (StateT ParserState (Parser Text)) (Text, a)
-> P (Text, a)
forall a.
ReaderT ParserConfig (StateT ParserState (Parser Text)) a -> P a
P (ReaderT ParserConfig (StateT ParserState (Parser Text)) (Text, a)
 -> P (Text, a))
-> ReaderT
     ParserConfig (StateT ParserState (Parser Text)) (Text, a)
-> P (Text, a)
forall a b. (a -> b) -> a -> b
$ do
  parseInfo <- ReaderT
  ParserConfig (StateT ParserState (Parser Text)) ParserConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
  parserState <- get
  lift . lift $ A.match (evalStateT (runReaderT (unP p) parseInfo) parserState)

string :: T.Text -> P T.Text
string :: Text -> P Text
string = Parser Text -> P Text
forall a. Parser a -> P a
liftP (Parser Text -> P Text) -> (Text -> Parser Text) -> Text -> P Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Parser Text
A.string

decimal :: Integral a => P a
decimal :: forall a. Integral a => P a
decimal = Parser a -> P a
forall a. Parser a -> P a
liftP Parser a
forall a. Integral a => Parser a
A.decimal

endOfInput :: P ()
endOfInput :: P ()
endOfInput = Parser () -> P ()
forall a. Parser a -> P a
liftP Parser ()
forall t. Chunk t => Parser t ()
A.endOfInput

endOfLine :: P ()
endOfLine :: P ()
endOfLine = Parser () -> P ()
forall a. Parser a -> P a
liftP Parser ()
A.endOfLine

takeWhile :: (Char -> Bool) -> P T.Text
takeWhile :: (Char -> Bool) -> P Text
takeWhile Char -> Bool
f = Parser Text -> P Text
forall a. Parser a -> P a
liftP ((Char -> Bool) -> Parser Text
A.takeWhile Char -> Bool
f)

takeWhile1 :: (Char -> Bool) -> P T.Text
takeWhile1 :: (Char -> Bool) -> P Text
takeWhile1 Char -> Bool
f = Parser Text -> P Text
forall a. Parser a -> P a
liftP ((Char -> Bool) -> Parser Text
A.takeWhile1 Char -> Bool
f)

skipWhile :: (Char -> Bool) -> P ()
skipWhile :: (Char -> Bool) -> P ()
skipWhile Char -> Bool
f = Parser () -> P ()
forall a. Parser a -> P a
liftP ((Char -> Bool) -> Parser ()
A.skipWhile Char -> Bool
f)

skipMany :: P a -> P ()
skipMany :: forall a. P a -> P ()
skipMany = P a -> P ()
forall (f :: * -> *) a. Alternative f => f a -> f ()
A.skipMany

option :: Alternative f => a -> f a -> f a
option :: forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option = a -> f a -> f a
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option

choice :: [P a] -> P a
choice :: forall a. [P a] -> P a
choice = [P a] -> P a
forall (f :: * -> *) a. Alternative f => [f a] -> f a
A.choice

count :: Int -> P a -> P [a]
count :: forall a. Int -> P a -> P [a]
count = Int -> P a -> P [a]
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
A.count

manyTill :: P a -> P b  -> P [a]
manyTill :: forall a b. P a -> P b -> P [a]
manyTill = P a -> P b -> P [a]
forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
A.manyTill

sepBy :: P a -> P b -> P [a]
sepBy :: forall a b. P a -> P b -> P [a]
sepBy = P a -> P b -> P [a]
forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
A.sepBy

sepBy1 :: P a -> P b -> P [a]
sepBy1 :: forall a b. P a -> P b -> P [a]
sepBy1 = P a -> P b -> P [a]
forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
A.sepBy1

--- Block parsing:

data BlockContext =
    SectionContext Int
  | ListContext Char Int
  | DelimitedContext Char Int
  deriving (Int -> BlockContext -> FilePath -> FilePath
[BlockContext] -> FilePath -> FilePath
BlockContext -> FilePath
(Int -> BlockContext -> FilePath -> FilePath)
-> (BlockContext -> FilePath)
-> ([BlockContext] -> FilePath -> FilePath)
-> Show BlockContext
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> BlockContext -> FilePath -> FilePath
showsPrec :: Int -> BlockContext -> FilePath -> FilePath
$cshow :: BlockContext -> FilePath
show :: BlockContext -> FilePath
$cshowList :: [BlockContext] -> FilePath -> FilePath
showList :: [BlockContext] -> FilePath -> FilePath
Show, BlockContext -> BlockContext -> Bool
(BlockContext -> BlockContext -> Bool)
-> (BlockContext -> BlockContext -> Bool) -> Eq BlockContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BlockContext -> BlockContext -> Bool
== :: BlockContext -> BlockContext -> Bool
$c/= :: BlockContext -> BlockContext -> Bool
/= :: BlockContext -> BlockContext -> Bool
Eq)


pDocument :: P Document
pDocument :: P Document
pDocument = do
  meta <- P Meta
pDocumentHeader
  attr' <- gets docAttrs
  let minSectionLevel = case Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
"doctype" Map Text Text
attr' of
                          Just Text
"book" -> Int
0
                          Maybe Text
_ -> Int
1
  bs <- (case M.lookup "hardbreaks-option" attr' of
            Just Text
"" -> P [Block] -> P [Block]
forall a. P a -> P a
withHardBreaks
            Maybe Text
_ -> P [Block] -> P [Block]
forall a. a -> a
id) $
        withBlockContext (SectionContext (minSectionLevel - 1)) pBlocks
  skipWhile isSpace
  endOfInput
  attr <- gets docAttrs
  pure $ Document { docMeta = meta{ docAttributes = attr } , docBlocks = bs }

pDocumentHeader :: P Meta
pDocumentHeader :: P Meta
pDocumentHeader = do
  P ()
skipBlankLines
  P () -> P ()
forall a. P a -> P ()
skipMany P ()
pDocAttribute
  P ()
skipBlankLines
  (title, titleAttr) <- ([Inline], Maybe Attr)
-> P ([Inline], Maybe Attr) -> P ([Inline], Maybe Attr)
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option ([], Maybe Attr
forall a. Maybe a
Nothing) (P ([Inline], Maybe Attr) -> P ([Inline], Maybe Attr))
-> P ([Inline], Maybe Attr) -> P ([Inline], Maybe Attr)
forall a b. (a -> b) -> a -> b
$ do
    (_,titleAttr) <- P (Maybe BlockTitle, Attr)
pTitlesAndAttributes
    title <- pDocumentTitle
    pure (title, case titleAttr of
                   Attr [] Map Text Text
kv | Map Text Text -> Bool
forall k a. Map k a -> Bool
M.null Map Text Text
kv -> Maybe Attr
forall a. Maybe a
Nothing
                   Attr
_ -> Attr -> Maybe Attr
forall a. a -> Maybe a
Just Attr
titleAttr)
  authors <- if null title
                then pure []
                else option [] pDocumentAuthors
  revision <- if null title
                 then pure Nothing
                 else optional pDocumentRevision
  skipMany pDocAttribute
  pure $ Meta{ docTitle = title
             , docTitleAttributes = titleAttr
             , docAuthors = authors
             , docRevision = revision
             , docAttributes = mempty }
              -- docAttributes this gets added at the end from docAttrs in state

pDocumentTitle :: P [Inline]
pDocumentTitle :: P [Inline]
pDocumentTitle = do
  (Char -> P ()
vchar Char
'=' P () -> P () -> P ()
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> P ()
vchar Char
'#') P () -> P FilePath -> P ()
forall a b. P a -> P b -> P a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* P Char -> P FilePath
forall a. P a -> P [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (Char -> P Char
char Char
' ')
  P Text
pLine P Text -> (Text -> P [Inline]) -> P [Inline]
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> P [Inline]
parseInlines

pDocumentAuthors :: P [Author]
pDocumentAuthors :: P [Author]
pDocumentAuthors = do
  mbc <- P (Maybe Char)
peekChar
  case mbc of
    Just Char
c | Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':' -> P [Author]
forall a. P a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    Maybe Char
_ -> Text -> [Author]
parseAuthors (Text -> [Author]) -> P Text -> P [Author]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Text
pLine

parseAuthors :: Text -> [Author]
parseAuthors :: Text -> [Author]
parseAuthors =
  (Text -> Author) -> [Text] -> [Author]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Author
parseAuthor (Text -> Author) -> (Text -> Text) -> Text -> Author
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip) ([Text] -> [Author]) -> (Text -> [Text]) -> Text -> [Author]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
';')

parseAuthor :: Text -> Author
parseAuthor :: Text -> Author
parseAuthor Text
t =
  Author { authorName :: Text
authorName = Text -> Text
T.strip Text
name
         , authorEmail :: Maybe Text
authorEmail = Maybe Text
email }
 where
  (Text
name, Text
rest) = (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'<') Text
t
  email :: Maybe Text
email = case Text -> Maybe (Char, Text)
T.uncons Text
rest of
            Just (Char
'<', Text
rest') -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'>') Text
rest'
            Maybe (Char, Text)
_ -> Maybe Text
forall a. Maybe a
Nothing

pDocumentRevision :: P Revision
pDocumentRevision :: P Revision
pDocumentRevision = do
  vprefix <- Bool -> P Bool -> P Bool
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option Bool
False (Bool
True Bool -> P () -> P Bool
forall a b. a -> P b -> P a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> P ()
vchar Char
'v')
  version <- takeWhile1 (\Char
c -> Bool -> Bool
not (Char -> Bool
isEndOfLine Char
c) Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
',')
  date <- optional (T.strip <$> (vchar ',' *> space
               *> takeWhile1 (\Char
c -> Bool -> Bool
not (Char -> Bool
isEndOfLine Char
c) Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':')))
  remark <- optional
            (T.strip <$> (vchar ':' *>  space *> takeWhile (not . isEndOfLine)))
  endOfLine
  when (isNothing date && isNothing remark) $ guard vprefix
  pure  Revision { revVersion = version
                 , revDate = date
                 , revRemark = remark
                 }

pLine :: P Text
pLine :: P Text
pLine = (Char -> Bool) -> P Text
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isEndOfLine) P Text -> P () -> P Text
forall a b. P a -> P b -> P a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (P ()
endOfLine P () -> P () -> P ()
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P ()
endOfInput)


pDocAttribute :: P ()
pDocAttribute :: P ()
pDocAttribute = do
  Char -> P ()
vchar Char
':'
  unset <- Bool -> P Bool -> P Bool
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option Bool
False (P Bool -> P Bool) -> P Bool -> P Bool
forall a b. (a -> b) -> a -> b
$ Bool
True Bool -> P () -> P Bool
forall a b. a -> P b -> P a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> P ()
vchar Char
'!'
  k <- pDocAttributeName
  vchar ':'
  v <- pLineWithEscapes
  modify $ \ParserState
s ->
    ParserState
s{ docAttrs =
         if unset
            then M.delete k (docAttrs s)
            else M.insert k v (docAttrs s) }

pDocAttributeName :: P Text
pDocAttributeName :: P Text
pDocAttributeName = do
  c <- (Char -> Bool) -> P Char
satisfy (\Char
d -> Char -> Bool
isAscii Char
d Bool -> Bool -> Bool
&& (Char -> Bool
isAlphaNum Char
d Bool -> Bool -> Bool
|| Char
d Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'))
  cs <- many $
          satisfy (\Char
d -> Char -> Bool
isAscii Char
d Bool -> Bool -> Bool
&& (Char -> Bool
isAlphaNum Char
d Bool -> Bool -> Bool
|| 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
'-'))
  pure $ T.pack (c:cs)

pLineWithEscapes :: P Text
pLineWithEscapes :: P Text
pLineWithEscapes = do
  _ <- (Char -> Bool) -> P Text
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')
  t <- takeWhile isLineEndChar
  endOfLine
  case T.stripSuffix "\\" t of
    Maybe Text
Nothing -> Text -> P Text
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
t
    Just Text
t' -> do
      case Text -> Text -> Maybe Text
T.stripSuffix Text
" +" Text
t' of
        Maybe Text
Nothing -> (Text
t' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> P Text -> P Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Text
pLineWithEscapes
        Just Text
t'' -> ((Text
t'' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> P Text -> P Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Text
pLineWithEscapes

isLineEndChar :: Char -> Bool
isLineEndChar :: Char -> Bool
isLineEndChar Char
'\r' = Bool
False
isLineEndChar Char
'\n' = Bool
False
isLineEndChar Char
_ = Bool
True

skipBlankLines :: P ()
skipBlankLines :: P ()
skipBlankLines = do
  contexts <- (ParserConfig -> [BlockContext]) -> P [BlockContext]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ParserConfig -> [BlockContext]
blockContexts
  case contexts of
    ListContext{} : [BlockContext]
_ -> P () -> P ()
forall a. P a -> P ()
skipMany (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$ Char -> P ()
vchar Char
'+' P () -> P () -> P ()
forall a b. P a -> P b -> P b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> P ()
pBlankLine
    [BlockContext]
_ -> P () -> P ()
forall a. P a -> P ()
skipMany P ()
pBlankLine

pBlankLine :: P ()
pBlankLine :: P ()
pBlankLine = (Char -> Bool) -> P Text
takeWhile (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\t') P Text -> P () -> P ()
forall a b. P a -> P b -> P b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (P ()
pLineComment P () -> P () -> P ()
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P ()
endOfLine)

parseWith :: P a -> Text -> P a
parseWith :: forall a. P a -> Text -> P a
parseWith P a
p Text
t = do
  cfg <- P ParserConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
  st <- get
  let result = ParserConfig
-> ParserState
-> P (a, ParserState)
-> Text
-> Either ParseError (a, ParserState)
forall a.
ParserConfig -> ParserState -> P a -> Text -> Either ParseError a
parse' ParserConfig
cfg ParserState
st ((,) (a -> ParserState -> (a, ParserState))
-> P a -> P (ParserState -> (a, ParserState))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P a
p P (ParserState -> (a, ParserState))
-> P ParserState -> P (a, ParserState)
forall a b. P (a -> b) -> P a -> P b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> P ParserState
forall s (m :: * -> *). MonadState s m => m s
get) Text
t
  case result of
    Left ParseError
e -> FilePath -> P a
forall a. FilePath -> P a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> P a) -> FilePath -> P a
forall a b. (a -> b) -> a -> b
$ ParseError -> FilePath
errorMessage ParseError
e
    Right (a
x, ParserState
newst) -> do
      ParserState -> P ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ParserState
newst
      a -> P a
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

parseBlocks :: Text -> P [Block]
parseBlocks :: Text -> P [Block]
parseBlocks = P [Block] -> Text -> P [Block]
forall a. P a -> Text -> P a
parseWith P [Block]
pBlocks (Text -> P [Block]) -> (Text -> Text) -> Text -> P [Block]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n") (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip

pBlocks :: P [Block]
pBlocks :: P [Block]
pBlocks = do
  bs <- P (Maybe Block) -> P [Maybe Block]
forall a. P a -> P [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many P (Maybe Block)
pBlock
  skipBlankLines
  skipMany pDocAttribute
  skipBlankLines
  pure $ catMaybes bs

parseAsciidoc :: Text -> P Document
parseAsciidoc :: Text -> P Document
parseAsciidoc = P Document -> Text -> P Document
forall a. P a -> Text -> P a
parseWith P Document
pDocument (Text -> P Document) -> (Text -> Text) -> Text -> P Document
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n") (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip

parseParagraphs :: Text -> P [Block]
parseParagraphs :: Text -> P [Block]
parseParagraphs = P [Block] -> Text -> P [Block]
forall a. P a -> Text -> P a
parseWith (P Block -> P [Block]
forall a. P a -> P [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many P Block
pParagraph) (Text -> P [Block]) -> (Text -> Text) -> Text -> P [Block]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n") (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip
 where
  pParagraph :: P Block
pParagraph = do
    P ()
skipBlankLines
    (mbtitle, attr@(Attr _ kvs)) <- P (Maybe BlockTitle, Attr)
pTitlesAndAttributes
    let hardbreaks = Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
"options" Map Text Text
kvs Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"hardbreaks"
    skipMany (pCommentBlock attr)
    (if hardbreaks then withHardBreaks else id) $ Block attr mbtitle <$> pPara

parseInlines :: Text -> P [Inline]
parseInlines :: Text -> P [Inline]
parseInlines = P [Inline] -> Text -> P [Inline]
forall a. P a -> Text -> P a
parseWith P [Inline]
pInlines (Text -> P [Inline]) -> (Text -> Text) -> Text -> P [Inline]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip

pBlock :: P (Maybe Block)
pBlock :: P (Maybe Block)
pBlock = do
  contexts <- (ParserConfig -> [BlockContext]) -> P [BlockContext]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ParserConfig -> [BlockContext]
blockContexts
  skipBlankLines
  skipMany pDocAttribute
  skipBlankLines
  (mbtitle, attr) <- pTitlesAndAttributes
  case contexts of
    ListContext{} : [BlockContext]
_ -> (Char -> Bool) -> P ()
skipWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')
    [BlockContext]
_ -> () -> P ()
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  let hardbreaks =
       case Attr
attr of
          Attr [Text]
_ Map Text Text
kvs
            | Just Text
opts <- Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
"options" Map Text Text
kvs
              -> Text
"hardbreaks" Text -> Text -> Bool
`T.isInfixOf` Text
opts
          Attr
_ -> Bool
False
  (Nothing <$ pCommentBlock attr) <|> fmap Just
    ((if hardbreaks then withHardBreaks else id) $
        pBlockMacro mbtitle attr
    <|> pDiscreteHeading mbtitle attr
    <|> pExampleBlock mbtitle attr
    <|> pSidebar mbtitle attr
    <|> pLiteralBlock mbtitle attr
    <|> pListing mbtitle attr
    <|> pFenced mbtitle attr
    <|> pVerse mbtitle attr
    <|> pQuoteBlock mbtitle attr
    <|> pPassBlock mbtitle attr
    <|> pOpenBlock mbtitle attr
    <|> pTable mbtitle attr
    <|> Block attr mbtitle <$>
          choice
            [ pSection
            , pThematicBreak
            , pPageBreak
            , pList
            , pDefinitionList
            , pIndentedLiteral
            , pPara
            ])


pIndentedLiteral :: P BlockType
pIndentedLiteral :: P BlockType
pIndentedLiteral = do
  xs <- P (Int, Text) -> P [(Int, Text)]
forall a. P a -> P [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some P (Int, Text)
pIndentedLine
  let minIndent = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (((Int, Text) -> Int) -> [(Int, Text)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Text) -> Int
forall a b. (a, b) -> a
fst [(Int, Text)]
xs)
  let xs' = ((Int, Text) -> (Int, Text)) -> [(Int, Text)] -> [(Int, Text)]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> Int) -> (Int, Text) -> (Int, Text)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (\Int
x -> Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
minIndent)) [(Int, Text)]
xs
  let t = [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ ((Int, Text) -> Text) -> [(Int, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
ind, Text
x) -> Int -> Text -> Text
T.replicate Int
ind Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x) [(Int, Text)]
xs'
  pure $ LiteralBlock t

pIndentedLine :: P (Int, Text)
pIndentedLine :: P (Int, Text)
pIndentedLine = do
  ind <- [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([()] -> Int) -> P [()] -> P Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P () -> P [()]
forall a. P a -> P [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (Char -> P ()
vchar Char
' ')
  t <- pLine
  pure (ind, t)

pPageBreak :: P BlockType
pPageBreak :: P BlockType
pPageBreak = BlockType
PageBreak BlockType -> P Text -> P BlockType
forall a b. a -> P b -> P a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Text -> P Text
string Text
"<<<" P Text -> P () -> P Text
forall a b. P a -> P b -> P a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* P ()
pBlankLine)

pThematicBreak :: P BlockType
pThematicBreak :: P BlockType
pThematicBreak = BlockType
ThematicBreak BlockType -> P () -> P BlockType
forall a b. a -> P b -> P a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$
  (P ()
pThematicBreakAsciidoc P () -> P () -> P ()
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> P ()
pThematicBreakMarkdown Char
'-' P () -> P () -> P ()
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> P ()
pThematicBreakMarkdown Char
'*')
 where
   pThematicBreakAsciidoc :: P ()
pThematicBreakAsciidoc = Text -> P Text
string Text
"'''" P Text -> P () -> P ()
forall a b. P a -> P b -> P b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> P ()
pBlankLine
   pThematicBreakMarkdown :: Char -> P ()
pThematicBreakMarkdown Char
c = Int -> P [()] -> P [[()]]
forall a. Int -> P a -> P [a]
count Int
3 (Char -> P ()
vchar Char
c P () -> P [()] -> P [()]
forall a b. P a -> P b -> P b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> P () -> P [()]
forall a. P a -> P [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Char -> P ()
vchar Char
' ')) P [[()]] -> P () -> P ()
forall a b. P a -> P b -> P b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> P ()
pBlankLine

pCommentBlock :: Attr -> P ()
pCommentBlock :: Attr -> P ()
pCommentBlock Attr
attr = P ()
pDelimitedCommentBlock P () -> P () -> P ()
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P ()
pAlternateCommentBlock
 where
  pDelimitedCommentBlock :: P ()
pDelimitedCommentBlock = P [Text] -> P ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (P [Text] -> P ()) -> P [Text] -> P ()
forall a b. (a -> b) -> a -> b
$ Char -> Int -> P [Text]
pDelimitedLiteralBlock Char
'/' Int
4
  pAlternateCommentBlock :: P ()
pAlternateCommentBlock = do
    case Attr
attr of
      Attr [Text
"comment"] Map Text Text
_ ->
        P [Text] -> P ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Char -> Int -> P [Text]
pDelimitedLiteralBlock Char
'-' Int
2) P () -> P () -> P ()
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                P (Text, BlockType) -> P ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (P BlockType -> P (Text, BlockType)
forall a. P a -> P (Text, a)
match (BlockContext -> P BlockType -> P BlockType
forall a. BlockContext -> P a -> P a
withBlockContext (Int -> BlockContext
SectionContext (-Int
1)) P BlockType
pPara))
      Attr
_ -> P ()
forall a. P a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

pBlockMacro :: Maybe BlockTitle -> Attr -> P Block
pBlockMacro :: Maybe BlockTitle -> Attr -> P Block
pBlockMacro Maybe BlockTitle
mbtitle Attr
attr = do
  (name, target) <- P (Text, Text)
pBlockMacro'
  handleBlockMacro mbtitle attr name target

pBlockMacro' :: P (Text, Text)
pBlockMacro' :: P (Text, Text)
pBlockMacro' = do
  name <- [P Text] -> P Text
forall a. [P a] -> P a
choice ((Text -> P Text) -> [Text] -> [P Text]
forall a b. (a -> b) -> [a] -> [b]
map (\Text
n -> Text -> P Text
string Text
n P Text -> P Text -> P Text
forall a b. P a -> P b -> P a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> P Text
string Text
"::") (Map Text (Maybe BlockTitle -> Attr -> Text -> P Block) -> [Text]
forall k a. Map k a -> [k]
M.keys Map Text (Maybe BlockTitle -> Attr -> Text -> P Block)
blockMacros))
  let targetChars = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> P [Text] -> P Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Text -> P [Text]
forall a. P a -> P [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some
        ((Char -> Bool) -> P Text
takeWhile1 (\Char
c -> Bool -> Bool
not (Char -> Bool
isSpace Char
c) 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 Text -> P Text -> P Text
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
         (Char -> P ()
vchar Char
'\\' P () -> P Text -> P Text
forall a b. P a -> P b -> P b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Text
T.singleton (Char -> Text) -> P Char -> P Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> P Char
satisfy (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'[' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'+')))
         P Text -> P Text -> P Text
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
         (do Inline _ (Str t) <- Bool -> Char -> Attr -> (Text -> P InlineType) -> P Inline
pInMatched Bool
False Char
'+' Attr
forall a. Monoid a => a
mempty (InlineType -> P InlineType
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InlineType -> P InlineType)
-> (Text -> InlineType) -> Text -> P InlineType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> InlineType
Str)
             pure t))
  target <- mconcat <$> many targetChars
  pure (name, target)

handleBlockMacro :: Maybe BlockTitle -> Attr -> Text -> Text -> P Block
handleBlockMacro :: Maybe BlockTitle -> Attr -> Text -> Text -> P Block
handleBlockMacro Maybe BlockTitle
mbtitle Attr
attr Text
name Text
target =
  case Text
-> Map Text (Maybe BlockTitle -> Attr -> Text -> P Block)
-> Maybe (Maybe BlockTitle -> Attr -> Text -> P Block)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
name Map Text (Maybe BlockTitle -> Attr -> Text -> P Block)
blockMacros of
    Maybe (Maybe BlockTitle -> Attr -> Text -> P Block)
Nothing -> P Block
forall a. P a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    Just Maybe BlockTitle -> Attr -> Text -> P Block
f -> Maybe BlockTitle -> Attr -> Text -> P Block
f Maybe BlockTitle
mbtitle Attr
attr Text
target

blockMacros :: M.Map Text (Maybe BlockTitle -> Attr -> Text -> P Block)
blockMacros :: Map Text (Maybe BlockTitle -> Attr -> Text -> P Block)
blockMacros = [(Text, Maybe BlockTitle -> Attr -> Text -> P Block)]
-> Map Text (Maybe BlockTitle -> Attr -> Text -> P Block)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
  [ (Text
"image", \Maybe BlockTitle
mbtitle Attr
attr Text
target -> do
        (Attr ps kvs) <- P Attr
pAttributes
        let (mbalt, mbw, mbh) =
              case ps of
                (Text
x:Text
y:Text
z:[Text]
_) -> (AltText -> Maybe AltText
forall a. a -> Maybe a
Just (Text -> AltText
AltText Text
x),
                              Int -> Width
Width (Int -> Width) -> Maybe Int -> Maybe Width
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe Int
readDecimal Text
y, Int -> Height
Height (Int -> Height) -> Maybe Int -> Maybe Height
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe Int
readDecimal Text
z)
                [Text
x,Text
y] -> (AltText -> Maybe AltText
forall a. a -> Maybe a
Just (Text -> AltText
AltText Text
x), Int -> Width
Width (Int -> Width) -> Maybe Int -> Maybe Width
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe Int
readDecimal Text
y, Maybe Height
forall a. Maybe a
Nothing)
                [Text
x] -> (AltText -> Maybe AltText
forall a. a -> Maybe a
Just (Text -> AltText
AltText Text
x), Maybe Width
forall a. Maybe a
Nothing, Maybe Height
forall a. Maybe a
Nothing)
                [] -> (Maybe AltText
forall a. Maybe a
Nothing, Maybe Width
forall a. Maybe a
Nothing, Maybe Height
forall a. Maybe a
Nothing)
        pure $ Block (Attr mempty kvs <> attr) mbtitle
             $ BlockImage (Target target) mbalt mbw mbh)
  , (Text
"video", \Maybe BlockTitle
mbtitle Attr
attr Text
target -> do
        attr' <- P Attr
pAttributes
        pure $ Block (attr' <> attr) mbtitle
             $ BlockVideo (Target target))
  , (Text
"audio", \Maybe BlockTitle
mbtitle Attr
attr Text
target -> do
        attr' <- P Attr
pAttributes
        pure $ Block (attr' <> attr) mbtitle
             $ BlockAudio (Target target))
  , (Text
"toc", \Maybe BlockTitle
mbtitle Attr
attr Text
_target -> do
        attr' <- P Attr
pAttributes
        pure $ Block (attr' <> attr) mbtitle TOC)
  , (Text
"include", \Maybe BlockTitle
mbtitle Attr
attr Text
target -> do
        attr' <- P Attr
pAttributes
        fp <- asks filePath
        let path = FilePath -> FilePath -> FilePath
resolvePath FilePath
fp (Text -> FilePath
T.unpack Text
target)
        pure $ Block (attr' <> attr) mbtitle $ Include path Nothing)
  ]

pSection :: P BlockType
pSection :: P BlockType
pSection = do
  contexts <- (ParserConfig -> [BlockContext]) -> P [BlockContext]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ParserConfig -> [BlockContext]
blockContexts
  case contexts of
    SectionContext Int
sectionLevel : [BlockContext]
_ -> do
      lev <- (\[()]
x -> [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [()]
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ([()] -> Int) -> P [()] -> P Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (P () -> P [()]
forall a. P a -> P [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (Char -> P ()
vchar Char
'=') P [()] -> P [()] -> P [()]
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P () -> P [()]
forall a. P a -> P [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (Char -> P ()
vchar Char
'#'))
      guard (lev > sectionLevel && lev >= 0 && lev <= 5)
      vchar ' '
      title <- pLine >>= parseInlines
      contents <- withBlockContext (SectionContext lev) pBlocks
      -- note: we use sectionLevel, not lev, so in improperly nested content, e.g.,
      -- == foo
      -- ==== bar
      -- ==== baz
      -- bar is a level-3 section and will contain baz!
      pure $ Section (Level (sectionLevel + 1)) title contents
    [BlockContext]
_ -> P BlockType
forall a. P a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

pDiscreteHeading :: Maybe BlockTitle -> Attr -> P Block
pDiscreteHeading :: Maybe BlockTitle -> Attr -> P Block
pDiscreteHeading Maybe BlockTitle
mbtitle Attr
attr = do
  let (Attr [Text]
ps Map Text Text
kvs) = Attr
attr
  Bool -> P ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> P ()) -> Bool -> P ()
forall a b. (a -> b) -> a -> b
$ case [Text]
ps of
            (Text
"discrete":[Text]
_) -> Bool
True
            [Text]
_ -> Bool
False
  lev <- (\[()]
x -> [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [()]
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ([()] -> Int) -> P [()] -> P Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (P () -> P [()]
forall a. P a -> P [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (Char -> P ()
vchar Char
'=') P [()] -> P [()] -> P [()]
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P () -> P [()]
forall a. P a -> P [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (Char -> P ()
vchar Char
'#'))
  guard (lev >= 0 && lev <= 5)
  vchar ' '
  title <- pLine >>= parseInlines
  pure $ Block (Attr (drop 1 ps) kvs) mbtitle $ DiscreteHeading (Level lev) title

pTitlesAndAttributes :: P (Maybe BlockTitle, Attr)
pTitlesAndAttributes :: P (Maybe BlockTitle, Attr)
pTitlesAndAttributes = do
  items <- P (Either BlockTitle Attr) -> P [Either BlockTitle Attr]
forall a. P a -> P [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many P (Either BlockTitle Attr)
pTitleOrAttribute
  let title = [BlockTitle] -> Maybe BlockTitle
forall a. [a] -> Maybe a
listToMaybe ([BlockTitle] -> Maybe BlockTitle)
-> [BlockTitle] -> Maybe BlockTitle
forall a b. (a -> b) -> a -> b
$ [Either BlockTitle Attr] -> [BlockTitle]
forall a b. [Either a b] -> [a]
lefts [Either BlockTitle Attr]
items
  let attr = [Attr] -> Attr
forall a. Monoid a => [a] -> a
mconcat ([Attr] -> Attr) -> [Attr] -> Attr
forall a b. (a -> b) -> a -> b
$ [Either BlockTitle Attr] -> [Attr]
forall a b. [Either a b] -> [b]
rights [Either BlockTitle Attr]
items
  pure (title, attr)

pTitleOrAttribute :: P (Either BlockTitle Attr)
pTitleOrAttribute :: P (Either BlockTitle Attr)
pTitleOrAttribute =
  ((BlockTitle -> Either BlockTitle Attr
forall a b. a -> Either a b
Left (BlockTitle -> Either BlockTitle Attr)
-> P BlockTitle -> P (Either BlockTitle Attr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P BlockTitle
pTitle)
    P (Either BlockTitle Attr)
-> P (Either BlockTitle Attr) -> P (Either BlockTitle Attr)
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Attr -> Either BlockTitle Attr
forall a b. b -> Either a b
Right (Attr -> Either BlockTitle Attr)
-> P Attr -> P (Either BlockTitle Attr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (P Attr
pAnchor P Attr -> P () -> P Attr
forall a b. P a -> P b -> P a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* P ()
endOfLine))
    P (Either BlockTitle Attr)
-> P (Either BlockTitle Attr) -> P (Either BlockTitle Attr)
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Attr -> Either BlockTitle Attr
forall a b. b -> Either a b
Right (Attr -> Either BlockTitle Attr)
-> P Attr -> P (Either BlockTitle Attr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (P Attr
pAttributes P Attr -> P () -> P Attr
forall a b. P a -> P b -> P a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* P ()
endOfLine))
  ) P (Either BlockTitle Attr) -> P () -> P (Either BlockTitle Attr)
forall a b. P a -> P b -> P a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* P () -> P ()
forall a. P a -> P ()
skipMany P ()
pBlankLine

pAnchor :: P Attr
pAnchor :: P Attr
pAnchor = do
  P Text -> P ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (P Text -> P ()) -> P Text -> P ()
forall a b. (a -> b) -> a -> b
$ Text -> P Text
string Text
"[["  -- [[anchor]] can set id
  anchor <- (Char -> Bool) -> P Text
takeWhile1 (\Char
c -> Bool -> Bool
not (Char -> Bool
isEndOfLine Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
']' Bool -> Bool -> Bool
|| Char -> Bool
isSpace Char
c))
  void $ string "]]"
  pure (Attr mempty (M.singleton "id" anchor))

pTitle :: P BlockTitle
pTitle :: P BlockTitle
pTitle = [Inline] -> BlockTitle
BlockTitle ([Inline] -> BlockTitle) -> P [Inline] -> P BlockTitle
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
           (do Char -> P ()
vchar Char
'.'
               mbc <- P (Maybe Char)
peekChar
               guard $ case mbc of
                         Just Char
' ' -> Bool
False
                         Just Char
'.' -> Bool
False
                         Maybe Char
_ -> Bool
True
               pLineWithEscapes >>= parseInlines)

pDefinitionList :: P BlockType
pDefinitionList :: P BlockType
pDefinitionList =
  [([Inline], [Block])] -> BlockType
DefinitionList ([([Inline], [Block])] -> BlockType)
-> P [([Inline], [Block])] -> P BlockType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P ([Inline], [Block]) -> P [([Inline], [Block])]
forall a. P a -> P [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some P ([Inline], [Block])
pDefinitionListItem

pDefinitionListItem :: P ([Inline],[Block])
pDefinitionListItem :: P ([Inline], [Block])
pDefinitionListItem = do
  contexts <- (ParserConfig -> [BlockContext]) -> P [BlockContext]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ParserConfig -> [BlockContext]
blockContexts
  let marker = (do t <- (Char -> Bool) -> P Text
takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':')
                   case contexts of
                       ListContext Char
':' Int
n : [BlockContext]
_ -> Bool -> P ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text -> Int
T.length Text
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)
                       [BlockContext]
_ -> Bool -> P ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text -> Int
T.length Text
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2))
  skipWhile (== ' ')
  term <- manyTill (takeWhile1 (\Char
c -> Bool -> Bool
not (Char -> Bool
isEndOfLine Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':'))
                              <|> takeWhile1 (==':')) marker
                    >>= parseInlines . mconcat
  skipWhile (== ' ')
  option () endOfLine
  skipWhile (== ' ')
  let newContext = case [BlockContext]
contexts of
                      ListContext Char
':' Int
n : [BlockContext]
_ -> Char -> Int -> BlockContext
ListContext Char
':' (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                      [BlockContext]
_ -> Char -> Int -> BlockContext
ListContext Char
':' Int
1
  defn <- withBlockContext newContext pBlocks
  void $ many pBlankLine
  pure (term, defn)

pList :: P BlockType
pList :: P BlockType
pList = do
  (c, lev, mbStart, mbCheckboxState) <- P (Char, Int, Maybe Int, Maybe CheckboxState)
pAnyListItemStart
  let guardContext BlockContext
ctx =
       case BlockContext
ctx of
         ListContext Char
c' Int
lev' -> Bool -> f ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> f ()) -> Bool -> f ()
forall a b. (a -> b) -> a -> b
$ Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
c' Bool -> Bool -> Bool
|| Int
lev Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
lev'
         BlockContext
_ -> () -> f ()
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  asks blockContexts >>= mapM_ guardContext
  ListItem _ bs <- withBlockContext (ListContext c lev) pListItem
  let x = Maybe CheckboxState -> [Block] -> ListItem
ListItem Maybe CheckboxState
mbCheckboxState [Block]
bs
  xs <- many (pListItemStart c lev *> withBlockContext (ListContext c lev) pListItem)
  let listType
        | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-'
        , Just CheckboxState
_ <- Maybe CheckboxState
mbCheckboxState
          = ListType
CheckList
        | 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
'1' = Level -> Maybe Int -> ListType
OrderedList (Int -> Level
Level Int
lev) Maybe Int
mbStart
        | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'<' = ListType
CalloutList
        | Bool
otherwise = Level -> ListType
BulletList (Int -> Level
Level Int
lev)
  pure $ List listType (x:xs)

pAnyListItemStart :: P (Char, Int, Maybe Int, Maybe CheckboxState)
pAnyListItemStart :: P (Char, Int, Maybe Int, Maybe CheckboxState)
pAnyListItemStart = (do
  (Char -> Bool) -> P ()
skipWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')
  c <- (Char -> Bool) -> P Char
satisfy (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'*' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'<')
  lev <- if c == '<'
            then pure 1
            else (+ 1) . T.length <$> takeWhile (== c)
  when (c == '<') $ do  -- callout list <1> or <.>
    void $ string "." <|> takeWhile1 isDigit
    vchar '>'
  vchar ' '
  mbCheck <- if c == '-' || c == '*'
                then optional pCheckbox
                else pure Nothing
  pure (c, lev, Nothing, mbCheck))
 P (Char, Int, Maybe Int, Maybe CheckboxState)
-> P (Char, Int, Maybe Int, Maybe CheckboxState)
-> P (Char, Int, Maybe Int, Maybe CheckboxState)
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (do d <- P Int
forall a. Integral a => P a
decimal
         vchar '.'
         vchar ' '
         pure ('1', 1, Just d, Nothing))


pCheckbox :: P CheckboxState
pCheckbox :: P CheckboxState
pCheckbox = do
  (Char -> Bool) -> P ()
skipWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
' ')
  Char -> P ()
vchar Char
'['
  c <- Char -> P Char
char Char
' ' P Char -> P Char -> P Char
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> P Char
char Char
'x' P Char -> P Char -> P Char
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> P Char
char Char
'*'
  vchar ']'
  vchar ' '
  pure $ if c == ' '
            then Unchecked
            else Checked

pListItemStart :: Char -> Int -> P ()
pListItemStart :: Char -> Int -> P ()
pListItemStart Char
c Int
lev = do
  (Char -> Bool) -> P ()
skipWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')
  case Char
c of
    Char
'<' -> Char -> P ()
vchar Char
'<' P () -> P Text -> P Text
forall a b. P a -> P b -> P b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Text -> P Text
string Text
"." P Text -> P Text -> P Text
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char -> Bool) -> P Text
takeWhile1 Char -> Bool
isDigit) P Text -> P () -> P ()
forall a b. P a -> P b -> P b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> P ()
vchar Char
'>'
    Char
'1' -> do Bool -> P ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
lev Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1)
              P Int -> P ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (P Int
forall a. Integral a => P a
decimal :: P Int)
              Char -> P ()
vchar Char
'.'
    Char
_ -> P [()] -> P ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (P [()] -> P ()) -> P [()] -> P ()
forall a b. (a -> b) -> a -> b
$ Int -> P () -> P [()]
forall a. Int -> P a -> P [a]
count Int
lev (Char -> P ()
vchar Char
c)
  Char -> P ()
vchar Char
' '

pListItem :: P ListItem
pListItem :: P ListItem
pListItem = do
  mbCheckboxState <- P CheckboxState -> P (Maybe CheckboxState)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional P CheckboxState
pCheckbox
  skipWhile (==' ')
  bs <- pBlocks
  pure $ ListItem mbCheckboxState bs

pDelimitedLiteralBlock :: Char -> Int -> P [T.Text]
pDelimitedLiteralBlock :: Char -> Int -> P [Text]
pDelimitedLiteralBlock Char
c Int
minimumNumber = do
  len <- [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([()] -> Int) -> P [()] -> P Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P () -> P [()]
forall a. P a -> P [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (Char -> P ()
vchar Char
c) P Int -> P () -> P Int
forall a b. P a -> P b -> P a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* P ()
pBlankLine
  guard $ len >= minimumNumber
  let endFence = Int -> P () -> P [()]
forall a. Int -> P a -> P [a]
count Int
len (Char -> P ()
vchar Char
c) P [()] -> P () -> P ()
forall a b. P a -> P b -> P b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (P ()
pBlankLine P () -> P () -> P ()
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P ()
endOfInput)
  manyTill pLine endFence

pDelimitedBlock :: Char -> Int -> P [Block]
pDelimitedBlock :: Char -> Int -> P [Block]
pDelimitedBlock Char
c Int
minimumNumber = do
  len <- [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([()] -> Int) -> P [()] -> P Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P () -> P [()]
forall a. P a -> P [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (Char -> P ()
vchar Char
c) P Int -> P () -> P Int
forall a b. P a -> P b -> P a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* P ()
pBlankLine
  guard $ len >= minimumNumber
  let endFence = Int -> P () -> P [()]
forall a. Int -> P a -> P [a]
count Int
len (Char -> P ()
vchar Char
c) P [()] -> P () -> P ()
forall a b. P a -> P b -> P b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> P ()
pBlankLine
  withBlockContext (DelimitedContext c len) $
    catMaybes <$> manyTill pBlock endFence

pPassBlock :: Maybe BlockTitle -> Attr -> P Block
pPassBlock :: Maybe BlockTitle -> Attr -> P Block
pPassBlock Maybe BlockTitle
mbtitle Attr
attr = do
  t <- [Text] -> Text
T.unlines ([Text] -> Text) -> P [Text] -> P Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Int -> P [Text]
pDelimitedLiteralBlock Char
'+' Int
4
  case attr of
    Attr (Text
"stem":[Text]
ps) Map Text Text
kvs ->
      Block -> P Block
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Block -> P Block) -> Block -> P Block
forall a b. (a -> b) -> a -> b
$ Attr -> Maybe BlockTitle -> BlockType -> Block
Block ([Text] -> Map Text Text -> Attr
Attr [Text]
ps Map Text Text
kvs) Maybe BlockTitle
mbtitle (BlockType -> Block) -> BlockType -> Block
forall a b. (a -> b) -> a -> b
$ Maybe MathType -> Text -> BlockType
MathBlock Maybe MathType
forall a. Maybe a
Nothing Text
t
    Attr (Text
"asciimath":[Text]
ps) Map Text Text
kvs ->
      Block -> P Block
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Block -> P Block) -> Block -> P Block
forall a b. (a -> b) -> a -> b
$ Attr -> Maybe BlockTitle -> BlockType -> Block
Block ([Text] -> Map Text Text -> Attr
Attr [Text]
ps Map Text Text
kvs) Maybe BlockTitle
mbtitle (BlockType -> Block) -> BlockType -> Block
forall a b. (a -> b) -> a -> b
$ Maybe MathType -> Text -> BlockType
MathBlock (MathType -> Maybe MathType
forall a. a -> Maybe a
Just MathType
AsciiMath) Text
t
    Attr (Text
"latexmath":[Text]
ps) Map Text Text
kvs ->
      Block -> P Block
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Block -> P Block) -> Block -> P Block
forall a b. (a -> b) -> a -> b
$ Attr -> Maybe BlockTitle -> BlockType -> Block
Block ([Text] -> Map Text Text -> Attr
Attr [Text]
ps Map Text Text
kvs) Maybe BlockTitle
mbtitle (BlockType -> Block) -> BlockType -> Block
forall a b. (a -> b) -> a -> b
$ Maybe MathType -> Text -> BlockType
MathBlock (MathType -> Maybe MathType
forall a. a -> Maybe a
Just MathType
LaTeXMath) Text
t
    Attr
_ -> Block -> P Block
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Block -> P Block) -> Block -> P Block
forall a b. (a -> b) -> a -> b
$ Attr -> Maybe BlockTitle -> BlockType -> Block
Block Attr
attr Maybe BlockTitle
mbtitle (BlockType -> Block) -> BlockType -> Block
forall a b. (a -> b) -> a -> b
$ Text -> BlockType
PassthroughBlock Text
t

pLiteralBlock :: Maybe BlockTitle -> Attr -> P Block
pLiteralBlock :: Maybe BlockTitle -> Attr -> P Block
pLiteralBlock Maybe BlockTitle
mbtitle Attr
attr =
  (Attr -> Maybe BlockTitle -> BlockType -> Block
Block Attr
attr Maybe BlockTitle
mbtitle (BlockType -> Block) -> ([Text] -> BlockType) -> [Text] -> Block
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> BlockType
LiteralBlock (Text -> BlockType) -> ([Text] -> Text) -> [Text] -> BlockType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unlines ([Text] -> Block) -> P [Text] -> P Block
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Int -> P [Text]
pDelimitedLiteralBlock Char
'.' Int
4)
  P Block -> P Block -> P Block
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  case Attr
attr of
    Attr (Text
"literal":[Text]
ps) Map Text Text
kvs -> do
      t <- [Text] -> Text
T.unlines ([Text] -> Text) -> P [Text] -> P Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Text -> P () -> P [Text]
forall a b. P a -> P b -> P [a]
manyTill P Text
pLine (P ()
pBlankLine P () -> P () -> P ()
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P ()
endOfInput)
      pure $ Block (Attr ps kvs) mbtitle $ LiteralBlock t
    Attr
_ -> P Block
forall a. P a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

pFenced :: Maybe BlockTitle -> Attr -> P Block
pFenced :: Maybe BlockTitle -> Attr -> P Block
pFenced Maybe BlockTitle
mbtitle Attr
attr = do
  ticks <- (Char -> Bool) -> P Text
takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'`')
  guard $ T.length ticks >= 3
  lang' <- pLine
  let mblang = case Text -> Text
T.strip Text
lang' of
                 Text
"" -> Maybe Language
forall a. Maybe a
Nothing
                 Text
l -> Language -> Maybe Language
forall a. a -> Maybe a
Just (Text -> Language
Language Text
l)
  lns <- toSourceLines <$> manyTill pLine (string ticks)
  pure $ Block attr mbtitle $ Listing mblang lns

pListing :: Maybe BlockTitle -> Attr -> P Block
pListing :: Maybe BlockTitle -> Attr -> P Block
pListing Maybe BlockTitle
mbtitle Attr
attr = (do
  let (Maybe Language
mbLang, Attr
attr') =
        case Attr
attr of
          Attr (Text
_:Text
lang:[Text]
ps) Map Text Text
kvs -> (Language -> Maybe Language
forall a. a -> Maybe a
Just (Text -> Language
Language Text
lang), [Text] -> Map Text Text -> Attr
Attr [Text]
ps Map Text Text
kvs)
          Attr [Text
"source"] Map Text Text
kvs -> (Maybe Language
forall a. Maybe a
Nothing, [Text] -> Map Text Text -> Attr
Attr [] Map Text Text
kvs)
          Attr
_ -> (Maybe Language
forall a. Maybe a
Nothing, Attr
attr)
  lns <- [Text] -> [SourceLine]
toSourceLines ([Text] -> [SourceLine]) -> P [Text] -> P [SourceLine]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Int -> P [Text]
pDelimitedLiteralBlock Char
'-' Int
4
  fp <- asks filePath
  pure $ Block attr' mbtitle $
    case lns of
      [SourceLine Text
x []] | Text
"include::" Text -> Text -> Bool
`T.isPrefixOf` Text
x
          , Right (Text
"include", Text
target) <- P (Text, Text)
-> FilePath -> Text -> Either ParseError (Text, Text)
forall a. P a -> FilePath -> Text -> Either ParseError a
parse P (Text, Text)
pBlockMacro' FilePath
fp Text
x
          -> Maybe Language -> FilePath -> Maybe [SourceLine] -> BlockType
IncludeListing Maybe Language
mbLang (FilePath -> FilePath -> FilePath
resolvePath FilePath
fp (Text -> FilePath
T.unpack Text
target)) Maybe [SourceLine]
forall a. Maybe a
Nothing
      [SourceLine]
_ -> Maybe Language -> [SourceLine] -> BlockType
Listing Maybe Language
mbLang [SourceLine]
lns)
 P Block -> P Block -> P Block
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  (case Attr
attr of
    Attr (Text
"listing":[Text]
ps) Map Text Text
kvs -> do
      lns <- [Text] -> [SourceLine]
toSourceLines ([Text] -> [SourceLine]) -> P [Text] -> P [SourceLine]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Text -> P () -> P [Text]
forall a b. P a -> P b -> P [a]
manyTill P Text
pLine (P ()
pBlankLine P () -> P () -> P ()
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P ()
endOfInput)
      pure $ Block (Attr ps kvs) mbtitle $ Listing Nothing lns
    Attr (Text
"source":Text
lang:[Text]
ps) Map Text Text
kvs -> do
      lns <- [Text] -> [SourceLine]
toSourceLines ([Text] -> [SourceLine]) -> P [Text] -> P [SourceLine]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Text -> P () -> P [Text]
forall a b. P a -> P b -> P [a]
manyTill P Text
pLine (P ()
pBlankLine P () -> P () -> P ()
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P ()
endOfInput)
      pure $ Block (Attr ps kvs) mbtitle
           $ Listing (Just (Language lang)) lns
    Attr [Text
"source"] Map Text Text
kvs -> do
      lns <- [Text] -> [SourceLine]
toSourceLines ([Text] -> [SourceLine]) -> P [Text] -> P [SourceLine]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Text -> P () -> P [Text]
forall a b. P a -> P b -> P [a]
manyTill P Text
pLine (P ()
pBlankLine P () -> P () -> P ()
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P ()
endOfInput)
      pure $ Block (Attr [] kvs) mbtitle $ Listing Nothing lns
    Attr
_ -> P Block
forall a. P a
forall (m :: * -> *) a. MonadPlus m => m a
mzero)

-- parse out callouts
toSourceLines :: [T.Text] -> [SourceLine]
toSourceLines :: [Text] -> [SourceLine]
toSourceLines = Int -> [Text] -> [SourceLine]
go Int
1
 where
   go :: Int -> [Text] -> [SourceLine]
go Int
_ [] = []
   go Int
nextnum (Text
t:[Text]
ts) =
     let (Text
t', [Maybe Int]
callouts) = [Maybe Int] -> Text -> (Text, [Maybe Int])
getCallouts [] Text
t
         (Int
nextnum'', [Callout]
callouts') =
                    ((Int, [Callout]) -> Maybe Int -> (Int, [Callout]))
-> (Int, [Callout]) -> [Maybe Int] -> (Int, [Callout])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\(Int
nextnum', [Callout]
cs) Maybe Int
c ->
                               case Maybe Int
c of
                                 Maybe Int
Nothing -> (Int
nextnum' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int -> Callout
Callout Int
nextnum' Callout -> [Callout] -> [Callout]
forall a. a -> [a] -> [a]
: [Callout]
cs)
                                 Just Int
i -> (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int -> Callout
Callout Int
i Callout -> [Callout] -> [Callout]
forall a. a -> [a] -> [a]
: [Callout]
cs))
                       (Int
nextnum, []) [Maybe Int]
callouts
     in Text -> [Callout] -> SourceLine
SourceLine Text
t' ([Callout] -> [Callout]
forall a. [a] -> [a]
reverse [Callout]
callouts') SourceLine -> [SourceLine] -> [SourceLine]
forall a. a -> [a] -> [a]
: Int -> [Text] -> [SourceLine]
go Int
nextnum'' [Text]
ts
   getCallouts :: [Maybe Int] -> Text -> (Text, [Maybe Int])
getCallouts [Maybe Int]
callouts Text
t =
    case HasCallStack => Text -> Text -> [(Text, Text)]
Text -> Text -> [(Text, Text)]
T.breakOnAll Text
"<" Text
t of
      [] -> (Text
t, [Maybe Int]
callouts)
      xs :: [(Text, Text)]
xs@((Text, Text)
_:[(Text, Text)]
_) ->
        let (Text
t', Text
rest) = [(Text, Text)] -> (Text, Text)
forall a. HasCallStack => [a] -> a
last [(Text, Text)]
xs
            (Text
ds, Text
rest') = (Char -> Bool) -> Text -> (Text, Text)
T.span (\Char
c -> Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') (Int -> Text -> Text
T.drop Int
1 Text
rest)
         in if Text -> Text
T.strip Text
rest' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
">" Bool -> Bool -> Bool
&& ((Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isDigit Text
ds Bool -> Bool -> Bool
|| Text
ds Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
".")
               then
                 if Text
ds Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"."
                    then [Maybe Int] -> Text -> (Text, [Maybe Int])
getCallouts (Maybe Int
forall a. Maybe a
Nothing Maybe Int -> [Maybe Int] -> [Maybe Int]
forall a. a -> [a] -> [a]
: [Maybe Int]
callouts) (Text -> Text
T.stripEnd Text
t')
                    else case Text -> Maybe Int
readDecimal Text
ds of
                           Just Int
num -> [Maybe Int] -> Text -> (Text, [Maybe Int])
getCallouts (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
num Maybe Int -> [Maybe Int] -> [Maybe Int]
forall a. a -> [a] -> [a]
: [Maybe Int]
callouts) (Text -> Text
T.stripEnd Text
t')
                           Maybe Int
Nothing -> (Text
t, [Maybe Int]
callouts)
               else (Text
t, [Maybe Int]
callouts)

pExampleBlock :: Maybe BlockTitle -> Attr -> P Block
pExampleBlock :: Maybe BlockTitle -> Attr -> P Block
pExampleBlock Maybe BlockTitle
mbtitle Attr
attr = do
  bs <- Char -> Int -> P [Block]
pDelimitedBlock Char
'=' Int
4
  pure $ case attr of
    Attr (Text
p:[Text]
ps) Map Text Text
kvs |
      Just AdmonitionType
adm <- Text -> Maybe AdmonitionType
parseAdmonitionType Text
p ->
        Attr -> Maybe BlockTitle -> BlockType -> Block
Block ([Text] -> Map Text Text -> Attr
Attr [Text]
ps Map Text Text
kvs) Maybe BlockTitle
mbtitle (BlockType -> Block) -> BlockType -> Block
forall a b. (a -> b) -> a -> b
$ AdmonitionType -> [Block] -> BlockType
Admonition AdmonitionType
adm [Block]
bs
    Attr
_ -> Attr -> Maybe BlockTitle -> BlockType -> Block
Block Attr
attr Maybe BlockTitle
mbtitle (BlockType -> Block) -> BlockType -> Block
forall a b. (a -> b) -> a -> b
$ [Block] -> BlockType
ExampleBlock [Block]
bs

pSidebar :: Maybe BlockTitle -> Attr -> P Block
pSidebar :: Maybe BlockTitle -> Attr -> P Block
pSidebar Maybe BlockTitle
mbtitle Attr
attr =
  Attr -> Maybe BlockTitle -> BlockType -> Block
Block Attr
attr Maybe BlockTitle
mbtitle (BlockType -> Block) -> ([Block] -> BlockType) -> [Block] -> Block
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Block] -> BlockType
Sidebar ([Block] -> Block) -> P [Block] -> P Block
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Int -> P [Block]
pDelimitedBlock Char
'*' Int
4

pVerse :: Maybe BlockTitle -> Attr -> P Block
pVerse :: Maybe BlockTitle -> Attr -> P Block
pVerse Maybe BlockTitle
mbtitle (Attr (Text
"verse":[Text]
xs) Map Text Text
kvs) = do
  let attribution :: Text
attribution = Text -> [Text] -> Text
T.intercalate Text
", " [Text]
xs
  let mbAttribution :: Maybe Attribution
mbAttribution = if Text -> Bool
T.null Text
attribution
                         then Maybe Attribution
forall a. Maybe a
Nothing
                         else Attribution -> Maybe Attribution
forall a. a -> Maybe a
Just (Text -> Attribution
Attribution Text
attribution)
  bs <- P [Block] -> P [Block]
forall a. P a -> P a
withHardBreaks (P [Block] -> P [Block]) -> P [Block] -> P [Block]
forall a b. (a -> b) -> a -> b
$
           Char -> Int -> P [Block]
pDelimitedBlock Char
'-' Int
2
       P [Block] -> P [Block] -> P [Block]
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Int -> P [Block]
pDelimitedBlock Char
'_' Int
4
       P [Block] -> P [Block] -> P [Block]
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
:[]) (Block -> [Block]) -> (BlockType -> Block) -> BlockType -> [Block]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attr -> Maybe BlockTitle -> BlockType -> Block
Block Attr
forall a. Monoid a => a
mempty Maybe BlockTitle
forall a. Maybe a
Nothing (BlockType -> [Block]) -> P BlockType -> P [Block]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P BlockType
pPara)
  pure $ Block (Attr [] kvs) mbtitle $ Verse mbAttribution bs
pVerse Maybe BlockTitle
_ Attr
_ = P Block
forall a. P a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

pQuoteBlock :: Maybe BlockTitle -> Attr -> P Block
pQuoteBlock :: Maybe BlockTitle -> Attr -> P Block
pQuoteBlock Maybe BlockTitle
mbtitle (Attr (Text
"quote":[Text]
xs) Map Text Text
kvs) = do
  let attribution :: Text
attribution = Text -> [Text] -> Text
T.intercalate Text
", " [Text]
xs
  let mbAttribution :: Maybe Attribution
mbAttribution = if Text -> Bool
T.null Text
attribution
                         then Maybe Attribution
forall a. Maybe a
Nothing
                         else Attribution -> Maybe Attribution
forall a. a -> Maybe a
Just (Text -> Attribution
Attribution Text
attribution)
  bs <-    Char -> Int -> P [Block]
pDelimitedBlock Char
'_' Int
4
       P [Block] -> P [Block] -> P [Block]
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Int -> P [Block]
pDelimitedBlock Char
'-' Int
2
       P [Block] -> P [Block] -> P [Block]
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
:[]) (Block -> [Block]) -> (BlockType -> Block) -> BlockType -> [Block]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attr -> Maybe BlockTitle -> BlockType -> Block
Block Attr
forall a. Monoid a => a
mempty Maybe BlockTitle
forall a. Maybe a
Nothing (BlockType -> [Block]) -> P BlockType -> P [Block]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P BlockType
pPara)
  pure $ Block (Attr [] kvs) mbtitle $ QuoteBlock mbAttribution bs
pQuoteBlock Maybe BlockTitle
_ Attr
_ = P Block
forall a. P a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

pOpenBlock :: Maybe BlockTitle -> Attr -> P Block
pOpenBlock :: Maybe BlockTitle -> Attr -> P Block
pOpenBlock Maybe BlockTitle
mbtitle Attr
attr = Attr -> Maybe BlockTitle -> BlockType -> Block
Block Attr
attr Maybe BlockTitle
mbtitle (BlockType -> Block) -> P BlockType -> P Block
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  (([Block] -> BlockType
OpenBlock ([Block] -> BlockType) -> P [Block] -> P BlockType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Int -> P [Block]
pDelimitedBlock Char
'-' Int
2)
   P BlockType -> P BlockType -> P BlockType
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  (Maybe Attribution -> [Block] -> BlockType
QuoteBlock Maybe Attribution
forall a. Maybe a
Nothing ([Block] -> BlockType) -> P [Block] -> P BlockType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
     (Char -> Int -> P [Block]
pDelimitedBlock Char
'-' Int
2 P [Block] -> P [Block] -> P [Block]
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Int -> P [Block]
pDelimitedBlock Char
'_' Int
4)))

parseAdmonitionType :: T.Text -> Maybe AdmonitionType
parseAdmonitionType :: Text -> Maybe AdmonitionType
parseAdmonitionType Text
t =
  case Text
t of
    Text
"NOTE" -> AdmonitionType -> Maybe AdmonitionType
forall a. a -> Maybe a
Just AdmonitionType
Note
    Text
"TIP" -> AdmonitionType -> Maybe AdmonitionType
forall a. a -> Maybe a
Just AdmonitionType
Tip
    Text
"IMPORTANT" -> AdmonitionType -> Maybe AdmonitionType
forall a. a -> Maybe a
Just AdmonitionType
Important
    Text
"CAUTION" -> AdmonitionType -> Maybe AdmonitionType
forall a. a -> Maybe a
Just AdmonitionType
Caution
    Text
"WARNING" -> AdmonitionType -> Maybe AdmonitionType
forall a. a -> Maybe a
Just AdmonitionType
Warning
    Text
_ -> Maybe AdmonitionType
forall a. Maybe a
Nothing

pPara :: P BlockType
pPara :: P BlockType
pPara = do
  t' <- P Text
pNormalLine
  contexts <- asks blockContexts
  case contexts of
    SectionContext{} : [BlockContext]
_ | Bool -> Bool
not (Text -> Bool
T.null Text
t') -> do
      case HasCallStack => Text -> Char
Text -> Char
T.head Text
t' of
        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
'#' -> do
          let eqs :: Int
eqs = Text -> Int
T.length (Text -> Int) -> Text -> Int
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
c) Text
t'
          let after :: Text
after = Int -> Text -> Text
T.take Int
1 (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
c) Text
t'
          Bool -> P ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> P ()) -> Bool -> P ()
forall a b. (a -> b) -> a -> b
$ Int
eqs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 Bool -> Bool -> Bool
|| Int
eqs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
6 Bool -> Bool -> Bool
|| Text
after Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
" " -- section heading
        Char
_ -> () -> P ()
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    [BlockContext]
_ -> () -> P ()
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  let (a,b) = T.break (== ':') t'
  let (t, mbAdmonition)
        = if ": " `T.isPrefixOf` b
          then
            let newt = Int -> Text -> Text
T.drop Int
2 Text
b
            in  case parseAdmonitionType a of
                 Just AdmonitionType
adm -> (Text
newt, AdmonitionType -> Maybe AdmonitionType
forall a. a -> Maybe a
Just AdmonitionType
adm)
                 Maybe AdmonitionType
Nothing -> (Text
t', Maybe AdmonitionType
forall a. Maybe a
Nothing)
          else (t', Nothing)
  ts <- many pNormalLine
  hardbreaks <- asks hardBreaks
  ils <- (if hardbreaks
             then newlinesToHardbreaks
             else id) <$> parseInlines (T.unlines (t:ts))
  pure $ case mbAdmonition of
           Maybe AdmonitionType
Nothing -> [Inline] -> BlockType
Paragraph [Inline]
ils
           Just AdmonitionType
admonType -> AdmonitionType -> [Block] -> BlockType
Admonition AdmonitionType
admonType
                  [Attr -> Maybe BlockTitle -> BlockType -> Block
Block Attr
forall a. Monoid a => a
mempty Maybe BlockTitle
forall a. Maybe a
Nothing ([Inline] -> BlockType
Paragraph [Inline]
ils)]

newlinesToHardbreaks :: [Inline] -> [Inline]
newlinesToHardbreaks :: [Inline] -> [Inline]
newlinesToHardbreaks [] = []
newlinesToHardbreaks (Inline Attr
attr (Str Text
t) : [Inline]
xs) | (Char -> Bool) -> Text -> Bool
T.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\n') Text
t =
  Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
intersperse (Attr -> InlineType -> Inline
Inline Attr
attr InlineType
HardBreak)
    ((Text -> Inline) -> [Text] -> [Inline]
forall a b. (a -> b) -> [a] -> [b]
map (Attr -> InlineType -> Inline
Inline Attr
attr (InlineType -> Inline) -> (Text -> InlineType) -> Text -> Inline
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> InlineType
Str) (Text -> [Text]
T.lines Text
t)) [Inline] -> [Inline] -> [Inline]
forall a. [a] -> [a] -> [a]
++ [Inline] -> [Inline]
newlinesToHardbreaks [Inline]
xs
newlinesToHardbreaks (Inline
x : [Inline]
xs) = Inline
x Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
: [Inline] -> [Inline]
newlinesToHardbreaks [Inline]
xs

pNormalLine :: P Text
pNormalLine :: P Text
pNormalLine = do
  P () -> P ()
forall a. P a -> P ()
notFollowedBy (Text -> P Text
string Text
"////" P Text -> P () -> P ()
forall a b. P a -> P b -> P b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> P ()
pBlankLine) -- block comment
  t <- P Text
pLine
  fp <- asks filePath
  guard $ not $ T.all (\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
'\t') t
  guard $ T.take 1 t /= "[" ||
          case parse (pAttributes *> skipWhile isSpace *> endOfInput)
                     fp t of
                Left ParseError
_ -> Bool
True
                Either ParseError ()
_ -> Bool
False
  let t' = Text -> Text
T.stripEnd Text
t
  contexts <- asks blockContexts
  let delims = [(Char
c, Int
num) | DelimitedContext Char
c Int
num <- [BlockContext]
contexts]
  mapM_ (\(Char
c, Int
num) -> Bool -> P ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not ((Char -> Bool) -> Text -> Bool
T.all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c) Text
t' Bool -> Bool -> Bool
&& Text -> Int
T.length Text
t' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
num)))
        delims
  case contexts of
    ListContext{} : [BlockContext]
_ -> do
      Bool -> P ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> P ()) -> Bool -> P ()
forall a b. (a -> b) -> a -> b
$ Text
t' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"+"
      Bool -> P ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> P ()) -> Bool -> P ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text
"::" Text -> Text -> Bool
`T.isInfixOf` Text
t'
      Bool -> P ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> P ()) -> Bool -> P ()
forall a b. (a -> b) -> a -> b
$ case P (Char, Int, Maybe Int, Maybe CheckboxState)
-> FilePath
-> Text
-> Either ParseError (Char, Int, Maybe Int, Maybe CheckboxState)
forall a. P a -> FilePath -> Text -> Either ParseError a
parse P (Char, Int, Maybe Int, Maybe CheckboxState)
pAnyListItemStart FilePath
fp (Text -> Text
T.strip Text
t) of
                Left ParseError
_ -> Bool
True
                Either ParseError (Char, Int, Maybe Int, Maybe CheckboxState)
_ -> Bool
False
    [BlockContext]
_ -> () -> P ()
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  pure t


--- Table parsing:

pTableBorder :: P TableSyntax
pTableBorder :: P TableSyntax
pTableBorder = do
  syntax <- (TableSyntax
PSV TableSyntax -> P () -> P TableSyntax
forall a b. a -> P b -> P a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> P ()
vchar Char
'|') P TableSyntax -> P TableSyntax -> P TableSyntax
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (TableSyntax
DSV TableSyntax -> P () -> P TableSyntax
forall a b. a -> P b -> P a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> P ()
vchar Char
':') P TableSyntax -> P TableSyntax -> P TableSyntax
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (TableSyntax
CSV TableSyntax -> P () -> P TableSyntax
forall a b. a -> P b -> P a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> P ()
vchar Char
',')
  void $ string "==="
  skipWhile (=='=')
  pBlankLine
  skipMany pBlankLine
  pure syntax

pTable :: Maybe BlockTitle -> Attr -> P Block
pTable :: Maybe BlockTitle -> Attr -> P Block
pTable Maybe BlockTitle
mbtitle (Attr [Text]
ps Map Text Text
kvs) = do
  syntax' <- P TableSyntax
pTableBorder
  mbcolspecs <- maybe (pure Nothing) (fmap Just . parseColspecs)
                  (M.lookup "cols" kvs)
  let options = [Text] -> (Text -> [Text]) -> Maybe Text -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Text -> [Text]
T.words (Maybe Text -> [Text]) -> Maybe Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
"options" Map Text Text
kvs
  let syntax = case Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
"format" Map Text Text
kvs of
                 Just Text
"psv" -> TableSyntax
PSV
                 Just Text
"csv" -> TableSyntax
CSV
                 Just Text
"dsv" -> TableSyntax
DSV
                 Just Text
"tsv" -> TableSyntax
TSV
                 Maybe Text
_ -> TableSyntax
syntax'
  let mbsep = case Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
"separator" Map Text Text
kvs of
                 Just Text
sep ->
                   case Text -> Maybe (Char, Text)
T.uncons Text
sep of
                     Just (Char
c,Text
_) -> Char -> Maybe Char
forall a. a -> Maybe a
Just Char
c
                     Maybe (Char, Text)
_ -> Maybe Char
forall a. Maybe a
Nothing
                 Maybe Text
_ -> Maybe Char
forall a. Maybe a
Nothing
  let tableOpts = TableOpts { tableSyntax :: TableSyntax
tableSyntax = TableSyntax
syntax
                            , tableSeparator :: Maybe Char
tableSeparator = Maybe Char
mbsep
                            , tableHeader :: Bool
tableHeader = Text
"header" Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
options Bool -> Bool -> Bool
||
                                Text
"noheader" Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
options
                            , tableFooter :: Bool
tableFooter = Text
"footer" Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
options Bool -> Bool -> Bool
||
                                Text
"nofooter" Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
options
                            }
  let getRows Maybe [ColumnSpec]
mbspecs [Int]
rowspans = (([],[]) ([TableRow], [ColumnSpec])
-> P TableSyntax -> P ([TableRow], [ColumnSpec])
forall a b. a -> P b -> P a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ P TableSyntax
pTableBorder) P ([TableRow], [ColumnSpec])
-> P ([TableRow], [ColumnSpec]) -> P ([TableRow], [ColumnSpec])
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
         do -- for this row, we modify the specs based on rowspans
            -- if there are rowspans from rows above, we need to skip some:
            let mbspecs' :: Maybe [ColumnSpec]
mbspecs' = case Maybe [ColumnSpec]
mbspecs of
                             Maybe [ColumnSpec]
Nothing -> Maybe [ColumnSpec]
forall a. Maybe a
Nothing
                             Just [ColumnSpec]
specs' -> [ColumnSpec] -> Maybe [ColumnSpec]
forall a. a -> Maybe a
Just [ColumnSpec
s | (ColumnSpec
s,Int
n) <- [ColumnSpec] -> [Int] -> [(ColumnSpec, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ColumnSpec]
specs' [Int]
rowspans, Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0]
            row@(TableRow cells) <- TableOpts -> Maybe [ColumnSpec] -> P TableRow
pTableRow TableOpts
tableOpts Maybe [ColumnSpec]
mbspecs'
            let numcols = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((TableCell -> Int) -> [TableCell] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map TableCell -> Int
cellColspan [TableCell]
cells)
            let specs = [ColumnSpec] -> Maybe [ColumnSpec] -> [ColumnSpec]
forall a. a -> Maybe a -> a
fromMaybe (Int -> ColumnSpec -> [ColumnSpec]
forall a. Int -> a -> [a]
replicate Int
numcols ColumnSpec
defaultColumnSpec) Maybe [ColumnSpec]
mbspecs
            -- now, update rowspans in light of new row
            let updateRowspans [] [Int]
rs = [Int]
rs
                updateRowspans (TableCell
c:[TableCell]
cs) [Int]
rs =
                  (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (TableCell -> Int
cellRowspan TableCell
c)) (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take (TableCell -> Int
cellColspan TableCell
c) [Int]
rs)
                  [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [TableCell] -> [Int] -> [Int]
updateRowspans [TableCell]
cs (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop (TableCell -> Int
cellColspan TableCell
c) [Int]
rs)
            let rowspans' = [TableCell] -> [Int] -> [Int]
updateRowspans [TableCell]
cells ((Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
x -> Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Int]
rowspans)
            (\([TableRow]
rows, [ColumnSpec]
colspecs') -> (TableRow
rowTableRow -> [TableRow] -> [TableRow]
forall a. a -> [a] -> [a]
:[TableRow]
rows, case [TableRow]
rows of
                                                 [] -> [ColumnSpec]
specs
                                                 [TableRow]
_ -> [ColumnSpec]
colspecs'))
                                     <$> getRows (Just specs) rowspans'
  (rows, colspecs') <- getRows mbcolspecs (repeat (0 :: Int))
  let attr' = [Text] -> Map Text Text -> Attr
Attr [Text]
ps (Map Text Text -> Attr) -> Map Text Text -> Attr
forall a b. (a -> b) -> a -> b
$ Text -> Map Text Text -> Map Text Text
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Text
"format" (Map Text Text -> Map Text Text)
-> (Map Text Text -> Map Text Text)
-> Map Text Text
-> Map Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                        Text -> Map Text Text -> Map Text Text
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Text
"separator" (Map Text Text -> Map Text Text)
-> (Map Text Text -> Map Text Text)
-> Map Text Text
-> Map Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                        Text -> Map Text Text -> Map Text Text
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Text
"cols" (Map Text Text -> Map Text Text)
-> (Map Text Text -> Map Text Text)
-> Map Text Text
-> Map Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                        Text -> Map Text Text -> Map Text Text
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Text
"options" (Map Text Text -> Map Text Text) -> Map Text Text -> Map Text Text
forall a b. (a -> b) -> a -> b
$ Map Text Text
kvs
  let (mbHead, rest)
        | tableHeader tableOpts = (Just (take 1 rows), drop 1 rows)
        | otherwise = (Nothing, rows)
  let (mbFoot, bodyRows)
        | tableFooter tableOpts
        , not (null rest) = (Just (drop (length rest - 1) rest),
                             take (length rest - 1) rest)
        | otherwise = (Nothing, rest)
  pure $ Block attr' mbtitle $ Table colspecs' mbHead bodyRows mbFoot

parseColspecs :: T.Text -> P [ColumnSpec]
parseColspecs :: Text -> P [ColumnSpec]
parseColspecs Text
t = do
  fp <- (ParserConfig -> FilePath) -> P FilePath
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ParserConfig -> FilePath
filePath
  case parse pColspecs fp t of
    Left ParseError
e -> FilePath -> P [ColumnSpec]
forall a. FilePath -> P a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> P [ColumnSpec]) -> FilePath -> P [ColumnSpec]
forall a b. (a -> b) -> a -> b
$ ParseError -> FilePath
errorMessage ParseError
e
    Right [ColumnSpec]
cs -> [ColumnSpec] -> P [ColumnSpec]
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ColumnSpec]
cs

pColspecs :: P [ColumnSpec]
pColspecs :: P [ColumnSpec]
pColspecs = [[ColumnSpec]] -> [ColumnSpec]
forall a. Monoid a => [a] -> a
mconcat ([[ColumnSpec]] -> [ColumnSpec])
-> P [[ColumnSpec]] -> P [ColumnSpec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P [ColumnSpec] -> P () -> P [[ColumnSpec]]
forall a b. P a -> P b -> P [a]
sepBy P [ColumnSpec]
pColspecPart P ()
pComma P [ColumnSpec] -> P () -> P [ColumnSpec]
forall a b. P a -> P b -> P a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* () -> P () -> P ()
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option () P ()
pComma

pColspecPart :: P [ColumnSpec]
pColspecPart :: P [ColumnSpec]
pColspecPart = do
  multiplier <- Int -> P Int -> P Int
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option Int
1 P Int
pMultiplier
  replicate multiplier <$> pColspec

pMultiplier :: P Int
pMultiplier :: P Int
pMultiplier = P Int
forall a. Integral a => P a
decimal P Int -> P () -> P Int
forall a b. P a -> P b -> P a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> P ()
vchar Char
'*'

pColspec :: P ColumnSpec
pColspec :: P ColumnSpec
pColspec = Maybe HorizAlign
-> Maybe VertAlign -> Maybe Int -> Maybe CellStyle -> ColumnSpec
ColumnSpec (Maybe HorizAlign
 -> Maybe VertAlign -> Maybe Int -> Maybe CellStyle -> ColumnSpec)
-> P (Maybe HorizAlign)
-> P (Maybe VertAlign
      -> Maybe Int -> Maybe CellStyle -> ColumnSpec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P HorizAlign -> P (Maybe HorizAlign)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional P HorizAlign
pHorizAlign
                      P (Maybe VertAlign -> Maybe Int -> Maybe CellStyle -> ColumnSpec)
-> P (Maybe VertAlign)
-> P (Maybe Int -> Maybe CellStyle -> ColumnSpec)
forall a b. P (a -> b) -> P a -> P b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> P VertAlign -> P (Maybe VertAlign)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional P VertAlign
pVertAlign
                      P (Maybe Int -> Maybe CellStyle -> ColumnSpec)
-> P (Maybe Int) -> P (Maybe CellStyle -> ColumnSpec)
forall a b. P (a -> b) -> P a -> P b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (P (Maybe Int)
pWidth P (Maybe Int) -> P (Maybe Int) -> P (Maybe Int)
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Int -> P (Maybe Int)
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
forall a. Maybe a
Nothing)
                      P (Maybe CellStyle -> ColumnSpec)
-> P (Maybe CellStyle) -> P ColumnSpec
forall a b. P (a -> b) -> P a -> P b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Char -> Maybe CellStyle
toCellStyle (Char -> Maybe CellStyle) -> P Char -> P (Maybe CellStyle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> P Char
satisfy (FilePath -> Char -> Bool
A.inClass FilePath
"adehlms")
                             P (Maybe CellStyle) -> P (Maybe CellStyle) -> P (Maybe CellStyle)
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe CellStyle -> P (Maybe CellStyle)
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CellStyle
forall a. Maybe a
Nothing)

pHorizAlign :: P HorizAlign
pHorizAlign :: P HorizAlign
pHorizAlign =
  (HorizAlign
AlignLeft HorizAlign -> P () -> P HorizAlign
forall a b. a -> P b -> P a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> P ()
vchar Char
'<') P HorizAlign -> P HorizAlign -> P HorizAlign
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (HorizAlign
AlignCenter HorizAlign -> P () -> P HorizAlign
forall a b. a -> P b -> P a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> P ()
vchar Char
'^') P HorizAlign -> P HorizAlign -> P HorizAlign
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (HorizAlign
AlignRight HorizAlign -> P () -> P HorizAlign
forall a b. a -> P b -> P a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> P ()
vchar Char
'>')

pVertAlign :: P VertAlign
pVertAlign :: P VertAlign
pVertAlign = do
  Char -> P ()
vchar Char
'.'
  (VertAlign
AlignTop VertAlign -> P () -> P VertAlign
forall a b. a -> P b -> P a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> P ()
vchar Char
'<') P VertAlign -> P VertAlign -> P VertAlign
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (VertAlign
AlignMiddle VertAlign -> P () -> P VertAlign
forall a b. a -> P b -> P a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> P ()
vchar Char
'^') P VertAlign -> P VertAlign -> P VertAlign
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (VertAlign
AlignBottom VertAlign -> P () -> P VertAlign
forall a b. a -> P b -> P a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> P ()
vchar Char
'>')

pWidth :: P (Maybe Int)
pWidth :: P (Maybe Int)
pWidth = (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> P Int -> P (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (P Int
forall a. Integral a => P a
decimal P Int -> P () -> P Int
forall a b. P a -> P b -> P a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* () -> P () -> P ()
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option () (Char -> P ()
vchar Char
'%'))) P (Maybe Int) -> P (Maybe Int) -> P (Maybe Int)
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Maybe Int
forall a. Maybe a
Nothing Maybe Int -> P () -> P (Maybe Int)
forall a b. a -> P b -> P a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> P ()
vchar Char
'~')

data TableSyntax =
    PSV
  | CSV
  | TSV
  | DSV
  deriving (Int -> TableSyntax -> FilePath -> FilePath
[TableSyntax] -> FilePath -> FilePath
TableSyntax -> FilePath
(Int -> TableSyntax -> FilePath -> FilePath)
-> (TableSyntax -> FilePath)
-> ([TableSyntax] -> FilePath -> FilePath)
-> Show TableSyntax
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> TableSyntax -> FilePath -> FilePath
showsPrec :: Int -> TableSyntax -> FilePath -> FilePath
$cshow :: TableSyntax -> FilePath
show :: TableSyntax -> FilePath
$cshowList :: [TableSyntax] -> FilePath -> FilePath
showList :: [TableSyntax] -> FilePath -> FilePath
Show)

data TableOpts =
  TableOpts { TableOpts -> TableSyntax
tableSyntax :: TableSyntax
            , TableOpts -> Maybe Char
tableSeparator :: Maybe Char
            , TableOpts -> Bool
tableHeader :: Bool
            , TableOpts -> Bool
tableFooter :: Bool
            }
  deriving (Int -> TableOpts -> FilePath -> FilePath
[TableOpts] -> FilePath -> FilePath
TableOpts -> FilePath
(Int -> TableOpts -> FilePath -> FilePath)
-> (TableOpts -> FilePath)
-> ([TableOpts] -> FilePath -> FilePath)
-> Show TableOpts
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> TableOpts -> FilePath -> FilePath
showsPrec :: Int -> TableOpts -> FilePath -> FilePath
$cshow :: TableOpts -> FilePath
show :: TableOpts -> FilePath
$cshowList :: [TableOpts] -> FilePath -> FilePath
showList :: [TableOpts] -> FilePath -> FilePath
Show)

pTableRow :: TableOpts -> Maybe [ColumnSpec] -> P TableRow
pTableRow :: TableOpts -> Maybe [ColumnSpec] -> P TableRow
pTableRow TableOpts
opts Maybe [ColumnSpec]
mbcolspecs = [TableCell] -> TableRow
TableRow ([TableCell] -> TableRow) -> P [TableCell] -> P TableRow
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  case TableOpts -> TableSyntax
tableSyntax TableOpts
opts of
       TableSyntax
PSV
         | Just [ColumnSpec]
colspecs <- Maybe [ColumnSpec]
mbcolspecs  ->
             let getCell :: [ColumnSpec] -> P [TableCell]
                 getCell :: [ColumnSpec] -> P [TableCell]
getCell [] = [TableCell] -> P [TableCell]
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
                 getCell [ColumnSpec]
colspecs' = do
                   xs <- Maybe Char -> Bool -> [ColumnSpec] -> P [TableCell]
pTableCellPSV (TableOpts -> Maybe Char
tableSeparator TableOpts
opts) Bool
True [ColumnSpec]
colspecs'
                   skipMany pBlankLine
                   (xs ++) <$> getCell (drop (sum (map cellColspan xs)) colspecs')
             in  [ColumnSpec] -> P [TableCell]
getCell [ColumnSpec]
colspecs
         | Bool
otherwise -> [[TableCell]] -> [TableCell]
forall a. Monoid a => [a] -> a
mconcat ([[TableCell]] -> [TableCell]) -> P [[TableCell]] -> P [TableCell]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
               P [TableCell] -> P [[TableCell]]
forall a. P a -> P [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (Maybe Char -> Bool -> [ColumnSpec] -> P [TableCell]
pTableCellPSV (TableOpts -> Maybe Char
tableSeparator TableOpts
opts)
                       Bool
False (ColumnSpec -> [ColumnSpec]
forall a. a -> [a]
repeat ColumnSpec
defaultColumnSpec))
                     P [TableCell] -> P () -> P [TableCell]
forall a b. P a -> P b -> P a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* P () -> P ()
forall a. P a -> P ()
skipMany P ()
pBlankLine
       TableSyntax
CSV -> Char -> Maybe [ColumnSpec] -> P [TableCell]
pCSVTableRow (Char -> Maybe Char -> Char
forall a. a -> Maybe a -> a
fromMaybe Char
',' (Maybe Char -> Char) -> Maybe Char -> Char
forall a b. (a -> b) -> a -> b
$ TableOpts -> Maybe Char
tableSeparator TableOpts
opts) Maybe [ColumnSpec]
mbcolspecs
       TableSyntax
TSV -> Char -> Maybe [ColumnSpec] -> P [TableCell]
pCSVTableRow (Char -> Maybe Char -> Char
forall a. a -> Maybe a -> a
fromMaybe Char
'\t' (Maybe Char -> Char) -> Maybe Char -> Char
forall a b. (a -> b) -> a -> b
$ TableOpts -> Maybe Char
tableSeparator TableOpts
opts) Maybe [ColumnSpec]
mbcolspecs
       TableSyntax
DSV -> Char -> Maybe [ColumnSpec] -> P [TableCell]
pDSVTableRow (Char -> Maybe Char -> Char
forall a. a -> Maybe a -> a
fromMaybe Char
':' (Maybe Char -> Char) -> Maybe Char -> Char
forall a b. (a -> b) -> a -> b
$ TableOpts -> Maybe Char
tableSeparator TableOpts
opts) Maybe [ColumnSpec]
mbcolspecs

defaultColumnSpec :: ColumnSpec
defaultColumnSpec :: ColumnSpec
defaultColumnSpec = Maybe HorizAlign
-> Maybe VertAlign -> Maybe Int -> Maybe CellStyle -> ColumnSpec
ColumnSpec Maybe HorizAlign
forall a. Maybe a
Nothing Maybe VertAlign
forall a. Maybe a
Nothing Maybe Int
forall a. Maybe a
Nothing Maybe CellStyle
forall a. Maybe a
Nothing

-- Note: AsciiDoc weirdly gobbles cells for rows even across CSV
-- row boundaries. We're not going to do that.

-- allows "; escape this as ""; delim can't be escaped
pCSVTableRow :: Char -> Maybe [ColumnSpec] -> P [TableCell]
pCSVTableRow :: Char -> Maybe [ColumnSpec] -> P [TableCell]
pCSVTableRow Char
delim Maybe [ColumnSpec]
mbcolspecs = do
  let colspecs :: [ColumnSpec]
colspecs = [ColumnSpec] -> Maybe [ColumnSpec] -> [ColumnSpec]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [ColumnSpec]
mbcolspecs
  as <- P Text -> P () -> P [Text]
forall a b. P a -> P b -> P [a]
sepBy (Char -> P Text
pCSVCell Char
delim) (Char -> P ()
vchar Char
delim)
  pBlankLine *> skipMany pBlankLine
  zipWithM toBasicCell as (colspecs ++ repeat defaultColumnSpec)

pCSVCell :: Char -> P T.Text
pCSVCell :: Char -> P Text
pCSVCell Char
delim = do
  (Char -> Bool) -> P ()
skipWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')
  mbc <- P (Maybe Char)
peekChar
  case mbc of
    Just Char
'"'
      -> Char -> P ()
vchar Char
'"' P () -> P Text -> P Text
forall a b. P a -> P b -> P b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
          (FilePath -> Text
T.pack (FilePath -> Text) -> P FilePath -> P Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            P Char -> P () -> P FilePath
forall a b. P a -> P b -> P [a]
manyTill ((Char -> Bool) -> P Char
satisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'"') P Char -> P Char -> P Char
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char
'"' Char -> P Text -> P Char
forall a b. a -> P b -> P a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> P Text
string Text
"\"\"")) (Char -> P ()
vchar Char
'"'))
    Maybe Char
_ -> Text -> Text
T.strip (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"\"\"" Text
"\"" (Text -> Text) -> P Text -> P Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
           (Char -> Bool) -> P Text
takeWhile1 (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
delim Bool -> Bool -> Bool
&& Bool -> Bool
not (Char -> Bool
isEndOfLine Char
c))

-- no "; escape delim with backslash
pDSVTableRow:: Char -> Maybe [ColumnSpec] -> P [TableCell]
pDSVTableRow :: Char -> Maybe [ColumnSpec] -> P [TableCell]
pDSVTableRow Char
delim Maybe [ColumnSpec]
mbcolspecs = do
  let colspecs :: [ColumnSpec]
colspecs = [ColumnSpec] -> Maybe [ColumnSpec] -> [ColumnSpec]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [ColumnSpec]
mbcolspecs
  as <- P Text -> P () -> P [Text]
forall a b. P a -> P b -> P [a]
sepBy (Char -> P Text
pDSVCell Char
delim) (Char -> P ()
vchar Char
delim)
  pBlankLine *> skipMany pBlankLine
  zipWithM toBasicCell as (colspecs ++ repeat defaultColumnSpec)

pDSVCell :: Char -> P T.Text
pDSVCell :: Char -> P Text
pDSVCell Char
delim =
  Text -> Text
T.strip (Text -> Text) -> ([Text] -> Text) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> P [Text] -> P Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    P Text -> P [Text]
forall a. P a -> P [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ((Char -> Bool) -> P Text
takeWhile1 (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
delim Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\\' Bool -> Bool -> Bool
&& Bool -> Bool
not (Char -> Bool
isEndOfLine Char
c))
       P Text -> P Text -> P Text
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char -> P ()
vchar Char
'\\' P () -> P Text -> P Text
forall a b. P a -> P b -> P b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ((\Char
c -> Text
"\\" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Char -> Text
T.singleton Char
c) (Char -> Text) -> P Char -> P Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Char
anyChar)))

toBasicCell :: T.Text -> ColumnSpec -> P TableCell
toBasicCell :: Text -> ColumnSpec -> P TableCell
toBasicCell Text
t ColumnSpec
colspec = do
  bs <- CellStyle -> Text -> P [Block]
parseCellContents (CellStyle -> Maybe CellStyle -> CellStyle
forall a. a -> Maybe a -> a
fromMaybe CellStyle
DefaultStyle (ColumnSpec -> Maybe CellStyle
colStyle ColumnSpec
colspec)) Text
t
  pure TableCell
         { cellContent = bs
         , cellHorizAlign = Nothing
         , cellVertAlign = Nothing
         , cellColspan = 1
         , cellRowspan = 1
         }


pTableCellPSV :: Maybe Char -> Bool -> [ColumnSpec] -> P [TableCell]
pTableCellPSV :: Maybe Char -> Bool -> [ColumnSpec] -> P [TableCell]
pTableCellPSV Maybe Char
mbsep Bool
allowNewlines [ColumnSpec]
colspecs = do
  let sep :: Char
sep = Char -> Maybe Char -> Char
forall a. a -> Maybe a -> a
fromMaybe Char
'|' Maybe Char
mbsep
  cellData <- Char -> P CellData
pCellSep Char
sep
  t <- T.pack <$>
         many
          (notFollowedBy (void (pCellSep sep) <|> void pTableBorder) *>
           ((vchar '\\' *> char sep)
             <|> satisfy (not . isEndOfLine)
             <|> if allowNewlines
                    then satisfy isEndOfLine
                    else satisfy isEndOfLine <* notFollowedBy (pCellSep sep)))
  let cell' = TableCell
               { cellContent :: [Block]
cellContent = []
               , cellHorizAlign :: Maybe HorizAlign
cellHorizAlign = CellData -> Maybe HorizAlign
cHorizAlign CellData
cellData
               , cellVertAlign :: Maybe VertAlign
cellVertAlign = CellData -> Maybe VertAlign
cVertAlign CellData
cellData
               , cellColspan :: Int
cellColspan = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
1 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ CellData -> Maybe Int
cColspan CellData
cellData
               , cellRowspan :: Int
cellRowspan = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
1 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ CellData -> Maybe Int
cRowspan CellData
cellData
               }
  let rawcells = Int -> (TableCell, Text) -> [(TableCell, Text)]
forall a. Int -> a -> [a]
replicate (CellData -> Int
cDuplicate CellData
cellData) (TableCell
cell', Text
t)
  reverse . fst <$> foldM (\([TableCell]
cells, [ColumnSpec]
specs) (TableCell
cell, Text
rawtext) -> do
                        let defsty :: Maybe CellStyle
defsty = case [ColumnSpec]
specs of
                                       ColumnSpec
spec:[ColumnSpec]
_ -> ColumnSpec -> Maybe CellStyle
colStyle ColumnSpec
spec
                                       [ColumnSpec]
_ -> Maybe CellStyle
forall a. Maybe a
Nothing
                        let sty :: CellStyle
sty = CellStyle -> Maybe CellStyle -> CellStyle
forall a. a -> Maybe a -> a
fromMaybe CellStyle
DefaultStyle (Maybe CellStyle -> CellStyle) -> Maybe CellStyle -> CellStyle
forall a b. (a -> b) -> a -> b
$ CellData -> Maybe CellStyle
cStyle CellData
cellData Maybe CellStyle -> Maybe CellStyle -> Maybe CellStyle
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe CellStyle
defsty
                        bs <- CellStyle -> Text -> P [Block]
parseCellContents CellStyle
sty Text
rawtext
                        pure (cell{ cellContent = bs } : cells,
                              drop (cellColspan cell) specs))
                ([],colspecs)
                rawcells


parseCellContents :: CellStyle -> T.Text -> P [Block]
parseCellContents :: CellStyle -> Text -> P [Block]
parseCellContents CellStyle
sty Text
t =
  case CellStyle
sty of
    CellStyle
AsciiDocStyle -> Document -> [Block]
docBlocks (Document -> [Block]) -> P Document -> P [Block]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> P Document
parseAsciidoc Text
t
    CellStyle
DefaultStyle -> Text -> P [Block]
parseParagraphs Text
t
    CellStyle
LiteralStyle -> [Block] -> P [Block]
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Attr -> Maybe BlockTitle -> BlockType -> Block
Block Attr
forall a. Monoid a => a
mempty Maybe BlockTitle
forall a. Maybe a
Nothing (BlockType -> Block) -> BlockType -> Block
forall a b. (a -> b) -> a -> b
$ Text -> BlockType
LiteralBlock Text
t]
    CellStyle
EmphasisStyle -> (Block -> Block) -> [Block] -> [Block]
forall a b. (a -> b) -> [a] -> [b]
map (([Inline] -> InlineType) -> Block -> Block
surroundPara [Inline] -> InlineType
Italic) ([Block] -> [Block]) -> P [Block] -> P [Block]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> P [Block]
parseBlocks Text
t
    CellStyle
StrongStyle -> (Block -> Block) -> [Block] -> [Block]
forall a b. (a -> b) -> [a] -> [b]
map (([Inline] -> InlineType) -> Block -> Block
surroundPara [Inline] -> InlineType
Bold) ([Block] -> [Block]) -> P [Block] -> P [Block]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> P [Block]
parseBlocks Text
t
    CellStyle
MonospaceStyle -> (Block -> Block) -> [Block] -> [Block]
forall a b. (a -> b) -> [a] -> [b]
map (([Inline] -> InlineType) -> Block -> Block
surroundPara [Inline] -> InlineType
Monospace) ([Block] -> [Block]) -> P [Block] -> P [Block]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> P [Block]
parseBlocks Text
t
    CellStyle
HeaderStyle -> Text -> P [Block]
parseBlocks Text
t
 where
   surroundPara :: ([Inline] -> InlineType) -> Block -> Block
   surroundPara :: ([Inline] -> InlineType) -> Block -> Block
surroundPara [Inline] -> InlineType
bt (Block Attr
attr Maybe BlockTitle
mbtitle (Paragraph [Inline]
ils)) =
     Attr -> Maybe BlockTitle -> BlockType -> Block
Block Attr
attr Maybe BlockTitle
mbtitle ([Inline] -> BlockType
Paragraph [Attr -> InlineType -> Inline
Inline Attr
forall a. Monoid a => a
mempty (InlineType -> Inline) -> InlineType -> Inline
forall a b. (a -> b) -> a -> b
$ [Inline] -> InlineType
bt [Inline]
ils])
   surroundPara [Inline] -> InlineType
_ Block
b = Block
b


data CellData =
  CellData
  { CellData -> Int
cDuplicate :: Int
  , CellData -> Maybe HorizAlign
cHorizAlign :: Maybe HorizAlign
  , CellData -> Maybe VertAlign
cVertAlign :: Maybe VertAlign
  , CellData -> Maybe Int
cColspan :: Maybe Int
  , CellData -> Maybe Int
cRowspan :: Maybe Int
  , CellData -> Maybe CellStyle
cStyle :: Maybe CellStyle }
  deriving (Int -> CellData -> FilePath -> FilePath
[CellData] -> FilePath -> FilePath
CellData -> FilePath
(Int -> CellData -> FilePath -> FilePath)
-> (CellData -> FilePath)
-> ([CellData] -> FilePath -> FilePath)
-> Show CellData
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> CellData -> FilePath -> FilePath
showsPrec :: Int -> CellData -> FilePath -> FilePath
$cshow :: CellData -> FilePath
show :: CellData -> FilePath
$cshowList :: [CellData] -> FilePath -> FilePath
showList :: [CellData] -> FilePath -> FilePath
Show)

toCellStyle :: Char -> Maybe CellStyle
toCellStyle :: Char -> Maybe CellStyle
toCellStyle Char
'a' = CellStyle -> Maybe CellStyle
forall a. a -> Maybe a
Just CellStyle
AsciiDocStyle
toCellStyle Char
'd' = CellStyle -> Maybe CellStyle
forall a. a -> Maybe a
Just CellStyle
DefaultStyle
toCellStyle Char
'e' = CellStyle -> Maybe CellStyle
forall a. a -> Maybe a
Just CellStyle
EmphasisStyle
toCellStyle Char
'h' = CellStyle -> Maybe CellStyle
forall a. a -> Maybe a
Just CellStyle
HeaderStyle
toCellStyle Char
'l' = CellStyle -> Maybe CellStyle
forall a. a -> Maybe a
Just CellStyle
LiteralStyle
toCellStyle Char
'm' = CellStyle -> Maybe CellStyle
forall a. a -> Maybe a
Just CellStyle
MonospaceStyle
toCellStyle Char
's' = CellStyle -> Maybe CellStyle
forall a. a -> Maybe a
Just CellStyle
StrongStyle
toCellStyle Char
_   = Maybe CellStyle
forall a. Maybe a
Nothing

-- 2+| colspan 2
-- 3.+| rowspan 3
-- 2.3+| colspan 2, rowspan 3
-- 2*| duplicate cell twice
-- 2*.3+^.>s| duplicate 2x, rowspan 3, top align, right align, s style
pCellSep :: Char -> P CellData
pCellSep :: Char -> P CellData
pCellSep Char
sep = do
  mult <- Int -> P Int -> P Int
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option Int
1 P Int
pMultiplier
  (colspan, rowspan) <- option (Nothing, Nothing) $ do
    a <- optional decimal
    b <- optional $ vchar '.' *> decimal
    guard $ not (isNothing a && isNothing b)
    vchar '+'
    pure (a, b)
  halign <- optional pHorizAlign
  valign <- optional pVertAlign
  sty <- (toCellStyle <$> satisfy (A.inClass "adehlms")) <|> pure Nothing
  notFollowedBy pTableBorder <* vchar sep
  pure $ CellData
    { cDuplicate = mult
    , cHorizAlign = halign
    , cVertAlign = valign
    , cColspan = colspan
    , cRowspan = rowspan
    , cStyle = sty
    }


--- Inline parsing:

pInlines :: P [Inline]
pInlines :: P [Inline]
pInlines = FilePath -> P [Inline]
pInlines' []

pComma :: P ()
pComma :: P ()
pComma = Char -> P ()
vchar Char
',' P () -> P () -> P ()
forall a b. P a -> P b -> P a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (Char -> Bool) -> P ()
skipWhile Char -> Bool
isSpace

pFormattedTextAttributes :: P Attr
pFormattedTextAttributes :: P Attr
pFormattedTextAttributes = do
  Char -> P ()
vchar Char
'['
  as <- P Attr
pShorthandAttributes
  ps <- option []
         (do unless (as == mempty) pComma
             sepBy1 pAttributeValue pComma <* option () pComma)
  vchar ']'
  if as == mempty
     then
       case ps of
         [] -> Attr -> P Attr
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Attr
forall a. Monoid a => a
mempty
         (Text
x:[Text]
_) -> Attr -> P Attr
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Attr -> P Attr) -> Attr -> P Attr
forall a b. (a -> b) -> a -> b
$ [Text] -> Map Text Text -> Attr
Attr [] ([(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Text
"role",Text
x)])
     else pure as

pAttributes :: P Attr
pAttributes :: P Attr
pAttributes = do
  Char -> P ()
vchar Char
'['
  (xs, as) <- ([Text], Attr) -> P ([Text], Attr) -> P ([Text], Attr)
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option ([], Attr
forall a. Monoid a => a
mempty) (P ([Text], Attr) -> P ([Text], Attr))
-> P ([Text], Attr) -> P ([Text], Attr)
forall a b. (a -> b) -> a -> b
$ do
    x <- (Char -> Bool) -> P Text
takeWhile (\Char
c -> Char -> Bool
isAlphaNum Char
c 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
'_')
    as <- pShorthandAttributes
    case as of
       Attr [] Map Text Text
m | Map Text Text -> Bool
forall k a. Map k a -> Bool
M.null Map Text Text
m -> P ([Text], Attr)
forall a. P a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
       Attr
_ -> ([Text], Attr) -> P ([Text], Attr)
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text
x | Bool -> Bool
not (Text -> Bool
T.null Text
x)] , Attr
as)
  bs <- option []
         (do unless (as == mempty) pComma
             sepBy pAttribute pComma <* option () pComma)
  vchar ']'
  let positional = [Text]
xs [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Either Text (Text, Text)] -> [Text]
forall a b. [Either a b] -> [a]
lefts [Either Text (Text, Text)]
bs
  let kvs = [Either Text (Text, Text)] -> [(Text, Text)]
forall a b. [Either a b] -> [b]
rights [Either Text (Text, Text)]
bs
  pure $ as <> Attr positional (M.fromList kvs)

pAttribute :: P (Either Text (Text,Text))
pAttribute :: P (Either Text (Text, Text))
pAttribute = ((Text, Text) -> Either Text (Text, Text)
forall a b. b -> Either a b
Right ((Text, Text) -> Either Text (Text, Text))
-> P (Text, Text) -> P (Either Text (Text, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P (Text, Text)
pKeyValue) P (Either Text (Text, Text))
-> P (Either Text (Text, Text)) -> P (Either Text (Text, Text))
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Text -> Either Text (Text, Text)
forall a b. a -> Either a b
Left (Text -> Either Text (Text, Text))
-> P Text -> P (Either Text (Text, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Text
pPositional)

pKeyValue :: P (Text, Text)
pKeyValue :: P (Text, Text)
pKeyValue = do
  k <- (Char -> Bool) -> P Text
takeWhile1 (\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
'=')
  vchar '=' *> ((k,) <$> pAttributeValue)

pPositional :: P Text
pPositional :: P Text
pPositional = do
  v <- P Text
pAttributeValue
  mbc <- peekChar
  case mbc of
    Just Char
',' -> () -> P ()
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Maybe Char
_ -> Bool -> P ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> P ()) -> Bool -> P ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Bool
T.null Text
v
  pure v

pAttributeValue :: P Text
pAttributeValue :: P Text
pAttributeValue = P Text
pQuotedAttr P Text -> P Text -> P Text
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P Text
pBareAttributeValue
 where
   pBareAttributeValue :: P Text
pBareAttributeValue =
     Text -> Text
T.strip (Text -> Text) -> P Text -> P Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> P Text
takeWhile (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
',' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
']')
   pQuotedAttr :: P Text
pQuotedAttr = do
     Char -> P ()
vchar Char
'"'
     result <- P Char -> P FilePath
forall a. P a -> P [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ((Char -> Bool) -> P Char
satisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'"') P Char -> P Char -> P Char
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char -> P ()
vchar Char
'\\' P () -> P Char -> P Char
forall a b. P a -> P b -> P b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> P Char
satisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'"')))
     vchar '"'
     pure $ T.pack result

pInlines' :: [Char] -> P [Inline]
pInlines' :: FilePath -> P [Inline]
pInlines' FilePath
cs = do
  (P ()
pLineComment P () -> P [Inline] -> P [Inline]
forall a b. P a -> P b -> P b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> FilePath -> P [Inline]
pInlines' FilePath
cs)
    P [Inline] -> P [Inline] -> P [Inline]
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (do il' <- FilePath -> P Inline
pInline FilePath
cs
            let il = case Inline
il' of
                       Inline (Attr [Text]
ps Map Text Text
kvs) (Span [Inline]
ils)
                         | Maybe Text
Nothing <- Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
"role" Map Text Text
kvs
                         -> Attr -> InlineType -> Inline
Inline ([Text] -> Map Text Text -> Attr
Attr [Text]
ps Map Text Text
kvs) ([Inline] -> InlineType
Highlight [Inline]
ils)
                       Inline
_ -> Inline
il'
            addStr . (il:) <$> pInlines' [])
    P [Inline] -> P [Inline] -> P [Inline]
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (do c <- P Char
anyChar
            pInlines' (c:cs))
    P [Inline] -> P [Inline] -> P [Inline]
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ([Inline] -> [Inline]
addStr [] [Inline] -> P () -> P [Inline]
forall a b. a -> P b -> P a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ P ()
endOfInput)
 where
  addStr :: [Inline] -> [Inline]
addStr = case FilePath
cs of
              [] -> [Inline] -> [Inline]
forall a. a -> a
id
              FilePath
_  -> (Attr -> InlineType -> Inline
Inline Attr
forall a. Monoid a => a
mempty (Text -> InlineType
Str (FilePath -> Text
T.pack (FilePath -> FilePath
replaceChars (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
forall a. [a] -> [a]
reverse FilePath
cs)))Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
:)

replaceChars :: [Char] -> [Char]
replaceChars :: FilePath -> FilePath
replaceChars [] = []
replaceChars (Char
'(':Char
'C':Char
')':FilePath
cs) = Char
'\169'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath -> FilePath
replaceChars FilePath
cs
replaceChars (Char
'(':Char
'R':Char
')':FilePath
cs) = Char
'\174'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath -> FilePath
replaceChars FilePath
cs
replaceChars (Char
'(':Char
'T':Char
'M':Char
')':FilePath
cs) = Char
'\8482'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath -> FilePath
replaceChars FilePath
cs
replaceChars (Char
x:Char
'-':Char
'-':Char
y:FilePath
cs)
  | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ', Char
y Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' = Char
'\8201'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:Char
'\8212'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:Char
'\8201'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath -> FilePath
replaceChars FilePath
cs
  | Char -> Bool
isAlphaNum Char
x, Char -> Bool
isAlphaNum Char
y = Char
xChar -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:Char
'\8212'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:Char
'\8203'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath -> FilePath
replaceChars (Char
yChar -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
cs)
  | Bool
otherwise = Char
xChar -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:Char
'-'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:Char
'-'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath -> FilePath
replaceChars (Char
yChar -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
cs)
replaceChars (Char
'.':Char
'.':Char
'.':FilePath
cs) = Char
'\8230'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath -> FilePath
replaceChars FilePath
cs
replaceChars (Char
'-':Char
'>':FilePath
cs) = Char
'\8594'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath -> FilePath
replaceChars FilePath
cs
replaceChars (Char
'=':Char
'>':FilePath
cs) = Char
'\8658'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath -> FilePath
replaceChars FilePath
cs
replaceChars (Char
'<':Char
'-':FilePath
cs) = Char
'\8592'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath -> FilePath
replaceChars FilePath
cs
replaceChars (Char
'<':Char
'=':FilePath
cs) = Char
'\8656'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath -> FilePath
replaceChars FilePath
cs
replaceChars (Char
'\'':FilePath
cs) = Char
'\8217'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath -> FilePath
replaceChars FilePath
cs
replaceChars (Char
c:FilePath
cs) = Char
cChar -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath -> FilePath
replaceChars FilePath
cs

pShorthandAttributes :: P Attr
pShorthandAttributes :: P Attr
pShorthandAttributes = do
  attr <- [Attr] -> Attr
forall a. Monoid a => [a] -> a
mconcat ([Attr] -> Attr) -> P [Attr] -> P Attr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
          P Attr -> P [Attr]
forall a. P a -> P [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ((Char -> Bool) -> P ()
skipWhile Char -> Bool
isSpace P () -> P Attr -> P Attr
forall a b. P a -> P b -> P b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
                ([Text] -> Map Text Text -> Attr
Attr [] (Map Text Text -> Attr)
-> ((Text, Text) -> Map Text Text) -> (Text, Text) -> Attr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text -> Map Text Text) -> (Text, Text) -> Map Text Text
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Text -> Map Text Text
forall k a. k -> a -> Map k a
M.singleton ((Text, Text) -> Attr) -> P (Text, Text) -> P Attr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P (Text, Text)
pShorthandAttribute))
  skipWhile isSpace
  pure attr

pShorthandAttribute :: P (Text,Text)
pShorthandAttribute :: P (Text, Text)
pShorthandAttribute = do
  let isSpecial :: Char -> Bool
isSpecial Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'#' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'%' Bool -> 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
','
  c <- (Char -> Bool) -> P Char
satisfy (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'#' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'%')
  val <- T.strip <$> takeWhile (not . isSpecial)
  key <- case c of
           Char
'.' -> Text -> P Text
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"role"
           Char
'#' -> Text -> P Text
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"id"
           Char
'%' -> Text -> P Text
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"options"
           Char
_ -> P Text
forall a. P a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  pure (key, val)

pInline :: [Char] -> P Inline
pInline :: FilePath -> P Inline
pInline FilePath
prevChars = do
  let maybeUnconstrained :: Bool
maybeUnconstrained = case FilePath
prevChars of
                              (Char
d:FilePath
_) -> Char -> Bool
isSpace Char
d Bool -> Bool -> Bool
|| Char -> Bool
isPunctuation Char
d Bool -> Bool -> Bool
|| Char
d Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'+'
                              [] -> Bool
True
  let inMatched :: Char -> Attr -> (Text -> P InlineType) -> P Inline
inMatched = Bool -> Char -> Attr -> (Text -> P InlineType) -> P Inline
pInMatched Bool
maybeUnconstrained
  (do attr <- P Attr
pFormattedTextAttributes P Attr -> P Attr -> P Attr
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Attr -> P Attr
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Attr
forall a. Monoid a => a
mempty
      c <- peekChar'
      case c of
        Char
'*' -> Char -> Attr -> (Text -> P InlineType) -> P Inline
inMatched Char
'*' Attr
attr (([Inline] -> InlineType) -> P [Inline] -> P InlineType
forall a b. (a -> b) -> P a -> P b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Inline] -> InlineType
Bold (P [Inline] -> P InlineType)
-> (Text -> P [Inline]) -> Text -> P InlineType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> P [Inline]
parseInlines)
        Char
'_' -> Char -> Attr -> (Text -> P InlineType) -> P Inline
inMatched Char
'_' Attr
attr (([Inline] -> InlineType) -> P [Inline] -> P InlineType
forall a b. (a -> b) -> P a -> P b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Inline] -> InlineType
Italic (P [Inline] -> P InlineType)
-> (Text -> P [Inline]) -> Text -> P InlineType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> P [Inline]
parseInlines)
        Char
'`' -> Char -> Attr -> (Text -> P InlineType) -> P Inline
inMatched Char
'`' Attr
attr (([Inline] -> InlineType) -> P [Inline] -> P InlineType
forall a b. (a -> b) -> P a -> P b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Inline] -> InlineType
Monospace (P [Inline] -> P InlineType)
-> (Text -> P [Inline]) -> Text -> P InlineType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> P [Inline]
parseInlines)
        Char
'#' -> Char -> Attr -> (Text -> P InlineType) -> P Inline
inMatched Char
'#' Attr
attr (([Inline] -> InlineType) -> P [Inline] -> P InlineType
forall a b. (a -> b) -> P a -> P b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Inline] -> InlineType
Span (P [Inline] -> P InlineType)
-> (Text -> P [Inline]) -> Text -> P InlineType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> P [Inline]
parseInlines)
        Char
'~' -> Char -> Attr -> (Text -> P InlineType) -> P Inline
pInSingleMatched Char
'~' Attr
attr (([Inline] -> InlineType) -> P [Inline] -> P InlineType
forall a b. (a -> b) -> P a -> P b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Inline] -> InlineType
Subscript (P [Inline] -> P InlineType)
-> (Text -> P [Inline]) -> Text -> P InlineType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> P [Inline]
parseInlines)
        Char
'^' -> Char -> Attr -> (Text -> P InlineType) -> P Inline
pInSingleMatched Char
'^' Attr
attr (([Inline] -> InlineType) -> P [Inline] -> P InlineType
forall a b. (a -> b) -> P a -> P b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Inline] -> InlineType
Superscript (P [Inline] -> P InlineType)
-> (Text -> P [Inline]) -> Text -> P InlineType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> P [Inline]
parseInlines)
        Char
'+' -> P Inline
pTriplePassthrough P Inline -> P Inline -> P Inline
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Attr -> (Text -> P InlineType) -> P Inline
inMatched Char
'+' Attr
attr (InlineType -> P InlineType
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InlineType -> P InlineType)
-> (Text -> InlineType) -> Text -> P InlineType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> InlineType
Str)
        Char
'"' -> Char -> Attr -> ([Inline] -> InlineType) -> P Inline
pQuoted Char
'"' Attr
attr [Inline] -> InlineType
DoubleQuoted
        Char
'\'' -> Char -> Attr -> ([Inline] -> InlineType) -> P Inline
pQuoted Char
'\'' Attr
attr [Inline] -> InlineType
SingleQuoted
        Char
'(' -> Attr -> P Inline
pIndexEntry Attr
attr
        Char
_ -> P Inline
forall a. P a
forall (m :: * -> *) a. MonadPlus m => m a
mzero)
     P Inline -> P Inline -> P Inline
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (do c <- P Char
peekChar'
             case c of
               Char
'\'' -> Char -> P Inline
pApostrophe Char
'\''
               Char
'+' -> P Inline
pHardBreak
               Char
'{' -> P Inline
pCounter P Inline -> P Inline -> P Inline
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P Inline
pAttributeReference
               Char
'\\' -> P Inline
pEscape
               Char
'<' -> P Inline
pBracedAutolink P Inline -> P Inline -> P Inline
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P Inline
pCrossReference
               Char
'&' -> P Inline
pCharacterReference
               Char
'[' -> P Inline
pBibAnchor P Inline -> P Inline -> P Inline
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P Inline
pInlineAnchor
               Char
_ | Char -> Bool
isLetter Char
c -> P Inline
pInlineMacro P Inline -> P Inline -> P Inline
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P Inline
pAutolink P Inline -> P Inline -> P Inline
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P Inline
pEmailAutolink
                 | Bool
otherwise -> P Inline
forall a. P a
forall (m :: * -> *) a. MonadPlus m => m a
mzero)

pIndexEntry :: Attr -> P Inline
pIndexEntry :: Attr -> P Inline
pIndexEntry Attr
attr = do
  P Text -> P ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (P Text -> P ()) -> P Text -> P ()
forall a b. (a -> b) -> a -> b
$ Text -> P Text
string Text
"(("
  concealed <- Bool -> P Bool -> P Bool
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option Bool
False (P Bool -> P Bool) -> P Bool -> P Bool
forall a b. (a -> b) -> a -> b
$ Bool
True Bool -> P () -> P Bool
forall a b. a -> P b -> P a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> P ()
vchar Char
'('
  terms <- takeWhile1 (/= ')')
  Inline attr <$>
    if concealed
       then IndexEntry (TermConcealed (map T.strip (T.split (==',') terms)))
                         <$ string ")))"
       else IndexEntry (TermInText terms) <$ string "))"

pTriplePassthrough :: P Inline
pTriplePassthrough :: P Inline
pTriplePassthrough = Attr -> InlineType -> Inline
Inline Attr
forall a. Monoid a => a
mempty (InlineType -> Inline)
-> (FilePath -> InlineType) -> FilePath -> Inline
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> InlineType
Passthrough (Text -> InlineType)
-> (FilePath -> Text) -> FilePath -> InlineType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack
    (FilePath -> Inline) -> P FilePath -> P Inline
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> P Text
string Text
"+++" P Text -> P FilePath -> P FilePath
forall a b. P a -> P b -> P b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> P Char -> P Text -> P FilePath
forall a b. P a -> P b -> P [a]
manyTill P Char
anyChar (Text -> P Text
string Text
"+++"))

pLineComment :: P ()
pLineComment :: P ()
pLineComment = Text -> P Text
string Text
"//" P Text -> P Char -> P Char
forall a b. P a -> P b -> P b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> P Char
satisfy (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\t') P Char -> P () -> P ()
forall a b. P a -> P b -> P b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> P Text -> P ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void P Text
pLine

pCrossReference :: P Inline
pCrossReference :: P Inline
pCrossReference = do
  P Text -> P ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (P Text -> P ()) -> P Text -> P ()
forall a b. (a -> b) -> a -> b
$ Text -> P Text
string Text
"<<"
  t <- FilePath -> Text
T.pack (FilePath -> Text) -> P FilePath -> P Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Char -> P () -> P FilePath
forall a b. P a -> P b -> P [a]
manyTill ((Char -> Bool) -> P Char
satisfy (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isEndOfLine)) (P Text -> P ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Text -> P Text
string Text
">>"))
  let ts = (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
',') Text
t
  case ts of
    [] -> P Inline
forall a. P a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    [Text
x] -> Inline -> P Inline
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Inline -> P Inline) -> Inline -> P Inline
forall a b. (a -> b) -> a -> b
$ Attr -> InlineType -> Inline
Inline Attr
forall a. Monoid a => a
mempty (InlineType -> Inline) -> InlineType -> Inline
forall a b. (a -> b) -> a -> b
$ Text -> Maybe [Inline] -> InlineType
CrossReference Text
x Maybe [Inline]
forall a. Maybe a
Nothing
    (Text
x:[Text]
xs) -> Attr -> InlineType -> Inline
Inline Attr
forall a. Monoid a => a
mempty (InlineType -> Inline)
-> ([Inline] -> InlineType) -> [Inline] -> Inline
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe [Inline] -> InlineType
CrossReference Text
x (Maybe [Inline] -> InlineType)
-> ([Inline] -> Maybe [Inline]) -> [Inline] -> InlineType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Inline] -> Maybe [Inline]
forall a. a -> Maybe a
Just
                       ([Inline] -> Inline) -> P [Inline] -> P Inline
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> P [Inline]
parseInlines (Text -> [Text] -> Text
T.intercalate Text
"," [Text]
xs)

data MatchState = Backslash | OneDelim | Regular
  deriving Int -> MatchState -> FilePath -> FilePath
[MatchState] -> FilePath -> FilePath
MatchState -> FilePath
(Int -> MatchState -> FilePath -> FilePath)
-> (MatchState -> FilePath)
-> ([MatchState] -> FilePath -> FilePath)
-> Show MatchState
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> MatchState -> FilePath -> FilePath
showsPrec :: Int -> MatchState -> FilePath -> FilePath
$cshow :: MatchState -> FilePath
show :: MatchState -> FilePath
$cshowList :: [MatchState] -> FilePath -> FilePath
showList :: [MatchState] -> FilePath -> FilePath
Show

-- used for super/subscript, which can't accept spaces but take single delims
pInSingleMatched :: Char -> Attr -> (Text -> P InlineType) -> P Inline
pInSingleMatched :: Char -> Attr -> (Text -> P InlineType) -> P Inline
pInSingleMatched Char
delim Attr
attr Text -> P InlineType
toInlineType = do
  Char -> P ()
vchar Char
delim
  cs <- P Char -> P () -> P FilePath
forall a b. P a -> P b -> P [a]
manyTill ((Char -> Bool) -> P Char
satisfy (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace)) (Char -> P ()
vchar Char
delim)
  guard $ not $ null cs
  Inline attr <$> toInlineType (T.pack cs)

pInMatched :: Bool -> Char -> Attr -> (Text -> P InlineType) -> P Inline
pInMatched :: Bool -> Char -> Attr -> (Text -> P InlineType) -> P Inline
pInMatched Bool
maybeUnconstrained Char
delim Attr
attr Text -> P InlineType
toInlineType = do
  Char -> P ()
vchar Char
delim
  isDoubled <- Bool -> P Bool -> P Bool
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option Bool
False (Bool
True Bool -> P () -> P Bool
forall a b. a -> P b -> P a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> P ()
vchar Char
delim)
  followedBySpace <- maybe True isSpace <$> peekChar
  guard $ isDoubled || (maybeUnconstrained && not followedBySpace)
  cs <- manyTill ( (vchar '\\' *> char delim) <|> anyChar )
                   (if isDoubled
                       then vchar delim *> vchar delim
                       else vchar delim)
  guard $ not $ null cs
  when (not isDoubled && maybeUnconstrained) $ do
    mbc <- peekChar
    case mbc of
      Maybe Char
Nothing -> () -> P ()
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just Char
c -> Bool -> P ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> P ()) -> Bool -> P ()
forall a b. (a -> b) -> a -> b
$ Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
|| Char -> Bool
isPunctuation Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'+'
  Inline attr <$> toInlineType (T.pack cs)

pInlineAnchor :: P Inline
pInlineAnchor :: P Inline
pInlineAnchor = do
  P Text -> P ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (P Text -> P ()) -> P Text -> P ()
forall a b. (a -> b) -> a -> b
$ Text -> P Text
string Text
"[["
  contents <- FilePath -> Text
T.pack (FilePath -> Text) -> P FilePath -> P Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Char -> P Text -> P FilePath
forall a b. P a -> P b -> P [a]
manyTill P Char
anyChar (Text -> P Text
string Text
"]]")
  let (anchorId, xrefLabel) =
        case T.split (==',') contents of
          [] -> (Text
forall a. Monoid a => a
mempty, Text
forall a. Monoid a => a
mempty)
          (Text
x:[Text]
ys) -> (Text
x, [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [Text]
ys)
  Inline mempty . InlineAnchor anchorId <$> parseInlines xrefLabel

pBibAnchor :: P Inline
pBibAnchor :: P Inline
pBibAnchor = do
  P Text -> P ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (P Text -> P ()) -> P Text -> P ()
forall a b. (a -> b) -> a -> b
$ Text -> P Text
string Text
"[[["
  contents <- FilePath -> Text
T.pack (FilePath -> Text) -> P FilePath -> P Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Char -> P Text -> P FilePath
forall a b. P a -> P b -> P [a]
manyTill P Char
anyChar (Text -> P Text
string Text
"]]]")
  let (anchorId, xrefLabel) =
        case T.split (==',') contents of
          [] -> (Text
forall a. Monoid a => a
mempty, Text
forall a. Monoid a => a
mempty)
          (Text
x:[Text]
ys) -> (Text
x, [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [Text]
ys)
  skipWhile (== ' ')
  Inline mempty . BibliographyAnchor anchorId <$> parseInlines xrefLabel

pCharacterReference :: P Inline
pCharacterReference :: P Inline
pCharacterReference =
  Char -> P ()
vchar Char
'&' P () -> P Inline -> P Inline
forall a b. P a -> P b -> P b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (P Inline
pNumericCharacterReference P Inline -> P Inline -> P Inline
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P Inline
pCharacterEntityReference)

pNumericCharacterReference :: P Inline
pNumericCharacterReference :: P Inline
pNumericCharacterReference =
  Char -> P ()
vchar Char
'#' P () -> P Inline -> P Inline
forall a b. P a -> P b -> P b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (((Char -> P ()
vchar Char
'x' P () -> P () -> P ()
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> P ()
vchar Char
'X') P () -> P Inline -> P Inline
forall a b. P a -> P b -> P b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> P Inline
pHexReference) P Inline -> P Inline -> P Inline
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P Inline
pDecimalReference)
 where
  pHexReference :: P Inline
pHexReference =
    Attr -> InlineType -> Inline
Inline Attr
forall a. Monoid a => a
mempty (InlineType -> Inline) -> (Int -> InlineType) -> Int -> Inline
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> InlineType
Str (Text -> InlineType) -> (Int -> Text) -> Int -> InlineType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
T.singleton (Char -> Text) -> (Int -> Char) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Char
chr (Int -> Inline) -> P Int -> P Inline
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser Int -> P Int
forall a. Parser a -> P a
liftP Parser Int
forall a. (Integral a, Bits a) => Parser a
A.hexadecimal P Int -> P () -> P Int
forall a b. P a -> P b -> P a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> P ()
vchar Char
';')
  pDecimalReference :: P Inline
pDecimalReference =
    Attr -> InlineType -> Inline
Inline Attr
forall a. Monoid a => a
mempty (InlineType -> Inline) -> (Int -> InlineType) -> Int -> Inline
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> InlineType
Str (Text -> InlineType) -> (Int -> Text) -> Int -> InlineType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
T.singleton (Char -> Text) -> (Int -> Char) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Char
chr (Int -> Inline) -> P Int -> P Inline
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (P Int
forall a. Integral a => P a
decimal P Int -> P () -> P Int
forall a b. P a -> P b -> P a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> P ()
vchar Char
';')

pCharacterEntityReference :: P Inline
pCharacterEntityReference :: P Inline
pCharacterEntityReference = do
  xs <- P Char -> P Char -> P FilePath
forall a b. P a -> P b -> P [a]
manyTill ((Char -> Bool) -> P Char
satisfy Char -> Bool
isAlphaNum) (Char -> P Char
char Char
';' P Char -> P Char -> P Char
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P Char
space)
  case lookupNamedEntity xs of
    Just FilePath
s -> Inline -> P Inline
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Inline -> P Inline) -> Inline -> P Inline
forall a b. (a -> b) -> a -> b
$ Attr -> InlineType -> Inline
Inline Attr
forall a. Monoid a => a
mempty (Text -> InlineType
Str (FilePath -> Text
T.pack FilePath
s))
    Maybe FilePath
Nothing -> P Inline
forall a. P a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

pQuoted :: Char -> Attr -> ([Inline] -> InlineType) -> P Inline
pQuoted :: Char -> Attr -> ([Inline] -> InlineType) -> P Inline
pQuoted Char
c Attr
attr [Inline] -> InlineType
constructor = do
  Char -> P ()
vchar Char
c
  result <- Bool -> Char -> Attr -> (Text -> P InlineType) -> P Inline
pInMatched Bool
True Char
'`' Attr
attr (([Inline] -> InlineType) -> P [Inline] -> P InlineType
forall a b. (a -> b) -> P a -> P b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Inline] -> InlineType
constructor (P [Inline] -> P InlineType)
-> (Text -> P [Inline]) -> Text -> P InlineType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> P [Inline]
parseInlines)
  vchar c
  return result

pApostrophe :: Char -> P Inline
pApostrophe :: Char -> P Inline
pApostrophe Char
'`' = Attr -> InlineType -> Inline
Inline Attr
forall a. Monoid a => a
mempty (Text -> InlineType
Str Text
"’") Inline -> P Text -> P Inline
forall a b. a -> P b -> P a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> P Text
string Text
"`'"
pApostrophe Char
_ = P Inline
forall a. P a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

pInlineMacro :: P Inline
pInlineMacro :: P Inline
pInlineMacro = do
  name <- [P Text] -> P Text
forall a. [P a] -> P a
choice ((Text -> P Text) -> [Text] -> [P Text]
forall a b. (a -> b) -> [a] -> [b]
map (\Text
n -> Text -> P Text
string Text
n P Text -> P () -> P Text
forall a b. P a -> P b -> P a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> P ()
vchar Char
':') (Map Text (Text -> P Inline) -> [Text]
forall k a. Map k a -> [k]
M.keys Map Text (Text -> P Inline)
inlineMacros))
  let targetChars = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> P [Text] -> P Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Text -> P [Text]
forall a. P a -> P [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some
       ( (Text -> P Text
string Text
"pass:" P Text -> P () -> P ()
forall a b. P a -> P b -> P b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> P ()
vchar Char
'[' P () -> P Text -> P Text
forall a b. P a -> P b -> P b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> P Text
takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
']') P Text -> P () -> P Text
forall a b. P a -> P b -> P a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> P ()
vchar Char
']')
         P Text -> P Text -> P Text
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
         (Char -> Bool) -> P Text
takeWhile1 (\Char
c -> Bool -> Bool
not (Char -> Bool
isSpace Char
c) 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 Text -> P Text -> P Text
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
         (Char -> P ()
vchar Char
'\\' P () -> P Text -> P Text
forall a b. P a -> P b -> P b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Text
T.singleton (Char -> Text) -> P Char -> P Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> P Char
satisfy (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'[' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'+')))
         P Text -> P Text -> P Text
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
        (do Inline _ (Str t) <- Bool -> Char -> Attr -> (Text -> P InlineType) -> P Inline
pInMatched Bool
False Char
'+' Attr
forall a. Monoid a => a
mempty (InlineType -> P InlineType
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InlineType -> P InlineType)
-> (Text -> InlineType) -> Text -> P InlineType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> InlineType
Str)
            pure t)
       )
  target <- mconcat <$> many targetChars
  handleInlineMacro name target

handleInlineMacro :: Text -> Text -> P Inline
handleInlineMacro :: Text -> Text -> P Inline
handleInlineMacro Text
name Text
target =
  case Text -> Map Text (Text -> P Inline) -> Maybe (Text -> P Inline)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
name Map Text (Text -> P Inline)
inlineMacros of
    Maybe (Text -> P Inline)
Nothing -> P Inline
forall a. P a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    Just Text -> P Inline
f -> Text -> P Inline
f Text
target

inlineMacros :: M.Map Text (Text -> P Inline)
inlineMacros :: Map Text (Text -> P Inline)
inlineMacros = [(Text, Text -> P Inline)] -> Map Text (Text -> P Inline)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
  [ (Text
"kbd", \Text
_ -> do
       attr <- P Attr
pAttributes
       let (description, attr') = extractDescription attr
       pure $ Inline attr' $ Kbd (map T.strip (T.split (=='+') description)))
  , (Text
"menu", \Text
target -> do
       attr <- P Attr
pAttributes
       let (description, attr') = extractDescription attr
       pure $ Inline attr' $ Menu (target : filter (not . T.null)
                                    (map T.strip (T.split (=='>') description))))
  , (Text
"btn", \Text
_ -> do
       attr <- P Attr
pAttributes
       let (description, attr') = extractDescription attr
       pure $ Inline attr' $ Button description)
  , (Text
"icon", \Text
target -> do
        attr <- P Attr
pAttributes
        pure $ Inline attr $ Icon target)
  , (Text
"anchor", \Text
target -> do
        attr <- P Attr
pAttributes
        let (anchorId, xrefLabel) =
              case T.split (==',') target of
                [] -> (Text
forall a. Monoid a => a
mempty, Text
forall a. Monoid a => a
mempty)
                (Text
x:[Text]
ys) -> (Text
x, [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [Text]
ys)
        Inline attr . InlineAnchor anchorId <$> parseInlines xrefLabel)
  , (Text
"pass", \Text
_ -> do
       attr <- P Attr
pAttributes
       let (description, attr') = extractDescription attr
       pure $ Inline attr' $ Passthrough description)
  , (Text
"link", \Text
target -> do
      attr <- P Attr
pAttributes
      let (description, attr') = extractDescription attr
      Inline attr' . Link URLLink (Target target)
          <$> (if T.null description
                  then pure [Inline mempty (Str target)]
                  else parseInlines description))
  , (Text
"mailto", \Text
target -> do
      attr <- P Attr
pAttributes
      let (description, attr') = extractDescription attr
      Inline attr' . Link EmailLink (Target target)
             <$> if T.null description
                    then pure [Inline mempty (Str target)]
                    else parseInlines description)
  , (Text
"footnote", \Text
target -> do
      ils <- P Text
pBracketedText P Text -> (Text -> P [Inline]) -> P [Inline]
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> P [Inline]
parseInlines
      let fnid = if Text
target Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
forall a. Monoid a => a
mempty
                    then Maybe FootnoteId
forall a. Maybe a
Nothing
                    else FootnoteId -> Maybe FootnoteId
forall a. a -> Maybe a
Just (Text -> FootnoteId
FootnoteId Text
target)
      pure $ Inline mempty (Footnote fnid ils))
  , (Text
"footnoteref", \Text
_ -> do
      (Attr ps kvs) <- P Attr
pAttributes
      (target, contents) <- case ps of
                                 (Text
t:Text
c:[Text]
_) -> (Text, Text) -> P (Text, Text)
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
t,Text
c)
                                 [Text
t] -> (Text, Text) -> P (Text, Text)
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
t,Text
forall a. Monoid a => a
mempty)
                                 [Text]
_ -> P (Text, Text)
forall a. P a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      let fnid = if Text
target Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
forall a. Monoid a => a
mempty
                  then Maybe FootnoteId
forall a. Maybe a
Nothing
                  else FootnoteId -> Maybe FootnoteId
forall a. a -> Maybe a
Just (Text -> FootnoteId
FootnoteId Text
target)
      Inline (Attr mempty kvs) . Footnote fnid <$> parseInlines contents)
  , (Text
"xref", \Text
target -> do
        ils <- P Text
pBracketedText P Text -> (Text -> P [Inline]) -> P [Inline]
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> P [Inline]
parseInlines
        let mbtext = if [Inline] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Inline]
ils then Maybe [Inline]
forall a. Maybe a
Nothing else [Inline] -> Maybe [Inline]
forall a. a -> Maybe a
Just [Inline]
ils
        pure $ Inline mempty $ CrossReference target mbtext)
  , (Text
"image", \Text
target -> do
        (Attr ps kvs) <- P Attr
pAttributes
        let (mbalt, mbw, mbh) =
              case ps of
                (Text
x:Text
y:Text
z:[Text]
_) -> (AltText -> Maybe AltText
forall a. a -> Maybe a
Just (Text -> AltText
AltText Text
x), Int -> Width
Width (Int -> Width) -> Maybe Int -> Maybe Width
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe Int
readDecimal Text
y,
                              Int -> Height
Height (Int -> Height) -> Maybe Int -> Maybe Height
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe Int
readDecimal Text
z)
                [Text
x,Text
y] -> (AltText -> Maybe AltText
forall a. a -> Maybe a
Just (Text -> AltText
AltText Text
x), Int -> Width
Width (Int -> Width) -> Maybe Int -> Maybe Width
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe Int
readDecimal Text
y, Maybe Height
forall a. Maybe a
Nothing)
                [Text
x] -> (AltText -> Maybe AltText
forall a. a -> Maybe a
Just (Text -> AltText
AltText Text
x), Maybe Width
forall a. Maybe a
Nothing, Maybe Height
forall a. Maybe a
Nothing)
                [] -> (Maybe AltText
forall a. Maybe a
Nothing, Maybe Width
forall a. Maybe a
Nothing, Maybe Height
forall a. Maybe a
Nothing)
        pure $ Inline (Attr mempty kvs) $ InlineImage (Target target) mbalt mbw mbh)
  , (Text
"latexmath", \Text
_ ->
      Attr -> InlineType -> Inline
Inline Attr
forall a. Monoid a => a
mempty (InlineType -> Inline) -> (Text -> InlineType) -> Text -> Inline
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe MathType -> Text -> InlineType
Math (MathType -> Maybe MathType
forall a. a -> Maybe a
Just MathType
LaTeXMath) (Text -> Inline) -> P Text -> P Inline
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Text
pBracketedText)
  , (Text
"asciimath", \Text
_ ->
      Attr -> InlineType -> Inline
Inline Attr
forall a. Monoid a => a
mempty (InlineType -> Inline) -> (Text -> InlineType) -> Text -> Inline
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe MathType -> Text -> InlineType
Math (MathType -> Maybe MathType
forall a. a -> Maybe a
Just MathType
AsciiMath) (Text -> Inline) -> P Text -> P Inline
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Text
pBracketedText)
  , (Text
"stem", \Text
_ ->
      Attr -> InlineType -> Inline
Inline Attr
forall a. Monoid a => a
mempty (InlineType -> Inline) -> (Text -> InlineType) -> Text -> Inline
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe MathType -> Text -> InlineType
Math Maybe MathType
forall a. Maybe a
Nothing (Text -> Inline) -> P Text -> P Inline
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Text
pBracketedText)
  , (Text
"indexterm", \Text
_ ->
      Attr -> InlineType -> Inline
Inline Attr
forall a. Monoid a => a
mempty (InlineType -> Inline) -> (Text -> InlineType) -> Text -> Inline
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IndexTerm -> InlineType
IndexEntry (IndexTerm -> InlineType)
-> (Text -> IndexTerm) -> Text -> InlineType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> IndexTerm
TermConcealed ([Text] -> IndexTerm) -> (Text -> [Text]) -> Text -> IndexTerm
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
T.strip ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
',') (Text -> Inline) -> P Text -> P Inline
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Text
pBracketedText)
  , (Text
"indexterm2", \Text
_ ->
      Attr -> InlineType -> Inline
Inline Attr
forall a. Monoid a => a
mempty (InlineType -> Inline) -> (Text -> InlineType) -> Text -> Inline
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IndexTerm -> InlineType
IndexEntry (IndexTerm -> InlineType)
-> (Text -> IndexTerm) -> Text -> InlineType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IndexTerm
TermInText (Text -> Inline) -> P Text -> P Inline
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Text
pBracketedText)
  ]

pBracketedText :: P Text
pBracketedText :: P Text
pBracketedText =
  Char -> P ()
vchar Char
'[' P () -> P Text -> P Text
forall a b. P a -> P b -> P b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
    ([Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> P [Text] -> P Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Text -> P [Text]
forall a. P a -> P [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many
         (FilePath -> Text
T.pack (FilePath -> Text) -> P FilePath -> P Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Char -> P FilePath
forall a. P a -> P [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ((Char -> P ()
vchar Char
'\\' P () -> P Char -> P Char
forall a b. P a -> P b -> P b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> P Char
char Char
']') P Char -> P Char -> P Char
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                           (Char -> P ()
vchar Char
'+' P () -> P () -> P ()
forall a b. P a -> P b -> P b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> P ()
vchar Char
'+' P () -> P Char -> P Char
forall a b. P a -> P b -> P b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> P Char
char Char
']'
                             P Char -> P () -> P Char
forall a b. P a -> P b -> P a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> P ()
vchar Char
'+' P Char -> P () -> P Char
forall a b. P a -> P b -> P a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> P ()
vchar Char
'+') P Char -> P Char -> P Char
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                 (Char -> Bool) -> P Char
satisfy (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
']' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'[' Bool -> Bool -> Bool
&& Bool -> Bool
not (Char -> Bool
isEndOfLine Char
c)) P Char -> P Char -> P Char
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                 (Char
' ' Char -> P () -> P Char
forall a b. a -> P b -> P a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Char -> P ()
vchar Char
'\\' P () -> P () -> P ()
forall a b. P a -> P b -> P a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* P ()
endOfLine)))
          P Text -> P Text -> P Text
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((\Text
x -> Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]") (Text -> Text) -> P Text -> P Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Text
pBracketedText)))
    P Text -> P () -> P Text
forall a b. P a -> P b -> P a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> P ()
vchar Char
']'

extractDescription :: Attr -> (Text, Attr)
extractDescription :: Attr -> (Text, Attr)
extractDescription (Attr [Text]
ps Map Text Text
kvs) =
  let description :: Text
description = case [Text]
ps of
                      (Text
x:[Text]
_) -> Text
x
                      [Text]
_ -> Text
""
  in (Text
description, [Text] -> Map Text Text -> Attr
Attr (Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop Int
1 [Text]
ps) Map Text Text
kvs)


pEmailAutolink :: P Inline
pEmailAutolink :: P Inline
pEmailAutolink = do
  a <- (Char -> Bool) -> P Text
takeWhile1 (\Char
c -> Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'+')
  vchar '@'
  b <- takeWhile1 isLetter
  vchar '.'
  c <- takeWhile1 isLetter
  guard $ let lc = Text -> Int
T.length Text
c in lc >= 2 && lc <= 5
  let email = Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c
  attr <- pAttributes <|> pure mempty
  let (description, attr') = extractDescription attr
  Inline attr' . Link EmailLink (Target email)
           <$> if T.null description
                  then pure [Inline mempty (Str email)]
                  else parseInlines description

pAutolink :: P Inline
pAutolink :: P Inline
pAutolink = do
  scheme <- [P Text] -> P Text
forall a. [P a] -> P a
choice ((Text -> P Text) -> [Text] -> [P Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> P Text
string
               [Text
"http:", Text
"https:", Text
"irc:", Text
"ftp:", Text
"mailto:"])
  let isSpecialPunct Char
',' = Bool
True
      isSpecialPunct Char
'.' = Bool
True
      isSpecialPunct Char
'?' = Bool
True
      isSpecialPunct Char
'!' = Bool
True
      isSpecialPunct Char
':' = Bool
True
      isSpecialPunct Char
';' = Bool
True
      isSpecialPunct Char
')' = Bool
True
      isSpecialPunct Char
_ = Bool
False
  let urlChunk = FilePath -> Text
T.pack (FilePath -> Text) -> P FilePath -> P Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        P Char -> P FilePath
forall a. P a -> P [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ((Char -> Bool) -> P Char
satisfy (\Char
c -> Bool -> Bool
not (Char -> Bool
isSpace Char
c) Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'[' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'>'
                               Bool -> Bool -> Bool
&& Bool -> Bool
not (Char -> Bool
isSpecialPunct Char
c))
             P Char -> P Char -> P Char
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (do c <- (Char -> Bool) -> P Char
satisfy Char -> Bool
isSpecialPunct
                     mbd <- peekChar
                     case mbd of
                       Maybe Char
Nothing -> P Char
forall a. P a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
                       Just Char
d | Char -> Bool
isSpace Char
d Bool -> Bool -> Bool
|| Char -> Bool
isSpecialPunct Char
d -> P Char
forall a. P a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
                       Maybe Char
_ -> Char -> P Char
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
c))
  url <- (scheme <>) . mconcat <$> some
          (urlChunk <|> (do Inline _ (Str t) <- pInMatched False '+' mempty (pure . Str)
                            pure t))
  attr <- pAttributes <|> pure mempty
  let (description, attr') = extractDescription attr
  Inline attr' . Link URLLink (Target url)
             <$> if T.null description
                    then pure [Inline mempty (Str url)]
                    else parseInlines description

pBracedAutolink :: P Inline
pBracedAutolink :: P Inline
pBracedAutolink = Char -> P ()
vchar Char
'<' P () -> P Inline -> P Inline
forall a b. P a -> P b -> P b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> P Inline
pAutolink P Inline -> P () -> P Inline
forall a b. P a -> P b -> P a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> P ()
vchar Char
'>'

pEscape :: P Inline
pEscape :: P Inline
pEscape =
  -- we allow letters to be escaped to handle escapes of macros
  -- though this also leads to differences from asciidoc
  Char -> P ()
vchar Char
'\\' P () -> P Inline -> P Inline
forall a b. P a -> P b -> P b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
   (Attr -> InlineType -> Inline
Inline Attr
forall a. Monoid a => a
mempty (InlineType -> Inline) -> (Char -> InlineType) -> Char -> Inline
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> InlineType
Str (Text -> InlineType) -> (Char -> Text) -> Char -> InlineType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
T.singleton (Char -> Inline) -> P Char -> P Inline
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      (Char -> Bool) -> P Char
satisfy (\Char
c -> Char -> Bool
isPunctuation Char
c Bool -> Bool -> Bool
|| Char -> Bool
isLetter Char
c))

pCounter :: P Inline
pCounter :: P Inline
pCounter = do
  Char -> P ()
vchar Char
'{' P () -> P Text -> P ()
forall a b. P a -> P b -> P a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> P Text
string Text
"counter:"
  name <- P Text
pDocAttributeName
  mbvalue <- optional (vchar ':' *> pCounterValue)
  vchar '}'
  cmap <- gets counterMap
  let (ctype, val) =
        case M.lookup name cmap of
          Just (CounterType
ctype', Int
val') -> (CounterType
ctype', Int
val' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
          Maybe (CounterType, Int)
Nothing ->
            case Maybe (CounterType, Int)
mbvalue of
              Maybe (CounterType, Int)
Nothing -> (CounterType
DecimalCounter, Int
1)
              Just (CounterType
ctype', Int
val') -> (CounterType
ctype', Int
val')
  modify $ \ParserState
st -> ParserState
st{ counterMap =
                       M.insert name (ctype, val) (counterMap st) }
  pure $ Inline mempty $ Counter name ctype val

pCounterValue :: P (CounterType, Int)
pCounterValue :: P (CounterType, Int)
pCounterValue = P (CounterType, Int)
pUpperValue P (CounterType, Int)
-> P (CounterType, Int) -> P (CounterType, Int)
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P (CounterType, Int)
pLowerValue P (CounterType, Int)
-> P (CounterType, Int) -> P (CounterType, Int)
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P (CounterType, Int)
pDecimalValue
 where
   pUpperValue :: P (CounterType, Int)
pUpperValue = do
     c <- (Char -> Bool) -> P Char
satisfy (\Char
c -> Char -> Bool
isAscii Char
c Bool -> Bool -> Bool
&& Char -> Bool
isUpper Char
c)
     pure (UpperAlphaCounter, 1 + (ord c - ord 'A'))
   pLowerValue :: P (CounterType, Int)
pLowerValue = do
     c <- (Char -> Bool) -> P Char
satisfy (\Char
c -> Char -> Bool
isAscii Char
c Bool -> Bool -> Bool
&& Char -> Bool
isLower Char
c)
     pure (UpperAlphaCounter, 1 + (ord c - ord 'a'))
   pDecimalValue :: P (CounterType, Int)
pDecimalValue = do
     n <- P Int
forall a. Integral a => P a
decimal
     pure (DecimalCounter, n)

pAttributeReference :: P Inline
pAttributeReference :: P Inline
pAttributeReference = do
  Char -> P ()
vchar Char
'{'
  name <- P Text
pDocAttributeName
  vchar '}'
  case M.lookup name replacements of
    Just Text
r -> Inline -> P Inline
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Inline -> P Inline) -> Inline -> P Inline
forall a b. (a -> b) -> a -> b
$ Attr -> InlineType -> Inline
Inline Attr
forall a. Monoid a => a
mempty (Text -> InlineType
Str Text
r)
    Maybe Text
Nothing -> Inline -> P Inline
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Inline -> P Inline) -> Inline -> P Inline
forall a b. (a -> b) -> a -> b
$ Attr -> InlineType -> Inline
Inline Attr
forall a. Monoid a => a
mempty (InlineType -> Inline) -> InlineType -> Inline
forall a b. (a -> b) -> a -> b
$ AttributeName -> InlineType
AttributeReference (Text -> AttributeName
AttributeName Text
name)

replacements :: M.Map Text Text
replacements :: Map Text Text
replacements = [(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
  [ (Text
"blank", Text
"")
  , (Text
"empty", Text
"")
  , (Text
"sp", Text
" ")
  , (Text
"nbsp", Text
"\160")
  , (Text
"zwsp", Text
"\8203")
  , (Text
"wj", Text
"\8288")
  , (Text
"apos", Text
"\39")
  , (Text
"lsquo", Text
"\8216")
  , (Text
"rsquo", Text
"\8217")
  , (Text
"ldquo", Text
"\8220")
  , (Text
"rdquo", Text
"\8221")
  , (Text
"deg", Text
"\176")
  , (Text
"plus", Text
"+")
  , (Text
"brvbar", Text
"\166")
  , (Text
"vbar", Text
"|")
  , (Text
"amp", Text
"&")
  , (Text
"lt", Text
"<")
  , (Text
"gt", Text
">")
  , (Text
"startsb", Text
"[")
  , (Text
"endsb", Text
"]")
  , (Text
"caret", Text
"^")
  , (Text
"asterisk", Text
"*")
  , (Text
"tilde", Text
"~")
  , (Text
"backslash", Text
"\\")
  , (Text
"backtick", Text
"`")
  , (Text
"two-colons", Text
"::")
  , (Text
"two-semicolons", Text
";;")
  , (Text
"cpp", Text
"C++")
  , (Text
"cxx", Text
"C++")
  , (Text
"pp", Text
"++")
  ]

pHardBreak :: P Inline
pHardBreak :: P Inline
pHardBreak = do
  Char -> P ()
vchar Char
'+'
  _ <- (Char -> Bool) -> P Text
takeWhile1 (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\r' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n')
  pure $ Inline mempty HardBreak

--- Utility functions:

readDecimal :: Text -> Maybe Int
readDecimal :: Text -> Maybe Int
readDecimal Text
t =
  case Reader Int
forall a. Integral a => Reader a
TR.decimal Text
t of
    Left FilePath
_ -> Maybe Int
forall a. Maybe a
Nothing
    Right (Int
x,Text
_) -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
x

notFollowedBy :: P a -> P ()
notFollowedBy :: forall a. P a -> P ()
notFollowedBy P a
p = P a -> P (Maybe a)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional P a
p P (Maybe a) -> (Maybe a -> P ()) -> P ()
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> P ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> P ()) -> (Maybe a -> Bool) -> Maybe a -> P ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> Bool
forall a. Maybe a -> Bool
isNothing

-- Generate auto-identifiers for sections.

addIdentifiers :: Document -> Document
addIdentifiers :: Document -> Document
addIdentifiers Document
doc =
  case Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
"sectids" Map Text Text
docattr of
    Just Text
_ -> State (Map Text Int) Document -> Map Text Int -> Document
forall s a. State s a -> s -> a
evalState ((Block -> StateT (Map Text Int) Identity Block)
-> Document -> State (Map Text Int) Document
forall a (m :: * -> *).
(HasBlocks a, Monad m) =>
(Block -> m Block) -> a -> m a
forall (m :: * -> *).
Monad m =>
(Block -> m Block) -> Document -> m Document
mapBlocks (Text -> Text -> Block -> StateT (Map Text Int) Identity Block
addIdentifier Text
prefix Text
idsep) Document
doc) Map Text Int
forall a. Monoid a => a
mempty
    Maybe Text
Nothing -> Document
doc
 where
  docattr :: Map Text Text
docattr = Meta -> Map Text Text
docAttributes (Document -> Meta
docMeta Document
doc)
  prefix :: Text
prefix = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"_" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
"idprefix" Map Text Text
docattr
  idsep :: Text
idsep = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"_" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
"idseparator" Map Text Text
docattr

addIdentifier :: Text -> Text -> Block -> State (M.Map Text Int) Block
addIdentifier :: Text -> Text -> Block -> StateT (Map Text Int) Identity Block
addIdentifier Text
prefix Text
idsep (Block (Attr [Text]
ps Map Text Text
kvs) Maybe BlockTitle
mbtitle (Section Level
lev [Inline]
ils [Block]
bs))
  | Maybe Text
Nothing <- Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
"id" Map Text Text
kvs
  = do
      usedIds <- StateT (Map Text Int) Identity (Map Text Int)
forall s (m :: * -> *). MonadState s m => m s
get
      let (ident, usedIds') = generateIdentifier prefix idsep usedIds ils
      put usedIds'
      pure $ Block (Attr ps (M.insert "id" ident kvs)) mbtitle
                     (Section lev ils bs)
addIdentifier Text
_ Text
_ Block
x = Block -> StateT (Map Text Int) Identity Block
forall a. a -> StateT (Map Text Int) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Block
x

generateIdentifier :: Text -> Text -> M.Map Text Int -> [Inline]
                   -> (Text, M.Map Text Int)
generateIdentifier :: Text -> Text -> Map Text Int -> [Inline] -> (Text, Map Text Int)
generateIdentifier Text
prefix Text
idsep Map Text Int
usedIds [Inline]
ils =
  case Text -> Map Text Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
s Map Text Int
usedIds of
    Maybe Int
Nothing -> (Text
s, Text -> Int -> Map Text Int -> Map Text Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
s Int
1 Map Text Int
usedIds)
    Just Int
n -> (Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
idsep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)), Text -> Int -> Map Text Int -> Map Text Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
s (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Map Text Int
usedIds)
 where
  s :: Text
s = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
makeSeps (Text -> Text
T.toLower ([Inline] -> Text
toString [Inline]
ils))
  makeSeps :: Text -> Text
makeSeps = Text -> [Text] -> Text
T.intercalate Text
idsep ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.words (Text -> [Text]) -> (Text -> Text) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
               (Char -> Char) -> Text -> Text
T.map (\case
                       Char
'.' -> Char
' '
                       Char
'-' -> Char
' '
                       Char
c | Char -> Bool
isSpace Char
c -> Char
' '
                         | Bool
otherwise -> Char
c)
  toString :: [Inline] -> Text
toString = (Inline -> Text) -> [Inline] -> Text
forall m. Monoid m => (Inline -> m) -> [Inline] -> m
forall a m. (HasInlines a, Monoid m) => (Inline -> m) -> a -> m
foldInlines Inline -> Text
getStr
  getStr :: Inline -> Text
getStr (Inline Attr
_ (Str Text
t)) = Text
t
  getStr Inline
_ = Text
""