summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGabrielGonzalez <>2019-09-12 02:40:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-09-12 02:40:00 (GMT)
commit0dc9492c748b189db8abf85499b577d632ea7af9 (patch)
tree8b20f108df999f5acef443d31bd1a08153498d6b
parent69e0cd102e4a242a02f97f0531c1915746d95f14 (diff)
version 1.4.11.4.1
-rw-r--r--CHANGELOG.md11
-rw-r--r--dhall-json.cabal8
-rw-r--r--dhall-to-json/Main.hs107
-rw-r--r--dhall-to-yaml/Main.hs65
-rw-r--r--json-to-dhall/Main.hs112
-rw-r--r--src/Dhall/JSON.hs269
-rw-r--r--src/Dhall/JSONToDhall.hs44
-rw-r--r--src/Dhall/Yaml.hs9
-rw-r--r--tasty/Main.hs15
-rw-r--r--tasty/data/emptyList.dhall17
-rw-r--r--tasty/data/emptyList.json1
-rw-r--r--tasty/data/emptyListSchema.dhall17
-rw-r--r--tasty/data/emptyListStrongType.dhall1
-rw-r--r--tasty/data/emptyListStrongType.json1
-rw-r--r--tasty/data/emptyListStrongTypeSchema.dhall1
-rw-r--r--tasty/data/emptyObject.dhall17
-rw-r--r--tasty/data/emptyObject.json1
-rw-r--r--tasty/data/emptyObjectSchema.dhall17
-rw-r--r--tasty/data/emptyObjectStrongType.dhall1
-rw-r--r--tasty/data/emptyObjectStrongType.json1
-rw-r--r--tasty/data/emptyObjectStrongTypeSchema.dhall1
-rw-r--r--tasty/data/nesting2.dhall8
-rw-r--r--tasty/data/nesting2.json1
-rw-r--r--tasty/data/nesting3.dhall8
-rw-r--r--tasty/data/nesting3.json1
-rw-r--r--tasty/data/normal.dhall2
-rw-r--r--tasty/data/quoted.dhall2
-rw-r--r--yaml-to-dhall/Main.hs101
28 files changed, 571 insertions, 268 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 4485e7c..d687178 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,3 +1,14 @@
+1.4.1
+
+* [Enable `--records-strict` by default for `{json-yaml}-to-dhall`](https://github.com/dhall-lang/dhall-haskell/pull/1181)
+* [Fix `--file` flag for `dhall-to-{json,yaml}`](https://github.com/dhall-lang/dhall-haskell/pull/1191)
+* [Fix `--version` flag for `{yaml,json}-to-dhall`](https://github.com/dhall-lang/dhall-haskell/pull/1199)
+* [`Nesting`: Support empty alternatives as contents](https://github.com/dhall-lang/dhall-haskell/pull/1204)
+* [Fix `yaml-to-dhall` support for empty objects](https://github.com/dhall-lang/dhall-haskell/pull/1186)
+* [Throw error when union value is incompatible with inline nesting](https://github.com/dhall-lang/dhall-haskell/pull/1226)
+* [Add `--output` options](https://github.com/dhall-lang/dhall-haskell/pull/1304)
+* [Minor bug fixes for `yaml-to-dhall` error messages](https://github.com/dhall-lang/dhall-haskell/pull/1305)
+
1.4.0
* BREAKING CHANGE: Split `Dhall.YAML` into `Dhall.YAML` + `Dhall.YAMLToDhall`
diff --git a/dhall-json.cabal b/dhall-json.cabal
index b09bd37..72f5590 100644
--- a/dhall-json.cabal
+++ b/dhall-json.cabal
@@ -1,5 +1,5 @@
Name: dhall-json
-Version: 1.4.0
+Version: 1.4.1
Cabal-Version: >=1.8.0.2
Build-Type: Simple
Tested-With: GHC == 7.10.3, GHC == 8.4.3, GHC == 8.6.1
@@ -47,9 +47,11 @@ Library
aeson-pretty < 0.9 ,
bytestring < 0.11,
containers ,
- dhall >= 1.25.0 && < 1.26,
+ dhall >= 1.26.0 && < 1.27,
exceptions >= 0.8.3 && < 0.11,
+ filepath < 1.5 ,
optparse-applicative >= 0.14.0.0 && < 0.16,
+ prettyprinter >= 1.2.0.1 && < 1.3 ,
scientific >= 0.3.0.0 && < 0.4 ,
text >= 0.11.1.0 && < 1.3 ,
unordered-containers < 0.3 ,
@@ -99,6 +101,8 @@ Executable dhall-to-yaml
dhall-json ,
optparse-applicative ,
text
+ Other-Modules:
+ Paths_dhall_json
GHC-Options: -Wall
Executable json-to-dhall
diff --git a/dhall-to-json/Main.hs b/dhall-to-json/Main.hs
index 7b88170..0309ea5 100644
--- a/dhall-to-json/Main.hs
+++ b/dhall-to-json/Main.hs
@@ -5,7 +5,6 @@ module Main where
import Control.Applicative ((<|>), optional)
import Control.Exception (SomeException)
-import Control.Monad (when)
import Data.Aeson (Value)
import Data.Monoid ((<>))
import Data.Version (showVersion)
@@ -15,9 +14,7 @@ import Options.Applicative (Parser, ParserInfo)
import qualified Control.Exception
import qualified Data.Aeson
import qualified Data.Aeson.Encode.Pretty
-import qualified Data.ByteString.Char8
import qualified Data.ByteString.Lazy
-import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO
import qualified Dhall
import qualified Dhall.JSON
@@ -27,26 +24,30 @@ import qualified Paths_dhall_json as Meta
import qualified System.Exit
import qualified System.IO
-data Options = Options
- { explain :: Bool
- , pretty :: Bool
- , omission :: Value -> Value
- , version :: Bool
- , conversion :: Conversion
- , approximateSpecialDoubles :: Bool
- , file :: Maybe FilePath
- }
+data Options
+ = Options
+ { explain :: Bool
+ , pretty :: Bool
+ , omission :: Value -> Value
+ , conversion :: Conversion
+ , approximateSpecialDoubles :: Bool
+ , file :: Maybe FilePath
+ , output :: Maybe FilePath
+ }
+ | Version
parseOptions :: Parser Options
parseOptions =
- Options
- <$> parseExplain
- <*> parsePretty
- <*> Dhall.JSON.parseOmission
- <*> parseVersion
- <*> Dhall.JSON.parseConversion
- <*> parseApproximateSpecialDoubles
- <*> optional parseFile
+ ( Options
+ <$> parseExplain
+ <*> parsePretty
+ <*> Dhall.JSON.parseOmission
+ <*> Dhall.JSON.parseConversion
+ <*> parseApproximateSpecialDoubles
+ <*> optional parseFile
+ <*> optional parseOutput
+ )
+ <|> parseVersion
where
parseExplain =
Options.switch
@@ -75,7 +76,8 @@ parseOptions =
pure False
parseVersion =
- Options.switch
+ Options.flag'
+ Version
( Options.long "version"
<> Options.help "Display version"
)
@@ -93,6 +95,13 @@ parseOptions =
<> Options.metavar "FILE"
)
+ parseOutput =
+ Options.strOption
+ ( Options.long "output"
+ <> Options.help "Write JSON to a file instead of standard output"
+ <> Options.metavar "FILE"
+ )
+
parserInfo :: ParserInfo Options
parserInfo =
Options.info
@@ -105,41 +114,43 @@ main :: IO ()
main = do
GHC.IO.Encoding.setLocaleEncoding GHC.IO.Encoding.utf8
- Options {..} <- Options.execParser parserInfo
+ options <- Options.execParser parserInfo
- when version $ do
- putStrLn (showVersion Meta.version)
- System.Exit.exitSuccess
+ case options of
+ Version -> do
+ putStrLn (showVersion Meta.version)
- handle $ do
- let config = Data.Aeson.Encode.Pretty.Config
- { Data.Aeson.Encode.Pretty.confIndent = Data.Aeson.Encode.Pretty.Spaces 2
- , Data.Aeson.Encode.Pretty.confCompare = compare
- , Data.Aeson.Encode.Pretty.confNumFormat = Data.Aeson.Encode.Pretty.Generic
- , Data.Aeson.Encode.Pretty.confTrailingNewline = False }
- let encode =
- if pretty
- then Data.Aeson.Encode.Pretty.encodePretty' config
- else Data.Aeson.encode
+ Options {..} -> do
+ handle $ do
+ let config = Data.Aeson.Encode.Pretty.Config
+ { Data.Aeson.Encode.Pretty.confIndent = Data.Aeson.Encode.Pretty.Spaces 2
+ , Data.Aeson.Encode.Pretty.confCompare = compare
+ , Data.Aeson.Encode.Pretty.confNumFormat = Data.Aeson.Encode.Pretty.Generic
+ , Data.Aeson.Encode.Pretty.confTrailingNewline = False }
+ let encode =
+ if pretty
+ then Data.Aeson.Encode.Pretty.encodePretty' config
+ else Data.Aeson.encode
- let explaining = if explain then Dhall.detailed else id
+ let explaining = if explain then Dhall.detailed else id
- let specialDoubleMode =
- if approximateSpecialDoubles
- then ApproximateWithinJSON
- else ForbidWithinJSON
+ let specialDoubleMode =
+ if approximateSpecialDoubles
+ then ApproximateWithinJSON
+ else ForbidWithinJSON
- text <- case file of
- Nothing -> Text.IO.getContents
- Just path -> Text.IO.readFile path
+ 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 file text)
- json <- omission <$> explaining (Dhall.JSON.codeToValue conversion specialDoubleMode path text)
+ let write =
+ case output of
+ Nothing -> Data.ByteString.Lazy.putStr
+ Just file_ -> Data.ByteString.Lazy.writeFile file_
- Data.ByteString.Char8.putStrLn $ Data.ByteString.Lazy.toStrict $ encode json
+ write (encode json <> "\n")
handle :: IO a -> IO a
handle = Control.Exception.handle handler
diff --git a/dhall-to-yaml/Main.hs b/dhall-to-yaml/Main.hs
index bddb5a6..c683b8e 100644
--- a/dhall-to-yaml/Main.hs
+++ b/dhall-to-yaml/Main.hs
@@ -2,7 +2,7 @@
{-# LANGUAGE RecordWildCards #-}
module Main where
-import Control.Applicative (optional)
+import Control.Applicative (optional, (<|>))
import Control.Exception (SomeException)
import Data.Monoid ((<>))
import Dhall.JSON (parseOmission, parseConversion)
@@ -11,22 +11,27 @@ import Options.Applicative (Parser, ParserInfo)
import qualified Control.Exception
import qualified Data.ByteString
-import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO
+import qualified Data.Version
import qualified GHC.IO.Encoding
import qualified Options.Applicative as Options
+import qualified Paths_dhall_json as Meta
import qualified System.Exit
import qualified System.IO
-parseOptions :: Parser Options
+parseOptions :: Parser (Maybe Options)
parseOptions =
- Options
- <$> parseExplain
- <*> Dhall.JSON.parseOmission
- <*> parseDocuments
- <*> parseQuoted
- <*> Dhall.JSON.parseConversion
- <*> optional parseFile
+ Just
+ <$> ( Options
+ <$> parseExplain
+ <*> Dhall.JSON.parseOmission
+ <*> parseDocuments
+ <*> parseQuoted
+ <*> Dhall.JSON.parseConversion
+ <*> optional parseFile
+ <*> optional parseOutput
+ )
+ <|> parseVersion
where
parseExplain =
Options.switch
@@ -41,7 +46,21 @@ parseOptions =
<> Options.metavar "FILE"
)
-parserInfo :: ParserInfo Options
+ parseVersion =
+ Options.flag'
+ Nothing
+ ( Options.long "version"
+ <> Options.help "Display version"
+ )
+
+ parseOutput =
+ Options.strOption
+ ( Options.long "output"
+ <> Options.help "Write YAML to a file instead of standard output"
+ <> Options.metavar "FILE"
+ )
+
+parserInfo :: ParserInfo (Maybe Options)
parserInfo =
Options.info
(Options.helper <*> parseOptions)
@@ -53,18 +72,24 @@ main :: IO ()
main = do
GHC.IO.Encoding.setLocaleEncoding GHC.IO.Encoding.utf8
- options@Options {..} <- Options.execParser parserInfo
+ maybeOptions <- Options.execParser parserInfo
+
+ case maybeOptions of
+ Nothing -> do
+ putStrLn (Data.Version.showVersion Meta.version)
- handle $ do
- contents <- case file of
- Nothing -> Text.IO.getContents
- Just path -> Text.IO.readFile path
+ Just options@(Options {..}) -> do
+ handle $ do
+ contents <- 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
+ let write =
+ case output of
+ Nothing -> Data.ByteString.putStr
+ Just file_ -> Data.ByteString.writeFile file_
- Data.ByteString.putStr =<< dhallToYaml options path contents
+ write =<< dhallToYaml options file contents
handle :: IO a -> IO a
handle = Control.Exception.handle handler
diff --git a/json-to-dhall/Main.hs b/json-to-dhall/Main.hs
index 12b6ca1..07d790a 100644
--- a/json-to-dhall/Main.hs
+++ b/json-to-dhall/Main.hs
@@ -8,9 +8,8 @@
module Main where
-import Control.Applicative (optional)
+import Control.Applicative (optional, (<|>))
import Control.Exception (SomeException, throwIO)
-import Control.Monad (when)
import Data.Monoid ((<>))
import Data.Text (Text)
import Data.Version (showVersion)
@@ -24,6 +23,7 @@ import qualified Data.ByteString.Lazy.Char8 as ByteString
import qualified Data.Text.IO as Text.IO
import qualified Data.Text.Prettyprint.Doc as Pretty
import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty.Terminal
+import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty.Text
import qualified GHC.IO.Encoding
import qualified Options.Applicative as Options
import qualified System.Console.ANSI as ANSI
@@ -45,23 +45,30 @@ parserInfo = Options.info
)
-- | All the command arguments and options
-data Options = Options
- { version :: Bool
- , schema :: Text
- , conversion :: Conversion
- , file :: Maybe FilePath
- , ascii :: Bool
- , plain :: Bool
- } deriving Show
+data Options
+ = Options
+ { schema :: Text
+ , conversion :: Conversion
+ , file :: Maybe FilePath
+ , output :: Maybe FilePath
+ , ascii :: Bool
+ , plain :: Bool
+ }
+ | Version
+ deriving Show
-- | Parser for all the command arguments and options
parseOptions :: Parser Options
-parseOptions = Options <$> parseVersion
- <*> parseSchema
- <*> parseConversion
- <*> optional parseFile
- <*> parseASCII
- <*> parsePlain
+parseOptions =
+ ( Options
+ <$> parseSchema
+ <*> parseConversion
+ <*> optional parseFile
+ <*> optional parseOutput
+ <*> parseASCII
+ <*> parsePlain
+ )
+ <|> parseVersion
where
parseSchema =
Options.strArgument
@@ -70,7 +77,8 @@ parseOptions = Options <$> parseVersion
)
parseVersion =
- Options.switch
+ Options.flag'
+ Version
( Options.long "version"
<> Options.short 'V'
<> Options.help "Display version"
@@ -83,6 +91,13 @@ parseOptions = Options <$> parseVersion
<> Options.metavar "FILE"
)
+ parseOutput =
+ Options.strOption
+ ( Options.long "output"
+ <> Options.help "Write Dhall expression to a file instead of standard output"
+ <> Options.metavar "FILE"
+ )
+
parseASCII =
Options.switch
( Options.long "ascii"
@@ -103,45 +118,54 @@ main :: IO ()
main = do
GHC.IO.Encoding.setLocaleEncoding GHC.IO.Encoding.utf8
- Options {..} <- Options.execParser parserInfo
+ options <- Options.execParser parserInfo
+
+ case options of
+ Version -> do
+ putStrLn (showVersion Meta.version)
+
+ Options {..} -> do
+ let characterSet = case ascii of
+ True -> ASCII
+ False -> Unicode
- let characterSet = case ascii of
- True -> ASCII
- False -> Unicode
+ handle $ do
+ bytes <- case file of
+ Nothing -> ByteString.getContents
+ Just path -> ByteString.readFile path
- when version $ do
- putStrLn (showVersion Meta.version)
- System.Exit.exitSuccess
+ value :: Aeson.Value <- case Aeson.eitherDecode bytes of
+ Left err -> throwIO (userError err)
+ Right v -> pure v
- handle $ do
- bytes <- case file of
- Nothing -> ByteString.getContents
- Just path -> ByteString.readFile path
+ expr <- typeCheckSchemaExpr id =<< resolveSchemaExpr schema
- value :: Aeson.Value <- case Aeson.eitherDecode bytes of
- Left err -> throwIO (userError err)
- Right v -> pure v
+ result <- case dhallFromJSON conversion expr value of
+ Left err -> throwIO err
+ Right result -> return result
- expr <- typeCheckSchemaExpr id =<< resolveSchemaExpr schema
+ let document = Dhall.Pretty.prettyCharacterSet characterSet result
- result <- case dhallFromJSON conversion expr value of
- Left err -> throwIO err
- Right result -> return result
+ let stream = Pretty.layoutSmart Dhall.Pretty.layoutOpts document
- let document = Dhall.Pretty.prettyCharacterSet characterSet result
+ case output of
+ Nothing -> do
+ supportsANSI <- ANSI.hSupportsANSI IO.stdout
- let stream = Pretty.layoutSmart Dhall.Pretty.layoutOpts document
+ let ansiStream =
+ if supportsANSI && not plain
+ then fmap Dhall.Pretty.annToAnsiStyle stream
+ else Pretty.unAnnotateS stream
- supportsANSI <- ANSI.hSupportsANSI IO.stdout
+ Pretty.Terminal.renderIO IO.stdout ansiStream
- let ansiStream =
- if supportsANSI && not plain
- then fmap Dhall.Pretty.annToAnsiStyle stream
- else Pretty.unAnnotateS stream
+ Text.IO.putStrLn ""
- Pretty.Terminal.renderIO IO.stdout ansiStream
+ Just file_ ->
+ IO.withFile file_ IO.WriteMode $ \h -> do
+ Pretty.Text.renderIO h stream
- Text.IO.putStrLn ""
+ Text.IO.hPutStrLn h ""
handle :: IO a -> IO a
handle = Control.Exception.handle handler
diff --git a/src/Dhall/JSON.hs b/src/Dhall/JSON.hs
index 79eb216..28c1c8b 100644
--- a/src/Dhall/JSON.hs
+++ b/src/Dhall/JSON.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
@@ -72,22 +73,17 @@
Dhall unions translate to the wrapped value:
-> $ dhall-to-json <<< "< Left = +2 | Right : Natural>"
+> $ dhall-to-json <<< "< Left : Natural | Right : Natural>.Left 2"
> 2
> $ cat config
-> [ < Person = { age = 47, name = "John" }
-> | Place : { location : Text }
-> >
-> , < Place = { location = "North Pole" }
-> | Person : { age : Natural, name : Text }
-> >
-> , < Place = { location = "Sahara Desert" }
-> | Person : { age : Natural, name : Text }
-> >
-> , < Person = { age = 35, name = "Alice" }
-> | Place : { location : Text }
-> >
-> ]
+> let MyType =
+> < Person : { age : Natural, name : Text } | Place : { location : Text } >
+>
+> in [ MyType.Person { age = 47, name = "John" }
+> , MyType.Place { location = "North Pole" }
+> , MyType.Place { location = "Sahara Desert" }
+> , MyType.Person { age = 35, name = "Alice" }
+> ]
> $ dhall-to-json <<< "./config"
> [{"age":47,"name":"John"},{"location":"North Pole"},{"location":"Sahara Desert"},{"age":35,"name":"Alice"}]
@@ -107,10 +103,10 @@
> let Example = < Left : { foo : Natural } | Right : { bar : Bool } >
>
-> let Nesting = < Inline : {} | Nested : Text >
+> let Nesting = < Inline | Nested : Text >
>
> in { field = "name"
-> , nesting = Nesting.Inline {=}
+> , nesting = Nesting.Inline
> , contents = Example.Left { foo = 2 }
> }
@@ -121,7 +117,7 @@
> "name": "Left"
> }
- If @nesting@ is set to @Nested nestedField@ then the union is store
+ If @nesting@ is set to @Nested nestedField@ then the union is stored
underneath a field named @nestedField@. For example, this code:
> let Example = < Left : { foo : Natural } | Right : { bar : Bool } >
@@ -188,28 +184,38 @@ import Control.Applicative (empty, (<|>))
import Control.Monad (guard)
import Control.Exception (Exception, throwIO)
import Data.Aeson (Value(..), ToJSON(..))
+import Data.Maybe (fromMaybe)
import Data.Monoid ((<>), mempty)
import Data.Text (Text)
-import Dhall.Core (Expr)
+import Data.Text.Prettyprint.Doc (Pretty)
+import Dhall.Core (Binding(..), Expr)
+import Dhall.Import (SemanticCacheMode(..))
import Dhall.TypeCheck (X)
import Dhall.Map (Map)
import Dhall.JSON.Util (pattern V)
import Options.Applicative (Parser)
+import Prelude hiding (getContents)
-import qualified Data.Aeson as Aeson
-import qualified Data.Foldable as Foldable
-import qualified Data.HashMap.Strict as HashMap
+import qualified Data.Aeson as Aeson
+import qualified Data.Foldable as Foldable
+import qualified Data.HashMap.Strict as HashMap
import qualified Data.List
+import qualified Data.Map
import qualified Data.Ord
import qualified Data.Text
-import qualified Data.Vector as Vector
-import qualified Dhall.Core as Core
+import qualified Data.Text.Prettyprint.Doc as Pretty
+import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty
+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.Pretty
import qualified Dhall.TypeCheck
+import qualified Dhall.Util
import qualified Options.Applicative
+import qualified System.FilePath
{-| This is the exception type for errors that might arise when translating
Dhall to JSON
@@ -221,6 +227,7 @@ data CompileError
= Unsupported (Expr X X)
| SpecialDouble Double
| BareNone
+ | InvalidInlineContents (Expr X X) (Expr X X)
instance Show CompileError where
show BareNone =
@@ -249,7 +256,7 @@ instance Show CompileError where
show (SpecialDouble n) =
Data.Text.unpack $
- _ERROR <> ": " <> special <> " disallowed in JSON \n\
+ _ERROR <> ": " <> special <> " disallowed in JSON \n\
\ \n\
\Explanation: The JSON standard does not define a canonical way to encode \n\
\❰NaN❱/❰Infinity❱/❰-Infinity❱. You can fix this error by either: \n\
@@ -275,12 +282,88 @@ instance Show CompileError where
\ \n\
\The following Dhall expression could not be translated to JSON: \n\
\ \n\
- \↳ " <> txt <> " "
- where
- txt = Core.pretty e
+ \" <> insert e
+
+ show (InvalidInlineContents record alternativeContents) =
+ Data.Text.unpack $
+ _ERROR <> ": Union value is not compatible with ❰Inline❱ nesting. \n\
+ \ \n\
+ \Explanation: You can use the ❰Inline❱ nesting to compactly encode a union while \n\
+ \preserving the name of the alternative. However the alternative must either be \n\
+ \empty or contain a record value. \n\
+ \ \n\
+ \For example: \n\
+ \ \n\
+ \ \n\
+ \ ┌─────────────────────────────────────────────────┐ \n\
+ \ │ let Example = < Empty | Record : { x : Bool } > │ \n\
+ \ │ │ \n\
+ \ │ let Nesting = < Inline | Nested : Text > │ \n\
+ \ │ │ \n\
+ \ │ in { field = \"name\" │ \n\
+ \ │ , nesting = Nesting.Inline │ \n\
+ \ │ , contents = Example.Empty │ An empty alternative \n\
+ \ │ } │ is ok. \n\
+ \ └─────────────────────────────────────────────────┘ \n\
+ \ \n\
+ \ \n\
+ \... is converted to this JSON: \n\
+ \ \n\
+ \ \n\
+ \ ┌─────────────────────┐ \n\
+ \ │ { \"name\": \"Empty\" } │ \n\
+ \ └─────────────────────┘ \n\
+ \ \n\
+ \ \n\
+ \ ┌──────────────────────────────────────────────┐ \n\
+ \ │ ... │ \n\
+ \ │ │ \n\
+ \ │ in { field = \"name\" │ \n\
+ \ │ , nesting = Nesting.Inline │ \n\
+ \ │ , contents = Example.Record { x = True } │ An alternative containing \n\
+ \ │ } │ a record value is ok. \n\
+ \ └──────────────────────────────────────────────┘ \n\
+ \ \n\
+ \ \n\
+ \... is converted to this JSON: \n\
+ \ \n\
+ \ \n\
+ \ ┌─────────────────────────────────┐ \n\
+ \ │ { \"name\": \"Record\", \"x\": true } │ \n\
+ \ └─────────────────────────────────┘ \n\
+ \ \n\
+ \ \n\
+ \This isn't valid: \n\
+ \ \n\
+ \ \n\
+ \ ┌──────────────────────────────────────────┐ \n\
+ \ │ let Example = < Foo : Bool > │ \n\
+ \ │ │ \n\
+ \ │ let Nesting = < Inline | Nested : Text > │ \n\
+ \ │ │ \n\
+ \ │ in { field = \"name\" │ \n\
+ \ │ , nesting = Nesting.Inline │ \n\
+ \ │ , contents = Example.Foo True │ ❰True❱ is not a record \n\
+ \ │ } │ \n\
+ \ └──────────────────────────────────────────┘ \n\
+ \ \n\
+ \ \n\
+ \The following Dhall expression could not be translated to JSON: \n\
+ \ \n\
+ \" <> insert record <> " \n\
+ \ \n\
+ \... because \n\
+ \ \n\
+ \" <> insert alternativeContents <> " \n\
+ \ \n\
+ \... is not a record."
_ERROR :: Data.Text.Text
-_ERROR = "\ESC[1;31mError\ESC[0m"
+_ERROR = Dhall.Util._ERROR
+
+insert :: Pretty a => a -> Text
+insert =
+ Pretty.renderStrict . Pretty.layoutPretty Dhall.Pretty.layoutOpts . Dhall.Util.insert
instance Exception CompileError
@@ -322,12 +405,7 @@ dhallToJSON e0 = loop (Core.alphaNormalize (Core.normalize e0))
Core.RecordLit a ->
case toOrderedList a of
[ ( "contents"
- , Core.App
- (Core.Field
- _
- alternativeName
- )
- contents
+ , contents
)
, ( "field"
, Core.TextLit
@@ -347,28 +425,26 @@ dhallToJSON e0 = loop (Core.alphaNormalize (Core.normalize e0))
(Core.Chunks [] nestedField)
)
)
- ] | all (== Core.Record []) mInlineType -> do
- contents' <- loop contents
-
- let taggedValue =
- Dhall.Map.fromList
- [ ( field
- , toJSON alternativeName
- )
- , ( nestedField
- , contents'
- )
- ]
-
- return (Aeson.toJSON ( Dhall.Map.toMap taggedValue ))
+ ] | all (== Core.Record []) mInlineType
+ , Just (alternativeName, mExpr) <- getContents contents -> do
+ contents' <- case mExpr of
+ Just expr -> loop expr
+ Nothing -> return Aeson.Null
+
+ let taggedValue =
+ Data.Map.fromList
+ [ ( field
+ , toJSON alternativeName
+ )
+ , ( nestedField
+ , contents'
+ )
+ ]
+
+ return (Aeson.toJSON taggedValue)
[ ( "contents"
- , Core.App
- (Core.Field
- _
- alternativeName
- )
- (Core.RecordLit contents)
+ , contents
)
, ( "field"
, Core.TextLit
@@ -377,23 +453,23 @@ dhallToJSON e0 = loop (Core.alphaNormalize (Core.normalize e0))
, ( "nesting"
, nesting
)
- ] | isInlineNesting nesting -> do
- let contents' =
- Dhall.Map.insert
- field
- (Core.TextLit
- (Core.Chunks
- []
- alternativeName
- )
- )
- contents
+ ] | isInlineNesting nesting
+ , Just (alternativeName, mExpr) <- getContents contents -> do
+ kvs0 <- case mExpr of
+ Just (Core.RecordLit kvs) -> return kvs
+ Just alternativeContents ->
+ Left (InvalidInlineContents e alternativeContents)
+ Nothing -> return mempty
+
+ let name = Core.TextLit (Core.Chunks [] alternativeName)
+
+ let kvs1 = Dhall.Map.insert field name kvs0
+
+ loop (Core.RecordLit kvs1)
- loop (Core.RecordLit contents')
_ -> do
a' <- traverse loop a
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)
@@ -436,6 +512,17 @@ dhallToJSON e0 = loop (Core.alphaNormalize (Core.normalize e0))
outer value
_ -> Left (Unsupported e)
+getContents :: Expr s X -> Maybe (Text, Maybe (Expr s X))
+getContents (Core.App
+ (Core.Field
+ _
+ alternativeName
+ )
+ expression
+ ) = Just (alternativeName, Just expression)
+getContents (Core.Field _ alternativeName) = Just (alternativeName, Nothing)
+getContents _ = Nothing
+
isInlineNesting :: Expr s X -> Bool
isInlineNesting (Core.App
(Core.Field
@@ -563,17 +650,12 @@ convertToHomogeneousMaps (Conversion {..}) e0 = loop (Core.normalize e0)
a' = loop a
b' = loop b
- Core.Let as b ->
- Core.Let as' b'
+ Core.Let (Binding src0 a src1 b src2 c) d ->
+ Core.Let (Binding src0 a src1 b' src2 c') d'
where
- f (Core.Binding x y z) = Core.Binding x y' z'
- where
- y' = fmap loop y
- z' = loop z
-
- as' = fmap f as
-
- b' = loop b
+ b' = fmap (fmap loop) b
+ c' = loop c
+ d' = loop d
Core.Annot a b ->
Core.Annot a' b'
@@ -645,6 +727,9 @@ convertToHomogeneousMaps (Conversion {..}) e0 = loop (Core.normalize e0)
Core.NaturalShow ->
Core.NaturalShow
+ Core.NaturalSubtract ->
+ Core.NaturalSubtract
+
Core.NaturalPlus a b ->
Core.NaturalPlus a' b'
where
@@ -808,12 +893,6 @@ convertToHomogeneousMaps (Conversion {..}) e0 = loop (Core.normalize e0)
where
a' = fmap (fmap loop) a
- Core.UnionLit a b c ->
- Core.UnionLit a b' c'
- where
- b' = loop b
- c' = fmap (fmap loop) c
-
Core.Combine a b ->
Core.Combine a' b'
where
@@ -855,6 +934,17 @@ convertToHomogeneousMaps (Conversion {..}) e0 = loop (Core.normalize e0)
where
a' = loop a
+ Core.Assert a ->
+ Core.Assert a'
+ where
+ a' = loop a
+
+ Core.Equivalent a b ->
+ Core.Equivalent a' b'
+ where
+ a' = loop a
+ b' = loop b
+
Core.ImportAlt a b ->
Core.ImportAlt a' b'
where
@@ -960,13 +1050,18 @@ handleSpecialDoubles specialDoubleMode =
codeToValue
:: Conversion
-> SpecialDoubleMode
- -> Text -- ^ Describe the input for the sake of error location.
+ -> Maybe FilePath -- ^ The source file path. If no path is given, imports
+ -- are resolved relative to the current directory.
-> Text -- ^ Input text.
-> IO Value
-codeToValue conversion specialDoubleMode name code = do
- parsedExpression <- Core.throws (Dhall.Parser.exprFromText (Data.Text.unpack name) code)
+codeToValue conversion specialDoubleMode mFilePath code = do
+ parsedExpression <- Core.throws (Dhall.Parser.exprFromText (fromMaybe "(stdin)" mFilePath) code)
+
+ let rootDirectory = case mFilePath of
+ Nothing -> "."
+ Just fp -> System.FilePath.takeDirectory fp
- resolvedExpression <- Dhall.Import.load parsedExpression
+ resolvedExpression <- Dhall.Import.loadRelativeTo rootDirectory UseSemanticCache parsedExpression
_ <- Core.throws (Dhall.TypeCheck.typeOf resolvedExpression)
diff --git a/src/Dhall/JSONToDhall.hs b/src/Dhall/JSONToDhall.hs
index f3ebb21..c91b43c 100644
--- a/src/Dhall/JSONToDhall.hs
+++ b/src/Dhall/JSONToDhall.hs
@@ -236,7 +236,6 @@ 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(..))
import qualified Dhall.Import
@@ -257,10 +256,17 @@ parseConversion = Conversion <$> parseStrict
<*> parseKVMap
<*> parseUnion
where
- parseStrict = O.switch
- ( O.long "records-strict"
- <> O.help "Parse all fields in records"
- )
+ parseStrict =
+ O.flag' True
+ ( O.long "records-strict"
+ <> O.help "Fail if any YAML fields are missing from the expected Dhall type"
+ )
+ <|> O.flag' False
+ ( O.long "records-loose"
+ <> O.help "Tolerate YAML fields not present within the expected Dhall type"
+ )
+ <|> pure True
+
parseKVArr = O.switch
( O.long "no-keyval-arrays"
<> O.help "Disable conversion of key-value arrays to records"
@@ -448,7 +454,7 @@ dhallFromJSON (Conversion {..}) expressionType =
let records = (fmap f . Seq.fromList . HM.toList) keyExprMap
- let typeAnn = if HM.null o then Just mapValue else Nothing
+ let typeAnn = if HM.null o then Just t else Nothing
return (D.ListLit typeAnn records)
| noKeyValMap
@@ -460,7 +466,7 @@ dhallFromJSON (Conversion {..}) expressionType =
loop (App D.List t) (A.Array a)
= let f :: [ExprX] -> ExprX
f es = D.ListLit
- (if null es then Just t else Nothing)
+ (if null es then Just (App D.List t) else Nothing)
(Seq.fromList es)
in f <$> traverse (loop t) (toList a)
@@ -473,9 +479,9 @@ dhallFromJSON (Conversion {..}) expressionType =
-- number ~> Natural
loop D.Natural (A.Number x)
- | Right n <- floatingOrInteger x :: Either Double Dhall.Natural
+ | Right n <- floatingOrInteger x :: Either Double Integer
, n >= 0
- = Right (D.NaturalLit n)
+ = Right (D.NaturalLit (fromInteger n))
| otherwise
= Left (Mismatch D.Natural (A.Number x))
@@ -527,7 +533,7 @@ dhallFromJSON (Conversion {..}) expressionType =
elementType
| null elements =
- Just (D.Record [ ("mapKey", D.Text), ("mapValue", "JSON") ])
+ Just (D.App D.List (D.Record [ ("mapKey", D.Text), ("mapValue", "JSON") ]))
| otherwise =
Nothing
@@ -538,7 +544,7 @@ dhallFromJSON (Conversion {..}) expressionType =
let elements = Seq.fromList (fmap outer (Vector.toList a))
elementType
- | null elements = Just "JSON"
+ | null elements = Just (D.App D.List "JSON")
| otherwise = Nothing
in D.App (D.Field "json" "array") (D.ListLit elementType elements)
@@ -631,15 +637,15 @@ showCompileError format showValue = let prefix = red "\nError: "
UndecidableUnion e v xs -> prefix
<> "More than one union component type matches " <> format <> " value"
- <> "\n\nDhall:\n" <> showExpr e
+ <> "\n\nExpected Dhall type:\n" <> showExpr e
<> "\n\n" <> format <> ":\n" <> showValue v
<> "\n\nPossible matches:\n\n" -- Showing all the allowed matches
<> Text.unpack (Text.intercalate sep $ D.pretty <$> xs)
where sep = red "\n--------\n" :: Text
Mismatch e v -> prefix
- <> "Dhall type expression and json value do not match:"
- <> "\n\nDhall:\n" <> showExpr e
+ <> "Dhall type expression and " <> format <> " value do not match:"
+ <> "\n\nExpected Dhall type:\n" <> showExpr e
<> "\n\n" <> format <> ":\n" <> showValue v
<> "\n"
@@ -651,22 +657,22 @@ showCompileError format showValue = let prefix = red "\nError: "
UnhandledKeys ks e v -> prefix
<> "Key(s) " <> purple (Text.unpack (Text.intercalate ", " ks))
- <> " present in the " <> format <> " object but not in the corresponding Dhall record. This is not allowed in presence of "
- <> green "--records-strict" <> " flag:"
- <> "\n\nDhall:\n" <> showExpr e
+ <> " present in the " <> format <> " object but not in the expected Dhall record type. This is not allowed unless you enable the "
+ <> green "--records-loose" <> " flag:"
+ <> "\n\nExpected Dhall type:\n" <> showExpr e
<> "\n\n" <> format <> ":\n" <> showValue v
<> "\n"
NoKeyValArray e v -> prefix
<> "" <> format <> " (key-value) arrays cannot be converted to Dhall records under "
<> green "--no-keyval-arrays" <> " flag"
- <> "\n\nDhall:\n" <> showExpr e
+ <> "\n\nExpected Dhall type:\n" <> showExpr e
<> "\n\n" <> format <> ":\n" <> showValue v
<> "\n"
NoKeyValMap e v -> prefix
<> "Homogeneous " <> format <> " map objects cannot be converted to Dhall association lists under "
<> green "--no-keyval-arrays" <> " flag"
- <> "\n\nDhall:\n" <> showExpr e
+ <> "\n\nExpected Dhall type:\n" <> showExpr e
<> "\n\n" <> format <> ":\n" <> showValue v
<> "\n"
diff --git a/src/Dhall/Yaml.hs b/src/Dhall/Yaml.hs
index 50abf6d..f110ea2 100644
--- a/src/Dhall/Yaml.hs
+++ b/src/Dhall/Yaml.hs
@@ -38,6 +38,7 @@ data Options = Options
, quoted :: Bool
, conversion :: Conversion
, file :: Maybe FilePath
+ , output :: Maybe FilePath
}
defaultOptions :: Options
@@ -48,6 +49,7 @@ defaultOptions =
, quoted = False
, conversion = NoConversion
, file = Nothing
+ , output = Nothing
}
parseDocuments :: Parser Bool
@@ -68,14 +70,15 @@ parseQuoted =
-}
dhallToYaml
:: Options
- -> Text -- ^ Describe the input for the sake of error location.
+ -> Maybe FilePath -- ^ The source file path. If no path is given, imports
+ -- are resolved relative to the current directory.
-> Text -- ^ Input text.
-> IO ByteString
-dhallToYaml Options{..} name code = do
+dhallToYaml Options{..} mFilePath code = do
let explaining = if explain then Dhall.detailed else id
- json <- omission <$> explaining (codeToValue conversion UseYAMLEncoding name code)
+ json <- omission <$> explaining (codeToValue conversion UseYAMLEncoding mFilePath code)
return $ jsonToYaml json documents quoted
diff --git a/tasty/Main.hs b/tasty/Main.hs
index 766f4aa..fc35998 100644
--- a/tasty/Main.hs
+++ b/tasty/Main.hs
@@ -11,7 +11,6 @@ import Test.Tasty (TestTree)
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
@@ -20,11 +19,15 @@ import qualified Dhall.JSONToDhall as JSONToDhall
import qualified Dhall.Parser
import qualified Dhall.TypeCheck
import qualified Dhall.Yaml
+import qualified GHC.IO.Encoding
import qualified Test.Tasty
import qualified Test.Tasty.HUnit
main :: IO ()
-main = Test.Tasty.defaultMain testTree
+main = do
+ GHC.IO.Encoding.setLocaleEncoding GHC.IO.Encoding.utf8
+
+ Test.Tasty.defaultMain testTree
testTree :: TestTree
testTree =
@@ -37,9 +40,15 @@ testTree =
(Dhall.Yaml.defaultOptions { Dhall.Yaml.quoted = True })
"./tasty/data/quoted"
, testJSONToDhall "./tasty/data/emptyAlternative"
+ , testJSONToDhall "./tasty/data/emptyObject"
+ , testJSONToDhall "./tasty/data/emptyList"
+ , testJSONToDhall "./tasty/data/emptyObjectStrongType"
+ , testJSONToDhall "./tasty/data/emptyListStrongType"
, Test.Tasty.testGroup "Nesting"
[ testDhallToJSON "./tasty/data/nesting0"
, testDhallToJSON "./tasty/data/nesting1"
+ , testDhallToJSON "./tasty/data/nesting2"
+ , testDhallToJSON "./tasty/data/nesting3"
, testDhallToJSON "./tasty/data/nestingLegacy0"
, testDhallToJSON "./tasty/data/nestingLegacy1"
]
@@ -131,7 +140,7 @@ testDhallToYaml options prefix = Test.Tasty.HUnit.testCase prefix $ do
text <- Data.Text.IO.readFile inputFile
actualValue <- do
- Dhall.Yaml.dhallToYaml options (Data.Text.pack inputFile) text
+ Dhall.Yaml.dhallToYaml options (Just inputFile) text
expectedValue <- Data.ByteString.readFile outputFile
diff --git a/tasty/data/emptyList.dhall b/tasty/data/emptyList.dhall
new file mode 100644
index 0000000..f94e0f9
--- /dev/null
+++ b/tasty/data/emptyList.dhall
@@ -0,0 +1,17 @@
+ λ(JSON : Type)
+→ λ ( json
+ : { array :
+ List JSON → JSON
+ , bool :
+ Bool → JSON
+ , null :
+ JSON
+ , number :
+ Double → JSON
+ , object :
+ List { mapKey : Text, mapValue : JSON } → JSON
+ , string :
+ Text → JSON
+ }
+ )
+→ json.array ([] : List JSON)
diff --git a/tasty/data/emptyList.json b/tasty/data/emptyList.json
new file mode 100644
index 0000000..fe51488
--- /dev/null
+++ b/tasty/data/emptyList.json
@@ -0,0 +1 @@
+[]
diff --git a/tasty/data/emptyListSchema.dhall b/tasty/data/emptyListSchema.dhall
new file mode 100644
index 0000000..c7e5c09
--- /dev/null
+++ b/tasty/data/emptyListSchema.dhall
@@ -0,0 +1,17 @@
+ ∀(JSON : Type)
+→ ∀ ( json
+ : { array :
+ List JSON → JSON
+ , bool :
+ Bool → JSON
+ , null :
+ JSON
+ , number :
+ Double → JSON
+ , object :
+ List { mapKey : Text, mapValue : JSON } → JSON
+ , string :
+ Text → JSON
+ }
+ )
+→ JSON
diff --git a/tasty/data/emptyListStrongType.dhall b/tasty/data/emptyListStrongType.dhall
new file mode 100644
index 0000000..df05bac
--- /dev/null
+++ b/tasty/data/emptyListStrongType.dhall
@@ -0,0 +1 @@
+[] : List Natural
diff --git a/tasty/data/emptyListStrongType.json b/tasty/data/emptyListStrongType.json
new file mode 100644
index 0000000..fe51488
--- /dev/null
+++ b/tasty/data/emptyListStrongType.json
@@ -0,0 +1 @@
+[]
diff --git a/tasty/data/emptyListStrongTypeSchema.dhall b/tasty/data/emptyListStrongTypeSchema.dhall
new file mode 100644
index 0000000..e786a26
--- /dev/null
+++ b/tasty/data/emptyListStrongTypeSchema.dhall
@@ -0,0 +1 @@
+List Natural
diff --git a/tasty/data/emptyObject.dhall b/tasty/data/emptyObject.dhall
new file mode 100644
index 0000000..4654ae1
--- /dev/null
+++ b/tasty/data/emptyObject.dhall
@@ -0,0 +1,17 @@
+ λ(JSON : Type)
+→ λ ( json
+ : { array :
+ List JSON → JSON
+ , bool :
+ Bool → JSON
+ , null :
+ JSON
+ , number :
+ Double → JSON
+ , object :
+ List { mapKey : Text, mapValue : JSON } → JSON
+ , string :
+ Text → JSON
+ }
+ )
+→ json.object ([] : List { mapKey : Text, mapValue : JSON })
diff --git a/tasty/data/emptyObject.json b/tasty/data/emptyObject.json
new file mode 100644
index 0000000..0967ef4
--- /dev/null
+++ b/tasty/data/emptyObject.json
@@ -0,0 +1 @@
+{}
diff --git a/tasty/data/emptyObjectSchema.dhall b/tasty/data/emptyObjectSchema.dhall
new file mode 100644
index 0000000..c7e5c09
--- /dev/null
+++ b/tasty/data/emptyObjectSchema.dhall
@@ -0,0 +1,17 @@
+ ∀(JSON : Type)
+→ ∀ ( json
+ : { array :
+ List JSON → JSON
+ , bool :
+ Bool → JSON
+ , null :
+ JSON
+ , number :
+ Double → JSON
+ , object :
+ List { mapKey : Text, mapValue : JSON } → JSON
+ , string :
+ Text → JSON
+ }
+ )
+→ JSON
diff --git a/tasty/data/emptyObjectStrongType.dhall b/tasty/data/emptyObjectStrongType.dhall
new file mode 100644
index 0000000..05d70a8
--- /dev/null
+++ b/tasty/data/emptyObjectStrongType.dhall
@@ -0,0 +1 @@
+[] : List { mapKey : Text, mapValue : Natural }
diff --git a/tasty/data/emptyObjectStrongType.json b/tasty/data/emptyObjectStrongType.json
new file mode 100644
index 0000000..0967ef4
--- /dev/null
+++ b/tasty/data/emptyObjectStrongType.json
@@ -0,0 +1 @@
+{}
diff --git a/tasty/data/emptyObjectStrongTypeSchema.dhall b/tasty/data/emptyObjectStrongTypeSchema.dhall
new file mode 100644
index 0000000..4a9542d
--- /dev/null
+++ b/tasty/data/emptyObjectStrongTypeSchema.dhall
@@ -0,0 +1 @@
+List { mapKey : Text, mapValue : Natural }
diff --git a/tasty/data/nesting2.dhall b/tasty/data/nesting2.dhall
new file mode 100644
index 0000000..7c98ab1
--- /dev/null
+++ b/tasty/data/nesting2.dhall
@@ -0,0 +1,8 @@
+let Example = < Left : { foo : Natural } | Middle | Right : { bar : Bool } >
+
+let Nesting = < Inline | Nested : Text >
+
+in { field = "name"
+ , nesting = Nesting.Inline
+ , contents = Example.Middle
+ }
diff --git a/tasty/data/nesting2.json b/tasty/data/nesting2.json
new file mode 100644
index 0000000..f616cf9
--- /dev/null
+++ b/tasty/data/nesting2.json
@@ -0,0 +1 @@
+{ "name": "Middle" }
diff --git a/tasty/data/nesting3.dhall b/tasty/data/nesting3.dhall
new file mode 100644
index 0000000..45c366e
--- /dev/null
+++ b/tasty/data/nesting3.dhall
@@ -0,0 +1,8 @@
+let Example = < Left : { foo : Natural } | Middle | Right : { bar : Bool } >
+
+let Nesting = < Inline | Nested : Text >
+
+in { field = "name"
+ , nesting = Nesting.Nested "value"
+ , contents = Example.Middle
+ }
diff --git a/tasty/data/nesting3.json b/tasty/data/nesting3.json
new file mode 100644
index 0000000..7b7176d
--- /dev/null
+++ b/tasty/data/nesting3.json
@@ -0,0 +1 @@
+{ "name": "Middle", "value": null }
diff --git a/tasty/data/normal.dhall b/tasty/data/normal.dhall
index 1eeedf7..e535136 100644
--- a/tasty/data/normal.dhall
+++ b/tasty/data/normal.dhall
@@ -1,5 +1,5 @@
{ string_value = "2000-01-01"
-, text = ./tasty/data/yaml.txt as Text
+, text = ./yaml.txt as Text
, int_value = 1
, bool_value = True
}
diff --git a/tasty/data/quoted.dhall b/tasty/data/quoted.dhall
index 1eeedf7..e535136 100644
--- a/tasty/data/quoted.dhall
+++ b/tasty/data/quoted.dhall
@@ -1,5 +1,5 @@
{ string_value = "2000-01-01"
-, text = ./tasty/data/yaml.txt as Text
+, text = ./yaml.txt as Text
, int_value = 1
, bool_value = True
}
diff --git a/yaml-to-dhall/Main.hs b/yaml-to-dhall/Main.hs
index 8276643..417140a 100644
--- a/yaml-to-dhall/Main.hs
+++ b/yaml-to-dhall/Main.hs
@@ -8,9 +8,8 @@
module Main where
-import Control.Applicative (optional)
+import Control.Applicative (optional, (<|>))
import Control.Exception (SomeException)
-import Control.Monad (when)
import Data.Monoid ((<>))
import Data.Text (Text)
import Data.Version (showVersion)
@@ -24,6 +23,7 @@ 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 Data.Text.Prettyprint.Doc.Render.Text as Pretty.Text
import qualified Dhall.Pretty
import qualified GHC.IO.Encoding
import qualified Options.Applicative as Options
@@ -36,14 +36,17 @@ import qualified Paths_dhall_json as Meta
-- Command options
-- ---------------
-data CommandOptions = CommandOptions
- { version :: Bool
- , schema :: Text
- , conversion :: Conversion
- , file :: Maybe FilePath
- , ascii :: Bool
- , plain :: Bool
- } deriving Show
+data CommandOptions
+ = CommandOptions
+ { schema :: Text
+ , conversion :: Conversion
+ , file :: Maybe FilePath
+ , output :: Maybe FilePath
+ , ascii :: Bool
+ , plain :: Bool
+ }
+ | Version
+ deriving (Show)
-- | Command info and description
parserInfo :: ParserInfo CommandOptions
@@ -53,16 +56,18 @@ parserInfo = Options.info
<> 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 CommandOptions
-parseOptions = CommandOptions <$> parseVersion
- <*> parseSchema
- <*> parseConversion
- <*> optional parseFile
- <*> parseASCII
- <*> parsePlain
+parseOptions =
+ ( CommandOptions
+ <$> parseSchema
+ <*> parseConversion
+ <*> optional parseFile
+ <*> optional parseOutput
+ <*> parseASCII
+ <*> parsePlain
+ )
+ <|> parseVersion
where
parseSchema =
Options.strArgument
@@ -71,7 +76,8 @@ parseOptions = CommandOptions <$> parseVersion
)
parseVersion =
- Options.switch
+ Options.flag'
+ Version
( Options.long "version"
<> Options.short 'V'
<> Options.help "Display version"
@@ -84,6 +90,13 @@ parseOptions = CommandOptions <$> parseVersion
<> Options.metavar "FILE"
)
+ parseOutput =
+ Options.strOption
+ ( Options.long "output"
+ <> Options.help "Write Dhall expression to a file instead of standard output"
+ <> Options.metavar "FILE"
+ )
+
parseASCII =
Options.switch
( Options.long "ascii"
@@ -104,38 +117,46 @@ main :: IO ()
main = do
GHC.IO.Encoding.setLocaleEncoding GHC.IO.Encoding.utf8
- CommandOptions{..} <- Options.execParser parserInfo
+ options <- Options.execParser parserInfo
+
+ case options of
+ Version -> do
+ putStrLn (showVersion Meta.version)
- let characterSet = case ascii of
- True -> ASCII
- False -> Unicode
+ CommandOptions {..} -> do
+ let characterSet = case ascii of
+ True -> ASCII
+ False -> Unicode
- when version $ do
- putStrLn (showVersion Meta.version)
- System.Exit.exitSuccess
+ handle $ do
+ bytes <- case file of
+ Nothing -> BSL8.getContents
+ Just path -> BSL8.readFile path
- handle $ do
- bytes <- case file of
- Nothing -> BSL8.getContents
- Just path -> BSL8.readFile path
+ result <- dhallFromYaml (Options schema conversion) bytes
- result <- dhallFromYaml (Options schema conversion) bytes
+ let document = Dhall.Pretty.prettyCharacterSet characterSet result
- let document = Dhall.Pretty.prettyCharacterSet characterSet result
+ let stream = Pretty.layoutSmart Dhall.Pretty.layoutOpts document
- let stream = Pretty.layoutSmart Dhall.Pretty.layoutOpts document
+ case output of
+ Nothing -> do
+ supportsANSI <- ANSI.hSupportsANSI IO.stdout
- supportsANSI <- ANSI.hSupportsANSI IO.stdout
+ let ansiStream =
+ if supportsANSI && not plain
+ then fmap Dhall.Pretty.annToAnsiStyle stream
+ else Pretty.unAnnotateS stream
- let ansiStream =
- if supportsANSI && not plain
- then fmap Dhall.Pretty.annToAnsiStyle stream
- else Pretty.unAnnotateS stream
+ Pretty.Terminal.renderIO IO.stdout ansiStream
- Pretty.Terminal.renderIO IO.stdout ansiStream
+ Text.IO.putStrLn ""
- Text.IO.putStrLn ""
+ Just file_ ->
+ IO.withFile file_ IO.WriteMode $ \h -> do
+ Pretty.Text.renderIO h stream
+ Text.IO.hPutStrLn h ""
handle :: IO a -> IO a
handle = Control.Exception.handle handler