Use HsYAML instead of yaml for translations, YAML metadata.

yaml wraps a C library; HsYAML is pure Haskell.
Closes #4747.  Advances #4535.

MANUAL.txt

@@ -3059,7 +3059,9 @@ Metadata will be taken from the fields of the YAML object and added to any
 existing document metadata.  Metadata can contain lists and objects (nested
 arbitrarily), but all string scalars will be interpreted as Markdown.  Fields
 with names ending in an underscore will be ignored by pandoc.  (They may be
-given a role by external processors.)
+given a role by external processors.)  Field names must not be
+interpretable as YAML numbers or boolean values (so, for
+example, `yes`, `True`, and `15` cannot be used as field names).
 
 A document may contain multiple metadata blocks.  The metadata fields will
 be combined through a *left-biased union*:  if two metadata blocks attempt

pandoc.cabal

@@ -370,7 +370,6 @@ library
                  temporary >= 1.1 && < 1.4,
                  blaze-html >= 0.9 && < 0.10,
                  blaze-markup >= 0.8 && < 0.9,
-                 scientific >= 0.2 && < 0.4,
                  vector >= 0.10 && < 0.13,
                  hslua >= 0.9.5 && < 0.9.6,
                  hslua-module-text >= 0.1.2 && < 0.2,
@@ -387,12 +386,10 @@ library
                  http-client >= 0.4.30 && < 0.6,
                  http-client-tls >= 0.2.4 && < 0.4,
                  http-types >= 0.8 && < 0.13,
-                 case-insensitive >= 1.2 && < 1.3
+                 case-insensitive >= 1.2 && < 1.3,
+                 HsYAML >= 0.1.1.1 && < 0.2
   if impl(ghc < 8.0)
-    build-depends: semigroups == 0.18.*,
-                   yaml >= 0.8.11 && < 0.8.31
-  else
-    build-depends: yaml >= 0.8.11 && < 0.9
+    build-depends: semigroups == 0.18.*
   if impl(ghc < 8.4)
      hs-source-dirs: prelude
      other-modules:  Prelude

src/Text/Pandoc/App.hs

@@ -62,8 +62,7 @@ import qualified Data.Text as T
 import qualified Data.Text.Lazy as TL
 import qualified Data.Text.Lazy.Encoding as TE
 import qualified Data.Text.Encoding.Error as TE
-import Data.Yaml (decodeEither')
-import qualified Data.Yaml as Yaml
+import qualified Data.YAML as YAML
 import GHC.Generics
 import Network.URI (URI (..), parseURI)
 #ifdef EMBED_DATA_FILES
@@ -702,9 +701,11 @@ removeMetaKeys :: [(String,String)] -> Pandoc -> Pandoc
 removeMetaKeys kvs pdc = foldr (deleteMeta . fst) pdc kvs
 
 readMetaValue :: String -> MetaValue
-readMetaValue s = case decodeEither' (UTF8.fromString s) of
-                       Right (Yaml.String t) -> MetaString $ T.unpack t
-                       Right (Yaml.Bool b)   -> MetaBool b
+readMetaValue s = case YAML.decodeStrict (UTF8.fromString s) of
+                       Right [YAML.Scalar (YAML.SStr t)]
+                                             -> MetaString $ T.unpack t
+                       Right [YAML.Scalar (YAML.SBool b)]
+                                             -> MetaBool b
                        _                     -> MetaString s
 
 -- Determine default reader based on source file extensions

src/Text/Pandoc/Readers/Markdown.hs

@@ -37,18 +37,14 @@ import Prelude
 import Control.Monad
 import Control.Monad.Except (throwError)
 import Data.Char (isAlphaNum, isPunctuation, isSpace, toLower)
-import qualified Data.HashMap.Strict as H
 import Data.List (intercalate, sortBy, transpose, elemIndex)
 import qualified Data.Map as M
 import Data.Maybe
 import Data.Ord (comparing)
-import Data.Scientific (base10Exponent, coefficient)
 import qualified Data.Set as Set
 import Data.Text (Text)
 import qualified Data.Text as T
-import qualified Data.Vector as V
-import Data.Yaml (ParseException (..), YamlException (..), YamlMark (..))
-import qualified Data.Yaml as Yaml
+import qualified Data.YAML as YAML
 import System.FilePath (addExtension, takeExtension)
 import Text.HTML.TagSoup
 import Text.Pandoc.Builder (Blocks, Inlines)
@@ -246,47 +242,38 @@ yamlMetaBlock = try $ do
   -- by including --- and ..., we allow yaml blocks with just comments:
   let rawYaml = unlines ("---" : (rawYamlLines ++ ["..."]))
   optional blanklines
-  case Yaml.decodeEither' $ UTF8.fromString rawYaml of
-       Right (Yaml.Object hashmap) -> do
-         let alist = H.toList hashmap
-         mapM_ (\(k, v) ->
-             if ignorable k
-                then return ()
-                else do
-                  v' <- yamlToMeta v
-                  let k' = T.unpack k
-                  updateState $ \st -> st{ stateMeta' =
-                     do m <- stateMeta' st
-                        -- if there's already a value, leave it unchanged
-                        case lookupMeta k' m of
-                             Just _ -> return m
-                             Nothing -> do
-                               v'' <- v'
-                               return $ B.setMeta (T.unpack k) v'' m}
+  case YAML.decodeStrict (UTF8.fromString rawYaml) of
+       Right (YAML.Mapping _ hashmap : _) -> do
+         let alist = M.toList hashmap
+         mapM_ (\(k', v) ->
+           case YAML.parseEither (YAML.parseYAML k') of
+                Left e  -> fail e
+                Right k -> do
+                  if ignorable k
+                     then return ()
+                     else do
+                       v' <- yamlToMeta v
+                       let k' = T.unpack k
+                       updateState $ \st -> st{ stateMeta' =
+                          do m <- stateMeta' st
+                             -- if there's already a value, leave it unchanged
+                             case lookupMeta k' m of
+                                  Just _ -> return m
+                                  Nothing -> do
+                                    v'' <- v'
+                                    return $ B.setMeta (T.unpack k) v'' m}
            ) alist
-       Right Yaml.Null -> return ()
+       Right [] -> return ()
+       Right (YAML.Scalar YAML.SNull:_) -> return ()
        Right _ -> do
-                   logMessage $
-                      CouldNotParseYamlMetadata "not an object"
-                      pos
-                   return ()
+                  logMessage $
+                     CouldNotParseYamlMetadata "not an object"
+                     pos
+                  return ()
        Left err' -> do
-                case err' of
-                   InvalidYaml (Just YamlParseException{
-                               yamlProblem = problem
-                             , yamlContext = _ctxt
-                             , yamlProblemMark = Yaml.YamlMark {
-                                   yamlLine = yline
-                                 , yamlColumn = ycol
-                             }}) ->
-                        logMessage $ CouldNotParseYamlMetadata
-                           problem (setSourceLine
-                           (setSourceColumn pos
-                              (sourceColumn pos + ycol))
-                           (sourceLine pos + 1 + yline))
-                   _ -> logMessage $ CouldNotParseYamlMetadata
-                           (show err') pos
-                return ()
+                    logMessage $ CouldNotParseYamlMetadata
+                                 err' pos
+                    return ()
   return mempty
 
 -- ignore fields ending with _
@@ -313,22 +300,25 @@ toMetaValue x =
         -- `|` or `>` will.
 
 yamlToMeta :: PandocMonad m
-           => Yaml.Value -> MarkdownParser m (F MetaValue)
-yamlToMeta (Yaml.String t) = toMetaValue t
-yamlToMeta (Yaml.Number n)
-  -- avoid decimal points for numbers that don't need them:
-  | base10Exponent n >= 0     = return $ return $ MetaString $ show
-                                $ coefficient n * (10 ^ base10Exponent n)
-  | otherwise                 = return $ return $ MetaString $ show n
-yamlToMeta (Yaml.Bool b) = return $ return $ MetaBool b
-yamlToMeta (Yaml.Array xs) = do
-  xs' <- mapM yamlToMeta (V.toList xs)
+           => YAML.Node -> MarkdownParser m (F MetaValue)
+yamlToMeta (YAML.Scalar x) =
+  case x of
+       YAML.SStr t   -> toMetaValue t
+       YAML.SBool b  -> return $ return $ MetaBool b
+       YAML.SFloat d -> return $ return $ MetaString (show d)
+       YAML.SInt i   -> return $ return $ MetaString (show i)
+       _             -> return $ return $ MetaString ""
+yamlToMeta (YAML.Sequence _ xs) = do
+  xs' <- mapM yamlToMeta xs
   return $ do
     xs'' <- sequence xs'
     return $ B.toMetaValue xs''
-yamlToMeta (Yaml.Object o) = do
-  let alist = H.toList o
-  foldM (\m (k,v) ->
+yamlToMeta (YAML.Mapping _ o) = do
+  let alist = M.toList o
+  foldM (\m (k',v) ->
+     case YAML.parseEither (YAML.parseYAML k') of
+          Left e  -> fail e
+          Right k -> do
            if ignorable k
               then return m
               else do

src/Text/Pandoc/Translations.hs

@@ -48,11 +48,12 @@ module Text.Pandoc.Translations (
                          )
 where
 import Prelude
-import Data.Aeson.Types (typeMismatch)
+import Data.Aeson.Types (Value(..), FromJSON(..))
+import qualified Data.Aeson.Types as Aeson
 import qualified Data.HashMap.Strict as HM
 import qualified Data.Map as M
 import Data.Text as T
-import Data.Yaml as Yaml
+import qualified Data.YAML as YAML
 import GHC.Generics (Generic)
 import Text.Pandoc.Shared (safeRead)
 import qualified Text.Pandoc.UTF8 as UTF8
@@ -90,7 +91,15 @@ instance FromJSON Term where
                                Just t' -> pure t'
                                Nothing -> fail $ "Invalid Term name " ++
                                                  show t
-  parseJSON invalid = typeMismatch "Term" invalid
+  parseJSON invalid = Aeson.typeMismatch "Term" invalid
+
+instance YAML.FromYAML Term where
+  parseYAML (YAML.Scalar (YAML.SStr t)) =
+                         case safeRead (T.unpack t) of
+                               Just t' -> pure t'
+                               Nothing -> fail $ "Invalid Term name " ++
+                                                 show t
+  parseYAML invalid = YAML.typeMismatch "Term" invalid
 
 instance FromJSON Translations where
   parseJSON (Object hm) = do
@@ -102,14 +111,28 @@ instance FromJSON Translations where
                  Just t  ->
                    case v of
                         (String s) -> return (t, T.unpack $ T.strip s)
-                        inv        -> typeMismatch "String" inv
-  parseJSON invalid = typeMismatch "Translations" invalid
+                        inv        -> Aeson.typeMismatch "String" inv
+  parseJSON invalid = Aeson.typeMismatch "Translations" invalid
+
+instance YAML.FromYAML Translations where
+  parseYAML = YAML.withMap "Translations" $
+    \tr -> Translations .M.fromList <$> mapM addItem (M.toList tr)
+   where addItem (n@(YAML.Scalar (YAML.SStr k)), v) =
+            case safeRead (T.unpack k) of
+                 Nothing -> YAML.typeMismatch "Term" n
+                 Just t  ->
+                   case v of
+                        (YAML.Scalar (YAML.SStr s)) ->
+                          return (t, T.unpack (T.strip s))
+                        n' -> YAML.typeMismatch "String" n'
+         addItem (n, _) = YAML.typeMismatch "String" n
 
 lookupTerm :: Term -> Translations -> Maybe String
 lookupTerm t (Translations tm) = M.lookup t tm
 
 readTranslations :: String -> Either String Translations
 readTranslations s =
-  case Yaml.decodeEither' $ UTF8.fromString s of
-       Left err' -> Left $ prettyPrintParseException err'
-       Right t   -> Right t
+  case YAML.decodeStrict $ UTF8.fromString s of
+       Left err'   -> Left err'
+       Right (t:_) -> Right t
+       Right []    -> Left "empty YAML document"

src/Text/Pandoc/Writers/Markdown.hs

@@ -50,7 +50,7 @@ import qualified Data.Set as Set
 import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Vector as V
-import Data.Yaml (Value (Array, Bool, Number, Object, String))
+import Data.Aeson (Value (Array, Bool, Number, Object, String))
 import Network.HTTP (urlEncode)
 import Text.HTML.TagSoup (Tag (..), isTagText, parseTags)
 import Text.Pandoc.Class (PandocMonad, report)

stack.lts9.yaml

@@ -27,4 +27,6 @@ extra-deps:
 - pandoc-types-1.17.5
 - haddock-library-1.6.0
 - texmath-0.11
+- HsYAML-0.1.1.1
+- text-1.2.3.0
 resolver: lts-9.14

stack.yaml

@@ -22,6 +22,8 @@ extra-deps:
 - hslua-module-text-0.1.2.1
 - texmath-0.11
 - haddock-library-1.6.0
+- HsYAML-0.1.1.1
+- text-1.2.3.0
 ghc-options:
    "$locals": -fhide-source-paths -XNoImplicitPrelude
 resolver: lts-10.10