summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGabrielGonzalez <>2019-06-07 00:16:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-06-07 00:16:00 (GMT)
commit3a1a99d9e1726e9e419d3713bfdabe53dacfe57b (patch)
tree1ffcbc6ca882b150ec61411d69c1ad69f6b77989
parentd3d7ef9113dcd1006db93616f8323c62fc4f1e36 (diff)
version 1.3.0HEAD1.3.0master
-rw-r--r--CHANGELOG.md15
-rw-r--r--dhall-json.cabal65
-rw-r--r--dhall-to-json/Main.hs27
-rw-r--r--dhall-to-yaml/Main.hs22
-rw-r--r--json-to-dhall/Main.hs494
-rw-r--r--src/Dhall/JSON.hs98
-rw-r--r--src/Dhall/JSONToDhall.hs529
-rw-r--r--src/Dhall/Yaml.hs56
-rw-r--r--tasty/Main.hs59
-rw-r--r--tasty/data/yaml.dhall5
-rw-r--r--yaml-to-dhall/Main.hs114
11 files changed, 949 insertions, 535 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 6a5812e..12ea064 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,3 +1,18 @@
+1.3.0
+
+* BREAKING CHANGE: Change YAML/JSON encoding for `NaN`/`Infinity`/`-Infinity`
+ * They are now encoded as the standard `"nan"`/`"inf"`/`"-inf"`
+ representations instead of `null`/`MIN_DOUBLE/`/`MAX_DOUBLE`
+ * See: https://github.com/dhall-lang/dhall-haskell/pull/946
+* BREAKING CHANGE: Isolate YAML code to one modulee
+ * This is a breaking change because it moves `Dhall.JSON.jsonToYaml` to
+ `Dhall.YAML.jsonToYaml`
+ * See: https://github.com/dhall-lang/dhall-haskell/pull/989/files
+* New `yaml-to-dhall` command-line utility
+ * See: https://github.com/dhall-lang/dhall-haskell/pull/977
+* Add `--quoted` flag to force quoting of YAML string literals
+ * See: https://github.com/dhall-lang/dhall-haskell/pull/941
+
1.2.8
* New `json-to-dhall` command-line utility
diff --git a/dhall-json.cabal b/dhall-json.cabal
index e1a2afe..c909ef0 100644
--- a/dhall-json.cabal
+++ b/dhall-json.cabal
@@ -1,5 +1,5 @@
Name: dhall-json
-Version: 1.2.8
+Version: 1.3.0
Cabal-Version: >=1.8.0.2
Build-Type: Simple
Tested-With: GHC == 7.10.3, GHC == 8.4.3, GHC == 8.6.1
@@ -9,10 +9,10 @@ Copyright: 2017 Gabriel Gonzalez
Author: Gabriel Gonzalez
Maintainer: Gabriel439@gmail.com
Bug-Reports: https://github.com/dhall-lang/dhall-haskell/issues
-Synopsis: Compile Dhall to JSON or YAML
+Synopsis: Convert between Dhall and JSON or YAML
Description:
- Use this package if you want to compile Dhall expressions to JSON or YAML.
- You can use this package as a library or an executable:
+ Use this package if you want to convert between Dhall expressions and JSON
+ or YAML. You can use this package as a library or an executable:
.
* See the "Dhall.JSON" module if you want to use this package as a library
.
@@ -26,21 +26,43 @@ 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
+Flag yaml-pre-0_11
+ Default: False
+ Manual: False
+
Library
Hs-Source-Dirs: src
Build-Depends:
base >= 4.8.0.0 && < 5 ,
aeson >= 1.0.0.0 && < 1.5 ,
- dhall >= 1.22.0 && < 1.23,
+ aeson-pretty < 0.9 ,
+ bytestring < 0.11,
+ containers ,
+ dhall >= 1.22.0 && < 1.25,
+ exceptions >= 0.8.3 && < 0.11,
+ lens >= 2.5 && < 4.18,
optparse-applicative >= 0.14.0.0 && < 0.15,
+ scientific >= 0.3.0.0 && < 0.4 ,
text >= 0.11.1.0 && < 1.3 ,
- unordered-containers < 0.3
- Exposed-Modules: Dhall.JSON
+ unordered-containers < 0.3 ,
+ vector
+ Exposed-Modules:
+ Dhall.JSON
+ Dhall.JSONToDhall
+ Dhall.Yaml
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
Executable dhall-to-json
Hs-Source-Dirs: dhall-to-json
@@ -48,7 +70,7 @@ Executable dhall-to-json
Build-Depends:
base ,
aeson ,
- aeson-pretty < 0.9 ,
+ aeson-pretty >= 0.8.5 && < 0.9 ,
bytestring < 0.11,
dhall ,
dhall-json ,
@@ -68,8 +90,6 @@ Executable dhall-to-yaml
dhall ,
dhall-json ,
optparse-applicative ,
- yaml >= 0.5.0 && < 0.12,
- vector ,
text
GHC-Options: -Wall
@@ -79,15 +99,30 @@ Executable json-to-dhall
Build-Depends:
base ,
aeson ,
- aeson-pretty < 0.9 ,
bytestring < 0.11 ,
dhall ,
+ dhall-json ,
+ exceptions >= 0.8.3 && < 0.11 ,
optparse-applicative ,
- text < 1.3 ,
- scientific >= 0.3.0.0 && < 0.4 ,
+ text < 1.3
+ if !impl(ghc >= 8.0) && !impl(eta >= 0.8.4)
+ Build-Depends: semigroups == 0.18.*
+ Other-Modules:
+ Paths_dhall_json
+ GHC-Options: -Wall
+
+Executable yaml-to-dhall
+ Hs-Source-Dirs: yaml-to-dhall
+ Main-Is: Main.hs
+ Build-Depends:
+ base ,
+ aeson ,
+ bytestring < 0.11 ,
+ dhall ,
+ dhall-json ,
exceptions >= 0.8.3 && < 0.11 ,
- containers ,
- unordered-containers >= 0.1.3.0 && < 0.3
+ optparse-applicative ,
+ text < 1.3
if !impl(ghc >= 8.0) && !impl(eta >= 0.8.4)
Build-Depends: semigroups == 0.18.*
Other-Modules:
diff --git a/dhall-to-json/Main.hs b/dhall-to-json/Main.hs
index 8670f01..07d556f 100644
--- a/dhall-to-json/Main.hs
+++ b/dhall-to-json/Main.hs
@@ -9,7 +9,7 @@ import Control.Monad (when)
import Data.Aeson (Value)
import Data.Monoid ((<>))
import Data.Version (showVersion)
-import Dhall.JSON (Conversion)
+import Dhall.JSON (Conversion, SpecialDoubleMode(..))
import Options.Applicative (Parser, ParserInfo)
import qualified Control.Exception
@@ -27,11 +27,12 @@ import qualified System.Exit
import qualified System.IO
data Options = Options
- { explain :: Bool
- , pretty :: Bool
- , omission :: Value -> Value
- , version :: Bool
- , conversion :: Conversion
+ { explain :: Bool
+ , pretty :: Bool
+ , omission :: Value -> Value
+ , version :: Bool
+ , conversion :: Conversion
+ , approximateSpecialDoubles :: Bool
}
parseOptions :: Parser Options
@@ -42,6 +43,7 @@ parseOptions =
<*> Dhall.JSON.parseOmission
<*> parseVersion
<*> Dhall.JSON.parseConversion
+ <*> parseApproximateSpecialDoubles
where
parseExplain =
Options.Applicative.switch
@@ -75,6 +77,12 @@ parseOptions =
<> Options.Applicative.help "Display version"
)
+ parseApproximateSpecialDoubles =
+ Options.Applicative.switch
+ ( Options.Applicative.long "approximate-special-doubles"
+ <> Options.Applicative.help "Use approximate representation for NaN/±Infinity"
+ )
+
parserInfo :: ParserInfo Options
parserInfo =
Options.Applicative.info
@@ -106,9 +114,14 @@ main = do
let explaining = if explain then Dhall.detailed else id
+ let specialDoubleMode =
+ if approximateSpecialDoubles
+ then ApproximateWithinJSON
+ else ForbidWithinJSON
+
stdin <- Data.Text.IO.getContents
- json <- omission <$> explaining (Dhall.JSON.codeToValue conversion "(stdin)" stdin)
+ json <- omission <$> explaining (Dhall.JSON.codeToValue conversion specialDoubleMode "(stdin)" stdin)
Data.ByteString.Char8.putStrLn $ Data.ByteString.Lazy.toStrict $ encode json
diff --git a/dhall-to-yaml/Main.hs b/dhall-to-yaml/Main.hs
index fd516df..06aacc6 100644
--- a/dhall-to-yaml/Main.hs
+++ b/dhall-to-yaml/Main.hs
@@ -6,16 +6,15 @@ module Main where
import Control.Exception (SomeException)
import Data.Aeson (Value)
import Data.Monoid ((<>))
-import Dhall.JSON (Conversion)
+import Dhall.JSON (Conversion, SpecialDoubleMode(..))
import Options.Applicative (Parser, ParserInfo)
import qualified Control.Exception
import qualified Data.ByteString
import qualified Data.Text.IO
-import qualified Data.Vector
-import qualified Data.Yaml
import qualified Dhall
import qualified Dhall.JSON
+import qualified Dhall.Yaml
import qualified GHC.IO.Encoding
import qualified Options.Applicative
import qualified System.Exit
@@ -25,6 +24,7 @@ data Options = Options
{ explain :: Bool
, omission :: Value -> Value
, documents :: Bool
+ , quoted :: Bool
, conversion :: Conversion
}
@@ -34,6 +34,7 @@ parseOptions =
<$> parseExplain
<*> Dhall.JSON.parseOmission
<*> parseDocuments
+ <*> parseQuoted
<*> Dhall.JSON.parseConversion
where
parseExplain =
@@ -48,6 +49,12 @@ parseOptions =
<> Options.Applicative.help "If given a Dhall list, output a document for every element"
)
+ parseQuoted =
+ Options.Applicative.switch
+ ( Options.Applicative.long "quoted"
+ <> Options.Applicative.help "Prevent from generating not quoted scalars"
+ )
+
parserInfo :: ParserInfo Options
parserInfo =
Options.Applicative.info
@@ -67,14 +74,9 @@ main = do
stdin <- Data.Text.IO.getContents
- json <- omission <$> explaining (Dhall.JSON.codeToValue conversion "(stdin)" stdin)
+ json <- omission <$> explaining (Dhall.JSON.codeToValue conversion UseYAMLEncoding "(stdin)" stdin)
- let yaml = case (documents, json) of
- (True, Data.Yaml.Array elems)
- -> Data.ByteString.intercalate "\n---\n"
- $ fmap Data.Yaml.encode
- $ Data.Vector.toList elems
- _ -> Data.Yaml.encode json
+ let yaml = Dhall.Yaml.jsonToYaml json documents quoted
Data.ByteString.putStr yaml
diff --git a/json-to-dhall/Main.hs b/json-to-dhall/Main.hs
index 16d16d6..5634bcb 100644
--- a/json-to-dhall/Main.hs
+++ b/json-to-dhall/Main.hs
@@ -6,159 +6,16 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-| The tool for converting JSON data to Dhall given a Dhall /type/ expression necessary to make the translation unambiguous.
-
- Reasonable requirements to the conversion tool are:
-
- 1. The Dhall type expression @/t/@ passed as an argument to @json-to-dhall@ should be a valid type of the resulting Dhall expression
- 2. A JSON data produced by the corresponding @dhall-to-json@ from the Dhall expression of type @/t/@ should (under reasonable assumptions) reproduce the original Dhall expression using @json-to-dhall@ with type argument @/t/@
-
- Only a subset of Dhall types consisting of all the primitive types as well as @Optional@, @Union@ and @Record@ constructs, is used for reading JSON data:
-
- * @Bool@s
- * @Natural@s
- * @Integer@s
- * @Double@s
- * @Text@s
- * @List@s
- * @Optional@ values
- * unions
- * records
-
-== Primitive types
-
- JSON @Bool@s translate to Dhall bools:
-
-> $ json-to-dhall Bool <<< 'true'
-> True
-> $ json-to-dhall Bool <<< 'false'
-> False
-
- JSON numbers translate to Dhall numbers:
-
-> $ json-to-dhall Integer <<< 2
-> +2
-> $ json-to-dhall Natural <<< 2
-> 2
-> $ json-to-dhall Double <<< -2.345
-> -2.345
-
- Dhall @Text@ corresponds to JSON text:
-
-> $ json-to-dhall Text <<< '"foo bar"'
-> "foo bar"
-
-
-== Lists and records
-
- Dhall @List@s correspond to JSON lists:
-
-> $ json-to-dhall 'List Integer' <<< '[1, 2, 3]'
-> [ +1, +2, +3 ]
-
-
- Dhall __records__ correspond to JSON records:
-
-> $ json-to-dhall '{foo : List Integer}' <<< '{"foo": [1, 2, 3]}'
-> { foo = [ +1, +2, +3 ] }
-
-
- Note, that by default, only the fields required by the Dhall type argument are parsed (as you commonly will not need all the data), the remaining ones being ignored:
-
-> $ json-to-dhall '{foo : List Integer}' <<< '{"foo": [1, 2, 3], "bar" : "asdf"}'
-> { foo = [ +1, +2, +3 ] }
-
-
- If you do need to make sure that Dhall fully reflects JSON record data comprehensively, @--records-strict@ flag should be used:
-
-> $ json-to-dhall --records-strict '{foo : List Integer}' <<< '{"foo": [1, 2, 3], "bar" : "asdf"}'
-> Error: Key(s) @bar@ present in the JSON object but not in the corresponding Dhall record. This is not allowed in presence of --records-strict:
-
-
- By default, JSON key-value arrays will be converted to Dhall records:
-
-> $ json-to-dhall '{ a : Integer, b : Text }' <<< '[{"key":"a", "value":1}, {"key":"b", "value":"asdf"}]'
-> { a = +1, b = "asdf" }
-
-
- Attempting to do the same with @--no-keyval-arrays@ on will result in error:
-
-> $ json-to-dhall --no-keyval-arrays '{ a : Integer, b : Text }' <<< '[{"key":"a", "value":1}, {"key":"b", "value":"asdf"}]'
-> Error: JSON (key-value) arrays cannot be converted to Dhall records under --no-keyval-arrays flag:
-
- Conversion of the homogeneous JSON maps to the corresponding Dhall association lists by default:
-
-> $ json-to-dhall 'List { mapKey : Text, mapValue : Text }' <<< '{"foo": "bar"}'
-> [ { mapKey = "foo", mapValue = "bar" } ]
-
- Flag @--no-keyval-maps@ switches off this mechanism (if one would ever need it):
-
-> $ json-to-dhall --no-keyval-maps 'List { mapKey : Text, mapValue : Text }' <<< '{"foo": "bar"}'
-> Error: Homogeneous JSON map objects cannot be converted to Dhall association lists under --no-keyval-arrays flag
-
-
-== Optional values and unions
-
- Dhall @Optional@ Dhall type allows null or missing JSON values:
-
-> $ json-to-dhall "Optional Integer" <<< '1'
-> Some +1
-
-> $ json-to-dhall "Optional Integer" <<< null
-> None Integer
-
-> $ json-to-dhall '{ a : Integer, b : Optional Text }' <<< '{ "a": 1 }'
-{ a = +1, b = None Text }
-
-
-
- For Dhall __union types__ the correct value will be based on matching the type of JSON expression:
-
-> $ json-to-dhall 'List < Left : Text | Right : Integer >' <<< '[1, "bar"]'
-> [ < Left : Text | Right : Integer >.Right +1
- , < Left : Text | Right : Integer >.Left "bar"
- ]
-
-> $ json-to-dhall '{foo : < Left : Text | Right : Integer >}' <<< '{ "foo": "bar" }'
-> { foo = < Left : Text | Right : Integer >.Left "bar" }
-
- In presence of multiple potential matches, the first will be selected by default:
-
-> $ json-to-dhall '{foo : < Left : Text | Middle : Text | Right : Integer >}' <<< '{ "foo": "bar"}'
-> { foo = < Left : Text | Middle : Text | Right : Integer >.Left "bar" }
-
- This will result in error if @--unions-strict@ flag is used, with the list of alternative matches being reported (as a Dhall list)
-
-> $ json-to-dhall --unions-strict '{foo : < Left : Text | Middle : Text | Right : Integer >}' <<< '{ "foo": "bar"}'
-> Error: More than one union component type matches JSON value
-> ...
-> Possible matches:
-< Left : Text | Middle : Text | Right : Integer >.Left "bar"
-> --------
-< Left : Text | Middle : Text | Right : Integer >.Middle "bar"
--}
-
module Main where
-import Control.Applicative ((<|>))
import qualified Control.Exception
-import Control.Exception (SomeException, Exception, throwIO)
-import Control.Monad.Catch (throwM, MonadCatch)
+import Control.Exception (SomeException, throwIO)
import Control.Monad (when)
import qualified Data.Aeson as A
-import Data.Aeson.Encode.Pretty (encodePretty)
import qualified Data.ByteString.Lazy.Char8 as BSL8
-import Data.Either (rights)
-import Data.Foldable (toList)
-import qualified Data.HashMap.Strict as HM
-import Data.List ((\\))
import Data.Monoid ((<>))
-import Data.Scientific (floatingOrInteger, toRealFloat)
-import qualified Data.Sequence as Seq
-import qualified Data.String
-import qualified Data.Text as Text
-import qualified Data.Text.IO as Text
import Data.Text (Text)
+import qualified Data.Text.IO as Text
import Data.Version (showVersion)
import qualified GHC.IO.Encoding
import qualified Options.Applicative as O
@@ -166,15 +23,8 @@ import Options.Applicative (Parser, ParserInfo)
import qualified System.Exit
import qualified System.IO
-import qualified Dhall
import qualified Dhall.Core as D
-import Dhall.Core (Expr(App), Chunks(..))
-import qualified Dhall.Import
-import qualified Dhall.Map as Map
-import qualified Dhall.Parser
-import Dhall.Parser (Src)
-import qualified Dhall.TypeCheck as D
-import Dhall.TypeCheck (X)
+import Dhall.JSONToDhall
import qualified Paths_dhall_json as Meta
@@ -213,66 +63,6 @@ parseOptions = Options <$> parseVersion
<> O.help "Display version"
)
--- | JSON-to-dhall translation options
-data Conversion = Conversion
- { strictRecs :: Bool
- , noKeyValArr :: Bool
- , noKeyValMap :: Bool
- , unions :: UnionConv
- } deriving Show
-
-data UnionConv = UFirst | UNone | UStrict deriving (Show, Read, Eq)
-
-defaultConversion :: Conversion
-defaultConversion = Conversion
- { strictRecs = False
- , noKeyValArr = False
- , noKeyValMap = False
- , unions = UFirst
- }
-
--- | Parser for command options related to the conversion method
-parseConversion :: Parser Conversion
-parseConversion = Conversion <$> parseStrict
- <*> parseKVArr
- <*> parseKVMap
- <*> parseUnion
- where
- parseStrict = O.switch
- ( O.long "records-strict"
- <> O.help "Parse all fields in records"
- )
- parseKVArr = O.switch
- ( O.long "no-keyval-arrays"
- <> O.help "Disable conversion of key-value arrays to records"
- )
- parseKVMap = O.switch
- ( O.long "no-keyval-maps"
- <> O.help "Disable conversion of homogeneous map objects to association lists"
- )
-
--- | Parser for command options related to treating union types
-parseUnion :: Parser UnionConv
-parseUnion =
- uFirst
- <|> uNone
- <|> uStrict
- <|> pure UFirst -- defaulting to UFirst
- where
- uFirst = O.flag' UFirst
- ( O.long "unions-first"
- <> O.help "The first value with the matching type (succefully parsed all the way down the tree) is accepted, even if not the only posible match. (DEFAULT)"
- )
- uNone = O.flag' UNone
- ( O.long "unions-none"
- <> O.help "Unions not allowed"
- )
- uStrict = O.flag' UStrict
- ( O.long "unions-strict"
- <> O.help "Error if more than one union values match the type (and parse successfully)"
- )
-
-
-- ----------
-- Main
-- ----------
@@ -293,7 +83,7 @@ main = do
Left err -> throwIO (userError err)
Right v -> pure v
- expr <- typeCheckSchemaExpr =<< resolveSchemaExpr schema
+ expr <- typeCheckSchemaExpr id =<< resolveSchemaExpr schema
case dhallFromJSON conversion expr value of
Left err -> throwIO err
@@ -307,279 +97,3 @@ handle = Control.Exception.handle handler
System.IO.hPutStrLn System.IO.stderr ""
System.IO.hPrint System.IO.stderr e
System.Exit.exitFailure
-
-
--- ----------
--- Conversion
--- ----------
-
--- | The 'Expr' type concretization used throughout this module
-type ExprX = Expr Src X
-
--- | Parse schema code to a valid Dhall expression and check that its type is actually Type
-resolveSchemaExpr :: Text -- ^ type code (schema)
- -> IO ExprX
-resolveSchemaExpr code = do
- parsedExpression <-
- case Dhall.Parser.exprFromText "\n\ESC[1;31mSCHEMA\ESC[0m" code of
- Left err -> Control.Exception.throwIO err
- Right parsedExpression -> return parsedExpression
- D.normalize <$> Dhall.Import.load parsedExpression -- IO
-
-{-| Check that the Dhall type expression actually has type 'Type'
->>> :set -XOverloadedStrings
->>> import Dhall.Core
-
->>> typeCheckSchemaExpr =<< resolveSchemaExpr "List Natural"
-App List Natural
-
->>> typeCheckSchemaExpr =<< resolveSchemaExpr "+1"
-*** Exception:
-Error: Schema expression is succesfully parsed but has Dhall type:
-Integer
-Expected Dhall type: Type
-Parsed expression: +1
--}
-typeCheckSchemaExpr :: MonadCatch m
- => ExprX -> m ExprX
-typeCheckSchemaExpr expr =
- case D.typeOf expr of -- check if the expression has type
- Left err -> throwM $ TypeError err
- Right t -> case t of -- check if the expression has type Type
- D.Const D.Type -> return expr
- _ -> throwM $ BadDhallType t expr
-
-keyValMay :: A.Value -> Maybe (Text, A.Value)
-keyValMay (A.Object o) = do
- A.String k <- HM.lookup "key" o
- v <- HM.lookup "value" o
- return (k, v)
-keyValMay _ = Nothing
-
-
-{-| The main conversion function. Traversing/zipping Dhall /type/ and Aeson value trees together to produce a Dhall /term/ tree, given 'Conversion' options:
-
->>> :set -XOverloadedStrings
->>> import qualified Dhall.Core as D
->>> import qualified Dhall.Map as Map
->>> import qualified Data.Aeson as A
->>> import qualified Data.HashMap.Strict as HM
-
->>> s = D.Record (Map.fromList [("foo", D.Integer)])
->>> v = A.Object (HM.fromList [("foo", A.Number 1)])
->>> dhallFromJSON defaultConversion s v
-Right (RecordLit (fromList [("foo",IntegerLit 1)]))
-
--}
-dhallFromJSON
- :: Conversion -> ExprX -> A.Value -> Either CompileError ExprX
-dhallFromJSON (Conversion {..}) = loop
- where
- -- any ~> Union
- loop t@(D.Union tmMay) v = case unions of
- UNone -> Left $ ContainsUnion t
- _ -> case Map.traverseWithKey (const id) tmMay of
- Nothing -> undefined
- Just tm ->
- -- OLD-STYLE UNION:
- -- let f k a = D.UnionLit k <$> loop a v
- -- <*> pure (Map.delete k tmMay)
- let f k a = D.App (D.Field t k) <$> loop a v
- in case rights . toList $ Map.mapWithKey f tm of
- [ ] -> Left $ Mismatch t v
- [x] -> Right x
- xs@(x:_:_) -> case unions of
- UStrict -> Left $ UndecidableUnion t v xs
- UFirst -> Right x
- UNone -> undefined -- can't happen
-
- -- object ~> Record
- loop (D.Record r) v@(A.Object o)
- | extraKeys <- HM.keys o \\ Map.keys r
- , strictRecs && not (null extraKeys)
- = Left (UnhandledKeys extraKeys (D.Record r) v)
- | otherwise
- = let f :: Text -> ExprX -> Either CompileError ExprX
- f k t | Just value <- HM.lookup k o
- = loop t value
- | App D.Optional t' <- t
- = Right (App D.None t')
- | otherwise
- = Left (MissingKey k t v)
- in D.RecordLit <$> Map.traverseWithKey f r
-
- -- key-value list ~> Record
- loop t@(D.Record _) v@(A.Array a)
- | not noKeyValArr
- , os :: [A.Value] <- toList a
- , Just kvs <- traverse keyValMay os
- = loop t (A.Object $ HM.fromList kvs)
- | noKeyValArr
- = Left (NoKeyValArray t v)
- | otherwise
- = Left (Mismatch t v)
-
- -- object ~> List (key, value)
- loop t@(App D.List (D.Record r)) v@(A.Object o)
- | not noKeyValMap
- , ["mapKey", "mapValue"] == Map.keys r
- , Just D.Text == Map.lookup "mapKey" r
- , Just mapValue <- Map.lookup "mapValue" r
- , keyExprMap :: Either CompileError (HM.HashMap Text ExprX)
- <- traverse (loop mapValue) o
- = let f :: (Text, ExprX) -> ExprX
- f (key, val) = D.RecordLit ( Map.fromList
- [ ("mapKey" , D.TextLit (Chunks [] key))
- , ("mapValue", val)
- ] )
- recs :: Either CompileError (Dhall.Seq ExprX)
- recs = fmap f . Seq.fromList . HM.toList <$> keyExprMap
- typeAnn = if HM.null o then Just mapValue else Nothing
- in D.ListLit typeAnn <$> recs
- | noKeyValMap
- = Left (NoKeyValMap t v)
- | otherwise
- = Left (Mismatch t v)
-
- -- array ~> List
- loop (App D.List t) (A.Array a)
- = let f :: [ExprX] -> ExprX
- f es = D.ListLit
- (if null es then Just t else Nothing)
- (Seq.fromList es)
- in f <$> traverse (loop t) (toList a)
-
- -- number ~> Integer
- loop D.Integer (A.Number x)
- | Right n <- floatingOrInteger x :: Either Double Integer
- = Right (D.IntegerLit n)
- | otherwise
- = Left (Mismatch D.Integer (A.Number x))
-
- -- number ~> Natural
- loop D.Natural (A.Number x)
- | Right n <- floatingOrInteger x :: Either Double Dhall.Natural
- , n >= 0
- = Right (D.NaturalLit n)
- | otherwise
- = Left (Mismatch D.Natural (A.Number x))
-
- -- number ~> Double
- loop D.Double (A.Number x)
- = Right (D.DoubleLit $ toRealFloat x)
-
- -- string ~> Text
- loop D.Text (A.String t)
- = Right (D.TextLit (Chunks [] t))
-
- -- bool ~> Bool
- loop D.Bool (A.Bool t)
- = Right (D.BoolLit t)
-
- -- null ~> Optional
- loop (App D.Optional expr) A.Null
- = Right $ App D.None expr
-
- -- value ~> Optional
- loop (App D.Optional expr) value
- = D.Some <$> loop expr value
-
- -- fail
- loop expr value
- = Left (Mismatch expr value)
-
-
--- ----------
--- EXCEPTIONS
--- ----------
-
-red, purple, green
- :: (Monoid a, Data.String.IsString a) => a -> a
-red s = "\ESC[1;31m" <> s <> "\ESC[0m" -- bold
-purple s = "\ESC[1;35m" <> s <> "\ESC[0m" -- bold
-green s = "\ESC[0;32m" <> s <> "\ESC[0m" -- plain
-
-showExpr :: ExprX -> String
-showExpr dhall = Text.unpack (D.pretty dhall)
-
-showJSON :: A.Value -> String
-showJSON value = BSL8.unpack (encodePretty value)
-
-data CompileError
- -- Dhall shema
- = TypeError (D.TypeError Src X)
- | BadDhallType
- ExprX -- Expression type
- ExprX -- Whole expression
- -- generic mismatch (fallback)
- | Mismatch
- ExprX -- Dhall expression
- A.Value -- Aeson value
- -- record specific
- | MissingKey Text ExprX A.Value
- | UnhandledKeys [Text] ExprX A.Value
- | NoKeyValArray ExprX A.Value
- | NoKeyValMap ExprX A.Value
- -- union specific
- | ContainsUnion ExprX
- | UndecidableUnion ExprX A.Value [ExprX]
-
-instance Show CompileError where
- show = let prefix = red "\nError: "
- in \case
- TypeError e -> show e
-
- BadDhallType t e -> prefix
- <> "Schema expression is succesfully parsed but has Dhall type:\n"
- <> showExpr t <> "\nExpected Dhall type: Type"
- <> "\nParsed expression: "
- <> showExpr e <> "\n"
-
- ContainsUnion e -> prefix
- <> "Dhall type expression contains union type:\n"
- <> showExpr e <> "\nwhile it is forbidden by option "
- <> green "--unions-none\n"
-
- UndecidableUnion e v xs -> prefix
- <> "More than one union component type matches JSON value"
- <> "\n\nDhall:\n" <> showExpr e
- <> "\n\nJSON:\n" <> showJSON v
- <> "\n\nPossible matches:\n\n" -- Showing all the allowed matches
- <> Text.unpack (Text.intercalate sep $ D.pretty <$> xs)
- where sep = red "\n--------\n" :: Text
-
- Mismatch e v -> prefix
- <> "Dhall type expression and json value do not match:"
- <> "\n\nDhall:\n" <> showExpr e
- <> "\n\nJSON:\n" <> showJSON v
- <> "\n"
-
- MissingKey k e v -> prefix
- <> "Key " <> purple (Text.unpack k) <> ", expected by Dhall type:\n"
- <> showExpr e
- <> "\nis not present in JSON object:\n"
- <> showJSON v <> "\n"
-
- UnhandledKeys ks e v -> prefix
- <> "Key(s) " <> purple (Text.unpack (Text.intercalate ", " ks))
- <> " present in the JSON object but not in the corresponding Dhall record. This is not allowed in presence of "
- <> green "--records-strict" <> " flag:"
- <> "\n\nDhall:\n" <> showExpr e
- <> "\n\nJSON:\n" <> showJSON v
- <> "\n"
-
- NoKeyValArray e v -> prefix
- <> "JSON (key-value) arrays cannot be converted to Dhall records under "
- <> green "--no-keyval-arrays" <> " flag"
- <> "\n\nDhall:\n" <> showExpr e
- <> "\n\nJSON:\n" <> showJSON v
- <> "\n"
-
- NoKeyValMap e v -> prefix
- <> "Homogeneous JSON map objects cannot be converted to Dhall association lists under "
- <> green "--no-keyval-arrays" <> " flag"
- <> "\n\nDhall:\n" <> showExpr e
- <> "\n\nJSON:\n" <> showJSON v
- <> "\n"
-
-instance Exception CompileError
diff --git a/src/Dhall/JSON.hs b/src/Dhall/JSON.hs
index 2765a20..c13921f 100644
--- a/src/Dhall/JSON.hs
+++ b/src/Dhall/JSON.hs
@@ -165,6 +165,8 @@ module Dhall.JSON (
, Conversion(..)
, convertToHomogeneousMaps
, parseConversion
+ , SpecialDoubleMode(..)
+ , handleSpecialDoubles
, codeToValue
-- * Exceptions
@@ -182,6 +184,7 @@ import Dhall.TypeCheck (X)
import Dhall.Map (Map)
import Options.Applicative (Parser)
+import qualified Control.Lens
import qualified Data.Foldable
import qualified Data.HashMap.Strict
import qualified Data.List
@@ -202,6 +205,7 @@ import qualified Options.Applicative
-}
data CompileError
= Unsupported (Expr X X)
+ | SpecialDouble Double
| BareNone
instance Show CompileError where
@@ -228,6 +232,26 @@ instance Show CompileError where
\ \n\
\ \n\
\The conversion to JSON/YAML only translates the fully applied form to ❰null❱. "
+
+ show (SpecialDouble n) =
+ Data.Text.unpack $
+ _ERROR <> ": " <> special <> " disallowed in JSON \n\
+ \ \n\
+ \Explanation: The JSON standard does not define a canonical way to encode \n\
+ \❰NaN❱/❰Infinity❱/❰-Infinity❱. You can fix this error by either: \n\
+ \ \n\
+ \● Using ❰dhall-to-yaml❱ instead of ❰dhall-to-json❱, since YAML does support \n\
+ \ ❰NaN❱/❰Infinity❱/❰-Infinity❱ \n\
+ \ \n\
+ \● Enabling the ❰--approximate-special-doubles❱ flag which will encode ❰NaN❱ as \n\
+ \ ❰null❱, ❰Infinity❱ as the maximum ❰Double❱, and ❰-Infinity❱ as the minimum \n\
+ \❰Double❱ \n\
+ \ \n\
+ \● See if there is a way to remove ❰NaN❱/❰Infinity❱/❰-Infinity❱ from the \n\
+ \ expression that you are converting to JSON "
+ where
+ special = Data.Text.pack (show n)
+
show (Unsupported e) =
Data.Text.unpack $
_ERROR <> ": Cannot translate to JSON \n\
@@ -256,17 +280,16 @@ Right (Object (fromList [("foo",Number 1.0),("bar",String "ABC")]))
>>> fmap Data.Aeson.encode it
Right "{\"foo\":1,\"bar\":\"ABC\"}"
-}
-dhallToJSON :: Expr s X -> Either CompileError Value
+dhallToJSON
+ :: Expr s X
+ -> Either CompileError Value
dhallToJSON e0 = loop (Dhall.Core.normalize e0)
where
loop e = case e of
Dhall.Core.BoolLit a -> return (toJSON a)
Dhall.Core.NaturalLit a -> return (toJSON a)
Dhall.Core.IntegerLit a -> return (toJSON a)
- Dhall.Core.DoubleLit a
- | isInfinite a && a > 0 -> return (toJSON ( 1.7976931348623157e308 :: Double))
- | isInfinite a && a < 0 -> return (toJSON (-1.7976931348623157e308 :: Double))
- | otherwise -> return (toJSON a)
+ Dhall.Core.DoubleLit a -> return (toJSON a)
Dhall.Core.TextLit (Dhall.Core.Chunks [] a) -> do
return (toJSON a)
Dhall.Core.ListLit _ a -> do
@@ -791,6 +814,55 @@ parseConversion =
<> Options.Applicative.help "Disable conversion of association lists to homogeneous maps"
)
+-- | This option specifies how to encode @NaN@\/@Infinity@\/@-Infinity@
+data SpecialDoubleMode
+ = UseYAMLEncoding
+ -- ^ YAML natively supports @NaN@\/@Infinity@\/@-Infinity@
+ | ForbidWithinJSON
+ -- ^ Forbid @NaN@\/@Infinity@\/@-Infinity@ because JSON doesn't support them
+ | ApproximateWithinJSON
+ -- ^ Encode @NaN@\/@Infinity@\/@-Infinity@ as
+ -- @null@\/@1.7976931348623157e308@\/@-1.7976931348623157e308@,
+ -- respectively
+
+{-| Pre-process an expression containing @NaN@\/@Infinity@\/@-Infinity@,
+ handling them as specified according to the `SpecialDoubleMode`
+-}
+handleSpecialDoubles
+ :: SpecialDoubleMode -> Expr s X -> Either CompileError (Expr s X)
+handleSpecialDoubles specialDoubleMode =
+ Control.Lens.rewriteMOf Dhall.Core.subExpressions rewrite
+ where
+ rewrite =
+ case specialDoubleMode of
+ UseYAMLEncoding -> useYAMLEncoding
+ ForbidWithinJSON -> forbidWithinJSON
+ ApproximateWithinJSON -> approximateWithinJSON
+
+ useYAMLEncoding (Dhall.Core.DoubleLit n)
+ | isInfinite n && 0 < n =
+ return (Just (Dhall.Core.TextLit (Dhall.Core.Chunks [] "inf")))
+ | isInfinite n && n < 0 =
+ return (Just (Dhall.Core.TextLit (Dhall.Core.Chunks [] "-inf")))
+ | isNaN n =
+ return (Just (Dhall.Core.TextLit (Dhall.Core.Chunks [] "nan")))
+ useYAMLEncoding _ =
+ return Nothing
+
+ forbidWithinJSON (Dhall.Core.DoubleLit n)
+ | isInfinite n || isNaN n =
+ Left (SpecialDouble n)
+ forbidWithinJSON _ =
+ return Nothing
+
+ approximateWithinJSON (Dhall.Core.DoubleLit n)
+ | isInfinite n && n > 0 =
+ return (Just (Dhall.Core.DoubleLit ( 1.7976931348623157e308 :: Double)))
+ | isInfinite n && n < 0 =
+ return (Just (Dhall.Core.DoubleLit (-1.7976931348623157e308 :: Double)))
+ -- Do nothing for @NaN@, which already encodes to @null@
+ approximateWithinJSON _ =
+ return Nothing
{-| Convert a piece of Text carrying a Dhall inscription to an equivalent JSON Value
@@ -801,23 +873,23 @@ parseConversion =
-}
codeToValue
:: Conversion
+ -> SpecialDoubleMode
-> Text -- ^ Describe the input for the sake of error location.
-> Text -- ^ Input text.
-> IO Value
-codeToValue conversion name code = do
- parsedExpression <- case Dhall.Parser.exprFromText (Data.Text.unpack name) code of
- Left err -> Control.Exception.throwIO err
- Right parsedExpression -> return parsedExpression
+codeToValue conversion specialDoubleMode name code = do
+ parsedExpression <- Dhall.Core.throws (Dhall.Parser.exprFromText (Data.Text.unpack name) code)
resolvedExpression <- Dhall.Import.load parsedExpression
- case Dhall.TypeCheck.typeOf resolvedExpression of
- Left err -> Control.Exception.throwIO err
- Right _ -> return ()
+ _ <- Dhall.Core.throws (Dhall.TypeCheck.typeOf resolvedExpression)
let convertedExpression =
convertToHomogeneousMaps conversion resolvedExpression
- case dhallToJSON convertedExpression of
+ specialDoubleExpression <- Dhall.Core.throws (handleSpecialDoubles specialDoubleMode convertedExpression)
+
+ case dhallToJSON specialDoubleExpression of
Left err -> Control.Exception.throwIO err
Right json -> return json
+
diff --git a/src/Dhall/JSONToDhall.hs b/src/Dhall/JSONToDhall.hs
new file mode 100644
index 0000000..359553e
--- /dev/null
+++ b/src/Dhall/JSONToDhall.hs
@@ -0,0 +1,529 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+{-| Convert JSON data to Dhall given a Dhall /type/ expression necessary to make the translation unambiguous.
+
+ Reasonable requirements for conversion are:
+
+ 1. The Dhall type expression @/t/@ passed as an argument to @json-to-dhall@ should be a valid type of the resulting Dhall expression
+ 2. A JSON data produced by the corresponding @dhall-to-json@ from the Dhall expression of type @/t/@ should (under reasonable assumptions) reproduce the original Dhall expression using @json-to-dhall@ with type argument @/t/@
+
+ Only a subset of Dhall types consisting of all the primitive types as well as @Optional@, @Union@ and @Record@ constructs, is used for reading JSON data:
+
+ * @Bool@s
+ * @Natural@s
+ * @Integer@s
+ * @Double@s
+ * @Text@s
+ * @List@s
+ * @Optional@ values
+ * unions
+ * records
+
+ This library can be used to implement an executable which takes any data
+ serialisation format which can be parsed as an Aeson @Value@ and converts
+ the result to a Dhall value. One such executable is @json-to-dhall@ which
+ is used in the examples below.
+
+== Primitive types
+
+ JSON @Bool@s translate to Dhall bools:
+
+> $ json-to-dhall Bool <<< 'true'
+> True
+> $ json-to-dhall Bool <<< 'false'
+> False
+
+ JSON numbers translate to Dhall numbers:
+
+> $ json-to-dhall Integer <<< 2
+> +2
+> $ json-to-dhall Natural <<< 2
+> 2
+> $ json-to-dhall Double <<< -2.345
+> -2.345
+
+ Dhall @Text@ corresponds to JSON text:
+
+> $ json-to-dhall Text <<< '"foo bar"'
+> "foo bar"
+
+
+== Lists and records
+
+ Dhall @List@s correspond to JSON lists:
+
+> $ json-to-dhall 'List Integer' <<< '[1, 2, 3]'
+> [ +1, +2, +3 ]
+
+
+ Dhall __records__ correspond to JSON records:
+
+> $ json-to-dhall '{foo : List Integer}' <<< '{"foo": [1, 2, 3]}'
+> { foo = [ +1, +2, +3 ] }
+
+
+ Note, that by default, only the fields required by the Dhall type argument are parsed (as you commonly will not need all the data), the remaining ones being ignored:
+
+> $ json-to-dhall '{foo : List Integer}' <<< '{"foo": [1, 2, 3], "bar" : "asdf"}'
+> { foo = [ +1, +2, +3 ] }
+
+
+ If you do need to make sure that Dhall fully reflects JSON record data comprehensively, @--records-strict@ flag should be used:
+
+> $ json-to-dhall --records-strict '{foo : List Integer}' <<< '{"foo": [1, 2, 3], "bar" : "asdf"}'
+> Error: Key(s) @bar@ present in the JSON object but not in the corresponding Dhall record. This is not allowed in presence of --records-strict:
+
+
+ By default, JSON key-value arrays will be converted to Dhall records:
+
+> $ json-to-dhall '{ a : Integer, b : Text }' <<< '[{"key":"a", "value":1}, {"key":"b", "value":"asdf"}]'
+> { a = +1, b = "asdf" }
+
+
+ Attempting to do the same with @--no-keyval-arrays@ on will result in error:
+
+> $ json-to-dhall --no-keyval-arrays '{ a : Integer, b : Text }' <<< '[{"key":"a", "value":1}, {"key":"b", "value":"asdf"}]'
+> Error: JSON (key-value) arrays cannot be converted to Dhall records under --no-keyval-arrays flag:
+
+ Conversion of the homogeneous JSON maps to the corresponding Dhall association lists by default:
+
+> $ json-to-dhall 'List { mapKey : Text, mapValue : Text }' <<< '{"foo": "bar"}'
+> [ { mapKey = "foo", mapValue = "bar" } ]
+
+ Flag @--no-keyval-maps@ switches off this mechanism (if one would ever need it):
+
+> $ json-to-dhall --no-keyval-maps 'List { mapKey : Text, mapValue : Text }' <<< '{"foo": "bar"}'
+> Error: Homogeneous JSON map objects cannot be converted to Dhall association lists under --no-keyval-arrays flag
+
+
+== Optional values and unions
+
+ Dhall @Optional@ Dhall type allows null or missing JSON values:
+
+> $ json-to-dhall "Optional Integer" <<< '1'
+> Some +1
+
+> $ json-to-dhall "Optional Integer" <<< null
+> None Integer
+
+> $ json-to-dhall '{ a : Integer, b : Optional Text }' <<< '{ "a": 1 }'
+{ a = +1, b = None Text }
+
+
+
+ For Dhall __union types__ the correct value will be based on matching the type of JSON expression:
+
+> $ json-to-dhall 'List < Left : Text | Right : Integer >' <<< '[1, "bar"]'
+> [ < Left : Text | Right : Integer >.Right +1
+ , < Left : Text | Right : Integer >.Left "bar"
+ ]
+
+> $ json-to-dhall '{foo : < Left : Text | Right : Integer >}' <<< '{ "foo": "bar" }'
+> { foo = < Left : Text | Right : Integer >.Left "bar" }
+
+ In presence of multiple potential matches, the first will be selected by default:
+
+> $ json-to-dhall '{foo : < Left : Text | Middle : Text | Right : Integer >}' <<< '{ "foo": "bar"}'
+> { foo = < Left : Text | Middle : Text | Right : Integer >.Left "bar" }
+
+ This will result in error if @--unions-strict@ flag is used, with the list of alternative matches being reported (as a Dhall list)
+
+> $ json-to-dhall --unions-strict '{foo : < Left : Text | Middle : Text | Right : Integer >}' <<< '{ "foo": "bar"}'
+> Error: More than one union component type matches JSON value
+> ...
+> Possible matches:
+< Left : Text | Middle : Text | Right : Integer >.Left "bar"
+> --------
+< Left : Text | Middle : Text | Right : Integer >.Middle "bar"
+-}
+
+module Dhall.JSONToDhall (
+ -- * JSON to Dhall
+ parseConversion
+ , Conversion(..)
+ , defaultConversion
+ , resolveSchemaExpr
+ , typeCheckSchemaExpr
+ , dhallFromJSON
+
+ -- * Exceptions
+ , CompileError(..)
+ , showCompileError
+ ) where
+
+import Control.Applicative ((<|>))
+import Control.Exception (Exception, throwIO)
+import Control.Monad.Catch (throwM, MonadCatch)
+import qualified Data.Aeson as A
+import Data.Aeson.Encode.Pretty (encodePretty)
+import qualified Data.ByteString.Lazy.Char8 as BSL8
+import Data.Either (rights)
+import Data.Foldable (toList)
+import qualified Data.HashMap.Strict as HM
+import Data.List ((\\))
+import Data.Monoid ((<>))
+import Data.Scientific (floatingOrInteger, toRealFloat)
+import qualified Data.Sequence as Seq
+import qualified Data.String
+import qualified Data.Text as Text
+import Data.Text (Text)
+import qualified Options.Applicative as O
+import Options.Applicative (Parser)
+
+import qualified Dhall
+import qualified Dhall.Core as D
+import Dhall.Core (Expr(App), Chunks(..))
+import qualified Dhall.Import
+import qualified Dhall.Map as Map
+import qualified Dhall.Parser
+import Dhall.Parser (Src)
+import qualified Dhall.TypeCheck as D
+import Dhall.TypeCheck (X)
+
+-- ---------------
+-- Command options
+-- ---------------
+
+-- | Standard parser for options related to the conversion method
+parseConversion :: Parser Conversion
+parseConversion = Conversion <$> parseStrict
+ <*> parseKVArr
+ <*> parseKVMap
+ <*> parseUnion
+ where
+ parseStrict = O.switch
+ ( O.long "records-strict"
+ <> O.help "Parse all fields in records"
+ )
+ parseKVArr = O.switch
+ ( O.long "no-keyval-arrays"
+ <> O.help "Disable conversion of key-value arrays to records"
+ )
+ parseKVMap = O.switch
+ ( O.long "no-keyval-maps"
+ <> O.help "Disable conversion of homogeneous map objects to association lists"
+ )
+
+-- | Parser for command options related to treating union types
+parseUnion :: Parser UnionConv
+parseUnion =
+ uFirst
+ <|> uNone
+ <|> uStrict
+ <|> pure UFirst -- defaulting to UFirst
+ where
+ uFirst = O.flag' UFirst
+ ( O.long "unions-first"
+ <> O.help "The first value with the matching type (succefully parsed all the way down the tree) is accepted, even if not the only posible match. (DEFAULT)"
+ )
+ uNone = O.flag' UNone
+ ( O.long "unions-none"
+ <> O.help "Unions not allowed"
+ )
+ uStrict = O.flag' UStrict
+ ( O.long "unions-strict"
+ <> O.help "Error if more than one union values match the type (and parse successfully)"
+ )
+
+-- ----------
+-- Conversion
+-- ----------
+
+-- | JSON-to-dhall translation options
+data Conversion = Conversion
+ { strictRecs :: Bool
+ , noKeyValArr :: Bool
+ , noKeyValMap :: Bool
+ , unions :: UnionConv
+ } deriving Show
+
+data UnionConv = UFirst | UNone | UStrict deriving (Show, Read, Eq)
+
+-- | Default conversion options
+defaultConversion :: Conversion
+defaultConversion = Conversion
+ { strictRecs = False
+ , noKeyValArr = False
+ , noKeyValMap = False
+ , unions = UFirst
+ }
+
+-- | The 'Expr' type concretization used throughout this module
+type ExprX = Expr Src X
+
+-- | Parse schema code to a valid Dhall expression and check that its type is actually Type
+resolveSchemaExpr :: Text -- ^ type code (schema)
+ -> IO ExprX
+resolveSchemaExpr code = do
+ parsedExpression <-
+ case Dhall.Parser.exprFromText "\n\ESC[1;31mSCHEMA\ESC[0m" code of
+ Left err -> throwIO err
+ Right parsedExpression -> return parsedExpression
+ D.normalize <$> Dhall.Import.load parsedExpression -- IO
+
+{-| Check that the Dhall type expression actually has type 'Type'
+>>> :set -XOverloadedStrings
+>>> import Dhall.Core
+
+>>> typeCheckSchemaExpr id =<< resolveSchemaExpr "List Natural"
+App List Natural
+
+>>> typeCheckSchemaExpr id =<< resolveSchemaExpr "+1"
+*** Exception:
+Error: Schema expression is succesfully parsed but has Dhall type:
+Integer
+Expected Dhall type: Type
+Parsed expression: +1
+-}
+typeCheckSchemaExpr :: (Exception e, MonadCatch m)
+ => (CompileError -> e) -> ExprX -> m ExprX
+typeCheckSchemaExpr compileException expr =
+ case D.typeOf expr of -- check if the expression has type
+ Left err -> throwM . compileException $ TypeError err
+ Right t -> case t of -- check if the expression has type Type
+ D.Const D.Type -> return expr
+ _ -> throwM . compileException $ BadDhallType t expr
+
+keyValMay :: A.Value -> Maybe (Text, A.Value)
+keyValMay (A.Object o) = do
+ A.String k <- HM.lookup "key" o
+ v <- HM.lookup "value" o
+ return (k, v)
+keyValMay _ = Nothing
+
+
+{-| The main conversion function. Traversing/zipping Dhall /type/ and Aeson value trees together to produce a Dhall /term/ tree, given 'Conversion' options:
+
+>>> :set -XOverloadedStrings
+>>> import qualified Dhall.Core as D
+>>> import qualified Dhall.Map as Map
+>>> import qualified Data.Aeson as A
+>>> import qualified Data.HashMap.Strict as HM
+
+>>> s = D.Record (Map.fromList [("foo", D.Integer)])
+>>> v = A.Object (HM.fromList [("foo", A.Number 1)])
+>>> dhallFromJSON defaultConversion s v
+Right (RecordLit (fromList [("foo",IntegerLit 1)]))
+
+-}
+dhallFromJSON
+ :: Conversion -> ExprX -> A.Value -> Either CompileError ExprX
+dhallFromJSON (Conversion {..}) = loop
+ where
+ -- any ~> Union
+ loop t@(D.Union tmMay) v = case unions of
+ UNone -> Left $ ContainsUnion t
+ _ -> case Map.traverseWithKey (const id) tmMay of
+ Nothing -> undefined
+ Just tm ->
+ -- OLD-STYLE UNION:
+ -- let f k a = D.UnionLit k <$> loop a v
+ -- <*> pure (Map.delete k tmMay)
+ let f k a = D.App (D.Field t k) <$> loop a v
+ in case rights . toList $ Map.mapWithKey f tm of
+ [ ] -> Left $ Mismatch t v
+ [x] -> Right x
+ xs@(x:_:_) -> case unions of
+ UStrict -> Left $ UndecidableUnion t v xs
+ UFirst -> Right x
+ UNone -> undefined -- can't happen
+
+ -- object ~> Record
+ loop (D.Record r) v@(A.Object o)
+ | extraKeys <- HM.keys o \\ Map.keys r
+ , strictRecs && not (null extraKeys)
+ = Left (UnhandledKeys extraKeys (D.Record r) v)
+ | otherwise
+ = let f :: Text -> ExprX -> Either CompileError ExprX
+ f k t | Just value <- HM.lookup k o
+ = loop t value
+ | App D.Optional t' <- t
+ = Right (App D.None t')
+ | otherwise
+ = Left (MissingKey k t v)
+ in D.RecordLit <$> Map.traverseWithKey f r
+
+ -- key-value list ~> Record
+ loop t@(D.Record _) v@(A.Array a)
+ | not noKeyValArr
+ , os :: [A.Value] <- toList a
+ , Just kvs <- traverse keyValMay os
+ = loop t (A.Object $ HM.fromList kvs)
+ | noKeyValArr
+ = Left (NoKeyValArray t v)
+ | otherwise
+ = Left (Mismatch t v)
+
+ -- object ~> List (key, value)
+ loop t@(App D.List (D.Record r)) v@(A.Object o)
+ | not noKeyValMap
+ , ["mapKey", "mapValue"] == Map.keys r
+ , Just D.Text == Map.lookup "mapKey" r
+ , Just mapValue <- Map.lookup "mapValue" r
+ , keyExprMap :: Either CompileError (HM.HashMap Text ExprX)
+ <- traverse (loop mapValue) o
+ = let f :: (Text, ExprX) -> ExprX
+ f (key, val) = D.RecordLit ( Map.fromList
+ [ ("mapKey" , D.TextLit (Chunks [] key))
+ , ("mapValue", val)
+ ] )
+ recs :: Either CompileError (Dhall.Seq ExprX)
+ recs = fmap f . Seq.fromList . HM.toList <$> keyExprMap
+ typeAnn = if HM.null o then Just mapValue else Nothing
+ in D.ListLit typeAnn <$> recs
+ | noKeyValMap
+ = Left (NoKeyValMap t v)
+ | otherwise
+ = Left (Mismatch t v)
+
+ -- array ~> List
+ loop (App D.List t) (A.Array a)
+ = let f :: [ExprX] -> ExprX
+ f es = D.ListLit
+ (if null es then Just t else Nothing)
+ (Seq.fromList es)
+ in f <$> traverse (loop t) (toList a)
+
+ -- number ~> Integer
+ loop D.Integer (A.Number x)
+ | Right n <- floatingOrInteger x :: Either Double Integer
+ = Right (D.IntegerLit n)
+ | otherwise
+ = Left (Mismatch D.Integer (A.Number x))
+
+ -- number ~> Natural
+ loop D.Natural (A.Number x)
+ | Right n <- floatingOrInteger x :: Either Double Dhall.Natural
+ , n >= 0
+ = Right (D.NaturalLit n)
+ | otherwise
+ = Left (Mismatch D.Natural (A.Number x))
+
+ -- number ~> Double
+ loop D.Double (A.Number x)
+ = Right (D.DoubleLit $ toRealFloat x)
+
+ -- string ~> Text
+ loop D.Text (A.String t)
+ = Right (D.TextLit (Chunks [] t))
+
+ -- bool ~> Bool
+ loop D.Bool (A.Bool t)
+ = Right (D.BoolLit t)
+
+ -- null ~> Optional
+ loop (App D.Optional expr) A.Null
+ = Right $ App D.None expr
+
+ -- value ~> Optional
+ loop (App D.Optional expr) value
+ = D.Some <$> loop expr value
+
+ -- fail
+ loop expr value
+ = Left (Mismatch expr value)
+
+
+-- ----------
+-- EXCEPTIONS
+-- ----------
+
+red, purple, green
+ :: (Monoid a, Data.String.IsString a) => a -> a
+red s = "\ESC[1;31m" <> s <> "\ESC[0m" -- bold
+purple s = "\ESC[1;35m" <> s <> "\ESC[0m" -- bold
+green s = "\ESC[0;32m" <> s <> "\ESC[0m" -- plain
+
+showExpr :: ExprX -> String
+showExpr dhall = Text.unpack (D.pretty dhall)
+
+showJSON :: A.Value -> String
+showJSON value = BSL8.unpack (encodePretty value)
+
+data CompileError
+ -- Dhall shema
+ = TypeError (D.TypeError Src X)
+ | BadDhallType
+ ExprX -- Expression type
+ ExprX -- Whole expression
+ -- generic mismatch (fallback)
+ | Mismatch
+ ExprX -- Dhall expression
+ A.Value -- Aeson value
+ -- record specific
+ | MissingKey Text ExprX A.Value
+ | UnhandledKeys [Text] ExprX A.Value
+ | NoKeyValArray ExprX A.Value
+ | NoKeyValMap ExprX A.Value
+ -- union specific
+ | ContainsUnion ExprX
+ | UndecidableUnion ExprX A.Value [ExprX]
+
+instance Show CompileError where
+ show = showCompileError "JSON" showJSON
+
+instance Exception CompileError
+
+showCompileError :: String -> (A.Value -> String) -> CompileError -> String
+showCompileError format showValue = let prefix = red "\nError: "
+ in \case
+ TypeError e -> show e
+
+ BadDhallType t e -> prefix
+ <> "Schema expression is succesfully parsed but has Dhall type:\n"
+ <> showExpr t <> "\nExpected Dhall type: Type"
+ <> "\nParsed expression: "
+ <> showExpr e <> "\n"
+
+ ContainsUnion e -> prefix
+ <> "Dhall type expression contains union type:\n"
+ <> showExpr e <> "\nwhile it is forbidden by option "
+ <> green "--unions-none\n"
+
+ UndecidableUnion e v xs -> prefix
+ <> "More than one union component type matches " <> format <> " value"
+ <> "\n\nDhall:\n" <> showExpr e
+ <> "\n\n" <> format <> ":\n" <> showValue v
+ <> "\n\nPossible matches:\n\n" -- Showing all the allowed matches
+ <> Text.unpack (Text.intercalate sep $ D.pretty <$> xs)
+ where sep = red "\n--------\n" :: Text
+
+ Mismatch e v -> prefix
+ <> "Dhall type expression and json value do not match:"
+ <> "\n\nDhall:\n" <> showExpr e
+ <> "\n\n" <> format <> ":\n" <> showValue v
+ <> "\n"
+
+ MissingKey k e v -> prefix
+ <> "Key " <> purple (Text.unpack k) <> ", expected by Dhall type:\n"
+ <> showExpr e
+ <> "\nis not present in " <> format <> " object:\n"
+ <> showValue v <> "\n"
+
+ UnhandledKeys ks e v -> prefix
+ <> "Key(s) " <> purple (Text.unpack (Text.intercalate ", " ks))
+ <> " present in the " <> format <> " object but not in the corresponding Dhall record. This is not allowed in presence of "
+ <> green "--records-strict" <> " flag:"
+ <> "\n\nDhall:\n" <> showExpr e
+ <> "\n\n" <> format <> ":\n" <> showValue v
+ <> "\n"
+
+ NoKeyValArray e v -> prefix
+ <> "" <> format <> " (key-value) arrays cannot be converted to Dhall records under "
+ <> green "--no-keyval-arrays" <> " flag"
+ <> "\n\nDhall:\n" <> showExpr e
+ <> "\n\n" <> format <> ":\n" <> showValue v
+ <> "\n"
+
+ NoKeyValMap e v -> prefix
+ <> "Homogeneous " <> format <> " map objects cannot be converted to Dhall association lists under "
+ <> green "--no-keyval-arrays" <> " flag"
+ <> "\n\nDhall:\n" <> showExpr e
+ <> "\n\n" <> format <> ":\n" <> showValue v
+ <> "\n"
diff --git a/src/Dhall/Yaml.hs b/src/Dhall/Yaml.hs
new file mode 100644
index 0000000..edbf31f
--- /dev/null
+++ b/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'
+
diff --git a/tasty/Main.hs b/tasty/Main.hs
index cd2fb78..ad01821 100644
--- a/tasty/Main.hs
+++ b/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
@@ -23,6 +24,8 @@ testTree :: TestTree
testTree =
Test.Tasty.testGroup "dhall-json"
[ issue48
+ , yamlQuotedStrings
+ , yaml
]
issue48 :: TestTree
@@ -60,3 +63,59 @@ issue48 = Test.Tasty.HUnit.testCase "Issue #48" assertion
"Conversion to homogeneous maps did not generate the expected JSON output"
Test.Tasty.HUnit.assertEqual message expectedValue actualValue
+
+yamlQuotedStrings :: TestTree
+yamlQuotedStrings = Test.Tasty.HUnit.testCase "Yaml: quoted string style" assertion
+ where
+ assertion = do
+ let file = "./tasty/data/yaml.dhall"
+
+ code <- Data.Text.IO.readFile file
+
+ parsedExpression <- case Dhall.Parser.exprFromText file code of
+ Left exception -> Control.Exception.throwIO exception
+ Right parsedExpression -> return parsedExpression
+
+ resolvedExpression <- Dhall.Import.load parsedExpression
+
+ jsonValue <- case Dhall.JSON.dhallToJSON resolvedExpression of
+ Left exception -> Control.Exception.throwIO exception
+ Right jsonValue -> return jsonValue
+
+ let actualValue = Dhall.Yaml.jsonToYaml jsonValue False True
+
+ bytes <- Data.ByteString.Lazy.readFile "./tasty/data/quoted.yaml"
+ let expectedValue = Data.ByteString.Lazy.toStrict bytes
+
+ let message =
+ "Conversion to quoted yaml did not generate the expected output"
+
+ Test.Tasty.HUnit.assertEqual message expectedValue actualValue
+
+yaml :: TestTree
+yaml = Test.Tasty.HUnit.testCase "Yaml: normal string style" assertion
+ where
+ assertion = do
+ let file = "./tasty/data/yaml.dhall"
+
+ code <- Data.Text.IO.readFile file
+
+ parsedExpression <- case Dhall.Parser.exprFromText file code of
+ Left exception -> Control.Exception.throwIO exception
+ Right parsedExpression -> return parsedExpression
+
+ resolvedExpression <- Dhall.Import.load parsedExpression
+
+ jsonValue <- case Dhall.JSON.dhallToJSON resolvedExpression of
+ Left exception -> Control.Exception.throwIO exception
+ Right jsonValue -> return jsonValue
+
+ let actualValue = Dhall.Yaml.jsonToYaml jsonValue False False
+
+ bytes <- Data.ByteString.Lazy.readFile "./tasty/data/normal.yaml"
+ let expectedValue = Data.ByteString.Lazy.toStrict bytes
+
+ let message =
+ "Conversion to normal yaml did not generate the expected output"
+
+ Test.Tasty.HUnit.assertEqual message expectedValue actualValue
diff --git a/tasty/data/yaml.dhall b/tasty/data/yaml.dhall
new file mode 100644
index 0000000..1eeedf7
--- /dev/null
+++ b/tasty/data/yaml.dhall
@@ -0,0 +1,5 @@
+{ string_value = "2000-01-01"
+, text = ./tasty/data/yaml.txt as Text
+, int_value = 1
+, bool_value = True
+}
diff --git a/yaml-to-dhall/Main.hs b/yaml-to-dhall/Main.hs
new file mode 100644
index 0000000..3188408
--- /dev/null
+++ b/yaml-to-dhall/Main.hs
@@ -0,0 +1,114 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Main where
+
+import qualified Control.Exception
+import Control.Exception (Exception, SomeException, throwIO)
+import Control.Monad (when)
+import qualified Data.Aeson as A
+import qualified Data.ByteString.Char8 as BS8
+import qualified Data.ByteString.Lazy.Char8 as BSL8
+import Data.Monoid ((<>))
+import Data.Text (Text)
+import qualified Data.Text.IO as Text
+import Data.Version (showVersion)
+import qualified GHC.IO.Encoding
+import qualified Options.Applicative as O
+import Options.Applicative (Parser, ParserInfo)
+import qualified System.Exit
+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
+
+-- ---------------
+-- Command options
+-- ---------------
+
+-- | Command info and description
+parserInfo :: ParserInfo Options
+parserInfo = O.info
+ ( O.helper <*> parseOptions)
+ ( O.fullDesc
+ <> O.progDesc "Populate Dhall value given its Dhall type (schema) from a YAML expression"
+ )
+
+-- | All the command arguments and options
+data Options = Options
+ { version :: Bool
+ , schema :: Text
+ , conversion :: Conversion
+ } deriving Show
+
+-- | Parser for all the command arguments and options
+parseOptions :: Parser Options
+parseOptions = Options <$> parseVersion
+ <*> parseSchema
+ <*> parseConversion
+ where
+ parseSchema = O.strArgument
+ ( O.metavar "SCHEMA"
+ <> O.help "Dhall type expression (schema)"
+ )
+ parseVersion = O.switch
+ ( O.long "version"
+ <> O.short 'V'
+ <> O.help "Display version"
+ )
+
+-- ----------
+-- YAML
+-- ----------
+
+showYAML :: A.Value -> String
+showYAML value = BS8.unpack (jsonToYaml value False False)
+
+data YAMLCompileError = YAMLCompileError CompileError
+
+instance Show YAMLCompileError where
+ show (YAMLCompileError e) = showCompileError "YAML" showYAML e
+
+instance Exception YAMLCompileError
+
+-- ----------
+-- Main
+-- ----------
+
+main :: IO ()
+main = do
+ GHC.IO.Encoding.setLocaleEncoding GHC.IO.Encoding.utf8
+
+ Options {..} <- O.execParser parserInfo
+
+ when version $ do
+ putStrLn (showVersion Meta.version)
+ System.Exit.exitSuccess
+
+ handle $ do
+ stdin <- BSL8.getContents
+
+ value <- either (throwIO . userError) pure
+ (yamlToJson . BS8.concat $ BSL8.toChunks stdin)
+
+ expr <- typeCheckSchemaExpr YAMLCompileError =<< resolveSchemaExpr schema
+
+ case dhallFromJSON conversion expr value of
+ Left err -> throwIO $ YAMLCompileError err
+ Right res -> Text.putStr (D.pretty res)
+
+handle :: IO a -> IO a
+handle = Control.Exception.handle handler
+ where
+ handler :: SomeException -> IO a
+ handler e = do
+ System.IO.hPutStrLn System.IO.stderr ""
+ System.IO.hPrint System.IO.stderr e
+ System.Exit.exitFailure