dhall-json 1.6.3 → 1.6.4

raw patch · 13 files changed

+726/−167 lines, 13 filesdep ~aesondep ~dhalldep ~tastyPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: aeson, dhall, tasty

API changes (from Hackage documentation)

Files

• CHANGELOG.md +12/−0
• dhall-json.cabal +14/−8
• json-to-dhall/Main.hs +84/−38
• src/Dhall/JSON.hs +2/−2
• src/Dhall/JSONToDhall.hs +483/−82
• tasty/Main.hs +22/−9
• tasty/data/emptyObject.dhall +7/−13
• tasty/data/emptyObjectStrongType.dhall +1/−1
• tasty/data/fromArbitraryJSON_12_0_0.dhall +8/−6
• tasty/data/fromArbitraryJSON_13_0_0.dhall +9/−7
• tasty/data/missingList.dhall +4/−1
• tasty/data/potpourri.dhall +53/−0
• tasty/data/potpourri.json +27/−0

@@ -1,3 +1,15 @@+1.6.4++* [Add `json-to-dhall` support for inferring the schema](https://github.com/dhall-lang/dhall-haskell/pull/1773)+    * You no longer need to provide the command with an explicit schema.  The+      command will infer a reasonably close schema from the provided JSON+* [Add `json-to-dhall type` subcommand](https://github.com/dhall-lang/dhall-haskell/pull/1776)+    * You can use this subcommand to print the inferred schema for a JSON value,+      so that you can edit the schema and use it for subsequent invocations.+* [Add `json-to-dhall` support for using `toMap`](https://github.com/dhall-lang/dhall-haskell/pull/1745)+    * Now if you specify a `Map` as the schema, the generated Dhall code will+      use `toMap` to improve the appearance+ 1.6.3  * [yaml: Single-quote date/bool string fields](https://github.com/dhall-lang/dhall-haskell/commits/master/dhall-json)

@@ -1,6 +1,6 @@ Name: dhall-json-Version: 1.6.3-Cabal-Version: >=1.8.0.2+Version: 1.6.4+Cabal-Version: >=1.10 Build-Type: Simple Tested-With: GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.1 License: BSD3@@ -14,13 +14,14 @@     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+    * See the "Dhall.JSON" or "Dhall.JSONToDhall" modules if you want to use+      this package as a library     .-    * Use the @dhall-to-json@ or @dhall-to-yaml@ programs from this package if-      you want an executable+    * Use the @dhall-to-json@, @dhall-to-yaml@, or @json-to-dhall@ programs from+      this package if you want an executable     .-    The "Dhall.JSON" module also contains instructions for how to use this-    package+    The "Dhall.JSON" and "Dhall.JSONToDhall" modules also contains instructions+    for how to use this package Category: Compiler Extra-Source-Files:     CHANGELOG.md@@ -40,7 +41,7 @@         aeson-yaml                >= 1.0.6    && < 1.1 ,         bytestring                               < 0.11,         containers                                     ,-        dhall                     >= 1.31.0   && < 1.32,+        dhall                     >= 1.31.0   && < 1.33,         exceptions                >= 0.8.3    && < 0.11,         filepath                                 < 1.5 ,         optparse-applicative      >= 0.14.0.0 && < 0.16,@@ -57,6 +58,7 @@     Other-Modules:         Dhall.JSON.Util     GHC-Options: -Wall+    Default-Language: Haskell2010  Executable dhall-to-json     Hs-Source-Dirs: dhall-to-json@@ -73,6 +75,7 @@     Other-Modules:         Paths_dhall_json     GHC-Options: -Wall+    Default-Language: Haskell2010  Executable dhall-to-yaml     Hs-Source-Dirs: dhall-to-yaml@@ -83,6 +86,7 @@     Other-Modules:         Paths_dhall_json     GHC-Options: -Wall+    Default-Language: Haskell2010  Executable json-to-dhall     Hs-Source-Dirs: json-to-dhall@@ -104,6 +108,7 @@     Other-Modules:         Paths_dhall_json     GHC-Options: -Wall+    Default-Language: Haskell2010  Test-Suite tasty     Type: exitcode-stdio-1.0@@ -119,3 +124,4 @@         text              ,         tasty-hunit >= 0.2     GHC-Options: -Wall+    Default-Language: Haskell2010

@@ -29,6 +29,7 @@ import qualified System.Console.ANSI                       as ANSI import qualified System.Exit import qualified System.IO                                 as IO+import qualified Dhall.Core import qualified Dhall.Pretty import qualified Paths_dhall_json                          as Meta @@ -46,22 +47,29 @@  -- | All the command arguments and options data Options-    = Options-        { schema     :: Text+    = Default+        { schema     :: Maybe Text         , conversion :: Conversion         , file       :: Maybe FilePath         , output     :: Maybe FilePath         , ascii      :: Bool         , plain      :: Bool         }+    | Type+        { file       :: Maybe FilePath+        , output     :: Maybe FilePath+        , ascii      :: Bool+        , plain      :: Bool+        }     | Version     deriving Show  -- | Parser for all the command arguments and options parseOptions :: Parser Options parseOptions =-        (   Options-        <$> parseSchema+        typeCommand+    <|> (   Default+        <$> optional parseSchema         <*> parseConversion         <*> optional parseFile         <*> optional parseOutput@@ -70,10 +78,24 @@         )     <|> parseVersion   where+    typeCommand =+        Options.hsubparser+            (Options.command "type" info <> Options.metavar "type")+      where+        info =+            Options.info parser (Options.progDesc "Output the inferred Dhall type from a JSON value")++        parser =+                Type+            <$> optional parseFile+            <*> optional parseOutput+            <*> parseASCII+            <*> parsePlain+     parseSchema =         Options.strArgument             (  Options.metavar "SCHEMA"-            <> Options.help "Dhall type expression (schema)"+            <> Options.help "Dhall type (schema).  You can omit the schema to let the executable infer the schema from the JSON value."             )      parseVersion =@@ -120,52 +142,76 @@      options <- Options.execParser parserInfo -    case options of-        Version -> do-            putStrLn (showVersion Meta.version)+    let toCharacterSet ascii = case ascii of+            True  -> ASCII+            False -> Unicode -        Options {..} -> do-            let characterSet = case ascii of-                    True  -> ASCII-                    False -> Unicode+    let toValue file = do+            bytes <- case file of+                Nothing   -> ByteString.getContents+                Just path -> ByteString.readFile path -            handle $ do-                bytes <- case file of-                    Nothing   -> ByteString.getContents-                    Just path -> ByteString.readFile path+            case Aeson.eitherDecode bytes of+                Left err -> throwIO (userError err)+                Right v -> pure v -                value :: Aeson.Value <- case Aeson.eitherDecode bytes of-                  Left err -> throwIO (userError err)-                  Right v -> pure v+    let toSchema schema value = do+            finalSchema <- case schema of+                Just text -> resolveSchemaExpr text+                Nothing   -> return (schemaToDhallType (inferSchema value)) -                expr <- typeCheckSchemaExpr id =<< resolveSchemaExpr schema+            typeCheckSchemaExpr id finalSchema -                result <- case dhallFromJSON conversion expr value of-                  Left err     -> throwIO err-                  Right result -> return result+    let renderExpression characterSet plain output expression = do+            let document =+                    Dhall.Pretty.prettyCharacterSet characterSet expression -                let document = Dhall.Pretty.prettyCharacterSet characterSet result+            let stream = Dhall.Pretty.layout document -                let stream = Dhall.Pretty.layout document+            case output of+                Nothing -> do+                    supportsANSI <- ANSI.hSupportsANSI IO.stdout -                case output of-                    Nothing -> do-                        supportsANSI <- ANSI.hSupportsANSI IO.stdout+                    let ansiStream =+                            if supportsANSI && not plain+                            then fmap Dhall.Pretty.annToAnsiStyle stream+                            else Pretty.unAnnotateS stream -                        let ansiStream =-                                if supportsANSI && not plain-                                then fmap Dhall.Pretty.annToAnsiStyle stream-                                else Pretty.unAnnotateS stream+                    Pretty.Terminal.renderIO IO.stdout ansiStream -                        Pretty.Terminal.renderIO IO.stdout ansiStream+                    Text.IO.putStrLn "" -                        Text.IO.putStrLn ""+                Just file_ ->+                    IO.withFile file_ IO.WriteMode $ \h -> do+                        Pretty.Text.renderIO h stream -                    Just file_ ->-                        IO.withFile file_ IO.WriteMode $ \h -> do-                            Pretty.Text.renderIO h stream+                        Text.IO.hPutStrLn h "" -                            Text.IO.hPutStrLn h ""+    case options of+        Version -> do+            putStrLn (showVersion Meta.version)++        Default{..} -> do+            let characterSet = toCharacterSet ascii++            handle $ do+                value <- toValue file++                finalSchema <- toSchema schema value++                expression <- Dhall.Core.throws (dhallFromJSON conversion finalSchema value)++                renderExpression characterSet plain output expression++        Type{..} -> do+            let characterSet = toCharacterSet ascii++            handle $ do+                value <- toValue file++                finalSchema <- toSchema Nothing value++                renderExpression characterSet plain output finalSchema  handle :: IO a -> IO a handle = Control.Exception.handle handler

@@ -1147,7 +1147,7 @@  >>> :set -XOverloadedStrings >>> import Core->>> Dhall.JSON.codeToValue "(stdin)" "{ a = 1 }"+>>> Dhall.JSON.codeToValue defaultConversion ForbidWithinJSON Nothing "{ a = 1 }" >>> Object (fromList [("a",Number 1.0)]) -} codeToValue@@ -1158,7 +1158,7 @@   -> Text  -- ^ Input text.   -> IO Value codeToValue conversion specialDoubleMode mFilePath code = do-    parsedExpression <- Core.throws (Dhall.Parser.exprFromText (fromMaybe "(stdin)" mFilePath) code)+    parsedExpression <- Core.throws (Dhall.Parser.exprFromText (fromMaybe "(input)" mFilePath) code)      let rootDirectory = case mFilePath of             Nothing -> "."

@@ -8,150 +8,240 @@ {-# LANGUAGE PatternSynonyms     #-} {-# LANGUAGE ScopedTypeVariables #-} -{-| Convert JSON data to Dhall given a Dhall /type/ expression necessary to make the translation unambiguous.+{-| Convert JSON data to Dhall in one of two ways: -    Reasonable requirements for conversion are:+    * By default, the conversion will make a best-effort at inferring the+      corresponding Dhall type -    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/@+    * Optionally, you can specify an expected Dhall type necessary to make the+      translation unambiguous. -    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:+    Either way, if you supply the generated Dhall result to @dhall-to-json@ you+    should get back the original JSON. -    * @Bool@s-    * @Natural@s-    * @Integer@s-    * @Double@s-    * @Text@s-    * @List@s-    * @Optional@ values+    Only a subset of Dhall types are supported when converting from JSON:++    * @Bool@+    * @Natural@+    * @Integer@+    * @Double@+    * @Text@+    * @List@+    * @Optional@     * unions     * records+    * @Prelude.Type.Map@+    * @Prelude.Type.JSON@ - You can always convert JSON data to this type as a+      last resort if you don't know the schema in advance. -    Additionally, you can read in arbitrary JSON data into a Dhall value of-    type @https://prelude.dhall-lang.org/JSON/Type@ if you don't know the-    schema of the JSON data in advance.+    You can use this code as a library (this module) or as an executable+    named @json-to-dhall@, which is used in the examples below. -    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.+    By default the @json-to-dhall@ executable attempts to infer the+    appropriate Dhall type from the JSON data, like this: +> $ json-to-dhall <<< 1+> 1++    ... but you can also provide an explicit schema on the command line if you+    prefer a slightly different Dhall type which still represents the same JSON+    value:++> $ json-to-dhall Integer <<< 1+> +1++    You can also get the best of both worlds by using the @type@ subcommand to+    infer the schema:++> $ json-to-dhall type <<< '[ "up", "down" ]' | tee schema.dhall+> List Text++    ... and then edit the @./schema.dhall@ file to better match the type you+    intended, such as:++> $ $EDITOR schema.dhall+> $ cat ./schema.dhall+> List < up | down >++    ... and then use the edited schema for subsequent conversions:++> $ json-to-dhall ./schema.dhall <<< '[ "up", "down" ]'+> [ < down | up >.up, < down | up >.down ]+ == Primitive types      JSON @Bool@s translate to Dhall bools: -> $ json-to-dhall Bool <<< 'true'+> $ json-to-dhall <<< 'true' > True-> $ json-to-dhall Bool <<< 'false'+> $ json-to-dhall <<< 'false' > False      JSON numbers translate to Dhall numbers: -> $ json-to-dhall Integer <<< 2-> +2+> $ json-to-dhall <<< 2+> 2+> $ json-to-dhall <<< -2+> -2+> $ json-to-dhall <<< -2.1+> -2.1 > $ json-to-dhall Natural <<< 2 > 2-> $ json-to-dhall Double <<< -2.345-> -2.345+> $ json-to-dhall Integer <<< 2+> +2+> $ json-to-dhall Double <<< 2+> 2.0 -    Dhall @Text@ corresponds to JSON text:+    JSON text corresponds to Dhall @Text@ by default: -> $ json-to-dhall Text <<< '"foo bar"'+> $ json-to-dhall <<< '"foo bar"' > "foo bar" +    ... but you can also decode text into a more structured enum, too, if you+    provide an explicit schema: +> $ json-to-dhall '< A | B >' <<< '"A"'+> < A | B >.A+ == Lists and records      Dhall @List@s correspond to JSON lists: -> $ json-to-dhall 'List Integer' <<< '[1, 2, 3]'-> [ +1, +2, +3 ]+> $ json-to-dhall <<< '[ 1, 2, 3 ]'+> [ 1, 2, 3 ] +    You can even decode an empty JSON list to Dhall: -    Dhall __records__ correspond to JSON records:+> $ json-to-dhall <<< '[]'+> [] : List <> -> $ json-to-dhall '{foo : List Integer}' <<< '{"foo": [1, 2, 3]}'-> { foo = [ +1, +2, +3 ] }+    ... which will infer the empty @\<\>@ type if there are no other constraints+    on the type.  If you provide an explicit type annotation then the conversion+    will use that instead: +> $ json-to-dhall 'List Natural' <<< '[]'+> [] : List Natural -    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:+    Dhall records correspond to JSON records: -> $ json-to-dhall '{foo : List Integer}' <<< '{"foo": [1, 2, 3], "bar" : "asdf"}'-> { foo = [ +1, +2, +3 ] }+> $ json-to-dhall <<< '{ "foo": [ 1, 2, 3 ] }'+> { foo = [ 1, 2, 3 ] } +    If you specify a schema with additional @Optional@ fields then they will be+    @None@ if absent: -    If you do need to make sure that Dhall fully reflects JSON record data comprehensively, @--records-strict@ flag should be used:+> $ json-to-dhall '{ foo : List Natural, bar : Optional Bool }' <<< '{ "foo": [ 1, 2, 3 ] }'+> { bar = None Bool, foo = [ 1, 2, 3 ] } -> $ 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:+    ... and @Some@ if present: +> $ json-to-dhall '{ foo : List Natural, bar : Optional Bool }' <<< '{ "foo": [ 1, 2, 3 ], "bar": true }'+> { bar = Some True, foo = [ 1, 2, 3 ] } -    By default, JSON key-value arrays will be converted to Dhall records:+    If you specify a schema with too few fields, then the behavior is+    configurable.  By default, the conversion will reject extra fields: -> $ json-to-dhall '{ a : Integer, b : Text }' <<< '[{"key":"a", "value":1}, {"key":"b", "value":"asdf"}]'-> { a = +1, b = "asdf" }+> $ json-to-dhall '{ foo : List Natural }' <<< '{ "foo": [ 1, 2, 3 ], "bar": true }'+>+> Error: Key(s) bar present in the JSON object but not in the expected Dhall record type. This is not allowed unless you enable the --records-loose flag:+>+> Expected Dhall type:+> { foo : List Natural }+>+> JSON:+> {+>     "foo": [+>         1,+>         2,+>         3+>     ],+>     "bar": true+> } +  ... as the error message suggests, extra fields are ignored if you enable the+  @--records-loose@ flag. -    Attempting to do the same with @--no-keyval-arrays@ on will result in error:+> $ json-to-dhall --records-loose '{ foo : List Natural }' <<< '{ "foo": [ 1, 2, 3 ], "bar": true }'+> { foo = [ 1, 2, 3 ] } -> $ json-to-dhall --no-keyval-arrays '{ a : Integer, b : Text }' <<< '[{"key":"a", "value":1}, {"key":"b", "value":"asdf"}]'+    You can convert JSON key-value arrays to Dhall records, but only if you+    supply an explicit Dhall type:++> $ json-to-dhall '{ a : Natural, b : Text }' <<< '[ { "key": "a", "value": 1 }, { "key": "b", "value": "asdf" } ]'+> { a = 1, b = "asdf" }++    You can also disable this behavior using the @--no-keyval-arrays@:++> $ json-to-dhall --no-keyval-arrays '{ a : Natural, 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:+    You can also convert JSON records to Dhall @Map@s, but only if you supply an+    explicit schema: -> $ json-to-dhall 'List { mapKey : Text, mapValue : Text }' <<< '{"foo": "bar"}'-> [ { mapKey = "foo", mapValue = "bar" } ]+> $ json-to-dhall 'List { mapKey : Text, mapValue : Text }' <<< '{ "foo": "bar" }'+> toMap { foo = "bar" }      The map keys can even be union types instead of `Text`: -> $ json-to-dhall 'List { mapKey : < A | B >, mapValue : Natural }' <<< '{"A": 1, "B": 2}'+> $ json-to-dhall 'List { mapKey : < A | B >, mapValue : Natural }' <<< '{ "A": 1, "B": 2 }' > [ { mapKey = < A | B >.A, mapValue = 1 }, { mapKey = < A | B >.B, mapValue = 2 } ] -    Flag @--no-keyval-maps@ switches off this mechanism (if one would ever need it):+    You can similarly disable this feature using @--no-keyval-maps@: -> $ json-to-dhall --no-keyval-maps 'List { mapKey : Text, mapValue : Text }' <<< '{"foo": "bar"}'+> $ 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 @null@ values correspond to @Optional@ Dhall values: -> $ json-to-dhall "Optional Integer" <<< '1'-> Some +1+> $ json-to-dhall <<< 'null'+> None <> -> $ json-to-dhall "Optional Integer" <<< null-> None Integer+    ... and the schema inference logic will automatically wrap other values in+    @Optional@ to ensure that the types line up: -> $ json-to-dhall '{ a : Integer, b : Optional Text }' <<< '{ "a": 1 }'-{ a = +1, b = None Text }+> $ json-to-dhall <<< '[ 1, null ]'+> [ Some 1, None Natural ] +    A field that might be absent also corresponds to an @Optional@ type: +> $ json-to-dhall <<< '[ { "x": 1 }, { "x": 2, "y": true } ]'+> [ { x = 1, y = None Bool }, { x = 2, y = Some True } ] -    For Dhall __union types__ the correct value will be based on matching the type of JSON expression:+    For Dhall union types the correct value will be based on matching the type+    of JSON expression if you give an explicit type:  > $ json-to-dhall 'List < Left : Text | Right : Integer >' <<< '[1, "bar"]' > [ < Left : Text | Right : Integer >.Right +1-  , < Left : Text | Right : Integer >.Left "bar"-  ]+> , < Left : Text | Right : Integer >.Left "bar"+> ] -> $ json-to-dhall '{foo : < Left : Text | Right : Integer >}' <<< '{ "foo": "bar" }'-> { foo = < Left : Text | Right : Integer >.Left "bar" }+    Also, the schema inference logic will still infer a union anyway in order+    to reconcile simple types: -    In presence of multiple potential matches, the first will be selected by default:+> $ json-to-dhall <<< '[ 1, true ]'+> [ < Bool : Bool | Natural : Natural >.Natural 1+> , < Bool : Bool | Natural : Natural >.Bool True+> ] +    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)+    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 >.Left "bar" > ---------< Left : Text | Middle : Text | Right : Integer >.Middle "bar"+> < Left : Text | Middle : Text | Right : Integer >.Middle "bar"  == Weakly-typed JSON @@ -171,9 +261,11 @@ > → λ(null : JSON) > → array >   [ object->     [ { mapKey = "foo", mapValue = null }->     , { mapKey = "bar", mapValue = array [ number 1.0, bool True ] }->     ]+>     ( toMap+>         { bar = array [ number 1.0, bool True ]+>         , foo = null+>         }+>     ) >   ]  You can also mix and match JSON fields whose schemas are known or unknown:@@ -199,6 +291,36 @@ >   } > ] +    The schema inference algorithm will also infer this schema of last resort+    when unifying a simple type with a record or a list:++> $ json-to-dhall <<< '[ 1, [] ]'+> [ λ(JSON : Type) →+>   λ ( json+>     : { array : List JSON → JSON+>       , bool : Bool → JSON+>       , double : Double → JSON+>       , integer : Integer → JSON+>       , null : JSON+>       , object : List { mapKey : Text, mapValue : JSON } → JSON+>       , string : Text → JSON+>       }+>     ) →+>     json.integer +1+> , λ(JSON : Type) →+>   λ ( json+>     : { array : List JSON → JSON+>       , bool : Bool → JSON+>       , double : Double → JSON+>       , integer : Integer → JSON+>       , null : JSON+>       , object : List { mapKey : Text, mapValue : JSON } → JSON+>       , string : Text → JSON+>       }+>     ) →+>     json.array ([] : List JSON)+> ]+ -}  module Dhall.JSONToDhall (@@ -210,6 +332,13 @@     , typeCheckSchemaExpr     , dhallFromJSON +    -- * Schema inference+    , Schema(..)+    , RecordSchema(..)+    , UnionSchema(..)+    , inferSchema+    , schemaToDhallType+     -- * Exceptions     , CompileError(..)     , showCompileError@@ -218,17 +347,22 @@ import           Control.Applicative ((<|>)) import           Control.Exception (Exception, throwIO) import           Control.Monad.Catch (throwM, MonadCatch)+import           Data.Aeson (Value) 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.Foldable as Foldable import qualified Data.HashMap.Strict as HM import           Data.List ((\\)) import qualified Data.List as List-import           Data.Monoid ((<>))+import qualified Data.Map+import qualified Data.Map.Merge.Lazy as Data.Map.Merge+import           Data.Monoid (Any(..)) import qualified Data.Ord as Ord import           Data.Scientific (floatingOrInteger, toRealFloat)+import           Data.Semigroup (Semigroup(..)) import qualified Data.Sequence as Seq import qualified Data.String import qualified Data.Text as Text@@ -242,7 +376,9 @@ import qualified Dhall.Core as D import           Dhall.Core (Expr(App), Chunks(..), DhallDouble(..)) import qualified Dhall.Import+import qualified Dhall.Lint as Lint import qualified Dhall.Map as Map+import qualified Dhall.Optics as Optics import qualified Dhall.Parser import           Dhall.Parser (Src) import qualified Dhall.TypeCheck as D@@ -365,13 +501,278 @@       D.Const D.Type -> return expr       _              -> throwM . compileException $ BadDhallType t expr -keyValMay :: A.Value -> Maybe (Text, A.Value)+keyValMay :: Value -> Maybe (Text, Value) keyValMay (A.Object o) = do      A.String k <- HM.lookup "key" o      v <- HM.lookup "value" o      return (k, v) keyValMay _ = Nothing +{-| Given a JSON `Value`, make a best-effort guess of what the matching Dhall+    type should be++    This is used by @{json,yaml}-to-dhall@ if the user does not supply a schema+    on the command line+-}+inferSchema :: Value -> Schema+inferSchema (A.Object m) =+    let convertMap = Data.Map.fromList . HM.toList++    in (Record . RecordSchema . convertMap) (fmap inferSchema m)+inferSchema (A.Array xs) =+    List (Foldable.foldMap inferSchema xs)+inferSchema (A.String _) =+    Text+inferSchema (A.Number n) =+    case floatingOrInteger n of+        Left (_ :: Double) -> Double+        Right (integer :: Integer)+            | 0 <= integer -> Natural+            | otherwise    -> Integer+inferSchema (A.Bool _) =+    Bool+inferSchema A.Null =+    Optional mempty++-- | A record type that `inferSchema` can infer+newtype RecordSchema =+    RecordSchema { getRecordSchema :: Data.Map.Map Text Schema }++instance Semigroup RecordSchema where+    RecordSchema l <> RecordSchema r = RecordSchema m+      where+        -- The reason this is not @Just (Optional s)@ is to avoid creating a+        -- double `Optional` wrapper when unifying a @null@ field with an+        -- absent field.+        onMissing _ s = Just (s <> Optional mempty)++        m = Data.Map.Merge.merge+                (Data.Map.Merge.mapMaybeMissing onMissing)+                (Data.Map.Merge.mapMaybeMissing onMissing)+                (Data.Map.Merge.zipWithMatched (\_ -> (<>)))+                l+                r++recordSchemaToDhallType :: RecordSchema -> Expr s a+recordSchemaToDhallType (RecordSchema m) =+    D.Record (Map.fromList (Data.Map.toList (fmap schemaToDhallType m)))++{-| `inferSchema` will never infer a union type with more than one numeric+    alternative++    Instead, the most general alternative type will be preferred, which this+    type tracks+-}+data UnionNumber+    = UnionAbsent+    -- ^ The union type does not have a numeric alternative+    | UnionNatural+    -- ^ The union type has a @Natural@ alternative+    | UnionInteger+    -- ^ The union type has an @Integer@ alternative+    | UnionDouble+    -- ^ The union type has a @Double@ alternative+    deriving (Bounded, Eq, Ord)++-- | Unify two numeric alternative types by preferring the most general type+instance Semigroup UnionNumber where+    (<>) = max++instance Monoid UnionNumber where+    mempty = minBound++    mappend = (<>)++unionNumberToAlternatives :: UnionNumber -> [ (Text, Maybe (Expr s a)) ]+unionNumberToAlternatives UnionAbsent  = []+unionNumberToAlternatives UnionNatural = [ ("Natural", Just D.Natural) ]+unionNumberToAlternatives UnionInteger = [ ("Integer", Just D.Integer) ]+unionNumberToAlternatives UnionDouble  = [ ("Double" , Just D.Double ) ]++{-| A union type that `inferSchema` can infer++    This type will have at most three alternatives:++    * A @Bool@ alternative+    * Either a @Natural@, @Integer@, or @Double@ alternative+    * A @Text@ alternative++    These alternatives will always use the same names and types when we convert+    back to a Dhall type, so we only need to keep track of whether or not each+    alternative is present.++    We only store simple types inside of a union since we treat any attempt to+    unify a simple type with a complex type as a strong indication that the+    user intended for the schema to be `ArbitraryJSON`.+-}+data UnionSchema = UnionSchema+    { bool :: Any+    -- ^ `True` if the union has a @Bool@ alternative+    , number :: UnionNumber+    -- ^ Up to one numeric alternative+    , text :: Any+    -- ^ `True` if the union has a @Text@ alternative+    } deriving (Eq)++unionSchemaToDhallType :: UnionSchema -> Expr s a+unionSchemaToDhallType UnionSchema{..} = D.Union (Map.fromList alternatives)+  where+    alternatives =+            (if getAny bool then [ ("Bool", Just D.Bool) ] else [])+        <>  unionNumberToAlternatives number+        <>  (if getAny text then [ ("Text", Just D.Text) ] else [])++-- | Unify two union types by combining their alternatives+instance Semigroup UnionSchema where+    UnionSchema boolL numberL textL <> UnionSchema boolR numberR textR =+        UnionSchema{..}+      where+        bool = boolL <> boolR++        number = numberL <> numberR++        text = textL <> textR++instance Monoid UnionSchema where+    mempty = UnionSchema{..}+      where+        bool = mempty++        number = mempty++        text = mempty++    mappend = (<>)++{-| A `Schema` is a subset of the `Expr` type representing all possible+    Dhall types that `inferSchema` could potentially return+-}+data Schema+    = Bool+    | Natural+    | Integer+    | Double+    | Text+    | List Schema+    | Optional Schema+    | Record RecordSchema+    | Union UnionSchema+    | ArbitraryJSON++-- | (`<>`) unifies two schemas+instance Semigroup Schema where+    -- `ArbitraryJSON` subsumes every other type+    ArbitraryJSON <> _ = ArbitraryJSON+    _ <> ArbitraryJSON = ArbitraryJSON++    -- Simple types unify with themselves+    Bool    <> Bool    = Bool+    Text    <> Text    = Text+    Natural <> Natural = Natural+    Integer <> Integer = Integer+    Double  <> Double  = Double++    -- Complex types unify with themselves+    Record   l <> Record   r = Record   (l <> r)+    List     l <> List     r = List     (l <> r)+    Union    l <> Union    r = Union    (l <> r)+    Optional l <> Optional r = Optional (l <> r)++    -- Numeric types unify on the most general numeric type+    Natural <> Integer = Integer+    Integer <> Natural = Integer+    Natural <> Double  = Double+    Integer <> Double  = Double+    Double  <> Natural = Double+    Double  <> Integer = Double++    -- Unifying two different simple types produces a union+    Bool    <> Natural = Union mempty{ bool = Any True, number = UnionNatural }+    Bool    <> Integer = Union mempty{ bool = Any True, number = UnionInteger }+    Bool    <> Double  = Union mempty{ bool = Any True, number = UnionDouble }+    Bool    <> Text    = Union mempty{ bool = Any True, text = Any True }+    Natural <> Bool    = Union mempty{ bool = Any True, number = UnionNatural }+    Natural <> Text    = Union mempty{ number = UnionNatural, text = Any True }+    Integer <> Bool    = Union mempty{ bool = Any True, number = UnionInteger }+    Integer <> Text    = Union mempty{ number = UnionInteger, text = Any True }+    Double  <> Bool    = Union mempty{ bool = Any True, number = UnionDouble }+    Double  <> Text    = Union mempty{ number = UnionDouble, text = Any True }+    Text    <> Bool    = Union mempty{ bool = Any True, text = Any True }+    Text    <> Natural = Union mempty{ number = UnionNatural, text = Any True }+    Text    <> Integer = Union mempty{ number = UnionInteger, text = Any True }+    Text    <> Double  = Union mempty{ number = UnionDouble, text = Any True }++    -- The empty union type is the identity of unification+    Union l <> r | l == mempty = r+    l <> Union r | r == mempty = l++    -- Unifying a simple type with a union adds the simple type as yet another+    -- alternative+    Bool    <> Union r = Union (mempty{ bool   = Any True } <> r)+    Natural <> Union r = Union (mempty{ number = UnionNatural } <> r)+    Integer <> Union r = Union (mempty{ number = UnionInteger } <> r)+    Double  <> Union r = Union (mempty{ number = UnionDouble} <> r)+    Text    <> Union r = Union (mempty{ text   = Any True } <> r)+    Union l <> Bool    = Union (l <> mempty{ bool   = Any True })+    Union l <> Natural = Union (l <> mempty{ number = UnionNatural })+    Union l <> Integer = Union (l <> mempty{ number = UnionInteger })+    Union l <> Double  = Union (l <> mempty{ number = UnionDouble })+    Union l <> Text    = Union (l <> mempty{ text   = Any True })++    -- All of the remaining cases are for unifying simple types with+    -- complex types.  The only such case that can be sensibly unified is for+    -- `Optional`++    -- `Optional` subsumes every type other than `ArbitraryJSON`+    Optional l <> r = Optional (l <> r)+    l <> Optional r = Optional (l <> r)++    -- For all other cases, a simple type cannot be unified with a complex+    -- type, so fall back to `ArbitraryJSON`+    --+    -- This is equivalent to:+    --+    --     _ <> _ = ArbitraryJSON+    --+    -- ... but more explicit, in order to minimize the chance of ignoring an+    -- important case by accident.+    List _   <> _        = ArbitraryJSON+    _        <> List _   = ArbitraryJSON+    Record _ <> _        = ArbitraryJSON+    _        <> Record _ = ArbitraryJSON++instance Monoid Schema where+    mempty = Union mempty++    mappend = (<>)++-- | Convert a `Schema` to the corresponding Dhall type+schemaToDhallType :: Schema -> Expr s a+schemaToDhallType Bool = D.Bool+schemaToDhallType Natural = D.Natural+schemaToDhallType Integer = D.Integer+schemaToDhallType Double = D.Double+schemaToDhallType Text = D.Text+schemaToDhallType (List a) = D.App D.List (schemaToDhallType a)+schemaToDhallType (Optional a) = D.App D.Optional (schemaToDhallType a)+schemaToDhallType (Record r) = recordSchemaToDhallType r+schemaToDhallType (Union u) = unionSchemaToDhallType u+schemaToDhallType ArbitraryJSON =+    D.Pi "_" (D.Const D.Type)+        (D.Pi "_"+            (D.Record+                [ ("array" , D.Pi "_" (D.App D.List (V 0)) (V 1))+                , ("bool"  , D.Pi "_" D.Bool (V 1))+                , ("double", D.Pi "_" D.Double (V 1))+                , ("integer", D.Pi "_" D.Integer (V 1))+                , ("null"  , V 0)+                , ("object", D.Pi "_" (D.App D.List (D.Record [ ("mapKey", D.Text), ("mapValue", V 0)])) (V 1))+                , ("string", D.Pi "_" D.Text (V 1))+                ]+            )+            (V 1)+        )+ {-| The main conversion function. Traversing\/zipping Dhall /type/ and Aeson value trees together to produce a Dhall /term/ tree, given 'Conversion' options:  >>> :set -XOverloadedStrings@@ -387,9 +788,9 @@  -} dhallFromJSON-  :: Conversion -> ExprX -> A.Value -> Either CompileError ExprX+  :: Conversion -> ExprX -> Value -> Either CompileError ExprX dhallFromJSON (Conversion {..}) expressionType =-    loop (D.alphaNormalize (D.normalize expressionType))+    fmap (Optics.rewriteOf D.subExpressions Lint.useToMap) . loop (D.alphaNormalize (D.normalize expressionType))   where     -- any ~> Union     loop t@(D.Union tm) v = do@@ -435,7 +836,7 @@     -- key-value list ~> Record     loop t@(D.Record _) v@(A.Array a)         | not noKeyValArr-        , os :: [A.Value] <- toList a+        , os :: [Value] <- toList a         , Just kvs <- traverse keyValMay os         = loop t (A.Object $ HM.fromList kvs)         | noKeyValArr@@ -689,7 +1090,7 @@ -- ----------  red, purple, green-    :: (Monoid a, Data.String.IsString a) => a -> a+    :: (Semigroup 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@@ -697,7 +1098,7 @@ showExpr :: ExprX   -> String showExpr dhall = Text.unpack (D.pretty dhall) -showJSON :: A.Value -> String+showJSON :: Value -> String showJSON value = BSL8.unpack (encodePretty value)  data CompileError@@ -709,22 +1110,22 @@   -- generic mismatch (fallback)   | Mismatch       ExprX   -- Dhall expression-      A.Value -- Aeson value+      Value -- Aeson value   -- record specific-  | MissingKey     Text  ExprX A.Value-  | UnhandledKeys [Text] ExprX A.Value-  | NoKeyValArray        ExprX A.Value-  | NoKeyValMap          ExprX A.Value+  | MissingKey     Text  ExprX Value+  | UnhandledKeys [Text] ExprX Value+  | NoKeyValArray        ExprX Value+  | NoKeyValMap          ExprX Value   -- union specific   | ContainsUnion        ExprX-  | UndecidableUnion     ExprX A.Value [ExprX]+  | UndecidableUnion     ExprX Value [ExprX]  instance Show CompileError where     show = showCompileError "JSON" showJSON  instance Exception CompileError -showCompileError :: String -> (A.Value -> String) -> CompileError -> String+showCompileError :: String -> (Value -> String) -> CompileError -> String showCompileError format showValue = let prefix = red "\nError: "           in \case     TypeError e -> show e

@@ -40,7 +40,8 @@         , testJSONToDhall "./tasty/data/emptyListStrongType"         , testJSONToDhall "./tasty/data/fromArbitraryJSON_12_0_0"         , testJSONToDhall "./tasty/data/fromArbitraryJSON_13_0_0"-        , testCustomConversionJSONToDhall omissibleLists "./tasty/data/missingList"+        , inferJSONToDhall "./tasty/data/potpourri"+        , testCustomConversionJSONToDhall False omissibleLists "./tasty/data/missingList"         , Test.Tasty.testGroup "Nesting"             [ testDhallToJSON "./tasty/data/nesting0"             , testDhallToJSON "./tasty/data/nesting1"@@ -86,11 +87,11 @@      Test.Tasty.HUnit.assertEqual message expectedValue actualValue -testCustomConversionJSONToDhall :: JSONToDhall.Conversion -> String -> TestTree-testCustomConversionJSONToDhall conv prefix =+testCustomConversionJSONToDhall+    :: Bool -> JSONToDhall.Conversion -> String -> TestTree+testCustomConversionJSONToDhall infer conv prefix =   Test.Tasty.HUnit.testCase prefix $ do     let inputFile = prefix <> ".json"-    let schemaFile = prefix <> "Schema.dhall"     let outputFile = prefix <> ".dhall"      bytes <- Data.ByteString.Lazy.readFile inputFile@@ -100,12 +101,19 @@             Left string -> fail string             Right value -> return value -    schemaText <- Data.Text.IO.readFile schemaFile+    schema <- do+        if infer+            then do+                return (JSONToDhall.schemaToDhallType (JSONToDhall.inferSchema value))+            else do+                let schemaFile = prefix <> "Schema.dhall" -    parsedSchema <- Core.throws (Dhall.Parser.exprFromText schemaFile schemaText)+                schemaText <- Data.Text.IO.readFile schemaFile -    schema <- Dhall.Import.load parsedSchema+                parsedSchema <- Core.throws (Dhall.Parser.exprFromText schemaFile schemaText) +                Dhall.Import.load parsedSchema+     _ <- Core.throws (Dhall.TypeCheck.typeOf schema)      actualExpression <- do@@ -120,7 +128,7 @@      _ <- Core.throws (Dhall.TypeCheck.typeOf resolvedExpression) -    let expectedExpression = Core.normalize resolvedExpression+    let expectedExpression = Core.denote resolvedExpression      let message =             "Conversion to Dhall did not generate the expected output"@@ -128,4 +136,9 @@     Test.Tasty.HUnit.assertEqual message expectedExpression actualExpression  testJSONToDhall :: String -> TestTree-testJSONToDhall = testCustomConversionJSONToDhall JSONToDhall.defaultConversion+testJSONToDhall =+    testCustomConversionJSONToDhall False JSONToDhall.defaultConversion++inferJSONToDhall :: String -> TestTree+inferJSONToDhall =+    testCustomConversionJSONToDhall True JSONToDhall.defaultConversion

@@ -1,17 +1,11 @@   λ(JSON : Type) → λ ( json-    : { array :-          List JSON → JSON-      , bool :-          Bool → JSON-      , null :-          JSON-      , number :-          Double → JSON-      , object :-          List { mapKey : Text, mapValue : JSON } → JSON-      , string :-          Text → JSON+    : { array : List JSON → JSON+      , bool : Bool → JSON+      , null : JSON+      , number : Double → JSON+      , object : List { mapKey : Text, mapValue : JSON } → JSON+      , string : Text → JSON       }     )-→ json.object ([] : List { mapKey : Text, mapValue : JSON })+→ json.object (toMap {=} : List { mapKey : Text, mapValue : JSON })

@@ -1,1 +1,1 @@-[] : List { mapKey : Text, mapValue : Natural }+toMap {=} : List { mapKey : Text, mapValue : Natural }

@@ -9,9 +9,11 @@       }     ) → json.object-    [ { mapKey = "array", mapValue = json.array ([] : List JSON) }-    , { mapKey = "bool", mapValue = json.bool False }-    , { mapKey = "null", mapValue = json.null }-    , { mapKey = "number", mapValue = json.number 1.0 }-    , { mapKey = "string", mapValue = json.string "ABC" }-    ]+    ( toMap+        { array = json.array ([] : List JSON)+        , bool = json.bool False+        , null = json.null+        , number = json.number 1.0+        , string = json.string "ABC"+        }+    )

@@ -10,10 +10,12 @@       }     ) → json.object-    [ { mapKey = "array", mapValue = json.array ([] : List JSON) }-    , { mapKey = "bool", mapValue = json.bool False }-    , { mapKey = "double", mapValue = json.double 1.5 }-    , { mapKey = "integer", mapValue = json.integer +1 }-    , { mapKey = "null", mapValue = json.null }-    , { mapKey = "string", mapValue = json.string "ABC" }-    ]+    ( toMap+        { array = json.array ([] : List JSON)+        , bool = json.bool False+        , double = json.double 1.5+        , integer = json.integer +1+        , null = json.null+        , string = json.string "ABC"+        }+    )

@@ -1,1 +1,4 @@-{present = ["some-stuff"], null = [] : List Text, missing = [] : List Text}+{ missing = [] : List Text+, null = [] : List Text+, present = ["some-stuff"]+}

@@ -0,0 +1,53 @@+[ { arbitraryJSON =+      λ(JSON : Type) →+      λ ( json+        : { array : List JSON → JSON+          , bool : Bool → JSON+          , double : Double → JSON+          , integer : Integer → JSON+          , null : JSON+          , object : List { mapKey : Text, mapValue : JSON } → JSON+          , string : Text → JSON+          }+        ) →+        json.integer +1+  , bool = True+  , double = 0.0+  , extraField = None Bool+  , integer = +0+  , natural = 0+  , null = None <>+  , optional = Some 1+  , preferDouble = 0.0+  , preferInteger = +0+  , text = "abc"+  , unifyEmpty = [] : List Natural+  , unifySimple = < Bool : Bool | Text : Text >.Bool True+  }+, { arbitraryJSON =+      λ(JSON : Type) →+      λ ( json+        : { array : List JSON → JSON+          , bool : Bool → JSON+          , double : Double → JSON+          , integer : Integer → JSON+          , null : JSON+          , object : List { mapKey : Text, mapValue : JSON } → JSON+          , string : Text → JSON+          }+        ) →+        json.array ([] : List JSON)+  , bool = False+  , double = 1.1+  , extraField = Some True+  , integer = -1+  , natural = 1+  , null = None <>+  , optional = None Natural+  , preferDouble = 1.1+  , preferInteger = -1+  , text = "def"+  , unifyEmpty = [ 1 ]+  , unifySimple = < Bool : Bool | Text : Text >.Text "abc"+  }+]

@@ -0,0 +1,27 @@+[ { "bool": true+  , "text": "abc"+  , "natural": 0+  , "integer": 0+  , "double": 0.0+  , "unifyEmpty": []+  , "preferInteger": 0+  , "preferDouble": 0+  , "unifySimple": true+  , "optional": 1+  , "null": null+  , "arbitraryJSON": 1+  }+, { "bool": false+  , "text": "def"+  , "natural": 1+  , "integer": -1+  , "double": 1.1+  , "unifyEmpty": [1]+  , "preferInteger": -1+  , "preferDouble": 1.1+  , "unifySimple": "abc"+  , "optional": null+  , "extraField": true+  , "arbitraryJSON": []+  }+]