1{-# LANGUAGE OverloadedStrings #-} 2{-# LANGUAGE FlexibleContexts #-} 3{-# LANGUAGE ScopedTypeVariables #-} 4{- | 5 Module : Text.Pandoc.Readers.CommonMark 6 Copyright : Copyright (C) 2015-2021 John MacFarlane 7 License : GNU GPL, version 2 or above 8 9 Maintainer : John MacFarlane <jgm@berkeley.edu> 10 Stability : alpha 11 Portability : portable 12 13Conversion of CommonMark-formatted plain text to 'Pandoc' document. 14 15CommonMark is a strongly specified variant of Markdown: http://commonmark.org. 16-} 17module Text.Pandoc.Readers.CommonMark (readCommonMark) 18where 19 20import Commonmark 21import Commonmark.Extensions 22import Commonmark.Pandoc 23import Data.Text (Text) 24import Text.Pandoc.Class.PandocMonad (PandocMonad) 25import Text.Pandoc.Definition 26import Text.Pandoc.Builder as B 27import Text.Pandoc.Options 28import Text.Pandoc.Error 29import Text.Pandoc.Readers.Metadata (yamlMetaBlock) 30import Control.Monad.Except 31import Data.Functor.Identity (runIdentity) 32import Data.Typeable 33import Text.Pandoc.Parsing (runParserT, getInput, 34 runF, defaultParserState, option, many1, anyChar, 35 Sources(..), ToSources(..), ParserT, Future, 36 sourceName) 37import qualified Data.Text as T 38 39-- | Parse a CommonMark formatted string into a 'Pandoc' structure. 40readCommonMark :: (PandocMonad m, ToSources a) 41 => ReaderOptions -> a -> m Pandoc 42readCommonMark opts s 43 | isEnabled Ext_yaml_metadata_block opts = do 44 let sources = toSources s 45 let toks = concatMap sourceToToks (unSources sources) 46 res <- runParserT (do meta <- yamlMetaBlock (metaValueParser opts) 47 rest <- getInput 48 return (meta, rest)) 49 defaultParserState "YAML metadata" (toSources s) 50 case res of 51 Left _ -> readCommonMarkBody opts sources toks 52 Right (meta, rest) -> do 53 -- strip off metadata section and parse body 54 let body = concatMap sourceToToks (unSources rest) 55 Pandoc _ bs <- readCommonMarkBody opts sources body 56 return $ Pandoc (runF meta defaultParserState) bs 57 | otherwise = do 58 let sources = toSources s 59 let toks = concatMap sourceToToks (unSources sources) 60 readCommonMarkBody opts sources toks 61 62sourceToToks :: (SourcePos, Text) -> [Tok] 63sourceToToks (pos, s) = tokenize (sourceName pos) s 64 65metaValueParser :: Monad m 66 => ReaderOptions -> ParserT Sources st m (Future st MetaValue) 67metaValueParser opts = do 68 inp <- option "" $ T.pack <$> many1 anyChar 69 let toks = concatMap sourceToToks (unSources (toSources inp)) 70 case runIdentity (parseCommonmarkWith (specFor opts) toks) of 71 Left _ -> mzero 72 Right (Cm bls :: Cm () Blocks) -> return $ return $ B.toMetaValue bls 73 74readCommonMarkBody :: PandocMonad m => ReaderOptions -> Sources -> [Tok] -> m Pandoc 75readCommonMarkBody opts s toks 76 | isEnabled Ext_sourcepos opts = 77 case runIdentity (parseCommonmarkWith (specFor opts) toks) of 78 Left err -> throwError $ PandocParsecError s err 79 Right (Cm bls :: Cm SourceRange Blocks) -> return $ B.doc bls 80 | otherwise = 81 case runIdentity (parseCommonmarkWith (specFor opts) toks) of 82 Left err -> throwError $ PandocParsecError s err 83 Right (Cm bls :: Cm () Blocks) -> return $ B.doc bls 84 85specFor :: (Monad m, Typeable m, Typeable a, 86 Rangeable (Cm a Inlines), Rangeable (Cm a Blocks)) 87 => ReaderOptions -> SyntaxSpec m (Cm a Inlines) (Cm a Blocks) 88specFor opts = foldr ($) defaultSyntaxSpec exts 89 where 90 exts = [ (hardLineBreaksSpec <>) | isEnabled Ext_hard_line_breaks opts ] ++ 91 [ (smartPunctuationSpec <>) | isEnabled Ext_smart opts ] ++ 92 [ (strikethroughSpec <>) | isEnabled Ext_strikeout opts ] ++ 93 [ (superscriptSpec <>) | isEnabled Ext_superscript opts ] ++ 94 [ (subscriptSpec <>) | isEnabled Ext_subscript opts ] ++ 95 [ (mathSpec <>) | isEnabled Ext_tex_math_dollars opts ] ++ 96 [ (fancyListSpec <>) | isEnabled Ext_fancy_lists opts ] ++ 97 [ (fencedDivSpec <>) | isEnabled Ext_fenced_divs opts ] ++ 98 [ (bracketedSpanSpec <>) | isEnabled Ext_bracketed_spans opts ] ++ 99 [ (rawAttributeSpec <>) | isEnabled Ext_raw_attribute opts ] ++ 100 [ (attributesSpec <>) | isEnabled Ext_attributes opts ] ++ 101 [ (<> pipeTableSpec) | isEnabled Ext_pipe_tables opts ] ++ 102 -- see #6739 103 [ (autolinkSpec <>) | isEnabled Ext_autolink_bare_uris opts ] ++ 104 [ (emojiSpec <>) | isEnabled Ext_emoji opts ] ++ 105 [ (autoIdentifiersSpec <>) 106 | isEnabled Ext_gfm_auto_identifiers opts 107 , not (isEnabled Ext_ascii_identifiers opts) ] ++ 108 [ (autoIdentifiersAsciiSpec <>) 109 | isEnabled Ext_gfm_auto_identifiers opts 110 , isEnabled Ext_ascii_identifiers opts ] ++ 111 [ (implicitHeadingReferencesSpec <>) 112 | isEnabled Ext_implicit_header_references opts ] ++ 113 [ (footnoteSpec <>) | isEnabled Ext_footnotes opts ] ++ 114 [ (definitionListSpec <>) | isEnabled Ext_definition_lists opts ] ++ 115 [ (taskListSpec <>) | isEnabled Ext_task_lists opts ] ++ 116 [ (rebaseRelativePathsSpec <>) 117 | isEnabled Ext_rebase_relative_paths opts ] 118 119