Use HsYAML instead of yaml for translations, YAML metadata.

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

4 files changed, 84 insertions, 70 deletions

diff --git a/src/Text/Pandoc/App.hs b/src/Text/Pandoc/App.hs
index 5cbbe13e7..b79273092 100644
--- a/src/Text/Pandoc/App.hs
+++ b/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
diff --git a/src/Text/Pandoc/Readers/Markdown.hs b/src/Text/Pandoc/Readers/Markdown.hs
index 0cd9ce63f..9fe84013f 100644
--- a/src/Text/Pandoc/Readers/Markdown.hs
+++ b/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
diff --git a/src/Text/Pandoc/Translations.hs b/src/Text/Pandoc/Translations.hs
index 4a216af92..13dcb3b61 100644
--- a/src/Text/Pandoc/Translations.hs
+++ b/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"
diff --git a/src/Text/Pandoc/Writers/Markdown.hs b/src/Text/Pandoc/Writers/Markdown.hs
index fe8f452d3..dc0b154bf 100644
--- a/src/Text/Pandoc/Writers/Markdown.hs
+++ b/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)