Clean up T.P.R.Metadata

src/Text/Pandoc/Readers/Markdown.hs

@@ -67,16 +67,13 @@ yamlToMeta :: PandocMonad m
            -> m Meta
 yamlToMeta opts bstr = do
   let parser = do
-        meta <- yamlBsToMeta (asBlocks <$> 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
 
-asBlocks :: Functor f => f (B.Many Block) -> f MetaValue
-asBlocks p = MetaBlocks . B.toList <$> p
-
 --
 -- Constants and data structure definitions
 --
@@ -241,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 (asBlocks <$> 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 }

src/Text/Pandoc/Readers/Metadata.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE OverloadedStrings   #-}
 {- |
    Module      : Text.Pandoc.Readers.Metadata
@@ -21,7 +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.Class.PandocMonad (PandocMonad (..))
 import Text.Pandoc.Definition
 import Text.Pandoc.Error
@@ -33,11 +31,11 @@ yamlBsToMeta :: PandocMonad m
              => 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
@@ -57,30 +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 MetaValue)
-            -> 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' pBlocks (x <> "\n")
-      else parseFromString' pInlines x
-  where pInlines = do
-          bs <- pBlocks
-          return $ do
-            bs' <- bs
-            return $
-              case bs' of
-                MetaBlocks bs'' ->
-                  case bs'' of
-                    [Plain ils] -> MetaInlines ils
-                    [Para ils]  -> MetaInlines ils
-                    xs          -> MetaBlocks xs
-                _ -> bs'
-
+      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
@@ -92,32 +81,30 @@ yamlToMetaValue :: PandocMonad m
                 => 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 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)
@@ -126,7 +113,7 @@ yamlMap pBlocks o = do
   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')