@@ -31,11 +31,12 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
3131
3232Conversion of markdown-formatted plain text to 'Pandoc' document.
3333-}
34−module Text.Pandoc.Readers.Markdown ( readMarkdown ) where
34+module Text.Pandoc.Readers.Markdown ( readMarkdown, yamlToMeta ) where
3535
3636import Prelude
3737import Control.Monad
3838import Control.Monad.Except (throwError)
39+import qualified Data.ByteString.Lazy as BS
3940import Data.Char (isAlphaNum, isPunctuation, isSpace, toLower)
4041import Data.List (intercalate, sortBy, transpose, elemIndex)
4142import qualified Data.Map as M
@@ -233,7 +234,6 @@ pandocTitleBlock = try $ do
233234yamlMetaBlock :: PandocMonad m => MarkdownParser m (F Blocks)
234235yamlMetaBlock = try $ do
235236 guardEnabled Ext_yaml_metadata_block
236− pos <- getPosition
237237 string "---"
238238 blankline
239239 notFollowedBy blankline -- if --- is followed by a blank it's an HRULE
@@ -241,47 +241,45 @@ yamlMetaBlock = try $ do
241241 -- by including --- and ..., we allow yaml blocks with just comments:
242242 let rawYaml = unlines ("---" : (rawYamlLines ++ ["..."]))
243243 optional blanklines
244− case YAML.decodeNode' YAML.failsafeSchemaResolver False False
245− (UTF8.fromStringLazy rawYaml) of
246− Right [YAML.Doc (YAML.Mapping _ hashmap)] ->
247− mapM_ (\(key, v) -> do
248− k <- nodeToKey key
249− if ignorable k
250− then return ()
251− else do
252− v' <- yamlToMeta v
253− let k' = T.unpack k
254− updateState $ \st -> st{ stateMeta' =
255− do m <- stateMeta' st
256− -- if there's already a value, leave it unchanged
257− case lookupMeta k' m of
258− Just _ -> return m
259− Nothing -> do
260− v'' <- v'
261− return $ B.setMeta (T.unpack k) v'' m})
262− (M.toList hashmap)
263− Right [] -> return ()
264− Right [YAML.Doc (YAML.Scalar YAML.SNull)] -> return ()
244+ newMetaF <- yamlBsToMeta $ UTF8.fromStringLazy rawYaml
245+ -- Since `<>` is left-biased, existing values are not touched:
246+ updateState $ \st -> st{ stateMeta' = (stateMeta' st) <> newMetaF }
247+ return mempty
248+
249+-- | Read a YAML string and convert it to pandoc metadata.
250+-- String scalars in the YAML are parsed as Markdown.
251+yamlToMeta :: PandocMonad m => BS.ByteString -> m Meta
252+yamlToMeta bstr = do
253+ let parser = do
254+ meta <- yamlBsToMeta bstr
255+ return $ runF meta defaultParserState
256+ parsed <- readWithM parser def ""
257+ case parsed of
258+ Right result -> return result
259+ Left e -> throwError e
260+
261+yamlBsToMeta :: PandocMonad m => BS.ByteString -> MarkdownParser m (F Meta)
262+yamlBsToMeta bstr = do
263+ pos <- getPosition
264+ case YAML.decodeNode' YAML.failsafeSchemaResolver False False bstr of
265+ Right ((YAML.Doc (YAML.Mapping _ o)):_) -> (fmap Meta) <$> yamlMap o
266+ Right [] -> return . return $ mempty
267+ Right [YAML.Doc (YAML.Scalar YAML.SNull)] -> return . return $ mempty
265268 Right _ -> do
266269 logMessage $
267270 CouldNotParseYamlMetadata "not an object"
268271 pos
269− return ()
272+ return . return $ mempty
270273 Left err' -> do
271274 logMessage $ CouldNotParseYamlMetadata
272275 err' pos
273− return ()
274− return mempty
276+ return . return $ mempty
275277
276278nodeToKey :: Monad m => YAML.Node -> m Text
277279nodeToKey (YAML.Scalar (YAML.SStr t)) = return t
278280nodeToKey (YAML.Scalar (YAML.SUnknown _ t)) = return t
279281nodeToKey _ = fail "Non-string key in YAML mapping"
280282
281−-- ignore fields ending with _
282−ignorable :: Text -> Bool
283−ignorable t = (T.pack "_") `T.isSuffixOf` t
284−
285283toMetaValue :: PandocMonad m
286284 => Text -> MarkdownParser m (F MetaValue)
287285toMetaValue x =
@@ -309,9 +307,9 @@ checkBoolean t =
309307 then Just False
310308 else Nothing
311309
312−yamlToMeta :: PandocMonad m
313− => YAML.Node -> MarkdownParser m (F MetaValue)
314−yamlToMeta (YAML.Scalar x) =
310+yamlToMetaValue :: PandocMonad m
311+ => YAML.Node -> MarkdownParser m (F MetaValue)
312+yamlToMetaValue (YAML.Scalar x) =
315313 case x of
316314 YAML.SStr t -> toMetaValue t
317315 YAML.SBool b -> return $ return $ MetaBool b
@@ -322,25 +320,30 @@ yamlToMeta (YAML.Scalar x) =
322320 Just b -> return $ return $ MetaBool b
323321 Nothing -> toMetaValue t
324322 YAML.SNull -> return $ return $ MetaString ""
325−yamlToMeta (YAML.Sequence _ xs) = do
326− xs' <- mapM yamlToMeta xs
323+yamlToMetaValue (YAML.Sequence _ xs) = do
324+ xs' <- mapM yamlToMetaValue xs
327325 return $ do
328326 xs'' <- sequence xs'
329327 return $ B.toMetaValue xs''
330−yamlToMeta (YAML.Mapping _ o) =
331− foldM (\m (key, v) -> do
332− k <- nodeToKey key
333− if ignorable k
334− then return m
335− else do
336− v' <- yamlToMeta v
337− return $ do
338− MetaMap m' <- m
339− v'' <- v'
340− return (MetaMap $ M.insert (T.unpack k) v'' m'))
341− (return $ MetaMap M.empty)
342− (M.toList o)
343−yamlToMeta _ = return $ return $ MetaString ""
328+yamlToMetaValue (YAML.Mapping _ o) = fmap B.toMetaValue <$> yamlMap o
329+yamlToMetaValue _ = return $ return $ MetaString ""
330+
331+yamlMap :: PandocMonad m
332+ => M.Map YAML.Node YAML.Node
333+ -> MarkdownParser m (F (M.Map String MetaValue))
334+yamlMap o = do
335+ kvs <- forM (M.toList o) $ \(key, v) -> do
336+ k <- nodeToKey key
337+ return (k, v)
338+ let kvs' = filter (not . ignorable . fst) kvs
339+ (fmap M.fromList . sequence) <$> mapM toMeta kvs'
340+ where
341+ ignorable t = (T.pack "_") `T.isSuffixOf` t
342+ toMeta (k, v) = do
343+ fv <- yamlToMetaValue v
344+ return $ do
345+ v' <- fv
346+ return (T.unpack k, v')
344347
345348stopLine :: PandocMonad m => MarkdownParser m ()
346349stopLine = try $ (string "---" <|> string "...") >> blankline >> return ()