[dhall-json] Isolate yaml usage behind Dhall.Yaml (#989)

dhall-json/dhall-json.cabal

@@ -26,6 +26,7 @@ Extra-Source-Files:
     CHANGELOG.md
     tasty/data/*.dhall
     tasty/data/*.json
+
 Source-Repository head
     Type: git
     Location: https://github.com/dhall-lang/dhall-haskell/tree/master/dhall-json
@@ -53,10 +54,8 @@ Library
     Exposed-Modules:
         Dhall.JSON
         Dhall.JSONToDhall
-    Other-Modules:
-        Dhall.JSON.Compat
+        Dhall.Yaml            
     GHC-Options: -Wall
-
     if flag(yaml-pre-0_11)
         Build-Depends:
             yaml >= 0.5.0 && < 0.11
@@ -130,14 +129,6 @@ Executable yaml-to-dhall
         Paths_dhall_json
     GHC-Options: -Wall
 
-    if flag(yaml-pre-0_11)
-        Build-Depends:
-            yaml >= 0.5.0 && < 0.11
-    else
-        Build-Depends:
-            libyaml >= 0.1.1.0 && < 0.2 ,
-            yaml    >= 0.11.0  && < 0.12
-
 Test-Suite tasty
     Type: exitcode-stdio-1.0
     Hs-Source-Dirs: tasty

dhall-json/dhall-to-yaml/Main.hs

@@ -14,6 +14,7 @@ import qualified Data.ByteString
 import qualified Data.Text.IO
 import qualified Dhall
 import qualified Dhall.JSON
+import qualified Dhall.Yaml
 import qualified GHC.IO.Encoding
 import qualified Options.Applicative
 import qualified System.Exit
@@ -75,7 +76,7 @@ main = do
 
         json <- omission <$> explaining (Dhall.JSON.codeToValue conversion UseYAMLEncoding "(stdin)" stdin)
 
-        let yaml = Dhall.JSON.jsonToYaml json documents quoted
+        let yaml = Dhall.Yaml.jsonToYaml json documents quoted
 
         Data.ByteString.putStr yaml
 

dhall-json/src/Dhall/JSON.hs

@@ -168,7 +168,6 @@ module Dhall.JSON (
     , SpecialDoubleMode(..)
     , handleSpecialDoubles
     , codeToValue
-    , jsonToYaml
 
     -- * Exceptions
     , CompileError(..)
@@ -186,17 +185,13 @@ import Dhall.Map (Map)
 import Options.Applicative (Parser)
 
 import qualified Control.Lens
-import qualified Data.ByteString
 import qualified Data.Foldable
 import qualified Data.HashMap.Strict
 import qualified Data.List
 import qualified Data.Ord
 import qualified Data.Text
-import qualified Data.Vector
-import qualified Data.Yaml
 import qualified Dhall.Core
 import qualified Dhall.Import
-import qualified Dhall.JSON.Compat
 import qualified Dhall.Map
 import qualified Dhall.Parser
 import qualified Dhall.TypeCheck
@@ -898,17 +893,3 @@ codeToValue conversion specialDoubleMode name code = do
       Left  err  -> Control.Exception.throwIO err
       Right json -> return json
 
--- | Transform json representation into yaml
-jsonToYaml
-    :: Value
-    -> Bool
-    -> Bool
-    -> Data.ByteString.ByteString
-jsonToYaml json documents quoted = case (documents, json) of
-  (True, Data.Yaml.Array elems)
-    -> Data.ByteString.intercalate "\n---\n"
-       $ fmap encodeYaml
-       $ Data.Vector.toList elems
-  _ -> encodeYaml json
-  where
-    encodeYaml = Dhall.JSON.Compat.encodeYaml quoted

dhall-json/src/Dhall/JSON/Compat.hs

@@ -1,37 +0,0 @@
-{-# LANGUAGE CPP               #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module Dhall.JSON.Compat where
-
-import Data.ByteString (ByteString)
-import Data.Yaml (Value)
-
-import qualified Data.Yaml
-#if MIN_VERSION_yaml(0,10,2)
-import qualified Data.Text
-import qualified Text.Libyaml
-#endif
-
-encodeYaml :: Bool -> Value -> ByteString
-encodeYaml _quoted =
-#if MIN_VERSION_yaml(0,10,2)
-    Data.Yaml.encodeWith encodeOptions
-  where
-    customStyle = \s -> case () of
-        ()
-            | "\n" `Data.Text.isInfixOf` s -> ( noTag, literal )
-            | otherwise -> ( noTag, Text.Libyaml.SingleQuoted )
-        where
-            noTag = Text.Libyaml.NoTag
-            literal = Text.Libyaml.Literal
-
-    quotedOptions = Data.Yaml.setStringStyle
-                        customStyle
-                        Data.Yaml.defaultEncodeOptions
-
-    encodeOptions = if _quoted
-        then quotedOptions
-        else Data.Yaml.defaultEncodeOptions
-#else
-    Data.Yaml.encode
-#endif

dhall-json/src/Dhall/Yaml.hs

@@ -0,0 +1,56 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP               #-}
+module Dhall.Yaml ( jsonToYaml, yamlToJson ) where
+
+import Data.Bifunctor (bimap)
+import Data.ByteString (ByteString)
+
+import qualified Data.Aeson
+import qualified Data.ByteString
+import qualified Data.Vector
+import qualified Data.Yaml
+#if MIN_VERSION_yaml(0,10,2)
+import qualified Data.Text
+import qualified Text.Libyaml
+#endif
+
+-- | Transform json representation into yaml
+jsonToYaml
+    :: Data.Aeson.Value
+    -> Bool
+    -> Bool
+    -> ByteString
+jsonToYaml json documents quoted = case (documents, json) of
+  (True, Data.Yaml.Array elems)
+    -> Data.ByteString.intercalate "\n---\n"
+       $ fmap (encodeYaml encodeOptions)
+       $ Data.Vector.toList elems
+  _ -> encodeYaml encodeOptions json
+  where
+#if !MIN_VERSION_yaml(0,10,2)
+    encodeYaml = Data.Yaml.encode
+#else
+    encodeYaml = Data.Yaml.encodeWith
+
+    customStyle = \s -> case () of
+        ()
+            | "\n" `Data.Text.isInfixOf` s -> ( noTag, literal )
+            | otherwise -> ( noTag, Text.Libyaml.SingleQuoted )
+        where
+            noTag = Text.Libyaml.NoTag
+            literal = Text.Libyaml.Literal
+
+    quotedOptions = Data.Yaml.setStringStyle
+                        customStyle
+                        Data.Yaml.defaultEncodeOptions
+
+    encodeOptions = if quoted
+        then quotedOptions
+        else Data.Yaml.defaultEncodeOptions
+#endif
+
+-- | Transform yaml representation into dhall
+yamlToJson :: ByteString -> Either String Data.Aeson.Value
+yamlToJson  =
+  bimap Data.Yaml.prettyPrintParseException id . Data.Yaml.decodeEither'
+

dhall-json/tasty/Main.hs

@@ -13,6 +13,7 @@ import qualified Data.Text.IO
 import qualified Dhall.Import
 import qualified Dhall.JSON
 import qualified Dhall.Parser
+import qualified Dhall.Yaml
 import qualified Test.Tasty
 import qualified Test.Tasty.HUnit
 
@@ -81,7 +82,7 @@ yamlQuotedStrings = Test.Tasty.HUnit.testCase "Yaml: quoted string style" assert
             Left  exception   -> Control.Exception.throwIO exception
             Right jsonValue -> return jsonValue
 
-        let actualValue = Dhall.JSON.jsonToYaml jsonValue False True
+        let actualValue = Dhall.Yaml.jsonToYaml jsonValue False True
 
         bytes <- Data.ByteString.Lazy.readFile "./tasty/data/quoted.yaml"
         let expectedValue = Data.ByteString.Lazy.toStrict bytes
@@ -109,7 +110,7 @@ yaml = Test.Tasty.HUnit.testCase "Yaml: normal string style" assertion
             Left  exception   -> Control.Exception.throwIO exception
             Right jsonValue -> return jsonValue
 
-        let actualValue = Dhall.JSON.jsonToYaml jsonValue False False
+        let actualValue = Dhall.Yaml.jsonToYaml jsonValue False False
 
         bytes <- Data.ByteString.Lazy.readFile "./tasty/data/normal.yaml"
         let expectedValue = Data.ByteString.Lazy.toStrict bytes

dhall-json/yaml-to-dhall/Main.hs

@@ -18,7 +18,6 @@ import           Data.Monoid ((<>))
 import           Data.Text (Text)
 import qualified Data.Text.IO as Text
 import           Data.Version (showVersion)
-import qualified Data.Yaml as Y
 import qualified GHC.IO.Encoding
 import qualified Options.Applicative as O
 import           Options.Applicative (Parser, ParserInfo)
@@ -27,7 +26,7 @@ import qualified System.IO
 
 import qualified Dhall.Core as D
 import           Dhall.JSONToDhall
-
+import           Dhall.Yaml (yamlToJson, jsonToYaml)
 import qualified Paths_dhall_json as Meta
 
 -- ---------------
@@ -70,7 +69,7 @@ parseOptions = Options <$> parseVersion
 -- ----------
 
 showYAML :: A.Value -> String
-showYAML value = BS8.unpack (Y.encode value)
+showYAML value = BS8.unpack (jsonToYaml value False False)
 
 data YAMLCompileError = YAMLCompileError CompileError
 
@@ -96,9 +95,8 @@ main = do
     handle $ do
         stdin <- BSL8.getContents
 
-        value :: A.Value <- case Y.decodeEither' . BS8.concat $ BSL8.toChunks stdin of
-          Left err -> throwIO (userError $ Y.prettyPrintParseException err)
-          Right v -> pure v
+        value <- either (throwIO . userError) pure
+                        (yamlToJson . BS8.concat $ BSL8.toChunks stdin)
 
         expr <- typeCheckSchemaExpr YAMLCompileError =<< resolveSchemaExpr schema