diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,14 @@ +1.2.8 + +* New `json-to-dhall` command-line utility + * See: https://github.com/dhall-lang/dhall-haskell/pull/884 +* `--omitEmpty` now also omits empty arrays + * See: https://github.com/dhall-lang/dhall-haskell/pull/872 +* Build against `dhall-1.22.0` +* Improved error messages: + * See: https://github.com/dhall-lang/dhall-haskell/pull/895 + * See: https://github.com/dhall-lang/dhall-haskell/pull/900 + 1.2.7 * Build against `dhall-1.21.0` diff --git a/dhall-json.cabal b/dhall-json.cabal --- a/dhall-json.cabal +++ b/dhall-json.cabal @@ -1,5 +1,5 @@ Name: dhall-json -Version: 1.2.7 +Version: 1.2.8 Cabal-Version: >=1.8.0.2 Build-Type: Simple Tested-With: GHC == 7.10.3, GHC == 8.4.3, GHC == 8.6.1 @@ -35,7 +35,7 @@ Build-Depends: base >= 4.8.0.0 && < 5 , aeson >= 1.0.0.0 && < 1.5 , - dhall >= 1.19.0 && < 1.22, + dhall >= 1.22.0 && < 1.23, optparse-applicative >= 0.14.0.0 && < 0.15, text >= 0.11.1.0 && < 1.3 , unordered-containers < 0.3 @@ -71,6 +71,27 @@ yaml >= 0.5.0 && < 0.12, vector , text + GHC-Options: -Wall + +Executable json-to-dhall + Hs-Source-Dirs: json-to-dhall + Main-Is: Main.hs + Build-Depends: + base , + aeson , + aeson-pretty < 0.9 , + bytestring < 0.11 , + dhall , + optparse-applicative , + text < 1.3 , + scientific >= 0.3.0.0 && < 0.4 , + exceptions >= 0.8.3 && < 0.11 , + containers , + unordered-containers >= 0.1.3.0 && < 0.3 + if !impl(ghc >= 8.0) && !impl(eta >= 0.8.4) + Build-Depends: semigroups == 0.18.* + Other-Modules: + Paths_dhall_json GHC-Options: -Wall Test-Suite tasty diff --git a/json-to-dhall/Main.hs b/json-to-dhall/Main.hs new file mode 100644 --- /dev/null +++ b/json-to-dhall/Main.hs @@ -0,0 +1,585 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-| The tool for converting JSON data to Dhall given a Dhall /type/ expression necessary to make the translation unambiguous. + + Reasonable requirements to the conversion tool are: + + 1. The Dhall type expression @/t/@ passed as an argument to @json-to-dhall@ should be a valid type of the resulting Dhall expression + 2. A JSON data produced by the corresponding @dhall-to-json@ from the Dhall expression of type @/t/@ should (under reasonable assumptions) reproduce the original Dhall expression using @json-to-dhall@ with type argument @/t/@ + + Only a subset of Dhall types consisting of all the primitive types as well as @Optional@, @Union@ and @Record@ constructs, is used for reading JSON data: + + * @Bool@s + * @Natural@s + * @Integer@s + * @Double@s + * @Text@s + * @List@s + * @Optional@ values + * unions + * records + +== Primitive types + + JSON @Bool@s translate to Dhall bools: + +> $ json-to-dhall Bool <<< 'true' +> True +> $ json-to-dhall Bool <<< 'false' +> False + + JSON numbers translate to Dhall numbers: + +> $ json-to-dhall Integer <<< 2 +> +2 +> $ json-to-dhall Natural <<< 2 +> 2 +> $ json-to-dhall Double <<< -2.345 +> -2.345 + + Dhall @Text@ corresponds to JSON text: + +> $ json-to-dhall Text <<< '"foo bar"' +> "foo bar" + + +== Lists and records + + Dhall @List@s correspond to JSON lists: + +> $ json-to-dhall 'List Integer' <<< '[1, 2, 3]' +> [ +1, +2, +3 ] + + + Dhall __records__ correspond to JSON records: + +> $ json-to-dhall '{foo : List Integer}' <<< '{"foo": [1, 2, 3]}' +> { foo = [ +1, +2, +3 ] } + + + Note, that by default, only the fields required by the Dhall type argument are parsed (as you commonly will not need all the data), the remaining ones being ignored: + +> $ json-to-dhall '{foo : List Integer}' <<< '{"foo": [1, 2, 3], "bar" : "asdf"}' +> { foo = [ +1, +2, +3 ] } + + + If you do need to make sure that Dhall fully reflects JSON record data comprehensively, @--records-strict@ flag should be used: + +> $ json-to-dhall --records-strict '{foo : List Integer}' <<< '{"foo": [1, 2, 3], "bar" : "asdf"}' +> Error: Key(s) @bar@ present in the JSON object but not in the corresponding Dhall record. This is not allowed in presence of --records-strict: + + + By default, JSON key-value arrays will be converted to Dhall records: + +> $ json-to-dhall '{ a : Integer, b : Text }' <<< '[{"key":"a", "value":1}, {"key":"b", "value":"asdf"}]' +> { a = +1, b = "asdf" } + + + Attempting to do the same with @--no-keyval-arrays@ on will result in error: + +> $ json-to-dhall --no-keyval-arrays '{ a : Integer, b : Text }' <<< '[{"key":"a", "value":1}, {"key":"b", "value":"asdf"}]' +> Error: JSON (key-value) arrays cannot be converted to Dhall records under --no-keyval-arrays flag: + + Conversion of the homogeneous JSON maps to the corresponding Dhall association lists by default: + +> $ json-to-dhall 'List { mapKey : Text, mapValue : Text }' <<< '{"foo": "bar"}' +> [ { mapKey = "foo", mapValue = "bar" } ] + + 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"}' +> Error: Homogeneous JSON map objects cannot be converted to Dhall association lists under --no-keyval-arrays flag + + +== Optional values and unions + + Dhall @Optional@ Dhall type allows null or missing JSON values: + +> $ json-to-dhall "Optional Integer" <<< '1' +> Some +1 + +> $ json-to-dhall "Optional Integer" <<< null +> None Integer + +> $ json-to-dhall '{ a : Integer, b : Optional Text }' <<< '{ "a": 1 }' +{ a = +1, b = None Text } + + + + For Dhall __union types__ the correct value will be based on matching the type of JSON expression: + +> $ json-to-dhall 'List < Left : Text | Right : Integer >' <<< '[1, "bar"]' +> [ < Left : Text | Right : Integer >.Right +1 + , < Left : Text | Right : Integer >.Left "bar" + ] + +> $ json-to-dhall '{foo : < Left : Text | Right : Integer >}' <<< '{ "foo": "bar" }' +> { foo = < Left : Text | Right : Integer >.Left "bar" } + + In presence of multiple potential matches, the first will be selected by default: + +> $ json-to-dhall '{foo : < Left : Text | Middle : Text | Right : Integer >}' <<< '{ "foo": "bar"}' +> { foo = < Left : Text | Middle : Text | Right : Integer >.Left "bar" } + + This will result in error if @--unions-strict@ flag is used, with the list of alternative matches being reported (as a Dhall list) + +> $ json-to-dhall --unions-strict '{foo : < Left : Text | Middle : Text | Right : Integer >}' <<< '{ "foo": "bar"}' +> Error: More than one union component type matches JSON value +> ... +> Possible matches: +< Left : Text | Middle : Text | Right : Integer >.Left "bar" +> -------- +< Left : Text | Middle : Text | Right : Integer >.Middle "bar" +-} + +module Main where + +import Control.Applicative ((<|>)) +import qualified Control.Exception +import Control.Exception (SomeException, Exception, throwIO) +import Control.Monad.Catch (throwM, MonadCatch) +import Control.Monad (when) +import qualified Data.Aeson as A +import Data.Aeson.Encode.Pretty (encodePretty) +import qualified Data.ByteString.Lazy.Char8 as BSL8 +import Data.Either (rights) +import Data.Foldable (toList) +import qualified Data.HashMap.Strict as HM +import Data.List ((\\)) +import Data.Monoid ((<>)) +import Data.Scientific (floatingOrInteger, toRealFloat) +import qualified Data.Sequence as Seq +import qualified Data.String +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import Data.Text (Text) +import Data.Version (showVersion) +import qualified GHC.IO.Encoding +import qualified Options.Applicative as O +import Options.Applicative (Parser, ParserInfo) +import qualified System.Exit +import qualified System.IO + +import qualified Dhall +import qualified Dhall.Core as D +import Dhall.Core (Expr(App), Chunks(..)) +import qualified Dhall.Import +import qualified Dhall.Map as Map +import qualified Dhall.Parser +import Dhall.Parser (Src) +import qualified Dhall.TypeCheck as D +import Dhall.TypeCheck (X) + +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 JSON expression" + ) + +-- | All the command arguments and options +data Options = Options + { version :: Bool + , schema :: Text + , conversion :: Conversion + } 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" + ) + +-- | JSON-to-dhall translation options +data Conversion = Conversion + { strictRecs :: Bool + , noKeyValArr :: Bool + , noKeyValMap :: Bool + , unions :: UnionConv + } deriving Show + +data UnionConv = UFirst | UNone | UStrict deriving (Show, Read, Eq) + +defaultConversion :: Conversion +defaultConversion = Conversion + { strictRecs = False + , noKeyValArr = False + , noKeyValMap = False + , unions = UFirst + } + +-- | Parser for command options related to the conversion method +parseConversion :: Parser Conversion +parseConversion = Conversion <$> parseStrict + <*> parseKVArr + <*> parseKVMap + <*> parseUnion + where + parseStrict = O.switch + ( O.long "records-strict" + <> O.help "Parse all fields in records" + ) + parseKVArr = O.switch + ( O.long "no-keyval-arrays" + <> O.help "Disable conversion of key-value arrays to records" + ) + parseKVMap = O.switch + ( O.long "no-keyval-maps" + <> O.help "Disable conversion of homogeneous map objects to association lists" + ) + +-- | Parser for command options related to treating union types +parseUnion :: Parser UnionConv +parseUnion = + uFirst + <|> uNone + <|> uStrict + <|> pure UFirst -- defaulting to UFirst + where + uFirst = O.flag' UFirst + ( O.long "unions-first" + <> O.help "The first value with the matching type (succefully parsed all the way down the tree) is accepted, even if not the only posible match. (DEFAULT)" + ) + uNone = O.flag' UNone + ( O.long "unions-none" + <> O.help "Unions not allowed" + ) + uStrict = O.flag' UStrict + ( O.long "unions-strict" + <> O.help "Error if more than one union values match the type (and parse successfully)" + ) + + +-- ---------- +-- Main +-- ---------- + +main :: IO () +main = do + GHC.IO.Encoding.setLocaleEncoding GHC.IO.Encoding.utf8 + + Options {..} <- O.execParser parserInfo + + when version $ do + putStrLn (showVersion Meta.version) + System.Exit.exitSuccess + + handle $ do + stdin <- BSL8.getContents + value :: A.Value <- case A.eitherDecode stdin of + Left err -> throwIO (userError err) + Right v -> pure v + + expr <- typeCheckSchemaExpr =<< resolveSchemaExpr schema + + case dhallFromJSON conversion expr value of + Left err -> throwIO 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 + System.Exit.exitFailure + + +-- ---------- +-- Conversion +-- ---------- + +-- | The 'Expr' type concretization used throughout this module +type ExprX = Expr Src X + +-- | Parse schema code to a valid Dhall expression and check that its type is actually Type +resolveSchemaExpr :: Text -- ^ type code (schema) + -> IO ExprX +resolveSchemaExpr code = do + parsedExpression <- + case Dhall.Parser.exprFromText "\n\ESC[1;31mSCHEMA\ESC[0m" code of + Left err -> Control.Exception.throwIO err + Right parsedExpression -> return parsedExpression + D.normalize <$> Dhall.Import.load parsedExpression -- IO + +{-| Check that the Dhall type expression actually has type 'Type' +>>> :set -XOverloadedStrings +>>> import Dhall.Core + +>>> typeCheckSchemaExpr =<< resolveSchemaExpr "List Natural" +App List Natural + +>>> typeCheckSchemaExpr =<< resolveSchemaExpr "+1" +*** Exception: +Error: Schema expression is succesfully parsed but has Dhall type: +Integer +Expected Dhall type: Type +Parsed expression: +1 +-} +typeCheckSchemaExpr :: MonadCatch m + => ExprX -> m ExprX +typeCheckSchemaExpr expr = + case D.typeOf expr of -- check if the expression has type + Left err -> throwM $ TypeError err + Right t -> case t of -- check if the expression has type Type + D.Const D.Type -> return expr + _ -> throwM $ BadDhallType t expr + +keyValMay :: A.Value -> Maybe (Text, A.Value) +keyValMay (A.Object o) = do + A.String k <- HM.lookup "key" o + v <- HM.lookup "value" o + 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 +>>> import qualified Dhall.Core as D +>>> import qualified Dhall.Map as Map +>>> import qualified Data.Aeson as A +>>> import qualified Data.HashMap.Strict as HM + +>>> s = D.Record (Map.fromList [("foo", D.Integer)]) +>>> v = A.Object (HM.fromList [("foo", A.Number 1)]) +>>> dhallFromJSON defaultConversion s v +Right (RecordLit (fromList [("foo",IntegerLit 1)])) + +-} +dhallFromJSON + :: Conversion -> ExprX -> A.Value -> Either CompileError ExprX +dhallFromJSON (Conversion {..}) = loop + 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 + + -- object ~> Record + loop (D.Record r) v@(A.Object o) + | extraKeys <- HM.keys o \\ Map.keys r + , strictRecs && not (null extraKeys) + = Left (UnhandledKeys extraKeys (D.Record r) v) + | otherwise + = let f :: Text -> ExprX -> Either CompileError ExprX + f k t | Just value <- HM.lookup k o + = loop t value + | App D.Optional t' <- t + = Right (App D.None t') + | otherwise + = Left (MissingKey k t v) + in D.RecordLit <$> Map.traverseWithKey f r + + -- key-value list ~> Record + loop t@(D.Record _) v@(A.Array a) + | not noKeyValArr + , os :: [A.Value] <- toList a + , Just kvs <- traverse keyValMay os + = loop t (A.Object $ HM.fromList kvs) + | noKeyValArr + = Left (NoKeyValArray t v) + | otherwise + = Left (Mismatch t v) + + -- object ~> List (key, value) + 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 mapValue <- Map.lookup "mapValue" r + , keyExprMap :: Either CompileError (HM.HashMap Text ExprX) + <- traverse (loop mapValue) o + = let f :: (Text, ExprX) -> ExprX + f (key, val) = D.RecordLit ( Map.fromList + [ ("mapKey" , D.TextLit (Chunks [] 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 + | noKeyValMap + = Left (NoKeyValMap t v) + | otherwise + = Left (Mismatch t v) + + -- array ~> List + loop (App D.List t) (A.Array a) + = let f :: [ExprX] -> ExprX + f es = D.ListLit + (if null es then Just t else Nothing) + (Seq.fromList es) + in f <$> traverse (loop t) (toList a) + + -- number ~> Integer + loop D.Integer (A.Number x) + | Right n <- floatingOrInteger x :: Either Double Integer + = Right (D.IntegerLit n) + | otherwise + = Left (Mismatch D.Integer (A.Number x)) + + -- number ~> Natural + loop D.Natural (A.Number x) + | Right n <- floatingOrInteger x :: Either Double Dhall.Natural + , n >= 0 + = Right (D.NaturalLit n) + | otherwise + = Left (Mismatch D.Natural (A.Number x)) + + -- number ~> Double + loop D.Double (A.Number x) + = Right (D.DoubleLit $ toRealFloat x) + + -- string ~> Text + loop D.Text (A.String t) + = Right (D.TextLit (Chunks [] t)) + + -- bool ~> Bool + loop D.Bool (A.Bool t) + = Right (D.BoolLit t) + + -- null ~> Optional + loop (App D.Optional expr) A.Null + = Right $ App D.None expr + + -- value ~> Optional + loop (App D.Optional expr) value + = D.Some <$> loop expr value + + -- fail + loop expr value + = Left (Mismatch expr value) + + +-- ---------- +-- EXCEPTIONS +-- ---------- + +red, purple, green + :: (Monoid a, Data.String.IsString a) => a -> a +red s = "\ESC[1;31m" <> s <> "\ESC[0m" -- bold +purple s = "\ESC[1;35m" <> s <> "\ESC[0m" -- bold +green s = "\ESC[0;32m" <> s <> "\ESC[0m" -- plain + +showExpr :: ExprX -> String +showExpr dhall = Text.unpack (D.pretty dhall) + +showJSON :: A.Value -> String +showJSON value = BSL8.unpack (encodePretty value) + +data CompileError + -- Dhall shema + = TypeError (D.TypeError Src X) + | BadDhallType + ExprX -- Expression type + ExprX -- Whole expression + -- generic mismatch (fallback) + | Mismatch + ExprX -- Dhall expression + A.Value -- Aeson value + -- record specific + | MissingKey Text ExprX A.Value + | UnhandledKeys [Text] ExprX A.Value + | NoKeyValArray ExprX A.Value + | NoKeyValMap ExprX A.Value + -- union specific + | ContainsUnion ExprX + | UndecidableUnion ExprX A.Value [ExprX] + +instance Show CompileError where + show = let prefix = red "\nError: " + in \case + TypeError e -> show e + + BadDhallType t e -> prefix + <> "Schema expression is succesfully parsed but has Dhall type:\n" + <> showExpr t <> "\nExpected Dhall type: Type" + <> "\nParsed expression: " + <> showExpr e <> "\n" + + ContainsUnion e -> prefix + <> "Dhall type expression contains union type:\n" + <> showExpr e <> "\nwhile it is forbidden by option " + <> green "--unions-none\n" + + UndecidableUnion e v xs -> prefix + <> "More than one union component type matches JSON value" + <> "\n\nDhall:\n" <> showExpr e + <> "\n\nJSON:\n" <> showJSON 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 + <> "\n\nJSON:\n" <> showJSON v + <> "\n" + + MissingKey k e v -> prefix + <> "Key " <> purple (Text.unpack k) <> ", expected by Dhall type:\n" + <> showExpr e + <> "\nis not present in JSON object:\n" + <> showJSON v <> "\n" + + UnhandledKeys ks e v -> prefix + <> "Key(s) " <> purple (Text.unpack (Text.intercalate ", " ks)) + <> " present in the JSON object but not in the corresponding Dhall record. This is not allowed in presence of " + <> green "--records-strict" <> " flag:" + <> "\n\nDhall:\n" <> showExpr e + <> "\n\nJSON:\n" <> showJSON v + <> "\n" + + NoKeyValArray e v -> prefix + <> "JSON (key-value) arrays cannot be converted to Dhall records under " + <> green "--no-keyval-arrays" <> " flag" + <> "\n\nDhall:\n" <> showExpr e + <> "\n\nJSON:\n" <> showJSON v + <> "\n" + + NoKeyValMap e v -> prefix + <> "Homogeneous JSON map objects cannot be converted to Dhall association lists under " + <> green "--no-keyval-arrays" <> " flag" + <> "\n\nDhall:\n" <> showExpr e + <> "\n\nJSON:\n" <> showJSON v + <> "\n" + +instance Exception CompileError diff --git a/src/Dhall/JSON.hs b/src/Dhall/JSON.hs --- a/src/Dhall/JSON.hs +++ b/src/Dhall/JSON.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-| This library only exports a single `dhallToJSON` function for translating a Dhall syntax tree to a JSON syntax tree (i.e. a `Value`) for the @aeson@ @@ -178,7 +177,6 @@ import Data.Aeson (Value(..), ToJSON(..)) import Data.Monoid ((<>), mempty) import Data.Text (Text) -import Data.Typeable (Typeable) import Dhall.Core (Expr) import Dhall.TypeCheck (X) import Dhall.Map (Map) @@ -202,19 +200,44 @@ Because the majority of Dhall language features do not translate to JSON this just returns the expression that failed -} -data CompileError = Unsupported (Expr X X) deriving (Typeable) +data CompileError + = Unsupported (Expr X X) + | BareNone instance Show CompileError where + show BareNone = + Data.Text.unpack $ + _ERROR <> ": ❰None❱ is not valid on its own \n\ + \ \n\ + \Explanation: The conversion to JSON/YAML does not accept ❰None❱ in isolation as \n\ + \a valid way to represent ❰null❱. In Dhall, ❰None❱ is a function whose input is \n\ + \a type and whose output is an ❰Optional❱ of that type. \n\ + \ \n\ + \For example: \n\ + \ \n\ + \ \n\ + \ ┌─────────────────────────────────┐ ❰None❱ is a function whose result is \n\ + \ │ None : ∀(a : Type) → Optional a │ an ❰Optional❱ value, but the function \n\ + \ └─────────────────────────────────┘ itself is not a valid ❰Optional❱ value \n\ + \ \n\ + \ \n\ + \ ┌─────────────────────────────────┐ ❰None Natural❱ is a valid ❰Optional❱ \n\ + \ │ None Natural : Optional Natural │ value (an absent ❰Natural❱ number in \n\ + \ └─────────────────────────────────┘ this case) \n\ + \ \n\ + \ \n\ + \ \n\ + \The conversion to JSON/YAML only translates the fully applied form to ❰null❱. " show (Unsupported e) = Data.Text.unpack $ - "" <> _ERROR <> ": Cannot translate to JSON \n\ - \ \n\ - \Explanation: Only primitive values, records, unions, ❰List❱s, and ❰Optional❱ \n\ - \values can be translated from Dhall to JSON \n\ - \ \n\ - \The following Dhall expression could not be translated to JSON: \n\ - \ \n\ - \↳ " <> txt <> " " + _ERROR <> ": Cannot translate to JSON \n\ + \ \n\ + \Explanation: Only primitive values, records, unions, ❰List❱s, and ❰Optional❱ \n\ + \values can be translated from Dhall to JSON \n\ + \ \n\ + \The following Dhall expression could not be translated to JSON: \n\ + \ \n\ + \↳ " <> txt <> " " where txt = Dhall.Core.pretty e @@ -257,6 +280,11 @@ return (toJSON a') Dhall.Core.App Dhall.Core.None _ -> do return Data.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 + Left BareNone Dhall.Core.RecordLit a -> case toOrderedList a of [ ( "contents" @@ -272,7 +300,7 @@ (Dhall.Core.TextLit (Dhall.Core.Chunks [] nestedField) ) - [ ("Inline", Dhall.Core.Record []) ] + [ ("Inline", Just (Dhall.Core.Record [])) ] ) ] -> do contents' <- loop contents @@ -303,7 +331,7 @@ , Dhall.Core.UnionLit "Inline" (Dhall.Core.RecordLit []) - [ ("Nested", Dhall.Core.Text) ] + [ ("Nested", Just Dhall.Core.Text) ] ) ] -> do let contents' = @@ -322,6 +350,8 @@ 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) _ -> Left (Unsupported e) toOrderedList :: Ord k => Map k v -> [(k, v)] @@ -345,8 +375,8 @@ omitNull Null = Null -{-| Omit record fields that are @null@ or records whose transitive fields are - all null +{-| Omit record fields that are @null@, arrays and records whose transitive + fields are all null -} omitEmpty :: Value -> Value omitEmpty (Object object) = @@ -354,7 +384,9 @@ where fields = Data.HashMap.Strict.filter (/= Null) (fmap omitEmpty object) omitEmpty (Array array) = - Array (fmap omitEmpty array) + if null elems then Null else Array elems + where + elems = (fmap omitEmpty array) omitEmpty (String string) = String string omitEmpty (Number number) = @@ -671,13 +703,13 @@ Dhall.Core.Union a -> Dhall.Core.Union a' where - a' = fmap loop a + a' = fmap (fmap loop) a Dhall.Core.UnionLit a b c -> Dhall.Core.UnionLit a b' c' where - b' = loop b - c' = fmap loop c + b' = loop b + c' = fmap (fmap loop) c Dhall.Core.Combine a b -> Dhall.Core.Combine a' b'