{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Text.Pandoc.Readers.CommonMark (readCommonMark)
where
import Commonmark
import Commonmark.Extensions
import Commonmark.Pandoc
import Data.Text (Text)
import Text.Pandoc.Class.PandocMonad (PandocMonad)
import Text.Pandoc.Definition
import Text.Pandoc.Builder as B
import Text.Pandoc.Options
import Text.Pandoc.Error
import Text.Pandoc.Readers.Metadata (yamlMetaBlock)
import Control.Monad.Except
import Data.Functor.Identity (runIdentity)
import Data.Typeable
import Text.Pandoc.Parsing (runParserT, getInput, getPosition,
runF, defaultParserState, option, many1, anyChar,
Sources(..), ToSources(..), ParserT, Future,
sourceName, sourceLine, incSourceLine)
import Text.Pandoc.Walk (walk)
import qualified Data.Text as T
import qualified Data.Attoparsec.Text as A
import Control.Applicative ((<|>))
readCommonMark :: (PandocMonad m, ToSources a)
=> ReaderOptions -> a -> m Pandoc
readCommonMark :: forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readCommonMark ReaderOptions
opts a
s
| forall a. HasSyntaxExtensions a => Extension -> a -> Bool
isEnabled Extension
Ext_yaml_metadata_block ReaderOptions
opts = do
let sources :: Sources
sources = forall a. ToSources a => a -> Sources
toSources a
s
let firstSourceName :: SourceName
firstSourceName = case Sources -> [(SourcePos, Text)]
unSources Sources
sources of
((SourcePos
pos,Text
_):[(SourcePos, Text)]
_) -> SourcePos -> SourceName
sourceName SourcePos
pos
[(SourcePos, Text)]
_ -> SourceName
""
let toks :: [Tok]
toks = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (SourcePos, Text) -> [Tok]
sourceToToks (Sources -> [(SourcePos, Text)]
unSources Sources
sources)
Either ParseError (Future ParserState Meta, Sources)
res <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> u -> SourceName -> s -> m (Either ParseError a)
runParserT (do Future ParserState Meta
meta <- forall st (m :: * -> *).
(HasLastStrPosition st, PandocMonad m) =>
ParserT Sources st m (Future st MetaValue)
-> ParserT Sources st m (Future st Meta)
yamlMetaBlock (forall (m :: * -> *) st.
Monad m =>
ReaderOptions -> ParserT Sources st m (Future st MetaValue)
metaValueParser ReaderOptions
opts)
SourcePos
pos <- forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
Sources
rest <- forall (m :: * -> *) s u. Monad m => ParsecT s u m s
getInput
let rest' :: Sources
rest' = case Sources
rest of
Sources ((SourcePos
_,Text
t):[(SourcePos, Text)]
xs) -> [(SourcePos, Text)] -> Sources
Sources ((SourcePos
pos,Text
t)forall a. a -> [a] -> [a]
:[(SourcePos, Text)]
xs)
Sources
_ -> Sources
rest
forall (m :: * -> *) a. Monad m => a -> m a
return (Future ParserState Meta
meta, Sources
rest'))
ParserState
defaultParserState SourceName
firstSourceName Sources
sources
case Either ParseError (Future ParserState Meta, Sources)
res of
Left ParseError
_ -> forall (m :: * -> *).
PandocMonad m =>
ReaderOptions -> Sources -> [Tok] -> m Pandoc
readCommonMarkBody ReaderOptions
opts Sources
sources [Tok]
toks
Right (Future ParserState Meta
meta, Sources
rest) -> do
let body :: [Tok]
body = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (SourcePos, Text) -> [Tok]
sourceToToks (Sources -> [(SourcePos, Text)]
unSources Sources
rest)
Pandoc Meta
_ [Block]
bs <- forall (m :: * -> *).
PandocMonad m =>
ReaderOptions -> Sources -> [Tok] -> m Pandoc
readCommonMarkBody ReaderOptions
opts Sources
sources [Tok]
body
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Meta -> [Block] -> Pandoc
Pandoc (forall s a. Future s a -> s -> a
runF Future ParserState Meta
meta ParserState
defaultParserState) [Block]
bs
| Bool
otherwise = do
let sources :: Sources
sources = forall a. ToSources a => a -> Sources
toSources a
s
let toks :: [Tok]
toks = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (SourcePos, Text) -> [Tok]
sourceToToks (Sources -> [(SourcePos, Text)]
unSources Sources
sources)
forall (m :: * -> *).
PandocMonad m =>
ReaderOptions -> Sources -> [Tok] -> m Pandoc
readCommonMarkBody ReaderOptions
opts Sources
sources [Tok]
toks
sourceToToks :: (SourcePos, Text) -> [Tok]
sourceToToks :: (SourcePos, Text) -> [Tok]
sourceToToks (SourcePos
pos, Text
s) = forall a b. (a -> b) -> [a] -> [b]
map Tok -> Tok
adjust forall a b. (a -> b) -> a -> b
$ SourceName -> Text -> [Tok]
tokenize (SourcePos -> SourceName
sourceName SourcePos
pos) Text
s
where
adjust :: Tok -> Tok
adjust = case SourcePos -> Line
sourceLine SourcePos
pos of
Line
1 -> forall a. a -> a
id
Line
n -> \Tok
tok -> Tok
tok{ tokPos :: SourcePos
tokPos =
SourcePos -> Line -> SourcePos
incSourceLine (Tok -> SourcePos
tokPos Tok
tok) (Line
n forall a. Num a => a -> a -> a
- Line
1) }
metaValueParser :: Monad m
=> ReaderOptions -> ParserT Sources st m (Future st MetaValue)
metaValueParser :: forall (m :: * -> *) st.
Monad m =>
ReaderOptions -> ParserT Sources st m (Future st MetaValue)
metaValueParser ReaderOptions
opts = do
Text
inp <- forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option Text
"" forall a b. (a -> b) -> a -> b
$ SourceName -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 forall (m :: * -> *) s u.
(Monad m, Stream s m Char, UpdateSourcePos s Char) =>
ParsecT s u m Char
anyChar
let toks :: [Tok]
toks = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (SourcePos, Text) -> [Tok]
sourceToToks (Sources -> [(SourcePos, Text)]
unSources (forall a. ToSources a => a -> Sources
toSources Text
inp))
case forall a. Identity a -> a
runIdentity (forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il) =>
SyntaxSpec m il bl -> [Tok] -> m (Either ParseError bl)
parseCommonmarkWith (forall (m :: * -> *) a.
(Monad m, Typeable m, Typeable a, Rangeable (Cm a Inlines),
Rangeable (Cm a Blocks)) =>
ReaderOptions -> SyntaxSpec m (Cm a Inlines) (Cm a Blocks)
specFor ReaderOptions
opts) [Tok]
toks) of
Left ParseError
_ -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
Right (Cm Blocks
bls :: Cm () Blocks) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. ToMetaValue a => a -> MetaValue
B.toMetaValue Blocks
bls
readCommonMarkBody :: PandocMonad m => ReaderOptions -> Sources -> [Tok] -> m Pandoc
readCommonMarkBody :: forall (m :: * -> *).
PandocMonad m =>
ReaderOptions -> Sources -> [Tok] -> m Pandoc
readCommonMarkBody ReaderOptions
opts Sources
s [Tok]
toks =
(if ReaderOptions -> Bool
readerStripComments ReaderOptions
opts
then forall a b. Walkable a b => (a -> a) -> b -> b
walk Block -> Block
stripBlockComments forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Walkable a b => (a -> a) -> b -> b
walk Inline -> Inline
stripInlineComments
else forall a. a -> a
id) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
if forall a. HasSyntaxExtensions a => Extension -> a -> Bool
isEnabled Extension
Ext_sourcepos ReaderOptions
opts
then case forall a. Identity a -> a
runIdentity (forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il) =>
SyntaxSpec m il bl -> [Tok] -> m (Either ParseError bl)
parseCommonmarkWith (forall (m :: * -> *) a.
(Monad m, Typeable m, Typeable a, Rangeable (Cm a Inlines),
Rangeable (Cm a Blocks)) =>
ReaderOptions -> SyntaxSpec m (Cm a Inlines) (Cm a Blocks)
specFor ReaderOptions
opts) [Tok]
toks) of
Left ParseError
err -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Sources -> ParseError -> PandocError
PandocParsecError Sources
s ParseError
err
Right (Cm Blocks
bls :: Cm SourceRange Blocks) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Blocks -> Pandoc
B.doc Blocks
bls
else case forall a. Identity a -> a
runIdentity (forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il) =>
SyntaxSpec m il bl -> [Tok] -> m (Either ParseError bl)
parseCommonmarkWith (forall (m :: * -> *) a.
(Monad m, Typeable m, Typeable a, Rangeable (Cm a Inlines),
Rangeable (Cm a Blocks)) =>
ReaderOptions -> SyntaxSpec m (Cm a Inlines) (Cm a Blocks)
specFor ReaderOptions
opts) [Tok]
toks) of
Left ParseError
err -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Sources -> ParseError -> PandocError
PandocParsecError Sources
s ParseError
err
Right (Cm Blocks
bls :: Cm () Blocks) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Blocks -> Pandoc
B.doc Blocks
bls
stripBlockComments :: Block -> Block
(RawBlock (B.Format Text
"html") Text
s) =
Format -> Text -> Block
RawBlock (Text -> Format
B.Format Text
"html") (Text -> Text
removeComments Text
s)
stripBlockComments Block
x = Block
x
stripInlineComments :: Inline -> Inline
(RawInline (B.Format Text
"html") Text
s) =
Format -> Text -> Inline
RawInline (Text -> Format
B.Format Text
"html") (Text -> Text
removeComments Text
s)
stripInlineComments Inline
x = Inline
x
removeComments :: Text -> Text
Text
s =
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const Text
s) forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> Text -> Either SourceName a
A.parseOnly Parser Text Text
pRemoveComments Text
s
where
pRemoveComments :: Parser Text Text
pRemoveComments = forall a. Monoid a => [a] -> a
mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
A.many'
(Text
"" forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Text -> Parser Text Text
A.string Text
"<!--" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s. s -> (s -> Char -> Maybe s) -> Parser Text Text
A.scan (Line
0 :: Int) forall {a}. (Num a, Ord a) => a -> Char -> Maybe a
scanChar forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
A.char Char
'>') forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
((Char -> Bool) -> Parser Text Text
A.takeWhile1 (forall a. Eq a => a -> a -> Bool
/= Char
'<')) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
(Text -> Parser Text Text
A.string Text
"<"))
scanChar :: a -> Char -> Maybe a
scanChar a
st Char
c =
case Char
c of
Char
'-' -> forall a. a -> Maybe a
Just (a
st forall a. Num a => a -> a -> a
+ a
1)
Char
'>' | a
st forall a. Ord a => a -> a -> Bool
>= a
2 -> forall a. Maybe a
Nothing
Char
_ -> forall a. a -> Maybe a
Just a
0
specFor :: (Monad m, Typeable m, Typeable a,
Rangeable (Cm a Inlines), Rangeable (Cm a Blocks))
=> ReaderOptions -> SyntaxSpec m (Cm a Inlines) (Cm a Blocks)
specFor :: forall (m :: * -> *) a.
(Monad m, Typeable m, Typeable a, Rangeable (Cm a Inlines),
Rangeable (Cm a Blocks)) =>
ReaderOptions -> SyntaxSpec m (Cm a Inlines) (Cm a Blocks)
specFor ReaderOptions
opts = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a b. (a -> b) -> a -> b
($) forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il) =>
SyntaxSpec m il bl
defaultSyntaxSpec [SyntaxSpec m (Cm a Inlines) (Cm a Blocks)
-> SyntaxSpec m (Cm a Inlines) (Cm a Blocks)]
exts
where
exts :: [SyntaxSpec m (Cm a Inlines) (Cm a Blocks)
-> SyntaxSpec m (Cm a Inlines) (Cm a Blocks)]
exts = [ (forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il) =>
SyntaxSpec m il bl
hardLineBreaksSpec forall a. Semigroup a => a -> a -> a
<>) | forall a. HasSyntaxExtensions a => Extension -> a -> Bool
isEnabled Extension
Ext_hard_line_breaks ReaderOptions
opts ] forall a. [a] -> [a] -> [a]
++
[ (forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il, HasQuoted il) =>
SyntaxSpec m il bl
smartPunctuationSpec forall a. Semigroup a => a -> a -> a
<>) | forall a. HasSyntaxExtensions a => Extension -> a -> Bool
isEnabled Extension
Ext_smart ReaderOptions
opts ] forall a. [a] -> [a] -> [a]
++
[ (forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il, HasStrikethrough il) =>
SyntaxSpec m il bl
strikethroughSpec forall a. Semigroup a => a -> a -> a
<>) | forall a. HasSyntaxExtensions a => Extension -> a -> Bool
isEnabled Extension
Ext_strikeout ReaderOptions
opts ] forall a. [a] -> [a] -> [a]
++
[ (forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il, HasSuperscript il) =>
SyntaxSpec m il bl
superscriptSpec forall a. Semigroup a => a -> a -> a
<>) | forall a. HasSyntaxExtensions a => Extension -> a -> Bool
isEnabled Extension
Ext_superscript ReaderOptions
opts ] forall a. [a] -> [a] -> [a]
++
[ (forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il, HasSubscript il) =>
SyntaxSpec m il bl
subscriptSpec forall a. Semigroup a => a -> a -> a
<>) | forall a. HasSyntaxExtensions a => Extension -> a -> Bool
isEnabled Extension
Ext_subscript ReaderOptions
opts ] forall a. [a] -> [a] -> [a]
++
[ (forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il, HasMath il) =>
SyntaxSpec m il bl
mathSpec forall a. Semigroup a => a -> a -> a
<>) | forall a. HasSyntaxExtensions a => Extension -> a -> Bool
isEnabled Extension
Ext_tex_math_dollars ReaderOptions
opts ] forall a. [a] -> [a] -> [a]
++
[ (forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il) =>
SyntaxSpec m il bl
fancyListSpec forall a. Semigroup a => a -> a -> a
<>) | forall a. HasSyntaxExtensions a => Extension -> a -> Bool
isEnabled Extension
Ext_fancy_lists ReaderOptions
opts ] forall a. [a] -> [a] -> [a]
++
[ (forall (m :: * -> *) il bl.
(Monad m, IsInline il, IsBlock il bl, HasDiv bl) =>
SyntaxSpec m il bl
fencedDivSpec forall a. Semigroup a => a -> a -> a
<>) | forall a. HasSyntaxExtensions a => Extension -> a -> Bool
isEnabled Extension
Ext_fenced_divs ReaderOptions
opts ] forall a. [a] -> [a] -> [a]
++
[ (forall (m :: * -> *) il bl.
(Monad m, IsInline il, HasSpan il) =>
SyntaxSpec m il bl
bracketedSpanSpec forall a. Semigroup a => a -> a -> a
<>) | forall a. HasSyntaxExtensions a => Extension -> a -> Bool
isEnabled Extension
Ext_bracketed_spans ReaderOptions
opts ] forall a. [a] -> [a] -> [a]
++
[ (forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl) =>
SyntaxSpec m il bl
rawAttributeSpec forall a. Semigroup a => a -> a -> a
<>) | forall a. HasSyntaxExtensions a => Extension -> a -> Bool
isEnabled Extension
Ext_raw_attribute ReaderOptions
opts ] forall a. [a] -> [a] -> [a]
++
[ (forall (m :: * -> *) il bl.
(Monad m, IsInline il) =>
SyntaxSpec m il bl
attributesSpec forall a. Semigroup a => a -> a -> a
<>) | forall a. HasSyntaxExtensions a => Extension -> a -> Bool
isEnabled Extension
Ext_attributes ReaderOptions
opts ] forall a. [a] -> [a] -> [a]
++
[ (forall a. Semigroup a => a -> a -> a
<> forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il, HasPipeTable il bl) =>
SyntaxSpec m il bl
pipeTableSpec) | forall a. HasSyntaxExtensions a => Extension -> a -> Bool
isEnabled Extension
Ext_pipe_tables ReaderOptions
opts ] forall a. [a] -> [a] -> [a]
++
[ (forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il) =>
SyntaxSpec m il bl
autolinkSpec forall a. Semigroup a => a -> a -> a
<>) | forall a. HasSyntaxExtensions a => Extension -> a -> Bool
isEnabled Extension
Ext_autolink_bare_uris ReaderOptions
opts ] forall a. [a] -> [a] -> [a]
++
[ (forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il, HasEmoji il) =>
SyntaxSpec m il bl
emojiSpec forall a. Semigroup a => a -> a -> a
<>) | forall a. HasSyntaxExtensions a => Extension -> a -> Bool
isEnabled Extension
Ext_emoji ReaderOptions
opts ] forall a. [a] -> [a] -> [a]
++
[ (forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il, ToPlainText il) =>
SyntaxSpec m il bl
autoIdentifiersSpec forall a. Semigroup a => a -> a -> a
<>)
| forall a. HasSyntaxExtensions a => Extension -> a -> Bool
isEnabled Extension
Ext_gfm_auto_identifiers ReaderOptions
opts
, Bool -> Bool
not (forall a. HasSyntaxExtensions a => Extension -> a -> Bool
isEnabled Extension
Ext_ascii_identifiers ReaderOptions
opts) ] forall a. [a] -> [a] -> [a]
++
[ (forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il, ToPlainText il) =>
SyntaxSpec m il bl
autoIdentifiersAsciiSpec forall a. Semigroup a => a -> a -> a
<>)
| forall a. HasSyntaxExtensions a => Extension -> a -> Bool
isEnabled Extension
Ext_gfm_auto_identifiers ReaderOptions
opts
, forall a. HasSyntaxExtensions a => Extension -> a -> Bool
isEnabled Extension
Ext_ascii_identifiers ReaderOptions
opts ] forall a. [a] -> [a] -> [a]
++
[ (forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il) =>
SyntaxSpec m il bl
implicitHeadingReferencesSpec forall a. Semigroup a => a -> a -> a
<>)
| forall a. HasSyntaxExtensions a => Extension -> a -> Bool
isEnabled Extension
Ext_implicit_header_references ReaderOptions
opts ] forall a. [a] -> [a] -> [a]
++
[ (forall (m :: * -> *) il bl.
(Monad m, Typeable m, IsBlock il bl, IsInline il, Typeable il,
Typeable bl, HasFootnote il bl) =>
SyntaxSpec m il bl
footnoteSpec forall a. Semigroup a => a -> a -> a
<>) | forall a. HasSyntaxExtensions a => Extension -> a -> Bool
isEnabled Extension
Ext_footnotes ReaderOptions
opts ] forall a. [a] -> [a] -> [a]
++
[ (forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il, Typeable il, Typeable bl,
HasDefinitionList il bl) =>
SyntaxSpec m il bl
definitionListSpec forall a. Semigroup a => a -> a -> a
<>) | forall a. HasSyntaxExtensions a => Extension -> a -> Bool
isEnabled Extension
Ext_definition_lists ReaderOptions
opts ] forall a. [a] -> [a] -> [a]
++
[ (forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il, HasTaskList il bl) =>
SyntaxSpec m il bl
taskListSpec forall a. Semigroup a => a -> a -> a
<>) | forall a. HasSyntaxExtensions a => Extension -> a -> Bool
isEnabled Extension
Ext_task_lists ReaderOptions
opts ] forall a. [a] -> [a] -> [a]
++
[ (forall (m :: * -> *) bl il.
(Monad m, IsInline il, IsBlock il bl) =>
SyntaxSpec m il bl
rebaseRelativePathsSpec forall a. Semigroup a => a -> a -> a
<>)
| forall a. HasSyntaxExtensions a => Extension -> a -> Bool
isEnabled Extension
Ext_rebase_relative_paths ReaderOptions
opts ]