diff options
| -rw-r--r-- | src/Text/Pandoc/Readers/Markdown.hs | 7 | ||||
| -rw-r--r-- | src/Text/Pandoc/Readers/Metadata.hs | 59 |
2 files changed, 25 insertions, 41 deletions
diff --git a/src/Text/Pandoc/Readers/Markdown.hs b/src/Text/Pandoc/Readers/Markdown.hs index cf59ef288..9b6671f1b 100644 --- a/src/Text/Pandoc/Readers/Markdown.hs +++ b/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 } diff --git a/src/Text/Pandoc/Readers/Metadata.hs b/src/Text/Pandoc/Readers/Metadata.hs index 94d4f0f0d..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 @@ -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') |