dhall-json 1.6.1 → 1.7.12
raw patch · 45 files changed
Files
- CHANGELOG.md +97/−0
- LICENSE +1/−1
- dhall-json.cabal +48/−39
- dhall-to-json/Main.hs +26/−19
- json-to-dhall/Main.hs +73/−58
- src/Dhall/DhallToYaml/Main.hs +24/−9
- src/Dhall/JSON.hs +212/−100
- src/Dhall/JSON/Compat.hs +79/−0
- src/Dhall/JSON/Util.hs +7/−1
- src/Dhall/JSON/Yaml.hs +44/−17
- src/Dhall/JSONToDhall.hs +732/−207
- tasty/Main.hs +76/−20
- tasty/data/emptyObject.dhall +7/−13
- tasty/data/emptyObjectStrongType.dhall +1/−1
- tasty/data/error/mismatchMessage0.golden +8/−0
- tasty/data/error/mismatchMessage0.json +14/−0
- tasty/data/error/mismatchMessage0Schema.dhall +3/−0
- tasty/data/error/mismatchMessage1.golden +8/−0
- tasty/data/error/mismatchMessage1.json +1/−0
- tasty/data/error/mismatchMessage1Schema.dhall +1/−0
- tasty/data/error/mismatchMessage2.golden +8/−0
- tasty/data/error/mismatchMessage2.json +1/−0
- tasty/data/error/mismatchMessage2Schema.dhall +1/−0
- tasty/data/error/missingKey.golden +5/−0
- tasty/data/error/missingKey.json +4/−0
- tasty/data/error/missingKeySchema.dhall +1/−0
- tasty/data/error/unhandledKeys.golden +10/−0
- tasty/data/error/unhandledKeys.json +4/−0
- tasty/data/error/unhandledKeysSchema.dhall +1/−0
- tasty/data/fromArbitraryJSON_12_0_0.dhall +19/−0
- tasty/data/fromArbitraryJSON_12_0_0.json +7/−0
- tasty/data/fromArbitraryJSON_12_0_0Schema.dhall +11/−0
- tasty/data/fromArbitraryJSON_13_0_0.dhall +21/−0
- tasty/data/fromArbitraryJSON_13_0_0.json +8/−0
- tasty/data/fromArbitraryJSON_13_0_0Schema.dhall +12/−0
- tasty/data/missingList.dhall +4/−1
- tasty/data/missingListSchema.dhall +1/−1
- tasty/data/potpourri.dhall +53/−0
- tasty/data/potpourri.json +27/−0
- tasty/data/time.dhall +7/−0
- tasty/data/time.json +8/−0
- tasty/data/toArbitraryJSON_12_0_0.dhall +17/−0
- tasty/data/toArbitraryJSON_12_0_0.json +7/−0
- tasty/data/toArbitraryJSON_13_0_0.dhall +19/−0
- tasty/data/toArbitraryJSON_13_0_0.json +8/−0
CHANGELOG.md view
@@ -1,3 +1,100 @@+1.7.12++* Build against `dhall-1.42`++1.7.11++* [Add new `--preserve-header` option](https://github.com/dhall-lang/dhall-haskell/pull/2433)+* Builds against newer dependencies+ * [`aeson-2.1`](https://github.com/dhall-lang/dhall-haskell/pull/2424)++1.7.10++* [Don't use scientific notation for large integers](https://github.com/dhall-lang/dhall-haskell/pull/2352)+* Build against `dhall-1.41`+* [Build against `text-2.0`](https://github.com/dhall-lang/dhall-haskell/pull/2356)+* [Build against `optparse-applicative-0.17`](https://github.com/dhall-lang/dhall-haskell/pull/2376)++1.7.9++* [Build against `aeson-2.0`](https://github.com/dhall-lang/dhall-haskell/pull/2315)++1.7.8++* [Add support for `Date` / `Time` / `TimeZone`](https://github.com/dhall-lang/dhall-haskell/pull/2247)++1.7.7++* Build against `dhall-1.39.0`++1.7.6++* [Fix `hashable`-related test failures](https://github.com/dhall-lang/dhall-haskell/pull/2152)+* [Fix lower bound on `dhall`](https://github.com/dhall-lang/dhall-haskell/pull/2147)+* [Allow bytestring-0.11](https://github.com/dhall-lang/dhall-haskell/pull/2144)+* [Fix typos in `json-to-dhall --help` output](https://github.com/dhall-lang/dhall-haskell/pull/2160)++1.7.5++* Build against `dhall-1.38.0`, `tasty-1.4`, and `tasty-silver-3.2`++1.7.4++* Build against `dhall-1.37.0`++1.7.3++* [Fix command-line completions for files](https://github.com/dhall-lang/dhall-haskell/pull/2034)+* [Support new `Text/replace` built-in](https://github.com/dhall-lang/dhall-haskell/pull/2063)++1.7.2++* [The `--documents` flag now wraps non-`List`s in a document](https://github.com/dhall-lang/dhall-haskell/pull/1977)++1.7.1++* [Format documents with leading `---`](https://github.com/dhall-lang/dhall-haskell/pull/1865)+ * Now if you use the `--documents` flag the first document will also+ include a leading `---`++1.7.0++* BREAKING CHANGE: [Add `--generated-comment` flag for `dhall-to-yaml{-ng}`](https://github.com/dhall-lang/dhall-haskell/pull/1840)+ * You can now optionally add a comment header to the YAML output+ indicating that the file is generated and should not be hand-edited+ * This is a breaking change because this adds a new `noEdit` field to the+ options type+ * In practice this breakage won't affect most users+* [Produce output compatible with YAML 1.1](https://github.com/dhall-lang/dhall-haskell/pull/1788)+ * Special strings like `on` are now quoted in order to avoid being+ misinterpreted as boolean values by YAML 1.1 implementations+* [Show JSON/YAML path on error reporting](https://github.com/dhall-lang/dhall-haskell/pull/1799)+ * Error messages will now include the path to the error in the diagnostic+ output++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.2++* [Fix `dhall-json` for new `Prelude.JSON.Type`](https://github.com/dhall-lang/dhall-haskell/pull/1631)+ * Version 13.0.0 of the Prelude caused the `JSON` type to change, which+ broke `dhall-json`'s support for that type+ * This release fixes that (and still supports the old `JSON` type)+ 1.6.1 * [Fix typos in error messages](https://github.com/dhall-lang/dhall-haskell/pull/1595)
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2018 Gabriel Gonzalez+Copyright (c) 2020 Gabriella Gonzalez All rights reserved. Redistribution and use in source and binary forms, with or without
dhall-json.cabal view
@@ -1,31 +1,34 @@ Name: dhall-json-Version: 1.6.1-Cabal-Version: >=1.8.0.2+Version: 1.7.12+Cabal-Version: >=1.10 Build-Type: Simple-Tested-With: GHC == 7.10.3, GHC == 8.4.3, GHC == 8.6.1 License: BSD3 License-File: LICENSE-Copyright: 2017 Gabriel Gonzalez-Author: Gabriel Gonzalez-Maintainer: Gabriel439@gmail.com+Copyright: 2017 Gabriella Gonzalez+Author: Gabriella Gonzalez+Maintainer: GenuineGabriella@gmail.com Bug-Reports: https://github.com/dhall-lang/dhall-haskell/issues Synopsis: Convert between Dhall and JSON or YAML Description: 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 tasty/data/*.dhall tasty/data/*.json+ tasty/data/error/*.golden+ tasty/data/error/*.json+ tasty/data/error/*.dhall Source-Repository head Type: git@@ -34,20 +37,21 @@ Library Hs-Source-Dirs: src Build-Depends:- base >= 4.8.0.0 && < 5 ,- aeson >= 1.0.0.0 && < 1.5 ,- aeson-pretty < 0.9 ,- aeson-yaml >= 1.0.5 && < 1.1 ,- bytestring < 0.11,- containers ,- dhall >= 1.28.0 && < 1.30,- exceptions >= 0.8.3 && < 0.11,- filepath < 1.5 ,- optparse-applicative >= 0.14.0.0 && < 0.16,- prettyprinter >= 1.5.1 && < 1.6 ,- scientific >= 0.3.0.0 && < 0.4 ,- text >= 0.11.1.0 && < 1.3 ,- unordered-containers < 0.3 ,+ base >= 4.11.0.0 && < 5 ,+ aeson >= 1.4.6.0 && < 2.2 ,+ aeson-pretty >= 0.8.0 && < 0.9 ,+ aeson-yaml >= 1.1.0 && < 1.2 ,+ bytestring < 0.12,+ containers >= 0.5.9 && < 0.7 ,+ dhall >= 1.42.0 && < 1.43,+ exceptions >= 0.8.3 && < 0.11,+ filepath < 1.5 ,+ lens-family-core >= 1.0.0 && < 2.2 ,+ optparse-applicative >= 0.14.0.0 && < 0.18,+ prettyprinter >= 1.7.0 && < 1.8 ,+ scientific >= 0.3.0.0 && < 0.4 ,+ text >= 0.11.1.0 && < 2.1 ,+ unordered-containers < 0.3 , vector Exposed-Modules: Dhall.JSON@@ -55,8 +59,10 @@ Dhall.JSON.Yaml Dhall.DhallToYaml.Main Other-Modules:+ Dhall.JSON.Compat Dhall.JSON.Util GHC-Options: -Wall+ Default-Language: Haskell2010 Executable dhall-to-json Hs-Source-Dirs: dhall-to-json@@ -65,7 +71,7 @@ base , aeson , aeson-pretty >= 0.8.5 && < 0.9 ,- bytestring < 0.11,+ bytestring , dhall , dhall-json , optparse-applicative ,@@ -73,6 +79,7 @@ Other-Modules: Paths_dhall_json GHC-Options: -Wall+ Default-Language: Haskell2010 Executable dhall-to-yaml Hs-Source-Dirs: dhall-to-yaml@@ -83,6 +90,7 @@ Other-Modules: Paths_dhall_json GHC-Options: -Wall+ Default-Language: Haskell2010 Executable json-to-dhall Hs-Source-Dirs: json-to-dhall@@ -90,32 +98,33 @@ Build-Depends: base , aeson ,- ansi-terminal >= 0.6.3.1 && < 0.11,- bytestring < 0.11,+ ansi-terminal >= 0.6.3.1 && < 0.12,+ bytestring , dhall , dhall-json , exceptions >= 0.8.3 && < 0.11, optparse-applicative , prettyprinter , prettyprinter-ansi-terminal >= 1.1.1 && < 1.2 ,- text < 1.3- if !impl(ghc >= 8.0) && !impl(eta >= 0.8.4)- Build-Depends: semigroups == 0.18.*+ text Other-Modules: Paths_dhall_json GHC-Options: -Wall+ Default-Language: Haskell2010 Test-Suite tasty Type: exitcode-stdio-1.0 Hs-Source-Dirs: tasty Main-Is: Main.hs Build-Depends:- base ,- aeson ,- bytestring ,- dhall ,- dhall-json ,- tasty < 1.3,- text ,- tasty-hunit >= 0.2+ base ,+ aeson ,+ bytestring ,+ dhall ,+ dhall-json ,+ tasty < 1.5,+ text ,+ tasty-hunit >= 0.2,+ tasty-silver >= 3.0 GHC-Options: -Wall+ Default-Language: Haskell2010
dhall-to-json/Main.hs view
@@ -1,26 +1,27 @@-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-} module Main where -import Control.Applicative ((<|>), optional)-import Control.Exception (SomeException)-import Data.Aeson (Value)-import Data.Monoid ((<>))-import Data.Version (showVersion)-import Dhall.JSON (Conversion, SpecialDoubleMode(..))+import Control.Applicative (optional, (<|>))+import Control.Exception (SomeException)+import Data.Aeson (Value)+import Data.Version (showVersion)+import Dhall.JSON (Conversion, SpecialDoubleMode (..)) import Options.Applicative (Parser, ParserInfo) import qualified Control.Exception import qualified Data.Aeson-import qualified Data.Aeson.Encode.Pretty+import qualified Data.Aeson.Text+import qualified Data.Aeson.Encode.Pretty as Pretty import qualified Data.ByteString.Lazy-import qualified Data.Text.IO as Text.IO+import qualified Data.Text.IO as Text.IO import qualified Dhall import qualified Dhall.JSON import qualified GHC.IO.Encoding-import qualified Options.Applicative as Options-import qualified Paths_dhall_json as Meta+import qualified Options.Applicative as Options+import qualified Paths_dhall_json as Meta import qualified System.Exit import qualified System.IO @@ -93,6 +94,7 @@ ( Options.long "file" <> Options.help "Read expression from a file instead of standard input" <> Options.metavar "FILE"+ <> Options.action "file" ) parseOutput =@@ -100,6 +102,7 @@ ( Options.long "output" <> Options.help "Write JSON to a file instead of standard output" <> Options.metavar "FILE"+ <> Options.action "file" ) parserInfo :: ParserInfo Options@@ -117,19 +120,23 @@ options <- Options.execParser parserInfo case options of- Version -> do+ Version -> putStrLn (showVersion Meta.version) - Options {..} -> do+ Options {..} -> handle $ do- let config = Data.Aeson.Encode.Pretty.Config- { Data.Aeson.Encode.Pretty.confIndent = Data.Aeson.Encode.Pretty.Spaces 2- , Data.Aeson.Encode.Pretty.confCompare = compare- , Data.Aeson.Encode.Pretty.confNumFormat = Data.Aeson.Encode.Pretty.Generic- , Data.Aeson.Encode.Pretty.confTrailingNewline = False }+ let custom scientific =+ Data.Aeson.Text.encodeToTextBuilder (Data.Aeson.Number scientific)++ let config = Pretty.Config+ { Pretty.confIndent = Pretty.Spaces 2+ , Pretty.confCompare = compare+ , Pretty.confNumFormat = Pretty.Custom custom+ , Pretty.confTrailingNewline = False+ } let encode = if pretty- then Data.Aeson.Encode.Pretty.encodePretty' config+ then Pretty.encodePretty' config else Data.Aeson.encode let explaining = if explain then Dhall.detailed else id
json-to-dhall/Main.hs view
@@ -1,36 +1,29 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE PatternGuards #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} module Main where import Control.Applicative (optional, (<|>))-import Control.Exception (SomeException, throwIO)-import Data.Monoid ((<>))-import Data.Text (Text)-import Data.Version (showVersion)+import Control.Exception (SomeException, throwIO)+import Data.Text (Text)+import Data.Version (showVersion) import Dhall.JSONToDhall-import Dhall.Pretty (CharacterSet(..))+import Dhall.Pretty (CharacterSet (..)) import Options.Applicative (Parser, ParserInfo) import qualified Control.Exception-import qualified Data.Aeson as Aeson-import qualified Data.ByteString.Lazy.Char8 as ByteString-import qualified Data.Text.IO as Text.IO-import qualified Data.Text.Prettyprint.Doc as Pretty-import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty.Terminal-import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty.Text+import qualified Data.Aeson as Aeson+import qualified Data.ByteString.Lazy.Char8 as ByteString+import qualified Dhall.Core+import qualified Dhall.Util import qualified GHC.IO.Encoding-import qualified Options.Applicative as Options-import qualified System.Console.ANSI as ANSI+import qualified Options.Applicative as Options+import qualified Paths_dhall_json as Meta import qualified System.Exit-import qualified System.IO as IO-import qualified Dhall.Pretty-import qualified Paths_dhall_json as Meta+import qualified System.IO as IO -- --------------- -- Command options@@ -46,22 +39,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 +70,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 =@@ -89,6 +103,7 @@ ( Options.long "file" <> Options.help "Read JSON from a file instead of standard input" <> Options.metavar "FILE"+ <> Options.action "file" ) parseOutput =@@ -96,6 +111,7 @@ ( Options.long "output" <> Options.help "Write Dhall expression to a file instead of standard output" <> Options.metavar "FILE"+ <> Options.action "file" ) parseASCII =@@ -120,52 +136,51 @@ 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+ case options of+ Version ->+ putStrLn (showVersion Meta.version) - let document = Dhall.Pretty.prettyCharacterSet characterSet result+ Default{..} -> do+ let characterSet = toCharacterSet ascii - let stream = Dhall.Pretty.layout document+ handle $ do+ value <- toValue file - case output of- Nothing -> do- supportsANSI <- ANSI.hSupportsANSI IO.stdout+ finalSchema <- toSchema schema value - let ansiStream =- if supportsANSI && not plain- then fmap Dhall.Pretty.annToAnsiStyle stream- else Pretty.unAnnotateS stream+ expression <- Dhall.Core.throws (dhallFromJSON conversion finalSchema value) - Pretty.Terminal.renderIO IO.stdout ansiStream+ Dhall.Util.renderExpression characterSet plain output expression - Text.IO.putStrLn ""+ Type{..} -> do+ let characterSet = toCharacterSet ascii - Just file_ ->- IO.withFile file_ IO.WriteMode $ \h -> do- Pretty.Text.renderIO h stream+ handle $ do+ value <- toValue file - Text.IO.hPutStrLn h ""+ finalSchema <- toSchema Nothing value++ Dhall.Util.renderExpression characterSet plain output finalSchema handle :: IO a -> IO a handle = Control.Exception.handle handler
src/Dhall/DhallToYaml/Main.hs view
@@ -6,12 +6,11 @@ module Dhall.DhallToYaml.Main (main) where import Control.Applicative (optional, (<|>))-import Control.Exception (SomeException)-import Data.ByteString (ByteString)-import Data.Monoid ((<>))-import Data.Text (Text)-import Dhall.JSON (parsePreservationAndOmission, parseConversion)-import Dhall.JSON.Yaml (Options(..), parseDocuments, parseQuoted)+import Control.Exception (SomeException)+import Data.ByteString (ByteString)+import Data.Text (Text)+import Dhall.JSON (parseConversion, parsePreservationAndOmission)+import Dhall.JSON.Yaml (Options (..), parseDocuments, parseQuoted) import Options.Applicative (Parser, ParserInfo) import qualified Control.Exception@@ -34,6 +33,8 @@ <*> Dhall.JSON.parseConversion <*> optional parseFile <*> optional parseOutput+ <*> parseNoEdit+ <*> parsePreserveHeader ) <|> parseVersion where@@ -48,6 +49,7 @@ ( Options.long "file" <> Options.help "Read expression from a file instead of standard input" <> Options.metavar "FILE"+ <> Options.action "file" ) parseVersion =@@ -62,8 +64,21 @@ ( Options.long "output" <> Options.help "Write YAML to a file instead of standard output" <> Options.metavar "FILE"+ <> Options.action "file" ) + parseNoEdit =+ Options.switch+ ( Options.long "generated-comment"+ <> Options.help "Include a comment header warning not to edit the generated file"+ )++ parsePreserveHeader =+ Options.switch+ ( Options.long "preserve-header"+ <> Options.help "Translate any Dhall comment header to a YAML comment header"+ )+ parserInfo :: ParserInfo (Maybe Options) parserInfo = Options.info@@ -82,10 +97,10 @@ maybeOptions <- Options.execParser parserInfo case maybeOptions of- Nothing -> do+ Nothing -> putStrLn (Data.Version.showVersion version) - Just options@(Options {..}) -> do+ Just options@Options{..} -> handle $ do contents <- case file of Nothing -> Text.IO.getContents@@ -93,7 +108,7 @@ let write = case output of- Nothing -> Data.ByteString.putStr+ Nothing -> Data.ByteString.putStr Just file_ -> Data.ByteString.writeFile file_ write =<< dhallToYaml options file contents
src/Dhall/JSON.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-} {-| This library only exports a single `dhallToJSON` function for translating a Dhall syntax tree to a JSON syntax tree (i.e. a `Value`) for the @aeson@@@ -26,7 +27,7 @@ * @Natural@s * @Integer@s * @Double@s- * @Text@+ * @Text@ values * @List@s * @Optional@ values * unions@@ -124,9 +125,9 @@ the same record. For example, this code: > let Example = < Left : { foo : Natural } | Right : { bar : Bool } >-> +> > let Nesting = < Inline | Nested : Text >-> +> > in { field = "name" > , nesting = Nesting.Inline > , contents = Example.Left { foo = 2 }@@ -143,9 +144,9 @@ underneath a field named @nestedField@. For example, this code: > let Example = < Left : { foo : Natural } | Right : { bar : Bool } >-> +> > let Nesting = < Inline | Nested : Text >-> +> > in { field = "name" > , nesting = Nesting.Nested "value" > , contents = Example.Left { foo = 2 }@@ -165,7 +166,7 @@ > $ cat ./example.dhall > let JSON = https://prelude.dhall-lang.org/JSON/package.dhall-> +> > in JSON.object > [ { mapKey = "foo", mapValue = JSON.null } > , { mapKey =@@ -207,45 +208,47 @@ , SpecialDoubleMode(..) , handleSpecialDoubles , codeToValue+ , codeToHeaderAndValue -- * Exceptions , CompileError(..) ) where import Control.Applicative (empty, (<|>))-import Control.Monad (guard)-import Control.Exception (Exception, throwIO)-import Data.Aeson (Value(..), ToJSON(..))-import Data.Maybe (fromMaybe)-import Data.Monoid ((<>), mempty)-import Data.Text (Text)-import Data.Text.Prettyprint.Doc (Pretty)-import Data.Void (Void)-import Dhall.Core (Binding(..), DhallDouble(..), Expr)-import Dhall.Import (SemanticCacheMode(..))-import Dhall.Map (Map)-import Dhall.JSON.Util (pattern V)+import Control.Exception (Exception, throwIO)+import Control.Monad (guard)+import Data.Aeson (ToJSON (..), Value (..))+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Void (Void)+import Dhall.Core (Binding (..), DhallDouble (..), Expr)+import Dhall.Import (SemanticCacheMode (..))+import Dhall.JSON.Util (pattern FA, pattern V)+import Dhall.Map (Map)+import Dhall.Parser (Header(..)) import Options.Applicative (Parser)-import Prelude hiding (getContents)+import Prelude hiding (getContents)+import Prettyprinter (Pretty) -import qualified Data.Aeson as Aeson-import qualified Data.Foldable as Foldable-import qualified Data.HashMap.Strict as HashMap+import qualified Data.Aeson as Aeson+import qualified Data.Foldable as Foldable import qualified Data.List import qualified Data.Map import qualified Data.Ord import qualified Data.Text-import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty-import qualified Data.Vector as Vector-import qualified Dhall.Core as Core+import qualified Data.Vector as Vector+import qualified Dhall.Core as Core import qualified Dhall.Import+import qualified Dhall.JSON.Compat as JSON.Compat import qualified Dhall.Map import qualified Dhall.Optics import qualified Dhall.Parser import qualified Dhall.Pretty import qualified Dhall.TypeCheck import qualified Dhall.Util+import qualified Lens.Family as Lens import qualified Options.Applicative+import qualified Prettyprinter.Render.Text as Pretty import qualified System.FilePath {-| This is the exception type for errors that might arise when translating@@ -412,44 +415,43 @@ -> Either CompileError Value dhallToJSON e0 = loop (Core.alphaNormalize (Core.normalize e0)) where- loop e = case e of + loop e = case e of Core.BoolLit a -> return (toJSON a) Core.NaturalLit a -> return (toJSON a) Core.IntegerLit a -> return (toJSON a) Core.DoubleLit (DhallDouble a) -> return (toJSON a)- Core.TextLit (Core.Chunks [] a) -> do- return (toJSON a)+ Core.TextLit (Core.Chunks [] a) -> return (toJSON a) Core.ListLit _ a -> do a' <- traverse loop a return (toJSON a') Core.Some a -> do a' <- loop a return (toJSON a')- Core.App Core.None _ -> do- return Aeson.Null+ Core.App Core.None _ -> return Aeson.Null -- Provide a nicer error message for a common user mistake. -- -- See: https://github.com/dhall-lang/dhall-lang/issues/492- Core.None -> do- Left BareNone+ Core.None -> Left BareNone+ _ | Just text <- Dhall.Pretty.temporalToText e ->+ loop (Core.TextLit (Core.Chunks [] text)) Core.RecordLit a -> case toOrderedList a of [ ( "contents"- , contents+ , Core.recordFieldValue -> contents ) , ( "field"- , Core.TextLit+ , Core.recordFieldValue -> Core.TextLit (Core.Chunks [] field) ) , ( "nesting"- , Core.App+ , Core.recordFieldValue -> Core.App (Core.Field (Core.Union [ ("Inline", mInlineType) , ("Nested", Just Core.Text) ] )- "Nested"+ (FA "Nested") ) (Core.TextLit (Core.Chunks [] nestedField)@@ -459,7 +461,7 @@ , Just (alternativeName, mExpr) <- getContents contents -> do contents' <- case mExpr of Just expr -> loop expr- Nothing -> return Aeson.Null+ Nothing -> return Aeson.Null let taggedValue = Data.Map.fromList@@ -474,14 +476,14 @@ return (Aeson.toJSON taggedValue) [ ( "contents"- , contents+ , Core.recordFieldValue -> contents ) , ( "field"- , Core.TextLit+ , Core.recordFieldValue -> Core.TextLit (Core.Chunks [] field) ) , ( "nesting"- , nesting+ , Core.recordFieldValue -> nesting ) ] | isInlineNesting nesting , Just (alternativeName, mExpr) <- getContents contents -> do@@ -491,40 +493,89 @@ Left (InvalidInlineContents e alternativeContents) Nothing -> return mempty - let name = Core.TextLit (Core.Chunks [] alternativeName)+ let name = Core.makeRecordField $ Core.TextLit (Core.Chunks [] alternativeName) let kvs1 = Dhall.Map.insert field name kvs0 loop (Core.RecordLit kvs1) _ -> do- a' <- traverse loop a+ a' <- traverse (loop . Core.recordFieldValue) a return (Aeson.toJSON (Dhall.Map.toMap a')) Core.App (Core.Field (Core.Union _) _) b -> loop b- Core.Field (Core.Union _) k -> return (Aeson.toJSON k)- Core.Lam _ (Core.Const Core.Type)- (Core.Lam _+ Core.Field (Core.Union _) (FA k) -> return (Aeson.toJSON k)+ Core.Lam _ (Core.functionBindingAnnotation -> Core.Const Core.Type)+ (Core.Lam _ (Core.functionBindingAnnotation -> (Core.Record- [ ("array" , Core.Pi _ (Core.App Core.List (V 0)) (V 1))- , ("bool" , Core.Pi _ Core.Bool (V 1))- , ("null" , V 0)- , ("number", Core.Pi _ Core.Double (V 1))- , ("object", Core.Pi _ (Core.App Core.List (Core.Record [ ("mapKey", Core.Text), ("mapValue", V 0)])) (V 1))- , ("string", Core.Pi _ Core.Text (V 1))+ [ ("array" , Core.recordFieldValue -> Core.Pi _ _ (Core.App Core.List (V 0)) (V 1))+ , ("bool" , Core.recordFieldValue -> Core.Pi _ _ Core.Bool (V 1))+ , ("null" , Core.recordFieldValue -> V 0)+ , ("number", Core.recordFieldValue -> Core.Pi _ _ Core.Double (V 1))+ , ("object", Core.recordFieldValue ->+ Core.Pi _ _ (Core.App Core.List (Core.Record+ [ ("mapKey", Core.recordFieldValue -> Core.Text)+ , ("mapValue", Core.recordFieldValue -> V 0)])) (V 1))+ , ("string", Core.recordFieldValue -> Core.Pi _ _ Core.Text (V 1)) ]- )+ )) value ) -> do- let outer (Core.Field (V 0) "null") = do+ let outer (Core.Field (V 0) (FA "null")) = return Aeson.Null+ outer (Core.App (Core.Field (V 0) (FA "bool")) (Core.BoolLit b)) =+ return (Aeson.Bool b)+ outer (Core.App (Core.Field (V 0) (FA "array")) (Core.ListLit _ xs)) = do+ ys <- traverse outer (Foldable.toList xs)++ return (Aeson.Array (Vector.fromList ys))+ outer (Core.App (Core.Field (V 0) (FA "object")) (Core.ListLit _ xs)) = do+ let inner (Core.RecordLit+ [ ("mapKey", Core.recordFieldValue -> Core.TextLit (Core.Chunks [] mapKey))+ , ("mapValue", Core.recordFieldValue -> mapExpression)]) = do+ mapValue <- outer mapExpression++ return (mapKey, mapValue)+ inner _ = Left (Unsupported e)++ ys <- traverse inner (Foldable.toList xs)++ return (Aeson.Object (JSON.Compat.objectFromList ys))+ outer (Core.App (Core.Field (V 0) (FA "number")) (Core.DoubleLit (DhallDouble n))) =+ return (Aeson.toJSON n)+ outer (Core.App (Core.Field (V 0) (FA "string")) (Core.TextLit (Core.Chunks [] text))) =+ return (toJSON text)+ outer _ = Left (Unsupported e)++ outer value+ Core.Lam _ (Core.functionBindingAnnotation -> Core.Const Core.Type)+ (Core.Lam _ (Core.functionBindingAnnotation ->+ (Core.Record+ [ ("array" , Core.recordFieldValue -> Core.Pi _ _ (Core.App Core.List (V 0)) (V 1))+ , ("bool" , Core.recordFieldValue -> Core.Pi _ _ Core.Bool (V 1))+ , ("double", Core.recordFieldValue -> Core.Pi _ _ Core.Double (V 1))+ , ("integer", Core.recordFieldValue -> Core.Pi _ _ Core.Integer (V 1))+ , ("null" , Core.recordFieldValue -> V 0)+ , ("object", Core.recordFieldValue ->+ Core.Pi _ _ (Core.App Core.List (Core.Record+ [ ("mapKey", Core.recordFieldValue -> Core.Text)+ , ("mapValue", Core.recordFieldValue -> V 0)+ ])) (V 1))+ , ("string", Core.recordFieldValue -> Core.Pi _ _ Core.Text (V 1))+ ]+ ))+ value+ ) -> do+ let outer (Core.Field (V 0) (FA "null")) = return Aeson.Null- outer (Core.App (Core.Field (V 0) "bool") (Core.BoolLit b)) = do+ outer (Core.App (Core.Field (V 0) (FA "bool")) (Core.BoolLit b)) = return (Aeson.Bool b)- outer (Core.App (Core.Field (V 0) "array") (Core.ListLit _ xs)) = do+ outer (Core.App (Core.Field (V 0) (FA "array")) (Core.ListLit _ xs)) = do ys <- traverse outer (Foldable.toList xs) return (Aeson.Array (Vector.fromList ys))- outer (Core.App (Core.Field (V 0) "object") (Core.ListLit _ xs)) = do- let inner (Core.RecordLit [("mapKey", Core.TextLit (Core.Chunks [] mapKey)), ("mapValue", mapExpression)]) = do+ outer (Core.App (Core.Field (V 0) (FA "object")) (Core.ListLit _ xs)) = do+ let inner (Core.RecordLit+ [ ("mapKey", Core.recordFieldValue -> Core.TextLit (Core.Chunks [] mapKey))+ , ("mapValue", Core.recordFieldValue -> mapExpression)]) = do mapValue <- outer mapExpression return (mapKey, mapValue)@@ -532,10 +583,12 @@ ys <- traverse inner (Foldable.toList xs) - return (Aeson.Object (HashMap.fromList ys))- outer (Core.App (Core.Field (V 0) "number") (Core.DoubleLit (DhallDouble n))) = do+ return (Aeson.Object (JSON.Compat.objectFromList ys))+ outer (Core.App (Core.Field (V 0) (FA "double")) (Core.DoubleLit (DhallDouble n))) = return (Aeson.toJSON n)- outer (Core.App (Core.Field (V 0) "string") (Core.TextLit (Core.Chunks [] text))) = do+ outer (Core.App (Core.Field (V 0) (FA "integer")) (Core.IntegerLit n)) =+ return (Aeson.toJSON n)+ outer (Core.App (Core.Field (V 0) (FA "string")) (Core.TextLit (Core.Chunks [] text))) = return (toJSON text) outer _ = Left (Unsupported e) @@ -546,11 +599,11 @@ getContents (Core.App (Core.Field _- alternativeName+ (FA alternativeName) ) expression ) = Just (alternativeName, Just expression)-getContents (Core.Field _ alternativeName) = Just (alternativeName, Nothing)+getContents (Core.Field _ (FA alternativeName)) = Just (alternativeName, Nothing) getContents _ = Nothing isInlineNesting :: Expr s Void -> Bool@@ -561,7 +614,7 @@ , ("Nested", Just Core.Text) ] )- "Inline"+ (FA "Inline") ) (Core.RecordLit []) ) = True@@ -571,7 +624,7 @@ , ("Nested", Just Core.Text) ] )- "Inline"+ (FA "Inline") ) = True isInlineNesting _ = False @@ -584,7 +637,7 @@ omitNull :: Value -> Value omitNull (Object object) = Object fields where- fields =HashMap.filter (/= Null) (fmap omitNull object)+ fields = JSON.Compat.filterObject (/= Null) (fmap omitNull object) omitNull (Array array) = Array (fmap omitNull array) omitNull (String string) =@@ -596,14 +649,14 @@ omitNull Null = Null -{-| Omit record fields that are @null@, arrays and records whose transitive +{-| Omit record fields that are @null@, arrays and records whose transitive fields are all null -} omitEmpty :: Value -> Value omitEmpty (Object object) = if null fields then Null else Object fields where- fields = HashMap.filter (/= Null) (fmap omitEmpty object)+ fields = JSON.Compat.filterObject (/= Null) (fmap omitEmpty object) omitEmpty (Array array) = if null elems then Null else Array elems where@@ -679,11 +732,11 @@ case we do *not* want to perform this rewrite since it will interfere with decoding the value. -}- Core.Lam a b c ->- Core.Lam a b c+ Core.Lam cs a b ->+ Core.Lam cs a b - Core.Pi a b c ->- Core.Pi a b' c'+ Core.Pi cs a b c ->+ Core.Pi cs a b' c' where b' = loop b c' = loop c@@ -744,6 +797,12 @@ b' = loop b c' = loop c + Core.Bytes ->+ Core.Bytes++ Core.BytesLit a ->+ Core.BytesLit a+ Core.Natural -> Core.Natural @@ -827,9 +886,39 @@ a' = loop a b' = loop b + Core.TextReplace ->+ Core.TextReplace+ Core.TextShow -> Core.TextShow + Core.Date ->+ Core.Date++ Core.DateLiteral d ->+ Core.DateLiteral d++ Core.DateShow ->+ Core.DateShow++ Core.Time ->+ Core.Time++ Core.TimeLiteral t p ->+ Core.TimeLiteral t p++ Core.TimeShow ->+ Core.TimeShow++ Core.TimeZone ->+ Core.TimeZone++ Core.TimeZoneLiteral z ->+ Core.TimeZoneLiteral z++ Core.TimeZoneShow ->+ Core.TimeZoneShow+ Core.List -> Core.List @@ -844,21 +933,21 @@ toKeyValue (Core.RecordLit m) = do guard (Foldable.length m == 2) - key <- Dhall.Map.lookup mapKey m- value <- Dhall.Map.lookup mapValue m+ key <- Core.recordFieldValue <$> Dhall.Map.lookup mapKey m+ value <- Core.recordFieldValue <$> Dhall.Map.lookup mapValue m keyText <- case key of Core.TextLit (Core.Chunks [] keyText) -> return keyText - Core.Field (Core.Union _) keyText ->+ Core.Field (Core.Union _) (FA keyText) -> return keyText _ -> empty return (keyText, value)- toKeyValue _ = do+ toKeyValue _ = empty transform =@@ -870,13 +959,12 @@ guard (Dhall.Map.member mapKey m) guard (Dhall.Map.member mapValue m) return (Core.RecordLit mempty)- _ -> do- empty+ _ -> empty _ -> do keyValues <- traverse toKeyValue elements - let recordLiteral =+ let recordLiteral = Core.makeRecordField <$> Dhall.Map.fromList keyValues return (Core.RecordLit recordLiteral)@@ -922,44 +1010,38 @@ Core.None -> Core.None - Core.OptionalFold ->- Core.OptionalFold-- Core.OptionalBuild ->- Core.OptionalBuild- Core.Record a -> Core.Record a' where- a' = fmap loop a+ a' = Lens.over Core.recordFieldExprs loop <$> a Core.RecordLit a -> Core.RecordLit a' where- a' = fmap loop a+ a' = Lens.over Core.recordFieldExprs loop <$> a Core.Union a -> Core.Union a' where a' = fmap (fmap loop) a - Core.Combine a b ->- Core.Combine a' b'+ Core.Combine cs a b c ->+ Core.Combine cs a b' c' where- a' = loop a b' = loop b+ c' = loop c - Core.CombineTypes a b ->- Core.CombineTypes a' b'+ Core.CombineTypes cs a b ->+ Core.CombineTypes cs a' b' where a' = loop a b' = loop b - Core.Prefer a b ->- Core.Prefer a' b'+ Core.Prefer cs a b c ->+ Core.Prefer cs a b' c' where- a' = loop a b' = loop b+ c' = loop c Core.RecordCompletion a b -> Core.RecordCompletion a' b'@@ -980,6 +1062,11 @@ a' = loop a b' = fmap loop b + Core.ShowConstructor a ->+ Core.ShowConstructor a'+ where+ a' = loop a+ Core.Field a b -> Core.Field a' b where@@ -995,12 +1082,18 @@ where a' = loop a - Core.Equivalent a b ->- Core.Equivalent a' b'+ Core.Equivalent cs a b ->+ Core.Equivalent cs a' b' where a' = loop a b' = loop b + Core.With a b c ->+ Core.With a' b c'+ where+ a' = loop a+ c' = loop c+ Core.ImportAlt a b -> Core.ImportAlt a' b' where@@ -1100,7 +1193,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@@ -1111,8 +1204,28 @@ -> Text -- ^ Input text. -> IO Value codeToValue conversion specialDoubleMode mFilePath code = do- parsedExpression <- Core.throws (Dhall.Parser.exprFromText (fromMaybe "(stdin)" mFilePath) code)+ fmap snd (codeToHeaderAndValue conversion specialDoubleMode mFilePath code) +{-| This is like `codeToValue`, except also returning a `Header` that is a+ valid YAML comment derived from the original Dhall code's `Header`+-}+codeToHeaderAndValue+ :: Conversion+ -> SpecialDoubleMode+ -> Maybe FilePath -- ^ The source file path. If no path is given, imports+ -- are resolved relative to the current directory.+ -> Text -- ^ Input text.+ -> IO (Header, Value)+codeToHeaderAndValue conversion specialDoubleMode mFilePath code = do+ (Header header, parsedExpression) <- Core.throws (Dhall.Parser.exprAndHeaderFromText (fromMaybe "(input)" mFilePath) code)++ let adapt line =+ case Data.Text.stripPrefix "--" line of+ Just suffix -> "#" <> suffix+ Nothing -> "#" <> line++ let yamlHeader = Data.Text.unlines (map adapt (Data.Text.lines header))+ let rootDirectory = case mFilePath of Nothing -> "." Just fp -> System.FilePath.takeDirectory fp@@ -1128,5 +1241,4 @@ case dhallToJSON specialDoubleExpression of Left err -> Control.Exception.throwIO err- Right json -> return json-+ Right json -> return (Header yamlHeader, json)
+ src/Dhall/JSON/Compat.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE CPP #-}++-- | Compatibility helpers for the @aeson-2@ migration.+module Dhall.JSON.Compat (+ objectFromList+ , mapToAscList+ , filterObject+ , lookupObject+ , traverseObjectWithKey+ , objectKeys+ , textToKey+ ) where++import Data.Aeson (Object, Value)+import Data.Text (Text)++#if MIN_VERSION_aeson(2,0,0)+import Data.Aeson.Key (Key)+import qualified Data.Aeson.Key as Key+import Data.Aeson.KeyMap (KeyMap)+import qualified Data.Aeson.KeyMap as KeyMap+import Data.Bifunctor (first)+#else+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import qualified Data.List as List+#endif++objectFromList :: [(Text, Value)] -> Object+#if MIN_VERSION_aeson(2,0,0)+objectFromList = KeyMap.fromList . map (first Key.fromText)+#else+objectFromList = HashMap.fromList+#endif++filterObject :: (Value -> Bool) -> Object -> Object+#if MIN_VERSION_aeson(2,0,0)+filterObject = KeyMap.filter+#else+filterObject = HashMap.filter+#endif++#if MIN_VERSION_aeson(2,0,0)+mapToAscList :: KeyMap a -> [(Text, a)]+mapToAscList = map (first Key.toText) . KeyMap.toAscList+#else+mapToAscList :: HashMap Text a -> [(Text, a)]+mapToAscList = List.sortOn fst . HashMap.toList+#endif++lookupObject :: Text -> Object -> Maybe Value+#if MIN_VERSION_aeson(2,0,0)+lookupObject k = KeyMap.lookup (Key.fromText k)+#else+lookupObject = HashMap.lookup+#endif++objectKeys :: Object -> [Text]+#if MIN_VERSION_aeson(2,0,0)+objectKeys = map (Key.toText) . KeyMap.keys+#else+objectKeys = HashMap.keys+#endif++#if MIN_VERSION_aeson(2,0,0)+textToKey :: Text -> Key+textToKey = Key.fromText+#else+textToKey :: Text -> Text+textToKey = id+#endif++#if MIN_VERSION_aeson(2,0,0)+traverseObjectWithKey :: Applicative f => (Key -> v1 -> f v2) -> KeyMap v1 -> f (KeyMap v2)+traverseObjectWithKey = KeyMap.traverseWithKey+#else+traverseObjectWithKey :: Applicative f => (Text -> v1 -> f v2) -> HashMap Text v1 -> f (HashMap Text v2)+traverseObjectWithKey = HashMap.traverseWithKey+#endif
src/Dhall/JSON/Util.hs view
@@ -3,11 +3,17 @@ module Dhall.JSON.Util ( pattern V+ , pattern FA ) where -import Dhall.Core (Expr)+import Data.Text (Text)+import Dhall.Core (Expr, FieldSelection) import qualified Dhall.Core as Core pattern V :: Int -> Expr s a pattern V n = Core.Var (Core.V "_" n)++pattern FA :: Text -> FieldSelection s+pattern FA t <- Core.FieldSelection _ t _+ where FA = Core.makeFieldSelection
src/Dhall/JSON/Yaml.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -14,30 +13,34 @@ , defaultOptions , dhallToYaml , jsonToYaml+ , generatedCodeNotice ) where -import Data.ByteString (ByteString)-import Data.Monoid ((<>))-import Data.Text (Text)-import Dhall.JSON (Conversion(..), SpecialDoubleMode(..))+import Data.ByteString (ByteString)+import Data.Text (Text)+import Dhall.JSON (Conversion (..), SpecialDoubleMode (..))+import Dhall.Parser (Header(..)) import Options.Applicative (Parser) import qualified Data.Aeson import qualified Data.Aeson.Yaml import qualified Data.ByteString.Lazy+import qualified Data.Text.Encoding import qualified Data.Vector import qualified Dhall import qualified Dhall.JSON import qualified Options.Applicative data Options = Options- { explain :: Bool- , omission :: Data.Aeson.Value -> Data.Aeson.Value- , documents :: Bool- , quoted :: Bool- , conversion :: Conversion- , file :: Maybe FilePath- , output :: Maybe FilePath+ { explain :: Bool+ , omission :: Data.Aeson.Value -> Data.Aeson.Value+ , documents :: Bool+ , quoted :: Bool+ , conversion :: Conversion+ , file :: Maybe FilePath+ , output :: Maybe FilePath+ , noEdit :: Bool+ , preserveHeader :: Bool } defaultOptions :: Options@@ -49,13 +52,15 @@ , conversion = Dhall.JSON.defaultConversion , file = Nothing , output = Nothing+ , noEdit = False+ , preserveHeader = False } parseDocuments :: Parser Bool parseDocuments = Options.Applicative.switch ( Options.Applicative.long "documents"- <> Options.Applicative.help "If given a Dhall list, output a document for every element"+ <> Options.Applicative.help "If given a Dhall list, output a document for every element. Each document, including the first one, will be preceded by \"---\", even if there is only one document. If not given a list, output a single document (as if it were a list of one element)" ) parseQuoted :: Parser Bool@@ -64,7 +69,13 @@ ( Options.Applicative.long "quoted" <> Options.Applicative.help "Prevent from generating not quoted scalars" )- ++{-| The notice added to the top of a generated file when enabling the+ @--generated-comment@+-}+generatedCodeNotice :: ByteString+generatedCodeNotice = "# Code generated by dhall-to-yaml. DO NOT EDIT.\n"+ {-| Convert a piece of Text carrying a Dhall inscription to an equivalent YAML ByteString -} dhallToYaml@@ -74,13 +85,24 @@ -> Text -- ^ Input text. -> IO ByteString dhallToYaml Options{..} mFilePath code = do- + let explaining = if explain then Dhall.detailed else id - json <- omission <$> explaining (Dhall.JSON.codeToValue conversion UseYAMLEncoding mFilePath code)+ let adapt (header, value) = (header, omission value) - return $ jsonToYaml json documents quoted+ (Header comment, json) <- adapt <$> explaining (Dhall.JSON.codeToHeaderAndValue conversion UseYAMLEncoding mFilePath code) + let suffix+ | preserveHeader = Data.Text.Encoding.encodeUtf8 comment+ | otherwise = mempty++ let header =+ if noEdit+ then generatedCodeNotice <> suffix+ else suffix++ return $ header <> jsonToYaml json documents quoted+ -- | Transform json representation into yaml jsonToYaml :: Data.Aeson.Value@@ -94,6 +116,11 @@ then Data.Aeson.Yaml.encodeQuotedDocuments else Data.Aeson.Yaml.encodeDocuments ) (Data.Vector.toList elems)+ (True, value)+ -> (if quoted+ then Data.Aeson.Yaml.encodeQuotedDocuments+ else Data.Aeson.Yaml.encodeDocuments+ ) [ value ] _ -> (if quoted then Data.Aeson.Yaml.encodeQuoted else Data.Aeson.Yaml.encode
src/Dhall/JSONToDhall.hs view
@@ -1,157 +1,263 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE PatternGuards #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-} {-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-} -{-| 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 + If your schema is a record with a `List` field and omit that field in the JSON,+ you'll get an error: +> $ json-to-dhall '{ a : List Natural }' <<< '{}'+>+>+> Error: Key a, expected by Dhall type:+> List Natural+> is not present in JSON object:+> {}++ You can use the @--omissible-lists@ option to default to an empty list in this case++> $ json-to-dhall --omissible-lists '{ a : List Natural }' <<< '{}'+> { a = [] : List Natural }+ == 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 +277,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 +307,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,40 +348,54 @@ , typeCheckSchemaExpr , dhallFromJSON + -- * Schema inference+ , Schema(..)+ , RecordSchema(..)+ , UnionSchema(..)+ , inferSchema+ , schemaToDhallType+ -- * 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 Control.Applicative ((<|>))+import Control.Exception (Exception, throwIO)+import Control.Monad.Catch (MonadCatch, throwM)+import Data.Aeson (Value)+import Data.Aeson.Encode.Pretty (encodePretty)+import Data.Either (rights)+import Data.Foldable (toList)+import Data.List ((\\))+import Data.Monoid (Any (..))+import Data.Scientific (floatingOrInteger, toRealFloat)+import Data.Text (Text)+import Data.Void (Void)+import Dhall.Core (Chunks (..), DhallDouble (..), Expr (App))+import Dhall.JSON.Util (pattern FA, pattern V)+import Dhall.Parser (Src)+import Options.Applicative (Parser)++import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Types as Aeson.Types 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.Foldable as Foldable+import qualified Data.Map+import qualified Data.Map.Merge.Lazy as Data.Map.Merge+import qualified Data.Sequence as Seq import qualified Data.String-import qualified Data.Text as Text-import Data.Text (Text)-import qualified Data.Vector as Vector-import Data.Void (Void)-import qualified Options.Applicative as O-import Options.Applicative (Parser)--import Dhall.JSON.Util (pattern V)-import qualified Dhall.Core as D-import Dhall.Core (Expr(App), Chunks(..), DhallDouble(..))+import qualified Data.Text as Text+import qualified Data.Vector as Vector+import qualified Dhall.Core as D import qualified Dhall.Import-import qualified Dhall.Map as Map+import qualified Dhall.JSON.Compat as JSON.Compat+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+import qualified Dhall.TypeCheck as D+import qualified Options.Applicative as O -- --------------- -- Command options@@ -260,11 +412,11 @@ parseStrict = O.flag' True ( O.long "records-strict"- <> O.help "Fail if any YAML fields are missing from the expected Dhall type"+ <> O.help "Fail if any JSON fields are missing from the expected Dhall type" ) <|> O.flag' False ( O.long "records-loose"- <> O.help "Tolerate YAML fields not present within the expected Dhall type"+ <> O.help "Tolerate JSON fields not present within the expected Dhall type" ) <|> pure True @@ -291,7 +443,7 @@ 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)"+ <> O.help "The first value with the matching type (successfully parsed all the way down the tree) is accepted, even if not the only possible match. (DEFAULT)" ) uNone = O.flag' UNone ( O.long "unions-none"@@ -363,236 +515,604 @@ 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+keyValMay :: Value -> Maybe (Text, Value)+keyValMay (Aeson.Object o) = do+ Aeson.String k <- JSON.Compat.lookupObject "key" o+ v <- JSON.Compat.lookupObject "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 (Aeson.Object m) =+ let convertMap = Data.Map.fromDistinctAscList . JSON.Compat.mapToAscList++ in (Record . RecordSchema . convertMap) (fmap inferSchema m)+inferSchema (Aeson.Array xs) =+ List (Foldable.foldMap inferSchema xs)+inferSchema (Aeson.String _) =+ Text+inferSchema (Aeson.Number n) =+ case floatingOrInteger n of+ Left (_ :: Double) -> Double+ Right (integer :: Integer)+ | 0 <= integer -> Natural+ | otherwise -> Integer+inferSchema (Aeson.Bool _) =+ Bool+inferSchema Aeson.Null =+ Optional mempty++-- | Aeson 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 (D.makeRecordField . 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++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++{-| 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++-- | 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 mempty "_" (D.Const D.Type)+ (D.Pi mempty "_"+ (D.Record+ [ ("array" , D.makeRecordField $ D.Pi mempty "_" (D.App D.List (V 0)) (V 1))+ , ("bool" , D.makeRecordField $ D.Pi mempty "_" D.Bool (V 1))+ , ("double", D.makeRecordField $ D.Pi mempty "_" D.Double (V 1))+ , ("integer", D.makeRecordField $ D.Pi mempty "_" D.Integer (V 1))+ , ("null" , D.makeRecordField $ V 0)+ , ("object", D.makeRecordField $+ D.Pi mempty "_" (D.App D.List (D.Record+ [ ("mapKey", D.makeRecordField D.Text)+ , ("mapValue", D.makeRecordField $ V 0)+ ])) (V 1))+ , ("string", D.makeRecordField $ D.Pi mempty "_" 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 >>> import qualified Dhall.Core as D >>> import qualified Dhall.Map as Map->>> import qualified Data.Aeson as A+>>> import qualified Data.Aeson as Aeson >>> import qualified Data.HashMap.Strict as HM >>> s = D.Record (Map.fromList [("foo", D.Integer)])->>> v = A.Object (HM.fromList [("foo", A.Number 1)])+>>> v = Aeson.Object (HM.fromList [("foo", Aeson.Number 1)]) >>> dhallFromJSON defaultConversion s v Right (RecordLit (fromList [("foo",IntegerLit 1)])) -} 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+ loop :: Aeson.Types.JSONPath -> ExprX -> Aeson.Value -> Either CompileError ExprX -- any ~> Union- loop t@(D.Union tm) v = do+ loop jsonPath t@(D.Union tm) v = do let f key maybeType = case maybeType of Just _type -> do- expression <- loop _type v+ expression <- loop jsonPath _type v - return (D.App (D.Field t key) expression)+ return (D.App (D.Field t $ FA key) expression) - Nothing -> do+ Nothing -> case v of- A.String text | key == text -> do- return (D.Field t key)- _ -> do- Left (Mismatch t v)+ Aeson.String text | key == text ->+ return (D.Field t $ FA key)+ _ ->+ Left (Mismatch t v jsonPath) case (unions, rights (toList (Map.mapWithKey f tm))) of (UNone , _ ) -> Left (ContainsUnion t) (UStrict, xs@(_:_:_)) -> Left (UndecidableUnion t v xs)- (_ , [ ] ) -> Left (Mismatch t v)+ (_ , [ ] ) -> Left (Mismatch t v jsonPath) (UFirst , x:_ ) -> Right x (UStrict, [x] ) -> Right x -- object ~> Record- loop (D.Record r) v@(A.Object o)- | extraKeys <- HM.keys o \\ Map.keys r+ loop jsonPath (D.Record r) v@(Aeson.Object o)+ | extraKeys <- JSON.Compat.objectKeys o \\ Map.keys r , strictRecs && not (null extraKeys)- = Left (UnhandledKeys extraKeys (D.Record r) v)+ = Left (UnhandledKeys extraKeys (D.Record r) v jsonPath) | otherwise = let f :: Text -> ExprX -> Either CompileError ExprX- f k t | Just value <- HM.lookup k o- = loop t value+ f k t | Just value <- JSON.Compat.lookupObject k o+ = loop (Aeson.Types.Key (JSON.Compat.textToKey k) : jsonPath) t value | App D.Optional t' <- t = Right (App D.None t') | App D.List _ <- t , omissibleLists = Right (D.ListLit (Just t) []) | otherwise- = Left (MissingKey k t v)- in D.RecordLit <$> Map.traverseWithKey f r+ = Left (MissingKey k t v jsonPath)+ in D.RecordLit . fmap D.makeRecordField <$> Map.traverseWithKey f (D.recordFieldValue <$> r) -- key-value list ~> Record- loop t@(D.Record _) v@(A.Array a)+ loop jsonPath t@(D.Record _) v@(Aeson.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)+ = loop jsonPath t (Aeson.Object $ JSON.Compat.objectFromList kvs) | noKeyValArr = Left (NoKeyValArray t v) | otherwise- = Left (Mismatch t v)+ = Left (Mismatch t v jsonPath) -- object ~> List (key, value)- loop t@(App D.List (D.Record r)) v@(A.Object o)+ loop jsonPath t@(App D.List (D.Record r)) v@(Aeson.Object o) | not noKeyValMap , ["mapKey", "mapValue"] == Map.keys r- , Just mapKey <- Map.lookup "mapKey" r- , Just mapValue <- Map.lookup "mapValue" r+ , Just mapKey <- D.recordFieldValue <$> Map.lookup "mapKey" r+ , Just mapValue <- D.recordFieldValue <$> Map.lookup "mapValue" r = do- keyExprMap <- traverse (loop mapValue) o+ keyExprMap <- JSON.Compat.traverseObjectWithKey (\k child -> loop (Aeson.Types.Key k : jsonPath) mapValue child) o - toKey <- do+ toKey <- case mapKey of- D.Text -> return (\key -> D.TextLit (Chunks [] key))- D.Union _ -> return (\key -> D.Field mapKey key)- _ -> Left (Mismatch t v)+ D.Text -> return $ D.TextLit . Chunks []+ D.Union _ -> return $ D.Field mapKey . FA+ _ -> Left (Mismatch t v jsonPath) let f :: (Text, ExprX) -> ExprX- f (key, val) = D.RecordLit ( Map.fromList+ f (key, val) = D.RecordLit $ D.makeRecordField <$> Map.fromList [ ("mapKey" , toKey key) , ("mapValue", val)- ] )+ ] - let records = (fmap f . Seq.fromList . HM.toList) keyExprMap+ let records =+ (fmap f . Seq.fromList . JSON.Compat.mapToAscList) keyExprMap - let typeAnn = if HM.null o then Just t else Nothing+ let typeAnn = if null o then Just t else Nothing return (D.ListLit typeAnn records) | noKeyValMap = Left (NoKeyValMap t v) | otherwise- = Left (Mismatch t v)+ = Left (Mismatch t v jsonPath) -- array ~> List- loop (App D.List t) (A.Array a)+ loop jsonPath (App D.List t) (Aeson.Array a) = let f :: [ExprX] -> ExprX f es = D.ListLit (if null es then Just (App D.List t) else Nothing) (Seq.fromList es)- in f <$> traverse (loop t) (toList a)+ in f <$> traverse (\(idx, val) -> loop (Aeson.Types.Index idx : jsonPath) t val) (zip [0..] $ toList a) -- null ~> List- loop t@(App D.List _) (A.Null)+ loop jsonPath t@(App D.List _) Aeson.Null = if omissibleLists then Right (D.ListLit (Just t) [])- else Left (Mismatch t A.Null)+ else Left (Mismatch t Aeson.Null jsonPath) -- number ~> Integer- loop D.Integer (A.Number x)+ loop jsonPath D.Integer (Aeson.Number x) | Right n <- floatingOrInteger x :: Either Double Integer = Right (D.IntegerLit n) | otherwise- = Left (Mismatch D.Integer (A.Number x))+ = Left (Mismatch D.Integer (Aeson.Number x) jsonPath) -- number ~> Natural- loop D.Natural (A.Number x)+ loop jsonPath D.Natural (Aeson.Number x) | Right n <- floatingOrInteger x :: Either Double Integer , n >= 0 = Right (D.NaturalLit (fromInteger n)) | otherwise- = Left (Mismatch D.Natural (A.Number x))+ = Left (Mismatch D.Natural (Aeson.Number x) jsonPath) -- number ~> Double- loop D.Double (A.Number x)+ loop _ D.Double (Aeson.Number x) = Right (D.DoubleLit $ DhallDouble $ toRealFloat x) -- string ~> Text- loop D.Text (A.String t)+ loop _ D.Text (Aeson.String t) = Right (D.TextLit (Chunks [] t)) -- bool ~> Bool- loop D.Bool (A.Bool t)+ loop _ D.Bool (Aeson.Bool t) = Right (D.BoolLit t) -- null ~> Optional- loop (App D.Optional expr) A.Null+ loop _ (App D.Optional expr) Aeson.Null = Right $ App D.None expr -- value ~> Optional- loop (App D.Optional expr) value- = D.Some <$> loop expr value+ loop jsonPath (App D.Optional expr) value+ = D.Some <$> loop jsonPath expr value - -- Arbitrary JSON ~> https://prelude.dhall-lang.org/JSON/Type+ -- Arbitrary JSON ~> https://prelude.dhall-lang.org/JSON/Type (< v13.0.0) loop- (D.Pi _ (D.Const D.Type)- (D.Pi _+ _+ (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))- , ("null" , V 0)- , ("number", D.Pi _ D.Double (V 1))- , ("object", D.Pi _ (D.App D.List (D.Record [ ("mapKey", D.Text), ("mapValue", V 0)])) (V 1))- , ("string", D.Pi _ D.Text (V 1))+ [ ("array" , D.recordFieldValue -> D.Pi _ _ (D.App D.List (V 0)) (V 1))+ , ("bool" , D.recordFieldValue -> D.Pi _ _ D.Bool (V 1))+ , ("null" , D.recordFieldValue -> V 0)+ , ("number", D.recordFieldValue -> D.Pi _ _ D.Double (V 1))+ , ("object", D.recordFieldValue ->+ D.Pi _ _ (D.App D.List (D.Record+ [ ("mapKey", D.recordFieldValue -> D.Text)+ , ("mapValue", D.recordFieldValue -> V 0)+ ])) (V 1))+ , ("string", D.recordFieldValue -> D.Pi _ _ D.Text (V 1)) ] ) (V 1) ) ) value = do- let outer (A.Object o) =+ let outer (Aeson.Object o) = let inner (key, val) = D.RecordLit- [ ("mapKey" , D.TextLit (D.Chunks [] key))- , ("mapValue", outer val )+ [ ("mapKey" , D.makeRecordField $ D.TextLit (D.Chunks [] key))+ , ("mapValue", D.makeRecordField $ outer val ) ] - elements = Seq.fromList (fmap inner (HM.toList o))+ elements =+ Seq.fromList+ (fmap inner+ (JSON.Compat.mapToAscList o)+ ) elementType | null elements =- Just (D.App D.List (D.Record [ ("mapKey", D.Text), ("mapValue", "JSON") ]))+ Just (D.App D.List (D.Record+ [ ("mapKey", D.makeRecordField D.Text)+ , ("mapValue", D.makeRecordField "JSON")+ ])) | otherwise = Nothing keyValues = D.ListLit elementType elements - in (D.App (D.Field "json" "object") keyValues)- outer (A.Array a) =+ in D.App (D.Field "json" $ FA "object") keyValues+ outer (Aeson.Array a) = let elements = Seq.fromList (fmap outer (Vector.toList a)) elementType | null elements = Just (D.App D.List "JSON") | otherwise = Nothing - in D.App (D.Field "json" "array") (D.ListLit elementType elements)- outer (A.String s) =- D.App (D.Field "json" "string") (D.TextLit (D.Chunks [] s))- outer (A.Number n) =- D.App (D.Field "json" "number") (D.DoubleLit (DhallDouble (toRealFloat n)))- outer (A.Bool b) =- D.App (D.Field "json" "bool") (D.BoolLit b)- outer A.Null =- D.Field "json" "null"+ in D.App (D.Field "json" $ FA "array") (D.ListLit elementType elements)+ outer (Aeson.String s) =+ D.App (D.Field "json" $ FA "string") (D.TextLit (D.Chunks [] s))+ outer (Aeson.Number n) =+ D.App (D.Field "json" $ FA "number") (D.DoubleLit (DhallDouble (toRealFloat n)))+ outer (Aeson.Bool b) =+ D.App (D.Field "json" $ FA "bool") (D.BoolLit b)+ outer Aeson.Null =+ D.Field "json" $ FA "null" let result =- D.Lam "JSON" (D.Const D.Type)- (D.Lam "json"+ D.Lam mempty (D.makeFunctionBinding "JSON" (D.Const D.Type))+ (D.Lam mempty (D.makeFunctionBinding "json" (D.Record- [ ("array" , D.Pi "_" (D.App D.List "JSON") "JSON")- , ("bool" , D.Pi "_" D.Bool "JSON")- , ("null" , "JSON")- , ("number", D.Pi "_" D.Double "JSON")- , ("object", D.Pi "_" (D.App D.List (D.Record [ ("mapKey", D.Text), ("mapValue", "JSON")])) "JSON")- , ("string", D.Pi "_" D.Text "JSON")+ [ ("array" , D.makeRecordField $ D.Pi mempty "_" (D.App D.List "JSON") "JSON")+ , ("bool" , D.makeRecordField $ D.Pi mempty "_" D.Bool "JSON")+ , ("null" , D.makeRecordField "JSON")+ , ("number", D.makeRecordField $ D.Pi mempty "_" D.Double "JSON")+ , ("object", D.makeRecordField $+ D.Pi mempty "_" (D.App D.List (D.Record+ [ ("mapKey", D.makeRecordField D.Text)+ , ("mapValue", D.makeRecordField "JSON")+ ])) "JSON")+ , ("string", D.makeRecordField $ D.Pi mempty "_" D.Text "JSON") ]- )+ )) (outer value) ) return result + -- Arbitrary JSON ~> https://prelude.dhall-lang.org/JSON/Type (v13.0.0 <=)+ loop+ _+ (D.Pi _ _ (D.Const D.Type)+ (D.Pi _ _+ (D.Record+ [ ("array" , D.recordFieldValue -> D.Pi _ _ (D.App D.List (V 0)) (V 1))+ , ("bool" , D.recordFieldValue -> D.Pi _ _ D.Bool (V 1))+ , ("double", D.recordFieldValue -> D.Pi _ _ D.Double (V 1))+ , ("integer", D.recordFieldValue -> D.Pi _ _ D.Integer (V 1))+ , ("null" , D.recordFieldValue -> V 0)+ , ("object", D.recordFieldValue ->+ D.Pi _ _ (D.App D.List (D.Record+ [ ("mapKey", D.recordFieldValue -> D.Text)+ , ("mapValue", D.recordFieldValue -> V 0)+ ])) (V 1))+ , ("string", D.recordFieldValue -> D.Pi _ _ D.Text (V 1))+ ]+ )+ (V 1)+ )+ )+ value = do+ let outer (Aeson.Object o) =+ let inner (key, val) =+ D.RecordLit+ [ ("mapKey" , D.makeRecordField $ D.TextLit (D.Chunks [] key))+ , ("mapValue", D.makeRecordField $ outer val )+ ]++ elements =+ Seq.fromList+ (fmap inner+ (JSON.Compat.mapToAscList o)+ )++ elementType+ | null elements =+ Just (D.App D.List (D.Record+ [ ("mapKey", D.makeRecordField D.Text)+ , ("mapValue", D.makeRecordField "JSON") ]))+ | otherwise =+ Nothing++ keyValues = D.ListLit elementType elements++ in D.App (D.Field "json" (FA "object")) keyValues+ outer (Aeson.Array a) =+ let elements = Seq.fromList (fmap outer (Vector.toList a))++ elementType+ | null elements = Just (D.App D.List "JSON")+ | otherwise = Nothing++ in D.App (D.Field "json" (FA "array")) (D.ListLit elementType elements)+ outer (Aeson.String s) =+ D.App (D.Field "json" (FA "string")) (D.TextLit (D.Chunks [] s))+ outer (Aeson.Number n) =+ case floatingOrInteger n of+ Left floating -> D.App (D.Field "json" (FA "double")) (D.DoubleLit (DhallDouble floating))+ Right integer -> D.App (D.Field "json" (FA "integer")) (D.IntegerLit integer)+ outer (Aeson.Bool b) =+ D.App (D.Field "json" (FA "bool")) (D.BoolLit b)+ outer Aeson.Null =+ D.Field "json" (FA "null")++ let result =+ D.Lam mempty (D.makeFunctionBinding "JSON" (D.Const D.Type))+ (D.Lam mempty (D.makeFunctionBinding "json"+ (D.Record+ [ ("array" , D.makeRecordField $ D.Pi mempty "_" (D.App D.List "JSON") "JSON")+ , ("bool" , D.makeRecordField $ D.Pi mempty "_" D.Bool "JSON")+ , ("double", D.makeRecordField $ D.Pi mempty "_" D.Double "JSON")+ , ("integer", D.makeRecordField $ D.Pi mempty "_" D.Integer "JSON")+ , ("null" , D.makeRecordField "JSON")+ , ("object", D.makeRecordField $ D.Pi mempty "_"+ (D.App D.List (D.Record+ [ ("mapKey", D.makeRecordField D.Text)+ , ("mapValue", D.makeRecordField "JSON")])) "JSON")+ , ("string", D.makeRecordField $ D.Pi mempty "_" D.Text "JSON")+ ]+ ))+ (outer value)+ )++ return result+ -- fail- loop expr value- = Left (Mismatch expr value)+ loop jsonPath expr value+ = Left (Mismatch expr value jsonPath) -- ----------@@ -600,7 +1120,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@@ -608,7 +1128,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@@ -620,22 +1140,23 @@ -- generic mismatch (fallback) | Mismatch ExprX -- Dhall expression- A.Value -- Aeson value+ Value -- Aeson value+ Aeson.Types.JSONPath -- JSON Path to the error -- record specific- | MissingKey Text ExprX A.Value- | UnhandledKeys [Text] ExprX A.Value- | NoKeyValArray ExprX A.Value- | NoKeyValMap ExprX A.Value+ | MissingKey Text ExprX Value Aeson.Types.JSONPath+ | UnhandledKeys [Text] ExprX Value Aeson.Types.JSONPath+ | 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@@ -659,21 +1180,22 @@ <> Text.unpack (Text.intercalate sep $ D.pretty <$> xs) where sep = red "\n--------\n" :: Text - Mismatch e v -> prefix- <> "Dhall type expression and " <> format <> " value do not match:"+ Mismatch e v jsonPath -> prefix+ <> showJsonPath jsonPath <> ": Dhall type expression and " <> format <> " value do not match:" <> "\n\nExpected Dhall type:\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"+ MissingKey k e v jsonPath -> prefix+ <> showJsonPath jsonPath <> ": 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 expected Dhall record type. This is not allowed unless you enable the "+ UnhandledKeys ks e v jsonPath -> prefix+ <> showJsonPath jsonPath <> ": Key(s) " <> purple (Text.unpack (Text.intercalate ", " ks))+ <> " present in the " <> format <> " object but not in the expected Dhall"+ <> " record type. This is not allowed unless you enable the " <> green "--records-loose" <> " flag:" <> "\n\nExpected Dhall type:\n" <> showExpr e <> "\n\n" <> format <> ":\n" <> showValue v@@ -688,7 +1210,10 @@ NoKeyValMap e v -> prefix <> "Homogeneous " <> format <> " map objects cannot be converted to Dhall association lists under "- <> green "--no-keyval-arrays" <> " flag"+ <> green "--no-keyval-maps" <> " flag" <> "\n\nExpected Dhall type:\n" <> showExpr e <> "\n\n" <> format <> ":\n" <> showValue v <> "\n"++showJsonPath :: Aeson.Types.JSONPath -> String+showJsonPath = Aeson.Types.formatPath . reverse
tasty/Main.hs view
@@ -1,14 +1,14 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLists #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-} module Main where -import Data.Monoid ((<>))+import Data.Void (Void) import Test.Tasty (TestTree) import qualified Data.Aeson as Aeson import qualified Data.ByteString.Lazy+import qualified Data.Text import qualified Data.Text.IO import qualified Dhall.Core as Core import qualified Dhall.Import@@ -19,6 +19,7 @@ import qualified GHC.IO.Encoding import qualified Test.Tasty import qualified Test.Tasty.HUnit+import qualified Test.Tasty.Silver main :: IO () main = do@@ -31,12 +32,24 @@ Test.Tasty.testGroup "dhall-json" [ testDhallToJSON "./tasty/data/issue48" , testDhallToJSON "./tasty/data/emptyObjectStrongType"+ , testDhallToJSON "./tasty/data/toArbitraryJSON_12_0_0"+ , testDhallToJSON "./tasty/data/toArbitraryJSON_13_0_0" , testJSONToDhall "./tasty/data/emptyAlternative" , testJSONToDhall "./tasty/data/emptyObject" , testJSONToDhall "./tasty/data/emptyList" , testJSONToDhall "./tasty/data/emptyObjectStrongType" , testJSONToDhall "./tasty/data/emptyListStrongType"- , testCustomConversionJSONToDhall omissibleLists "./tasty/data/missingList"+ , testJSONToDhall "./tasty/data/fromArbitraryJSON_12_0_0"+ , testJSONToDhall "./tasty/data/fromArbitraryJSON_13_0_0"+ , inferJSONToDhall "./tasty/data/potpourri"+ , testCustomConversionJSONToDhall False omissibleLists "./tasty/data/missingList"+ , Test.Tasty.testGroup "Errors"+ [ testJSONToDhallErrorMessage "./tasty/data/error/mismatchMessage0" defaultConversion+ , testJSONToDhallErrorMessage "./tasty/data/error/mismatchMessage1" defaultConversion+ , testJSONToDhallErrorMessage "./tasty/data/error/mismatchMessage2" defaultConversion+ , testJSONToDhallErrorMessage "./tasty/data/error/unhandledKeys" strictRecs+ , testJSONToDhallErrorMessage "./tasty/data/error/missingKey" strictRecs+ ] , Test.Tasty.testGroup "Nesting" [ testDhallToJSON "./tasty/data/nesting0" , testDhallToJSON "./tasty/data/nesting1"@@ -44,13 +57,17 @@ , testDhallToJSON "./tasty/data/nesting3" , testDhallToJSON "./tasty/data/nestingLegacy0" , testDhallToJSON "./tasty/data/nestingLegacy1"+ , testDhallToJSON "./tasty/data/time" ] , Test.Tasty.testGroup "Union keys" [ testJSONToDhall "./tasty/data/unionKeys" , testDhallToJSON "./tasty/data/unionKeys" ] ]- where omissibleLists = JSONToDhall.defaultConversion{JSONToDhall.omissibleLists = True}+ where+ defaultConversion = JSONToDhall.defaultConversion+ omissibleLists = defaultConversion{JSONToDhall.omissibleLists = True}+ strictRecs = defaultConversion{JSONToDhall.strictRecs = True} testDhallToJSON :: String -> TestTree testDhallToJSON prefix = Test.Tasty.HUnit.testCase prefix $ do@@ -59,7 +76,7 @@ text <- Data.Text.IO.readFile inputFile - parsedExpression <- do+ parsedExpression <- Core.throws (Dhall.Parser.exprFromText inputFile text) resolvedExpression <- Dhall.Import.load parsedExpression@@ -69,7 +86,7 @@ let convertedExpression = Dhall.JSON.convertToHomogeneousMaps Dhall.JSON.defaultConversion resolvedExpression - actualValue <- do+ actualValue <- Core.throws (Dhall.JSON.dhallToJSON convertedExpression) bytes <- Data.ByteString.Lazy.readFile outputFile@@ -82,41 +99,40 @@ 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 - value <- do+ value <- case Aeson.eitherDecode bytes of Left string -> fail string Right value -> return value - schemaText <- Data.Text.IO.readFile schemaFile-- parsedSchema <- Core.throws (Dhall.Parser.exprFromText schemaFile schemaText)-- schema <- Dhall.Import.load parsedSchema+ schema <-+ if infer+ then return (JSONToDhall.schemaToDhallType (JSONToDhall.inferSchema value))+ else let schemaFile = prefix <> "Schema.dhall" in loadSchemaFromFile schemaFile _ <- Core.throws (Dhall.TypeCheck.typeOf schema) - actualExpression <- do+ actualExpression <- Core.throws (JSONToDhall.dhallFromJSON conv schema value) outputText <- Data.Text.IO.readFile outputFile - parsedExpression <- do+ parsedExpression <- Core.throws (Dhall.Parser.exprFromText outputFile outputText) resolvedExpression <- Dhall.Import.load parsedExpression _ <- 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"@@ -124,4 +140,44 @@ 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++loadSchemaFromFile :: FilePath -> IO (Core.Expr Dhall.Parser.Src Void)+loadSchemaFromFile schemaFile = do+ schemaText <- Data.Text.IO.readFile schemaFile++ parsedSchema <- Core.throws (Dhall.Parser.exprFromText schemaFile schemaText)++ Dhall.Import.load parsedSchema++testJSONToDhallErrorMessage :: String -> JSONToDhall.Conversion -> TestTree+testJSONToDhallErrorMessage prefix conv =+ Test.Tasty.Silver.goldenVsAction prefix goldenFile action converter+ where+ goldenFile = prefix <> ".golden"+ schemaFile = prefix <> "Schema.dhall"+ inputFile = prefix <> ".json"++ action = do+ bytes <- Data.ByteString.Lazy.readFile inputFile++ value <-+ case Aeson.eitherDecode bytes of+ Left string -> fail string+ Right value -> return value++ schema <- loadSchemaFromFile schemaFile++ _ <- Core.throws (Dhall.TypeCheck.typeOf schema)++ case JSONToDhall.dhallFromJSON conv schema value of+ Right _ -> fail $ prefix <> " should fail"+ Left compileError ->+ return (Data.Text.pack $ show compileError)++ converter = id
tasty/data/emptyObject.dhall view
@@ -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 })
tasty/data/emptyObjectStrongType.dhall view
@@ -1,1 +1,1 @@-[] : List { mapKey : Text, mapValue : Natural }+toMap {=} : List { mapKey : Text, mapValue : Natural }
+ tasty/data/error/mismatchMessage0.golden view
@@ -0,0 +1,8 @@+[1;31m+Error: [0m$.a.b[1]: Dhall type expression and JSON value do not match:++Expected Dhall type:+Natural++JSON:+0.5
+ tasty/data/error/mismatchMessage0.json view
@@ -0,0 +1,14 @@+{+ "a": {+ "b": [+ 10,+ 0.5+ ]+ },+ "c": {+ "d": [+ 10,+ 0.5+ ]+ }+}
+ tasty/data/error/mismatchMessage0Schema.dhall view
@@ -0,0 +1,3 @@+{ a : { b : List Natural }+, c : { d : List Integer }+}
+ tasty/data/error/mismatchMessage1.golden view
@@ -0,0 +1,8 @@+[1;31m+Error: [0m$: Dhall type expression and JSON value do not match:++Expected Dhall type:+Text++JSON:+1
+ tasty/data/error/mismatchMessage1.json view
@@ -0,0 +1,1 @@+1
+ tasty/data/error/mismatchMessage1Schema.dhall view
@@ -0,0 +1,1 @@+Text
+ tasty/data/error/mismatchMessage2.golden view
@@ -0,0 +1,8 @@+[1;31m+Error: [0m$[3]: Dhall type expression and JSON value do not match:++Expected Dhall type:+Natural++JSON:+"oh oh"
+ tasty/data/error/mismatchMessage2.json view
@@ -0,0 +1,1 @@+[ 1, 2, 3, "oh oh" ]
+ tasty/data/error/mismatchMessage2Schema.dhall view
@@ -0,0 +1,1 @@+List Natural
+ tasty/data/error/missingKey.golden view
@@ -0,0 +1,5 @@+[1;31m+Error: [0m$.a: Key [1;35mb[0m, expected by Dhall type:+Bool+is not present in JSON object:+{}
+ tasty/data/error/missingKey.json view
@@ -0,0 +1,4 @@+{+ "a": {+ }+}
+ tasty/data/error/missingKeySchema.dhall view
@@ -0,0 +1,1 @@+{ a: { b: Bool } }
+ tasty/data/error/unhandledKeys.golden view
@@ -0,0 +1,10 @@+[1;31m+Error: [0m$[1]: Key(s) [1;35mb[0m present in the JSON object but not in the expected Dhall record type. This is not allowed unless you enable the [0;32m--records-loose[0m flag:++Expected Dhall type:+{ a : Natural }++JSON:+{+ "b": 2+}
+ tasty/data/error/unhandledKeys.json view
@@ -0,0 +1,4 @@+[+ { "a": 1 },+ { "b": 2 }+]
+ tasty/data/error/unhandledKeysSchema.dhall view
@@ -0,0 +1,1 @@+List { a: Natural }
+ tasty/data/fromArbitraryJSON_12_0_0.dhall view
@@ -0,0 +1,19 @@+ λ(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+ }+ )+→ json.object+ ( toMap+ { array = json.array ([] : List JSON)+ , bool = json.bool False+ , null = json.null+ , number = json.number 1.0+ , string = json.string "ABC"+ }+ )
+ tasty/data/fromArbitraryJSON_12_0_0.json view
@@ -0,0 +1,7 @@+{+ "array": [],+ "bool": false,+ "null": null,+ "number": 1,+ "string": "ABC"+}
+ tasty/data/fromArbitraryJSON_12_0_0Schema.dhall view
@@ -0,0 +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+ }+ )+→ JSON
+ tasty/data/fromArbitraryJSON_13_0_0.dhall view
@@ -0,0 +1,21 @@+ λ(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.object+ ( 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"+ }+ )
+ tasty/data/fromArbitraryJSON_13_0_0.json view
@@ -0,0 +1,8 @@+{+ "array": [],+ "bool": false,+ "null": null,+ "double": 1.5,+ "integer": 1,+ "string": "ABC"+}
+ tasty/data/fromArbitraryJSON_13_0_0Schema.dhall view
@@ -0,0 +1,12 @@+ ∀(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
tasty/data/missingList.dhall view
@@ -1,1 +1,4 @@-{present = ["some-stuff"], null = [] : List Text, missing = [] : List Text}+{ missingProp = [] : List Text+, null = [] : List Text+, present = ["some-stuff"]+}
tasty/data/missingListSchema.dhall view
@@ -1,1 +1,1 @@-{present : List Text, null : List Text, missing : List Text}+{present : List Text, null : List Text, missingProp : List Text}
+ tasty/data/potpourri.dhall view
@@ -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"+ }+]
+ tasty/data/potpourri.json view
@@ -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": []+ }+]
+ tasty/data/time.dhall view
@@ -0,0 +1,7 @@+{ example0 = 2020-01-01+, example1 = 00:00:00+, example2 = +00:00+, example3 = 2020-01-01T00:00:00+, example4 = 00:00:00+00:00+, example5 = 2020-01-01T00:00:00+00:00+}
+ tasty/data/time.json view
@@ -0,0 +1,8 @@+{+ "example0": "2020-01-01",+ "example1": "00:00:00",+ "example2": "+00:00",+ "example3": "2020-01-01T00:00:00",+ "example4": "00:00:00+00:00",+ "example5": "2020-01-01T00:00:00+00:00"+}
+ tasty/data/toArbitraryJSON_12_0_0.dhall view
@@ -0,0 +1,17 @@+ λ(_ : Type)+→ λ ( _+ : { array : List _ → _@1+ , bool : Bool → _@1+ , null : _+ , number : Double → _@1+ , object : List { mapKey : Text, mapValue : _ } → _@1+ , string : Text → _@1+ }+ )+→ _.object+ [ { mapKey = "array", mapValue = _.array ([] : List _@1) }+ , { mapKey = "bool", mapValue = _.bool False }+ , { mapKey = "null", mapValue = _.null }+ , { mapKey = "number", mapValue = _.number 1.0 }+ , { mapKey = "string", mapValue = _.string "ABC" }+ ]
+ tasty/data/toArbitraryJSON_12_0_0.json view
@@ -0,0 +1,7 @@+{+ "array": [],+ "bool": false,+ "null": null,+ "number": 1,+ "string": "ABC"+}
+ tasty/data/toArbitraryJSON_13_0_0.dhall view
@@ -0,0 +1,19 @@+ λ(_ : Type)+→ λ ( _+ : { array : List _ → _@1+ , bool : Bool → _@1+ , null : _+ , double : Double → _@1+ , integer : Integer → _@1+ , object : List { mapKey : Text, mapValue : _ } → _@1+ , string : Text → _@1+ }+ )+→ _.object+ [ { mapKey = "array", mapValue = _.array ([] : List _@1) }+ , { mapKey = "bool", mapValue = _.bool False }+ , { mapKey = "null", mapValue = _.null }+ , { mapKey = "double", mapValue = _.double 1.0 }+ , { mapKey = "integer", mapValue = _.integer +1 }+ , { mapKey = "string", mapValue = _.string "ABC" }+ ]
+ tasty/data/toArbitraryJSON_13_0_0.json view
@@ -0,0 +1,8 @@+{+ "array": [],+ "bool": false,+ "null": null,+ "double": 1,+ "integer": 1,+ "string": "ABC"+}