aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorJohn MacFarlane <jgm@berkeley.edu>2020-06-29 12:38:49 -0700
committerGitHub <noreply@github.com>2020-06-29 12:38:49 -0700
commitf1a529508240ddeca75d6d31c475ae9f9e5fbc82 (patch)
tree72c575031bc9ddd00067e2a4aca36fac03138ea4 /src
parent5ef315cc6db868a11bd0c3e887b8c55eb2216662 (diff)
parent42e7f1e976842d975cd2e13bafb9228d7bc92acf (diff)
downloadpandoc-f1a529508240ddeca75d6d31c475ae9f9e5fbc82.tar.gz
Merge pull request #6328 from lierdakil/defaults-meta-parse
Unify defaults metadata and markdown metadata parsers
Diffstat (limited to 'src')
-rw-r--r--src/Text/Pandoc/App/Opt.hs29
-rw-r--r--src/Text/Pandoc/Readers/Markdown.hs6
-rw-r--r--src/Text/Pandoc/Readers/Metadata.hs67
3 files changed, 45 insertions, 57 deletions
diff --git a/src/Text/Pandoc/App/Opt.hs b/src/Text/Pandoc/App/Opt.hs
index fb2aeab22..5c39f4ab6 100644
--- a/src/Text/Pandoc/App/Opt.hs
+++ b/src/Text/Pandoc/App/Opt.hs
@@ -4,6 +4,7 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
{- |
Module : Text.Pandoc.App.Opt
Copyright : Copyright (C) 2006-2020 John MacFarlane
@@ -34,9 +35,12 @@ import Text.Pandoc.Options (TopLevelDivision (TopLevelDefault),
ObfuscationMethod (NoObfuscation),
CiteMethod (Citeproc))
import Text.Pandoc.Shared (camelCaseStrToHyphenated)
-import Text.DocLayout (render)
-import Text.DocTemplates (Context(..), Val(..))
+import qualified Text.Pandoc.Parsing as P
+import Text.Pandoc.Readers.Metadata (yamlMap)
+import Text.Pandoc.Class.PandocPure
+import Text.DocTemplates (Context(..))
import Data.Text (Text, unpack)
+import Data.Default (def)
import qualified Data.Text as T
import qualified Data.Map as M
import Text.Pandoc.Definition (Meta(..), MetaValue(..), lookupMeta)
@@ -185,8 +189,7 @@ doOpt (k',v) = do
-- Note: x comes first because <> for Context is left-biased union
-- and we want to favor later default files. See #5988.
"metadata" ->
- parseYAML v >>= \x -> return (\o -> o{ optMetadata = optMetadata o <>
- contextToMeta x })
+ yamlToMeta v >>= \x -> return (\o -> o{ optMetadata = optMetadata o <> x })
"metadata-files" ->
parseYAML v >>= \x ->
return (\o -> o{ optMetadataFiles =
@@ -475,16 +478,14 @@ defaultOpts = Opt
, optStripComments = False
}
-contextToMeta :: Context Text -> Meta
-contextToMeta (Context m) =
- Meta . M.map valToMetaVal $ m
-
-valToMetaVal :: Val Text -> MetaValue
-valToMetaVal (MapVal (Context m)) =
- MetaMap . M.map valToMetaVal $ m
-valToMetaVal (ListVal xs) = MetaList $ map valToMetaVal xs
-valToMetaVal (SimpleVal d) = MetaString $ render Nothing d
-valToMetaVal NullVal = MetaString ""
+yamlToMeta :: Node Pos -> Parser Meta
+yamlToMeta (Mapping _ _ m) =
+ either (fail . show) return $ runEverything (yamlMap pMetaString m)
+ where
+ pMetaString = pure . MetaString <$> P.manyChar P.anyChar
+ runEverything p = runPure (P.readWithM p def "")
+ >>= fmap (Meta . flip P.runF def)
+yamlToMeta _ = return mempty
addMeta :: String -> String -> Meta -> Meta
addMeta k v meta =
diff --git a/src/Text/Pandoc/Readers/Markdown.hs b/src/Text/Pandoc/Readers/Markdown.hs
index 41ca8bfe1..9b6671f1b 100644
--- a/src/Text/Pandoc/Readers/Markdown.hs
+++ b/src/Text/Pandoc/Readers/Markdown.hs
@@ -67,15 +67,13 @@ yamlToMeta :: PandocMonad m
-> m Meta
yamlToMeta opts bstr = do
let parser = do
- meta <- yamlBsToMeta parseBlocks bstr
+ meta <- yamlBsToMeta (fmap B.toMetaValue <$> parseBlocks) bstr
return $ runF meta defaultParserState
parsed <- readWithM parser def{ stateOptions = opts } ""
case parsed of
Right result -> return result
Left e -> throwError e
-
-
--
-- Constants and data structure definitions
--
@@ -240,7 +238,7 @@ yamlMetaBlock = try $ do
-- by including --- and ..., we allow yaml blocks with just comments:
let rawYaml = T.unlines ("---" : (rawYamlLines ++ ["..."]))
optional blanklines
- newMetaF <- yamlBsToMeta parseBlocks
+ newMetaF <- yamlBsToMeta (fmap B.toMetaValue <$> parseBlocks)
$ UTF8.fromTextLazy $ TL.fromStrict rawYaml
-- Since `<>` is left-biased, existing values are not touched:
updateState $ \st -> st{ stateMeta' = stateMeta' st <> newMetaF }
diff --git a/src/Text/Pandoc/Readers/Metadata.hs b/src/Text/Pandoc/Readers/Metadata.hs
index b2028252d..826111756 100644
--- a/src/Text/Pandoc/Readers/Metadata.hs
+++ b/src/Text/Pandoc/Readers/Metadata.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{- |
Module : Text.Pandoc.Readers.Metadata
@@ -11,7 +10,7 @@
Parse YAML/JSON metadata to 'Pandoc' 'Meta'.
-}
-module Text.Pandoc.Readers.Metadata ( yamlBsToMeta ) where
+module Text.Pandoc.Readers.Metadata ( yamlBsToMeta, yamlMap ) where
import Control.Monad
import Control.Monad.Except (throwError)
@@ -21,8 +20,6 @@ import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.YAML as YAML
import qualified Data.YAML.Event as YE
-import qualified Text.Pandoc.Builder as B
-import Text.Pandoc.Builder (Blocks)
import Text.Pandoc.Class.PandocMonad (PandocMonad (..))
import Text.Pandoc.Definition
import Text.Pandoc.Error
@@ -31,14 +28,14 @@ import Text.Pandoc.Parsing hiding (tableWith)
import Text.Pandoc.Shared
yamlBsToMeta :: PandocMonad m
- => ParserT Text ParserState m (F Blocks)
+ => ParserT Text ParserState m (F MetaValue)
-> BL.ByteString
-> ParserT Text ParserState m (F Meta)
-yamlBsToMeta pBlocks bstr = do
+yamlBsToMeta pMetaValue bstr = do
pos <- getPosition
case YAML.decodeNode' YAML.failsafeSchemaResolver False False bstr of
Right (YAML.Doc (YAML.Mapping _ _ o):_)
- -> fmap Meta <$> yamlMap pBlocks o
+ -> fmap Meta <$> yamlMap pMetaValue o
Right [] -> return . return $ mempty
Right [YAML.Doc (YAML.Scalar _ YAML.SNull)]
-> return . return $ mempty
@@ -58,27 +55,21 @@ nodeToKey (YAML.Scalar _ (YAML.SUnknown _ t)) = return t
nodeToKey _ = throwError $ PandocParseError
"Non-string key in YAML mapping"
-toMetaValue :: PandocMonad m
- => ParserT Text ParserState m (F Blocks)
- -> Text
- -> ParserT Text ParserState m (F MetaValue)
-toMetaValue pBlocks x =
+normalizeMetaValue :: PandocMonad m
+ => ParserT Text ParserState m (F MetaValue)
+ -> Text
+ -> ParserT Text ParserState m (F MetaValue)
+normalizeMetaValue pMetaValue x =
-- Note: a standard quoted or unquoted YAML value will
-- not end in a newline, but a "block" set off with
-- `|` or `>` will.
if "\n" `T.isSuffixOf` x
- then parseFromString' (asBlocks <$> pBlocks) (x <> "\n")
- else parseFromString' pInlines x
- where pInlines = do
- bs <- pBlocks
- return $ do
- bs' <- bs
- return $
- case B.toList bs' of
- [Plain ils] -> MetaInlines ils
- [Para ils] -> MetaInlines ils
- xs -> MetaBlocks xs
- asBlocks p = MetaBlocks . B.toList <$> p
+ then parseFromString' pMetaValue (x <> "\n")
+ else parseFromString' asInlines x
+ where asInlines = fmap b2i <$> pMetaValue
+ b2i (MetaBlocks [Plain ils]) = MetaInlines ils
+ b2i (MetaBlocks [Para ils]) = MetaInlines ils
+ b2i bs = bs
checkBoolean :: Text -> Maybe Bool
checkBoolean t
@@ -87,44 +78,42 @@ checkBoolean t
| otherwise = Nothing
yamlToMetaValue :: PandocMonad m
- => ParserT Text ParserState m (F Blocks)
+ => ParserT Text ParserState m (F MetaValue)
-> YAML.Node YE.Pos
-> ParserT Text ParserState m (F MetaValue)
-yamlToMetaValue pBlocks (YAML.Scalar _ x) =
+yamlToMetaValue pMetaValue (YAML.Scalar _ x) =
case x of
- YAML.SStr t -> toMetaValue pBlocks t
+ YAML.SStr t -> normalizeMetaValue pMetaValue t
YAML.SBool b -> return $ return $ MetaBool b
YAML.SFloat d -> return $ return $ MetaString $ tshow d
YAML.SInt i -> return $ return $ MetaString $ tshow i
YAML.SUnknown _ t ->
case checkBoolean t of
Just b -> return $ return $ MetaBool b
- Nothing -> toMetaValue pBlocks t
+ Nothing -> normalizeMetaValue pMetaValue t
YAML.SNull -> return $ return $ MetaString ""
-yamlToMetaValue pBlocks (YAML.Sequence _ _ xs) = do
- xs' <- mapM (yamlToMetaValue pBlocks) xs
- return $ do
- xs'' <- sequence xs'
- return $ B.toMetaValue xs''
-yamlToMetaValue pBlocks (YAML.Mapping _ _ o) =
- fmap B.toMetaValue <$> yamlMap pBlocks o
+yamlToMetaValue pMetaValue (YAML.Sequence _ _ xs) =
+ fmap MetaList . sequence
+ <$> mapM (yamlToMetaValue pMetaValue) xs
+yamlToMetaValue pMetaValue (YAML.Mapping _ _ o) =
+ fmap MetaMap <$> yamlMap pMetaValue o
yamlToMetaValue _ _ = return $ return $ MetaString ""
yamlMap :: PandocMonad m
- => ParserT Text ParserState m (F Blocks)
+ => ParserT Text ParserState m (F MetaValue)
-> M.Map (YAML.Node YE.Pos) (YAML.Node YE.Pos)
-> ParserT Text ParserState m (F (M.Map Text MetaValue))
-yamlMap pBlocks o = do
+yamlMap pMetaValue o = do
kvs <- forM (M.toList o) $ \(key, v) -> do
k <- nodeToKey key
return (k, v)
let kvs' = filter (not . ignorable . fst) kvs
- (fmap M.fromList . sequence) <$> mapM toMeta kvs'
+ fmap M.fromList . sequence <$> mapM toMeta kvs'
where
ignorable t = "_" `T.isSuffixOf` t
toMeta (k, v) = do
- fv <- yamlToMetaValue pBlocks v
+ fv <- yamlToMetaValue pMetaValue v
return $ do
v' <- fv
return (k, v')
generated by cgit v1.2.3 (git 2.39.1) at 2025-03-28 16:04:38 +0000