From f26923b9e493ecd2c4515d821da58e88fd2d946b Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Fri, 1 May 2020 03:11:44 +0300 Subject: Unify defaults and markdown metadata parsers --- src/Text/Pandoc/App/Opt.hs | 29 +++++++++++++++-------------- src/Text/Pandoc/Readers/Markdown.hs | 7 +++++-- src/Text/Pandoc/Readers/Metadata.hs | 28 +++++++++++++++------------- 3 files changed, 35 insertions(+), 29 deletions(-) (limited to 'src') diff --git a/src/Text/Pandoc/App/Opt.hs b/src/Text/Pandoc/App/Opt.hs index fb2aeab22..c550bed2c 100644 --- a/src/Text/Pandoc/App/Opt.hs +++ b/src/Text/Pandoc/App/Opt.hs @@ -34,9 +34,13 @@ import Text.Pandoc.Options (TopLevelDivision (TopLevelDefault), ObfuscationMethod (NoObfuscation), CiteMethod (Citeproc)) import Text.Pandoc.Shared (camelCaseStrToHyphenated) -import Text.DocLayout (render) -import Text.DocTemplates (Context(..), Val(..)) +import qualified Text.Pandoc.Parsing as P +import Text.Pandoc.Readers.Metadata (yamlMap) +import Text.Pandoc.Class.PandocPure +import Text.DocTemplates (Context(..)) import Data.Text (Text, unpack) +import Data.Default (def) +import Control.Monad (join) import qualified Data.Text as T import qualified Data.Map as M import Text.Pandoc.Definition (Meta(..), MetaValue(..), lookupMeta) @@ -185,8 +189,7 @@ doOpt (k',v) = do -- Note: x comes first because <> for Context is left-biased union -- and we want to favor later default files. See #5988. "metadata" -> - parseYAML v >>= \x -> return (\o -> o{ optMetadata = optMetadata o <> - contextToMeta x }) + return (\o -> o{ optMetadata = optMetadata o <> yamlToMeta v }) "metadata-files" -> parseYAML v >>= \x -> return (\o -> o{ optMetadataFiles = @@ -475,16 +478,14 @@ defaultOpts = Opt , optStripComments = False } -contextToMeta :: Context Text -> Meta -contextToMeta (Context m) = - Meta . M.map valToMetaVal $ m - -valToMetaVal :: Val Text -> MetaValue -valToMetaVal (MapVal (Context m)) = - MetaMap . M.map valToMetaVal $ m -valToMetaVal (ListVal xs) = MetaList $ map valToMetaVal xs -valToMetaVal (SimpleVal d) = MetaString $ render Nothing d -valToMetaVal NullVal = MetaString "" +yamlToMeta :: Node Pos -> Meta +yamlToMeta (Mapping _ _ m) = runEverything (yamlMap pMetaString m) + where + pMetaString = pure . MetaString <$> P.manyChar P.anyChar + runEverything :: P.ParserT Text P.ParserState PandocPure (P.F (M.Map Text MetaValue)) -> Meta + runEverything p = + either (const mempty) (Meta . flip P.runF def) . join . runPure $ P.readWithM p def "" +yamlToMeta _ = mempty addMeta :: String -> String -> Meta -> Meta addMeta k v meta = diff --git a/src/Text/Pandoc/Readers/Markdown.hs b/src/Text/Pandoc/Readers/Markdown.hs index 41ca8bfe1..77a371537 100644 --- a/src/Text/Pandoc/Readers/Markdown.hs +++ b/src/Text/Pandoc/Readers/Markdown.hs @@ -67,14 +67,17 @@ yamlToMeta :: PandocMonad m -> m Meta yamlToMeta opts bstr = do let parser = do - meta <- yamlBsToMeta parseBlocks bstr + meta <- yamlBsToMeta (fmap asBlocks parseBlocks) bstr return $ runF meta defaultParserState parsed <- readWithM parser def{ stateOptions = opts } "" case parsed of Right result -> return result Left e -> throwError e + where +asBlocks :: Functor f => f (B.Many Block) -> f MetaValue +asBlocks p = MetaBlocks . B.toList <$> p -- -- Constants and data structure definitions @@ -240,7 +243,7 @@ yamlMetaBlock = try $ do -- by including --- and ..., we allow yaml blocks with just comments: let rawYaml = T.unlines ("---" : (rawYamlLines ++ ["..."])) optional blanklines - newMetaF <- yamlBsToMeta parseBlocks + newMetaF <- yamlBsToMeta (asBlocks <$> 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 b2028252d..94d4f0f0d 100644 --- a/src/Text/Pandoc/Readers/Metadata.hs +++ b/src/Text/Pandoc/Readers/Metadata.hs @@ -11,7 +11,7 @@ Parse YAML/JSON metadata to 'Pandoc' 'Meta'. -} -module Text.Pandoc.Readers.Metadata ( yamlBsToMeta ) where +module Text.Pandoc.Readers.Metadata ( yamlBsToMeta, yamlMap ) where import Control.Monad import Control.Monad.Except (throwError) @@ -22,7 +22,6 @@ 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.Builder (Blocks) import Text.Pandoc.Class.PandocMonad (PandocMonad (..)) import Text.Pandoc.Definition import Text.Pandoc.Error @@ -31,7 +30,7 @@ import Text.Pandoc.Parsing hiding (tableWith) import Text.Pandoc.Shared yamlBsToMeta :: PandocMonad m - => ParserT Text ParserState m (F Blocks) + => ParserT Text ParserState m (F MetaValue) -> BL.ByteString -> ParserT Text ParserState m (F Meta) yamlBsToMeta pBlocks bstr = do @@ -59,7 +58,7 @@ nodeToKey _ = throwError $ PandocParseError "Non-string key in YAML mapping" toMetaValue :: PandocMonad m - => ParserT Text ParserState m (F Blocks) + => ParserT Text ParserState m (F MetaValue) -> Text -> ParserT Text ParserState m (F MetaValue) toMetaValue pBlocks x = @@ -67,18 +66,21 @@ toMetaValue pBlocks x = -- not end in a newline, but a "block" set off with -- `|` or `>` will. if "\n" `T.isSuffixOf` x - then parseFromString' (asBlocks <$> pBlocks) (x <> "\n") + then parseFromString' pBlocks (x <> "\n") else parseFromString' pInlines x where pInlines = do bs <- pBlocks return $ do bs' <- bs return $ - case B.toList bs' of - [Plain ils] -> MetaInlines ils - [Para ils] -> MetaInlines ils - xs -> MetaBlocks xs - asBlocks p = MetaBlocks . B.toList <$> p + case bs' of + MetaBlocks bs'' -> + case bs'' of + [Plain ils] -> MetaInlines ils + [Para ils] -> MetaInlines ils + xs -> MetaBlocks xs + _ -> bs' + checkBoolean :: Text -> Maybe Bool checkBoolean t @@ -87,7 +89,7 @@ checkBoolean t | otherwise = Nothing yamlToMetaValue :: PandocMonad m - => ParserT Text ParserState m (F Blocks) + => ParserT Text ParserState m (F MetaValue) -> YAML.Node YE.Pos -> ParserT Text ParserState m (F MetaValue) yamlToMetaValue pBlocks (YAML.Scalar _ x) = @@ -112,7 +114,7 @@ yamlToMetaValue pBlocks (YAML.Mapping _ _ o) = yamlToMetaValue _ _ = return $ return $ MetaString "" yamlMap :: PandocMonad m - => ParserT Text ParserState m (F Blocks) + => 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 @@ -120,7 +122,7 @@ yamlMap pBlocks o = do k <- nodeToKey key return (k, v) let kvs' = filter (not . ignorable . fst) kvs - (fmap M.fromList . sequence) <$> mapM toMeta kvs' + fmap M.fromList . sequence <$> mapM toMeta kvs' where ignorable t = "_" `T.isSuffixOf` t toMeta (k, v) = do -- cgit v1.2.3 From 34e54d30202e492fa6a4b1541fd8d094af8bc2a1 Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Mon, 25 May 2020 15:11:36 +0300 Subject: Handle errors in yamlToMeta --- src/Text/Pandoc/App/Opt.hs | 16 ++++++++-------- src/Text/Pandoc/Readers/Markdown.hs | 4 +--- 2 files changed, 9 insertions(+), 11 deletions(-) (limited to 'src') diff --git a/src/Text/Pandoc/App/Opt.hs b/src/Text/Pandoc/App/Opt.hs index c550bed2c..5c39f4ab6 100644 --- a/src/Text/Pandoc/App/Opt.hs +++ b/src/Text/Pandoc/App/Opt.hs @@ -4,6 +4,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} {- | Module : Text.Pandoc.App.Opt Copyright : Copyright (C) 2006-2020 John MacFarlane @@ -40,7 +41,6 @@ import Text.Pandoc.Class.PandocPure import Text.DocTemplates (Context(..)) import Data.Text (Text, unpack) import Data.Default (def) -import Control.Monad (join) import qualified Data.Text as T import qualified Data.Map as M import Text.Pandoc.Definition (Meta(..), MetaValue(..), lookupMeta) @@ -189,7 +189,7 @@ doOpt (k',v) = do -- Note: x comes first because <> for Context is left-biased union -- and we want to favor later default files. See #5988. "metadata" -> - return (\o -> o{ optMetadata = optMetadata o <> yamlToMeta v }) + yamlToMeta v >>= \x -> return (\o -> o{ optMetadata = optMetadata o <> x }) "metadata-files" -> parseYAML v >>= \x -> return (\o -> o{ optMetadataFiles = @@ -478,14 +478,14 @@ defaultOpts = Opt , optStripComments = False } -yamlToMeta :: Node Pos -> Meta -yamlToMeta (Mapping _ _ m) = runEverything (yamlMap pMetaString m) +yamlToMeta :: Node Pos -> Parser Meta +yamlToMeta (Mapping _ _ m) = + either (fail . show) return $ runEverything (yamlMap pMetaString m) where pMetaString = pure . MetaString <$> P.manyChar P.anyChar - runEverything :: P.ParserT Text P.ParserState PandocPure (P.F (M.Map Text MetaValue)) -> Meta - runEverything p = - either (const mempty) (Meta . flip P.runF def) . join . runPure $ P.readWithM p def "" -yamlToMeta _ = mempty + runEverything p = runPure (P.readWithM p def "") + >>= fmap (Meta . flip P.runF def) +yamlToMeta _ = return mempty addMeta :: String -> String -> Meta -> Meta addMeta k v meta = diff --git a/src/Text/Pandoc/Readers/Markdown.hs b/src/Text/Pandoc/Readers/Markdown.hs index 77a371537..cf59ef288 100644 --- a/src/Text/Pandoc/Readers/Markdown.hs +++ b/src/Text/Pandoc/Readers/Markdown.hs @@ -67,14 +67,12 @@ yamlToMeta :: PandocMonad m -> m Meta yamlToMeta opts bstr = do let parser = do - meta <- yamlBsToMeta (fmap asBlocks parseBlocks) bstr + meta <- yamlBsToMeta (asBlocks <$> parseBlocks) bstr return $ runF meta defaultParserState parsed <- readWithM parser def{ stateOptions = opts } "" case parsed of Right result -> return result Left e -> throwError e - where - asBlocks :: Functor f => f (B.Many Block) -> f MetaValue asBlocks p = MetaBlocks . B.toList <$> p -- cgit v1.2.3 From 42e7f1e976842d975cd2e13bafb9228d7bc92acf Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Sun, 28 Jun 2020 22:52:21 +0300 Subject: Clean up T.P.R.Metadata --- src/Text/Pandoc/Readers/Markdown.hs | 7 ++--- src/Text/Pandoc/Readers/Metadata.hs | 59 +++++++++++++++---------------------- 2 files changed, 25 insertions(+), 41 deletions(-) (limited to 'src') 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') -- cgit v1.2.3