dhall-json 1.3.0 → 1.4.0
raw patch · 33 files changed
+1156/−542 lines, 33 filesdep +ansi-terminaldep +prettyprinterdep +prettyprinter-ansi-terminaldep −lensdep ~dhallPVP ok
version bump matches the API change (PVP)
Dependencies added: ansi-terminal, prettyprinter, prettyprinter-ansi-terminal
Dependencies removed: lens
Dependency ranges changed: dhall
API changes (from Hackage documentation)
- Dhall.Yaml: jsonToYaml :: Value -> Bool -> Bool -> ByteString
- Dhall.Yaml: yamlToJson :: ByteString -> Either String Value
+ Dhall.Yaml: Options :: Bool -> (Value -> Value) -> Bool -> Bool -> Conversion -> Maybe FilePath -> Options
+ Dhall.Yaml: [conversion] :: Options -> Conversion
+ Dhall.Yaml: [documents] :: Options -> Bool
+ Dhall.Yaml: [explain] :: Options -> Bool
+ Dhall.Yaml: [file] :: Options -> Maybe FilePath
+ Dhall.Yaml: [omission] :: Options -> Value -> Value
+ Dhall.Yaml: [quoted] :: Options -> Bool
+ Dhall.Yaml: data Options
+ Dhall.Yaml: defaultOptions :: Options
+ Dhall.Yaml: dhallToYaml :: Options -> Text -> Text -> IO ByteString
+ Dhall.Yaml: parseDocuments :: Parser Bool
+ Dhall.Yaml: parseQuoted :: Parser Bool
+ Dhall.YamlToDhall: Options :: Text -> Conversion -> Options
+ Dhall.YamlToDhall: YAMLCompileError :: CompileError -> YAMLCompileError
+ Dhall.YamlToDhall: [conversion] :: Options -> Conversion
+ Dhall.YamlToDhall: [schema] :: Options -> Text
+ Dhall.YamlToDhall: data Options
+ Dhall.YamlToDhall: data YAMLCompileError
+ Dhall.YamlToDhall: defaultOptions :: Text -> Options
+ Dhall.YamlToDhall: dhallFromYaml :: Options -> ByteString -> IO (Expr Src X)
+ Dhall.YamlToDhall: instance GHC.Exception.Type.Exception Dhall.YamlToDhall.YAMLCompileError
+ Dhall.YamlToDhall: instance GHC.Show.Show Dhall.YamlToDhall.Options
+ Dhall.YamlToDhall: instance GHC.Show.Show Dhall.YamlToDhall.YAMLCompileError
Files
- CHANGELOG.md +26/−1
- dhall-json.cabal +40/−26
- dhall-to-json/Main.hs +42/−26
- dhall-to-yaml/Main.hs +27/−41
- java/Utils.java +23/−0
- json-to-dhall/Main.hs +91/−37
- src/Dhall/JSON.hs +319/−233
- src/Dhall/JSON/Util.hs +13/−0
- src/Dhall/JSONToDhall.hs +170/−27
- src/Dhall/Yaml.hs +82/−18
- src/Dhall/YamlToDhall.hs +78/−0
- tasty/Main.hs +87/−68
- tasty/data/emptyAlternative.dhall +1/−0
- tasty/data/emptyAlternative.json +1/−0
- tasty/data/emptyAlternativeSchema.dhall +1/−0
- tasty/data/nesting0.dhall +8/−0
- tasty/data/nesting0.json +1/−0
- tasty/data/nesting1.dhall +8/−0
- tasty/data/nesting1.json +1/−0
- tasty/data/nestingLegacy0.dhall +8/−0
- tasty/data/nestingLegacy0.json +1/−0
- tasty/data/nestingLegacy1.dhall +8/−0
- tasty/data/nestingLegacy1.json +1/−0
- tasty/data/normal.dhall +5/−0
- tasty/data/normal.yaml +5/−0
- tasty/data/quoted.dhall +5/−0
- tasty/data/quoted.yaml +5/−0
- tasty/data/unionKeys.dhall +3/−0
- tasty/data/unionKeys.json +1/−0
- tasty/data/unionKeysSchema.dhall +1/−0
- tasty/data/yaml.dhall +0/−5
- tasty/data/yaml.txt +1/−0
- yaml-to-dhall/Main.hs +93/−60
CHANGELOG.md view
@@ -1,3 +1,28 @@+1.4.0++* BREAKING CHANGE: Split `Dhall.YAML` into `Dhall.YAML` + `Dhall.YAMLToDhall`+ * See: https://github.com/dhall-lang/dhall-haskell/pull/993+* BUG FIX: Fix `dhall-to-{json,yaml}`'s support for preserving alternative+ names+ * The `Nested`/`Inline` unions are now correctly given special treatment+ again+ * See: https://github.com/dhall-lang/dhall-haskell/pull/1080+* Feature: Support weakly-typed JSON value added to Prelude+ * You can now encode/decode values of type `./Prelude/JSON/Type` which+ can store arbitrary JSON+ * This is useful when dealing with "pass-through" or schema-free JSON+ values+ * See: https://github.com/dhall-lang/dhall-haskell/pull/1007+* Feature: Eta support for `dhall-json`+ * See: https://github.com/dhall-lang/dhall-haskell/pull/1013+* Feature: Add `--file` option to `dhall-json` executables+* Feature: Support unions for keys+ * You can now decode record fields as enums instead of `Text` so that you+ can pattern match on them+ * See: https://github.com/dhall-lang/dhall-haskell/pull/1094+* Pretty-print output of `{json,yaml}-to-dhall`+ * See: https://github.com/dhall-lang/dhall-haskell/pull/1150+ 1.3.0 * BREAKING CHANGE: Change YAML/JSON encoding for `NaN`/`Infinity`/`-Infinity`@@ -7,7 +32,7 @@ * BREAKING CHANGE: Isolate YAML code to one modulee * This is a breaking change because it moves `Dhall.JSON.jsonToYaml` to `Dhall.YAML.jsonToYaml`- * See: https://github.com/dhall-lang/dhall-haskell/pull/989/files+ * See: https://github.com/dhall-lang/dhall-haskell/pull/989 * New `yaml-to-dhall` command-line utility * See: https://github.com/dhall-lang/dhall-haskell/pull/977 * Add `--quoted` flag to force quoting of YAML string literals
dhall-json.cabal view
@@ -1,5 +1,5 @@ Name: dhall-json-Version: 1.3.0+Version: 1.4.0 Cabal-Version: >=1.8.0.2 Build-Type: Simple Tested-With: GHC == 7.10.3, GHC == 8.4.3, GHC == 8.6.1@@ -24,9 +24,13 @@ Category: Compiler Extra-Source-Files: CHANGELOG.md+ java/*.java tasty/data/*.dhall tasty/data/*.json+ tasty/data/*.txt+ tasty/data/*.yaml + Source-Repository head Type: git Location: https://github.com/dhall-lang/dhall-haskell/tree/master/dhall-json@@ -43,10 +47,9 @@ aeson-pretty < 0.9 , bytestring < 0.11, containers ,- dhall >= 1.22.0 && < 1.25,+ dhall >= 1.25.0 && < 1.26, exceptions >= 0.8.3 && < 0.11,- lens >= 2.5 && < 4.18,- optparse-applicative >= 0.14.0.0 && < 0.15,+ optparse-applicative >= 0.14.0.0 && < 0.16, scientific >= 0.3.0.0 && < 0.4 , text >= 0.11.1.0 && < 1.3 , unordered-containers < 0.3 ,@@ -54,15 +57,20 @@ Exposed-Modules: Dhall.JSON Dhall.JSONToDhall- Dhall.Yaml + Dhall.Yaml+ Dhall.YamlToDhall+ Other-Modules:+ Dhall.JSON.Util++ GHC-Options: -Wall if flag(yaml-pre-0_11)- Build-Depends:- yaml >= 0.5.0 && < 0.11+ Build-Depends:+ yaml >= 0.5.0 && < 0.11 else- Build-Depends:- libyaml >= 0.1.1.0 && < 0.2 ,- yaml >= 0.11.0 && < 0.12+ Build-Depends:+ libyaml >= 0.1.1.0 && < 0.2 ,+ yaml >= 0.11.0 && < 0.12 Executable dhall-to-json Hs-Source-Dirs: dhall-to-json@@ -97,14 +105,17 @@ Hs-Source-Dirs: json-to-dhall Main-Is: Main.hs Build-Depends:- base ,- aeson ,- bytestring < 0.11 ,- dhall ,- dhall-json ,- exceptions >= 0.8.3 && < 0.11 ,- optparse-applicative ,- text < 1.3+ base ,+ aeson ,+ ansi-terminal >= 0.6.3.1 && < 0.10,+ bytestring < 0.11,+ dhall ,+ dhall-json ,+ exceptions >= 0.8.3 && < 0.11,+ optparse-applicative ,+ prettyprinter >= 1.2.0.1 && < 1.3 ,+ 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.* Other-Modules:@@ -115,14 +126,17 @@ Hs-Source-Dirs: yaml-to-dhall Main-Is: Main.hs Build-Depends:- base ,- aeson ,- bytestring < 0.11 ,- dhall ,- dhall-json ,- exceptions >= 0.8.3 && < 0.11 ,- optparse-applicative ,- text < 1.3+ base ,+ aeson ,+ ansi-terminal >= 0.6.3.1 && < 0.10,+ bytestring < 0.11 ,+ dhall ,+ dhall-json ,+ exceptions >= 0.8.3 && < 0.11 ,+ optparse-applicative ,+ prettyprinter >= 1.2.0.1 && < 1.3 ,+ 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.* Other-Modules:
dhall-to-json/Main.hs view
@@ -3,7 +3,7 @@ module Main where -import Control.Applicative ((<|>))+import Control.Applicative ((<|>), optional) import Control.Exception (SomeException) import Control.Monad (when) import Data.Aeson (Value)@@ -17,12 +17,13 @@ import qualified Data.Aeson.Encode.Pretty import qualified Data.ByteString.Char8 import qualified Data.ByteString.Lazy-import qualified Data.Text.IO+import qualified Data.Text as Text+import qualified Data.Text.IO as Text.IO import qualified Dhall import qualified Dhall.JSON import qualified GHC.IO.Encoding-import qualified Options.Applicative-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 @@ -33,6 +34,7 @@ , version :: Bool , conversion :: Conversion , approximateSpecialDoubles :: Bool+ , file :: Maybe FilePath } parseOptions :: Parser Options@@ -44,58 +46,66 @@ <*> parseVersion <*> Dhall.JSON.parseConversion <*> parseApproximateSpecialDoubles+ <*> optional parseFile where parseExplain =- Options.Applicative.switch- ( Options.Applicative.long "explain"- <> Options.Applicative.help "Explain error messages in detail"+ Options.switch+ ( Options.long "explain"+ <> Options.help "Explain error messages in detail" ) parsePretty = prettyFlag <|> compactFlag <|> defaultBehavior where prettyFlag =- Options.Applicative.flag'+ Options.flag' True- ( Options.Applicative.long "pretty"- <> Options.Applicative.help "Pretty print generated JSON"+ ( Options.long "pretty"+ <> Options.help "Pretty print generated JSON" ) compactFlag =- Options.Applicative.flag'+ Options.flag' False- ( Options.Applicative.long "compact"- <> Options.Applicative.help "Render JSON on one line"+ ( Options.long "compact"+ <> Options.help "Render JSON on one line" ) defaultBehavior = pure False parseVersion =- Options.Applicative.switch- ( Options.Applicative.long "version"- <> Options.Applicative.help "Display version"+ Options.switch+ ( Options.long "version"+ <> Options.help "Display version" ) parseApproximateSpecialDoubles =- Options.Applicative.switch- ( Options.Applicative.long "approximate-special-doubles"- <> Options.Applicative.help "Use approximate representation for NaN/±Infinity"+ Options.switch+ ( Options.long "approximate-special-doubles"+ <> Options.help "Use approximate representation for NaN/±Infinity" ) + parseFile =+ Options.strOption+ ( Options.long "file"+ <> Options.help "Read expression from a file instead of standard input"+ <> Options.metavar "FILE"+ )+ parserInfo :: ParserInfo Options parserInfo =- Options.Applicative.info- (Options.Applicative.helper <*> parseOptions)- ( Options.Applicative.fullDesc- <> Options.Applicative.progDesc "Compile Dhall to JSON"+ Options.info+ (Options.helper <*> parseOptions)+ ( Options.fullDesc+ <> Options.progDesc "Compile Dhall to JSON" ) main :: IO () main = do GHC.IO.Encoding.setLocaleEncoding GHC.IO.Encoding.utf8 - Options {..} <- Options.Applicative.execParser parserInfo+ Options {..} <- Options.execParser parserInfo when version $ do putStrLn (showVersion Meta.version)@@ -119,9 +129,15 @@ then ApproximateWithinJSON else ForbidWithinJSON - stdin <- Data.Text.IO.getContents+ text <- case file of+ Nothing -> Text.IO.getContents+ Just path -> Text.IO.readFile path - json <- omission <$> explaining (Dhall.JSON.codeToValue conversion specialDoubleMode "(stdin)" stdin)+ let path = case file of+ Nothing -> "(stdin)"+ Just p -> Text.pack p++ json <- omission <$> explaining (Dhall.JSON.codeToValue conversion specialDoubleMode path text) Data.ByteString.Char8.putStrLn $ Data.ByteString.Lazy.toStrict $ encode json
dhall-to-yaml/Main.hs view
@@ -1,33 +1,23 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}- module Main where +import Control.Applicative (optional) import Control.Exception (SomeException)-import Data.Aeson (Value) import Data.Monoid ((<>))-import Dhall.JSON (Conversion, SpecialDoubleMode(..))+import Dhall.JSON (parseOmission, parseConversion)+import Dhall.Yaml (Options(..), dhallToYaml, parseDocuments, parseQuoted) import Options.Applicative (Parser, ParserInfo) import qualified Control.Exception import qualified Data.ByteString-import qualified Data.Text.IO-import qualified Dhall-import qualified Dhall.JSON-import qualified Dhall.Yaml+import qualified Data.Text as Text+import qualified Data.Text.IO as Text.IO import qualified GHC.IO.Encoding-import qualified Options.Applicative+import qualified Options.Applicative as Options import qualified System.Exit import qualified System.IO -data Options = Options- { explain :: Bool- , omission :: Value -> Value- , documents :: Bool- , quoted :: Bool- , conversion :: Conversion- }- parseOptions :: Parser Options parseOptions = Options@@ -36,49 +26,45 @@ <*> parseDocuments <*> parseQuoted <*> Dhall.JSON.parseConversion+ <*> optional parseFile where parseExplain =- Options.Applicative.switch- ( Options.Applicative.long "explain"- <> Options.Applicative.help "Explain error messages in detail"- )-- parseDocuments =- Options.Applicative.switch- ( Options.Applicative.long "documents"- <> Options.Applicative.help "If given a Dhall list, output a document for every element"+ Options.switch+ ( Options.long "explain"+ <> Options.help "Explain error messages in detail" ) - parseQuoted =- Options.Applicative.switch- ( Options.Applicative.long "quoted"- <> Options.Applicative.help "Prevent from generating not quoted scalars"+ parseFile =+ Options.strOption+ ( Options.long "file"+ <> Options.help "Read expression from a file instead of standard input"+ <> Options.metavar "FILE" ) parserInfo :: ParserInfo Options parserInfo =- Options.Applicative.info- (Options.Applicative.helper <*> parseOptions)- ( Options.Applicative.fullDesc- <> Options.Applicative.progDesc "Compile Dhall to YAML"+ Options.info+ (Options.helper <*> parseOptions)+ ( Options.fullDesc+ <> Options.progDesc "Compile Dhall to YAML" ) main :: IO () main = do GHC.IO.Encoding.setLocaleEncoding GHC.IO.Encoding.utf8 - Options {..} <- Options.Applicative.execParser parserInfo+ options@Options {..} <- Options.execParser parserInfo handle $ do- let explaining = if explain then Dhall.detailed else id-- stdin <- Data.Text.IO.getContents-- json <- omission <$> explaining (Dhall.JSON.codeToValue conversion UseYAMLEncoding "(stdin)" stdin)+ contents <- case file of+ Nothing -> Text.IO.getContents+ Just path -> Text.IO.readFile path - let yaml = Dhall.Yaml.jsonToYaml json documents quoted+ let path = case file of+ Nothing -> "(stdin)"+ Just p -> Text.pack p - Data.ByteString.putStr yaml+ Data.ByteString.putStr =<< dhallToYaml options path contents handle :: IO a -> IO a handle = Control.Exception.handle handler
+ java/Utils.java view
@@ -0,0 +1,23 @@+import java.io.IOException;++import com.fasterxml.jackson.core.JsonProcessingException;+import com.fasterxml.jackson.databind.JsonNode;+import com.fasterxml.jackson.databind.ObjectMapper;+import com.fasterxml.jackson.dataformat.yaml.YAMLMapper;++public class Utils {++ public static String jsonToYaml (String jsonString) throws+ JsonProcessingException, IOException {+ JsonNode jsonNodeTree = new ObjectMapper().readTree(jsonString);+ String jsonAsYaml = new YAMLMapper().writeValueAsString(jsonNodeTree);+ return jsonAsYaml;+ }++ public static String yamlToJson (String yamlString) throws+ JsonProcessingException, IOException {+ JsonNode jsonNodeTree = new YAMLMapper().readTree(yamlString);+ String yamlAsJson = new ObjectMapper().writeValueAsString(jsonNodeTree);+ return yamlAsJson;+ }+}
json-to-dhall/Main.hs view
@@ -8,25 +8,29 @@ module Main where +import Control.Applicative (optional)+import Control.Exception (SomeException, throwIO)+import Control.Monad (when)+import Data.Monoid ((<>))+import Data.Text (Text)+import Data.Version (showVersion)+import Dhall.JSONToDhall+import Dhall.Pretty (CharacterSet(..))+import Options.Applicative (Parser, ParserInfo)+ import qualified Control.Exception-import Control.Exception (SomeException, throwIO)-import Control.Monad (when)-import qualified Data.Aeson as A-import qualified Data.ByteString.Lazy.Char8 as BSL8-import Data.Monoid ((<>))-import Data.Text (Text)-import qualified Data.Text.IO as Text-import Data.Version (showVersion)+import qualified 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 GHC.IO.Encoding-import qualified Options.Applicative as O-import Options.Applicative (Parser, ParserInfo)+import qualified Options.Applicative as Options+import qualified System.Console.ANSI as ANSI import qualified System.Exit-import qualified System.IO--import qualified Dhall.Core as D-import Dhall.JSONToDhall--import qualified Paths_dhall_json as Meta+import qualified System.IO as IO+import qualified Dhall.Pretty+import qualified Paths_dhall_json as Meta -- --------------- -- Command options@@ -34,10 +38,10 @@ -- | Command info and description parserInfo :: ParserInfo Options-parserInfo = O.info- ( O.helper <*> parseOptions)- ( O.fullDesc- <> O.progDesc "Populate Dhall value given its Dhall type (schema) from a JSON expression"+parserInfo = Options.info+ ( Options.helper <*> parseOptions)+ ( Options.fullDesc+ <> Options.progDesc "Convert a JSON expression to a Dhall expression, given the expected Dhall type" ) -- | All the command arguments and options@@ -45,6 +49,9 @@ { version :: Bool , schema :: Text , conversion :: Conversion+ , file :: Maybe FilePath+ , ascii :: Bool+ , plain :: Bool } deriving Show -- | Parser for all the command arguments and options@@ -52,17 +59,42 @@ parseOptions = Options <$> parseVersion <*> parseSchema <*> parseConversion+ <*> optional parseFile+ <*> parseASCII+ <*> parsePlain where- parseSchema = O.strArgument- ( O.metavar "SCHEMA"- <> O.help "Dhall type expression (schema)"- )- parseVersion = O.switch- ( O.long "version"- <> O.short 'V'- <> O.help "Display version"- )+ parseSchema =+ Options.strArgument+ ( Options.metavar "SCHEMA"+ <> Options.help "Dhall type expression (schema)"+ ) + parseVersion =+ Options.switch+ ( Options.long "version"+ <> Options.short 'V'+ <> Options.help "Display version"+ )++ parseFile =+ Options.strOption+ ( Options.long "file"+ <> Options.help "Read JSON from a file instead of standard input"+ <> Options.metavar "FILE"+ )++ parseASCII =+ Options.switch+ ( Options.long "ascii"+ <> Options.help "Format code using only ASCII syntax"+ )++ parsePlain =+ Options.switch+ ( Options.long "plain"+ <> Options.help "Disable syntax highlighting"+ )+ -- ---------- -- Main -- ----------@@ -71,29 +103,51 @@ main = do GHC.IO.Encoding.setLocaleEncoding GHC.IO.Encoding.utf8 - Options {..} <- O.execParser parserInfo+ Options {..} <- Options.execParser parserInfo + let characterSet = case ascii of+ True -> ASCII+ False -> Unicode+ when version $ do putStrLn (showVersion Meta.version) System.Exit.exitSuccess handle $ do- stdin <- BSL8.getContents- value :: A.Value <- case A.eitherDecode stdin of+ bytes <- case file of+ Nothing -> ByteString.getContents+ Just path -> ByteString.readFile path++ value :: Aeson.Value <- case Aeson.eitherDecode bytes of Left err -> throwIO (userError err) Right v -> pure v expr <- typeCheckSchemaExpr id =<< resolveSchemaExpr schema - case dhallFromJSON conversion expr value of- Left err -> throwIO err- Right res -> Text.putStr (D.pretty res)+ result <- case dhallFromJSON conversion expr value of+ Left err -> throwIO err+ Right result -> return result + let document = Dhall.Pretty.prettyCharacterSet characterSet result++ let stream = Pretty.layoutSmart Dhall.Pretty.layoutOpts document++ supportsANSI <- ANSI.hSupportsANSI IO.stdout++ let ansiStream =+ if supportsANSI && not plain+ then fmap Dhall.Pretty.annToAnsiStyle stream+ else Pretty.unAnnotateS stream++ Pretty.Terminal.renderIO IO.stdout ansiStream++ Text.IO.putStrLn ""+ handle :: IO a -> IO a handle = Control.Exception.handle handler where handler :: SomeException -> IO a handler e = do- System.IO.hPutStrLn System.IO.stderr ""- System.IO.hPrint System.IO.stderr e+ IO.hPutStrLn IO.stderr ""+ IO.hPrint IO.stderr e System.Exit.exitFailure
src/Dhall/JSON.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-| This library only exports a single `dhallToJSON` function for translating a@@ -53,15 +54,15 @@ Dhall @List@s translate to JSON lists: -> $ dhall-to-json <<< '[1, 2, 3] : List Integer'+> $ dhall-to-json <<< '[1, 2, 3] : List Natural' > [1,2,3] Dhall @Optional@ values translate to @null@ if absent and the unwrapped value otherwise: -> $ dhall-to-json <<< '[] : Optional Integer'+> $ dhall-to-json <<< 'None Natural' > null-> $ dhall-to-json <<< '[1] : Optional Integer'+> $ dhall-to-json <<< 'Some 1' > 1 Dhall records translate to JSON records:@@ -74,7 +75,7 @@ > $ dhall-to-json <<< "< Left = +2 | Right : Natural>" > 2 > $ cat config-> [ < Person = { age = +47, name = "John" }+> [ < Person = { age = 47, name = "John" } > | Place : { location : Text } > > > , < Place = { location = "North Pole" }@@ -83,7 +84,7 @@ > , < Place = { location = "Sahara Desert" } > | Person : { age : Natural, name : Text } > >-> , < Person = { age = +35, name = "Alice" }+> , < Person = { age = 35, name = "Alice" } > | Place : { location : Text } > > > ]@@ -104,17 +105,13 @@ contains a record then the name of the alternative is stored inline within the same record. For example, this code: -> let Example = < Left : { foo : Natural } | Right : { bar : Bool } >-> -> in let example = constructors Example-> -> in let Nesting = < Inline : {} | Nested : Text >+> let Example = < Left : { foo : Natural } | Right : { bar : Bool } > > -> in let nesting = constructors Nesting+> let Nesting = < Inline : {} | Nested : Text > > > in { field = "name"-> , nesting = nesting.Inline {=}-> , contents = example.Left { foo = 2 }+> , nesting = Nesting.Inline {=}+> , contents = Example.Left { foo = 2 } > } ... produces this JSON:@@ -127,17 +124,13 @@ If @nesting@ is set to @Nested nestedField@ then the union is store underneath a field named @nestedField@. For example, this code: -> let Example = < Left : { foo : Natural } | Right : { bar : Bool } >-> -> in let example = constructors Example-> -> in let Nesting = < Inline : {} | Nested : Text >+> let Example = < Left : { foo : Natural } | Right : { bar : Bool } > > -> in let nesting = constructors Nesting+> let Nesting = < Inline : {} | Nested : Text > > > in { field = "name"-> , nesting = nesting.Nested "value"-> , contents = example.Left { foo = 2 }+> , nesting = Nesting.Nested "value"+> , contents = Example.Left { foo = 2 } > } ... produces this JSON:@@ -149,6 +142,24 @@ > } > } + You can also translate Dhall expressions encoding weakly-typed JSON+ (see: <https://prelude.dhall-lang.org/JSON/Type>):++> $ cat ./example.dhall+> let JSON = https://prelude.dhall-lang.org/JSON/package.dhall+> +> in JSON.object+> [ { mapKey = "foo", mapValue = JSON.null }+> , { mapKey =+> "bar"+> , mapValue =+> JSON.array [ JSON.number 1.0, JSON.bool True ]+> }+> ]++> $ dhall-to-json <<< './example.dhall'+> {"foo":null,"bar":[1,true]}+ Also, all Dhall expressions are normalized before translation to JSON: > $ dhall-to-json <<< "True == False"@@ -182,17 +193,20 @@ import Dhall.Core (Expr) import Dhall.TypeCheck (X) import Dhall.Map (Map)+import Dhall.JSON.Util (pattern V) import Options.Applicative (Parser) -import qualified Control.Lens-import qualified Data.Foldable-import qualified Data.HashMap.Strict+import qualified Data.Aeson as Aeson+import qualified Data.Foldable as Foldable+import qualified Data.HashMap.Strict as HashMap import qualified Data.List import qualified Data.Ord import qualified Data.Text-import qualified Dhall.Core+import qualified Data.Vector as Vector+import qualified Dhall.Core as Core import qualified Dhall.Import import qualified Dhall.Map+import qualified Dhall.Optics import qualified Dhall.Parser import qualified Dhall.TypeCheck import qualified Options.Applicative@@ -263,7 +277,7 @@ \ \n\ \↳ " <> txt <> " " where- txt = Dhall.Core.pretty e+ txt = Core.pretty e _ERROR :: Data.Text.Text _ERROR = "\ESC[1;31mError\ESC[0m"@@ -274,58 +288,66 @@ >>> :set -XOverloadedStrings >>> :set -XOverloadedLists->>> import Dhall.Core+>>> import Core >>> dhallToJSON (RecordLit [("foo", IntegerLit 1), ("bar", TextLit "ABC")]) Right (Object (fromList [("foo",Number 1.0),("bar",String "ABC")]))->>> fmap Data.Aeson.encode it+>>> fmap Aeson.encode it Right "{\"foo\":1,\"bar\":\"ABC\"}" -} dhallToJSON :: Expr s X -> Either CompileError Value-dhallToJSON e0 = loop (Dhall.Core.normalize e0)+dhallToJSON e0 = loop (Core.alphaNormalize (Core.normalize e0)) where loop e = case e of - Dhall.Core.BoolLit a -> return (toJSON a)- Dhall.Core.NaturalLit a -> return (toJSON a)- Dhall.Core.IntegerLit a -> return (toJSON a)- Dhall.Core.DoubleLit a -> return (toJSON a)- Dhall.Core.TextLit (Dhall.Core.Chunks [] a) -> do+ Core.BoolLit a -> return (toJSON a)+ Core.NaturalLit a -> return (toJSON a)+ Core.IntegerLit a -> return (toJSON a)+ Core.DoubleLit a -> return (toJSON a)+ Core.TextLit (Core.Chunks [] a) -> do return (toJSON a)- Dhall.Core.ListLit _ a -> do- a' <- traverse loop a- return (toJSON a')- Dhall.Core.OptionalLit _ a -> do+ Core.ListLit _ a -> do a' <- traverse loop a return (toJSON a')- Dhall.Core.Some a -> do+ Core.Some a -> do a' <- loop a return (toJSON a')- Dhall.Core.App Dhall.Core.None _ -> do- return Data.Aeson.Null+ Core.App Core.None _ -> do+ return Aeson.Null -- Provide a nicer error message for a common user mistake. -- -- See: https://github.com/dhall-lang/dhall-lang/issues/492- Dhall.Core.None -> do+ Core.None -> do Left BareNone- Dhall.Core.RecordLit a ->+ Core.RecordLit a -> case toOrderedList a of [ ( "contents"- , Dhall.Core.UnionLit alternativeName contents _+ , Core.App+ (Core.Field+ _+ alternativeName+ )+ contents ) , ( "field"- , Dhall.Core.TextLit- (Dhall.Core.Chunks [] field)+ , Core.TextLit+ (Core.Chunks [] field) ) , ( "nesting"- , Dhall.Core.UnionLit- "Nested"- (Dhall.Core.TextLit- (Dhall.Core.Chunks [] nestedField)+ , Core.App+ (Core.Field+ (Core.Union+ [ ("Inline", mInlineType)+ , ("Nested", Just Core.Text)+ ]+ )+ "Nested" )- [ ("Inline", Just (Dhall.Core.Record [])) ]+ (Core.TextLit+ (Core.Chunks [] nestedField)+ ) )- ] -> do+ ] | all (== Core.Record []) mInlineType -> do contents' <- loop contents let taggedValue =@@ -338,45 +360,104 @@ ) ] - return (Data.Aeson.toJSON ( Dhall.Map.toMap taggedValue ))+ return (Aeson.toJSON ( Dhall.Map.toMap taggedValue )) [ ( "contents"- , Dhall.Core.UnionLit- alternativeName- (Dhall.Core.RecordLit contents)- _+ , Core.App+ (Core.Field+ _+ alternativeName+ )+ (Core.RecordLit contents) ) , ( "field"- , Dhall.Core.TextLit- (Dhall.Core.Chunks [] field)+ , Core.TextLit+ (Core.Chunks [] field) ) , ( "nesting"- , Dhall.Core.UnionLit- "Inline"- (Dhall.Core.RecordLit [])- [ ("Nested", Just Dhall.Core.Text) ]+ , nesting )- ] -> do+ ] | isInlineNesting nesting -> do let contents' = Dhall.Map.insert field- (Dhall.Core.TextLit- (Dhall.Core.Chunks+ (Core.TextLit+ (Core.Chunks [] alternativeName ) ) contents - loop (Dhall.Core.RecordLit contents')+ loop (Core.RecordLit contents') _ -> do a' <- traverse loop a- return (Data.Aeson.toJSON (Dhall.Map.toMap a'))- Dhall.Core.UnionLit _ b _ -> loop b- Dhall.Core.App (Dhall.Core.Field (Dhall.Core.Union _) _) b -> loop b- Dhall.Core.Field (Dhall.Core.Union _) k -> return (toJSON k)+ return (Aeson.toJSON (Dhall.Map.toMap a'))+ Core.UnionLit _ b _ -> loop b+ 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.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))+ ]+ )+ value+ ) -> do+ let outer (Core.Field (V 0) "null") = do+ return Aeson.Null+ outer (Core.App (Core.Field (V 0) "bool") (Core.BoolLit b)) = do+ return (Aeson.Bool b)+ outer (Core.App (Core.Field (V 0) "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+ mapValue <- outer mapExpression++ return (mapKey, mapValue)+ inner _ = Left (Unsupported e)++ ys <- traverse inner (Foldable.toList xs)++ return (Aeson.Object (HashMap.fromList ys))+ outer (Core.App (Core.Field (V 0) "number") (Core.DoubleLit n)) = do+ return (Aeson.toJSON n)+ outer (Core.App (Core.Field (V 0) "string") (Core.TextLit (Core.Chunks [] text))) = do+ return (toJSON text)+ outer _ = Left (Unsupported e)++ outer value _ -> Left (Unsupported e) +isInlineNesting :: Expr s X -> Bool+isInlineNesting (Core.App+ (Core.Field+ (Core.Union+ [ ("Inline", Just (Core.Record []))+ , ("Nested", Just Core.Text)+ ]+ )+ "Inline"+ )+ (Core.RecordLit [])+ ) = True+isInlineNesting (Core.Field+ (Core.Union+ [ ("Inline", Nothing)+ , ("Nested", Just Core.Text)+ ]+ )+ "Inline"+ ) = True+isInlineNesting _ = False+ toOrderedList :: Ord k => Map k v -> [(k, v)] toOrderedList = Data.List.sortBy (Data.Ord.comparing fst)@@ -386,7 +467,7 @@ omitNull :: Value -> Value omitNull (Object object) = Object fields where- fields =Data.HashMap.Strict.filter (/= Null) (fmap omitNull object)+ fields =HashMap.filter (/= Null) (fmap omitNull object) omitNull (Array array) = Array (fmap omitNull array) omitNull (String string) =@@ -405,7 +486,7 @@ omitEmpty (Object object) = if null fields then Null else Object fields where- fields = Data.HashMap.Strict.filter (/= Null) (fmap omitEmpty object)+ fields = HashMap.filter (/= Null) (fmap omitEmpty object) omitEmpty (Array array) = if null elems then Null else Array elems where@@ -453,37 +534,39 @@ -} convertToHomogeneousMaps :: Conversion -> Expr s X -> Expr s X convertToHomogeneousMaps NoConversion e0 = e0-convertToHomogeneousMaps (Conversion {..}) e0 = loop (Dhall.Core.normalize e0)+convertToHomogeneousMaps (Conversion {..}) e0 = loop (Core.normalize e0) where loop e = case e of- Dhall.Core.Const a ->- Dhall.Core.Const a+ Core.Const a ->+ Core.Const a - Dhall.Core.Var v ->- Dhall.Core.Var v+ Core.Var v ->+ Core.Var v - Dhall.Core.Lam a b c ->- Dhall.Core.Lam a b' c'- where- b' = loop b- c' = loop c+ {- Minor hack: Don't descend into lambda, since the only thing it can+ possibly encode is a Boehm-Berarducci-encoded JSON value. In such a+ 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 - Dhall.Core.Pi a b c ->- Dhall.Core.Pi a b' c'+ Core.Pi a b c ->+ Core.Pi a b' c' where b' = loop b c' = loop c - Dhall.Core.App a b ->- Dhall.Core.App a' b'+ Core.App a b ->+ Core.App a' b' where a' = loop a b' = loop b - Dhall.Core.Let as b ->- Dhall.Core.Let as' b'+ Core.Let as b ->+ Core.Let as' b' where- f (Dhall.Core.Binding x y z) = Dhall.Core.Binding x y' z'+ f (Core.Binding x y z) = Core.Binding x y' z' where y' = fmap loop y z' = loop z@@ -492,147 +575,150 @@ b' = loop b - Dhall.Core.Annot a b ->- Dhall.Core.Annot a' b'+ Core.Annot a b ->+ Core.Annot a' b' where a' = loop a b' = loop b - Dhall.Core.Bool ->- Dhall.Core.Bool+ Core.Bool ->+ Core.Bool - Dhall.Core.BoolLit a ->- Dhall.Core.BoolLit a+ Core.BoolLit a ->+ Core.BoolLit a - Dhall.Core.BoolAnd a b ->- Dhall.Core.BoolAnd a' b'+ Core.BoolAnd a b ->+ Core.BoolAnd a' b' where a' = loop a b' = loop b - Dhall.Core.BoolOr a b ->- Dhall.Core.BoolOr a' b'+ Core.BoolOr a b ->+ Core.BoolOr a' b' where a' = loop a b' = loop b - Dhall.Core.BoolEQ a b ->- Dhall.Core.BoolEQ a' b'+ Core.BoolEQ a b ->+ Core.BoolEQ a' b' where a' = loop a b' = loop b - Dhall.Core.BoolNE a b ->- Dhall.Core.BoolNE a' b'+ Core.BoolNE a b ->+ Core.BoolNE a' b' where a' = loop a b' = loop b - Dhall.Core.BoolIf a b c ->- Dhall.Core.BoolIf a' b' c'+ Core.BoolIf a b c ->+ Core.BoolIf a' b' c' where a' = loop a b' = loop b c' = loop c - Dhall.Core.Natural ->- Dhall.Core.Natural+ Core.Natural ->+ Core.Natural - Dhall.Core.NaturalLit a ->- Dhall.Core.NaturalLit a+ Core.NaturalLit a ->+ Core.NaturalLit a - Dhall.Core.NaturalFold ->- Dhall.Core.NaturalFold+ Core.NaturalFold ->+ Core.NaturalFold - Dhall.Core.NaturalBuild ->- Dhall.Core.NaturalBuild+ Core.NaturalBuild ->+ Core.NaturalBuild - Dhall.Core.NaturalIsZero ->- Dhall.Core.NaturalIsZero+ Core.NaturalIsZero ->+ Core.NaturalIsZero - Dhall.Core.NaturalEven ->- Dhall.Core.NaturalEven+ Core.NaturalEven ->+ Core.NaturalEven - Dhall.Core.NaturalOdd ->- Dhall.Core.NaturalOdd+ Core.NaturalOdd ->+ Core.NaturalOdd - Dhall.Core.NaturalToInteger ->- Dhall.Core.NaturalToInteger+ Core.NaturalToInteger ->+ Core.NaturalToInteger - Dhall.Core.NaturalShow ->- Dhall.Core.NaturalShow+ Core.NaturalShow ->+ Core.NaturalShow - Dhall.Core.NaturalPlus a b ->- Dhall.Core.NaturalPlus a' b'+ Core.NaturalPlus a b ->+ Core.NaturalPlus a' b' where a' = loop a b' = loop b - Dhall.Core.NaturalTimes a b ->- Dhall.Core.NaturalTimes a' b'+ Core.NaturalTimes a b ->+ Core.NaturalTimes a' b' where a' = loop a b' = loop b - Dhall.Core.Integer ->- Dhall.Core.Integer+ Core.Integer ->+ Core.Integer - Dhall.Core.IntegerLit a ->- Dhall.Core.IntegerLit a+ Core.IntegerLit a ->+ Core.IntegerLit a - Dhall.Core.IntegerShow ->- Dhall.Core.IntegerShow+ Core.IntegerShow ->+ Core.IntegerShow - Dhall.Core.IntegerToDouble ->- Dhall.Core.IntegerToDouble+ Core.IntegerToDouble ->+ Core.IntegerToDouble - Dhall.Core.Double ->- Dhall.Core.Double+ Core.Double ->+ Core.Double - Dhall.Core.DoubleLit a ->- Dhall.Core.DoubleLit a+ Core.DoubleLit a ->+ Core.DoubleLit a - Dhall.Core.DoubleShow ->- Dhall.Core.DoubleShow+ Core.DoubleShow ->+ Core.DoubleShow - Dhall.Core.Text ->- Dhall.Core.Text+ Core.Text ->+ Core.Text - Dhall.Core.TextLit (Dhall.Core.Chunks a b) ->- Dhall.Core.TextLit (Dhall.Core.Chunks a' b)+ Core.TextLit (Core.Chunks a b) ->+ Core.TextLit (Core.Chunks a' b) where a' = fmap (fmap loop) a - Dhall.Core.TextAppend a b ->- Dhall.Core.TextAppend a' b'+ Core.TextAppend a b ->+ Core.TextAppend a' b' where a' = loop a b' = loop b - Dhall.Core.TextShow ->- Dhall.Core.TextShow+ Core.TextShow ->+ Core.TextShow - Dhall.Core.List ->- Dhall.Core.List+ Core.List ->+ Core.List - Dhall.Core.ListLit a b ->+ Core.ListLit a b -> case transform of Just c -> loop c- Nothing -> Dhall.Core.ListLit a' b'+ Nothing -> Core.ListLit a' b' where- elements = Data.Foldable.toList b+ elements = Foldable.toList b toKeyValue :: Expr s X -> Maybe (Text, Expr s X)- toKeyValue (Dhall.Core.RecordLit m) = do- guard (Data.Foldable.length m == 2)+ toKeyValue (Core.RecordLit m) = do+ guard (Foldable.length m == 2) key <- Dhall.Map.lookup mapKey m value <- Dhall.Map.lookup mapValue m keyText <- case key of- Dhall.Core.TextLit (Dhall.Core.Chunks [] keyText) ->+ Core.TextLit (Core.Chunks [] keyText) -> return keyText + Core.Field (Core.Union _) keyText ->+ return keyText+ _ -> empty @@ -644,11 +730,11 @@ case elements of [] -> case a of- Just (Dhall.Core.Record m) -> do- guard (Data.Foldable.length m == 2)+ Just (Core.Record m) -> do+ guard (Foldable.length m == 2) guard (Dhall.Map.member mapKey m) guard (Dhall.Map.member mapValue m)- return (Dhall.Core.RecordLit mempty)+ return (Core.RecordLit mempty) _ -> do empty @@ -658,130 +744,130 @@ let recordLiteral = Dhall.Map.fromList keyValues - return (Dhall.Core.RecordLit recordLiteral)+ return (Core.RecordLit recordLiteral) a' = fmap loop a b' = fmap loop b - Dhall.Core.ListAppend a b ->- Dhall.Core.ListAppend a' b'+ Core.ListAppend a b ->+ Core.ListAppend a' b' where a' = loop a b' = loop b - Dhall.Core.ListBuild ->- Dhall.Core.ListBuild-- Dhall.Core.ListFold ->- Dhall.Core.ListFold+ Core.ListBuild ->+ Core.ListBuild - Dhall.Core.ListLength ->- Dhall.Core.ListLength+ Core.ListFold ->+ Core.ListFold - Dhall.Core.ListHead ->- Dhall.Core.ListHead+ Core.ListLength ->+ Core.ListLength - Dhall.Core.ListLast ->- Dhall.Core.ListLast+ Core.ListHead ->+ Core.ListHead - Dhall.Core.ListIndexed ->- Dhall.Core.ListIndexed+ Core.ListLast ->+ Core.ListLast - Dhall.Core.ListReverse ->- Dhall.Core.ListReverse+ Core.ListIndexed ->+ Core.ListIndexed - Dhall.Core.Optional ->- Dhall.Core.Optional+ Core.ListReverse ->+ Core.ListReverse - Dhall.Core.OptionalLit a b ->- Dhall.Core.OptionalLit a' b'- where- a' = loop a- b' = fmap loop b+ Core.Optional ->+ Core.Optional - Dhall.Core.Some a ->- Dhall.Core.Some a'+ Core.Some a ->+ Core.Some a' where a' = loop a - Dhall.Core.None ->- Dhall.Core.None+ Core.None ->+ Core.None - Dhall.Core.OptionalFold ->- Dhall.Core.OptionalFold+ Core.OptionalFold ->+ Core.OptionalFold - Dhall.Core.OptionalBuild ->- Dhall.Core.OptionalBuild+ Core.OptionalBuild ->+ Core.OptionalBuild - Dhall.Core.Record a ->- Dhall.Core.Record a'+ Core.Record a ->+ Core.Record a' where a' = fmap loop a - Dhall.Core.RecordLit a ->- Dhall.Core.RecordLit a'+ Core.RecordLit a ->+ Core.RecordLit a' where a' = fmap loop a - Dhall.Core.Union a ->- Dhall.Core.Union a'+ Core.Union a ->+ Core.Union a' where a' = fmap (fmap loop) a - Dhall.Core.UnionLit a b c ->- Dhall.Core.UnionLit a b' c'+ Core.UnionLit a b c ->+ Core.UnionLit a b' c' where b' = loop b c' = fmap (fmap loop) c - Dhall.Core.Combine a b ->- Dhall.Core.Combine a' b'+ Core.Combine a b ->+ Core.Combine a' b' where a' = loop a b' = loop b - Dhall.Core.CombineTypes a b ->- Dhall.Core.CombineTypes a' b'+ Core.CombineTypes a b ->+ Core.CombineTypes a' b' where a' = loop a b' = loop b - Dhall.Core.Prefer a b ->- Dhall.Core.Prefer a' b'+ Core.Prefer a b ->+ Core.Prefer a' b' where a' = loop a b' = loop b - Dhall.Core.Merge a b c ->- Dhall.Core.Merge a' b' c'+ Core.Merge a b c ->+ Core.Merge a' b' c' where a' = loop a b' = loop b c' = fmap loop c - Dhall.Core.Field a b ->- Dhall.Core.Field a' b+ Core.ToMap a b ->+ Core.ToMap a' b' where+ a' = loop a+ b' = fmap loop b++ Core.Field a b ->+ Core.Field a' b+ where a' = loop a - Dhall.Core.Project a b ->- Dhall.Core.Project a' b+ Core.Project a b ->+ Core.Project a' b where a' = loop a - Dhall.Core.ImportAlt a b ->- Dhall.Core.ImportAlt a' b'+ Core.ImportAlt a b ->+ Core.ImportAlt a' b' where a' = loop a b' = loop b - Dhall.Core.Note a b ->- Dhall.Core.Note a b'+ Core.Note a b ->+ Core.Note a b' where b' = loop b - Dhall.Core.Embed a ->- Dhall.Core.Embed a+ Core.Embed a ->+ Core.Embed a -- | Parser for command-line options related to homogeneous map support parseConversion :: Parser Conversion@@ -831,7 +917,7 @@ handleSpecialDoubles :: SpecialDoubleMode -> Expr s X -> Either CompileError (Expr s X) handleSpecialDoubles specialDoubleMode =- Control.Lens.rewriteMOf Dhall.Core.subExpressions rewrite+ Dhall.Optics.rewriteMOf Core.subExpressions rewrite where rewrite = case specialDoubleMode of@@ -839,27 +925,27 @@ ForbidWithinJSON -> forbidWithinJSON ApproximateWithinJSON -> approximateWithinJSON - useYAMLEncoding (Dhall.Core.DoubleLit n)+ useYAMLEncoding (Core.DoubleLit n) | isInfinite n && 0 < n =- return (Just (Dhall.Core.TextLit (Dhall.Core.Chunks [] "inf")))+ return (Just (Core.TextLit (Core.Chunks [] "inf"))) | isInfinite n && n < 0 =- return (Just (Dhall.Core.TextLit (Dhall.Core.Chunks [] "-inf")))+ return (Just (Core.TextLit (Core.Chunks [] "-inf"))) | isNaN n =- return (Just (Dhall.Core.TextLit (Dhall.Core.Chunks [] "nan")))+ return (Just (Core.TextLit (Core.Chunks [] "nan"))) useYAMLEncoding _ = return Nothing - forbidWithinJSON (Dhall.Core.DoubleLit n)+ forbidWithinJSON (Core.DoubleLit n) | isInfinite n || isNaN n = Left (SpecialDouble n) forbidWithinJSON _ = return Nothing - approximateWithinJSON (Dhall.Core.DoubleLit n)+ approximateWithinJSON (Core.DoubleLit n) | isInfinite n && n > 0 =- return (Just (Dhall.Core.DoubleLit ( 1.7976931348623157e308 :: Double)))+ return (Just (Core.DoubleLit ( 1.7976931348623157e308 :: Double))) | isInfinite n && n < 0 =- return (Just (Dhall.Core.DoubleLit (-1.7976931348623157e308 :: Double)))+ return (Just (Core.DoubleLit (-1.7976931348623157e308 :: Double))) -- Do nothing for @NaN@, which already encodes to @null@ approximateWithinJSON _ = return Nothing@@ -867,7 +953,7 @@ {-| Convert a piece of Text carrying a Dhall inscription to an equivalent JSON Value >>> :set -XOverloadedStrings->>> import Dhall.Core+>>> import Core >>> Dhall.JSON.codeToValue "(stdin)" "{ a = 1 }" >>> Object (fromList [("a",Number 1.0)]) -}@@ -878,16 +964,16 @@ -> Text -- ^ Input text. -> IO Value codeToValue conversion specialDoubleMode name code = do- parsedExpression <- Dhall.Core.throws (Dhall.Parser.exprFromText (Data.Text.unpack name) code)+ parsedExpression <- Core.throws (Dhall.Parser.exprFromText (Data.Text.unpack name) code) resolvedExpression <- Dhall.Import.load parsedExpression - _ <- Dhall.Core.throws (Dhall.TypeCheck.typeOf resolvedExpression)+ _ <- Core.throws (Dhall.TypeCheck.typeOf resolvedExpression) let convertedExpression = convertToHomogeneousMaps conversion resolvedExpression - specialDoubleExpression <- Dhall.Core.throws (handleSpecialDoubles specialDoubleMode convertedExpression)+ specialDoubleExpression <- Core.throws (handleSpecialDoubles specialDoubleMode convertedExpression) case dhallToJSON specialDoubleExpression of Left err -> Control.Exception.throwIO err
+ src/Dhall/JSON/Util.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}++module Dhall.JSON.Util+ ( pattern V+ ) where++import Dhall.Core (Expr)++import qualified Dhall.Core as Core++pattern V :: Int -> Expr s a+pattern V n = Core.Var (Core.V "_" n)
src/Dhall/JSONToDhall.hs view
@@ -4,6 +4,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-| Convert JSON data to Dhall given a Dhall /type/ expression necessary to make the translation unambiguous.@@ -25,6 +27,10 @@ * unions * records + 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.+ 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@@ -96,6 +102,11 @@ > $ json-to-dhall 'List { mapKey : Text, mapValue : Text }' <<< '{"foo": "bar"}' > [ { mapKey = "foo", mapValue = "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}'+> [ { 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): > $ json-to-dhall --no-keyval-maps 'List { mapKey : Text, mapValue : Text }' <<< '{"foo": "bar"}'@@ -141,6 +152,53 @@ < Left : Text | Middle : Text | Right : Integer >.Left "bar" > -------- < Left : Text | Middle : Text | Right : Integer >.Middle "bar"++== Weakly-typed JSON++If you don't know the JSON's schema in advance, you can decode into the most+general schema possible:++> $ cat ./schema.dhall+> https://prelude.dhall-lang.org/JSON/Type++> $ json-to-dhall ./schema.dhall <<< '[ { "foo": null, "bar": [ 1.0, true ] } ]'+> λ(JSON : Type)+> → λ(string : Text → JSON)+> → λ(number : Double → JSON)+> → λ(object : List { mapKey : Text, mapValue : JSON } → JSON)+> → λ(array : List JSON → JSON)+> → λ(bool : Bool → JSON)+> → λ(null : JSON)+> → array+> [ object+> [ { mapKey = "foo", mapValue = null }+> , { mapKey = "bar", mapValue = array [ number 1.0, bool True ] }+> ]+> ]++You can also mix and match JSON fields whose schemas are known or unknown:++> $ cat ./mixed.dhall+> List+> { foo : Optional Natural+> , bar : https://prelude.dhall-lang.org/JSON/Type+> }++> $ json-to-dhall ./mixed.dhall <<< '[ { "foo": null, "bar": [ 1.0, true ] } ]'+> [ { bar =+> λ(JSON : Type)+> → λ(string : Text → JSON)+> → λ(number : Double → JSON)+> → λ(object : List { mapKey : Text, mapValue : JSON } → JSON)+> → λ(array : List JSON → JSON)+> → λ(bool : Bool → JSON)+> → λ(null : JSON)+> → array [ number 1.0, bool True ]+> , foo =+> None Natural+> }+> ]+ -} module Dhall.JSONToDhall (@@ -173,9 +231,11 @@ import qualified Data.String import qualified Data.Text as Text import Data.Text (Text)+import qualified Data.Vector as Vector import qualified Options.Applicative as O import Options.Applicative (Parser) +import Dhall.JSON.Util (pattern V) import qualified Dhall import qualified Dhall.Core as D import Dhall.Core (Expr(App), Chunks(..))@@ -297,7 +357,6 @@ return (k, v) keyValMay _ = Nothing - {-| The main conversion function. Traversing/zipping Dhall /type/ and Aeson value trees together to produce a Dhall /term/ tree, given 'Conversion' options: >>> :set -XOverloadedStrings@@ -314,26 +373,32 @@ -} dhallFromJSON :: Conversion -> ExprX -> A.Value -> Either CompileError ExprX-dhallFromJSON (Conversion {..}) = loop+dhallFromJSON (Conversion {..}) expressionType =+ loop (D.alphaNormalize (D.normalize expressionType)) where -- any ~> Union- loop t@(D.Union tmMay) v = case unions of- UNone -> Left $ ContainsUnion t- _ -> case Map.traverseWithKey (const id) tmMay of- Nothing -> undefined- Just tm ->- -- OLD-STYLE UNION:- -- let f k a = D.UnionLit k <$> loop a v- -- <*> pure (Map.delete k tmMay)- let f k a = D.App (D.Field t k) <$> loop a v- in case rights . toList $ Map.mapWithKey f tm of- [ ] -> Left $ Mismatch t v- [x] -> Right x- xs@(x:_:_) -> case unions of- UStrict -> Left $ UndecidableUnion t v xs- UFirst -> Right x- UNone -> undefined -- can't happen+ loop t@(D.Union tm) v = do+ let f key maybeType =+ case maybeType of+ Just _type -> do+ expression <- loop _type v + return (D.App (D.Field t key) expression)++ Nothing -> do+ case v of+ A.String text | key == text -> do+ return (D.Field t key)+ _ -> do+ Left (Mismatch t v)++ case (unions, rights (toList (Map.mapWithKey f tm))) of+ (UNone , _ ) -> Left (ContainsUnion t)+ (UStrict, xs@(_:_:_)) -> Left (UndecidableUnion t v xs)+ (_ , [ ] ) -> Left (Mismatch t v)+ (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@@ -364,19 +429,28 @@ loop t@(App D.List (D.Record r)) v@(A.Object o) | not noKeyValMap , ["mapKey", "mapValue"] == Map.keys r- , Just D.Text == Map.lookup "mapKey" r+ , Just mapKey <- Map.lookup "mapKey" r , Just mapValue <- Map.lookup "mapValue" r- , keyExprMap :: Either CompileError (HM.HashMap Text ExprX)- <- traverse (loop mapValue) o- = let f :: (Text, ExprX) -> ExprX+ = do+ keyExprMap <- traverse (loop mapValue) o++ toKey <- do+ case mapKey of+ D.Text -> return (\key -> D.TextLit (Chunks [] key))+ D.Union _ -> return (\key -> D.Field mapKey key)+ _ -> Left (Mismatch t v)++ let f :: (Text, ExprX) -> ExprX f (key, val) = D.RecordLit ( Map.fromList- [ ("mapKey" , D.TextLit (Chunks [] key))+ [ ("mapKey" , toKey key) , ("mapValue", val) ] )- recs :: Either CompileError (Dhall.Seq ExprX)- recs = fmap f . Seq.fromList . HM.toList <$> keyExprMap- typeAnn = if HM.null o then Just mapValue else Nothing- in D.ListLit typeAnn <$> recs++ let records = (fmap f . Seq.fromList . HM.toList) keyExprMap++ let typeAnn = if HM.null o then Just mapValue else Nothing++ return (D.ListLit typeAnn records) | noKeyValMap = Left (NoKeyValMap t v) | otherwise@@ -424,6 +498,75 @@ -- value ~> Optional loop (App D.Optional expr) value = D.Some <$> loop expr value++ -- Arbitrary JSON ~> https://prelude.dhall-lang.org/JSON/Type+ loop+ (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))+ ]+ )+ (V 1)+ )+ )+ value = do+ let outer (A.Object o) =+ let inner (key, val) =+ D.RecordLit+ [ ("mapKey" , D.TextLit (D.Chunks [] key))+ , ("mapValue", outer val )+ ]++ elements = Seq.fromList (fmap inner (HM.toList o))++ elementType+ | null elements =+ Just (D.Record [ ("mapKey", D.Text), ("mapValue", "JSON") ])+ | otherwise =+ Nothing++ keyValues = D.ListLit elementType elements++ in (D.App (D.Field "json" "object") keyValues)+ outer (A.Array a) =+ let elements = Seq.fromList (fmap outer (Vector.toList a))++ elementType+ | null elements = Just "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 (toRealFloat n))+ outer (A.Bool b) =+ D.App (D.Field "json" "bool") (D.BoolLit b)+ outer A.Null =+ D.Field "json" "null"++ let result =+ D.Lam "JSON" (D.Const D.Type)+ (D.Lam "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")+ ]+ )+ (outer value)+ )++ return result -- fail loop expr value
src/Dhall/Yaml.hs view
@@ -1,35 +1,104 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-}-module Dhall.Yaml ( jsonToYaml, yamlToJson ) where+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} -import Data.Bifunctor (bimap)+module Dhall.Yaml+ ( Options(..)+ , parseDocuments+ , parseQuoted+ , defaultOptions+ , dhallToYaml ) where+ import Data.ByteString (ByteString)+import Data.Monoid ((<>))+import Data.Text (Text)+import Dhall.JSON (Conversion(..), SpecialDoubleMode(..), codeToValue)+import Options.Applicative (Parser) import qualified Data.Aeson import qualified Data.ByteString import qualified Data.Vector+import qualified Dhall+import qualified Options.Applicative+#if defined(ETA_VERSION)+import Dhall.Yaml.Eta ( jsonToYaml )+#else import qualified Data.Yaml-#if MIN_VERSION_yaml(0,10,2)+# if MIN_VERSION_yaml(0,10,2) import qualified Data.Text import qualified Text.Libyaml+# endif #endif ++data Options = Options+ { explain :: Bool+ , omission :: Data.Aeson.Value -> Data.Aeson.Value+ , documents :: Bool+ , quoted :: Bool+ , conversion :: Conversion+ , file :: Maybe FilePath+ }++defaultOptions :: Options+defaultOptions =+ Options { explain = False+ , omission = id+ , documents = False+ , quoted = False+ , conversion = NoConversion+ , file = Nothing+ }++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"+ )++parseQuoted :: Parser Bool+parseQuoted =+ Options.Applicative.switch+ ( Options.Applicative.long "quoted"+ <> Options.Applicative.help "Prevent from generating not quoted scalars"+ )+ +{-| Convert a piece of Text carrying a Dhall inscription to an equivalent YAML ByteString+-}+dhallToYaml+ :: Options+ -> Text -- ^ Describe the input for the sake of error location.+ -> Text -- ^ Input text.+ -> IO ByteString+dhallToYaml Options{..} name code = do+ + let explaining = if explain then Dhall.detailed else id++ json <- omission <$> explaining (codeToValue conversion UseYAMLEncoding name code)++ return $ jsonToYaml json documents quoted++#if !defined(ETA_VERSION) -- | Transform json representation into yaml jsonToYaml :: Data.Aeson.Value -> Bool -> Bool -> ByteString-jsonToYaml json documents quoted = case (documents, json) of- (True, Data.Yaml.Array elems)- -> Data.ByteString.intercalate "\n---\n"- $ fmap (encodeYaml encodeOptions)- $ Data.Vector.toList elems- _ -> encodeYaml encodeOptions json+jsonToYaml json documents quoted =++ case (documents, json) of+ (True, Data.Yaml.Array elems)+ -> Data.ByteString.intercalate "\n---\n"+ $ fmap (encodeYaml encodeOptions)+ $ Data.Vector.toList elems+ _ -> encodeYaml encodeOptions json+ where-#if !MIN_VERSION_yaml(0,10,2)+# if !MIN_VERSION_yaml(0,10,2) encodeYaml = Data.Yaml.encode-#else+# else encodeYaml = Data.Yaml.encodeWith customStyle = \s -> case () of@@ -47,10 +116,5 @@ encodeOptions = if quoted then quotedOptions else Data.Yaml.defaultEncodeOptions+# endif #endif---- | Transform yaml representation into dhall-yamlToJson :: ByteString -> Either String Data.Aeson.Value-yamlToJson =- bimap Data.Yaml.prettyPrintParseException id . Data.Yaml.decodeEither'-
+ src/Dhall/YamlToDhall.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++module Dhall.YamlToDhall+ ( Options(..)+ , defaultOptions+ , YAMLCompileError(..)+ , dhallFromYaml+ ) where++import Data.ByteString (ByteString)++import Dhall.JSONToDhall+ ( CompileError(..)+ , Conversion(..)+ , defaultConversion+ , dhallFromJSON+ , resolveSchemaExpr+ , showCompileError+ , typeCheckSchemaExpr+ )++import Control.Exception (Exception, throwIO)+import Data.Text (Text)+import Dhall.Core (Expr)+import Dhall.Src (Src)+import Dhall.TypeCheck(X)++#if defined(ETA_VERSION)+import Dhall.Yaml.Eta ( yamlToJson, showYaml )+#else+import Data.Aeson (Value)+import Data.Bifunctor (bimap)+import qualified Data.ByteString.Char8 as BS8+import qualified Data.Yaml+#endif++-- | Options to parametrize conversion+data Options = Options+ { schema :: Text+ , conversion :: Conversion+ } deriving Show++defaultOptions :: Text -> Options+defaultOptions schema = Options {..}+ where conversion = defaultConversion++ +data YAMLCompileError = YAMLCompileError CompileError++instance Show YAMLCompileError where+ show (YAMLCompileError e) = showCompileError "YAML" showYaml e++instance Exception YAMLCompileError+++-- | Transform yaml representation into dhall+dhallFromYaml :: Options -> ByteString -> IO (Expr Src X)+dhallFromYaml Options{..} yaml = do++ value <- either (throwIO . userError) pure (yamlToJson yaml)++ expr <- typeCheckSchemaExpr YAMLCompileError =<< resolveSchemaExpr schema++ let dhall = dhallFromJSON conversion expr value++ either (throwIO . YAMLCompileError) pure dhall+++#if !defined(ETA_VERSION)+yamlToJson :: ByteString -> Either String Data.Aeson.Value+yamlToJson =+ bimap Data.Yaml.prettyPrintParseException id . Data.Yaml.decodeEither'++showYaml :: Value -> String+showYaml value = BS8.unpack (Data.Yaml.encode value)+#endif+
tasty/Main.hs view
@@ -1,18 +1,24 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE RecordWildCards #-} module Main where +import Data.Monoid ((<>)) import Dhall.JSON (Conversion(..)) import Test.Tasty (TestTree) -import qualified Control.Exception-import qualified Data.Aeson+import qualified Data.Aeson as Aeson+import qualified Data.ByteString import qualified Data.ByteString.Lazy+import qualified Data.Text import qualified Data.Text.IO+import qualified Dhall.Core as Core import qualified Dhall.Import import qualified Dhall.JSON+import qualified Dhall.JSONToDhall as JSONToDhall import qualified Dhall.Parser+import qualified Dhall.TypeCheck import qualified Dhall.Yaml import qualified Test.Tasty import qualified Test.Tasty.HUnit@@ -23,99 +29,112 @@ testTree :: TestTree testTree = Test.Tasty.testGroup "dhall-json"- [ issue48- , yamlQuotedStrings- , yaml+ [ testDhallToJSON "./tasty/data/issue48"+ , testDhallToYaml+ Dhall.Yaml.defaultOptions+ "./tasty/data/normal"+ , testDhallToYaml+ (Dhall.Yaml.defaultOptions { Dhall.Yaml.quoted = True })+ "./tasty/data/quoted"+ , testJSONToDhall "./tasty/data/emptyAlternative"+ , Test.Tasty.testGroup "Nesting"+ [ testDhallToJSON "./tasty/data/nesting0"+ , testDhallToJSON "./tasty/data/nesting1"+ , testDhallToJSON "./tasty/data/nestingLegacy0"+ , testDhallToJSON "./tasty/data/nestingLegacy1"+ ]+ , Test.Tasty.testGroup "Union keys"+ [ testJSONToDhall "./tasty/data/unionKeys"+ , testDhallToJSON "./tasty/data/unionKeys"+ ] ] -issue48 :: TestTree-issue48 = Test.Tasty.HUnit.testCase "Issue #48" assertion- where- assertion = do- let file = "./tasty/data/issue48.dhall"+testDhallToJSON :: String -> TestTree+testDhallToJSON prefix = Test.Tasty.HUnit.testCase prefix $ do+ let inputFile = prefix <> ".dhall"+ let outputFile = prefix <> ".json" - code <- Data.Text.IO.readFile file+ text <- Data.Text.IO.readFile inputFile - parsedExpression <- case Dhall.Parser.exprFromText file code of- Left exception -> Control.Exception.throwIO exception- Right parsedExpression -> return parsedExpression+ parsedExpression <- do+ Core.throws (Dhall.Parser.exprFromText inputFile text) - resolvedExpression <- Dhall.Import.load parsedExpression+ resolvedExpression <- Dhall.Import.load parsedExpression - let mapKey = "mapKey"- let mapValue = "mapValue"- let conversion = Conversion {..}+ _ <- Core.throws (Dhall.TypeCheck.typeOf resolvedExpression) - let convertedExpression =- Dhall.JSON.convertToHomogeneousMaps conversion resolvedExpression+ let mapKey = "mapKey"+ let mapValue = "mapValue"+ let conversion = Conversion {..} - actualValue <- case Dhall.JSON.dhallToJSON convertedExpression of- Left exception -> Control.Exception.throwIO exception- Right actualValue -> return actualValue+ let convertedExpression =+ Dhall.JSON.convertToHomogeneousMaps conversion resolvedExpression - bytes <- Data.ByteString.Lazy.readFile "./tasty/data/issue48.json"+ actualValue <- do+ Core.throws (Dhall.JSON.dhallToJSON convertedExpression) - expectedValue <- case Data.Aeson.eitherDecode bytes of- Left string -> fail string- Right expectedValue -> return expectedValue+ bytes <- Data.ByteString.Lazy.readFile outputFile - let message =- "Conversion to homogeneous maps did not generate the expected JSON output"+ expectedValue <- case Aeson.eitherDecode bytes of+ Left string -> fail string+ Right expectedValue -> return expectedValue - Test.Tasty.HUnit.assertEqual message expectedValue actualValue+ let message = "Conversion to JSON did not generate the expected output" -yamlQuotedStrings :: TestTree-yamlQuotedStrings = Test.Tasty.HUnit.testCase "Yaml: quoted string style" assertion- where- assertion = do- let file = "./tasty/data/yaml.dhall"+ Test.Tasty.HUnit.assertEqual message expectedValue actualValue - code <- Data.Text.IO.readFile file+testJSONToDhall :: String -> TestTree+testJSONToDhall prefix = Test.Tasty.HUnit.testCase prefix $ do+ let inputFile = prefix <> ".json"+ let schemaFile = prefix <> "Schema.dhall"+ let outputFile = prefix <> ".dhall" - parsedExpression <- case Dhall.Parser.exprFromText file code of- Left exception -> Control.Exception.throwIO exception- Right parsedExpression -> return parsedExpression+ bytes <- Data.ByteString.Lazy.readFile inputFile - resolvedExpression <- Dhall.Import.load parsedExpression+ value <- do+ case Aeson.eitherDecode bytes of+ Left string -> fail string+ Right value -> return value - jsonValue <- case Dhall.JSON.dhallToJSON resolvedExpression of- Left exception -> Control.Exception.throwIO exception- Right jsonValue -> return jsonValue+ schemaText <- Data.Text.IO.readFile schemaFile - let actualValue = Dhall.Yaml.jsonToYaml jsonValue False True+ parsedSchema <- Core.throws (Dhall.Parser.exprFromText schemaFile schemaText) - bytes <- Data.ByteString.Lazy.readFile "./tasty/data/quoted.yaml"- let expectedValue = Data.ByteString.Lazy.toStrict bytes+ schema <- Dhall.Import.load parsedSchema - let message =- "Conversion to quoted yaml did not generate the expected output"+ _ <- Core.throws (Dhall.TypeCheck.typeOf schema) - Test.Tasty.HUnit.assertEqual message expectedValue actualValue+ actualExpression <- do+ Core.throws (JSONToDhall.dhallFromJSON JSONToDhall.defaultConversion schema value) -yaml :: TestTree-yaml = Test.Tasty.HUnit.testCase "Yaml: normal string style" assertion- where- assertion = do- let file = "./tasty/data/yaml.dhall"+ outputText <- Data.Text.IO.readFile outputFile - code <- Data.Text.IO.readFile file+ parsedExpression <- do+ Core.throws (Dhall.Parser.exprFromText outputFile outputText) - parsedExpression <- case Dhall.Parser.exprFromText file code of- Left exception -> Control.Exception.throwIO exception- Right parsedExpression -> return parsedExpression+ resolvedExpression <- Dhall.Import.load parsedExpression - resolvedExpression <- Dhall.Import.load parsedExpression+ _ <- Core.throws (Dhall.TypeCheck.typeOf resolvedExpression) - jsonValue <- case Dhall.JSON.dhallToJSON resolvedExpression of- Left exception -> Control.Exception.throwIO exception- Right jsonValue -> return jsonValue+ let expectedExpression = Core.normalize resolvedExpression - let actualValue = Dhall.Yaml.jsonToYaml jsonValue False False+ let message =+ "Conversion to Dhall did not generate the expected output" - bytes <- Data.ByteString.Lazy.readFile "./tasty/data/normal.yaml"- let expectedValue = Data.ByteString.Lazy.toStrict bytes+ Test.Tasty.HUnit.assertEqual message expectedExpression actualExpression - let message =- "Conversion to normal yaml did not generate the expected output"+testDhallToYaml :: Dhall.Yaml.Options -> String -> TestTree+testDhallToYaml options prefix = Test.Tasty.HUnit.testCase prefix $ do+ let inputFile = prefix <> ".dhall"+ let outputFile = prefix <> ".yaml" - Test.Tasty.HUnit.assertEqual message expectedValue actualValue+ text <- Data.Text.IO.readFile inputFile++ actualValue <- do+ Dhall.Yaml.dhallToYaml options (Data.Text.pack inputFile) text++ expectedValue <- Data.ByteString.readFile outputFile++ let message = "Conversion to YAML did not generate the expected output"++ Test.Tasty.HUnit.assertEqual message expectedValue actualValue
+ tasty/data/emptyAlternative.dhall view
@@ -0,0 +1,1 @@+< Bar | Foo >.Foo
+ tasty/data/emptyAlternative.json view
@@ -0,0 +1,1 @@+"Foo"
+ tasty/data/emptyAlternativeSchema.dhall view
@@ -0,0 +1,1 @@+< Bar | Foo >
+ tasty/data/nesting0.dhall view
@@ -0,0 +1,8 @@+let Example = < Left : { foo : Natural } | Right : { bar : Bool } >++let Nesting = < Inline | Nested : Text >++in { field = "name"+ , nesting = Nesting.Inline+ , contents = Example.Left { foo = 2 }+ }
+ tasty/data/nesting0.json view
@@ -0,0 +1,1 @@+{ "foo": 2, "name": "Left" }
+ tasty/data/nesting1.dhall view
@@ -0,0 +1,8 @@+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 }+ }
+ tasty/data/nesting1.json view
@@ -0,0 +1,1 @@+{ "name": "Left", "value": { "foo": 2 } }
+ tasty/data/nestingLegacy0.dhall view
@@ -0,0 +1,8 @@+let Example = < Left : { foo : Natural } | Right : { bar : Bool } >++let Nesting = < Inline : {} | Nested : Text >++in { field = "name"+ , nesting = Nesting.Inline {=}+ , contents = Example.Left { foo = 2 }+ }
+ tasty/data/nestingLegacy0.json view
@@ -0,0 +1,1 @@+{ "foo": 2, "name": "Left" }
+ tasty/data/nestingLegacy1.dhall view
@@ -0,0 +1,8 @@+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 }+ }
+ tasty/data/nestingLegacy1.json view
@@ -0,0 +1,1 @@+{ "name": "Left", "value": { "foo": 2 } }
+ tasty/data/normal.dhall view
@@ -0,0 +1,5 @@+{ string_value = "2000-01-01"+, text = ./tasty/data/yaml.txt as Text+, int_value = 1+, bool_value = True+}
+ tasty/data/normal.yaml view
@@ -0,0 +1,5 @@+bool_value: true+text: |+ Plain text+string_value: 2000-01-01+int_value: 1
+ tasty/data/quoted.dhall view
@@ -0,0 +1,5 @@+{ string_value = "2000-01-01"+, text = ./tasty/data/yaml.txt as Text+, int_value = 1+, bool_value = True+}
+ tasty/data/quoted.yaml view
@@ -0,0 +1,5 @@+'bool_value': true+'text': |+ Plain text+'string_value': '2000-01-01'+'int_value': 1
+ tasty/data/unionKeys.dhall view
@@ -0,0 +1,3 @@+[ { mapKey = < A | B >.A, mapValue = 1 }+, { mapKey = < A | B >.B, mapValue = 2 }+]
+ tasty/data/unionKeys.json view
@@ -0,0 +1,1 @@+{ "A": 1, "B": 2 }
+ tasty/data/unionKeysSchema.dhall view
@@ -0,0 +1,1 @@+List { mapKey : < A | B >, mapValue : Natural }
− tasty/data/yaml.dhall
@@ -1,5 +0,0 @@-{ string_value = "2000-01-01"-, text = ./tasty/data/yaml.txt as Text-, int_value = 1-, bool_value = True-}
+ tasty/data/yaml.txt view
@@ -0,0 +1,1 @@+Plain text
yaml-to-dhall/Main.hs view
@@ -8,75 +8,93 @@ module Main where +import Control.Applicative (optional)+import Control.Exception (SomeException)+import Control.Monad (when)+import Data.Monoid ((<>))+import Data.Text (Text)+import Data.Version (showVersion)+import Dhall.JSONToDhall (Conversion, parseConversion)+import Dhall.Pretty (CharacterSet(..))+import Dhall.YamlToDhall (Options(..), dhallFromYaml)+import Options.Applicative (Parser, ParserInfo)+ import qualified Control.Exception-import Control.Exception (Exception, SomeException, throwIO)-import Control.Monad (when)-import qualified Data.Aeson as A-import qualified Data.ByteString.Char8 as BS8-import qualified Data.ByteString.Lazy.Char8 as BSL8-import Data.Monoid ((<>))-import Data.Text (Text)-import qualified Data.Text.IO as Text-import Data.Version (showVersion)+import qualified Data.ByteString.Char8 as BSL8+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 Dhall.Pretty import qualified GHC.IO.Encoding-import qualified Options.Applicative as O-import Options.Applicative (Parser, ParserInfo)+import qualified Options.Applicative as Options+import qualified System.Console.ANSI as ANSI import qualified System.Exit-import qualified System.IO--import qualified Dhall.Core as D-import Dhall.JSONToDhall-import Dhall.Yaml (yamlToJson, jsonToYaml)-import qualified Paths_dhall_json as Meta+import qualified System.IO as IO+import qualified Paths_dhall_json as Meta -- --------------- -- Command options -- --------------- --- | Command info and description-parserInfo :: ParserInfo Options-parserInfo = O.info- ( O.helper <*> parseOptions)- ( O.fullDesc- <> O.progDesc "Populate Dhall value given its Dhall type (schema) from a YAML expression"- )---- | All the command arguments and options-data Options = Options+data CommandOptions = CommandOptions { version :: Bool , schema :: Text , conversion :: Conversion+ , file :: Maybe FilePath+ , ascii :: Bool+ , plain :: Bool } deriving Show +-- | Command info and description+parserInfo :: ParserInfo CommandOptions+parserInfo = Options.info+ ( Options.helper <*> parseOptions)+ ( Options.fullDesc+ <> Options.progDesc "Convert a YAML expression to a Dhall expression, given the expected Dhall type"+ )+++ -- | Parser for all the command arguments and options-parseOptions :: Parser Options-parseOptions = Options <$> parseVersion- <*> parseSchema- <*> parseConversion+parseOptions :: Parser CommandOptions+parseOptions = CommandOptions <$> parseVersion+ <*> parseSchema+ <*> parseConversion+ <*> optional parseFile+ <*> parseASCII+ <*> parsePlain where- parseSchema = O.strArgument- ( O.metavar "SCHEMA"- <> O.help "Dhall type expression (schema)"- )- parseVersion = O.switch- ( O.long "version"- <> O.short 'V'- <> O.help "Display version"- )---- ------------- YAML--- ----------+ parseSchema =+ Options.strArgument+ ( Options.metavar "SCHEMA"+ <> Options.help "Dhall type expression (schema)"+ ) -showYAML :: A.Value -> String-showYAML value = BS8.unpack (jsonToYaml value False False)+ parseVersion =+ Options.switch+ ( Options.long "version"+ <> Options.short 'V'+ <> Options.help "Display version"+ ) -data YAMLCompileError = YAMLCompileError CompileError+ parseFile =+ Options.strOption+ ( Options.long "file"+ <> Options.help "Read YAML expression from a file instead of standard input"+ <> Options.metavar "FILE"+ ) -instance Show YAMLCompileError where- show (YAMLCompileError e) = showCompileError "YAML" showYAML e+ parseASCII =+ Options.switch+ ( Options.long "ascii"+ <> Options.help "Format code using only ASCII syntax"+ ) -instance Exception YAMLCompileError+ parsePlain =+ Options.switch+ ( Options.long "plain"+ <> Options.help "Disable syntax highlighting"+ ) -- ---------- -- Main@@ -86,29 +104,44 @@ main = do GHC.IO.Encoding.setLocaleEncoding GHC.IO.Encoding.utf8 - Options {..} <- O.execParser parserInfo+ CommandOptions{..} <- Options.execParser parserInfo + let characterSet = case ascii of+ True -> ASCII+ False -> Unicode+ when version $ do putStrLn (showVersion Meta.version) System.Exit.exitSuccess handle $ do- stdin <- BSL8.getContents+ bytes <- case file of+ Nothing -> BSL8.getContents+ Just path -> BSL8.readFile path - value <- either (throwIO . userError) pure- (yamlToJson . BS8.concat $ BSL8.toChunks stdin)+ result <- dhallFromYaml (Options schema conversion) bytes - expr <- typeCheckSchemaExpr YAMLCompileError =<< resolveSchemaExpr schema+ let document = Dhall.Pretty.prettyCharacterSet characterSet result - case dhallFromJSON conversion expr value of- Left err -> throwIO $ YAMLCompileError err- Right res -> Text.putStr (D.pretty res)+ let stream = Pretty.layoutSmart Dhall.Pretty.layoutOpts document + supportsANSI <- ANSI.hSupportsANSI IO.stdout++ let ansiStream =+ if supportsANSI && not plain+ then fmap Dhall.Pretty.annToAnsiStyle stream+ else Pretty.unAnnotateS stream++ Pretty.Terminal.renderIO IO.stdout ansiStream++ Text.IO.putStrLn ""++ handle :: IO a -> IO a handle = Control.Exception.handle handler where handler :: SomeException -> IO a handler e = do- System.IO.hPutStrLn System.IO.stderr ""- System.IO.hPrint System.IO.stderr e+ IO.hPutStrLn IO.stderr ""+ IO.hPrint IO.stderr e System.Exit.exitFailure