summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGabrielGonzalez <>2019-07-29 05:37:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-07-29 05:37:00 (GMT)
commit69e0cd102e4a242a02f97f0531c1915746d95f14 (patch)
tree6cef9641d9cd2161e0461dcc3df34b26f355cf3a
parent3a1a99d9e1726e9e419d3713bfdabe53dacfe57b (diff)
version 1.4.01.4.0
-rw-r--r--CHANGELOG.md27
-rw-r--r--dhall-json.cabal66
-rw-r--r--dhall-to-json/Main.hs68
-rw-r--r--dhall-to-yaml/Main.hs68
-rw-r--r--java/Utils.java23
-rw-r--r--json-to-dhall/Main.hs128
-rw-r--r--src/Dhall/JSON.hs558
-rw-r--r--src/Dhall/JSON/Util.hs13
-rw-r--r--src/Dhall/JSONToDhall.hs197
-rw-r--r--src/Dhall/Yaml.hs100
-rw-r--r--src/Dhall/YamlToDhall.hs78
-rw-r--r--tasty/Main.hs155
-rw-r--r--tasty/data/emptyAlternative.dhall1
-rw-r--r--tasty/data/emptyAlternative.json1
-rw-r--r--tasty/data/emptyAlternativeSchema.dhall1
-rw-r--r--tasty/data/nesting0.dhall8
-rw-r--r--tasty/data/nesting0.json1
-rw-r--r--tasty/data/nesting1.dhall8
-rw-r--r--tasty/data/nesting1.json1
-rw-r--r--tasty/data/nestingLegacy0.dhall8
-rw-r--r--tasty/data/nestingLegacy0.json1
-rw-r--r--tasty/data/nestingLegacy1.dhall8
-rw-r--r--tasty/data/nestingLegacy1.json1
-rw-r--r--tasty/data/normal.dhall (renamed from tasty/data/yaml.dhall)0
-rw-r--r--tasty/data/normal.yaml5
-rw-r--r--tasty/data/quoted.dhall5
-rw-r--r--tasty/data/quoted.yaml5
-rw-r--r--tasty/data/unionKeys.dhall3
-rw-r--r--tasty/data/unionKeys.json1
-rw-r--r--tasty/data/unionKeysSchema.dhall1
-rw-r--r--tasty/data/yaml.txt1
-rw-r--r--yaml-to-dhall/Main.hs159
32 files changed, 1157 insertions, 543 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 12ea064..4485e7c 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -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
diff --git a/dhall-json.cabal b/dhall-json.cabal
index c909ef0..b09bd37 100644
--- a/dhall-json.cabal
+++ b/dhall-json.cabal
@@ -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,8 +24,12 @@ Description:
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
@@ -43,10 +47,9 @@ Library
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 @@ Library
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 @@ Executable json-to-dhall
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 @@ Executable yaml-to-dhall
Hs-Source-Dirs: yaml-to-dhall
Main-Is: Main.hs
Build-Depends:
- base ,
- aeson ,
- bytestring < 0.11 ,
- dhall ,
- dhall-json ,
- exceptions >= 0.8.3 && < 0.11 ,
- 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:
diff --git a/dhall-to-json/Main.hs b/dhall-to-json/Main.hs
index 07d556f..7b88170 100644
--- a/dhall-to-json/Main.hs
+++ b/dhall-to-json/Main.hs
@@ -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
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 @@ data Options = Options
, version :: Bool
, conversion :: Conversion
, approximateSpecialDoubles :: Bool
+ , file :: Maybe FilePath
}
parseOptions :: Parser Options
@@ -44,58 +46,66 @@ parseOptions =
<*> 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 @@ main = do
then ApproximateWithinJSON
else ForbidWithinJSON
- stdin <- Data.Text.IO.getContents
+ text <- case file of
+ Nothing -> Text.IO.getContents
+ Just path -> Text.IO.readFile path
+
+ let path = case file of
+ Nothing -> "(stdin)"
+ Just p -> Text.pack p
- json <- omission <$> explaining (Dhall.JSON.codeToValue conversion specialDoubleMode "(stdin)" stdin)
+ json <- omission <$> explaining (Dhall.JSON.codeToValue conversion specialDoubleMode path text)
Data.ByteString.Char8.putStrLn $ Data.ByteString.Lazy.toStrict $ encode json
diff --git a/dhall-to-yaml/Main.hs b/dhall-to-yaml/Main.hs
index 06aacc6..bddb5a6 100644
--- a/dhall-to-yaml/Main.hs
+++ b/dhall-to-yaml/Main.hs
@@ -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 @@ parseOptions =
<*> 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
diff --git a/java/Utils.java b/java/Utils.java
new file mode 100644
index 0000000..26b4ff4
--- /dev/null
+++ b/java/Utils.java
@@ -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;
+ }
+}
diff --git a/json-to-dhall/Main.hs b/json-to-dhall/Main.hs
index 5634bcb..12b6ca1 100644
--- a/json-to-dhall/Main.hs
+++ b/json-to-dhall/Main.hs
@@ -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 @@ import qualified Paths_dhall_json as Meta
-- | 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 @@ data Options = Options
{ version :: Bool
, schema :: Text
, conversion :: Conversion
+ , file :: Maybe FilePath
+ , ascii :: Bool
+ , plain :: Bool
} deriving Show
-- | Parser for all the command arguments and options
@@ -52,16 +59,41 @@ parseOptions :: Parser Options
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 :: IO ()
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
diff --git a/src/Dhall/JSON.hs b/src/Dhall/JSON.hs
index c13921f..79eb216 100644
--- a/src/Dhall/JSON.hs
+++ b/src/Dhall/JSON.hs
@@ -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 } >
+> let Example = < Left : { foo : Natural } | Right : { bar : Bool } >
>
-> in let example = constructors Example
->
-> in let Nesting = < Inline : {} | Nested : Text >
->
-> 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
+> let Example = < Left : { foo : Natural } | Right : { bar : Bool } >
>
-> in let Nesting = < Inline : {} | Nested : Text >
->
-> 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 Data.Text (Text)
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 @@ instance Show CompileError where
\ \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 @@ instance Exception CompileError
>>> :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"
+ )
+ (Core.TextLit
+ (Core.Chunks [] nestedField)
)
- [ ("Inline", Just (Dhall.Core.Record [])) ]
)
- ] -> do
+ ] | all (== Core.Record []) mInlineType -> do
contents' <- loop contents
let taggedValue =
@@ -338,45 +360,104 @@ dhallToJSON e0 = loop (Dhall.Core.normalize e0)
)
]
- 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 @@ toOrderedList =
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 :: Value -> Value
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 @@ data Conversion
-}
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
-
- Dhall.Core.Var v ->
- Dhall.Core.Var v
-
- Dhall.Core.Lam a b c ->
- Dhall.Core.Lam a b' c'
- where
- b' = loop b
- c' = loop c
-
- Dhall.Core.Pi a b c ->
- Dhall.Core.Pi a b' c'
+ Core.Const a ->
+ Core.Const a
+
+ Core.Var v ->
+ Core.Var v
+
+ {- 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
+
+ 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,145 +575,148 @@ convertToHomogeneousMaps (Conversion {..}) e0 = loop (Dhall.Core.normalize e0)
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
_ ->
@@ -644,11 +730,11 @@ convertToHomogeneousMaps (Conversion {..}) e0 = loop (Dhall.Core.normalize e0)
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 @@ convertToHomogeneousMaps (Conversion {..}) e0 = loop (Dhall.Core.normalize e0)
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
+ Core.ListBuild ->
+ Core.ListBuild
- Dhall.Core.ListFold ->
- Dhall.Core.ListFold
+ Core.ListFold ->
+ Core.ListFold
- Dhall.Core.ListLength ->
- Dhall.Core.ListLength
+ Core.ListLength ->
+ Core.ListLength
- Dhall.Core.ListHead ->
- Dhall.Core.ListHead
+ Core.ListHead ->
+ Core.ListHead
- Dhall.Core.ListLast ->
- Dhall.Core.ListLast
+ Core.ListLast ->
+ Core.ListLast
- Dhall.Core.ListIndexed ->
- Dhall.Core.ListIndexed
+ Core.ListIndexed ->
+ Core.ListIndexed
- Dhall.Core.ListReverse ->
- Dhall.Core.ListReverse
+ Core.ListReverse ->
+ Core.ListReverse
- Dhall.Core.Optional ->
- Dhall.Core.Optional
+ Core.Optional ->
+ Core.Optional
- Dhall.Core.OptionalLit a b ->
- Dhall.Core.OptionalLit a' b'
- where
- a' = loop a
- b' = fmap loop b
-
- 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 @@ data SpecialDoubleMode
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 @@ handleSpecialDoubles specialDoubleMode =
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 @@ handleSpecialDoubles specialDoubleMode =
{-| 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 @@ codeToValue
-> 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
diff --git a/src/Dhall/JSON/Util.hs b/src/Dhall/JSON/Util.hs
new file mode 100644
index 0000000..efc58a3
--- /dev/null
+++ b/src/Dhall/JSON/Util.hs
@@ -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)
diff --git a/src/Dhall/JSONToDhall.hs b/src/Dhall/JSONToDhall.hs
index 359553e..f3ebb21 100644
--- a/src/Dhall/JSONToDhall.hs
+++ b/src/Dhall/JSONToDhall.hs
@@ -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.Sequence as Seq
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 @@ keyValMay (A.Object o) = do
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,25 +373,31 @@ Right (RecordLit (fromList [("foo",IntegerLit 1)]))
-}
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)
@@ -364,19 +429,28 @@ dhallFromJSON (Conversion {..}) = loop
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
@@ -425,6 +499,75 @@ dhallFromJSON (Conversion {..}) = loop
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
= Left (Mismatch expr value)
diff --git a/src/Dhall/Yaml.hs b/src/Dhall/Yaml.hs
index edbf31f..50abf6d 100644
--- a/src/Dhall/Yaml.hs
+++ b/src/Dhall/Yaml.hs
@@ -1,35 +1,104 @@
-{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
-module Dhall.Yaml ( jsonToYaml, yamlToJson ) where
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Dhall.Yaml
+ ( Options(..)
+ , parseDocuments
+ , parseQuoted
+ , defaultOptions
+ , dhallToYaml ) where
-import Data.Bifunctor (bimap)
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 @@ jsonToYaml json documents quoted = case (documents, json) of
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'
-
diff --git a/src/Dhall/YamlToDhall.hs b/src/Dhall/YamlToDhall.hs
new file mode 100644
index 0000000..65f6c85
--- /dev/null
+++ b/src/Dhall/YamlToDhall.hs
@@ -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
+
diff --git a/tasty/Main.hs b/tasty/Main.hs
index ad01821..766f4aa 100644
--- a/tasty/Main.hs
+++ b/tasty/Main.hs
@@ -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 @@ main = Test.Tasty.defaultMain testTree
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
diff --git a/tasty/data/emptyAlternative.dhall b/tasty/data/emptyAlternative.dhall
new file mode 100644
index 0000000..4228451
--- /dev/null
+++ b/tasty/data/emptyAlternative.dhall
@@ -0,0 +1 @@
+< Bar | Foo >.Foo
diff --git a/tasty/data/emptyAlternative.json b/tasty/data/emptyAlternative.json
new file mode 100644
index 0000000..2489cfc
--- /dev/null
+++ b/tasty/data/emptyAlternative.json
@@ -0,0 +1 @@
+"Foo"
diff --git a/tasty/data/emptyAlternativeSchema.dhall b/tasty/data/emptyAlternativeSchema.dhall
new file mode 100644
index 0000000..0c6b03f
--- /dev/null
+++ b/tasty/data/emptyAlternativeSchema.dhall
@@ -0,0 +1 @@
+< Bar | Foo >
diff --git a/tasty/data/nesting0.dhall b/tasty/data/nesting0.dhall
new file mode 100644
index 0000000..dc9dde8
--- /dev/null
+++ b/tasty/data/nesting0.dhall
@@ -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 }
+ }
diff --git a/tasty/data/nesting0.json b/tasty/data/nesting0.json
new file mode 100644
index 0000000..483fc3b
--- /dev/null
+++ b/tasty/data/nesting0.json
@@ -0,0 +1 @@
+{ "foo": 2, "name": "Left" }
diff --git a/tasty/data/nesting1.dhall b/tasty/data/nesting1.dhall
new file mode 100644
index 0000000..0947da6
--- /dev/null
+++ b/tasty/data/nesting1.dhall
@@ -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 }
+ }
diff --git a/tasty/data/nesting1.json b/tasty/data/nesting1.json
new file mode 100644
index 0000000..dfdba8f
--- /dev/null
+++ b/tasty/data/nesting1.json
@@ -0,0 +1 @@
+{ "name": "Left", "value": { "foo": 2 } }
diff --git a/tasty/data/nestingLegacy0.dhall b/tasty/data/nestingLegacy0.dhall
new file mode 100644
index 0000000..ef379c7
--- /dev/null
+++ b/tasty/data/nestingLegacy0.dhall
@@ -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 }
+ }
diff --git a/tasty/data/nestingLegacy0.json b/tasty/data/nestingLegacy0.json
new file mode 100644
index 0000000..483fc3b
--- /dev/null
+++ b/tasty/data/nestingLegacy0.json
@@ -0,0 +1 @@
+{ "foo": 2, "name": "Left" }
diff --git a/tasty/data/nestingLegacy1.dhall b/tasty/data/nestingLegacy1.dhall
new file mode 100644
index 0000000..811794a
--- /dev/null
+++ b/tasty/data/nestingLegacy1.dhall
@@ -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 }
+ }
diff --git a/tasty/data/nestingLegacy1.json b/tasty/data/nestingLegacy1.json
new file mode 100644
index 0000000..dfdba8f
--- /dev/null
+++ b/tasty/data/nestingLegacy1.json
@@ -0,0 +1 @@
+{ "name": "Left", "value": { "foo": 2 } }
diff --git a/tasty/data/yaml.dhall b/tasty/data/normal.dhall
index 1eeedf7..1eeedf7 100644
--- a/tasty/data/yaml.dhall
+++ b/tasty/data/normal.dhall
diff --git a/tasty/data/normal.yaml b/tasty/data/normal.yaml
new file mode 100644
index 0000000..785dfc5
--- /dev/null
+++ b/tasty/data/normal.yaml
@@ -0,0 +1,5 @@
+bool_value: true
+text: |
+ Plain text
+string_value: 2000-01-01
+int_value: 1
diff --git a/tasty/data/quoted.dhall b/tasty/data/quoted.dhall
new file mode 100644
index 0000000..1eeedf7
--- /dev/null
+++ b/tasty/data/quoted.dhall
@@ -0,0 +1,5 @@
+{ string_value = "2000-01-01"
+, text = ./tasty/data/yaml.txt as Text
+, int_value = 1
+, bool_value = True
+}
diff --git a/tasty/data/quoted.yaml b/tasty/data/quoted.yaml
new file mode 100644
index 0000000..16ee2a8
--- /dev/null
+++ b/tasty/data/quoted.yaml
@@ -0,0 +1,5 @@
+'bool_value': true
+'text': |
+ Plain text
+'string_value': '2000-01-01'
+'int_value': 1
diff --git a/tasty/data/unionKeys.dhall b/tasty/data/unionKeys.dhall
new file mode 100644
index 0000000..3f630d9
--- /dev/null
+++ b/tasty/data/unionKeys.dhall
@@ -0,0 +1,3 @@
+[ { mapKey = < A | B >.A, mapValue = 1 }
+, { mapKey = < A | B >.B, mapValue = 2 }
+]
diff --git a/tasty/data/unionKeys.json b/tasty/data/unionKeys.json
new file mode 100644
index 0000000..9b77fa7
--- /dev/null
+++ b/tasty/data/unionKeys.json
@@ -0,0 +1 @@
+{ "A": 1, "B": 2 }
diff --git a/tasty/data/unionKeysSchema.dhall b/tasty/data/unionKeysSchema.dhall
new file mode 100644
index 0000000..9f60e06
--- /dev/null
+++ b/tasty/data/unionKeysSchema.dhall
@@ -0,0 +1 @@
+List { mapKey : < A | B >, mapValue : Natural }
diff --git a/tasty/data/yaml.txt b/tasty/data/yaml.txt
new file mode 100644
index 0000000..ec6816d
--- /dev/null
+++ b/tasty/data/yaml.txt
@@ -0,0 +1 @@
+Plain text
diff --git a/yaml-to-dhall/Main.hs b/yaml-to-dhall/Main.hs
index 3188408..8276643 100644
--- a/yaml-to-dhall/Main.hs
+++ b/yaml-to-dhall/Main.hs
@@ -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
--- | Parser for all the command arguments and options
-parseOptions :: Parser Options
-parseOptions = Options <$> parseVersion
- <*> parseSchema
- <*> parseConversion
- where
- parseSchema = O.strArgument
- ( O.metavar "SCHEMA"
- <> O.help "Dhall type expression (schema)"
- )
- parseVersion = O.switch
- ( O.long "version"
- <> O.short 'V'
- <> O.help "Display version"
- )
-
--- ----------
--- YAML
--- ----------
-
-showYAML :: A.Value -> String
-showYAML value = BS8.unpack (jsonToYaml value False False)
+-- | 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"
+ )
-data YAMLCompileError = YAMLCompileError CompileError
-instance Show YAMLCompileError where
- show (YAMLCompileError e) = showCompileError "YAML" showYAML e
-instance Exception YAMLCompileError
+-- | Parser for all the command arguments and options
+parseOptions :: Parser CommandOptions
+parseOptions = CommandOptions <$> parseVersion
+ <*> parseSchema
+ <*> parseConversion
+ <*> optional parseFile
+ <*> parseASCII
+ <*> parsePlain
+ where
+ 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 YAML expression 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
@@ -86,29 +104,44 @@ main :: IO ()
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
+
+ result <- dhallFromYaml (Options schema conversion) bytes
+
+ 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
- value <- either (throwIO . userError) pure
- (yamlToJson . BS8.concat $ BSL8.toChunks stdin)
+ Pretty.Terminal.renderIO IO.stdout ansiStream
- expr <- typeCheckSchemaExpr YAMLCompileError =<< resolveSchemaExpr schema
+ Text.IO.putStrLn ""
- case dhallFromJSON conversion expr value of
- Left err -> throwIO $ YAMLCompileError err
- Right res -> Text.putStr (D.pretty res)
handle :: IO a -> IO a
handle = Control.Exception.handle handler
where
handler :: SomeException -> IO a
handler e = do
- System.IO.hPutStrLn System.IO.stderr ""
- System.IO.hPrint System.IO.stderr e
+ IO.hPutStrLn IO.stderr ""
+ IO.hPrint IO.stderr e
System.Exit.exitFailure