From 73fa70c3974fa37aeb9a9d1535c1e09fb549bbcf Mon Sep 17 00:00:00 2001
From: mb21 <mb21@users.noreply.github.com>
Date: Sat, 15 Sep 2018 14:35:04 +0200
Subject: [PATCH] Markdown Reader: factor out yamlMap
---
src/Text/Pandoc/Readers/Markdown.hs | 67 ++++++++++++-----------------
1 file changed, 27 insertions(+), 40 deletions(-)
diff --git a/src/Text/Pandoc/Readers/Markdown.hs b/src/Text/Pandoc/Readers/Markdown.hs
index 4efbd25eb..50780b379 100644
--- a/src/Text/Pandoc/Readers/Markdown.hs
+++ b/src/Text/Pandoc/Readers/Markdown.hs
@@ -241,51 +241,33 @@ yamlMetaBlock = try $ do
-- by including --- and ..., we allow yaml blocks with just comments:
let rawYaml = unlines ("---" : (rawYamlLines ++ ["..."]))
optional blanklines
- yamlBsToMeta $ UTF8.fromStringLazy rawYaml
+ newMetaF <- yamlBsToMeta $ UTF8.fromStringLazy rawYaml
+ -- Since `<>` is left-biased, existing values are not touched:
+ updateState $ \st -> st{ stateMeta' = (stateMeta' st) <> newMetaF }
return mempty
-yamlBsToMeta :: PandocMonad m => BS.ByteString -> MarkdownParser m ()
+yamlBsToMeta :: PandocMonad m => BS.ByteString -> MarkdownParser m (F Meta)
yamlBsToMeta bstr = do
pos <- getPosition
case YAML.decodeNode' YAML.failsafeSchemaResolver False False bstr of
- Right [YAML.Doc (YAML.Mapping _ hashmap)] ->
- mapM_ (\(key, v) -> do
- k <- nodeToKey key
- if ignorable k
- then return ()
- else do
- v' <- yamlToMetaValue v
- let k' = T.unpack k
- updateState $ \st -> st{ stateMeta' =
- do m <- stateMeta' st
- -- if there's already a value, leave it unchanged
- case lookupMeta k' m of
- Just _ -> return m
- Nothing -> do
- v'' <- v'
- return $ B.setMeta (T.unpack k) v'' m})
- (M.toList hashmap)
- Right [] -> return ()
- Right [YAML.Doc (YAML.Scalar YAML.SNull)] -> return ()
+ Right [YAML.Doc (YAML.Mapping _ o)] -> (fmap Meta) <$> yamlMap o
+ Right [] -> return . return $ mempty
+ Right [YAML.Doc (YAML.Scalar YAML.SNull)] -> return . return $ mempty
Right _ -> do
logMessage $
CouldNotParseYamlMetadata "not an object"
pos
- return ()
+ return . return $ mempty
Left err' -> do
logMessage $ CouldNotParseYamlMetadata
err' pos
- return ()
+ return . return $ mempty
nodeToKey :: Monad m => YAML.Node -> m Text
nodeToKey (YAML.Scalar (YAML.SStr t)) = return t
nodeToKey (YAML.Scalar (YAML.SUnknown _ t)) = return t
nodeToKey _ = fail "Non-string key in YAML mapping"
--- ignore fields ending with _
-ignorable :: Text -> Bool
-ignorable t = (T.pack "_") `T.isSuffixOf` t
-
toMetaValue :: PandocMonad m
=> Text -> MarkdownParser m (F MetaValue)
toMetaValue x =
@@ -331,21 +313,26 @@ yamlToMetaValue (YAML.Sequence _ xs) = do
return $ do
xs'' <- sequence xs'
return $ B.toMetaValue xs''
-yamlToMetaValue (YAML.Mapping _ o) =
- foldM (\m (key, v) -> do
- k <- nodeToKey key
- if ignorable k
- then return m
- else do
- v' <- yamlToMetaValue v
- return $ do
- MetaMap m' <- m
- v'' <- v'
- return (MetaMap $ M.insert (T.unpack k) v'' m'))
- (return $ MetaMap M.empty)
- (M.toList o)
+yamlToMetaValue (YAML.Mapping _ o) = fmap B.toMetaValue <$> yamlMap o
yamlToMetaValue _ = return $ return $ MetaString ""
+yamlMap :: PandocMonad m
+ => M.Map YAML.Node YAML.Node
+ -> MarkdownParser m (F (M.Map String MetaValue))
+yamlMap 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'
+ where
+ ignorable t = (T.pack "_") `T.isSuffixOf` t
+ toMeta (k, v) = do
+ fv <- yamlToMetaValue v
+ return $ do
+ v' <- fv
+ return (T.unpack k, v')
+
stopLine :: PandocMonad m => MarkdownParser m ()
stopLine = try $ (string "---" <|> string "...") >> blankline >> return ()