{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# 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, sortOn)
import qualified Data.Text.Internal as TI
import qualified Data.Text.Unsafe as TU
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,
                  isHexDigit, digitToInt, 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 = do
  -- The parser records which constructs occurred, so that the
  -- post-processing passes (each a full traversal of the AST) can be
  -- skipped when they would do nothing.  When includes are expanded,
  -- their contents are not reflected in the flags, so all passes run.
  (doc0, flags) <- case P (Document, ParseFlags)
-> FilePath -> Text -> Either ParseError (Document, ParseFlags)
forall a. P a -> FilePath -> Text -> Either ParseError a
parse ((,) (Document -> ParseFlags -> (Document, ParseFlags))
-> P Document -> P (ParseFlags -> (Document, ParseFlags))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Document
pDocument P (ParseFlags -> (Document, ParseFlags))
-> P ParseFlags -> P (Document, ParseFlags)
forall a b. P (a -> b) -> P a -> P b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ParserState -> ParseFlags) -> P ParseFlags
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ParserState -> ParseFlags
parseFlags) FilePath
path Text
t of
                     Left ParseError
err -> do
                       -- raiseError may return a fallback document whose
                       -- contents we know nothing about, so run all passes.
                       d <- FilePath -> Int -> FilePath -> m Document
raiseError FilePath
path (ParseError -> Int
errorPosition ParseError
err)
                                            (ParseError -> FilePath
errorMessage ParseError
err)
                       pure (d, ParseFlags True True True True)
                     Right (Document, ParseFlags)
r -> (Document, ParseFlags) -> m (Document, ParseFlags)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Document, ParseFlags)
r
  doc1 <- if sawInclude flags
             then handleIncludes doc0
             else pure doc0
  let doc2 = if ParseFlags -> Bool
sawInclude ParseFlags
flags Bool -> Bool -> Bool
|| ParseFlags -> Bool
sawSection ParseFlags
flags
                then Document -> Document
addIdentifiers Document
doc1
                else Document
doc1
  doc3 <- if sawInclude flags || sawAttributeReference flags
             then resolveAttributeReferences doc2
             else pure doc2
  if sawInclude flags || sawCrossReference flags
     then resolveCrossReferences doc3
     else pure doc3
 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 ([FilePath] -> Block -> m Block
handleIncludeBlock [FilePath
path])

  -- The first argument is the chain of files being included; a file
  -- that (transitively) includes itself is left unexpanded instead of
  -- recursing forever.
  handleIncludeBlock :: [FilePath] -> Block -> m Block
handleIncludeBlock [FilePath]
seen b :: Block
b@(Block Attr
attr Maybe BlockTitle
mbtitle (Include FilePath
fp Maybe [Block]
Nothing))
    | FilePath
fp FilePath -> [FilePath] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath]
seen = Block -> m Block
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Block
b
    | Bool
otherwise =
        (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 ([FilePath] -> Block -> m Block
handleIncludeBlock (FilePath
fp FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
seen))
  handleIncludeBlock [FilePath]
seen (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 ([FilePath] -> Block -> m Block
handleIncludeBlock (FilePath
fp FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
seen))
  handleIncludeBlock [FilePath]
_ 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:

-- A parser in continuation-passing style over the whole input Text.
-- The config, state and remaining input are threaded by hand and
-- passed directly to a success continuation, so binds allocate no
-- intermediate results.  Incremental (chunked) input is not
-- supported -- the whole document is in memory anyway -- which makes
-- backtracking cheap: (<|>) simply re-runs the second parser with the
-- state and input it saved.  As with StateT over a backtracking
-- parser, state changes made by a failed branch of (<|>) are
-- discarded.  The failure continuation receives the message and the
-- remaining input at the failure site (used to report a position).
newtype P a = P { forall a.
P a
-> forall r.
   ParserConfig
   -> ParserState
   -> Text
   -> (FilePath -> Text -> r)
   -> (a -> ParserState -> Text -> r)
   -> r
unP :: forall r. ParserConfig -> ParserState -> Text
                      -> (String -> Text -> r)              -- failure
                      -> (a -> ParserState -> Text -> r)    -- success
                      -> r }

instance Functor P where
  fmap :: forall a b. (a -> b) -> P a -> P b
fmap a -> b
f (P forall r.
ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> (a -> ParserState -> Text -> r)
-> r
m) = (forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (b -> ParserState -> Text -> r)
 -> r)
-> P b
forall a.
(forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
P ((forall r.
  ParserConfig
  -> ParserState
  -> Text
  -> (FilePath -> Text -> r)
  -> (b -> ParserState -> Text -> r)
  -> r)
 -> P b)
-> (forall r.
    ParserConfig
    -> ParserState
    -> Text
    -> (FilePath -> Text -> r)
    -> (b -> ParserState -> Text -> r)
    -> r)
-> P b
forall a b. (a -> b) -> a -> b
$ \ParserConfig
c ParserState
s Text
t FilePath -> Text -> r
kf b -> ParserState -> Text -> r
ks -> ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> (a -> ParserState -> Text -> r)
-> r
forall r.
ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> (a -> ParserState -> Text -> r)
-> r
m ParserConfig
c ParserState
s Text
t FilePath -> Text -> r
kf (\a
a ParserState
s' Text
t' -> b -> ParserState -> Text -> r
ks (a -> b
f a
a) ParserState
s' Text
t')
  {-# INLINE fmap #-}

instance Applicative P where
  pure :: forall a. a -> P a
pure a
a = (forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
forall a.
(forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
P ((forall r.
  ParserConfig
  -> ParserState
  -> Text
  -> (FilePath -> Text -> r)
  -> (a -> ParserState -> Text -> r)
  -> r)
 -> P a)
-> (forall r.
    ParserConfig
    -> ParserState
    -> Text
    -> (FilePath -> Text -> r)
    -> (a -> ParserState -> Text -> r)
    -> r)
-> P a
forall a b. (a -> b) -> a -> b
$ \ParserConfig
_ ParserState
s Text
t FilePath -> Text -> r
_ a -> ParserState -> Text -> r
ks -> a -> ParserState -> Text -> r
ks a
a ParserState
s Text
t
  {-# INLINE pure #-}
  P forall r.
ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> ((a -> b) -> ParserState -> Text -> r)
-> r
mf <*> :: forall a b. P (a -> b) -> P a -> P b
<*> P forall r.
ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> (a -> ParserState -> Text -> r)
-> r
ma = (forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (b -> ParserState -> Text -> r)
 -> r)
-> P b
forall a.
(forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
P ((forall r.
  ParserConfig
  -> ParserState
  -> Text
  -> (FilePath -> Text -> r)
  -> (b -> ParserState -> Text -> r)
  -> r)
 -> P b)
-> (forall r.
    ParserConfig
    -> ParserState
    -> Text
    -> (FilePath -> Text -> r)
    -> (b -> ParserState -> Text -> r)
    -> r)
-> P b
forall a b. (a -> b) -> a -> b
$ \ParserConfig
c ParserState
s Text
t FilePath -> Text -> r
kf b -> ParserState -> Text -> r
ks ->
    ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> ((a -> b) -> ParserState -> Text -> r)
-> r
forall r.
ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> ((a -> b) -> ParserState -> Text -> r)
-> r
mf ParserConfig
c ParserState
s Text
t FilePath -> Text -> r
kf (\a -> b
f ParserState
s' Text
t' ->
      ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> (a -> ParserState -> Text -> r)
-> r
forall r.
ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> (a -> ParserState -> Text -> r)
-> r
ma ParserConfig
c ParserState
s' Text
t' FilePath -> Text -> r
kf (\a
a ParserState
s'' Text
t'' -> b -> ParserState -> Text -> r
ks (a -> b
f a
a) ParserState
s'' Text
t''))
  {-# INLINE (<*>) #-}
  P forall r.
ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> (a -> ParserState -> Text -> r)
-> r
ma *> :: forall a b. P a -> P b -> P b
*> P forall r.
ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> (b -> ParserState -> Text -> r)
-> r
mb = (forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (b -> ParserState -> Text -> r)
 -> r)
-> P b
forall a.
(forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
P ((forall r.
  ParserConfig
  -> ParserState
  -> Text
  -> (FilePath -> Text -> r)
  -> (b -> ParserState -> Text -> r)
  -> r)
 -> P b)
-> (forall r.
    ParserConfig
    -> ParserState
    -> Text
    -> (FilePath -> Text -> r)
    -> (b -> ParserState -> Text -> r)
    -> r)
-> P b
forall a b. (a -> b) -> a -> b
$ \ParserConfig
c ParserState
s Text
t FilePath -> Text -> r
kf b -> ParserState -> Text -> r
ks ->
    ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> (a -> ParserState -> Text -> r)
-> r
forall r.
ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> (a -> ParserState -> Text -> r)
-> r
ma ParserConfig
c ParserState
s Text
t FilePath -> Text -> r
kf (\a
_ ParserState
s' Text
t' -> ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> (b -> ParserState -> Text -> r)
-> r
forall r.
ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> (b -> ParserState -> Text -> r)
-> r
mb ParserConfig
c ParserState
s' Text
t' FilePath -> Text -> r
kf b -> ParserState -> Text -> r
ks)
  {-# INLINE (*>) #-}
  P forall r.
ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> (a -> ParserState -> Text -> r)
-> r
ma <* :: forall a b. P a -> P b -> P a
<* P forall r.
ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> (b -> ParserState -> Text -> r)
-> r
mb = (forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
forall a.
(forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
P ((forall r.
  ParserConfig
  -> ParserState
  -> Text
  -> (FilePath -> Text -> r)
  -> (a -> ParserState -> Text -> r)
  -> r)
 -> P a)
-> (forall r.
    ParserConfig
    -> ParserState
    -> Text
    -> (FilePath -> Text -> r)
    -> (a -> ParserState -> Text -> r)
    -> r)
-> P a
forall a b. (a -> b) -> a -> b
$ \ParserConfig
c ParserState
s Text
t FilePath -> Text -> r
kf a -> ParserState -> Text -> r
ks ->
    ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> (a -> ParserState -> Text -> r)
-> r
forall r.
ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> (a -> ParserState -> Text -> r)
-> r
ma ParserConfig
c ParserState
s Text
t FilePath -> Text -> r
kf (\a
a ParserState
s' Text
t' ->
      ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> (b -> ParserState -> Text -> r)
-> r
forall r.
ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> (b -> ParserState -> Text -> r)
-> r
mb ParserConfig
c ParserState
s' Text
t' FilePath -> Text -> r
kf (\b
_ ParserState
s'' Text
t'' -> a -> ParserState -> Text -> r
ks a
a ParserState
s'' Text
t''))
  {-# INLINE (<*) #-}

instance Monad P where
  P forall r.
ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> (a -> ParserState -> Text -> r)
-> r
m >>= :: forall a b. P a -> (a -> P b) -> P b
>>= a -> P b
f = (forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (b -> ParserState -> Text -> r)
 -> r)
-> P b
forall a.
(forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
P ((forall r.
  ParserConfig
  -> ParserState
  -> Text
  -> (FilePath -> Text -> r)
  -> (b -> ParserState -> Text -> r)
  -> r)
 -> P b)
-> (forall r.
    ParserConfig
    -> ParserState
    -> Text
    -> (FilePath -> Text -> r)
    -> (b -> ParserState -> Text -> r)
    -> r)
-> P b
forall a b. (a -> b) -> a -> b
$ \ParserConfig
c ParserState
s Text
t FilePath -> Text -> r
kf b -> ParserState -> Text -> r
ks ->
    ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> (a -> ParserState -> Text -> r)
-> r
forall r.
ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> (a -> ParserState -> Text -> r)
-> r
m ParserConfig
c ParserState
s Text
t FilePath -> Text -> r
kf (\a
a ParserState
s' Text
t' -> P b
-> forall r.
   ParserConfig
   -> ParserState
   -> Text
   -> (FilePath -> Text -> r)
   -> (b -> ParserState -> Text -> r)
   -> r
forall a.
P a
-> forall r.
   ParserConfig
   -> ParserState
   -> Text
   -> (FilePath -> Text -> r)
   -> (a -> ParserState -> Text -> r)
   -> r
unP (a -> P b
f a
a) ParserConfig
c ParserState
s' Text
t' FilePath -> Text -> r
kf b -> ParserState -> Text -> r
ks)
  {-# INLINE (>>=) #-}

instance MonadFail P where
  fail :: forall a. FilePath -> P a
fail FilePath
msg = (forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
forall a.
(forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
P ((forall r.
  ParserConfig
  -> ParserState
  -> Text
  -> (FilePath -> Text -> r)
  -> (a -> ParserState -> Text -> r)
  -> r)
 -> P a)
-> (forall r.
    ParserConfig
    -> ParserState
    -> Text
    -> (FilePath -> Text -> r)
    -> (a -> ParserState -> Text -> r)
    -> r)
-> P a
forall a b. (a -> b) -> a -> b
$ \ParserConfig
_ ParserState
_ Text
t FilePath -> Text -> r
kf a -> ParserState -> Text -> r
_ -> FilePath -> Text -> r
kf (FilePath
"Failed reading: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
msg) Text
t

instance Alternative P where
  empty :: forall a. P a
empty = (forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
forall a.
(forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
P ((forall r.
  ParserConfig
  -> ParserState
  -> Text
  -> (FilePath -> Text -> r)
  -> (a -> ParserState -> Text -> r)
  -> r)
 -> P a)
-> (forall r.
    ParserConfig
    -> ParserState
    -> Text
    -> (FilePath -> Text -> r)
    -> (a -> ParserState -> Text -> r)
    -> r)
-> P a
forall a b. (a -> b) -> a -> b
$ \ParserConfig
_ ParserState
_ Text
t FilePath -> Text -> r
kf a -> ParserState -> Text -> r
_ -> FilePath -> Text -> r
kf FilePath
"empty" Text
t
  {-# INLINE empty #-}
  -- Note that the success continuation is passed through unchanged:
  -- once a branch succeeds, a later failure calls the failure
  -- continuation in scope at that point, not the saved one, so it
  -- does not backtrack into the right branch.
  P forall r.
ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> (a -> ParserState -> Text -> r)
-> r
a <|> :: forall a. P a -> P a -> P a
<|> P forall r.
ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> (a -> ParserState -> Text -> r)
-> r
b = (forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
forall a.
(forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
P ((forall r.
  ParserConfig
  -> ParserState
  -> Text
  -> (FilePath -> Text -> r)
  -> (a -> ParserState -> Text -> r)
  -> r)
 -> P a)
-> (forall r.
    ParserConfig
    -> ParserState
    -> Text
    -> (FilePath -> Text -> r)
    -> (a -> ParserState -> Text -> r)
    -> r)
-> P a
forall a b. (a -> b) -> a -> b
$ \ParserConfig
c ParserState
s Text
t FilePath -> Text -> r
kf a -> ParserState -> Text -> r
ks -> ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> (a -> ParserState -> Text -> r)
-> r
forall r.
ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> (a -> ParserState -> Text -> r)
-> r
a ParserConfig
c ParserState
s Text
t (\FilePath
_ Text
_ -> ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> (a -> ParserState -> Text -> r)
-> r
forall r.
ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> (a -> ParserState -> Text -> r)
-> r
b ParserConfig
c ParserState
s Text
t FilePath -> Text -> r
kf a -> ParserState -> Text -> r
ks) a -> ParserState -> Text -> r
ks
  {-# INLINE (<|>) #-}

instance MonadPlus P

instance MonadReader ParserConfig P where
  ask :: P ParserConfig
ask = (forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (ParserConfig -> ParserState -> Text -> r)
 -> r)
-> P ParserConfig
forall a.
(forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
P ((forall r.
  ParserConfig
  -> ParserState
  -> Text
  -> (FilePath -> Text -> r)
  -> (ParserConfig -> ParserState -> Text -> r)
  -> r)
 -> P ParserConfig)
-> (forall r.
    ParserConfig
    -> ParserState
    -> Text
    -> (FilePath -> Text -> r)
    -> (ParserConfig -> ParserState -> Text -> r)
    -> r)
-> P ParserConfig
forall a b. (a -> b) -> a -> b
$ \ParserConfig
c ParserState
s Text
t FilePath -> Text -> r
_ ParserConfig -> ParserState -> Text -> r
ks -> ParserConfig -> ParserState -> Text -> r
ks ParserConfig
c ParserState
s Text
t
  {-# INLINE ask #-}
  local :: forall a. (ParserConfig -> ParserConfig) -> P a -> P a
local ParserConfig -> ParserConfig
f (P forall r.
ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> (a -> ParserState -> Text -> r)
-> r
m) = (forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
forall a.
(forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
P ((forall r.
  ParserConfig
  -> ParserState
  -> Text
  -> (FilePath -> Text -> r)
  -> (a -> ParserState -> Text -> r)
  -> r)
 -> P a)
-> (forall r.
    ParserConfig
    -> ParserState
    -> Text
    -> (FilePath -> Text -> r)
    -> (a -> ParserState -> Text -> r)
    -> r)
-> P a
forall a b. (a -> b) -> a -> b
$ \ParserConfig
c -> ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> (a -> ParserState -> Text -> r)
-> r
forall r.
ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> (a -> ParserState -> Text -> r)
-> r
m (ParserConfig -> ParserConfig
f ParserConfig
c)
  {-# INLINE local #-}

instance MonadState ParserState P where
  get :: P ParserState
get = (forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (ParserState -> ParserState -> Text -> r)
 -> r)
-> P ParserState
forall a.
(forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
P ((forall r.
  ParserConfig
  -> ParserState
  -> Text
  -> (FilePath -> Text -> r)
  -> (ParserState -> ParserState -> Text -> r)
  -> r)
 -> P ParserState)
-> (forall r.
    ParserConfig
    -> ParserState
    -> Text
    -> (FilePath -> Text -> r)
    -> (ParserState -> ParserState -> Text -> r)
    -> r)
-> P ParserState
forall a b. (a -> b) -> a -> b
$ \ParserConfig
_ ParserState
s Text
t FilePath -> Text -> r
_ ParserState -> ParserState -> Text -> r
ks -> ParserState -> ParserState -> Text -> r
ks ParserState
s ParserState
s Text
t
  {-# INLINE get #-}
  put :: ParserState -> P ()
put ParserState
s = (forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (() -> ParserState -> Text -> r)
 -> r)
-> P ()
forall a.
(forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
P ((forall r.
  ParserConfig
  -> ParserState
  -> Text
  -> (FilePath -> Text -> r)
  -> (() -> ParserState -> Text -> r)
  -> r)
 -> P ())
-> (forall r.
    ParserConfig
    -> ParserState
    -> Text
    -> (FilePath -> Text -> r)
    -> (() -> ParserState -> Text -> r)
    -> r)
-> P ()
forall a b. (a -> b) -> a -> b
$ \ParserConfig
_ ParserState
_ Text
t FilePath -> Text -> r
_ () -> ParserState -> Text -> r
ks -> () -> ParserState -> Text -> r
ks () ParserState
s Text
t
  {-# INLINE put #-}
  state :: forall a. (ParserState -> (a, ParserState)) -> P a
state ParserState -> (a, ParserState)
f = (forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
forall a.
(forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
P ((forall r.
  ParserConfig
  -> ParserState
  -> Text
  -> (FilePath -> Text -> r)
  -> (a -> ParserState -> Text -> r)
  -> r)
 -> P a)
-> (forall r.
    ParserConfig
    -> ParserState
    -> Text
    -> (FilePath -> Text -> r)
    -> (a -> ParserState -> Text -> r)
    -> r)
-> P a
forall a b. (a -> b) -> a -> b
$ \ParserConfig
_ ParserState
s Text
t FilePath -> Text -> r
_ a -> ParserState -> Text -> r
ks -> case ParserState -> (a, ParserState)
f ParserState
s of (a
a, ParserState
s') -> a -> ParserState -> Text -> r
ks a
a ParserState
s' Text
t
  {-# INLINE state #-}

data ParserState = ParserState
                     { ParserState -> Map Text (CounterType, Int)
counterMap :: M.Map Text (CounterType, Int)
                     , ParserState -> Map Text Text
docAttrs :: M.Map Text Text
                     , ParserState -> ParseFlags
parseFlags :: !ParseFlags
                     }
        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)

-- | Which constructs occurred during the parse; used to skip
-- post-processing passes that would have no effect.
data ParseFlags = ParseFlags
  { ParseFlags -> Bool
sawInclude :: !Bool
  , ParseFlags -> Bool
sawSection :: !Bool
  , ParseFlags -> Bool
sawAttributeReference :: !Bool
  , ParseFlags -> Bool
sawCrossReference :: !Bool
  } deriving (Int -> ParseFlags -> FilePath -> FilePath
[ParseFlags] -> FilePath -> FilePath
ParseFlags -> FilePath
(Int -> ParseFlags -> FilePath -> FilePath)
-> (ParseFlags -> FilePath)
-> ([ParseFlags] -> FilePath -> FilePath)
-> Show ParseFlags
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> ParseFlags -> FilePath -> FilePath
showsPrec :: Int -> ParseFlags -> FilePath -> FilePath
$cshow :: ParseFlags -> FilePath
show :: ParseFlags -> FilePath
$cshowList :: [ParseFlags] -> FilePath -> FilePath
showList :: [ParseFlags] -> FilePath -> FilePath
Show)

noParseFlags :: ParseFlags
noParseFlags :: ParseFlags
noParseFlags = Bool -> Bool -> Bool -> Bool -> ParseFlags
ParseFlags Bool
False Bool
False Bool
False Bool
False

setFlag :: (ParseFlags -> ParseFlags) -> P ()
setFlag :: (ParseFlags -> ParseFlags) -> P ()
setFlag ParseFlags -> ParseFlags
f = (ParserState -> ParserState) -> P ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ParserState -> ParserState) -> P ())
-> (ParserState -> ParserState) -> P ()
forall a b. (a -> b) -> a -> b
$ \ParserState
s -> ParserState
s{ parseFlags = f (parseFlags s) }

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
                                 , parseFlags :: ParseFlags
parseFlags = ParseFlags
noParseFlags
                                 })
                    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 =
  P a
-> forall r.
   ParserConfig
   -> ParserState
   -> Text
   -> (FilePath -> Text -> r)
   -> (a -> ParserState -> Text -> r)
   -> r
forall a.
P a
-> forall r.
   ParserConfig
   -> ParserState
   -> Text
   -> (FilePath -> Text -> r)
   -> (a -> ParserState -> Text -> r)
   -> r
unP P a
p ParserConfig
cfg ParserState
st Text
t FilePath -> Text -> Either ParseError a
forall {b}. FilePath -> Text -> Either ParseError b
failure a -> ParserState -> Text -> Either ParseError a
forall {b} {p} {p} {a}. b -> p -> p -> Either a b
success
 where
  failure :: FilePath -> Text -> Either ParseError b
failure FilePath
msg Text
i = 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
  success :: b -> p -> p -> Either a b
success b
a p
_ p
_ = b -> Either a b
forall a b. b -> Either a b
Right b
a

localP :: (ParserConfig -> ParserConfig) -> P a -> P a
localP :: forall a. (ParserConfig -> ParserConfig) -> P a -> P a
localP ParserConfig -> ParserConfig
f (P forall r.
ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> (a -> ParserState -> Text -> r)
-> r
p) = (forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
forall a.
(forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
P ((forall r.
  ParserConfig
  -> ParserState
  -> Text
  -> (FilePath -> Text -> r)
  -> (a -> ParserState -> Text -> r)
  -> r)
 -> P a)
-> (forall r.
    ParserConfig
    -> ParserState
    -> Text
    -> (FilePath -> Text -> r)
    -> (a -> ParserState -> Text -> r)
    -> r)
-> P a
forall a b. (a -> b) -> a -> b
$ \ParserConfig
c -> ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> (a -> ParserState -> Text -> r)
-> r
forall r.
ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> (a -> ParserState -> Text -> r)
-> r
p (ParserConfig -> ParserConfig
f ParserConfig
c)
{-# INLINE localP #-}

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 })

failP :: String -> P a
failP :: forall a. FilePath -> P a
failP FilePath
msg = (forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
forall a.
(forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
P ((forall r.
  ParserConfig
  -> ParserState
  -> Text
  -> (FilePath -> Text -> r)
  -> (a -> ParserState -> Text -> r)
  -> r)
 -> P a)
-> (forall r.
    ParserConfig
    -> ParserState
    -> Text
    -> (FilePath -> Text -> r)
    -> (a -> ParserState -> Text -> r)
    -> r)
-> P a
forall a b. (a -> b) -> a -> b
$ \ParserConfig
_ ParserState
_ Text
t FilePath -> Text -> r
kf a -> ParserState -> Text -> r
_ -> FilePath -> Text -> r
kf FilePath
msg Text
t

vchar :: Char -> P ()
vchar :: Char -> P ()
vchar Char
c = (forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (() -> ParserState -> Text -> r)
 -> r)
-> P ()
forall a.
(forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
P ((forall r.
  ParserConfig
  -> ParserState
  -> Text
  -> (FilePath -> Text -> r)
  -> (() -> ParserState -> Text -> r)
  -> r)
 -> P ())
-> (forall r.
    ParserConfig
    -> ParserState
    -> Text
    -> (FilePath -> Text -> r)
    -> (() -> ParserState -> Text -> r)
    -> r)
-> P ()
forall a b. (a -> b) -> a -> b
$ \ParserConfig
_ ParserState
s Text
t FilePath -> Text -> r
kf () -> ParserState -> Text -> r
ks ->
  case Text -> Maybe (Char, Text)
T.uncons Text
t of
    Just (Char
c', Text
t') | Char
c' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c -> () -> ParserState -> Text -> r
ks () ParserState
s Text
t'
    Maybe (Char, Text)
_ -> FilePath -> Text -> r
kf FilePath
"satisfy" Text
t
{-# INLINE vchar #-}

char :: Char -> P Char
char :: Char -> P Char
char Char
c = (forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (Char -> ParserState -> Text -> r)
 -> r)
-> P Char
forall a.
(forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
P ((forall r.
  ParserConfig
  -> ParserState
  -> Text
  -> (FilePath -> Text -> r)
  -> (Char -> ParserState -> Text -> r)
  -> r)
 -> P Char)
-> (forall r.
    ParserConfig
    -> ParserState
    -> Text
    -> (FilePath -> Text -> r)
    -> (Char -> ParserState -> Text -> r)
    -> r)
-> P Char
forall a b. (a -> b) -> a -> b
$ \ParserConfig
_ ParserState
s Text
t FilePath -> Text -> r
kf Char -> ParserState -> Text -> r
ks ->
  case Text -> Maybe (Char, Text)
T.uncons Text
t of
    Just (Char
c', Text
t') | Char
c' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c -> Char -> ParserState -> Text -> r
ks Char
c ParserState
s Text
t'
    Maybe (Char, Text)
_ -> FilePath -> Text -> r
kf FilePath
"satisfy" Text
t
{-# INLINE char #-}

peekChar :: P (Maybe Char)
peekChar :: P (Maybe Char)
peekChar = (forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (Maybe Char -> ParserState -> Text -> r)
 -> r)
-> P (Maybe Char)
forall a.
(forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
P ((forall r.
  ParserConfig
  -> ParserState
  -> Text
  -> (FilePath -> Text -> r)
  -> (Maybe Char -> ParserState -> Text -> r)
  -> r)
 -> P (Maybe Char))
-> (forall r.
    ParserConfig
    -> ParserState
    -> Text
    -> (FilePath -> Text -> r)
    -> (Maybe Char -> ParserState -> Text -> r)
    -> r)
-> P (Maybe Char)
forall a b. (a -> b) -> a -> b
$ \ParserConfig
_ ParserState
s Text
t FilePath -> Text -> r
_ Maybe Char -> ParserState -> Text -> r
ks ->
  case Text -> Maybe (Char, Text)
T.uncons Text
t of
    Just (Char
c, Text
_) -> Maybe Char -> ParserState -> Text -> r
ks (Char -> Maybe Char
forall a. a -> Maybe a
Just Char
c) ParserState
s Text
t
    Maybe (Char, Text)
Nothing -> Maybe Char -> ParserState -> Text -> r
ks Maybe Char
forall a. Maybe a
Nothing ParserState
s Text
t
{-# INLINE peekChar #-}

peekChar' :: P Char
peekChar' :: P Char
peekChar' = (forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (Char -> ParserState -> Text -> r)
 -> r)
-> P Char
forall a.
(forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
P ((forall r.
  ParserConfig
  -> ParserState
  -> Text
  -> (FilePath -> Text -> r)
  -> (Char -> ParserState -> Text -> r)
  -> r)
 -> P Char)
-> (forall r.
    ParserConfig
    -> ParserState
    -> Text
    -> (FilePath -> Text -> r)
    -> (Char -> ParserState -> Text -> r)
    -> r)
-> P Char
forall a b. (a -> b) -> a -> b
$ \ParserConfig
_ ParserState
s Text
t FilePath -> Text -> r
kf Char -> ParserState -> Text -> r
ks ->
  case Text -> Maybe (Char, Text)
T.uncons Text
t of
    Just (Char
c, Text
_) -> Char -> ParserState -> Text -> r
ks Char
c ParserState
s Text
t
    Maybe (Char, Text)
Nothing -> FilePath -> Text -> r
kf FilePath
"not enough input" Text
t
{-# INLINE peekChar' #-}

anyChar :: P Char
anyChar :: P Char
anyChar = (forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (Char -> ParserState -> Text -> r)
 -> r)
-> P Char
forall a.
(forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
P ((forall r.
  ParserConfig
  -> ParserState
  -> Text
  -> (FilePath -> Text -> r)
  -> (Char -> ParserState -> Text -> r)
  -> r)
 -> P Char)
-> (forall r.
    ParserConfig
    -> ParserState
    -> Text
    -> (FilePath -> Text -> r)
    -> (Char -> ParserState -> Text -> r)
    -> r)
-> P Char
forall a b. (a -> b) -> a -> b
$ \ParserConfig
_ ParserState
s Text
t FilePath -> Text -> r
kf Char -> ParserState -> Text -> r
ks ->
  case Text -> Maybe (Char, Text)
T.uncons Text
t of
    Just (Char
c, Text
t') -> Char -> ParserState -> Text -> r
ks Char
c ParserState
s Text
t'
    Maybe (Char, Text)
Nothing -> FilePath -> Text -> r
kf FilePath
"not enough input" Text
t
{-# INLINE anyChar #-}

satisfy :: (Char -> Bool) -> P Char
satisfy :: (Char -> Bool) -> P Char
satisfy Char -> Bool
f = (forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (Char -> ParserState -> Text -> r)
 -> r)
-> P Char
forall a.
(forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
P ((forall r.
  ParserConfig
  -> ParserState
  -> Text
  -> (FilePath -> Text -> r)
  -> (Char -> ParserState -> Text -> r)
  -> r)
 -> P Char)
-> (forall r.
    ParserConfig
    -> ParserState
    -> Text
    -> (FilePath -> Text -> r)
    -> (Char -> ParserState -> Text -> r)
    -> r)
-> P Char
forall a b. (a -> b) -> a -> b
$ \ParserConfig
_ ParserState
s Text
t FilePath -> Text -> r
kf Char -> ParserState -> Text -> r
ks ->
  case Text -> Maybe (Char, Text)
T.uncons Text
t of
    Just (Char
c, Text
t') | Char -> Bool
f Char
c -> Char -> ParserState -> Text -> r
ks Char
c ParserState
s Text
t'
    Maybe (Char, Text)
_ -> FilePath -> Text -> r
kf FilePath
"satisfy" Text
t
{-# INLINE satisfy #-}

space :: P Char
space :: P Char
space = (Char -> Bool) -> P Char
satisfy Char -> Bool
isSpace

isEndOfLine :: Char -> Bool
isEndOfLine :: Char -> Bool
isEndOfLine Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\r'

-- The parser only ever advances by taking suffixes of the input, all
-- slices of one underlying array, so the text consumed between two
-- points is the prefix of the earlier remainder whose length is the
-- difference of the remainders' lengths.
consumed :: Text -> Text -> Text
consumed :: Text -> Text -> Text
consumed (TI.Text Array
arr Int
off Int
len) (TI.Text Array
_ Int
_ Int
len') =
  Array -> Int -> Int -> Text
TI.text Array
arr Int
off (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
len')
{-# INLINE consumed #-}

match :: P a -> P (T.Text, a)
match :: forall a. P a -> P (Text, a)
match P a
p = (forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> ((Text, a) -> ParserState -> Text -> r)
 -> r)
-> P (Text, a)
forall a.
(forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
P ((forall r.
  ParserConfig
  -> ParserState
  -> Text
  -> (FilePath -> Text -> r)
  -> ((Text, a) -> ParserState -> Text -> r)
  -> r)
 -> P (Text, a))
-> (forall r.
    ParserConfig
    -> ParserState
    -> Text
    -> (FilePath -> Text -> r)
    -> ((Text, a) -> ParserState -> Text -> r)
    -> r)
-> P (Text, a)
forall a b. (a -> b) -> a -> b
$ \ParserConfig
c ParserState
s Text
t FilePath -> Text -> r
kf (Text, a) -> ParserState -> Text -> r
ks ->
  P a
-> forall r.
   ParserConfig
   -> ParserState
   -> Text
   -> (FilePath -> Text -> r)
   -> (a -> ParserState -> Text -> r)
   -> r
forall a.
P a
-> forall r.
   ParserConfig
   -> ParserState
   -> Text
   -> (FilePath -> Text -> r)
   -> (a -> ParserState -> Text -> r)
   -> r
unP P a
p ParserConfig
c ParserState
s Text
t FilePath -> Text -> r
kf (\a
x ParserState
_ Text
t' -> (Text, a) -> ParserState -> Text -> r
ks (Text -> Text -> Text
consumed Text
t Text
t', a
x) ParserState
s Text
t')

-- Like match, but keeps the parser state changes made by the inner
-- parser instead of discarding them.
matchKeepingState :: P a -> P (T.Text, a)
matchKeepingState :: forall a. P a -> P (Text, a)
matchKeepingState P a
p = (forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> ((Text, a) -> ParserState -> Text -> r)
 -> r)
-> P (Text, a)
forall a.
(forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
P ((forall r.
  ParserConfig
  -> ParserState
  -> Text
  -> (FilePath -> Text -> r)
  -> ((Text, a) -> ParserState -> Text -> r)
  -> r)
 -> P (Text, a))
-> (forall r.
    ParserConfig
    -> ParserState
    -> Text
    -> (FilePath -> Text -> r)
    -> ((Text, a) -> ParserState -> Text -> r)
    -> r)
-> P (Text, a)
forall a b. (a -> b) -> a -> b
$ \ParserConfig
c ParserState
s Text
t FilePath -> Text -> r
kf (Text, a) -> ParserState -> Text -> r
ks ->
  P a
-> forall r.
   ParserConfig
   -> ParserState
   -> Text
   -> (FilePath -> Text -> r)
   -> (a -> ParserState -> Text -> r)
   -> r
forall a.
P a
-> forall r.
   ParserConfig
   -> ParserState
   -> Text
   -> (FilePath -> Text -> r)
   -> (a -> ParserState -> Text -> r)
   -> r
unP P a
p ParserConfig
c ParserState
s Text
t FilePath -> Text -> r
kf (\a
x ParserState
s' Text
t' -> (Text, a) -> ParserState -> Text -> r
ks (Text -> Text -> Text
consumed Text
t Text
t', a
x) ParserState
s' Text
t')

-- Run a parser, then restore the input (and state) as they were.
lookAhead :: P a -> P a
lookAhead :: forall a. P a -> P a
lookAhead (P forall r.
ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> (a -> ParserState -> Text -> r)
-> r
m) = (forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
forall a.
(forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
P ((forall r.
  ParserConfig
  -> ParserState
  -> Text
  -> (FilePath -> Text -> r)
  -> (a -> ParserState -> Text -> r)
  -> r)
 -> P a)
-> (forall r.
    ParserConfig
    -> ParserState
    -> Text
    -> (FilePath -> Text -> r)
    -> (a -> ParserState -> Text -> r)
    -> r)
-> P a
forall a b. (a -> b) -> a -> b
$ \ParserConfig
c ParserState
s Text
t FilePath -> Text -> r
kf a -> ParserState -> Text -> r
ks -> ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> (a -> ParserState -> Text -> r)
-> r
forall r.
ParserConfig
-> ParserState
-> Text
-> (FilePath -> Text -> r)
-> (a -> ParserState -> Text -> r)
-> r
m ParserConfig
c ParserState
s Text
t FilePath -> Text -> r
kf (\a
a ParserState
_ Text
_ -> a -> ParserState -> Text -> r
ks a
a ParserState
s Text
t)

string :: T.Text -> P T.Text
string :: Text -> P Text
string Text
pat = (forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (Text -> ParserState -> Text -> r)
 -> r)
-> P Text
forall a.
(forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
P ((forall r.
  ParserConfig
  -> ParserState
  -> Text
  -> (FilePath -> Text -> r)
  -> (Text -> ParserState -> Text -> r)
  -> r)
 -> P Text)
-> (forall r.
    ParserConfig
    -> ParserState
    -> Text
    -> (FilePath -> Text -> r)
    -> (Text -> ParserState -> Text -> r)
    -> r)
-> P Text
forall a b. (a -> b) -> a -> b
$ \ParserConfig
_ ParserState
s Text
t FilePath -> Text -> r
kf Text -> ParserState -> Text -> r
ks ->
  case Text -> Text -> Maybe Text
T.stripPrefix Text
pat Text
t of
    Just Text
t' -> Text -> ParserState -> Text -> r
ks Text
pat ParserState
s Text
t'
    Maybe Text
Nothing -> FilePath -> Text -> r
kf FilePath
"string" Text
t
{-# INLINE string #-}

decimal :: Integral a => P a
decimal :: forall a. Integral a => P a
decimal = (forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
forall a.
(forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
P ((forall r.
  ParserConfig
  -> ParserState
  -> Text
  -> (FilePath -> Text -> r)
  -> (a -> ParserState -> Text -> r)
  -> r)
 -> P a)
-> (forall r.
    ParserConfig
    -> ParserState
    -> Text
    -> (FilePath -> Text -> r)
    -> (a -> ParserState -> Text -> r)
    -> r)
-> P a
forall a b. (a -> b) -> a -> b
$ \ParserConfig
_ ParserState
s Text
t FilePath -> Text -> r
kf a -> ParserState -> Text -> r
ks ->
  case (Char -> Bool) -> Text -> (Text, Text)
T.span Char -> Bool
isDigit Text
t of
    (Text
ds, Text
t') | Text -> Bool
T.null Text
ds -> FilePath -> Text -> r
kf FilePath
"decimal" Text
t
             | Bool
otherwise -> a -> ParserState -> Text -> r
ks ((a -> Char -> a) -> a -> Text -> a
forall a. (a -> Char -> a) -> a -> Text -> a
T.foldl' a -> Char -> a
forall {a}. Num a => a -> Char -> a
step a
0 Text
ds) ParserState
s Text
t'
 where
  step :: a -> Char -> a
step a
n Char
d = a
n a -> a -> a
forall a. Num a => a -> a -> a
* a
10 a -> a -> a
forall a. Num a => a -> a -> a
+ Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
48)

hexadecimal :: Integral a => P a
hexadecimal :: forall a. Integral a => P a
hexadecimal = (forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
forall a.
(forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
P ((forall r.
  ParserConfig
  -> ParserState
  -> Text
  -> (FilePath -> Text -> r)
  -> (a -> ParserState -> Text -> r)
  -> r)
 -> P a)
-> (forall r.
    ParserConfig
    -> ParserState
    -> Text
    -> (FilePath -> Text -> r)
    -> (a -> ParserState -> Text -> r)
    -> r)
-> P a
forall a b. (a -> b) -> a -> b
$ \ParserConfig
_ ParserState
s Text
t FilePath -> Text -> r
kf a -> ParserState -> Text -> r
ks ->
  case (Char -> Bool) -> Text -> (Text, Text)
T.span Char -> Bool
isHexDigit Text
t of
    (Text
ds, Text
t') | Text -> Bool
T.null Text
ds -> FilePath -> Text -> r
kf FilePath
"hexadecimal" Text
t
             | Bool
otherwise -> a -> ParserState -> Text -> r
ks ((a -> Char -> a) -> a -> Text -> a
forall a. (a -> Char -> a) -> a -> Text -> a
T.foldl' a -> Char -> a
forall {a}. Num a => a -> Char -> a
step a
0 Text
ds) ParserState
s Text
t'
 where
  step :: a -> Char -> a
step a
n Char
d = a
n a -> a -> a
forall a. Num a => a -> a -> a
* a
16 a -> a -> a
forall a. Num a => a -> a -> a
+ Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
digitToInt Char
d)

endOfInput :: P ()
endOfInput :: P ()
endOfInput = (forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (() -> ParserState -> Text -> r)
 -> r)
-> P ()
forall a.
(forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
P ((forall r.
  ParserConfig
  -> ParserState
  -> Text
  -> (FilePath -> Text -> r)
  -> (() -> ParserState -> Text -> r)
  -> r)
 -> P ())
-> (forall r.
    ParserConfig
    -> ParserState
    -> Text
    -> (FilePath -> Text -> r)
    -> (() -> ParserState -> Text -> r)
    -> r)
-> P ()
forall a b. (a -> b) -> a -> b
$ \ParserConfig
_ ParserState
s Text
t FilePath -> Text -> r
kf () -> ParserState -> Text -> r
ks ->
  if Text -> Bool
T.null Text
t then () -> ParserState -> Text -> r
ks () ParserState
s Text
t else FilePath -> Text -> r
kf FilePath
"endOfInput" Text
t

endOfLine :: P ()
endOfLine :: P ()
endOfLine = (forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (() -> ParserState -> Text -> r)
 -> r)
-> P ()
forall a.
(forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
P ((forall r.
  ParserConfig
  -> ParserState
  -> Text
  -> (FilePath -> Text -> r)
  -> (() -> ParserState -> Text -> r)
  -> r)
 -> P ())
-> (forall r.
    ParserConfig
    -> ParserState
    -> Text
    -> (FilePath -> Text -> r)
    -> (() -> ParserState -> Text -> r)
    -> r)
-> P ()
forall a b. (a -> b) -> a -> b
$ \ParserConfig
_ ParserState
s Text
t FilePath -> Text -> r
kf () -> ParserState -> Text -> r
ks ->
  case Text -> Maybe (Char, Text)
T.uncons Text
t of
    Just (Char
'\n', Text
t') -> () -> ParserState -> Text -> r
ks () ParserState
s Text
t'
    Just (Char
'\r', Text
t') | Just (Char
'\n', Text
t'') <- Text -> Maybe (Char, Text)
T.uncons Text
t' -> () -> ParserState -> Text -> r
ks () ParserState
s Text
t''
    Maybe (Char, Text)
_ -> FilePath -> Text -> r
kf FilePath
"endOfLine" Text
t
{-# INLINE endOfLine #-}

takeWhile :: (Char -> Bool) -> P T.Text
takeWhile :: (Char -> Bool) -> P Text
takeWhile Char -> Bool
f = (forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (Text -> ParserState -> Text -> r)
 -> r)
-> P Text
forall a.
(forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
P ((forall r.
  ParserConfig
  -> ParserState
  -> Text
  -> (FilePath -> Text -> r)
  -> (Text -> ParserState -> Text -> r)
  -> r)
 -> P Text)
-> (forall r.
    ParserConfig
    -> ParserState
    -> Text
    -> (FilePath -> Text -> r)
    -> (Text -> ParserState -> Text -> r)
    -> r)
-> P Text
forall a b. (a -> b) -> a -> b
$ \ParserConfig
_ ParserState
s Text
t FilePath -> Text -> r
_ Text -> ParserState -> Text -> r
ks ->
  case (Char -> Bool) -> Text -> (Text, Text)
T.span Char -> Bool
f Text
t of (Text
a, Text
t') -> Text -> ParserState -> Text -> r
ks Text
a ParserState
s Text
t'
{-# INLINE takeWhile #-}

takeWhile1 :: (Char -> Bool) -> P T.Text
takeWhile1 :: (Char -> Bool) -> P Text
takeWhile1 Char -> Bool
f = (forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (Text -> ParserState -> Text -> r)
 -> r)
-> P Text
forall a.
(forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
P ((forall r.
  ParserConfig
  -> ParserState
  -> Text
  -> (FilePath -> Text -> r)
  -> (Text -> ParserState -> Text -> r)
  -> r)
 -> P Text)
-> (forall r.
    ParserConfig
    -> ParserState
    -> Text
    -> (FilePath -> Text -> r)
    -> (Text -> ParserState -> Text -> r)
    -> r)
-> P Text
forall a b. (a -> b) -> a -> b
$ \ParserConfig
_ ParserState
s Text
t FilePath -> Text -> r
kf Text -> ParserState -> Text -> r
ks ->
  case (Char -> Bool) -> Text -> (Text, Text)
T.span Char -> Bool
f Text
t of
    (Text
a, Text
t') | Text -> Bool
T.null Text
a -> FilePath -> Text -> r
kf FilePath
"takeWhile1" Text
t
            | Bool
otherwise -> Text -> ParserState -> Text -> r
ks Text
a ParserState
s Text
t'
{-# INLINE takeWhile1 #-}

skipWhile :: (Char -> Bool) -> P ()
skipWhile :: (Char -> Bool) -> P ()
skipWhile Char -> Bool
f = (forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (() -> ParserState -> Text -> r)
 -> r)
-> P ()
forall a.
(forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
P ((forall r.
  ParserConfig
  -> ParserState
  -> Text
  -> (FilePath -> Text -> r)
  -> (() -> ParserState -> Text -> r)
  -> r)
 -> P ())
-> (forall r.
    ParserConfig
    -> ParserState
    -> Text
    -> (FilePath -> Text -> r)
    -> (() -> ParserState -> Text -> r)
    -> r)
-> P ()
forall a b. (a -> b) -> a -> b
$ \ParserConfig
_ ParserState
s Text
t FilePath -> Text -> r
_ () -> ParserState -> Text -> r
ks -> () -> ParserState -> Text -> r
ks () ParserState
s ((Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
f Text
t)
{-# INLINE skipWhile #-}

skipMany :: P a -> P ()
skipMany :: forall a. P a -> P ()
skipMany P a
p = P ()
go
 where
  go :: P ()
go = (P a
p P a -> P () -> P ()
forall a b. P a -> P b -> P b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> P ()
go) P () -> P () -> P ()
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> () -> P ()
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

option :: Alternative f => a -> f a -> f a
option :: forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option a
x f a
p = f a
p f a -> f a -> f a
forall a. f a -> f a -> f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> a -> f a
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

choice :: [P a] -> P a
choice :: forall a. [P a] -> P a
choice = (P a -> P a -> P a) -> P a -> [P a] -> P a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr P a -> P a -> P a
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) (FilePath -> P a
forall a. FilePath -> P a
failP FilePath
"choice")

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

manyTill :: P a -> P b  -> P [a]
manyTill :: forall a b. P a -> P b -> P [a]
manyTill P a
p P b
end = P [a]
go
 where
  go :: P [a]
go = ([] [a] -> P b -> P [a]
forall a b. a -> P b -> P a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ P b
end) P [a] -> P [a] -> P [a]
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (a -> [a] -> [a]) -> P a -> P [a] -> P [a]
forall a b c. (a -> b -> c) -> P a -> P b -> P c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (:) P a
p P [a]
go

sepBy :: P a -> P b -> P [a]
sepBy :: forall a b. P a -> P b -> P [a]
sepBy P a
p P b
s = P a -> P b -> P [a]
forall a b. P a -> P b -> P [a]
sepBy1 P a
p P b
s P [a] -> P [a] -> P [a]
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [a] -> P [a]
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

sepBy1 :: P a -> P b -> P [a]
sepBy1 :: forall a b. P a -> P b -> P [a]
sepBy1 P a
p P b
s = P [a]
go
 where
  go :: P [a]
go = (a -> [a] -> [a]) -> P a -> P [a] -> P [a]
forall a b c. (a -> b -> c) -> P a -> P b -> P c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (:) P a
p ((P b
s P b -> P [a] -> P [a]
forall a b. P a -> P b -> P b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> P [a]
go) P [a] -> P [a] -> P [a]
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [a] -> P [a]
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])

--- 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)
        setFlag $ \ParseFlags
f -> ParseFlags
f{ sawInclude = True }
        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!
      setFlag $ \ParseFlags
f -> ParseFlags
f{ sawSection = True }
      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
  -- The term/definition separator must occur before the end of the
  -- line, so ordinary paragraph text can be rejected with a single
  -- substring check instead of the chunked term scan below.
  restOfLine <- lookAhead (takeWhile (not . isEndOfLine))
  guard $ "::" `T.isInfixOf` restOfLine
  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)
                   -- The marker must be followed by a space or the end of
                   -- the line, so that e.g. std::vector is not mistaken
                   -- for a term/definition separator.
                   mbc <- peekChar
                   guard $ maybe True (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char -> Bool
isEndOfLine Char
c) mbc)
  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
  -- The bare endOfInput alternative makes an unterminated block extend
  -- to the end of input; without it, manyTill would loop forever at end
  -- of input because pLine succeeds there without consuming anything.
  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))
                 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

pDelimitedBlockExact :: Char -> Int -> P [Block]
pDelimitedBlockExact :: Char -> Int -> P [Block]
pDelimitedBlockExact Char
c Int
exactNumber = do
  let fence :: P ()
fence = Int -> P () -> P [()]
forall a. Int -> P a -> P [a]
count Int
exactNumber (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 ()
fence
  BlockContext -> P [Block] -> P [Block]
forall a. BlockContext -> P a -> P a
withBlockContext (Char -> Int -> BlockContext
DelimitedContext Char
c Int
exactNumber) (P [Block] -> P [Block]) -> P [Block] -> P [Block]
forall a b. (a -> b) -> a -> b
$
    [Maybe Block] -> [Block]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Block] -> [Block]) -> P [Maybe Block] -> P [Block]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P (Maybe Block) -> P () -> P [Maybe Block]
forall a b. P a -> P b -> P [a]
manyTill P (Maybe Block)
pBlock P ()
fence

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)
  -- An unterminated block extends to the end of input; without the
  -- endOfInput alternative, manyTill would loop forever at end of input
  -- because pLine succeeds there without consuming anything.  A closing
  -- fence may be longer than the opening one; consume the extra
  -- backticks so they don't leak into the following block.
  lns <- toSourceLines <$>
    manyTill pLine ((string ticks *> skipWhile (== '`')) <|> endOfInput)
  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
  bt <- 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
          -> do (ParseFlags -> ParseFlags) -> P ()
setFlag ((ParseFlags -> ParseFlags) -> P ())
-> (ParseFlags -> ParseFlags) -> P ()
forall a b. (a -> b) -> a -> b
$ \ParseFlags
f -> ParseFlags
f{ sawInclude = True }
                BlockType -> P BlockType
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BlockType -> P BlockType) -> BlockType -> P BlockType
forall a b. (a -> b) -> a -> b
$ 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]
_ -> BlockType -> P BlockType
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BlockType -> P BlockType) -> BlockType -> P BlockType
forall a b. (a -> b) -> a -> b
$ Maybe Language -> [SourceLine] -> BlockType
Listing Maybe Language
mbLang [SourceLine]
lns
  pure $ Block attr' mbtitle bt)
 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]
pDelimitedBlockExact 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
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
"+"
      -- A definition list marker is a run of 2 to 4 colons followed by a
      -- space or the end of the line.  A mere "::" infix (e.g. in
      -- std::vector) does not start a definition list.
      let isDlistMarker :: (a, Text) -> Bool
isDlistMarker (a
_, Text
post) =
            let colons :: Text
colons = (Char -> Bool) -> Text -> Text
T.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') Text
post
                rest :: Text
rest = Int -> Text -> Text
T.drop (Text -> Int
T.length Text
colons) Text
post
            in Text -> Int
T.length Text
colons Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 Bool -> Bool -> Bool
&& Text -> Int
T.length Text
colons Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
4 Bool -> Bool -> Bool
&&
               (Text -> Bool
T.null Text
rest Bool -> Bool -> Bool
|| HasCallStack => Text -> Char
Text -> Char
T.head Text
rest Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== 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, Text) -> Bool) -> [(Text, Text)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text, Text) -> Bool
forall {a}. (a, Text) -> Bool
isDlistMarker (HasCallStack => Text -> Text -> [(Text, Text)]
Text -> Text -> [(Text, Text)]
T.breakOnAll Text
"::" 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
  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
  -- Record whether a blank line separates the opening border from the
  -- first row; if so, no header row is implied.
  leadingBlank <- not . null <$> many pBlankLine
  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
                            , 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
                            }
  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; the new row's
            -- cells only occupy the columns that are not taken up by
            -- rowspans from rows above (after decrementing, those
            -- columns have a countdown >= 0), so we skip those:
            let fillRowspans [] [a]
rs = [a]
rs
                fillRowspans [a]
vs (a
r:[a]
rs)
                  | a
r a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
0 = a
r a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
fillRowspans [a]
vs [a]
rs
                fillRowspans (a
v:[a]
vs) (a
_:[a]
rs) = a
v a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
fillRowspans [a]
vs [a]
rs
                fillRowspans [a]
_ [] = []
            let newspans = (TableCell -> [Int]) -> [TableCell] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
                  (\TableCell
c -> Int -> Int -> [Int]
forall a. Int -> a -> [a]
replicate (TableCell -> Int
cellColspan TableCell
c) (TableCell -> Int
cellRowspan TableCell
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) [TableCell]
cells
            let rowspans' = [Int] -> [Int] -> [Int]
forall {a}. (Ord a, Num a) => [a] -> [a] -> [a]
fillRowspans [Int]
newspans ((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'
  (rawRows, (rows, colspecs')) <-
    matchKeepingState (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
  -- Like Asciidoctor, imply a header row when the first row sits on a
  -- single line directly after the opening border and is followed by a
  -- blank line.
  let isBlankLine = (Char -> Bool) -> Text -> Bool
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')
  let headerImplied = Bool -> Bool
not Bool
leadingBlank Bool -> Bool -> Bool
&& Bool -> Bool
not ([TableRow] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TableRow]
rows) Bool -> Bool -> Bool
&&
        case Text -> [Text]
T.lines Text
rawRows of
          Text
_ : Text
l2 : [Text]
_ -> Text -> Bool
isBlankLine Text
l2
          [Text]
_ -> Bool
False
  let hasHeader = TableOpts -> Bool
tableHeader TableOpts
tableOpts Bool -> Bool -> Bool
||
        (Text
"noheader" Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
options Bool -> Bool -> Bool
&& Bool
headerImplied)
  let (mbHead, rest)
        | hasHeader = (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 Char -> Bool
isCellStyleChar
                             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
takeWhile (\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
  -- A cell separator match can only begin at the separator itself or
  -- at one of the characters that may precede it in a cell spec
  -- (whitespace, duplicate/span numbers, alignments, styles); a table
  -- border only at its delimiter.  Runs of other characters can be
  -- consumed at once, and the expensive lookahead for a separator or
  -- border is only needed at characters that could begin one.
  let couldStartCellSep Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
sep 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
'\t' Bool -> Bool -> Bool
||
        Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| Char -> Bool
isCellSpecChar Char
c
  let couldStartBorder 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
','
  let isPlainCellChar Char
c = Bool -> Bool
not (Char -> Bool
couldStartCellSep Char
c) Bool -> Bool -> Bool
&&
        Bool -> Bool
not (Char -> Bool
couldStartBorder Char
c) 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)
  t <- mconcat <$>
         many
          (takeWhile1 isPlainCellChar
           <|>
           (do mbc <- peekChar
               case mbc of
                 Maybe Char
Nothing -> P Text
forall a. P a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
                 Just Char
c -> do
                   Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Char -> Bool
couldStartCellSep Char
c) (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$
                     P () -> P ()
forall a. P a -> P ()
notFollowedBy (P CellData -> P ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Char -> P CellData
pCellSep Char
sep))
                   Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Char -> Bool
couldStartBorder Char
c) (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$
                     P () -> P ()
forall a. P a -> P ()
notFollowedBy (P TableSyntax -> P ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void P TableSyntax
pTableBorder)
                   -- pCellSep skips leading whitespace itself, so if it
                   -- failed at the first space of a run it fails at
                   -- every position within it; the whole run can be
                   -- consumed after a single lookahead.
                   if 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'
                      then (Char -> Bool) -> P Text
takeWhile1 (\Char
d -> Char
d Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
d Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\t')
                      else Char -> Text
T.singleton (Char -> Text) -> P Char -> P Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> 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
sep)
                          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 (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isEndOfLine)
                          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
<|> if Bool
allowNewlines
                                 then (Char -> Bool) -> P Char
satisfy Char -> Bool
isEndOfLine
                                 else (Char -> Bool) -> P Char
satisfy Char -> Bool
isEndOfLine
                                        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
<* P CellData -> P ()
forall a. P a -> P ()
notFollowedBy (Char -> P CellData
pCellSep Char
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)

-- The letters that may denote a cell style ("adehlms").
isCellStyleChar :: Char -> Bool
isCellStyleChar :: Char -> Bool
isCellStyleChar Char
c =
  case Char
c of
    Char
'a' -> Bool
True
    Char
'd' -> Bool
True
    Char
'e' -> Bool
True
    Char
'h' -> Bool
True
    Char
'l' -> Bool
True
    Char
'm' -> Bool
True
    Char
's' -> Bool
True
    Char
_   -> Bool
False

-- The characters that may occur in a cell spec (".<^>adehlms").
isCellSpecChar :: Char -> Bool
isCellSpecChar :: Char -> Bool
isCellSpecChar Char
c =
  case Char
c of
    Char
'.' -> Bool
True
    Char
'<' -> Bool
True
    Char
'^' -> Bool
True
    Char
'>' -> Bool
True
    Char
_   -> Char -> Bool
isCellStyleChar Char
c

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
  (Char -> Bool) -> P ()
skipWhile (\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')
  -- Fail fast unless the next character can actually begin a cell
  -- separator, so that speculative lookaheads stay cheap.
  mbc <- P (Maybe Char)
peekChar
  case mbc of
    Just Char
c | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
sep Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| Char -> Bool
isCellSpecChar Char
c -> () -> P ()
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Maybe Char
_ -> P ()
forall a. P a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  mult <- option 1 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 isCellStyleChar) <|> 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 = Bool -> [Text] -> P [Inline]
pInlines' Bool
False []

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 :: 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

-- The [Text] argument accumulates the plain text seen so far, in
-- reverse chunk order; prependStr turns it into a Str inline.  The
-- Bool records whether the accumulated text can contain the start of
-- a typographic replacement, so that prependStr can skip
-- replaceCharsText without rescanning the text.
pInlines' :: Bool -> [Text] -> P [Inline]
pInlines' :: Bool -> [Text] -> P [Inline]
pInlines' !Bool
trig [Text]
cs = (forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> ([Inline] -> ParserState -> Text -> r)
 -> r)
-> P [Inline]
forall a.
(forall r.
 ParserConfig
 -> ParserState
 -> Text
 -> (FilePath -> Text -> r)
 -> (a -> ParserState -> Text -> r)
 -> r)
-> P a
P ((forall r.
  ParserConfig
  -> ParserState
  -> Text
  -> (FilePath -> Text -> r)
  -> ([Inline] -> ParserState -> Text -> r)
  -> r)
 -> P [Inline])
-> (forall r.
    ParserConfig
    -> ParserState
    -> Text
    -> (FilePath -> Text -> r)
    -> ([Inline] -> ParserState -> Text -> r)
    -> r)
-> P [Inline]
forall a b. (a -> b) -> a -> b
$ \ParserConfig
cfg ParserState
st t :: Text
t@(TI.Text Array
arr Int
off Int
len) FilePath -> Text -> r
kf [Inline] -> ParserState -> Text -> r
ks ->
  -- Consume a whole run of plain characters in a single scan.  Only a
  -- few characters can require anything other than plain text: the
  -- characters that can begin an inline element or line comment, the
  -- ':' that ends a macro or autolink name, and the '@' of an email
  -- autolink.  Everything in between (letters, spaces, ordinary
  -- punctuation) is consumed here without trying any parsers.  The
  -- scan also notes replacement triggers ('-', '=', or a ".." pair).
  let chunk :: Int -> [Text]
chunk Int
i = if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then [Text]
cs else Array -> Int -> Int -> Text
TI.text Array
arr Int
off Int
i Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
cs
      go :: Int -> Bool -> Bool -> r
go !Int
i !Bool
tr !Bool
prevDot
        | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
len = [Inline] -> ParserState -> Text -> r
ks (Bool -> [Text] -> [Inline] -> [Inline]
prependStr Bool
tr (Int -> [Text]
chunk Int
i) []) ParserState
st Text
T.empty
        | Bool
otherwise =
            case Text -> Int -> Iter
TU.iter Text
t Int
i of
              TU.Iter Char
c Int
d
                | Char -> Bool
isPlainInlineChar Char
c ->
                    Int -> Bool -> Bool -> r
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d)
                       (Bool
tr 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
prevDot Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.'))
                       (Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.')
                | Bool
otherwise ->
                    P [Inline]
-> forall r.
   ParserConfig
   -> ParserState
   -> Text
   -> (FilePath -> Text -> r)
   -> ([Inline] -> ParserState -> Text -> r)
   -> r
forall a.
P a
-> forall r.
   ParserConfig
   -> ParserState
   -> Text
   -> (FilePath -> Text -> r)
   -> (a -> ParserState -> Text -> r)
   -> r
unP (Char -> Bool -> [Text] -> P [Inline]
pInlineBoundary Char
c Bool
tr (Int -> [Text]
chunk Int
i)) ParserConfig
cfg ParserState
st
                        (Array -> Int -> Int -> Text
TI.text Array
arr (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i) (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)) FilePath -> Text -> r
kf [Inline] -> ParserState -> Text -> r
ks
  in Int -> Bool -> Bool -> r
go Int
0 Bool
trig Bool
False

-- Handle a stop character of the plain-text scan (not yet consumed).
pInlineBoundary :: Char -> Bool -> [Text] -> P [Inline]
pInlineBoundary :: Char -> Bool -> [Text] -> P [Inline]
pInlineBoundary Char
c !Bool
trig [Text]
cs
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':' = Bool -> [Text] -> P [Inline] -> P [Inline]
pMacroAtColon Bool
trig [Text]
cs P [Inline]
plainChar
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'@' = Bool -> [Text] -> P [Inline] -> P [Inline]
pEmailAtBoundary Bool
trig [Text]
cs P [Inline]
plainChar
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/' = (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
*> Bool -> [Text] -> P [Inline]
pInlines' Bool
trig [Text]
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
<|> P [Inline]
plainChar
  | Bool
otherwise =
      -- An inline start character.  '+' and '_' can also occur inside
      -- the local part of an email autolink, whose attempt must come
      -- first (it can only succeed when a '@' with a valid domain
      -- follows, in which case the formatting parse would misfire).
      (if Char -> Bool
isEmailLocalChar Char
c then Bool -> [Text] -> P [Inline] -> P [Inline]
pEmailAtBoundary Bool
trig [Text]
cs else P [Inline] -> P [Inline]
forall a. a -> a
id) (P [Inline] -> P [Inline]) -> P [Inline] -> P [Inline]
forall a b. (a -> b) -> a -> b
$
      (do il' <- [Text] -> P Inline
pInline [Text]
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'
          prependStr trig cs . (il:) <$> pInlines' False [])
      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]
plainChar
 where
  -- Consume the stop character (which failed to begin anything
  -- special) as a chunk of its own; the next pInlines' scan picks up
  -- the plain run that follows.
  plainChar :: P [Inline]
plainChar = do
    _ <- P Char
anyChar
    pInlines' (trig || isTriggerStop c) (T.singleton c : cs)

-- Stop characters of the plain scan that are also replacement
-- triggers.  ('-', '=' and '.' are not stop characters, so they are
-- detected by the pInlines' scan instead; a ".." pair cannot
-- straddle two chunks, since the character between them is a stop
-- character and hence not a '.'.)
isTriggerStop :: Char -> Bool
isTriggerStop :: Char -> Bool
isTriggerStop 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
'<'

-- Characters that cannot begin an inline element or line comment, end
-- a macro or autolink name, or start the domain of an email autolink.
-- A run of them can be consumed at once without trying any parsers.
isPlainInlineChar :: Char -> Bool
isPlainInlineChar :: Char -> Bool
isPlainInlineChar Char
c =
  case Char
c of
    Char
'*'  -> Bool
False
    Char
'_'  -> Bool
False
    Char
'`'  -> Bool
False
    Char
'#'  -> Bool
False
    Char
'~'  -> Bool
False
    Char
'^'  -> Bool
False
    Char
'+'  -> Bool
False
    Char
'"'  -> Bool
False
    Char
'\'' -> Bool
False
    Char
'('  -> Bool
False
    Char
'{'  -> Bool
False
    Char
'\\' -> Bool
False
    Char
'<'  -> Bool
False
    Char
'&'  -> Bool
False
    Char
'['  -> Bool
False
    Char
'/'  -> Bool
False
    Char
':'  -> Bool
False
    Char
'@'  -> Bool
False
    Char
_    -> Bool
True

-- The Bool says whether the text can contain the start of a
-- typographic replacement; it is tracked during scanning so that no
-- extra pass over the text is needed here.
prependStr :: Bool -> [Text] -> [Inline] -> [Inline]
prependStr :: Bool -> [Text] -> [Inline] -> [Inline]
prependStr Bool
_ [] = [Inline] -> [Inline]
forall a. a -> a
id
prependStr Bool
trig [Text]
cs =
  (Attr -> InlineType -> Inline
Inline Attr
forall a. Monoid a => a
mempty (Text -> InlineType
Str (Text -> Text
replaced ([Text] -> Text
T.concat ([Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
cs))))Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
:)
 where
  replaced :: Text -> Text
replaced = if Bool
trig then Text -> Text
replaceCharsText else Text -> Text
forall a. a -> a
id

-- A macro or autolink name ends at a ':'.  A name contains no
-- plain-scan stop characters, so it must be a suffix of the plain
-- text accumulated since the last boundary; only the few candidates
-- whose last character matches the character before the ':' need to
-- be checked, leftmost (i.e. longest) first.  This also covers names
-- with a non-letter tail like indexterm2, whose '2' was consumed by
-- the plain scan.
pMacroAtColon :: Bool -> [Text] -> P [Inline] -> P [Inline]
pMacroAtColon :: Bool -> [Text] -> P [Inline] -> P [Inline]
pMacroAtColon Bool
trig (Text
piece : [Text]
rest) P [Inline]
alt
  | Bool -> Bool
not (Text -> Bool
T.null Text
piece)
  , Just [(Text, P Inline)]
candidates <- Char -> Map Char [(Text, P Inline)] -> Maybe [(Text, P Inline)]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (HasCallStack => Text -> Char
Text -> Char
T.last Text
piece) Map Char [(Text, P Inline)]
nestedInlineStartsByLastChar
  = ((Text, P Inline) -> P [Inline] -> P [Inline])
-> P [Inline] -> [(Text, P Inline)] -> P [Inline]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Text, P Inline) -> P [Inline] -> P [Inline]
tryCandidate P [Inline]
alt [(Text, P Inline)]
candidates
 where
  tryCandidate :: (Text, P Inline) -> P [Inline] -> P [Inline]
tryCandidate (Text
name, P Inline
p) P [Inline]
alt'
    | Text
name Text -> Text -> Bool
`T.isSuffixOf` Text
piece =
        (do Char -> P ()
vchar Char
':'
            il <- P Inline
p
            let pre = Int -> Text -> Text
T.dropEnd (Text -> Int
T.length Text
name) Text
piece
            let cs' = if Text -> Bool
T.null Text
pre then [Text]
rest else Text
pre Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
rest
            prependStr trig cs' . (il:) <$> pInlines' False []) 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]
alt'
    | Bool
otherwise = P [Inline]
alt'
pMacroAtColon Bool
_ [Text]
_ P [Inline]
alt = P [Inline]
alt

-- Try email autolinks at a '@' (or at a '+' or '_', which can occur
-- inside a local part).  A local part starts at the beginning of a
-- run of letters; every candidate start lies in the trailing run of
-- email-local characters of the accumulated plain text.  Try each,
-- leftmost first.  Starts in earlier chunks need not be considered:
-- any that could reach this position was already tried, with the same
-- local part and input position, at the boundary ending its chunk.
pEmailAtBoundary :: Bool -> [Text] -> P [Inline] -> P [Inline]
pEmailAtBoundary :: Bool -> [Text] -> P [Inline] -> P [Inline]
pEmailAtBoundary Bool
trig (Text
piece : [Text]
rest) P [Inline]
alt
  | Bool -> Bool
not (Text -> Bool
T.null Text
localSpan) = (Text -> P [Inline] -> P [Inline])
-> P [Inline] -> [Text] -> P [Inline]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Text -> P [Inline] -> P [Inline]
tryStart P [Inline]
alt (Text -> [Text]
emailStarts Text
localSpan)
 where
  localSpan :: Text
localSpan = (Char -> Bool) -> Text -> Text
T.takeWhileEnd Char -> Bool
isEmailLocalChar Text
piece
  tryStart :: Text -> P [Inline] -> P [Inline]
tryStart Text
sfx P [Inline]
alt' =
    (do more <- (Char -> Bool) -> P Text
takeWhile Char -> Bool
isEmailLocalChar
        il <- pEmailAutolinkRest (sfx <> more)
        let pre = Int -> Text -> Text
T.dropEnd (Text -> Int
T.length Text
sfx) Text
piece
        let cs' = if Text -> Bool
T.null Text
pre then [Text]
rest else Text
pre Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
rest
        prependStr trig cs' . (il:) <$> pInlines' False []) 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]
alt'
pEmailAtBoundary Bool
_ [Text]
_ P [Inline]
alt = P [Inline]
alt

-- Suffixes of the given text beginning at the start of a run of
-- letters, leftmost first: the candidate starts of an email
-- autolink's local part.
emailStarts :: Text -> [Text]
emailStarts :: Text -> [Text]
emailStarts Text
t
  | Text -> Bool
T.null Text
t' = []
  | Bool
otherwise = Text
t' Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text -> [Text]
emailStarts ((Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isLetter Text
t')
 where
  t' :: Text
t' = (Char -> Bool) -> Text -> Text
T.dropWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isLetter) Text
t

-- Possible macro and autolink names, as (name, parser for what
-- follows the name and ':').  Sorted by decreasing name length, so
-- that the leftmost match within a run of plain text wins; macros
-- come before autolink schemes of the same name.
nestedInlineStarts :: [(Text, P Inline)]
nestedInlineStarts :: [(Text, P Inline)]
nestedInlineStarts =
  ((Text, P Inline) -> Int)
-> [(Text, P Inline)] -> [(Text, P Inline)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (\(Text
name, P Inline
_) -> Int -> Int
forall a. Num a => a -> a
negate (Text -> Int
T.length Text
name)) ([(Text, P Inline)] -> [(Text, P Inline)])
-> [(Text, P Inline)] -> [(Text, P Inline)]
forall a b. (a -> b) -> a -> b
$
    [ (Text
name, Text -> P Inline
pInlineMacroTarget Text
name) | Text
name <- Map Text (Text -> P Inline) -> [Text]
forall k a. Map k a -> [k]
M.keys Map Text (Text -> P Inline)
inlineMacros ] [(Text, P Inline)] -> [(Text, P Inline)] -> [(Text, P Inline)]
forall a. [a] -> [a] -> [a]
++
    [ (Text
scheme, Text -> P Inline
pAutolinkTarget (Text
scheme Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":")) | Text
scheme <- [Text]
autolinkSchemes ]

-- The same candidates indexed by the last character of the name, so
-- that a ':' boundary only has to check the few candidates that could
-- end just before it, preserving the order of nestedInlineStarts
-- within a bucket.
nestedInlineStartsByLastChar :: M.Map Char [(Text, P Inline)]
nestedInlineStartsByLastChar :: Map Char [(Text, P Inline)]
nestedInlineStartsByLastChar =
  ([(Text, P Inline)] -> [(Text, P Inline)] -> [(Text, P Inline)])
-> [(Char, [(Text, P Inline)])] -> Map Char [(Text, P Inline)]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith (([(Text, P Inline)] -> [(Text, P Inline)] -> [(Text, P Inline)])
-> [(Text, P Inline)] -> [(Text, P Inline)] -> [(Text, P Inline)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [(Text, P Inline)] -> [(Text, P Inline)] -> [(Text, P Inline)]
forall a. [a] -> [a] -> [a]
(++))
    [ (HasCallStack => Text -> Char
Text -> Char
T.last Text
name, [(Text, P Inline)
x]) | x :: (Text, P Inline)
x@(Text
name, P Inline
_) <- [(Text, P Inline)]
nestedInlineStarts ]

-- Apply typographic replacements in a single pass, splicing
-- replacements between unchanged slices of the input.  Equivalent to
-- matching, at each position, the first of these patterns (x and y
-- are arbitrary characters):
--
--   (C) (R) (TM)             -> copyright, registered, trademark sign
--   " -- "                   -> thin space, em dash, thin space
--   x--y  (x, y alphanumeric)-> x, em dash, zero-width space, y...
--   x--y  (otherwise)        -> unchanged (consuming x "--")
--   ...                      -> ellipsis
--   ->  =>  <-  <=           -> arrows
--   '                        -> right single quotation mark
replaceCharsText :: Text -> Text
replaceCharsText :: Text -> Text
replaceCharsText t :: Text
t@(TI.Text Array
arr Int
toff Int
len) = [Text] -> Int -> Int -> Char -> Text
go [] Int
0 Int
0 Char
'\0'
 where
  slice :: Int -> Int -> Text
slice Int
s Int
e = Array -> Int -> Int -> Text
TI.text Array
arr (Int
toff Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
s) (Int
e Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
s)
  charAt :: Int -> Char
charAt Int
j = case Text -> Int -> Iter
TU.iter Text
t Int
j of TU.Iter Char
c Int
_ -> Char
c
  -- acc: finished output pieces in reverse order; s: start of the
  -- current unchanged run; i: current position (byte offsets); prev:
  -- the character ending at i (only meaningful when i > s).
  go :: [Text] -> Int -> Int -> Char -> Text
go [Text]
acc !Int
s !Int
i !Char
prev
    | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
len =
        case [Text]
acc of
          [] -> Text
t                              -- nothing was replaced
          [Text]
_ -> [Text] -> Text
T.concat ([Text] -> [Text]
forall a. [a] -> [a]
reverse (Int -> Int -> Text
slice Int
s Int
i Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
acc))
    | Bool
otherwise =
        case Char
c0 of
          Char
'-' | Int
i1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len, Int -> Char
charAt Int
i1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' ->  -- a "--" pair at (i, i1)
                  if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
s Bool -> Bool -> Bool
&& Int
i2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len
                    then                       -- x--y with x = prev
                      let y :: Char
y = Int -> Char
charAt Int
i2
                      in if Char
prev Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
&& Char
y Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' '
                           then Int -> Text -> Int -> Text
emit (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Text
"\8201\8212\8201" (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3)
                         else if Char -> Bool
isAlphaNum Char
prev Bool -> Bool -> Bool
&& Char -> Bool
isAlphaNum Char
y
                           then Int -> Text -> Int -> Text
emit Int
i Text
"\8212\8203" Int
i2
                         else [Text] -> Int -> Int -> Char -> Text
go [Text]
acc Int
s Int
i2 Char
'-'  -- x "--" kept as-is
                    else if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
s Bool -> Bool -> Bool
&& Int
i2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len Bool -> Bool -> Bool
&& Int -> Char
charAt Int
i2 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-'
                            Bool -> Bool -> Bool
&& Int
i3 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len
                           then [Text] -> Int -> Int -> Char -> Text
go [Text]
acc Int
s Int
i3 Char
'-' -- x--y, x a dash itself
                           else Text
plain
              | Int
i1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len, Int -> Char
charAt Int
i1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'>' -> Int -> Text -> Int -> Text
emit Int
i Text
"\8594" Int
i2
          Char
'(' | Int
i2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len, Int -> Char
charAt Int
i2 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
')', Int -> Char
charAt Int
i1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'C' ->
                  Int -> Text -> Int -> Text
emit Int
i Text
"\169" Int
i3
              | Int
i2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len, Int -> Char
charAt Int
i2 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
')', Int -> Char
charAt Int
i1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'R' ->
                  Int -> Text -> Int -> Text
emit Int
i Text
"\174" Int
i3
              | Int
i3 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len, Int -> Char
charAt Int
i1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'T', Int -> Char
charAt Int
i2 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'M',
                Int -> Char
charAt Int
i3 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
')' -> Int -> Text -> Int -> Text
emit Int
i Text
"\8482" (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4)
          Char
'.' | Int
i2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len, Int -> Char
charAt Int
i1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.', Int -> Char
charAt Int
i2 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' ->
                  Int -> Text -> Int -> Text
emit Int
i Text
"\8230" Int
i3
          Char
'=' | Int
i1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len, Int -> Char
charAt Int
i1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'>' -> Int -> Text -> Int -> Text
emit Int
i Text
"\8658" Int
i2
          Char
'<' | Int
i1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len, Int -> Char
charAt Int
i1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' ->
                  if Int
i2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len Bool -> Bool -> Bool
&& Int -> Char
charAt Int
i2 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
&& Int
i3 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len
                    then [Text] -> Int -> Int -> Char -> Text
go [Text]
acc Int
s Int
i3 Char
'-'       -- x--y with x = '<'
                    else Int -> Text -> Int -> Text
emit Int
i Text
"\8592" Int
i2
              | Int
i1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len, Int -> Char
charAt Int
i1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'=' -> Int -> Text -> Int -> Text
emit Int
i Text
"\8656" Int
i2
          Char
'\'' | Int
i2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len, Int -> Char
charAt Int
i1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-', Int -> Char
charAt Int
i2 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-',
                 Int
i3 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len -> [Text] -> Int -> Int -> Char -> Text
go [Text]
acc Int
s Int
i3 Char
'-'   -- x--y with x = '\''
               | Bool
otherwise -> Int -> Text -> Int -> Text
emit Int
i Text
"\8217" Int
i1
          Char
_ -> Text
plain
    where
      TU.Iter Char
c0 Int
d0 = Text -> Int -> Iter
TU.iter Text
t Int
i
      i1 :: Int
i1 = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
      i2 :: Int
i2 = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2
      i3 :: Int
i3 = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3
      plain :: Text
plain = [Text] -> Int -> Int -> Char -> Text
go [Text]
acc Int
s (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d0) Char
c0
      emit :: Int -> Text -> Int -> Text
emit Int
e Text
piece Int
j =
        let acc' :: [Text]
acc' | Int
e Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
s = Text
piece Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Int -> Int -> Text
slice Int
s Int
e Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
acc
                 | Bool
otherwise = Text
piece Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
acc
        in [Text] -> Int -> Int -> Char -> Text
go [Text]
acc' Int
j Int
j Char
'\0'

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 :: [Text] -> P Inline
pInline :: [Text] -> P Inline
pInline [Text]
prevChars = do
  -- The chunks in prevChars are non-empty by construction.
  let maybeUnconstrained :: Bool
maybeUnconstrained = case [Text]
prevChars of
                              (Text
t:[Text]
_) -> let d :: Char
d = HasCallStack => Text -> Char
Text -> Char
T.last Text
t
                                       in 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
               -- macros, autolinks and email autolinks are handled
               -- at the ':' and '@' boundaries in pInlineBoundary
               Char
_ -> 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] -> do
      (ParseFlags -> ParseFlags) -> P ()
setFlag ((ParseFlags -> ParseFlags) -> P ())
-> (ParseFlags -> ParseFlags) -> P ()
forall a b. (a -> b) -> a -> b
$ \ParseFlags
f -> ParseFlags
f{ sawCrossReference = True }
      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)
  t <- pMatchedContent isDoubled delim
  guard $ not $ T.null t
  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

-- Scan the content of a delimited span up to and including the closing
-- delimiter (doubled or single), consuming runs of plain characters in
-- chunks rather than character by character.  A backslash escapes the
-- delimiter; in doubled mode a lone delimiter is content.
pMatchedContent :: Bool -> Char -> P Text
pMatchedContent :: Bool -> Char -> P Text
pMatchedContent Bool
isDoubled Char
delim = [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]
go
 where
  closing :: P ()
closing = if Bool
isDoubled
               then Char -> P ()
vchar Char
delim 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
delim
               else Char -> P ()
vchar Char
delim
  go :: P [Text]
go = ([] [Text] -> P () -> P [Text]
forall a b. a -> P b -> P a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ P ()
closing) 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 -> [Text] -> [Text]) -> P Text -> P ([Text] -> [Text])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Text
piece P ([Text] -> [Text]) -> P [Text] -> P [Text]
forall a b. P (a -> b) -> P a -> P b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> P [Text]
go)
  piece :: P Text
piece = (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
'\\')
      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 -> P Char
char Char
delim) 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 -> P Text
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 -> Text
T.singleton (Char -> Text) -> P Char -> P Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> P Char
char Char
delim)
          -- only reachable in doubled mode, when the delimiter is not
          -- part of a closing pair

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
<$> (P Int
forall a. Integral a => P 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
';')
  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

-- Parse the part of an inline macro after the name and ':'.
pInlineMacroTarget :: Text -> P Inline
pInlineMacroTarget :: Text -> P Inline
pInlineMacroTarget Text
name = do
  let targetChars :: P Text
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 <- [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 P Text
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
        mbtext <- if null ils
                     then Nothing <$ setFlag (\ParseFlags
f -> ParseFlags
f{ sawCrossReference = True })
                     else pure (Just 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)


isEmailLocalChar :: Char -> Bool
isEmailLocalChar :: Char -> Bool
isEmailLocalChar 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
'+'

-- Parse the part of an email autolink after the local part.
pEmailAutolinkRest :: Text -> P Inline
pEmailAutolinkRest :: Text -> P Inline
pEmailAutolinkRest Text
a = do
  Char -> P ()
vchar Char
'@'
  b <- (Char -> Bool) -> P Text
takeWhile1 Char -> Bool
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
  (description, attr') <- pLinkDescription <|> pure (mempty, mempty)
  Inline attr' . Link EmailLink (Target email)
           <$> if T.null description
                  then pure [Inline mempty (Str email)]
                  else parseInlines description

autolinkSchemes :: [Text]
autolinkSchemes :: [Text]
autolinkSchemes = [Text
"http", Text
"https", Text
"irc", Text
"ftp", Text
"mailto"]

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
s -> Text -> P Text
string (Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":")) [Text]
autolinkSchemes)
  pAutolinkTarget scheme

-- Parse the part of an autolink after the scheme (which includes the
-- trailing ':').
pAutolinkTarget :: Text -> P Inline
pAutolinkTarget :: Text -> P Inline
pAutolinkTarget Text
scheme = do
  let isSpecialPunct :: Char -> Bool
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 :: P Text
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 <- (Text
scheme Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (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]
some
          (P Text
urlChunk 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))
  (description, attr') <- pLinkDescription <|> pure (mempty, mempty)
  Inline attr' . Link URLLink (Target url)
             <$> if T.null description
                    then pure [Inline mempty (Str url)]
                    else parseInlines description

pLinkDescription :: P (Text, Attr)
pLinkDescription :: P (Text, Attr)
pLinkDescription = do
  Char -> P ()
vchar Char
'['
  -- parse link description
  let literalPart :: P Text
literalPart = (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
'=')
  description <- Text -> P Text -> P Text
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option Text
forall a. Monoid a => a
mempty (P Text -> P Text) -> P Text -> P Text
forall a b. (a -> b) -> a -> b
$
                    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
<|> [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 (P Text
literalPart
                         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
"," Text -> P () -> P Text
forall a b. a -> P b -> P a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> P ()
vchar 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
<* P (Text, Text) -> P ()
forall a. P a -> P ()
notFollowedBy P (Text, Text)
pKeyValue))
  -- parse (optional) attributes
  kvs <- option []
         (do unless (description == mempty) pComma
             sepBy pKeyValue pComma <* option () pComma)
  vchar ']'
  pure (description, Attr mempty (M.fromList kvs))


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 (LowerAlphaCounter, 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 -> do
      -- Resolve document attributes at the point of use, so that a
      -- reference sees the value in effect where it occurs.  References
      -- to attributes defined later are left unresolved here and get
      -- the end-of-document value in a post-processing pass.
      attrs <- (ParserState -> Map Text Text) -> P (Map Text Text)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ParserState -> Map Text Text
docAttrs
      case M.lookup name attrs of
        Just Text
v -> 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
v)
        Maybe Text
Nothing -> do
          (ParseFlags -> ParseFlags) -> P ()
setFlag ((ParseFlags -> ParseFlags) -> P ())
-> (ParseFlags -> ParseFlags) -> P ()
forall a b. (a -> b) -> a -> b
$ \ParseFlags
f -> ParseFlags
f{ sawAttributeReference = True }
          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
""