diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,100 @@ +1.7.12 + +* Build against `dhall-1.42` + +1.7.11 + +* [Add new `--preserve-header` option](https://github.com/dhall-lang/dhall-haskell/pull/2433) +* Builds against newer dependencies + * [`aeson-2.1`](https://github.com/dhall-lang/dhall-haskell/pull/2424) + +1.7.10 + +* [Don't use scientific notation for large integers](https://github.com/dhall-lang/dhall-haskell/pull/2352) +* Build against `dhall-1.41` +* [Build against `text-2.0`](https://github.com/dhall-lang/dhall-haskell/pull/2356) +* [Build against `optparse-applicative-0.17`](https://github.com/dhall-lang/dhall-haskell/pull/2376) + +1.7.9 + +* [Build against `aeson-2.0`](https://github.com/dhall-lang/dhall-haskell/pull/2315) + +1.7.8 + +* [Add support for `Date` / `Time` / `TimeZone`](https://github.com/dhall-lang/dhall-haskell/pull/2247) + +1.7.7 + +* Build against `dhall-1.39.0` + +1.7.6 + +* [Fix `hashable`-related test failures](https://github.com/dhall-lang/dhall-haskell/pull/2152) +* [Fix lower bound on `dhall`](https://github.com/dhall-lang/dhall-haskell/pull/2147) +* [Allow bytestring-0.11](https://github.com/dhall-lang/dhall-haskell/pull/2144) +* [Fix typos in `json-to-dhall --help` output](https://github.com/dhall-lang/dhall-haskell/pull/2160) + +1.7.5 + +* Build against `dhall-1.38.0`, `tasty-1.4`, and `tasty-silver-3.2` + +1.7.4 + +* Build against `dhall-1.37.0` + +1.7.3 + +* [Fix command-line completions for files](https://github.com/dhall-lang/dhall-haskell/pull/2034) +* [Support new `Text/replace` built-in](https://github.com/dhall-lang/dhall-haskell/pull/2063) + +1.7.2 + +* [The `--documents` flag now wraps non-`List`s in a document](https://github.com/dhall-lang/dhall-haskell/pull/1977) + +1.7.1 + +* [Format documents with leading `---`](https://github.com/dhall-lang/dhall-haskell/pull/1865) + * Now if you use the `--documents` flag the first document will also + include a leading `---` + +1.7.0 + +* BREAKING CHANGE: [Add `--generated-comment` flag for `dhall-to-yaml{-ng}`](https://github.com/dhall-lang/dhall-haskell/pull/1840) + * You can now optionally add a comment header to the YAML output + indicating that the file is generated and should not be hand-edited + * This is a breaking change because this adds a new `noEdit` field to the + options type + * In practice this breakage won't affect most users +* [Produce output compatible with YAML 1.1](https://github.com/dhall-lang/dhall-haskell/pull/1788) + * Special strings like `on` are now quoted in order to avoid being + misinterpreted as boolean values by YAML 1.1 implementations +* [Show JSON/YAML path on error reporting](https://github.com/dhall-lang/dhall-haskell/pull/1799) + * Error messages will now include the path to the error in the diagnostic + output + +1.6.4 + +* [Add `json-to-dhall` support for inferring the schema](https://github.com/dhall-lang/dhall-haskell/pull/1773) + * You no longer need to provide the command with an explicit schema. The + command will infer a reasonably close schema from the provided JSON +* [Add `json-to-dhall type` subcommand](https://github.com/dhall-lang/dhall-haskell/pull/1776) + * You can use this subcommand to print the inferred schema for a JSON value, + so that you can edit the schema and use it for subsequent invocations. +* [Add `json-to-dhall` support for using `toMap`](https://github.com/dhall-lang/dhall-haskell/pull/1745) + * Now if you specify a `Map` as the schema, the generated Dhall code will + use `toMap` to improve the appearance + +1.6.3 + +* [yaml: Single-quote date/bool string fields](https://github.com/dhall-lang/dhall-haskell/commits/master/dhall-json) + +1.6.2 + +* [Fix `dhall-json` for new `Prelude.JSON.Type`](https://github.com/dhall-lang/dhall-haskell/pull/1631) + * Version 13.0.0 of the Prelude caused the `JSON` type to change, which + broke `dhall-json`'s support for that type + * This release fixes that (and still supports the old `JSON` type) + 1.6.1 * [Fix typos in error messages](https://github.com/dhall-lang/dhall-haskell/pull/1595) diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2018 Gabriel Gonzalez +Copyright (c) 2020 Gabriella Gonzalez All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/dhall-json.cabal b/dhall-json.cabal --- a/dhall-json.cabal +++ b/dhall-json.cabal @@ -1,31 +1,34 @@ Name: dhall-json -Version: 1.6.1 -Cabal-Version: >=1.8.0.2 +Version: 1.7.12 +Cabal-Version: >=1.10 Build-Type: Simple -Tested-With: GHC == 7.10.3, GHC == 8.4.3, GHC == 8.6.1 License: BSD3 License-File: LICENSE -Copyright: 2017 Gabriel Gonzalez -Author: Gabriel Gonzalez -Maintainer: Gabriel439@gmail.com +Copyright: 2017 Gabriella Gonzalez +Author: Gabriella Gonzalez +Maintainer: GenuineGabriella@gmail.com Bug-Reports: https://github.com/dhall-lang/dhall-haskell/issues Synopsis: Convert between Dhall and JSON or YAML Description: Use this package if you want to convert between Dhall expressions and JSON or YAML. You can use this package as a library or an executable: . - * See the "Dhall.JSON" module if you want to use this package as a library + * See the "Dhall.JSON" or "Dhall.JSONToDhall" modules if you want to use + this package as a library . - * Use the @dhall-to-json@ or @dhall-to-yaml@ programs from this package if - you want an executable + * Use the @dhall-to-json@, @dhall-to-yaml@, or @json-to-dhall@ programs from + this package if you want an executable . - The "Dhall.JSON" module also contains instructions for how to use this - package + The "Dhall.JSON" and "Dhall.JSONToDhall" modules also contains instructions + for how to use this package Category: Compiler Extra-Source-Files: CHANGELOG.md tasty/data/*.dhall tasty/data/*.json + tasty/data/error/*.golden + tasty/data/error/*.json + tasty/data/error/*.dhall Source-Repository head Type: git @@ -34,20 +37,21 @@ Library Hs-Source-Dirs: src Build-Depends: - base >= 4.8.0.0 && < 5 , - aeson >= 1.0.0.0 && < 1.5 , - aeson-pretty < 0.9 , - aeson-yaml >= 1.0.5 && < 1.1 , - bytestring < 0.11, - containers , - dhall >= 1.28.0 && < 1.30, - exceptions >= 0.8.3 && < 0.11, - filepath < 1.5 , - optparse-applicative >= 0.14.0.0 && < 0.16, - prettyprinter >= 1.5.1 && < 1.6 , - scientific >= 0.3.0.0 && < 0.4 , - text >= 0.11.1.0 && < 1.3 , - unordered-containers < 0.3 , + base >= 4.11.0.0 && < 5 , + aeson >= 1.4.6.0 && < 2.2 , + aeson-pretty >= 0.8.0 && < 0.9 , + aeson-yaml >= 1.1.0 && < 1.2 , + bytestring < 0.12, + containers >= 0.5.9 && < 0.7 , + dhall >= 1.42.0 && < 1.43, + exceptions >= 0.8.3 && < 0.11, + filepath < 1.5 , + lens-family-core >= 1.0.0 && < 2.2 , + optparse-applicative >= 0.14.0.0 && < 0.18, + prettyprinter >= 1.7.0 && < 1.8 , + scientific >= 0.3.0.0 && < 0.4 , + text >= 0.11.1.0 && < 2.1 , + unordered-containers < 0.3 , vector Exposed-Modules: Dhall.JSON @@ -55,8 +59,10 @@ Dhall.JSON.Yaml Dhall.DhallToYaml.Main Other-Modules: + Dhall.JSON.Compat Dhall.JSON.Util GHC-Options: -Wall + Default-Language: Haskell2010 Executable dhall-to-json Hs-Source-Dirs: dhall-to-json @@ -65,7 +71,7 @@ base , aeson , aeson-pretty >= 0.8.5 && < 0.9 , - bytestring < 0.11, + bytestring , dhall , dhall-json , optparse-applicative , @@ -73,6 +79,7 @@ Other-Modules: Paths_dhall_json GHC-Options: -Wall + Default-Language: Haskell2010 Executable dhall-to-yaml Hs-Source-Dirs: dhall-to-yaml @@ -83,6 +90,7 @@ Other-Modules: Paths_dhall_json GHC-Options: -Wall + Default-Language: Haskell2010 Executable json-to-dhall Hs-Source-Dirs: json-to-dhall @@ -90,32 +98,33 @@ Build-Depends: base , aeson , - ansi-terminal >= 0.6.3.1 && < 0.11, - bytestring < 0.11, + ansi-terminal >= 0.6.3.1 && < 0.12, + bytestring , dhall , dhall-json , exceptions >= 0.8.3 && < 0.11, optparse-applicative , prettyprinter , prettyprinter-ansi-terminal >= 1.1.1 && < 1.2 , - text < 1.3 - if !impl(ghc >= 8.0) && !impl(eta >= 0.8.4) - Build-Depends: semigroups == 0.18.* + text Other-Modules: Paths_dhall_json GHC-Options: -Wall + Default-Language: Haskell2010 Test-Suite tasty Type: exitcode-stdio-1.0 Hs-Source-Dirs: tasty Main-Is: Main.hs Build-Depends: - base , - aeson , - bytestring , - dhall , - dhall-json , - tasty < 1.3, - text , - tasty-hunit >= 0.2 + base , + aeson , + bytestring , + dhall , + dhall-json , + tasty < 1.5, + text , + tasty-hunit >= 0.2, + tasty-silver >= 3.0 GHC-Options: -Wall + Default-Language: Haskell2010 diff --git a/dhall-to-json/Main.hs b/dhall-to-json/Main.hs --- a/dhall-to-json/Main.hs +++ b/dhall-to-json/Main.hs @@ -1,26 +1,27 @@ -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} module Main where -import Control.Applicative ((<|>), optional) -import Control.Exception (SomeException) -import Data.Aeson (Value) -import Data.Monoid ((<>)) -import Data.Version (showVersion) -import Dhall.JSON (Conversion, SpecialDoubleMode(..)) +import Control.Applicative (optional, (<|>)) +import Control.Exception (SomeException) +import Data.Aeson (Value) +import Data.Version (showVersion) +import Dhall.JSON (Conversion, SpecialDoubleMode (..)) import Options.Applicative (Parser, ParserInfo) import qualified Control.Exception import qualified Data.Aeson -import qualified Data.Aeson.Encode.Pretty +import qualified Data.Aeson.Text +import qualified Data.Aeson.Encode.Pretty as Pretty import qualified Data.ByteString.Lazy -import qualified Data.Text.IO as Text.IO +import qualified Data.Text.IO as Text.IO import qualified Dhall import qualified Dhall.JSON import qualified GHC.IO.Encoding -import qualified Options.Applicative as Options -import qualified Paths_dhall_json as Meta +import qualified Options.Applicative as Options +import qualified Paths_dhall_json as Meta import qualified System.Exit import qualified System.IO @@ -93,6 +94,7 @@ ( Options.long "file" <> Options.help "Read expression from a file instead of standard input" <> Options.metavar "FILE" + <> Options.action "file" ) parseOutput = @@ -100,6 +102,7 @@ ( Options.long "output" <> Options.help "Write JSON to a file instead of standard output" <> Options.metavar "FILE" + <> Options.action "file" ) parserInfo :: ParserInfo Options @@ -117,19 +120,23 @@ options <- Options.execParser parserInfo case options of - Version -> do + Version -> putStrLn (showVersion Meta.version) - Options {..} -> do + Options {..} -> handle $ do - let config = Data.Aeson.Encode.Pretty.Config - { Data.Aeson.Encode.Pretty.confIndent = Data.Aeson.Encode.Pretty.Spaces 2 - , Data.Aeson.Encode.Pretty.confCompare = compare - , Data.Aeson.Encode.Pretty.confNumFormat = Data.Aeson.Encode.Pretty.Generic - , Data.Aeson.Encode.Pretty.confTrailingNewline = False } + let custom scientific = + Data.Aeson.Text.encodeToTextBuilder (Data.Aeson.Number scientific) + + let config = Pretty.Config + { Pretty.confIndent = Pretty.Spaces 2 + , Pretty.confCompare = compare + , Pretty.confNumFormat = Pretty.Custom custom + , Pretty.confTrailingNewline = False + } let encode = if pretty - then Data.Aeson.Encode.Pretty.encodePretty' config + then Pretty.encodePretty' config else Data.Aeson.encode let explaining = if explain then Dhall.detailed else id diff --git a/json-to-dhall/Main.hs b/json-to-dhall/Main.hs --- a/json-to-dhall/Main.hs +++ b/json-to-dhall/Main.hs @@ -1,36 +1,29 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE PatternGuards #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} module Main where import Control.Applicative (optional, (<|>)) -import Control.Exception (SomeException, throwIO) -import Data.Monoid ((<>)) -import Data.Text (Text) -import Data.Version (showVersion) +import Control.Exception (SomeException, throwIO) +import Data.Text (Text) +import Data.Version (showVersion) import Dhall.JSONToDhall -import Dhall.Pretty (CharacterSet(..)) +import Dhall.Pretty (CharacterSet (..)) import Options.Applicative (Parser, ParserInfo) import qualified Control.Exception -import qualified Data.Aeson as Aeson -import qualified Data.ByteString.Lazy.Char8 as ByteString -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Prettyprint.Doc as Pretty -import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty.Terminal -import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty.Text +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy.Char8 as ByteString +import qualified Dhall.Core +import qualified Dhall.Util import qualified GHC.IO.Encoding -import qualified Options.Applicative as Options -import qualified System.Console.ANSI as ANSI +import qualified Options.Applicative as Options +import qualified Paths_dhall_json as Meta import qualified System.Exit -import qualified System.IO as IO -import qualified Dhall.Pretty -import qualified Paths_dhall_json as Meta +import qualified System.IO as IO -- --------------- -- Command options @@ -46,22 +39,29 @@ -- | All the command arguments and options data Options - = Options - { schema :: Text + = Default + { schema :: Maybe Text , conversion :: Conversion , file :: Maybe FilePath , output :: Maybe FilePath , ascii :: Bool , plain :: Bool } + | Type + { file :: Maybe FilePath + , output :: Maybe FilePath + , ascii :: Bool + , plain :: Bool + } | Version deriving Show -- | Parser for all the command arguments and options parseOptions :: Parser Options parseOptions = - ( Options - <$> parseSchema + typeCommand + <|> ( Default + <$> optional parseSchema <*> parseConversion <*> optional parseFile <*> optional parseOutput @@ -70,10 +70,24 @@ ) <|> parseVersion where + typeCommand = + Options.hsubparser + (Options.command "type" info <> Options.metavar "type") + where + info = + Options.info parser (Options.progDesc "Output the inferred Dhall type from a JSON value") + + parser = + Type + <$> optional parseFile + <*> optional parseOutput + <*> parseASCII + <*> parsePlain + parseSchema = Options.strArgument ( Options.metavar "SCHEMA" - <> Options.help "Dhall type expression (schema)" + <> Options.help "Dhall type (schema). You can omit the schema to let the executable infer the schema from the JSON value." ) parseVersion = @@ -89,6 +103,7 @@ ( Options.long "file" <> Options.help "Read JSON from a file instead of standard input" <> Options.metavar "FILE" + <> Options.action "file" ) parseOutput = @@ -96,6 +111,7 @@ ( Options.long "output" <> Options.help "Write Dhall expression to a file instead of standard output" <> Options.metavar "FILE" + <> Options.action "file" ) parseASCII = @@ -120,52 +136,51 @@ options <- Options.execParser parserInfo - case options of - Version -> do - putStrLn (showVersion Meta.version) + let toCharacterSet ascii = case ascii of + True -> ASCII + False -> Unicode - Options {..} -> do - let characterSet = case ascii of - True -> ASCII - False -> Unicode + let toValue file = do + bytes <- case file of + Nothing -> ByteString.getContents + Just path -> ByteString.readFile path - handle $ do - bytes <- case file of - Nothing -> ByteString.getContents - Just path -> ByteString.readFile path + case Aeson.eitherDecode bytes of + Left err -> throwIO (userError err) + Right v -> pure v - value :: Aeson.Value <- case Aeson.eitherDecode bytes of - Left err -> throwIO (userError err) - Right v -> pure v + let toSchema schema value = do + finalSchema <- case schema of + Just text -> resolveSchemaExpr text + Nothing -> return (schemaToDhallType (inferSchema value)) - expr <- typeCheckSchemaExpr id =<< resolveSchemaExpr schema + typeCheckSchemaExpr id finalSchema - result <- case dhallFromJSON conversion expr value of - Left err -> throwIO err - Right result -> return result + case options of + Version -> + putStrLn (showVersion Meta.version) - let document = Dhall.Pretty.prettyCharacterSet characterSet result + Default{..} -> do + let characterSet = toCharacterSet ascii - let stream = Dhall.Pretty.layout document + handle $ do + value <- toValue file - case output of - Nothing -> do - supportsANSI <- ANSI.hSupportsANSI IO.stdout + finalSchema <- toSchema schema value - let ansiStream = - if supportsANSI && not plain - then fmap Dhall.Pretty.annToAnsiStyle stream - else Pretty.unAnnotateS stream + expression <- Dhall.Core.throws (dhallFromJSON conversion finalSchema value) - Pretty.Terminal.renderIO IO.stdout ansiStream + Dhall.Util.renderExpression characterSet plain output expression - Text.IO.putStrLn "" + Type{..} -> do + let characterSet = toCharacterSet ascii - Just file_ -> - IO.withFile file_ IO.WriteMode $ \h -> do - Pretty.Text.renderIO h stream + handle $ do + value <- toValue file - Text.IO.hPutStrLn h "" + finalSchema <- toSchema Nothing value + + Dhall.Util.renderExpression characterSet plain output finalSchema handle :: IO a -> IO a handle = Control.Exception.handle handler diff --git a/src/Dhall/DhallToYaml/Main.hs b/src/Dhall/DhallToYaml/Main.hs --- a/src/Dhall/DhallToYaml/Main.hs +++ b/src/Dhall/DhallToYaml/Main.hs @@ -6,12 +6,11 @@ module Dhall.DhallToYaml.Main (main) where import Control.Applicative (optional, (<|>)) -import Control.Exception (SomeException) -import Data.ByteString (ByteString) -import Data.Monoid ((<>)) -import Data.Text (Text) -import Dhall.JSON (parsePreservationAndOmission, parseConversion) -import Dhall.JSON.Yaml (Options(..), parseDocuments, parseQuoted) +import Control.Exception (SomeException) +import Data.ByteString (ByteString) +import Data.Text (Text) +import Dhall.JSON (parseConversion, parsePreservationAndOmission) +import Dhall.JSON.Yaml (Options (..), parseDocuments, parseQuoted) import Options.Applicative (Parser, ParserInfo) import qualified Control.Exception @@ -34,6 +33,8 @@ <*> Dhall.JSON.parseConversion <*> optional parseFile <*> optional parseOutput + <*> parseNoEdit + <*> parsePreserveHeader ) <|> parseVersion where @@ -48,6 +49,7 @@ ( Options.long "file" <> Options.help "Read expression from a file instead of standard input" <> Options.metavar "FILE" + <> Options.action "file" ) parseVersion = @@ -62,8 +64,21 @@ ( Options.long "output" <> Options.help "Write YAML to a file instead of standard output" <> Options.metavar "FILE" + <> Options.action "file" ) + parseNoEdit = + Options.switch + ( Options.long "generated-comment" + <> Options.help "Include a comment header warning not to edit the generated file" + ) + + parsePreserveHeader = + Options.switch + ( Options.long "preserve-header" + <> Options.help "Translate any Dhall comment header to a YAML comment header" + ) + parserInfo :: ParserInfo (Maybe Options) parserInfo = Options.info @@ -82,10 +97,10 @@ maybeOptions <- Options.execParser parserInfo case maybeOptions of - Nothing -> do + Nothing -> putStrLn (Data.Version.showVersion version) - Just options@(Options {..}) -> do + Just options@Options{..} -> handle $ do contents <- case file of Nothing -> Text.IO.getContents @@ -93,7 +108,7 @@ let write = case output of - Nothing -> Data.ByteString.putStr + Nothing -> Data.ByteString.putStr Just file_ -> Data.ByteString.writeFile file_ write =<< dhallToYaml options file contents diff --git a/src/Dhall/JSON.hs b/src/Dhall/JSON.hs --- a/src/Dhall/JSON.hs +++ b/src/Dhall/JSON.hs @@ -3,6 +3,7 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} {-| This library only exports a single `dhallToJSON` function for translating a Dhall syntax tree to a JSON syntax tree (i.e. a `Value`) for the @aeson@ @@ -26,7 +27,7 @@ * @Natural@s * @Integer@s * @Double@s - * @Text@ + * @Text@ values * @List@s * @Optional@ values * unions @@ -124,9 +125,9 @@ the same record. For example, this code: > let Example = < Left : { foo : Natural } | Right : { bar : Bool } > -> +> > let Nesting = < Inline | Nested : Text > -> +> > in { field = "name" > , nesting = Nesting.Inline > , contents = Example.Left { foo = 2 } @@ -143,9 +144,9 @@ underneath a field named @nestedField@. For example, this code: > let Example = < Left : { foo : Natural } | Right : { bar : Bool } > -> +> > let Nesting = < Inline | Nested : Text > -> +> > in { field = "name" > , nesting = Nesting.Nested "value" > , contents = Example.Left { foo = 2 } @@ -165,7 +166,7 @@ > $ cat ./example.dhall > let JSON = https://prelude.dhall-lang.org/JSON/package.dhall -> +> > in JSON.object > [ { mapKey = "foo", mapValue = JSON.null } > , { mapKey = @@ -207,45 +208,47 @@ , SpecialDoubleMode(..) , handleSpecialDoubles , codeToValue + , codeToHeaderAndValue -- * Exceptions , CompileError(..) ) where import Control.Applicative (empty, (<|>)) -import Control.Monad (guard) -import Control.Exception (Exception, throwIO) -import Data.Aeson (Value(..), ToJSON(..)) -import Data.Maybe (fromMaybe) -import Data.Monoid ((<>), mempty) -import Data.Text (Text) -import Data.Text.Prettyprint.Doc (Pretty) -import Data.Void (Void) -import Dhall.Core (Binding(..), DhallDouble(..), Expr) -import Dhall.Import (SemanticCacheMode(..)) -import Dhall.Map (Map) -import Dhall.JSON.Util (pattern V) +import Control.Exception (Exception, throwIO) +import Control.Monad (guard) +import Data.Aeson (ToJSON (..), Value (..)) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Void (Void) +import Dhall.Core (Binding (..), DhallDouble (..), Expr) +import Dhall.Import (SemanticCacheMode (..)) +import Dhall.JSON.Util (pattern FA, pattern V) +import Dhall.Map (Map) +import Dhall.Parser (Header(..)) import Options.Applicative (Parser) -import Prelude hiding (getContents) +import Prelude hiding (getContents) +import Prettyprinter (Pretty) -import qualified Data.Aeson as Aeson -import qualified Data.Foldable as Foldable -import qualified Data.HashMap.Strict as HashMap +import qualified Data.Aeson as Aeson +import qualified Data.Foldable as Foldable import qualified Data.List import qualified Data.Map import qualified Data.Ord import qualified Data.Text -import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty -import qualified Data.Vector as Vector -import qualified Dhall.Core as Core +import qualified Data.Vector as Vector +import qualified Dhall.Core as Core import qualified Dhall.Import +import qualified Dhall.JSON.Compat as JSON.Compat import qualified Dhall.Map import qualified Dhall.Optics import qualified Dhall.Parser import qualified Dhall.Pretty import qualified Dhall.TypeCheck import qualified Dhall.Util +import qualified Lens.Family as Lens import qualified Options.Applicative +import qualified Prettyprinter.Render.Text as Pretty import qualified System.FilePath {-| This is the exception type for errors that might arise when translating @@ -412,44 +415,43 @@ -> Either CompileError Value dhallToJSON e0 = loop (Core.alphaNormalize (Core.normalize e0)) where - loop e = case e of + loop e = case e of Core.BoolLit a -> return (toJSON a) Core.NaturalLit a -> return (toJSON a) Core.IntegerLit a -> return (toJSON a) Core.DoubleLit (DhallDouble a) -> return (toJSON a) - Core.TextLit (Core.Chunks [] a) -> do - return (toJSON a) + Core.TextLit (Core.Chunks [] a) -> return (toJSON a) Core.ListLit _ a -> do a' <- traverse loop a return (toJSON a') Core.Some a -> do a' <- loop a return (toJSON a') - Core.App Core.None _ -> do - return Aeson.Null + Core.App Core.None _ -> return Aeson.Null -- Provide a nicer error message for a common user mistake. -- -- See: https://github.com/dhall-lang/dhall-lang/issues/492 - Core.None -> do - Left BareNone + Core.None -> Left BareNone + _ | Just text <- Dhall.Pretty.temporalToText e -> + loop (Core.TextLit (Core.Chunks [] text)) Core.RecordLit a -> case toOrderedList a of [ ( "contents" - , contents + , Core.recordFieldValue -> contents ) , ( "field" - , Core.TextLit + , Core.recordFieldValue -> Core.TextLit (Core.Chunks [] field) ) , ( "nesting" - , Core.App + , Core.recordFieldValue -> Core.App (Core.Field (Core.Union [ ("Inline", mInlineType) , ("Nested", Just Core.Text) ] ) - "Nested" + (FA "Nested") ) (Core.TextLit (Core.Chunks [] nestedField) @@ -459,7 +461,7 @@ , Just (alternativeName, mExpr) <- getContents contents -> do contents' <- case mExpr of Just expr -> loop expr - Nothing -> return Aeson.Null + Nothing -> return Aeson.Null let taggedValue = Data.Map.fromList @@ -474,14 +476,14 @@ return (Aeson.toJSON taggedValue) [ ( "contents" - , contents + , Core.recordFieldValue -> contents ) , ( "field" - , Core.TextLit + , Core.recordFieldValue -> Core.TextLit (Core.Chunks [] field) ) , ( "nesting" - , nesting + , Core.recordFieldValue -> nesting ) ] | isInlineNesting nesting , Just (alternativeName, mExpr) <- getContents contents -> do @@ -491,40 +493,89 @@ Left (InvalidInlineContents e alternativeContents) Nothing -> return mempty - let name = Core.TextLit (Core.Chunks [] alternativeName) + let name = Core.makeRecordField $ Core.TextLit (Core.Chunks [] alternativeName) let kvs1 = Dhall.Map.insert field name kvs0 loop (Core.RecordLit kvs1) _ -> do - a' <- traverse loop a + a' <- traverse (loop . Core.recordFieldValue) a return (Aeson.toJSON (Dhall.Map.toMap a')) Core.App (Core.Field (Core.Union _) _) b -> loop b - Core.Field (Core.Union _) k -> return (Aeson.toJSON k) - Core.Lam _ (Core.Const Core.Type) - (Core.Lam _ + Core.Field (Core.Union _) (FA k) -> return (Aeson.toJSON k) + Core.Lam _ (Core.functionBindingAnnotation -> Core.Const Core.Type) + (Core.Lam _ (Core.functionBindingAnnotation -> (Core.Record - [ ("array" , Core.Pi _ (Core.App Core.List (V 0)) (V 1)) - , ("bool" , Core.Pi _ Core.Bool (V 1)) - , ("null" , V 0) - , ("number", Core.Pi _ Core.Double (V 1)) - , ("object", Core.Pi _ (Core.App Core.List (Core.Record [ ("mapKey", Core.Text), ("mapValue", V 0)])) (V 1)) - , ("string", Core.Pi _ Core.Text (V 1)) + [ ("array" , Core.recordFieldValue -> Core.Pi _ _ (Core.App Core.List (V 0)) (V 1)) + , ("bool" , Core.recordFieldValue -> Core.Pi _ _ Core.Bool (V 1)) + , ("null" , Core.recordFieldValue -> V 0) + , ("number", Core.recordFieldValue -> Core.Pi _ _ Core.Double (V 1)) + , ("object", Core.recordFieldValue -> + Core.Pi _ _ (Core.App Core.List (Core.Record + [ ("mapKey", Core.recordFieldValue -> Core.Text) + , ("mapValue", Core.recordFieldValue -> V 0)])) (V 1)) + , ("string", Core.recordFieldValue -> Core.Pi _ _ Core.Text (V 1)) ] - ) + )) value ) -> do - let outer (Core.Field (V 0) "null") = do + let outer (Core.Field (V 0) (FA "null")) = return Aeson.Null + outer (Core.App (Core.Field (V 0) (FA "bool")) (Core.BoolLit b)) = + return (Aeson.Bool b) + outer (Core.App (Core.Field (V 0) (FA "array")) (Core.ListLit _ xs)) = do + ys <- traverse outer (Foldable.toList xs) + + return (Aeson.Array (Vector.fromList ys)) + outer (Core.App (Core.Field (V 0) (FA "object")) (Core.ListLit _ xs)) = do + let inner (Core.RecordLit + [ ("mapKey", Core.recordFieldValue -> Core.TextLit (Core.Chunks [] mapKey)) + , ("mapValue", Core.recordFieldValue -> mapExpression)]) = do + mapValue <- outer mapExpression + + return (mapKey, mapValue) + inner _ = Left (Unsupported e) + + ys <- traverse inner (Foldable.toList xs) + + return (Aeson.Object (JSON.Compat.objectFromList ys)) + outer (Core.App (Core.Field (V 0) (FA "number")) (Core.DoubleLit (DhallDouble n))) = + return (Aeson.toJSON n) + outer (Core.App (Core.Field (V 0) (FA "string")) (Core.TextLit (Core.Chunks [] text))) = + return (toJSON text) + outer _ = Left (Unsupported e) + + outer value + Core.Lam _ (Core.functionBindingAnnotation -> Core.Const Core.Type) + (Core.Lam _ (Core.functionBindingAnnotation -> + (Core.Record + [ ("array" , Core.recordFieldValue -> Core.Pi _ _ (Core.App Core.List (V 0)) (V 1)) + , ("bool" , Core.recordFieldValue -> Core.Pi _ _ Core.Bool (V 1)) + , ("double", Core.recordFieldValue -> Core.Pi _ _ Core.Double (V 1)) + , ("integer", Core.recordFieldValue -> Core.Pi _ _ Core.Integer (V 1)) + , ("null" , Core.recordFieldValue -> V 0) + , ("object", Core.recordFieldValue -> + Core.Pi _ _ (Core.App Core.List (Core.Record + [ ("mapKey", Core.recordFieldValue -> Core.Text) + , ("mapValue", Core.recordFieldValue -> V 0) + ])) (V 1)) + , ("string", Core.recordFieldValue -> Core.Pi _ _ Core.Text (V 1)) + ] + )) + value + ) -> do + let outer (Core.Field (V 0) (FA "null")) = return Aeson.Null - outer (Core.App (Core.Field (V 0) "bool") (Core.BoolLit b)) = do + outer (Core.App (Core.Field (V 0) (FA "bool")) (Core.BoolLit b)) = return (Aeson.Bool b) - outer (Core.App (Core.Field (V 0) "array") (Core.ListLit _ xs)) = do + outer (Core.App (Core.Field (V 0) (FA "array")) (Core.ListLit _ xs)) = do ys <- traverse outer (Foldable.toList xs) return (Aeson.Array (Vector.fromList ys)) - outer (Core.App (Core.Field (V 0) "object") (Core.ListLit _ xs)) = do - let inner (Core.RecordLit [("mapKey", Core.TextLit (Core.Chunks [] mapKey)), ("mapValue", mapExpression)]) = do + outer (Core.App (Core.Field (V 0) (FA "object")) (Core.ListLit _ xs)) = do + let inner (Core.RecordLit + [ ("mapKey", Core.recordFieldValue -> Core.TextLit (Core.Chunks [] mapKey)) + , ("mapValue", Core.recordFieldValue -> mapExpression)]) = do mapValue <- outer mapExpression return (mapKey, mapValue) @@ -532,10 +583,12 @@ ys <- traverse inner (Foldable.toList xs) - return (Aeson.Object (HashMap.fromList ys)) - outer (Core.App (Core.Field (V 0) "number") (Core.DoubleLit (DhallDouble n))) = do + return (Aeson.Object (JSON.Compat.objectFromList ys)) + outer (Core.App (Core.Field (V 0) (FA "double")) (Core.DoubleLit (DhallDouble n))) = return (Aeson.toJSON n) - outer (Core.App (Core.Field (V 0) "string") (Core.TextLit (Core.Chunks [] text))) = do + outer (Core.App (Core.Field (V 0) (FA "integer")) (Core.IntegerLit n)) = + return (Aeson.toJSON n) + outer (Core.App (Core.Field (V 0) (FA "string")) (Core.TextLit (Core.Chunks [] text))) = return (toJSON text) outer _ = Left (Unsupported e) @@ -546,11 +599,11 @@ getContents (Core.App (Core.Field _ - alternativeName + (FA alternativeName) ) expression ) = Just (alternativeName, Just expression) -getContents (Core.Field _ alternativeName) = Just (alternativeName, Nothing) +getContents (Core.Field _ (FA alternativeName)) = Just (alternativeName, Nothing) getContents _ = Nothing isInlineNesting :: Expr s Void -> Bool @@ -561,7 +614,7 @@ , ("Nested", Just Core.Text) ] ) - "Inline" + (FA "Inline") ) (Core.RecordLit []) ) = True @@ -571,7 +624,7 @@ , ("Nested", Just Core.Text) ] ) - "Inline" + (FA "Inline") ) = True isInlineNesting _ = False @@ -584,7 +637,7 @@ omitNull :: Value -> Value omitNull (Object object) = Object fields where - fields =HashMap.filter (/= Null) (fmap omitNull object) + fields = JSON.Compat.filterObject (/= Null) (fmap omitNull object) omitNull (Array array) = Array (fmap omitNull array) omitNull (String string) = @@ -596,14 +649,14 @@ omitNull Null = Null -{-| Omit record fields that are @null@, arrays and records whose transitive +{-| Omit record fields that are @null@, arrays and records whose transitive fields are all null -} omitEmpty :: Value -> Value omitEmpty (Object object) = if null fields then Null else Object fields where - fields = HashMap.filter (/= Null) (fmap omitEmpty object) + fields = JSON.Compat.filterObject (/= Null) (fmap omitEmpty object) omitEmpty (Array array) = if null elems then Null else Array elems where @@ -679,11 +732,11 @@ case we do *not* want to perform this rewrite since it will interfere with decoding the value. -} - Core.Lam a b c -> - Core.Lam a b c + Core.Lam cs a b -> + Core.Lam cs a b - Core.Pi a b c -> - Core.Pi a b' c' + Core.Pi cs a b c -> + Core.Pi cs a b' c' where b' = loop b c' = loop c @@ -744,6 +797,12 @@ b' = loop b c' = loop c + Core.Bytes -> + Core.Bytes + + Core.BytesLit a -> + Core.BytesLit a + Core.Natural -> Core.Natural @@ -827,9 +886,39 @@ a' = loop a b' = loop b + Core.TextReplace -> + Core.TextReplace + Core.TextShow -> Core.TextShow + Core.Date -> + Core.Date + + Core.DateLiteral d -> + Core.DateLiteral d + + Core.DateShow -> + Core.DateShow + + Core.Time -> + Core.Time + + Core.TimeLiteral t p -> + Core.TimeLiteral t p + + Core.TimeShow -> + Core.TimeShow + + Core.TimeZone -> + Core.TimeZone + + Core.TimeZoneLiteral z -> + Core.TimeZoneLiteral z + + Core.TimeZoneShow -> + Core.TimeZoneShow + Core.List -> Core.List @@ -844,21 +933,21 @@ toKeyValue (Core.RecordLit m) = do guard (Foldable.length m == 2) - key <- Dhall.Map.lookup mapKey m - value <- Dhall.Map.lookup mapValue m + key <- Core.recordFieldValue <$> Dhall.Map.lookup mapKey m + value <- Core.recordFieldValue <$> Dhall.Map.lookup mapValue m keyText <- case key of Core.TextLit (Core.Chunks [] keyText) -> return keyText - Core.Field (Core.Union _) keyText -> + Core.Field (Core.Union _) (FA keyText) -> return keyText _ -> empty return (keyText, value) - toKeyValue _ = do + toKeyValue _ = empty transform = @@ -870,13 +959,12 @@ guard (Dhall.Map.member mapKey m) guard (Dhall.Map.member mapValue m) return (Core.RecordLit mempty) - _ -> do - empty + _ -> empty _ -> do keyValues <- traverse toKeyValue elements - let recordLiteral = + let recordLiteral = Core.makeRecordField <$> Dhall.Map.fromList keyValues return (Core.RecordLit recordLiteral) @@ -922,44 +1010,38 @@ Core.None -> Core.None - Core.OptionalFold -> - Core.OptionalFold - - Core.OptionalBuild -> - Core.OptionalBuild - Core.Record a -> Core.Record a' where - a' = fmap loop a + a' = Lens.over Core.recordFieldExprs loop <$> a Core.RecordLit a -> Core.RecordLit a' where - a' = fmap loop a + a' = Lens.over Core.recordFieldExprs loop <$> a Core.Union a -> Core.Union a' where a' = fmap (fmap loop) a - Core.Combine a b -> - Core.Combine a' b' + Core.Combine cs a b c -> + Core.Combine cs a b' c' where - a' = loop a b' = loop b + c' = loop c - Core.CombineTypes a b -> - Core.CombineTypes a' b' + Core.CombineTypes cs a b -> + Core.CombineTypes cs a' b' where a' = loop a b' = loop b - Core.Prefer a b -> - Core.Prefer a' b' + Core.Prefer cs a b c -> + Core.Prefer cs a b' c' where - a' = loop a b' = loop b + c' = loop c Core.RecordCompletion a b -> Core.RecordCompletion a' b' @@ -980,6 +1062,11 @@ a' = loop a b' = fmap loop b + Core.ShowConstructor a -> + Core.ShowConstructor a' + where + a' = loop a + Core.Field a b -> Core.Field a' b where @@ -995,12 +1082,18 @@ where a' = loop a - Core.Equivalent a b -> - Core.Equivalent a' b' + Core.Equivalent cs a b -> + Core.Equivalent cs a' b' where a' = loop a b' = loop b + Core.With a b c -> + Core.With a' b c' + where + a' = loop a + c' = loop c + Core.ImportAlt a b -> Core.ImportAlt a' b' where @@ -1100,7 +1193,7 @@ >>> :set -XOverloadedStrings >>> import Core ->>> Dhall.JSON.codeToValue "(stdin)" "{ a = 1 }" +>>> Dhall.JSON.codeToValue defaultConversion ForbidWithinJSON Nothing "{ a = 1 }" >>> Object (fromList [("a",Number 1.0)]) -} codeToValue @@ -1111,8 +1204,28 @@ -> Text -- ^ Input text. -> IO Value codeToValue conversion specialDoubleMode mFilePath code = do - parsedExpression <- Core.throws (Dhall.Parser.exprFromText (fromMaybe "(stdin)" mFilePath) code) + fmap snd (codeToHeaderAndValue conversion specialDoubleMode mFilePath code) +{-| This is like `codeToValue`, except also returning a `Header` that is a + valid YAML comment derived from the original Dhall code's `Header` +-} +codeToHeaderAndValue + :: Conversion + -> SpecialDoubleMode + -> Maybe FilePath -- ^ The source file path. If no path is given, imports + -- are resolved relative to the current directory. + -> Text -- ^ Input text. + -> IO (Header, Value) +codeToHeaderAndValue conversion specialDoubleMode mFilePath code = do + (Header header, parsedExpression) <- Core.throws (Dhall.Parser.exprAndHeaderFromText (fromMaybe "(input)" mFilePath) code) + + let adapt line = + case Data.Text.stripPrefix "--" line of + Just suffix -> "#" <> suffix + Nothing -> "#" <> line + + let yamlHeader = Data.Text.unlines (map adapt (Data.Text.lines header)) + let rootDirectory = case mFilePath of Nothing -> "." Just fp -> System.FilePath.takeDirectory fp @@ -1128,5 +1241,4 @@ case dhallToJSON specialDoubleExpression of Left err -> Control.Exception.throwIO err - Right json -> return json - + Right json -> return (Header yamlHeader, json) diff --git a/src/Dhall/JSON/Compat.hs b/src/Dhall/JSON/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/JSON/Compat.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE CPP #-} + +-- | Compatibility helpers for the @aeson-2@ migration. +module Dhall.JSON.Compat ( + objectFromList + , mapToAscList + , filterObject + , lookupObject + , traverseObjectWithKey + , objectKeys + , textToKey + ) where + +import Data.Aeson (Object, Value) +import Data.Text (Text) + +#if MIN_VERSION_aeson(2,0,0) +import Data.Aeson.Key (Key) +import qualified Data.Aeson.Key as Key +import Data.Aeson.KeyMap (KeyMap) +import qualified Data.Aeson.KeyMap as KeyMap +import Data.Bifunctor (first) +#else +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import qualified Data.List as List +#endif + +objectFromList :: [(Text, Value)] -> Object +#if MIN_VERSION_aeson(2,0,0) +objectFromList = KeyMap.fromList . map (first Key.fromText) +#else +objectFromList = HashMap.fromList +#endif + +filterObject :: (Value -> Bool) -> Object -> Object +#if MIN_VERSION_aeson(2,0,0) +filterObject = KeyMap.filter +#else +filterObject = HashMap.filter +#endif + +#if MIN_VERSION_aeson(2,0,0) +mapToAscList :: KeyMap a -> [(Text, a)] +mapToAscList = map (first Key.toText) . KeyMap.toAscList +#else +mapToAscList :: HashMap Text a -> [(Text, a)] +mapToAscList = List.sortOn fst . HashMap.toList +#endif + +lookupObject :: Text -> Object -> Maybe Value +#if MIN_VERSION_aeson(2,0,0) +lookupObject k = KeyMap.lookup (Key.fromText k) +#else +lookupObject = HashMap.lookup +#endif + +objectKeys :: Object -> [Text] +#if MIN_VERSION_aeson(2,0,0) +objectKeys = map (Key.toText) . KeyMap.keys +#else +objectKeys = HashMap.keys +#endif + +#if MIN_VERSION_aeson(2,0,0) +textToKey :: Text -> Key +textToKey = Key.fromText +#else +textToKey :: Text -> Text +textToKey = id +#endif + +#if MIN_VERSION_aeson(2,0,0) +traverseObjectWithKey :: Applicative f => (Key -> v1 -> f v2) -> KeyMap v1 -> f (KeyMap v2) +traverseObjectWithKey = KeyMap.traverseWithKey +#else +traverseObjectWithKey :: Applicative f => (Text -> v1 -> f v2) -> HashMap Text v1 -> f (HashMap Text v2) +traverseObjectWithKey = HashMap.traverseWithKey +#endif diff --git a/src/Dhall/JSON/Util.hs b/src/Dhall/JSON/Util.hs --- a/src/Dhall/JSON/Util.hs +++ b/src/Dhall/JSON/Util.hs @@ -3,11 +3,17 @@ module Dhall.JSON.Util ( pattern V + , pattern FA ) where -import Dhall.Core (Expr) +import Data.Text (Text) +import Dhall.Core (Expr, FieldSelection) import qualified Dhall.Core as Core pattern V :: Int -> Expr s a pattern V n = Core.Var (Core.V "_" n) + +pattern FA :: Text -> FieldSelection s +pattern FA t <- Core.FieldSelection _ t _ + where FA = Core.makeFieldSelection diff --git a/src/Dhall/JSON/Yaml.hs b/src/Dhall/JSON/Yaml.hs --- a/src/Dhall/JSON/Yaml.hs +++ b/src/Dhall/JSON/Yaml.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -14,30 +13,34 @@ , defaultOptions , dhallToYaml , jsonToYaml + , generatedCodeNotice ) where -import Data.ByteString (ByteString) -import Data.Monoid ((<>)) -import Data.Text (Text) -import Dhall.JSON (Conversion(..), SpecialDoubleMode(..)) +import Data.ByteString (ByteString) +import Data.Text (Text) +import Dhall.JSON (Conversion (..), SpecialDoubleMode (..)) +import Dhall.Parser (Header(..)) import Options.Applicative (Parser) import qualified Data.Aeson import qualified Data.Aeson.Yaml import qualified Data.ByteString.Lazy +import qualified Data.Text.Encoding import qualified Data.Vector import qualified Dhall import qualified Dhall.JSON import qualified Options.Applicative data Options = Options - { explain :: Bool - , omission :: Data.Aeson.Value -> Data.Aeson.Value - , documents :: Bool - , quoted :: Bool - , conversion :: Conversion - , file :: Maybe FilePath - , output :: Maybe FilePath + { explain :: Bool + , omission :: Data.Aeson.Value -> Data.Aeson.Value + , documents :: Bool + , quoted :: Bool + , conversion :: Conversion + , file :: Maybe FilePath + , output :: Maybe FilePath + , noEdit :: Bool + , preserveHeader :: Bool } defaultOptions :: Options @@ -49,13 +52,15 @@ , conversion = Dhall.JSON.defaultConversion , file = Nothing , output = Nothing + , noEdit = False + , preserveHeader = False } parseDocuments :: Parser Bool parseDocuments = Options.Applicative.switch ( Options.Applicative.long "documents" - <> Options.Applicative.help "If given a Dhall list, output a document for every element" + <> Options.Applicative.help "If given a Dhall list, output a document for every element. Each document, including the first one, will be preceded by \"---\", even if there is only one document. If not given a list, output a single document (as if it were a list of one element)" ) parseQuoted :: Parser Bool @@ -64,7 +69,13 @@ ( Options.Applicative.long "quoted" <> Options.Applicative.help "Prevent from generating not quoted scalars" ) - + +{-| The notice added to the top of a generated file when enabling the + @--generated-comment@ +-} +generatedCodeNotice :: ByteString +generatedCodeNotice = "# Code generated by dhall-to-yaml. DO NOT EDIT.\n" + {-| Convert a piece of Text carrying a Dhall inscription to an equivalent YAML ByteString -} dhallToYaml @@ -74,13 +85,24 @@ -> Text -- ^ Input text. -> IO ByteString dhallToYaml Options{..} mFilePath code = do - + let explaining = if explain then Dhall.detailed else id - json <- omission <$> explaining (Dhall.JSON.codeToValue conversion UseYAMLEncoding mFilePath code) + let adapt (header, value) = (header, omission value) - return $ jsonToYaml json documents quoted + (Header comment, json) <- adapt <$> explaining (Dhall.JSON.codeToHeaderAndValue conversion UseYAMLEncoding mFilePath code) + let suffix + | preserveHeader = Data.Text.Encoding.encodeUtf8 comment + | otherwise = mempty + + let header = + if noEdit + then generatedCodeNotice <> suffix + else suffix + + return $ header <> jsonToYaml json documents quoted + -- | Transform json representation into yaml jsonToYaml :: Data.Aeson.Value @@ -94,6 +116,11 @@ then Data.Aeson.Yaml.encodeQuotedDocuments else Data.Aeson.Yaml.encodeDocuments ) (Data.Vector.toList elems) + (True, value) + -> (if quoted + then Data.Aeson.Yaml.encodeQuotedDocuments + else Data.Aeson.Yaml.encodeDocuments + ) [ value ] _ -> (if quoted then Data.Aeson.Yaml.encodeQuoted else Data.Aeson.Yaml.encode diff --git a/src/Dhall/JSONToDhall.hs b/src/Dhall/JSONToDhall.hs --- a/src/Dhall/JSONToDhall.hs +++ b/src/Dhall/JSONToDhall.hs @@ -1,157 +1,263 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE PatternGuards #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} -{-| Convert JSON data to Dhall given a Dhall /type/ expression necessary to make the translation unambiguous. +{-| Convert JSON data to Dhall in one of two ways: - Reasonable requirements for conversion are: + * By default, the conversion will make a best-effort at inferring the + corresponding Dhall type - 1. The Dhall type expression @/t/@ passed as an argument to @json-to-dhall@ should be a valid type of the resulting Dhall expression - 2. A JSON data produced by the corresponding @dhall-to-json@ from the Dhall expression of type @/t/@ should (under reasonable assumptions) reproduce the original Dhall expression using @json-to-dhall@ with type argument @/t/@ + * Optionally, you can specify an expected Dhall type necessary to make the + translation unambiguous. - Only a subset of Dhall types consisting of all the primitive types as well as @Optional@, @Union@ and @Record@ constructs, is used for reading JSON data: + Either way, if you supply the generated Dhall result to @dhall-to-json@ you + should get back the original JSON. - * @Bool@s - * @Natural@s - * @Integer@s - * @Double@s - * @Text@s - * @List@s - * @Optional@ values + Only a subset of Dhall types are supported when converting from JSON: + + * @Bool@ + * @Natural@ + * @Integer@ + * @Double@ + * @Text@ + * @List@ + * @Optional@ * unions * records + * @Prelude.Type.Map@ + * @Prelude.Type.JSON@ - You can always convert JSON data to this type as a + last resort if you don't know the schema in advance. - Additionally, you can read in arbitrary JSON data into a Dhall value of - type @https://prelude.dhall-lang.org/JSON/Type@ if you don't know the - schema of the JSON data in advance. + You can use this code as a library (this module) or as an executable + named @json-to-dhall@, which is used in the examples below. - This library can be used to implement an executable which takes any data - serialisation format which can be parsed as an Aeson @Value@ and converts - the result to a Dhall value. One such executable is @json-to-dhall@ which - is used in the examples below. + By default the @json-to-dhall@ executable attempts to infer the + appropriate Dhall type from the JSON data, like this: +> $ json-to-dhall <<< 1 +> 1 + + ... but you can also provide an explicit schema on the command line if you + prefer a slightly different Dhall type which still represents the same JSON + value: + +> $ json-to-dhall Integer <<< 1 +> +1 + + You can also get the best of both worlds by using the @type@ subcommand to + infer the schema: + +> $ json-to-dhall type <<< '[ "up", "down" ]' | tee schema.dhall +> List Text + + ... and then edit the @./schema.dhall@ file to better match the type you + intended, such as: + +> $ $EDITOR schema.dhall +> $ cat ./schema.dhall +> List < up | down > + + ... and then use the edited schema for subsequent conversions: + +> $ json-to-dhall ./schema.dhall <<< '[ "up", "down" ]' +> [ < down | up >.up, < down | up >.down ] + == Primitive types JSON @Bool@s translate to Dhall bools: -> $ json-to-dhall Bool <<< 'true' +> $ json-to-dhall <<< 'true' > True -> $ json-to-dhall Bool <<< 'false' +> $ json-to-dhall <<< 'false' > False JSON numbers translate to Dhall numbers: -> $ json-to-dhall Integer <<< 2 -> +2 +> $ json-to-dhall <<< 2 +> 2 +> $ json-to-dhall <<< -2 +> -2 +> $ json-to-dhall <<< -2.1 +> -2.1 > $ json-to-dhall Natural <<< 2 > 2 -> $ json-to-dhall Double <<< -2.345 -> -2.345 +> $ json-to-dhall Integer <<< 2 +> +2 +> $ json-to-dhall Double <<< 2 +> 2.0 - Dhall @Text@ corresponds to JSON text: + JSON text corresponds to Dhall @Text@ by default: -> $ json-to-dhall Text <<< '"foo bar"' +> $ json-to-dhall <<< '"foo bar"' > "foo bar" + ... but you can also decode text into a more structured enum, too, if you + provide an explicit schema: +> $ json-to-dhall '< A | B >' <<< '"A"' +> < A | B >.A + == Lists and records Dhall @List@s correspond to JSON lists: -> $ json-to-dhall 'List Integer' <<< '[1, 2, 3]' -> [ +1, +2, +3 ] +> $ json-to-dhall <<< '[ 1, 2, 3 ]' +> [ 1, 2, 3 ] + You can even decode an empty JSON list to Dhall: - Dhall __records__ correspond to JSON records: +> $ json-to-dhall <<< '[]' +> [] : List <> -> $ json-to-dhall '{foo : List Integer}' <<< '{"foo": [1, 2, 3]}' -> { foo = [ +1, +2, +3 ] } + ... which will infer the empty @\<\>@ type if there are no other constraints + on the type. If you provide an explicit type annotation then the conversion + will use that instead: +> $ json-to-dhall 'List Natural' <<< '[]' +> [] : List Natural - Note, that by default, only the fields required by the Dhall type argument are parsed (as you commonly will not need all the data), the remaining ones being ignored: + Dhall records correspond to JSON records: -> $ json-to-dhall '{foo : List Integer}' <<< '{"foo": [1, 2, 3], "bar" : "asdf"}' -> { foo = [ +1, +2, +3 ] } +> $ json-to-dhall <<< '{ "foo": [ 1, 2, 3 ] }' +> { foo = [ 1, 2, 3 ] } + If you specify a schema with additional @Optional@ fields then they will be + @None@ if absent: - If you do need to make sure that Dhall fully reflects JSON record data comprehensively, @--records-strict@ flag should be used: +> $ json-to-dhall '{ foo : List Natural, bar : Optional Bool }' <<< '{ "foo": [ 1, 2, 3 ] }' +> { bar = None Bool, foo = [ 1, 2, 3 ] } -> $ json-to-dhall --records-strict '{foo : List Integer}' <<< '{"foo": [1, 2, 3], "bar" : "asdf"}' -> Error: Key(s) @bar@ present in the JSON object but not in the corresponding Dhall record. This is not allowed in presence of --records-strict: + ... and @Some@ if present: +> $ json-to-dhall '{ foo : List Natural, bar : Optional Bool }' <<< '{ "foo": [ 1, 2, 3 ], "bar": true }' +> { bar = Some True, foo = [ 1, 2, 3 ] } - By default, JSON key-value arrays will be converted to Dhall records: + If you specify a schema with too few fields, then the behavior is + configurable. By default, the conversion will reject extra fields: -> $ json-to-dhall '{ a : Integer, b : Text }' <<< '[{"key":"a", "value":1}, {"key":"b", "value":"asdf"}]' -> { a = +1, b = "asdf" } +> $ json-to-dhall '{ foo : List Natural }' <<< '{ "foo": [ 1, 2, 3 ], "bar": true }' +> +> Error: Key(s) bar present in the JSON object but not in the expected Dhall record type. This is not allowed unless you enable the --records-loose flag: +> +> Expected Dhall type: +> { foo : List Natural } +> +> JSON: +> { +> "foo": [ +> 1, +> 2, +> 3 +> ], +> "bar": true +> } + ... as the error message suggests, extra fields are ignored if you enable the + @--records-loose@ flag. - Attempting to do the same with @--no-keyval-arrays@ on will result in error: +> $ json-to-dhall --records-loose '{ foo : List Natural }' <<< '{ "foo": [ 1, 2, 3 ], "bar": true }' +> { foo = [ 1, 2, 3 ] } -> $ json-to-dhall --no-keyval-arrays '{ a : Integer, b : Text }' <<< '[{"key":"a", "value":1}, {"key":"b", "value":"asdf"}]' + You can convert JSON key-value arrays to Dhall records, but only if you + supply an explicit Dhall type: + +> $ json-to-dhall '{ a : Natural, b : Text }' <<< '[ { "key": "a", "value": 1 }, { "key": "b", "value": "asdf" } ]' +> { a = 1, b = "asdf" } + + You can also disable this behavior using the @--no-keyval-arrays@: + +> $ json-to-dhall --no-keyval-arrays '{ a : Natural, b : Text }' <<< '[ { "key": "a", "value": 1 }, { "key": "b", "value": "asdf" } ]' > Error: JSON (key-value) arrays cannot be converted to Dhall records under --no-keyval-arrays flag: - Conversion of the homogeneous JSON maps to the corresponding Dhall association lists by default: + You can also convert JSON records to Dhall @Map@s, but only if you supply an + explicit schema: -> $ json-to-dhall 'List { mapKey : Text, mapValue : Text }' <<< '{"foo": "bar"}' -> [ { mapKey = "foo", mapValue = "bar" } ] +> $ json-to-dhall 'List { mapKey : Text, mapValue : Text }' <<< '{ "foo": "bar" }' +> toMap { foo = "bar" } The map keys can even be union types instead of `Text`: -> $ json-to-dhall 'List { mapKey : < A | B >, mapValue : Natural }' <<< '{"A": 1, "B": 2}' +> $ json-to-dhall 'List { mapKey : < A | B >, mapValue : Natural }' <<< '{ "A": 1, "B": 2 }' > [ { mapKey = < A | B >.A, mapValue = 1 }, { mapKey = < A | B >.B, mapValue = 2 } ] - Flag @--no-keyval-maps@ switches off this mechanism (if one would ever need it): + You can similarly disable this feature using @--no-keyval-maps@: -> $ json-to-dhall --no-keyval-maps 'List { mapKey : Text, mapValue : Text }' <<< '{"foo": "bar"}' +> $ json-to-dhall --no-keyval-maps 'List { mapKey : Text, mapValue : Text }' <<< '{ "foo": "bar" }' > Error: Homogeneous JSON map objects cannot be converted to Dhall association lists under --no-keyval-arrays flag + If your schema is a record with a `List` field and omit that field in the JSON, + you'll get an error: +> $ json-to-dhall '{ a : List Natural }' <<< '{}' +> +> +> Error: Key a, expected by Dhall type: +> List Natural +> is not present in JSON object: +> {} + + You can use the @--omissible-lists@ option to default to an empty list in this case + +> $ json-to-dhall --omissible-lists '{ a : List Natural }' <<< '{}' +> { a = [] : List Natural } + == Optional values and unions - Dhall @Optional@ Dhall type allows null or missing JSON values: + JSON @null@ values correspond to @Optional@ Dhall values: -> $ json-to-dhall "Optional Integer" <<< '1' -> Some +1 +> $ json-to-dhall <<< 'null' +> None <> -> $ json-to-dhall "Optional Integer" <<< null -> None Integer + ... and the schema inference logic will automatically wrap other values in + @Optional@ to ensure that the types line up: -> $ json-to-dhall '{ a : Integer, b : Optional Text }' <<< '{ "a": 1 }' -{ a = +1, b = None Text } +> $ json-to-dhall <<< '[ 1, null ]' +> [ Some 1, None Natural ] + A field that might be absent also corresponds to an @Optional@ type: +> $ json-to-dhall <<< '[ { "x": 1 }, { "x": 2, "y": true } ]' +> [ { x = 1, y = None Bool }, { x = 2, y = Some True } ] - For Dhall __union types__ the correct value will be based on matching the type of JSON expression: + For Dhall union types the correct value will be based on matching the type + of JSON expression if you give an explicit type: > $ json-to-dhall 'List < Left : Text | Right : Integer >' <<< '[1, "bar"]' > [ < Left : Text | Right : Integer >.Right +1 - , < Left : Text | Right : Integer >.Left "bar" - ] +> , < Left : Text | Right : Integer >.Left "bar" +> ] -> $ json-to-dhall '{foo : < Left : Text | Right : Integer >}' <<< '{ "foo": "bar" }' -> { foo = < Left : Text | Right : Integer >.Left "bar" } + Also, the schema inference logic will still infer a union anyway in order + to reconcile simple types: - In presence of multiple potential matches, the first will be selected by default: +> $ json-to-dhall <<< '[ 1, true ]' +> [ < Bool : Bool | Natural : Natural >.Natural 1 +> , < Bool : Bool | Natural : Natural >.Bool True +> ] + In presence of multiple potential matches, the first will be selected by + default: + > $ json-to-dhall '{foo : < Left : Text | Middle : Text | Right : Integer >}' <<< '{ "foo": "bar"}' > { foo = < Left : Text | Middle : Text | Right : Integer >.Left "bar" } - This will result in error if @--unions-strict@ flag is used, with the list of alternative matches being reported (as a Dhall list) + This will result in error if @--unions-strict@ flag is used, with the list + of alternative matches being reported (as a Dhall list) > $ json-to-dhall --unions-strict '{foo : < Left : Text | Middle : Text | Right : Integer >}' <<< '{ "foo": "bar"}' > Error: More than one union component type matches JSON value > ... > Possible matches: -< Left : Text | Middle : Text | Right : Integer >.Left "bar" +> < Left : Text | Middle : Text | Right : Integer >.Left "bar" > -------- -< Left : Text | Middle : Text | Right : Integer >.Middle "bar" +> < Left : Text | Middle : Text | Right : Integer >.Middle "bar" == Weakly-typed JSON @@ -171,9 +277,11 @@ > → λ(null : JSON) > → array > [ object -> [ { mapKey = "foo", mapValue = null } -> , { mapKey = "bar", mapValue = array [ number 1.0, bool True ] } -> ] +> ( toMap +> { bar = array [ number 1.0, bool True ] +> , foo = null +> } +> ) > ] You can also mix and match JSON fields whose schemas are known or unknown: @@ -199,6 +307,36 @@ > } > ] + The schema inference algorithm will also infer this schema of last resort + when unifying a simple type with a record or a list: + +> $ json-to-dhall <<< '[ 1, [] ]' +> [ λ(JSON : Type) → +> λ ( json +> : { array : List JSON → JSON +> , bool : Bool → JSON +> , double : Double → JSON +> , integer : Integer → JSON +> , null : JSON +> , object : List { mapKey : Text, mapValue : JSON } → JSON +> , string : Text → JSON +> } +> ) → +> json.integer +1 +> , λ(JSON : Type) → +> λ ( json +> : { array : List JSON → JSON +> , bool : Bool → JSON +> , double : Double → JSON +> , integer : Integer → JSON +> , null : JSON +> , object : List { mapKey : Text, mapValue : JSON } → JSON +> , string : Text → JSON +> } +> ) → +> json.array ([] : List JSON) +> ] + -} module Dhall.JSONToDhall ( @@ -210,40 +348,54 @@ , typeCheckSchemaExpr , dhallFromJSON + -- * Schema inference + , Schema(..) + , RecordSchema(..) + , UnionSchema(..) + , inferSchema + , schemaToDhallType + -- * Exceptions , CompileError(..) , showCompileError ) where -import Control.Applicative ((<|>)) -import Control.Exception (Exception, throwIO) -import Control.Monad.Catch (throwM, MonadCatch) -import qualified Data.Aeson as A -import Data.Aeson.Encode.Pretty (encodePretty) +import Control.Applicative ((<|>)) +import Control.Exception (Exception, throwIO) +import Control.Monad.Catch (MonadCatch, throwM) +import Data.Aeson (Value) +import Data.Aeson.Encode.Pretty (encodePretty) +import Data.Either (rights) +import Data.Foldable (toList) +import Data.List ((\\)) +import Data.Monoid (Any (..)) +import Data.Scientific (floatingOrInteger, toRealFloat) +import Data.Text (Text) +import Data.Void (Void) +import Dhall.Core (Chunks (..), DhallDouble (..), Expr (App)) +import Dhall.JSON.Util (pattern FA, pattern V) +import Dhall.Parser (Src) +import Options.Applicative (Parser) + +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson.Types import qualified Data.ByteString.Lazy.Char8 as BSL8 -import Data.Either (rights) -import Data.Foldable (toList) -import qualified Data.HashMap.Strict as HM -import Data.List ((\\)) -import Data.Monoid ((<>)) -import Data.Scientific (floatingOrInteger, toRealFloat) -import qualified Data.Sequence as Seq +import qualified Data.Foldable as Foldable +import qualified Data.Map +import qualified Data.Map.Merge.Lazy as Data.Map.Merge +import qualified Data.Sequence as Seq import qualified Data.String -import qualified Data.Text as Text -import Data.Text (Text) -import qualified Data.Vector as Vector -import Data.Void (Void) -import qualified Options.Applicative as O -import Options.Applicative (Parser) - -import Dhall.JSON.Util (pattern V) -import qualified Dhall.Core as D -import Dhall.Core (Expr(App), Chunks(..), DhallDouble(..)) +import qualified Data.Text as Text +import qualified Data.Vector as Vector +import qualified Dhall.Core as D import qualified Dhall.Import -import qualified Dhall.Map as Map +import qualified Dhall.JSON.Compat as JSON.Compat +import qualified Dhall.Lint as Lint +import qualified Dhall.Map as Map +import qualified Dhall.Optics as Optics import qualified Dhall.Parser -import Dhall.Parser (Src) -import qualified Dhall.TypeCheck as D +import qualified Dhall.TypeCheck as D +import qualified Options.Applicative as O -- --------------- -- Command options @@ -260,11 +412,11 @@ parseStrict = O.flag' True ( O.long "records-strict" - <> O.help "Fail if any YAML fields are missing from the expected Dhall type" + <> O.help "Fail if any JSON fields are missing from the expected Dhall type" ) <|> O.flag' False ( O.long "records-loose" - <> O.help "Tolerate YAML fields not present within the expected Dhall type" + <> O.help "Tolerate JSON fields not present within the expected Dhall type" ) <|> pure True @@ -291,7 +443,7 @@ where uFirst = O.flag' UFirst ( O.long "unions-first" - <> O.help "The first value with the matching type (succefully parsed all the way down the tree) is accepted, even if not the only posible match. (DEFAULT)" + <> O.help "The first value with the matching type (successfully parsed all the way down the tree) is accepted, even if not the only possible match. (DEFAULT)" ) uNone = O.flag' UNone ( O.long "unions-none" @@ -363,236 +515,604 @@ D.Const D.Type -> return expr _ -> throwM . compileException $ BadDhallType t expr -keyValMay :: A.Value -> Maybe (Text, A.Value) -keyValMay (A.Object o) = do - A.String k <- HM.lookup "key" o - v <- HM.lookup "value" o +keyValMay :: Value -> Maybe (Text, Value) +keyValMay (Aeson.Object o) = do + Aeson.String k <- JSON.Compat.lookupObject "key" o + v <- JSON.Compat.lookupObject "value" o return (k, v) keyValMay _ = Nothing +{-| Given a JSON `Value`, make a best-effort guess of what the matching Dhall + type should be + + This is used by @{json,yaml}-to-dhall@ if the user does not supply a schema + on the command line +-} +inferSchema :: Value -> Schema +inferSchema (Aeson.Object m) = + let convertMap = Data.Map.fromDistinctAscList . JSON.Compat.mapToAscList + + in (Record . RecordSchema . convertMap) (fmap inferSchema m) +inferSchema (Aeson.Array xs) = + List (Foldable.foldMap inferSchema xs) +inferSchema (Aeson.String _) = + Text +inferSchema (Aeson.Number n) = + case floatingOrInteger n of + Left (_ :: Double) -> Double + Right (integer :: Integer) + | 0 <= integer -> Natural + | otherwise -> Integer +inferSchema (Aeson.Bool _) = + Bool +inferSchema Aeson.Null = + Optional mempty + +-- | Aeson record type that `inferSchema` can infer +newtype RecordSchema = + RecordSchema { getRecordSchema :: Data.Map.Map Text Schema } + +instance Semigroup RecordSchema where + RecordSchema l <> RecordSchema r = RecordSchema m + where + -- The reason this is not @Just (Optional s)@ is to avoid creating a + -- double `Optional` wrapper when unifying a @null@ field with an + -- absent field. + onMissing _ s = Just (s <> Optional mempty) + + m = Data.Map.Merge.merge + (Data.Map.Merge.mapMaybeMissing onMissing) + (Data.Map.Merge.mapMaybeMissing onMissing) + (Data.Map.Merge.zipWithMatched (\_ -> (<>))) + l + r + +recordSchemaToDhallType :: RecordSchema -> Expr s a +recordSchemaToDhallType (RecordSchema m) = + D.Record (Map.fromList (Data.Map.toList (fmap (D.makeRecordField . schemaToDhallType) m))) + +{-| `inferSchema` will never infer a union type with more than one numeric + alternative + + Instead, the most general alternative type will be preferred, which this + type tracks +-} +data UnionNumber + = UnionAbsent + -- ^ The union type does not have a numeric alternative + | UnionNatural + -- ^ The union type has a @Natural@ alternative + | UnionInteger + -- ^ The union type has an @Integer@ alternative + | UnionDouble + -- ^ The union type has a @Double@ alternative + deriving (Bounded, Eq, Ord) + +-- | Unify two numeric alternative types by preferring the most general type +instance Semigroup UnionNumber where + (<>) = max + +instance Monoid UnionNumber where + mempty = minBound + +unionNumberToAlternatives :: UnionNumber -> [ (Text, Maybe (Expr s a)) ] +unionNumberToAlternatives UnionAbsent = [] +unionNumberToAlternatives UnionNatural = [ ("Natural", Just D.Natural) ] +unionNumberToAlternatives UnionInteger = [ ("Integer", Just D.Integer) ] +unionNumberToAlternatives UnionDouble = [ ("Double" , Just D.Double ) ] + +{-| A union type that `inferSchema` can infer + + This type will have at most three alternatives: + + * A @Bool@ alternative + * Either a @Natural@, @Integer@, or @Double@ alternative + * A @Text@ alternative + + These alternatives will always use the same names and types when we convert + back to a Dhall type, so we only need to keep track of whether or not each + alternative is present. + + We only store simple types inside of a union since we treat any attempt to + unify a simple type with a complex type as a strong indication that the + user intended for the schema to be `ArbitraryJSON`. +-} +data UnionSchema = UnionSchema + { bool :: Any + -- ^ `True` if the union has a @Bool@ alternative + , number :: UnionNumber + -- ^ Up to one numeric alternative + , text :: Any + -- ^ `True` if the union has a @Text@ alternative + } deriving (Eq) + +unionSchemaToDhallType :: UnionSchema -> Expr s a +unionSchemaToDhallType UnionSchema{..} = D.Union (Map.fromList alternatives) + where + alternatives = + (if getAny bool then [ ("Bool", Just D.Bool) ] else []) + <> unionNumberToAlternatives number + <> (if getAny text then [ ("Text", Just D.Text) ] else []) + +-- | Unify two union types by combining their alternatives +instance Semigroup UnionSchema where + UnionSchema boolL numberL textL <> UnionSchema boolR numberR textR = + UnionSchema{..} + where + bool = boolL <> boolR + + number = numberL <> numberR + + text = textL <> textR + +instance Monoid UnionSchema where + mempty = UnionSchema{..} + where + bool = mempty + + number = mempty + + text = mempty + +{-| A `Schema` is a subset of the `Expr` type representing all possible + Dhall types that `inferSchema` could potentially return +-} +data Schema + = Bool + | Natural + | Integer + | Double + | Text + | List Schema + | Optional Schema + | Record RecordSchema + | Union UnionSchema + | ArbitraryJSON + +-- | (`<>`) unifies two schemas +instance Semigroup Schema where + -- `ArbitraryJSON` subsumes every other type + ArbitraryJSON <> _ = ArbitraryJSON + _ <> ArbitraryJSON = ArbitraryJSON + + -- Simple types unify with themselves + Bool <> Bool = Bool + Text <> Text = Text + Natural <> Natural = Natural + Integer <> Integer = Integer + Double <> Double = Double + + -- Complex types unify with themselves + Record l <> Record r = Record (l <> r) + List l <> List r = List (l <> r) + Union l <> Union r = Union (l <> r) + Optional l <> Optional r = Optional (l <> r) + + -- Numeric types unify on the most general numeric type + Natural <> Integer = Integer + Integer <> Natural = Integer + Natural <> Double = Double + Integer <> Double = Double + Double <> Natural = Double + Double <> Integer = Double + + -- Unifying two different simple types produces a union + Bool <> Natural = Union mempty{ bool = Any True, number = UnionNatural } + Bool <> Integer = Union mempty{ bool = Any True, number = UnionInteger } + Bool <> Double = Union mempty{ bool = Any True, number = UnionDouble } + Bool <> Text = Union mempty{ bool = Any True, text = Any True } + Natural <> Bool = Union mempty{ bool = Any True, number = UnionNatural } + Natural <> Text = Union mempty{ number = UnionNatural, text = Any True } + Integer <> Bool = Union mempty{ bool = Any True, number = UnionInteger } + Integer <> Text = Union mempty{ number = UnionInteger, text = Any True } + Double <> Bool = Union mempty{ bool = Any True, number = UnionDouble } + Double <> Text = Union mempty{ number = UnionDouble, text = Any True } + Text <> Bool = Union mempty{ bool = Any True, text = Any True } + Text <> Natural = Union mempty{ number = UnionNatural, text = Any True } + Text <> Integer = Union mempty{ number = UnionInteger, text = Any True } + Text <> Double = Union mempty{ number = UnionDouble, text = Any True } + + -- The empty union type is the identity of unification + Union l <> r | l == mempty = r + l <> Union r | r == mempty = l + + -- Unifying a simple type with a union adds the simple type as yet another + -- alternative + Bool <> Union r = Union (mempty{ bool = Any True } <> r) + Natural <> Union r = Union (mempty{ number = UnionNatural } <> r) + Integer <> Union r = Union (mempty{ number = UnionInteger } <> r) + Double <> Union r = Union (mempty{ number = UnionDouble} <> r) + Text <> Union r = Union (mempty{ text = Any True } <> r) + Union l <> Bool = Union (l <> mempty{ bool = Any True }) + Union l <> Natural = Union (l <> mempty{ number = UnionNatural }) + Union l <> Integer = Union (l <> mempty{ number = UnionInteger }) + Union l <> Double = Union (l <> mempty{ number = UnionDouble }) + Union l <> Text = Union (l <> mempty{ text = Any True }) + + -- All of the remaining cases are for unifying simple types with + -- complex types. The only such case that can be sensibly unified is for + -- `Optional` + + -- `Optional` subsumes every type other than `ArbitraryJSON` + Optional l <> r = Optional (l <> r) + l <> Optional r = Optional (l <> r) + + -- For all other cases, a simple type cannot be unified with a complex + -- type, so fall back to `ArbitraryJSON` + -- + -- This is equivalent to: + -- + -- _ <> _ = ArbitraryJSON + -- + -- ... but more explicit, in order to minimize the chance of ignoring an + -- important case by accident. + List _ <> _ = ArbitraryJSON + _ <> List _ = ArbitraryJSON + Record _ <> _ = ArbitraryJSON + _ <> Record _ = ArbitraryJSON + +instance Monoid Schema where + mempty = Union mempty + +-- | Convert a `Schema` to the corresponding Dhall type +schemaToDhallType :: Schema -> Expr s a +schemaToDhallType Bool = D.Bool +schemaToDhallType Natural = D.Natural +schemaToDhallType Integer = D.Integer +schemaToDhallType Double = D.Double +schemaToDhallType Text = D.Text +schemaToDhallType (List a) = D.App D.List (schemaToDhallType a) +schemaToDhallType (Optional a) = D.App D.Optional (schemaToDhallType a) +schemaToDhallType (Record r) = recordSchemaToDhallType r +schemaToDhallType (Union u) = unionSchemaToDhallType u +schemaToDhallType ArbitraryJSON = + D.Pi mempty "_" (D.Const D.Type) + (D.Pi mempty "_" + (D.Record + [ ("array" , D.makeRecordField $ D.Pi mempty "_" (D.App D.List (V 0)) (V 1)) + , ("bool" , D.makeRecordField $ D.Pi mempty "_" D.Bool (V 1)) + , ("double", D.makeRecordField $ D.Pi mempty "_" D.Double (V 1)) + , ("integer", D.makeRecordField $ D.Pi mempty "_" D.Integer (V 1)) + , ("null" , D.makeRecordField $ V 0) + , ("object", D.makeRecordField $ + D.Pi mempty "_" (D.App D.List (D.Record + [ ("mapKey", D.makeRecordField D.Text) + , ("mapValue", D.makeRecordField $ V 0) + ])) (V 1)) + , ("string", D.makeRecordField $ D.Pi mempty "_" D.Text (V 1)) + ] + ) + (V 1) + ) + {-| The main conversion function. Traversing\/zipping Dhall /type/ and Aeson value trees together to produce a Dhall /term/ tree, given 'Conversion' options: >>> :set -XOverloadedStrings >>> import qualified Dhall.Core as D >>> import qualified Dhall.Map as Map ->>> import qualified Data.Aeson as A +>>> import qualified Data.Aeson as Aeson >>> import qualified Data.HashMap.Strict as HM >>> s = D.Record (Map.fromList [("foo", D.Integer)]) ->>> v = A.Object (HM.fromList [("foo", A.Number 1)]) +>>> v = Aeson.Object (HM.fromList [("foo", Aeson.Number 1)]) >>> dhallFromJSON defaultConversion s v Right (RecordLit (fromList [("foo",IntegerLit 1)])) -} dhallFromJSON - :: Conversion -> ExprX -> A.Value -> Either CompileError ExprX + :: Conversion -> ExprX -> Value -> Either CompileError ExprX dhallFromJSON (Conversion {..}) expressionType = - loop (D.alphaNormalize (D.normalize expressionType)) + fmap (Optics.rewriteOf D.subExpressions Lint.useToMap) . loop [] (D.alphaNormalize (D.normalize expressionType)) where + loop :: Aeson.Types.JSONPath -> ExprX -> Aeson.Value -> Either CompileError ExprX -- any ~> Union - loop t@(D.Union tm) v = do + loop jsonPath t@(D.Union tm) v = do let f key maybeType = case maybeType of Just _type -> do - expression <- loop _type v + expression <- loop jsonPath _type v - return (D.App (D.Field t key) expression) + return (D.App (D.Field t $ FA key) expression) - Nothing -> do + Nothing -> case v of - A.String text | key == text -> do - return (D.Field t key) - _ -> do - Left (Mismatch t v) + Aeson.String text | key == text -> + return (D.Field t $ FA key) + _ -> + Left (Mismatch t v jsonPath) case (unions, rights (toList (Map.mapWithKey f tm))) of (UNone , _ ) -> Left (ContainsUnion t) (UStrict, xs@(_:_:_)) -> Left (UndecidableUnion t v xs) - (_ , [ ] ) -> Left (Mismatch t v) + (_ , [ ] ) -> Left (Mismatch t v jsonPath) (UFirst , x:_ ) -> Right x (UStrict, [x] ) -> Right x -- object ~> Record - loop (D.Record r) v@(A.Object o) - | extraKeys <- HM.keys o \\ Map.keys r + loop jsonPath (D.Record r) v@(Aeson.Object o) + | extraKeys <- JSON.Compat.objectKeys o \\ Map.keys r , strictRecs && not (null extraKeys) - = Left (UnhandledKeys extraKeys (D.Record r) v) + = Left (UnhandledKeys extraKeys (D.Record r) v jsonPath) | otherwise = let f :: Text -> ExprX -> Either CompileError ExprX - f k t | Just value <- HM.lookup k o - = loop t value + f k t | Just value <- JSON.Compat.lookupObject k o + = loop (Aeson.Types.Key (JSON.Compat.textToKey k) : jsonPath) t value | App D.Optional t' <- t = Right (App D.None t') | App D.List _ <- t , omissibleLists = Right (D.ListLit (Just t) []) | otherwise - = Left (MissingKey k t v) - in D.RecordLit <$> Map.traverseWithKey f r + = Left (MissingKey k t v jsonPath) + in D.RecordLit . fmap D.makeRecordField <$> Map.traverseWithKey f (D.recordFieldValue <$> r) -- key-value list ~> Record - loop t@(D.Record _) v@(A.Array a) + loop jsonPath t@(D.Record _) v@(Aeson.Array a) | not noKeyValArr - , os :: [A.Value] <- toList a + , os :: [Value] <- toList a , Just kvs <- traverse keyValMay os - = loop t (A.Object $ HM.fromList kvs) + = loop jsonPath t (Aeson.Object $ JSON.Compat.objectFromList kvs) | noKeyValArr = Left (NoKeyValArray t v) | otherwise - = Left (Mismatch t v) + = Left (Mismatch t v jsonPath) -- object ~> List (key, value) - loop t@(App D.List (D.Record r)) v@(A.Object o) + loop jsonPath t@(App D.List (D.Record r)) v@(Aeson.Object o) | not noKeyValMap , ["mapKey", "mapValue"] == Map.keys r - , Just mapKey <- Map.lookup "mapKey" r - , Just mapValue <- Map.lookup "mapValue" r + , Just mapKey <- D.recordFieldValue <$> Map.lookup "mapKey" r + , Just mapValue <- D.recordFieldValue <$> Map.lookup "mapValue" r = do - keyExprMap <- traverse (loop mapValue) o + keyExprMap <- JSON.Compat.traverseObjectWithKey (\k child -> loop (Aeson.Types.Key k : jsonPath) mapValue child) o - toKey <- do + toKey <- case mapKey of - D.Text -> return (\key -> D.TextLit (Chunks [] key)) - D.Union _ -> return (\key -> D.Field mapKey key) - _ -> Left (Mismatch t v) + D.Text -> return $ D.TextLit . Chunks [] + D.Union _ -> return $ D.Field mapKey . FA + _ -> Left (Mismatch t v jsonPath) let f :: (Text, ExprX) -> ExprX - f (key, val) = D.RecordLit ( Map.fromList + f (key, val) = D.RecordLit $ D.makeRecordField <$> Map.fromList [ ("mapKey" , toKey key) , ("mapValue", val) - ] ) + ] - let records = (fmap f . Seq.fromList . HM.toList) keyExprMap + let records = + (fmap f . Seq.fromList . JSON.Compat.mapToAscList) keyExprMap - let typeAnn = if HM.null o then Just t else Nothing + let typeAnn = if null o then Just t else Nothing return (D.ListLit typeAnn records) | noKeyValMap = Left (NoKeyValMap t v) | otherwise - = Left (Mismatch t v) + = Left (Mismatch t v jsonPath) -- array ~> List - loop (App D.List t) (A.Array a) + loop jsonPath (App D.List t) (Aeson.Array a) = let f :: [ExprX] -> ExprX f es = D.ListLit (if null es then Just (App D.List t) else Nothing) (Seq.fromList es) - in f <$> traverse (loop t) (toList a) + in f <$> traverse (\(idx, val) -> loop (Aeson.Types.Index idx : jsonPath) t val) (zip [0..] $ toList a) -- null ~> List - loop t@(App D.List _) (A.Null) + loop jsonPath t@(App D.List _) Aeson.Null = if omissibleLists then Right (D.ListLit (Just t) []) - else Left (Mismatch t A.Null) + else Left (Mismatch t Aeson.Null jsonPath) -- number ~> Integer - loop D.Integer (A.Number x) + loop jsonPath D.Integer (Aeson.Number x) | Right n <- floatingOrInteger x :: Either Double Integer = Right (D.IntegerLit n) | otherwise - = Left (Mismatch D.Integer (A.Number x)) + = Left (Mismatch D.Integer (Aeson.Number x) jsonPath) -- number ~> Natural - loop D.Natural (A.Number x) + loop jsonPath D.Natural (Aeson.Number x) | Right n <- floatingOrInteger x :: Either Double Integer , n >= 0 = Right (D.NaturalLit (fromInteger n)) | otherwise - = Left (Mismatch D.Natural (A.Number x)) + = Left (Mismatch D.Natural (Aeson.Number x) jsonPath) -- number ~> Double - loop D.Double (A.Number x) + loop _ D.Double (Aeson.Number x) = Right (D.DoubleLit $ DhallDouble $ toRealFloat x) -- string ~> Text - loop D.Text (A.String t) + loop _ D.Text (Aeson.String t) = Right (D.TextLit (Chunks [] t)) -- bool ~> Bool - loop D.Bool (A.Bool t) + loop _ D.Bool (Aeson.Bool t) = Right (D.BoolLit t) -- null ~> Optional - loop (App D.Optional expr) A.Null + loop _ (App D.Optional expr) Aeson.Null = Right $ App D.None expr -- value ~> Optional - loop (App D.Optional expr) value - = D.Some <$> loop expr value + loop jsonPath (App D.Optional expr) value + = D.Some <$> loop jsonPath expr value - -- Arbitrary JSON ~> https://prelude.dhall-lang.org/JSON/Type + -- Arbitrary JSON ~> https://prelude.dhall-lang.org/JSON/Type (< v13.0.0) loop - (D.Pi _ (D.Const D.Type) - (D.Pi _ + _ + (D.Pi _ _ (D.Const D.Type) + (D.Pi _ _ (D.Record - [ ("array" , D.Pi _ (D.App D.List (V 0)) (V 1)) - , ("bool" , D.Pi _ D.Bool (V 1)) - , ("null" , V 0) - , ("number", D.Pi _ D.Double (V 1)) - , ("object", D.Pi _ (D.App D.List (D.Record [ ("mapKey", D.Text), ("mapValue", V 0)])) (V 1)) - , ("string", D.Pi _ D.Text (V 1)) + [ ("array" , D.recordFieldValue -> D.Pi _ _ (D.App D.List (V 0)) (V 1)) + , ("bool" , D.recordFieldValue -> D.Pi _ _ D.Bool (V 1)) + , ("null" , D.recordFieldValue -> V 0) + , ("number", D.recordFieldValue -> D.Pi _ _ D.Double (V 1)) + , ("object", D.recordFieldValue -> + D.Pi _ _ (D.App D.List (D.Record + [ ("mapKey", D.recordFieldValue -> D.Text) + , ("mapValue", D.recordFieldValue -> V 0) + ])) (V 1)) + , ("string", D.recordFieldValue -> D.Pi _ _ D.Text (V 1)) ] ) (V 1) ) ) value = do - let outer (A.Object o) = + let outer (Aeson.Object o) = let inner (key, val) = D.RecordLit - [ ("mapKey" , D.TextLit (D.Chunks [] key)) - , ("mapValue", outer val ) + [ ("mapKey" , D.makeRecordField $ D.TextLit (D.Chunks [] key)) + , ("mapValue", D.makeRecordField $ outer val ) ] - elements = Seq.fromList (fmap inner (HM.toList o)) + elements = + Seq.fromList + (fmap inner + (JSON.Compat.mapToAscList o) + ) elementType | null elements = - Just (D.App D.List (D.Record [ ("mapKey", D.Text), ("mapValue", "JSON") ])) + Just (D.App D.List (D.Record + [ ("mapKey", D.makeRecordField D.Text) + , ("mapValue", D.makeRecordField "JSON") + ])) | otherwise = Nothing keyValues = D.ListLit elementType elements - in (D.App (D.Field "json" "object") keyValues) - outer (A.Array a) = + in D.App (D.Field "json" $ FA "object") keyValues + outer (Aeson.Array a) = let elements = Seq.fromList (fmap outer (Vector.toList a)) elementType | null elements = Just (D.App D.List "JSON") | otherwise = Nothing - in D.App (D.Field "json" "array") (D.ListLit elementType elements) - outer (A.String s) = - D.App (D.Field "json" "string") (D.TextLit (D.Chunks [] s)) - outer (A.Number n) = - D.App (D.Field "json" "number") (D.DoubleLit (DhallDouble (toRealFloat n))) - outer (A.Bool b) = - D.App (D.Field "json" "bool") (D.BoolLit b) - outer A.Null = - D.Field "json" "null" + in D.App (D.Field "json" $ FA "array") (D.ListLit elementType elements) + outer (Aeson.String s) = + D.App (D.Field "json" $ FA "string") (D.TextLit (D.Chunks [] s)) + outer (Aeson.Number n) = + D.App (D.Field "json" $ FA "number") (D.DoubleLit (DhallDouble (toRealFloat n))) + outer (Aeson.Bool b) = + D.App (D.Field "json" $ FA "bool") (D.BoolLit b) + outer Aeson.Null = + D.Field "json" $ FA "null" let result = - D.Lam "JSON" (D.Const D.Type) - (D.Lam "json" + D.Lam mempty (D.makeFunctionBinding "JSON" (D.Const D.Type)) + (D.Lam mempty (D.makeFunctionBinding "json" (D.Record - [ ("array" , D.Pi "_" (D.App D.List "JSON") "JSON") - , ("bool" , D.Pi "_" D.Bool "JSON") - , ("null" , "JSON") - , ("number", D.Pi "_" D.Double "JSON") - , ("object", D.Pi "_" (D.App D.List (D.Record [ ("mapKey", D.Text), ("mapValue", "JSON")])) "JSON") - , ("string", D.Pi "_" D.Text "JSON") + [ ("array" , D.makeRecordField $ D.Pi mempty "_" (D.App D.List "JSON") "JSON") + , ("bool" , D.makeRecordField $ D.Pi mempty "_" D.Bool "JSON") + , ("null" , D.makeRecordField "JSON") + , ("number", D.makeRecordField $ D.Pi mempty "_" D.Double "JSON") + , ("object", D.makeRecordField $ + D.Pi mempty "_" (D.App D.List (D.Record + [ ("mapKey", D.makeRecordField D.Text) + , ("mapValue", D.makeRecordField "JSON") + ])) "JSON") + , ("string", D.makeRecordField $ D.Pi mempty "_" D.Text "JSON") ] - ) + )) (outer value) ) return result + -- Arbitrary JSON ~> https://prelude.dhall-lang.org/JSON/Type (v13.0.0 <=) + loop + _ + (D.Pi _ _ (D.Const D.Type) + (D.Pi _ _ + (D.Record + [ ("array" , D.recordFieldValue -> D.Pi _ _ (D.App D.List (V 0)) (V 1)) + , ("bool" , D.recordFieldValue -> D.Pi _ _ D.Bool (V 1)) + , ("double", D.recordFieldValue -> D.Pi _ _ D.Double (V 1)) + , ("integer", D.recordFieldValue -> D.Pi _ _ D.Integer (V 1)) + , ("null" , D.recordFieldValue -> V 0) + , ("object", D.recordFieldValue -> + D.Pi _ _ (D.App D.List (D.Record + [ ("mapKey", D.recordFieldValue -> D.Text) + , ("mapValue", D.recordFieldValue -> V 0) + ])) (V 1)) + , ("string", D.recordFieldValue -> D.Pi _ _ D.Text (V 1)) + ] + ) + (V 1) + ) + ) + value = do + let outer (Aeson.Object o) = + let inner (key, val) = + D.RecordLit + [ ("mapKey" , D.makeRecordField $ D.TextLit (D.Chunks [] key)) + , ("mapValue", D.makeRecordField $ outer val ) + ] + + elements = + Seq.fromList + (fmap inner + (JSON.Compat.mapToAscList o) + ) + + elementType + | null elements = + Just (D.App D.List (D.Record + [ ("mapKey", D.makeRecordField D.Text) + , ("mapValue", D.makeRecordField "JSON") ])) + | otherwise = + Nothing + + keyValues = D.ListLit elementType elements + + in D.App (D.Field "json" (FA "object")) keyValues + outer (Aeson.Array a) = + let elements = Seq.fromList (fmap outer (Vector.toList a)) + + elementType + | null elements = Just (D.App D.List "JSON") + | otherwise = Nothing + + in D.App (D.Field "json" (FA "array")) (D.ListLit elementType elements) + outer (Aeson.String s) = + D.App (D.Field "json" (FA "string")) (D.TextLit (D.Chunks [] s)) + outer (Aeson.Number n) = + case floatingOrInteger n of + Left floating -> D.App (D.Field "json" (FA "double")) (D.DoubleLit (DhallDouble floating)) + Right integer -> D.App (D.Field "json" (FA "integer")) (D.IntegerLit integer) + outer (Aeson.Bool b) = + D.App (D.Field "json" (FA "bool")) (D.BoolLit b) + outer Aeson.Null = + D.Field "json" (FA "null") + + let result = + D.Lam mempty (D.makeFunctionBinding "JSON" (D.Const D.Type)) + (D.Lam mempty (D.makeFunctionBinding "json" + (D.Record + [ ("array" , D.makeRecordField $ D.Pi mempty "_" (D.App D.List "JSON") "JSON") + , ("bool" , D.makeRecordField $ D.Pi mempty "_" D.Bool "JSON") + , ("double", D.makeRecordField $ D.Pi mempty "_" D.Double "JSON") + , ("integer", D.makeRecordField $ D.Pi mempty "_" D.Integer "JSON") + , ("null" , D.makeRecordField "JSON") + , ("object", D.makeRecordField $ D.Pi mempty "_" + (D.App D.List (D.Record + [ ("mapKey", D.makeRecordField D.Text) + , ("mapValue", D.makeRecordField "JSON")])) "JSON") + , ("string", D.makeRecordField $ D.Pi mempty "_" D.Text "JSON") + ] + )) + (outer value) + ) + + return result + -- fail - loop expr value - = Left (Mismatch expr value) + loop jsonPath expr value + = Left (Mismatch expr value jsonPath) -- ---------- @@ -600,7 +1120,7 @@ -- ---------- red, purple, green - :: (Monoid a, Data.String.IsString a) => a -> a + :: (Semigroup a, Data.String.IsString a) => a -> a red s = "\ESC[1;31m" <> s <> "\ESC[0m" -- bold purple s = "\ESC[1;35m" <> s <> "\ESC[0m" -- bold green s = "\ESC[0;32m" <> s <> "\ESC[0m" -- plain @@ -608,7 +1128,7 @@ showExpr :: ExprX -> String showExpr dhall = Text.unpack (D.pretty dhall) -showJSON :: A.Value -> String +showJSON :: Value -> String showJSON value = BSL8.unpack (encodePretty value) data CompileError @@ -620,22 +1140,23 @@ -- generic mismatch (fallback) | Mismatch ExprX -- Dhall expression - A.Value -- Aeson value + Value -- Aeson value + Aeson.Types.JSONPath -- JSON Path to the error -- record specific - | MissingKey Text ExprX A.Value - | UnhandledKeys [Text] ExprX A.Value - | NoKeyValArray ExprX A.Value - | NoKeyValMap ExprX A.Value + | MissingKey Text ExprX Value Aeson.Types.JSONPath + | UnhandledKeys [Text] ExprX Value Aeson.Types.JSONPath + | NoKeyValArray ExprX Value + | NoKeyValMap ExprX Value -- union specific | ContainsUnion ExprX - | UndecidableUnion ExprX A.Value [ExprX] + | UndecidableUnion ExprX Value [ExprX] instance Show CompileError where show = showCompileError "JSON" showJSON instance Exception CompileError -showCompileError :: String -> (A.Value -> String) -> CompileError -> String +showCompileError :: String -> (Value -> String) -> CompileError -> String showCompileError format showValue = let prefix = red "\nError: " in \case TypeError e -> show e @@ -659,21 +1180,22 @@ <> Text.unpack (Text.intercalate sep $ D.pretty <$> xs) where sep = red "\n--------\n" :: Text - Mismatch e v -> prefix - <> "Dhall type expression and " <> format <> " value do not match:" + Mismatch e v jsonPath -> prefix + <> showJsonPath jsonPath <> ": Dhall type expression and " <> format <> " value do not match:" <> "\n\nExpected Dhall type:\n" <> showExpr e <> "\n\n" <> format <> ":\n" <> showValue v <> "\n" - MissingKey k e v -> prefix - <> "Key " <> purple (Text.unpack k) <> ", expected by Dhall type:\n" + MissingKey k e v jsonPath -> prefix + <> showJsonPath jsonPath <> ": Key " <> purple (Text.unpack k) <> ", expected by Dhall type:\n" <> showExpr e <> "\nis not present in " <> format <> " object:\n" <> showValue v <> "\n" - UnhandledKeys ks e v -> prefix - <> "Key(s) " <> purple (Text.unpack (Text.intercalate ", " ks)) - <> " present in the " <> format <> " object but not in the expected Dhall record type. This is not allowed unless you enable the " + UnhandledKeys ks e v jsonPath -> prefix + <> showJsonPath jsonPath <> ": Key(s) " <> purple (Text.unpack (Text.intercalate ", " ks)) + <> " present in the " <> format <> " object but not in the expected Dhall" + <> " record type. This is not allowed unless you enable the " <> green "--records-loose" <> " flag:" <> "\n\nExpected Dhall type:\n" <> showExpr e <> "\n\n" <> format <> ":\n" <> showValue v @@ -688,7 +1210,10 @@ NoKeyValMap e v -> prefix <> "Homogeneous " <> format <> " map objects cannot be converted to Dhall association lists under " - <> green "--no-keyval-arrays" <> " flag" + <> green "--no-keyval-maps" <> " flag" <> "\n\nExpected Dhall type:\n" <> showExpr e <> "\n\n" <> format <> ":\n" <> showValue v <> "\n" + +showJsonPath :: Aeson.Types.JSONPath -> String +showJsonPath = Aeson.Types.formatPath . reverse diff --git a/tasty/Main.hs b/tasty/Main.hs --- a/tasty/Main.hs +++ b/tasty/Main.hs @@ -1,14 +1,14 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} module Main where -import Data.Monoid ((<>)) +import Data.Void (Void) import Test.Tasty (TestTree) import qualified Data.Aeson as Aeson import qualified Data.ByteString.Lazy +import qualified Data.Text import qualified Data.Text.IO import qualified Dhall.Core as Core import qualified Dhall.Import @@ -19,6 +19,7 @@ import qualified GHC.IO.Encoding import qualified Test.Tasty import qualified Test.Tasty.HUnit +import qualified Test.Tasty.Silver main :: IO () main = do @@ -31,12 +32,24 @@ Test.Tasty.testGroup "dhall-json" [ testDhallToJSON "./tasty/data/issue48" , testDhallToJSON "./tasty/data/emptyObjectStrongType" + , testDhallToJSON "./tasty/data/toArbitraryJSON_12_0_0" + , testDhallToJSON "./tasty/data/toArbitraryJSON_13_0_0" , testJSONToDhall "./tasty/data/emptyAlternative" , testJSONToDhall "./tasty/data/emptyObject" , testJSONToDhall "./tasty/data/emptyList" , testJSONToDhall "./tasty/data/emptyObjectStrongType" , testJSONToDhall "./tasty/data/emptyListStrongType" - , testCustomConversionJSONToDhall omissibleLists "./tasty/data/missingList" + , testJSONToDhall "./tasty/data/fromArbitraryJSON_12_0_0" + , testJSONToDhall "./tasty/data/fromArbitraryJSON_13_0_0" + , inferJSONToDhall "./tasty/data/potpourri" + , testCustomConversionJSONToDhall False omissibleLists "./tasty/data/missingList" + , Test.Tasty.testGroup "Errors" + [ testJSONToDhallErrorMessage "./tasty/data/error/mismatchMessage0" defaultConversion + , testJSONToDhallErrorMessage "./tasty/data/error/mismatchMessage1" defaultConversion + , testJSONToDhallErrorMessage "./tasty/data/error/mismatchMessage2" defaultConversion + , testJSONToDhallErrorMessage "./tasty/data/error/unhandledKeys" strictRecs + , testJSONToDhallErrorMessage "./tasty/data/error/missingKey" strictRecs + ] , Test.Tasty.testGroup "Nesting" [ testDhallToJSON "./tasty/data/nesting0" , testDhallToJSON "./tasty/data/nesting1" @@ -44,13 +57,17 @@ , testDhallToJSON "./tasty/data/nesting3" , testDhallToJSON "./tasty/data/nestingLegacy0" , testDhallToJSON "./tasty/data/nestingLegacy1" + , testDhallToJSON "./tasty/data/time" ] , Test.Tasty.testGroup "Union keys" [ testJSONToDhall "./tasty/data/unionKeys" , testDhallToJSON "./tasty/data/unionKeys" ] ] - where omissibleLists = JSONToDhall.defaultConversion{JSONToDhall.omissibleLists = True} + where + defaultConversion = JSONToDhall.defaultConversion + omissibleLists = defaultConversion{JSONToDhall.omissibleLists = True} + strictRecs = defaultConversion{JSONToDhall.strictRecs = True} testDhallToJSON :: String -> TestTree testDhallToJSON prefix = Test.Tasty.HUnit.testCase prefix $ do @@ -59,7 +76,7 @@ text <- Data.Text.IO.readFile inputFile - parsedExpression <- do + parsedExpression <- Core.throws (Dhall.Parser.exprFromText inputFile text) resolvedExpression <- Dhall.Import.load parsedExpression @@ -69,7 +86,7 @@ let convertedExpression = Dhall.JSON.convertToHomogeneousMaps Dhall.JSON.defaultConversion resolvedExpression - actualValue <- do + actualValue <- Core.throws (Dhall.JSON.dhallToJSON convertedExpression) bytes <- Data.ByteString.Lazy.readFile outputFile @@ -82,41 +99,40 @@ Test.Tasty.HUnit.assertEqual message expectedValue actualValue -testCustomConversionJSONToDhall :: JSONToDhall.Conversion -> String -> TestTree -testCustomConversionJSONToDhall conv prefix = +testCustomConversionJSONToDhall + :: Bool -> JSONToDhall.Conversion -> String -> TestTree +testCustomConversionJSONToDhall infer conv prefix = Test.Tasty.HUnit.testCase prefix $ do let inputFile = prefix <> ".json" - let schemaFile = prefix <> "Schema.dhall" let outputFile = prefix <> ".dhall" bytes <- Data.ByteString.Lazy.readFile inputFile - value <- do + value <- case Aeson.eitherDecode bytes of Left string -> fail string Right value -> return value - schemaText <- Data.Text.IO.readFile schemaFile - - parsedSchema <- Core.throws (Dhall.Parser.exprFromText schemaFile schemaText) - - schema <- Dhall.Import.load parsedSchema + schema <- + if infer + then return (JSONToDhall.schemaToDhallType (JSONToDhall.inferSchema value)) + else let schemaFile = prefix <> "Schema.dhall" in loadSchemaFromFile schemaFile _ <- Core.throws (Dhall.TypeCheck.typeOf schema) - actualExpression <- do + actualExpression <- Core.throws (JSONToDhall.dhallFromJSON conv schema value) outputText <- Data.Text.IO.readFile outputFile - parsedExpression <- do + parsedExpression <- Core.throws (Dhall.Parser.exprFromText outputFile outputText) resolvedExpression <- Dhall.Import.load parsedExpression _ <- Core.throws (Dhall.TypeCheck.typeOf resolvedExpression) - let expectedExpression = Core.normalize resolvedExpression + let expectedExpression = Core.denote resolvedExpression let message = "Conversion to Dhall did not generate the expected output" @@ -124,4 +140,44 @@ Test.Tasty.HUnit.assertEqual message expectedExpression actualExpression testJSONToDhall :: String -> TestTree -testJSONToDhall = testCustomConversionJSONToDhall JSONToDhall.defaultConversion +testJSONToDhall = + testCustomConversionJSONToDhall False JSONToDhall.defaultConversion + +inferJSONToDhall :: String -> TestTree +inferJSONToDhall = + testCustomConversionJSONToDhall True JSONToDhall.defaultConversion + +loadSchemaFromFile :: FilePath -> IO (Core.Expr Dhall.Parser.Src Void) +loadSchemaFromFile schemaFile = do + schemaText <- Data.Text.IO.readFile schemaFile + + parsedSchema <- Core.throws (Dhall.Parser.exprFromText schemaFile schemaText) + + Dhall.Import.load parsedSchema + +testJSONToDhallErrorMessage :: String -> JSONToDhall.Conversion -> TestTree +testJSONToDhallErrorMessage prefix conv = + Test.Tasty.Silver.goldenVsAction prefix goldenFile action converter + where + goldenFile = prefix <> ".golden" + schemaFile = prefix <> "Schema.dhall" + inputFile = prefix <> ".json" + + action = do + bytes <- Data.ByteString.Lazy.readFile inputFile + + value <- + case Aeson.eitherDecode bytes of + Left string -> fail string + Right value -> return value + + schema <- loadSchemaFromFile schemaFile + + _ <- Core.throws (Dhall.TypeCheck.typeOf schema) + + case JSONToDhall.dhallFromJSON conv schema value of + Right _ -> fail $ prefix <> " should fail" + Left compileError -> + return (Data.Text.pack $ show compileError) + + converter = id diff --git a/tasty/data/emptyObject.dhall b/tasty/data/emptyObject.dhall --- a/tasty/data/emptyObject.dhall +++ b/tasty/data/emptyObject.dhall @@ -1,17 +1,11 @@ λ(JSON : Type) → λ ( json - : { array : - List JSON → JSON - , bool : - Bool → JSON - , null : - JSON - , number : - Double → JSON - , object : - List { mapKey : Text, mapValue : JSON } → JSON - , string : - Text → JSON + : { array : List JSON → JSON + , bool : Bool → JSON + , null : JSON + , number : Double → JSON + , object : List { mapKey : Text, mapValue : JSON } → JSON + , string : Text → JSON } ) -→ json.object ([] : List { mapKey : Text, mapValue : JSON }) +→ json.object (toMap {=} : List { mapKey : Text, mapValue : JSON }) diff --git a/tasty/data/emptyObjectStrongType.dhall b/tasty/data/emptyObjectStrongType.dhall --- a/tasty/data/emptyObjectStrongType.dhall +++ b/tasty/data/emptyObjectStrongType.dhall @@ -1,1 +1,1 @@ -[] : List { mapKey : Text, mapValue : Natural } +toMap {=} : List { mapKey : Text, mapValue : Natural } diff --git a/tasty/data/error/mismatchMessage0.golden b/tasty/data/error/mismatchMessage0.golden new file mode 100644 --- /dev/null +++ b/tasty/data/error/mismatchMessage0.golden @@ -0,0 +1,8 @@ + +Error: $.a.b[1]: Dhall type expression and JSON value do not match: + +Expected Dhall type: +Natural + +JSON: +0.5 diff --git a/tasty/data/error/mismatchMessage0.json b/tasty/data/error/mismatchMessage0.json new file mode 100644 --- /dev/null +++ b/tasty/data/error/mismatchMessage0.json @@ -0,0 +1,14 @@ +{ + "a": { + "b": [ + 10, + 0.5 + ] + }, + "c": { + "d": [ + 10, + 0.5 + ] + } +} diff --git a/tasty/data/error/mismatchMessage0Schema.dhall b/tasty/data/error/mismatchMessage0Schema.dhall new file mode 100644 --- /dev/null +++ b/tasty/data/error/mismatchMessage0Schema.dhall @@ -0,0 +1,3 @@ +{ a : { b : List Natural } +, c : { d : List Integer } +} diff --git a/tasty/data/error/mismatchMessage1.golden b/tasty/data/error/mismatchMessage1.golden new file mode 100644 --- /dev/null +++ b/tasty/data/error/mismatchMessage1.golden @@ -0,0 +1,8 @@ + +Error: $: Dhall type expression and JSON value do not match: + +Expected Dhall type: +Text + +JSON: +1 diff --git a/tasty/data/error/mismatchMessage1.json b/tasty/data/error/mismatchMessage1.json new file mode 100644 --- /dev/null +++ b/tasty/data/error/mismatchMessage1.json @@ -0,0 +1,1 @@ +1 diff --git a/tasty/data/error/mismatchMessage1Schema.dhall b/tasty/data/error/mismatchMessage1Schema.dhall new file mode 100644 --- /dev/null +++ b/tasty/data/error/mismatchMessage1Schema.dhall @@ -0,0 +1,1 @@ +Text diff --git a/tasty/data/error/mismatchMessage2.golden b/tasty/data/error/mismatchMessage2.golden new file mode 100644 --- /dev/null +++ b/tasty/data/error/mismatchMessage2.golden @@ -0,0 +1,8 @@ + +Error: $[3]: Dhall type expression and JSON value do not match: + +Expected Dhall type: +Natural + +JSON: +"oh oh" diff --git a/tasty/data/error/mismatchMessage2.json b/tasty/data/error/mismatchMessage2.json new file mode 100644 --- /dev/null +++ b/tasty/data/error/mismatchMessage2.json @@ -0,0 +1,1 @@ +[ 1, 2, 3, "oh oh" ] diff --git a/tasty/data/error/mismatchMessage2Schema.dhall b/tasty/data/error/mismatchMessage2Schema.dhall new file mode 100644 --- /dev/null +++ b/tasty/data/error/mismatchMessage2Schema.dhall @@ -0,0 +1,1 @@ +List Natural diff --git a/tasty/data/error/missingKey.golden b/tasty/data/error/missingKey.golden new file mode 100644 --- /dev/null +++ b/tasty/data/error/missingKey.golden @@ -0,0 +1,5 @@ + +Error: $.a: Key b, expected by Dhall type: +Bool +is not present in JSON object: +{} diff --git a/tasty/data/error/missingKey.json b/tasty/data/error/missingKey.json new file mode 100644 --- /dev/null +++ b/tasty/data/error/missingKey.json @@ -0,0 +1,4 @@ +{ + "a": { + } +} diff --git a/tasty/data/error/missingKeySchema.dhall b/tasty/data/error/missingKeySchema.dhall new file mode 100644 --- /dev/null +++ b/tasty/data/error/missingKeySchema.dhall @@ -0,0 +1,1 @@ +{ a: { b: Bool } } diff --git a/tasty/data/error/unhandledKeys.golden b/tasty/data/error/unhandledKeys.golden new file mode 100644 --- /dev/null +++ b/tasty/data/error/unhandledKeys.golden @@ -0,0 +1,10 @@ + +Error: $[1]: Key(s) b present in the JSON object but not in the expected Dhall record type. This is not allowed unless you enable the --records-loose flag: + +Expected Dhall type: +{ a : Natural } + +JSON: +{ + "b": 2 +} diff --git a/tasty/data/error/unhandledKeys.json b/tasty/data/error/unhandledKeys.json new file mode 100644 --- /dev/null +++ b/tasty/data/error/unhandledKeys.json @@ -0,0 +1,4 @@ +[ + { "a": 1 }, + { "b": 2 } +] diff --git a/tasty/data/error/unhandledKeysSchema.dhall b/tasty/data/error/unhandledKeysSchema.dhall new file mode 100644 --- /dev/null +++ b/tasty/data/error/unhandledKeysSchema.dhall @@ -0,0 +1,1 @@ +List { a: Natural } diff --git a/tasty/data/fromArbitraryJSON_12_0_0.dhall b/tasty/data/fromArbitraryJSON_12_0_0.dhall new file mode 100644 --- /dev/null +++ b/tasty/data/fromArbitraryJSON_12_0_0.dhall @@ -0,0 +1,19 @@ + λ(JSON : Type) +→ λ ( json + : { array : List JSON → JSON + , bool : Bool → JSON + , null : JSON + , number : Double → JSON + , object : List { mapKey : Text, mapValue : JSON } → JSON + , string : Text → JSON + } + ) +→ json.object + ( toMap + { array = json.array ([] : List JSON) + , bool = json.bool False + , null = json.null + , number = json.number 1.0 + , string = json.string "ABC" + } + ) diff --git a/tasty/data/fromArbitraryJSON_12_0_0.json b/tasty/data/fromArbitraryJSON_12_0_0.json new file mode 100644 --- /dev/null +++ b/tasty/data/fromArbitraryJSON_12_0_0.json @@ -0,0 +1,7 @@ +{ + "array": [], + "bool": false, + "null": null, + "number": 1, + "string": "ABC" +} diff --git a/tasty/data/fromArbitraryJSON_12_0_0Schema.dhall b/tasty/data/fromArbitraryJSON_12_0_0Schema.dhall new file mode 100644 --- /dev/null +++ b/tasty/data/fromArbitraryJSON_12_0_0Schema.dhall @@ -0,0 +1,11 @@ + ∀(JSON : Type) +→ ∀ ( json + : { array : List JSON → JSON + , bool : Bool → JSON + , null : JSON + , number : Double → JSON + , object : List { mapKey : Text, mapValue : JSON } → JSON + , string : Text → JSON + } + ) +→ JSON diff --git a/tasty/data/fromArbitraryJSON_13_0_0.dhall b/tasty/data/fromArbitraryJSON_13_0_0.dhall new file mode 100644 --- /dev/null +++ b/tasty/data/fromArbitraryJSON_13_0_0.dhall @@ -0,0 +1,21 @@ + λ(JSON : Type) +→ λ ( json + : { array : List JSON → JSON + , bool : Bool → JSON + , double : Double → JSON + , integer : Integer → JSON + , null : JSON + , object : List { mapKey : Text, mapValue : JSON } → JSON + , string : Text → JSON + } + ) +→ json.object + ( toMap + { array = json.array ([] : List JSON) + , bool = json.bool False + , double = json.double 1.5 + , integer = json.integer +1 + , null = json.null + , string = json.string "ABC" + } + ) diff --git a/tasty/data/fromArbitraryJSON_13_0_0.json b/tasty/data/fromArbitraryJSON_13_0_0.json new file mode 100644 --- /dev/null +++ b/tasty/data/fromArbitraryJSON_13_0_0.json @@ -0,0 +1,8 @@ +{ + "array": [], + "bool": false, + "null": null, + "double": 1.5, + "integer": 1, + "string": "ABC" +} diff --git a/tasty/data/fromArbitraryJSON_13_0_0Schema.dhall b/tasty/data/fromArbitraryJSON_13_0_0Schema.dhall new file mode 100644 --- /dev/null +++ b/tasty/data/fromArbitraryJSON_13_0_0Schema.dhall @@ -0,0 +1,12 @@ + ∀(JSON : Type) +→ ∀ ( json + : { array : List JSON → JSON + , bool : Bool → JSON + , double : Double → JSON + , integer : Integer → JSON + , null : JSON + , object : List { mapKey : Text, mapValue : JSON } → JSON + , string : Text → JSON + } + ) +→ JSON diff --git a/tasty/data/missingList.dhall b/tasty/data/missingList.dhall --- a/tasty/data/missingList.dhall +++ b/tasty/data/missingList.dhall @@ -1,1 +1,4 @@ -{present = ["some-stuff"], null = [] : List Text, missing = [] : List Text} +{ missingProp = [] : List Text +, null = [] : List Text +, present = ["some-stuff"] +} diff --git a/tasty/data/missingListSchema.dhall b/tasty/data/missingListSchema.dhall --- a/tasty/data/missingListSchema.dhall +++ b/tasty/data/missingListSchema.dhall @@ -1,1 +1,1 @@ -{present : List Text, null : List Text, missing : List Text} +{present : List Text, null : List Text, missingProp : List Text} diff --git a/tasty/data/potpourri.dhall b/tasty/data/potpourri.dhall new file mode 100644 --- /dev/null +++ b/tasty/data/potpourri.dhall @@ -0,0 +1,53 @@ +[ { arbitraryJSON = + λ(JSON : Type) → + λ ( json + : { array : List JSON → JSON + , bool : Bool → JSON + , double : Double → JSON + , integer : Integer → JSON + , null : JSON + , object : List { mapKey : Text, mapValue : JSON } → JSON + , string : Text → JSON + } + ) → + json.integer +1 + , bool = True + , double = 0.0 + , extraField = None Bool + , integer = +0 + , natural = 0 + , null = None <> + , optional = Some 1 + , preferDouble = 0.0 + , preferInteger = +0 + , text = "abc" + , unifyEmpty = [] : List Natural + , unifySimple = < Bool : Bool | Text : Text >.Bool True + } +, { arbitraryJSON = + λ(JSON : Type) → + λ ( json + : { array : List JSON → JSON + , bool : Bool → JSON + , double : Double → JSON + , integer : Integer → JSON + , null : JSON + , object : List { mapKey : Text, mapValue : JSON } → JSON + , string : Text → JSON + } + ) → + json.array ([] : List JSON) + , bool = False + , double = 1.1 + , extraField = Some True + , integer = -1 + , natural = 1 + , null = None <> + , optional = None Natural + , preferDouble = 1.1 + , preferInteger = -1 + , text = "def" + , unifyEmpty = [ 1 ] + , unifySimple = < Bool : Bool | Text : Text >.Text "abc" + } +] diff --git a/tasty/data/potpourri.json b/tasty/data/potpourri.json new file mode 100644 --- /dev/null +++ b/tasty/data/potpourri.json @@ -0,0 +1,27 @@ +[ { "bool": true + , "text": "abc" + , "natural": 0 + , "integer": 0 + , "double": 0.0 + , "unifyEmpty": [] + , "preferInteger": 0 + , "preferDouble": 0 + , "unifySimple": true + , "optional": 1 + , "null": null + , "arbitraryJSON": 1 + } +, { "bool": false + , "text": "def" + , "natural": 1 + , "integer": -1 + , "double": 1.1 + , "unifyEmpty": [1] + , "preferInteger": -1 + , "preferDouble": 1.1 + , "unifySimple": "abc" + , "optional": null + , "extraField": true + , "arbitraryJSON": [] + } +] diff --git a/tasty/data/time.dhall b/tasty/data/time.dhall new file mode 100644 --- /dev/null +++ b/tasty/data/time.dhall @@ -0,0 +1,7 @@ +{ example0 = 2020-01-01 +, example1 = 00:00:00 +, example2 = +00:00 +, example3 = 2020-01-01T00:00:00 +, example4 = 00:00:00+00:00 +, example5 = 2020-01-01T00:00:00+00:00 +} diff --git a/tasty/data/time.json b/tasty/data/time.json new file mode 100644 --- /dev/null +++ b/tasty/data/time.json @@ -0,0 +1,8 @@ +{ + "example0": "2020-01-01", + "example1": "00:00:00", + "example2": "+00:00", + "example3": "2020-01-01T00:00:00", + "example4": "00:00:00+00:00", + "example5": "2020-01-01T00:00:00+00:00" +} diff --git a/tasty/data/toArbitraryJSON_12_0_0.dhall b/tasty/data/toArbitraryJSON_12_0_0.dhall new file mode 100644 --- /dev/null +++ b/tasty/data/toArbitraryJSON_12_0_0.dhall @@ -0,0 +1,17 @@ + λ(_ : Type) +→ λ ( _ + : { array : List _ → _@1 + , bool : Bool → _@1 + , null : _ + , number : Double → _@1 + , object : List { mapKey : Text, mapValue : _ } → _@1 + , string : Text → _@1 + } + ) +→ _.object + [ { mapKey = "array", mapValue = _.array ([] : List _@1) } + , { mapKey = "bool", mapValue = _.bool False } + , { mapKey = "null", mapValue = _.null } + , { mapKey = "number", mapValue = _.number 1.0 } + , { mapKey = "string", mapValue = _.string "ABC" } + ] diff --git a/tasty/data/toArbitraryJSON_12_0_0.json b/tasty/data/toArbitraryJSON_12_0_0.json new file mode 100644 --- /dev/null +++ b/tasty/data/toArbitraryJSON_12_0_0.json @@ -0,0 +1,7 @@ +{ + "array": [], + "bool": false, + "null": null, + "number": 1, + "string": "ABC" +} diff --git a/tasty/data/toArbitraryJSON_13_0_0.dhall b/tasty/data/toArbitraryJSON_13_0_0.dhall new file mode 100644 --- /dev/null +++ b/tasty/data/toArbitraryJSON_13_0_0.dhall @@ -0,0 +1,19 @@ + λ(_ : Type) +→ λ ( _ + : { array : List _ → _@1 + , bool : Bool → _@1 + , null : _ + , double : Double → _@1 + , integer : Integer → _@1 + , object : List { mapKey : Text, mapValue : _ } → _@1 + , string : Text → _@1 + } + ) +→ _.object + [ { mapKey = "array", mapValue = _.array ([] : List _@1) } + , { mapKey = "bool", mapValue = _.bool False } + , { mapKey = "null", mapValue = _.null } + , { mapKey = "double", mapValue = _.double 1.0 } + , { mapKey = "integer", mapValue = _.integer +1 } + , { mapKey = "string", mapValue = _.string "ABC" } + ] diff --git a/tasty/data/toArbitraryJSON_13_0_0.json b/tasty/data/toArbitraryJSON_13_0_0.json new file mode 100644 --- /dev/null +++ b/tasty/data/toArbitraryJSON_13_0_0.json @@ -0,0 +1,8 @@ +{ + "array": [], + "bool": false, + "null": null, + "double": 1, + "integer": 1, + "string": "ABC" +}