Issue warnings for duplicate YAML metadata keys.

Text.Pandoc.Logging: add YamlWarning constructor to LogMessage
[API change].

Closes #10312.

pandoc.cabal

@@ -537,6 +537,7 @@ library
                  unicode-collation     >= 0.1.1    && < 0.2,
                  unicode-transforms    >= 0.3      && < 0.5,
                  yaml                  >= 0.11     && < 0.12,
+                 libyaml               >= 0.1.4    && < 0.2,
                  zip-archive           >= 0.4.3.1  && < 0.5,
                  zlib                  >= 0.5      && < 0.8,
                  xml                   >= 1.3.12   && < 1.4,

src/Text/Pandoc/Logging.hs

@@ -104,6 +104,7 @@ data LogMessage =
   | MakePDFWarning Text
   | UnclosedDiv SourcePos SourcePos
   | UnsupportedCodePage Int
+  | YamlWarning SourcePos Text
   deriving (Show, Eq, Data, Ord, Typeable, Generic)
 
 instance ToJSON LogMessage where
@@ -283,6 +284,12 @@ instance ToJSON LogMessage where
            ]
       UnsupportedCodePage cpg ->
            ["codepage" .= cpg]
+      YamlWarning pos msg ->
+           [ "source" .= sourceName pos
+           , "line" .= toJSON (sourceLine pos)
+           , "column" .= toJSON (sourceColumn pos)
+           , "message" .= msg
+           ]
 
 showPos :: SourcePos -> Text
 showPos pos = Text.pack $ sn ++ "line " ++
@@ -430,6 +437,7 @@ showLogMessage msg =
           " unclosed at " <> showPos closepos <> ", closing implicitly."
        UnsupportedCodePage cpg -> "Unsupported code page " <> tshow cpg <>
           ". Text will likely be garbled."
+       YamlWarning pos m -> "YAML warning (" <> showPos pos <> "): " <> m
 
 messageVerbosity :: LogMessage -> Verbosity
 messageVerbosity msg =
@@ -488,3 +496,4 @@ messageVerbosity msg =
        MakePDFWarning{}              -> WARNING
        UnclosedDiv{}                 -> WARNING
        UnsupportedCodePage{}         -> WARNING
+       YamlWarning{}                 -> WARNING

src/Text/Pandoc/Readers/Metadata.hs

@@ -24,25 +24,38 @@ import qualified Data.Map as M
 import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Yaml as Yaml
-import Data.Aeson (Value(..), Object, Result(..), fromJSON, (.:?), withObject)
-import Data.Aeson.Types (parse)
+import qualified Data.Yaml.Internal as Yaml
+import qualified Text.Libyaml as Y
+import Data.Aeson (Value(..), Object, Result(..), fromJSON, (.:?), withObject,
+                   FromJSON)
+import Data.Aeson.Types (formatRelativePath, parse)
 import Text.Pandoc.Shared (tshow, blocksToInlines)
-import Text.Pandoc.Class.PandocMonad (PandocMonad (..))
+import Text.Pandoc.Class (PandocMonad (..), report)
 import Text.Pandoc.Definition
 import Text.Pandoc.Error
+import Text.Pandoc.Logging (LogMessage(YamlWarning))
 import Text.Pandoc.Parsing hiding (tableWith, parse)
 import qualified Text.Pandoc.UTF8 as UTF8
+import System.IO.Unsafe (unsafePerformIO)
 
 yamlBsToMeta :: (PandocMonad m, HasLastStrPosition st)
              => ParsecT Sources st m (Future st MetaValue)
              -> B.ByteString
              -> ParsecT Sources st m (Future st Meta)
 yamlBsToMeta pMetaValue bstr = do
-  case Yaml.decodeAllEither' bstr of
-       Right (Object o:_) -> fmap Meta <$> yamlMap pMetaValue o
-       Right [] -> return . return $ mempty
-       Right [Null] -> return . return $ mempty
-       Right _  -> Prelude.fail "expected YAML object"
+  case decodeAllWithWarnings bstr of
+       Right (warnings, xs) -> do
+         pos <- getPosition
+         mapM_ (\w -> case w of
+                        Yaml.DuplicateKey jpath ->
+                          report (YamlWarning pos $ "Duplicate key: " <>
+                                  T.pack (formatRelativePath jpath)))
+           warnings
+         case xs of
+           (Object o : _) -> fmap Meta <$> yamlMap pMetaValue o
+           [Null] -> return . return $ mempty
+           [] -> return . return $ mempty
+           _  -> Prelude.fail "expected YAML object"
        Left err' -> do
          let msg = T.pack $ Yaml.prettyPrintParseException err'
          throwError $ PandocParseError $
@@ -51,6 +64,17 @@ yamlBsToMeta pMetaValue bstr = do
                    "\nConsider enclosing the entire field in 'single quotes'"
               else msg
 
+decodeAllWithWarnings :: FromJSON a
+                      => B.ByteString
+                      -> (Either Yaml.ParseException ([Yaml.Warning], [a]))
+decodeAllWithWarnings = either Left (\(ws,res)
+                       -> case res of
+                            Left s  -> Left (Yaml.AesonException s)
+                            Right v -> Right (ws, v))
+                   . unsafePerformIO
+                   . Yaml.decodeAllHelper
+                   . Y.decode
+
 -- Returns filtered list of references.
 yamlBsToRefs :: (PandocMonad m, HasLastStrPosition st)
              => ParsecT Sources st m (Future st MetaValue)
@@ -142,14 +166,19 @@ yamlMetaBlock :: (HasLastStrPosition st, PandocMonad m)
               => ParsecT Sources st m (Future st MetaValue)
               -> ParsecT Sources st m (Future st Meta)
 yamlMetaBlock parser = try $ do
+  pos <- getPosition
   string "---"
   blankline
   notFollowedBy blankline  -- if --- is followed by a blank it's an HRULE
   rawYamlLines <- manyTill anyLine stopLine
   -- by including --- and ..., we allow yaml blocks with just comments:
   let rawYaml = T.unlines ("---" : (rawYamlLines ++ ["..."]))
   optional blanklines
-  yamlBsToMeta parser $ UTF8.fromText rawYaml
+  oldPos <- getPosition
+  setPosition pos
+  res <- yamlBsToMeta parser $ UTF8.fromText rawYaml
+  setPosition oldPos
+  pure res
 
 stopLine :: Monad m => ParsecT Sources st m ()
 stopLine = try $ (string "---" <|> string "...") >> blankline >> return ()