diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,18 @@ +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) diff --git a/dhall-json.cabal b/dhall-json.cabal --- a/dhall-json.cabal +++ b/dhall-json.cabal @@ -1,5 +1,5 @@ Name: dhall-json -Version: 1.6.4 +Version: 1.7.0 Cabal-Version: >=1.10 Build-Type: Simple Tested-With: GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.1 @@ -27,6 +27,9 @@ 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 @@ -36,12 +39,12 @@ Hs-Source-Dirs: src Build-Depends: base >= 4.8.0.0 && < 5 , - aeson >= 1.0.0.0 && < 1.5 , + aeson >= 1.0.0.0 && < 1.6 , aeson-pretty < 0.9 , aeson-yaml >= 1.0.6 && < 1.1 , bytestring < 0.11, - containers , - dhall >= 1.31.0 && < 1.33, + containers >= 0.5.9 && < 0.7 , + dhall >= 1.33.0 && < 1.34, exceptions >= 0.8.3 && < 0.11, filepath < 1.5 , optparse-applicative >= 0.14.0.0 && < 0.16, @@ -115,13 +118,14 @@ 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.4, + text , + tasty-hunit >= 0.2, + tasty-silver >= 3.0 GHC-Options: -Wall Default-Language: Haskell2010 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,12 @@ 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.Monoid ((<>)) +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 +34,7 @@ <*> Dhall.JSON.parseConversion <*> optional parseFile <*> optional parseOutput + <*> parseNoEdit ) <|> parseVersion where @@ -64,6 +65,12 @@ <> Options.metavar "FILE" ) + parseNoEdit = + Options.switch + ( Options.long "generated-comment" + <> Options.help "Include a comment header warning not to edit the generated file" + ) + parserInfo :: ParserInfo (Maybe Options) parserInfo = Options.info @@ -82,10 +89,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 +100,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 @@ -124,9 +124,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 +143,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 +165,7 @@ > $ cat ./example.dhall > let JSON = https://prelude.dhall-lang.org/JSON/package.dhall -> +> > in JSON.object > [ { mapKey = "foo", mapValue = JSON.null } > , { mapKey = @@ -212,21 +212,21 @@ , 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 Control.Applicative (empty, (<|>)) +import Control.Exception (Exception, throwIO) +import Control.Monad (guard) +import Data.Aeson (ToJSON (..), Value (..)) +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 Options.Applicative (Parser) -import Prelude hiding (getContents) +import Data.Void (Void) +import Dhall.Core (Binding (..), DhallDouble (..), Expr) +import Dhall.Import (SemanticCacheMode (..)) +import Dhall.JSON.Util (pattern V) +import Dhall.Map (Map) +import Options.Applicative (Parser) +import Prelude hiding (getContents) import qualified Data.Aeson as Aeson import qualified Data.Foldable as Foldable @@ -412,7 +412,7 @@ -> 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) @@ -459,7 +459,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 @@ -637,7 +637,7 @@ 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 @@ -962,12 +962,6 @@ Core.None -> Core.None - - Core.OptionalFold -> - Core.OptionalFold - - Core.OptionalBuild -> - Core.OptionalBuild Core.Record a -> Core.Record a' 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 @@ -13,12 +13,13 @@ , 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.Monoid ((<>)) +import Data.Text (Text) +import Dhall.JSON (Conversion (..), SpecialDoubleMode (..)) import Options.Applicative (Parser) import qualified Data.Aeson @@ -37,6 +38,7 @@ , conversion :: Conversion , file :: Maybe FilePath , output :: Maybe FilePath + , noEdit :: Bool } defaultOptions :: Options @@ -48,6 +50,7 @@ , conversion = Dhall.JSON.defaultConversion , file = Nothing , output = Nothing + , noEdit = False } parseDocuments :: Parser Bool @@ -63,7 +66,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 @@ -73,12 +82,17 @@ -> 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) - return $ jsonToYaml json documents quoted + let header = + if noEdit + then generatedCodeNotice + else mempty + + return $ header <> jsonToYaml json documents quoted -- | Transform json representation into yaml jsonToYaml diff --git a/src/Dhall/JSONToDhall.hs b/src/Dhall/JSONToDhall.hs --- a/src/Dhall/JSONToDhall.hs +++ b/src/Dhall/JSONToDhall.hs @@ -191,7 +191,22 @@ > $ 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 JSON @null@ values correspond to @Optional@ Dhall values: @@ -344,44 +359,45 @@ , showCompileError ) where -import Control.Applicative ((<|>)) -import Control.Exception (Exception, throwIO) -import Control.Monad.Catch (throwM, MonadCatch) -import Data.Aeson (Value) -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.Semigroup (Semigroup (..)) +import Data.Text (Text) +import Data.Void (Void) +import Dhall.Core (Chunks (..), DhallDouble (..), Expr (App)) +import Dhall.JSON.Util (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.Foldable as Foldable -import qualified Data.HashMap.Strict as HM -import Data.List ((\\)) -import qualified Data.List as List +import qualified Data.Foldable as Foldable +import qualified Data.HashMap.Strict as HM +import qualified Data.List as List import qualified Data.Map -import qualified Data.Map.Merge.Lazy as Data.Map.Merge -import Data.Monoid (Any(..)) -import qualified Data.Ord as Ord -import Data.Scientific (floatingOrInteger, toRealFloat) -import Data.Semigroup (Semigroup(..)) -import qualified Data.Sequence as Seq +import qualified Data.Map.Merge.Lazy as Data.Map.Merge +import qualified Data.Ord as Ord +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.Lint as Lint -import qualified Dhall.Map as Map -import qualified Dhall.Optics as Optics +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 @@ -398,11 +414,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 @@ -502,8 +518,8 @@ _ -> throwM . compileException $ BadDhallType t expr keyValMay :: Value -> Maybe (Text, Value) -keyValMay (A.Object o) = do - A.String k <- HM.lookup "key" o +keyValMay (Aeson.Object o) = do + Aeson.String k <- HM.lookup "key" o v <- HM.lookup "value" o return (k, v) keyValMay _ = Nothing @@ -515,26 +531,26 @@ on the command line -} inferSchema :: Value -> Schema -inferSchema (A.Object m) = +inferSchema (Aeson.Object m) = let convertMap = Data.Map.fromList . HM.toList in (Record . RecordSchema . convertMap) (fmap inferSchema m) -inferSchema (A.Array xs) = +inferSchema (Aeson.Array xs) = List (Foldable.foldMap inferSchema xs) -inferSchema (A.String _) = +inferSchema (Aeson.String _) = Text -inferSchema (A.Number n) = +inferSchema (Aeson.Number n) = case floatingOrInteger n of Left (_ :: Double) -> Double Right (integer :: Integer) | 0 <= integer -> Natural | otherwise -> Integer -inferSchema (A.Bool _) = +inferSchema (Aeson.Bool _) = Bool -inferSchema A.Null = +inferSchema Aeson.Null = Optional mempty --- | A record type that `inferSchema` can infer +-- | Aeson record type that `inferSchema` can infer newtype RecordSchema = RecordSchema { getRecordSchema :: Data.Map.Map Text Schema } @@ -778,11 +794,11 @@ >>> :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)])) @@ -790,74 +806,75 @@ dhallFromJSON :: Conversion -> ExprX -> Value -> Either CompileError ExprX dhallFromJSON (Conversion {..}) expressionType = - fmap (Optics.rewriteOf D.subExpressions Lint.useToMap) . 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) - Nothing -> do + Nothing -> case v of - A.String text | key == text -> do + Aeson.String text | key == text -> return (D.Field t key) - _ -> do - Left (Mismatch t v) + _ -> + 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) + loop jsonPath (D.Record r) v@(Aeson.Object o) | extraKeys <- HM.keys 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 + = loop (Aeson.Types.Key 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) + = Left (MissingKey k t v jsonPath) in D.RecordLit <$> Map.traverseWithKey f 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 :: [Value] <- toList a , Just kvs <- traverse keyValMay os - = loop t (A.Object $ HM.fromList kvs) + = loop jsonPath t (Aeson.Object $ HM.fromList 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 = do - keyExprMap <- traverse (loop mapValue) o + keyExprMap <- HM.traverseWithKey (\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 + _ -> Left (Mismatch t v jsonPath) let f :: (Text, ExprX) -> ExprX f (key, val) = D.RecordLit ( Map.fromList @@ -873,59 +890,60 @@ | 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 (< v13.0.0) loop + _ (D.Pi _ (D.Const D.Type) (D.Pi _ (D.Record @@ -941,7 +959,7 @@ ) ) value = do - let outer (A.Object o) = + let outer (Aeson.Object o) = let inner (key, val) = D.RecordLit [ ("mapKey" , D.TextLit (D.Chunks [] key)) @@ -965,8 +983,8 @@ keyValues = D.ListLit elementType elements - in (D.App (D.Field "json" "object") keyValues) - outer (A.Array a) = + in D.App (D.Field "json" "object") keyValues + outer (Aeson.Array a) = let elements = Seq.fromList (fmap outer (Vector.toList a)) elementType @@ -974,13 +992,13 @@ | otherwise = Nothing in D.App (D.Field "json" "array") (D.ListLit elementType elements) - outer (A.String s) = + outer (Aeson.String s) = D.App (D.Field "json" "string") (D.TextLit (D.Chunks [] s)) - outer (A.Number n) = + outer (Aeson.Number n) = D.App (D.Field "json" "number") (D.DoubleLit (DhallDouble (toRealFloat n))) - outer (A.Bool b) = + outer (Aeson.Bool b) = D.App (D.Field "json" "bool") (D.BoolLit b) - outer A.Null = + outer Aeson.Null = D.Field "json" "null" let result = @@ -1002,6 +1020,7 @@ -- Arbitrary JSON ~> https://prelude.dhall-lang.org/JSON/Type (v13.0.0 <=) loop + _ (D.Pi _ (D.Const D.Type) (D.Pi _ (D.Record @@ -1018,7 +1037,7 @@ ) ) value = do - let outer (A.Object o) = + let outer (Aeson.Object o) = let inner (key, val) = D.RecordLit [ ("mapKey" , D.TextLit (D.Chunks [] key)) @@ -1042,8 +1061,8 @@ keyValues = D.ListLit elementType elements - in (D.App (D.Field "json" "object") keyValues) - outer (A.Array a) = + in D.App (D.Field "json" "object") keyValues + outer (Aeson.Array a) = let elements = Seq.fromList (fmap outer (Vector.toList a)) elementType @@ -1051,15 +1070,15 @@ | otherwise = Nothing in D.App (D.Field "json" "array") (D.ListLit elementType elements) - outer (A.String s) = + outer (Aeson.String s) = D.App (D.Field "json" "string") (D.TextLit (D.Chunks [] s)) - outer (A.Number n) = + outer (Aeson.Number n) = case floatingOrInteger n of Left floating -> D.App (D.Field "json" "double") (D.DoubleLit (DhallDouble floating)) Right integer -> D.App (D.Field "json" "integer") (D.IntegerLit integer) - outer (A.Bool b) = + outer (Aeson.Bool b) = D.App (D.Field "json" "bool") (D.BoolLit b) - outer A.Null = + outer Aeson.Null = D.Field "json" "null" let result = @@ -1081,8 +1100,8 @@ return result -- fail - loop expr value - = Left (Mismatch expr value) + loop jsonPath expr value + = Left (Mismatch expr value jsonPath) -- ---------- @@ -1111,9 +1130,10 @@ | Mismatch ExprX -- Dhall expression Value -- Aeson value + Aeson.Types.JSONPath -- JSON Path to the error -- record specific - | MissingKey Text ExprX Value - | UnhandledKeys [Text] ExprX Value + | MissingKey Text ExprX Value Aeson.Types.JSONPath + | UnhandledKeys [Text] ExprX Value Aeson.Types.JSONPath | NoKeyValArray ExprX Value | NoKeyValMap ExprX Value -- union specific @@ -1149,21 +1169,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 @@ -1178,7 +1199,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 @@ -5,10 +5,12 @@ module Main where import Data.Monoid ((<>)) -import Test.Tasty (TestTree) +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 +21,7 @@ import qualified GHC.IO.Encoding import qualified Test.Tasty import qualified Test.Tasty.HUnit +import qualified Test.Tasty.Silver main :: IO () main = do @@ -42,6 +45,13 @@ , 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" @@ -55,7 +65,10 @@ , 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 @@ -96,23 +109,15 @@ bytes <- Data.ByteString.Lazy.readFile inputFile - value <- do + value <- case Aeson.eitherDecode bytes of Left string -> fail string Right value -> return value - schema <- do + schema <- if infer - then do - return (JSONToDhall.schemaToDhallType (JSONToDhall.inferSchema value)) - else do - let schemaFile = prefix <> "Schema.dhall" - - schemaText <- Data.Text.IO.readFile schemaFile - - parsedSchema <- Core.throws (Dhall.Parser.exprFromText schemaFile schemaText) - - Dhall.Import.load parsedSchema + then return (JSONToDhall.schemaToDhallType (JSONToDhall.inferSchema value)) + else let schemaFile = prefix <> "Schema.dhall" in loadSchemaFromFile schemaFile _ <- Core.throws (Dhall.TypeCheck.typeOf schema) @@ -142,3 +147,38 @@ 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/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/missingList.dhall b/tasty/data/missingList.dhall --- a/tasty/data/missingList.dhall +++ b/tasty/data/missingList.dhall @@ -1,4 +1,4 @@ -{ 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}