@@ -20,7 +20,6 @@ module Text.Pandoc.Readers.Markdown ( readMarkdown, yamlToMeta ) where
2020import Prelude
2121import Control.Monad
2222import Control.Monad.Except (throwError)
23−import qualified Data.ByteString.Lazy as BS
2423import Data.Char (isAlphaNum, isPunctuation, isSpace)
2524import Data.List (sortBy, transpose, elemIndex)
2625import qualified Data.Map as M
@@ -30,8 +29,7 @@ import qualified Data.Set as Set
3029import Data.Text (Text)
3130import qualified Data.Text as T
3231import qualified Data.Text.Lazy as TL
33−import qualified Data.YAML as YAML
34−import qualified Data.YAML.Event as YE
32+import qualified Data.ByteString.Lazy as BL
3533import System.FilePath (addExtension, takeExtension)
3634import Text.HTML.TagSoup
3735import Text.Pandoc.Builder (Blocks, Inlines)
@@ -49,6 +47,7 @@ import Text.Pandoc.Readers.LaTeX (applyMacros, rawLaTeXBlock, rawLaTeXInline)
4947import Text.Pandoc.Shared
5048import qualified Text.Pandoc.UTF8 as UTF8
5149import Text.Pandoc.XML (fromEntities)
50+import Text.Pandoc.Readers.Metadata (yamlBsToMeta)
5251
5352type MarkdownParser m = ParserT Text ParserState m
5453
@@ -64,6 +63,23 @@ readMarkdown opts s = do
6463 Right result -> return result
6564 Left e -> throwError e
6665
66+-- | Read a YAML string and convert it to pandoc metadata.
67+-- String scalars in the YAML are parsed as Markdown.
68+yamlToMeta :: PandocMonad m
69+ => ReaderOptions
70+ -> BL.ByteString
71+ -> m Meta
72+yamlToMeta opts bstr = do
73+ let parser = do
74+ meta <- yamlBsToMeta parseBlocks bstr
75+ return $ runF meta defaultParserState
76+ parsed <- readWithM parser def{ stateOptions = opts } ""
77+ case parsed of
78+ Right result -> return result
79+ Left e -> throwError e
80+
81+
82+
6783--
6884-- Constants and data structure definitions
6985--
@@ -228,111 +244,12 @@ yamlMetaBlock = try $ do
228244 -- by including --- and ..., we allow yaml blocks with just comments:
229245 let rawYaml = T.unlines ("---" : (rawYamlLines ++ ["..."]))
230246 optional blanklines
231− newMetaF <- yamlBsToMeta $ UTF8.fromTextLazy $ TL.fromStrict rawYaml
247+ newMetaF <- yamlBsToMeta parseBlocks
248+ $ UTF8.fromTextLazy $ TL.fromStrict rawYaml
232249 -- Since `<>` is left-biased, existing values are not touched:
233250 updateState $ \st -> st{ stateMeta' = (stateMeta' st) <> newMetaF }
234251 return mempty
235252
236−-- | Read a YAML string and convert it to pandoc metadata.
237−-- String scalars in the YAML are parsed as Markdown.
238−yamlToMeta :: PandocMonad m => ReaderOptions -> BS.ByteString -> m Meta
239−yamlToMeta opts bstr = do
240− let parser = do
241− meta <- yamlBsToMeta bstr
242− return $ runF meta defaultParserState
243− parsed <- readWithM parser def{ stateOptions = opts } ""
244− case parsed of
245− Right result -> return result
246− Left e -> throwError e
247−
248−yamlBsToMeta :: PandocMonad m => BS.ByteString -> MarkdownParser m (F Meta)
249−yamlBsToMeta bstr = do
250− pos <- getPosition
251− case YAML.decodeNode' YAML.failsafeSchemaResolver False False bstr of
252− Right ((YAML.Doc (YAML.Mapping _ _ o)):_) -> (fmap Meta) <$> yamlMap o
253− Right [] -> return . return $ mempty
254− Right [YAML.Doc (YAML.Scalar _ YAML.SNull)] -> return . return $ mempty
255− Right _ -> do
256− logMessage $
257− CouldNotParseYamlMetadata "not an object"
258− pos
259− return . return $ mempty
260− Left (_pos, err') -> do
261− logMessage $ CouldNotParseYamlMetadata
262− (T.pack err') pos
263− return . return $ mempty
264−
265−nodeToKey :: PandocMonad m => YAML.Node YE.Pos -> m Text
266−nodeToKey (YAML.Scalar _ (YAML.SStr t)) = return t
267−nodeToKey (YAML.Scalar _ (YAML.SUnknown _ t)) = return t
268−nodeToKey _ = throwError $ PandocParseError
269− "Non-string key in YAML mapping"
270−
271−toMetaValue :: PandocMonad m
272− => Text -> MarkdownParser m (F MetaValue)
273−toMetaValue x =
274− -- Note: a standard quoted or unquoted YAML value will
275− -- not end in a newline, but a "block" set off with
276− -- `|` or `>` will.
277− if "\n" `T.isSuffixOf` x
278− then parseFromString' (asBlocks <$> parseBlocks) (x <> "\n")
279− else parseFromString'
280− ((asInlines <$> try pInlines) <|> (asBlocks <$> parseBlocks))
281− x
282− where pInlines = trimInlinesF . mconcat <$> manyTill inline eof
283− asBlocks p = do
284− p' <- p
285− return $ MetaBlocks (B.toList p')
286− asInlines p = do
287− p' <- p
288− return $ MetaInlines (B.toList p')
289−
290−checkBoolean :: Text -> Maybe Bool
291−checkBoolean t =
292− if t == T.pack "true" || t == T.pack "True" || t == T.pack "TRUE"
293− then Just True
294− else if t == T.pack "false" || t == T.pack "False" || t == T.pack "FALSE"
295− then Just False
296− else Nothing
297−
298−yamlToMetaValue :: PandocMonad m
299− => YAML.Node YE.Pos-> MarkdownParser m (F MetaValue)
300−yamlToMetaValue (YAML.Scalar _ x) =
301− case x of
302− YAML.SStr t -> toMetaValue t
303− YAML.SBool b -> return $ return $ MetaBool b
304− YAML.SFloat d -> return $ return $ MetaString $ tshow d
305− YAML.SInt i -> return $ return $ MetaString $ tshow i
306− YAML.SUnknown _ t ->
307− case checkBoolean t of
308− Just b -> return $ return $ MetaBool b
309− Nothing -> toMetaValue t
310− YAML.SNull -> return $ return $ MetaString ""
311−yamlToMetaValue (YAML.Sequence _ _ xs) = do
312− xs' <- mapM yamlToMetaValue xs
313− return $ do
314− xs'' <- sequence xs'
315− return $ B.toMetaValue xs''
316−yamlToMetaValue (YAML.Mapping _ _ o) = fmap B.toMetaValue <$> yamlMap o
317−yamlToMetaValue _ = return $ return $ MetaString ""
318−
319−yamlMap :: PandocMonad m
320− => M.Map (YAML.Node YE.Pos) (YAML.Node YE.Pos)
321− -> MarkdownParser m (F (M.Map Text MetaValue))
322−yamlMap o = do
323− kvs <- forM (M.toList o) $ \(key, v) -> do
324− k <- nodeToKey key
325− return (k, v)
326− let kvs' = filter (not . ignorable . fst) kvs
327− (fmap M.fromList . sequence) <$> mapM toMeta kvs'
328− where
329− ignorable t = "_" `T.isSuffixOf` t
330− toMeta (k, v) = do
331− fv <- yamlToMetaValue v
332− return $ do
333− v' <- fv
334− return (k, v')
335−
336253stopLine :: PandocMonad m => MarkdownParser m ()
337254stopLine = try $ (string "---" <|> string "...") >> blankline >> return ()
338255