Merge pull request #6328 from lierdakil/defaults-meta-parse

Unify defaults metadata and markdown metadata parsers

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