Use yamlet for YAML parsing.

Pandoc parsed YAML with the yaml package, which depends on the C
library libyaml. It now uses yamlet, a pure Haskell YAML 1.2 parser.
Values still go through the existing aeson instances.

Behavior changes:

- YAML errors show the file, the line and the column, with the
  offending line. In metadata blocks the line is the line in the
  document.
- `yes`, `no`, `on`, `off`, `y` and `n` are strings,
  not booleans, as in YAML 1.2. This restores the behavior before
  the switch from HsYAML.
- Duplicate keys in a mapping are an error. They were a warning.
- .5, .inf and .nan are numbers.

Text.Pandoc.Translations: readTranslations takes the path of the
file, for error messages [API change].

pandoc.cabal

@@ -580,8 +580,8 @@ library
                  unicode-collation     >= 0.1.1    && < 0.2,
                  unicode-data          >= 0.6      && < 0.10,
                  unicode-transforms    >= 0.3      && < 0.5,
-                 yaml                  >= 0.11     && < 0.12,
-                 libyaml               >= 0.1.4    && < 0.2,
+                 yamlet                >= 1.0.0.1  && < 1.1,
+                 yamlet-aeson          >= 1.0.0.1  && < 1.1,
                  zip-archive           >= 0.5      && < 0.6,
                  zlib                  >= 0.6      && < 0.8,
                  xml                   >= 1.3.12   && < 1.4,

src/Text/Pandoc/App/Opt.hs

@@ -67,11 +67,14 @@ import qualified Data.Text as T
 import qualified Data.Map as M
 import qualified Data.ByteString.Char8 as B8
 import Text.Pandoc.Definition (Meta(..), MetaValue(..))
-import Data.Aeson (defaultOptions, Options(..), Result(..),
-                   genericToJSON, fromJSON, camelTo2, eitherDecodeStrict)
 import Data.Aeson.TH (deriveJSON)
 import Control.Applicative ((<|>))
-import Data.Yaml
+import Data.Aeson
+import Data.Aeson.Types
+import qualified Data.List as L
+import qualified Data.List.NonEmpty as NE
+import qualified Yamlet as Y
+import Yamlet.Aeson
 
 -- | The type of line-endings to be used when writing plain-text.
 data LineEnding = LF | CRLF | Native deriving (Show, Generic)
@@ -938,11 +941,11 @@ applyDefaults opt file = do
          Left err' -> throwError $ PandocParseError $ T.pack $
             "Error parsing " <> file <> ":\n" <> err'
      else
-       case decodeEither' (B8.unlines . takeWhile (/= "...") . B8.lines $ inp) of
-           Right f -> f opt
-           Left err'  -> throwError $ PandocParseError $ T.pack $
+       case Y.decode (B8.unlines . takeWhile (/= "...") . B8.lines $ inp) of
+           Right (ViaAeson f) -> f opt
+           Left errs  -> throwError $ PandocParseError $ T.pack $
                   "Error parsing " <> file <> ":\n" <>
-                  Data.Yaml.prettyPrintParseException err'
+                  L.intercalate "\n" (map (Y.prettyError file) (NE.toList errs))
 
 fullDefaultsPath :: (PandocMonad m, MonadIO m)
                  => Maybe FilePath

src/Text/Pandoc/Readers/Metadata.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications    #-}
 {- |
    Module      : Text.Pandoc.Readers.Metadata
    Copyright   : Copyright (C) 2006-2024 John MacFarlane
@@ -20,24 +21,22 @@ module Text.Pandoc.Readers.Metadata (
 
 import Control.Monad.Except (throwError)
 import qualified Data.ByteString as B
+import qualified Data.List as L
 import qualified Data.Map as M
 import qualified Data.Vector as V
 import Data.Text (Text)
 import qualified Data.Text as T
-import qualified Data.Yaml as Yaml
-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 qualified Data.List.NonEmpty as NE
+import qualified Yamlet as Y
+import Yamlet.Aeson ()
+import Data.Aeson (Value(..), Object, Result(..), fromJSON, (.:?), withObject)
+import Data.Aeson.Types (parse)
 import Text.Pandoc.Shared (tshow, blocksToInlines)
-import Text.Pandoc.Class (PandocMonad (..), report)
+import Text.Pandoc.Class (PandocMonad (..))
 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)
@@ -45,37 +44,28 @@ yamlBsToMeta :: (PandocMonad m, HasLastStrPosition st)
              -> ParsecT Sources st m (Future st Meta)
 yamlBsToMeta pMetaValue bstr = do
   pos <- getPosition
-  case decodeAllWithWarnings bstr of
-       Right (warnings, xs) -> do
-         mapM_ (\(Yaml.DuplicateKey jpath) ->
-                          report (YamlWarning pos $ "Duplicate key: " <>
-                                  T.pack (formatRelativePath jpath)))
-           warnings
+  case Y.decodeAll @Value bstr of
+       Right xs ->
          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 $ "Error parsing YAML metadata at " <>
-                             show pos <> ":\n" <>
-                             Yaml.prettyPrintParseException err'
-         throwError $ PandocParseError $
-           if "did not find expected key" `T.isInfixOf` msg
-              then msg <>
-                   "\nConsider enclosing the entire field in 'single quotes'"
-              else msg
+       Left errs -> throwError $ PandocParseError $ T.pack $
+         "Error parsing YAML metadata at " <> show pos <> ":\n" <>
+         renderYamlErrors pos errs
 
-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
+-- | Render the errors with their lines in the source, given the position of
+-- the first line of the YAML input.
+renderYamlErrors :: SourcePos -> NE.NonEmpty Y.Error -> String
+renderYamlErrors pos =
+  L.intercalate "\n" . map (Y.prettyError (sourceName pos) . shift) . NE.toList
+  where
+    shift :: Y.Error -> Y.Error
+    shift err@Y.Error{Y.location = loc@Y.Location{Y.line = l}}
+      -- Line 0 means that the error has no position.
+      | l == 0 = err
+      | otherwise = err{Y.location = loc{Y.line = l + sourceLine pos - 1}}
 
 -- Returns filtered list of references.
 yamlBsToRefs :: (PandocMonad m, HasLastStrPosition st)
@@ -83,8 +73,9 @@ yamlBsToRefs :: (PandocMonad m, HasLastStrPosition st)
              -> (Text -> Bool) -- ^ Filter for id
              -> B.ByteString
              -> ParsecT Sources st m (Future st [MetaValue])
-yamlBsToRefs pMetaValue idpred bstr =
-  case Yaml.decodeAllEither' bstr of
+yamlBsToRefs pMetaValue idpred bstr = do
+  pos <- getPosition
+  case Y.decodeAll @Value bstr of
        Right (Object m : _) -> do
          case parse (withObject "metadata" (.:? "references")) (Object m) of
            Success (Just refs) -> sequence <$>
@@ -94,8 +85,8 @@ yamlBsToRefs pMetaValue idpred bstr =
          let refs = filter hasSelectedId $ V.toList v
          sequence <$> mapM (yamlToMetaValue pMetaValue) (filter hasSelectedId refs)
        Right _ -> return . return $ []
-       Left err' -> throwError $ PandocParseError
-                               $ T.pack $ Yaml.prettyPrintParseException err'
+       Left errs -> throwError $ PandocParseError
+                               $ T.pack $ renderYamlErrors pos errs
  where
    isSelected (String t) = idpred t
    isSelected _ = False

src/Text/Pandoc/Translations.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP                        #-}
 {-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE TypeApplications           #-}
 {- |
    Module      : Text.Pandoc.Translations
    Copyright   : Copyright (C) 2017-2024 John MacFarlane
@@ -27,18 +28,19 @@ import Data.Containers.ListUtils (nubOrd)
 import Text.Pandoc.Logging (LogMessage(..))
 import Control.Monad.Except (catchError)
 import qualified Data.Text as T
-import qualified Data.Yaml as Yaml
-import qualified Text.Pandoc.UTF8 as UTF8
-import Data.Yaml (prettyPrintParseException)
+import qualified Data.List.NonEmpty as NE
+import qualified Yamlet as Y
+import Yamlet.Aeson
 import Text.Collate.Lang (Lang(..), renderLang)
 
--- | Parse YAML translations.
-readTranslations :: T.Text -> Either T.Text Translations
-readTranslations s =
-  case Yaml.decodeAllEither' $ UTF8.fromText s of
-       Left err' -> Left $ T.pack $ prettyPrintParseException err'
-       Right (t:_)     -> Right t
-       Right []        -> Left "empty YAML document"
+-- | Parse YAML translations. The file path is used in error messages.
+readTranslations :: FilePath -> T.Text -> Either T.Text Translations
+readTranslations fp s =
+  case Y.decodeAllText @(ViaAeson Translations) s of
+       Left errs -> Left $ T.intercalate "\n" $
+         map (T.pack . Y.prettyError fp) (NE.toList errs)
+       Right (ViaAeson t:_) -> Right t
+       Right []        -> Left $ T.pack fp <> ": empty YAML document"
 
 -- | Select the language to use with 'translateTerm'.
 -- Note that this does not read a translation file;
@@ -68,12 +70,11 @@ getTranslations = do
          let getTrans [] = return mempty
              getTrans (fp:fps) = do
                result <- catchError (Right <$> (readDataFile fp >>= toTextM fp))
-                             (\_ -> pure (Left ""))
-               case result >>= readTranslations of
+                             (\_ -> pure (Left (T.pack fp)))
+               case result >>= readTranslations fp of
                   Left e
                     | null fps -> do
-                      report $ CouldNotLoadTranslations (renderLang lang)
-                                  (T.pack fp <> ": " <> e)
+                      report $ CouldNotLoadTranslations (renderLang lang) e
                       -- make sure we don't try again...
                       modifyCommonState $ \st ->
                         st{ stTranslations = Nothing }

stack.yaml

@@ -41,6 +41,12 @@ extra-deps:
 - typst-0.12
 - texmath-0.13.3.1
 - citeproc-0.14.1
+- yamlet-1.0.0.1
+- yamlet-aeson-1.0.0.1
+# yamlet and yamlet-aeson need newer versions than the snapshot has:
+- aeson-2.2.5.1
+- scientific-0.3.9.0
+- text-iso8601-0.1.1.2
 # needed because not yet in nixpkgs:
 - pandoc-types-1.23.1.2
 # needed because not yet in nixpkgs:

test/command/4819.md

@@ -49,7 +49,9 @@ foo: no
 ...
 ^D
 Pandoc
-  Meta { unMeta = fromList [ ( "foo" , MetaBool False ) ] }
+  Meta
+    { unMeta = fromList [ ( "foo" , MetaInlines [ Str "no" ] ) ]
+    }
   []
 ```