diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,43 @@ ## Upcoming +## 1.3.0 + +Breaking changes: + +* Refactored types to be correct by construction. Namely, the `schema` parameter in `Object schema` now has kind `Schema` instead of `SchemaType`, which prevents the possibility of a non-object schema stored in an `Object`. This means that any schemas previously annotated with the `SchemaType` kind should now be annotated as `Schema`. +* Instead of using `IsSchemaObject` is obviated because of this change, so it's been removed. You may use the new `IsSchema` instead, if you need it. +* `SchemaResult` has been removed from the export list of `Data.Aeson.Schema`. You probably won't need this in typical usage of this library, but if you need it, you can always get it from `Data.Aeson.Schema.Internal`. + +New features: + +* Add support for unwrapping into included schemas +* Add `toMap` +* Re-export `showSchema` in `Data.Aeson.Schema` + +Bug fixes: + +* Avoid requiring `TypeApplications` when using `get` quasiquoter ([#16](https://github.com/LeapYear/aeson-schemas/issues/16)) +* Allow optional quotes around keys, both in getter-expressions and in schema definitions +* Allow `//` at the beginning of phantom keys (were previously parsed as comments) + +Performance: + +* We've added benchmarks! To view performance metrics, you can clone the repo and run `stack bench`. You may also view the benchmark statistics in CI, but due to Circle CI's memory limitations, we're forced to run them with `--fast`, so it'll be a factor slower than it would actually be at runtime. +* Fixed the `Show` instance from being `O(n^2)` to `O(n)`, where `n` is the depth of the object. +* In order to fix some bugs and implement new features, the `schema` quasiquoter took a performance hit. The biggest slowdown occurs if you're including other schemas like: + + ``` + { + user: #UserSchema + } + ``` + + If this causes your build to be noticeably slower, please open an issue. Thanks! + +Miscellaneous changes: + +* The `Show` instance for objects added some whitespace, from `{"foo": 0}` to `{ "foo": 0 }` + ## 1.2.0 New features: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,6 +2,7 @@ ![CircleCI](https://img.shields.io/hackage/v/aeson-schemas) ![Hackage](https://img.shields.io/circleci/build/github/LeapYear/aeson-schemas) +[![codecov](https://codecov.io/gh/LeapYear/aeson-schemas/branch/master/graph/badge.svg)](https://codecov.io/gh/LeapYear/aeson-schemas) A library that extracts information from JSON input using type-level schemas and quasiquoters, consuming JSON data in a type-safe manner. Better than @@ -57,8 +58,9 @@ ### Type safe -Since schemas are defined at the type level, parsing JSON objects is checked at -compile-time: +Since schemas are defined at the type level, extracting data from JSON objects +is checked at compile-time, meaning that using the `get` quasiquoter should +never throw an error at runtime. ``` -- using schema from above @@ -77,11 +79,11 @@ ('Data.Aeson.Schema.SchemaObject '[ '("id", 'Data.Aeson.Schema.SchemaInt), '("name", 'Data.Aeson.Schema.SchemaText)])))] - • In the second argument of ‘(.)’, namely ‘getKey @"isEnabled"’ + • In the second argument of ‘(.)’, namely ‘getKey (Proxy :: Proxy "isEnabled")’ In the first argument of ‘(<$:>)’, namely - ‘(id . getKey @"isEnabled")’ + ‘(id . getKey (Proxy :: Proxy "isEnabled"))’ In the first argument of ‘(.)’, namely - ‘((id . getKey @"isEnabled") <$:>)’ + ‘((id . getKey (Proxy :: Proxy "isEnabled")) <$:>)’ ``` ### Point-free definitions @@ -93,7 +95,8 @@ getNames = [get| .users[].name |] ``` -You can use the `unwrap` quasiquoter to define intermediate schemas: +If you'd like to extract intermediate schemas, you can use the `unwrap` +quasiquoter: ```haskell type User = [unwrap| MySchema.users[] |] @@ -177,22 +180,21 @@ ```haskell data Result = Result { permissions :: [Permission] - } - deriving (Generic, FromJSON) + } deriving (Show, Generic, FromJSON) data Permission = Permission { resource :: Resource , access :: String - } deriving (Generic, FromJSON) + } deriving (Show, Generic, FromJSON) data Resource = Resource { name :: String , owner :: Owner - } deriving (Generic, FromJSON) + } deriving (Show, Generic, FromJSON) data Owner = Owner { username :: String - } + } deriving (Show, Generic, FromJSON) ``` It might be fine for a single example like this, but if you have to parse this @@ -220,7 +222,7 @@ |] ``` -The only identifier added to the namespace is `Result`, and parsing out data +The only identifier added to the namespace is `Result`, and extracting data is easier and more readable: ```haskell @@ -298,7 +300,7 @@ groupNames = map (\GroupNode{node = Group{name = name}} -> name) userGroups ``` -With this library, parsing is much more straightforward +With this library, extraction is much more straightforward ```haskell let groupNames = [get| userNode.node.groups[].node.name |] diff --git a/aeson-schemas.cabal b/aeson-schemas.cabal --- a/aeson-schemas.cabal +++ b/aeson-schemas.cabal @@ -1,13 +1,13 @@ cabal-version: >= 1.10 --- This file has been generated from package.yaml by hpack version 0.31.1. +-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack -- --- hash: f264efe1e9e5d79645f971635649d0dea5c3dedf8e8aee3513f201dd9386a438 +-- hash: d195684258f0bf8fc5b3ab749824dc20c842da7acdb82d6e7aeb9e03c6165e28 name: aeson-schemas -version: 1.2.0 +version: 1.3.0 synopsis: Easily consume JSON data on-demand with type-safety description: Parse JSON data easily and safely without defining new data types. Useful for deeply nested JSON data, which is difficult to parse using the default @@ -23,92 +23,30 @@ extra-source-files: README.md CHANGELOG.md - test/all_types.json - test/nested.json - test/goldens/bool.golden - test/goldens/bool_int_double.golden - test/goldens/double.golden - test/goldens/enum.golden - test/goldens/from_object_all_types.golden - test/goldens/from_object_namespaced.golden - test/goldens/from_object_nested.golden - test/goldens/get_empty.golden - test/goldens/get_just_start.golden - test/goldens/get_ops_after_list.golden - test/goldens/get_ops_after_tuple.golden - test/goldens/getter_all_types_list.golden - test/goldens/getter_all_types_list_item.golden - test/goldens/int.golden - test/goldens/int_int2.golden - test/goldens/lambda_bool.golden - test/goldens/list.golden - test/goldens/list_explicit.golden - test/goldens/list_maybeBool.golden - test/goldens/list_maybeInt.golden - test/goldens/list_type.golden - test/goldens/maybeList.golden - test/goldens/maybeList_bang.golden - test/goldens/maybeList_bang_list.golden - test/goldens/maybeList_bang_list_text.golden - test/goldens/maybeList_list.golden - test/goldens/maybeList_list_text.golden - test/goldens/maybeListNull.golden - test/goldens/maybeListNull_bang.golden - test/goldens/maybeListNull_list.golden - test/goldens/maybeListNull_list_text.golden - test/goldens/maybeObj.golden - test/goldens/maybeObj_bang.golden - test/goldens/maybeObj_bang_text.golden - test/goldens/maybeObj_text.golden - test/goldens/maybeObjNull.golden - test/goldens/maybeObjNull_text.golden - test/goldens/nonexistent.golden - test/goldens/phantom.golden + test/goldens/fromjson_error_messages_truncate.golden + test/goldens/fromjson_list_inner_invalid.golden + test/goldens/fromjson_list_invalid.golden + test/goldens/fromjson_maybe_invalid.golden + test/goldens/fromjson_nested_inner_invalid.golden + test/goldens/fromjson_nested_invalid.golden + test/goldens/fromjson_object_invalid.golden + test/goldens/fromjson_object_later_keys_invalid.golden + test/goldens/fromjson_phantom_inner_invalid.golden + test/goldens/fromjson_phantom_inner_missing.golden + test/goldens/fromjson_phantom_invalid.golden + test/goldens/fromjson_scalar_invalid.golden + test/goldens/fromjson_union_invalid.golden + test/goldens/getqq_empty_expression.golden + test/goldens/getqq_missing_key.golden + test/goldens/getqq_no_operators.golden + test/goldens/getqq_ops_after_list.golden + test/goldens/getqq_ops_after_tuple.golden test/goldens/README_Quickstart.golden - test/goldens/scalar.golden - test/goldens/schema_def_bool.golden - test/goldens/schema_def_custom.golden - test/goldens/schema_def_double.golden - test/goldens/schema_def_duplicate.golden - test/goldens/schema_def_duplicate_extend.golden - test/goldens/schema_def_duplicate_phantom.golden - test/goldens/schema_def_extend.golden - test/goldens/schema_def_import_user.golden - test/goldens/schema_def_int.golden - test/goldens/schema_def_invalid_extend.golden - test/goldens/schema_def_list.golden - test/goldens/schema_def_list_obj.golden - test/goldens/schema_def_maybe.golden - test/goldens/schema_def_maybe_obj.golden - test/goldens/schema_def_nonobject_phantom.golden - test/goldens/schema_def_not_object.golden - test/goldens/schema_def_obj.golden - test/goldens/schema_def_shadow.golden - test/goldens/schema_def_text.golden - test/goldens/schema_def_union.golden - test/goldens/schema_def_union_grouped.golden - test/goldens/schema_def_unknown_type.golden - test/goldens/text.golden - test/goldens/tryObj.golden - test/goldens/tryObj_a.golden - test/goldens/tryObj_bang.golden - test/goldens/tryObj_bang_a.golden - test/goldens/tryObjNull.golden - test/goldens/tryObjNull_a.golden - test/goldens/union.golden - test/goldens/union_0.golden - test/goldens/union_0_a.golden - test/goldens/union_1.golden - test/goldens/union_2.golden - test/goldens/unwrap_schema.golden - test/goldens/unwrap_schema_bad_bang.golden - test/goldens/unwrap_schema_bad_branch.golden - test/goldens/unwrap_schema_bad_key.golden - test/goldens/unwrap_schema_bad_list.golden - test/goldens/unwrap_schema_bad_question.golden - test/goldens/unwrap_schema_branch_out_of_bounds.golden - test/goldens/unwrap_schema_nested_list.golden - test/goldens/unwrap_schema_nested_object.golden + test/goldens/schemaqq_key_with_invalid_character.golden + test/goldens/schemaqq_key_with_trailing_escape.golden + test/goldens/sumtype_decode_invalid.golden + test/goldens/unwrapqq_unwrap_past_list.golden + test/goldens/unwrapqq_unwrap_past_tuple.golden source-repository head type: git @@ -121,8 +59,10 @@ Data.Aeson.Schema.Key Data.Aeson.Schema.Show Data.Aeson.Schema.TH + Data.Aeson.Schema.Type + Data.Aeson.Schema.Utils.All + Data.Aeson.Schema.Utils.Invariant Data.Aeson.Schema.Utils.Sum - Data.Aeson.Schema.Utils.TypeFamilies other-modules: Data.Aeson.Schema.TH.Enum Data.Aeson.Schema.TH.Get @@ -137,9 +77,9 @@ build-depends: aeson >=1.1.2.0 && <1.6 , base >=4.9 && <5 - , bytestring >=0.10.8.1 && <0.11 , first-class-families >=0.3.0.0 && <0.9 - , megaparsec >=6.0.0 && <9 + , hashable >=1.2.7.0 && <1.4 + , megaparsec >=6.0.0 && <10 , template-haskell >=2.12.0.0 && <2.17 , text >=1.2.2.2 && <1.3 , unordered-containers >=0.2.8.0 && <0.3 @@ -153,32 +93,85 @@ type: exitcode-stdio-1.0 main-is: Main.hs other-modules: - AllTypes - Enums - Nested - Schema - SumType - Util + Tests.EnumTH + Tests.GetQQ + Tests.GetQQ.TH + Tests.MkGetter + Tests.Object + Tests.Object.Eq + Tests.Object.FromJSON + Tests.Object.FromJSON.TH + Tests.Object.Show + Tests.Object.Show.TH + Tests.Object.ToJSON + Tests.SchemaQQ + Tests.SchemaQQ.TH + Tests.SumType + Tests.UnwrapQQ + Tests.UnwrapQQ.TH + TestUtils + TestUtils.Arbitrary + TestUtils.DeepSeq Paths_aeson_schemas hs-source-dirs: test ghc-options: -Wall build-depends: - QuickCheck >=2.7 && <3 + QuickCheck , aeson >=1.1.2.0 && <1.6 + , aeson-qq , aeson-schemas , base >=4.9 && <5 - , bytestring >=0.10.8.1 && <0.11 + , deepseq , first-class-families >=0.3.0.0 && <0.9 - , megaparsec >=6.0.0 && <9 - , raw-strings-qq >=1.1 && <1.2 - , tasty >=0.11.3 && <1.4 - , tasty-golden >=2.3.1.2 && <2.4 - , tasty-hunit >=0.9 && <0.11 - , tasty-quickcheck >=0.9 && <0.11 + , hashable >=1.2.7.0 && <1.4 + , hint + , interpolate + , megaparsec >=6.0.0 && <10 + , raw-strings-qq + , tasty + , tasty-golden + , tasty-hunit + , tasty-quickcheck , template-haskell >=2.12.0.0 && <2.17 , text >=1.2.2.2 && <1.3 - , th-test-utils >=1.0.0 && <1.1 + , th-orphans + , th-test-utils + , unordered-containers >=0.2.8.0 && <0.3 + if impl(ghc >= 8.0) + ghc-options: -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances + if impl(ghc < 8.8) + ghc-options: -Wnoncanonical-monadfail-instances + default-language: Haskell2010 + +benchmark aeson-schemas-bench + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Benchmarks.Data.Objects + Benchmarks.Data.Schemas + Benchmarks.Data.Schemas.TH + Benchmarks.FromJSON + Benchmarks.SchemaQQ + Benchmarks.Show + Benchmarks.ToJSON + Utils.DeepSeq + Paths_aeson_schemas + hs-source-dirs: + bench + ghc-options: -Wall + build-depends: + aeson >=1.1.2.0 && <1.6 + , aeson-schemas + , base >=4.9 && <5 + , criterion + , deepseq + , first-class-families >=0.3.0.0 && <0.9 + , hashable >=1.2.7.0 && <1.4 + , megaparsec >=6.0.0 && <10 + , template-haskell >=2.12.0.0 && <2.17 + , text >=1.2.2.2 && <1.3 + , th-test-utils , unordered-containers >=0.2.8.0 && <0.3 if impl(ghc >= 8.0) ghc-options: -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances diff --git a/bench/Benchmarks/Data/Objects.hs b/bench/Benchmarks/Data/Objects.hs new file mode 100644 --- /dev/null +++ b/bench/Benchmarks/Data/Objects.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} + +module Benchmarks.Data.Objects where + +import Data.Aeson (ToJSON(..), Value) +import Data.Dynamic (Dynamic, Typeable, toDyn) +import qualified Data.HashMap.Strict as HashMap +import Data.Proxy (Proxy(..)) +import Data.Text (Text) +import qualified Data.Text as Text + +import Data.Aeson.Schema.Internal (Object(..), SchemaResult) +import Data.Aeson.Schema.Key (IsSchemaKey, SchemaKey, fromSchemaKey) +import Data.Aeson.Schema.Type + (IsSchemaObjectMap, SchemaType, SchemaType'(..), ToSchemaObject) +import Data.Aeson.Schema.Utils.All (All(..)) + +type MockSchema schema = + ( MockSchemaResult (ToSchemaObject schema) + , Object schema ~ SchemaResult (ToSchemaObject schema) + , ToJSON (Object schema) + ) + +schemaObject :: forall schema. MockSchema schema => Object schema +schemaObject = schemaResult (Proxy @(ToSchemaObject schema)) + +schemaValue :: forall schema. MockSchema schema => Value +schemaValue = toJSON $ schemaObject @schema + +class Typeable (SchemaResult schema) => MockSchemaResult (schema :: SchemaType) where + schemaResult :: Proxy schema -> SchemaResult schema + +instance MockSchemaResult ('SchemaScalar Int) where + schemaResult _ = 42 + +instance + ( All MockSchemaResultPair pairs + , IsSchemaObjectMap pairs + , Typeable pairs + ) => MockSchemaResult ('SchemaObject pairs) where + schemaResult _ = UnsafeObject $ HashMap.fromList $ mapAll @MockSchemaResultPair @pairs schemaResultPair + +class MockSchemaResultPair (pair :: (SchemaKey, SchemaType)) where + schemaResultPair :: Proxy pair -> (Text, Dynamic) + +instance (IsSchemaKey key, MockSchemaResult inner) => MockSchemaResultPair '(key, inner) where + schemaResultPair _ = (Text.pack $ fromSchemaKey @key, toDyn $ schemaResult $ Proxy @inner) diff --git a/bench/Benchmarks/Data/Schemas.hs b/bench/Benchmarks/Data/Schemas.hs new file mode 100644 --- /dev/null +++ b/bench/Benchmarks/Data/Schemas.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} + +module Benchmarks.Data.Schemas + ( module Benchmarks.Data.Schemas + , module Benchmarks.Data.Schemas.TH + ) where + +import Control.Monad (forM) +import Data.Char (chr, toUpper) +import Language.Haskell.TH +import Language.Haskell.TH.Syntax (lift) +import Language.Haskell.TH.TestUtils () + +import Benchmarks.Data.Schemas.TH + +-- Generates: +-- +-- type Schema1 = { a1: Int } +-- type Schema5 = { a1: Int, a2: Int, ... a5: Int } +-- type Schema10 = { a1: Int, a2: Int, ... a10: Int } +-- type Schema100 = { a1: Int, a2: Int, ... a100: Int } +$(do + -- The sizes of schemas to generate + let schemaSizes = [1, 5, 10, 100] + allSchemas = flip map schemaSizes $ \n -> + let name = "Schema" ++ show n + in (n, name, mkName name) + + concat <$> sequence + [ forM allSchemas $ \(n, _, name) -> genSchema name $ keysTo n + , [d| + sizedSchemas :: [(Int, String)] + sizedSchemas = $(lift $ flip map allSchemas $ \(n, name, _) -> (n, name)) + + sizedSchemasNames :: [(String, Name)] + sizedSchemasNames = $(lift $ flip map allSchemas $ \(_, name, thName) -> (name, thName)) + |] + ] + ) + +-- Generates: +-- +-- type SchemaNest1 = { a1: Int } +-- type SchemaNest5 = { a1: { a2: { ... a5: Int } } +-- type SchemaNest10 = { a1: { a2: { ... a10: Int } } +-- type SchemaNest100 = { a1: { a2: { ... a100: Int } } +$(do + -- The depths of schemas to generate + let schemaSizes = [1, 5, 10, 100] + allSchemas = flip map schemaSizes $ \n -> + let name = "SchemaNest" ++ show n + in (n, name, mkName name) + + concat <$> sequence + [ forM allSchemas $ \(n, _, name) -> genSchema' name $ + foldr (\i inner -> genSchemaDef [Field (mkField i) inner]) "Int" [1..n] + , [d| + nestedSchemas :: [(Int, String)] + nestedSchemas = $(lift $ flip map allSchemas $ \(n, name, _) -> (n, name)) + + nestedSchemasNames :: [(String, Name)] + nestedSchemasNames = $(lift $ flip map allSchemas $ \(_, name, thName) -> (name, thName)) + |] + ] + ) + +-- Generates: +-- +-- type SchemaA1 = { a1: Int } +-- type SchemaB1 = { b1: Int } +-- ... +-- type SchemaZ1 = { z1: Int } +-- type SchemaA2 = { a2: Int } +-- type SchemaB2 = { a2: Int } +-- ... +$(do + let numSchemas = 100 + allSchemas = flip map [1..numSchemas] $ \n -> + let (q, r) = n `divMod` 26 + c = chr $ 97 + r -- a .. z + field = c : show q + name = "Schema" ++ map toUpper field + in (field, name, mkName name) + + concat <$> sequence + [ forM allSchemas $ \(field, _, name) -> genSchema name [Field field "Int"] + , [d| + singleSchemas :: [String] + singleSchemas = $(lift $ flip map allSchemas $ \(_, name, _) -> name) + + singleSchemasNames :: [(String, Name)] + singleSchemasNames = $(lift $ flip map allSchemas $ \(_, name, thName) -> (name, thName)) + |] + ] + ) diff --git a/bench/Benchmarks/Data/Schemas/TH.hs b/bench/Benchmarks/Data/Schemas/TH.hs new file mode 100644 --- /dev/null +++ b/bench/Benchmarks/Data/Schemas/TH.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE LambdaCase #-} + +module Benchmarks.Data.Schemas.TH + ( SchemaDef(..) + , genSchema + , genSchema' + , genSchemaDef + , keysTo + , mkField + ) where + +import Data.List (intercalate) +import Language.Haskell.TH +import Language.Haskell.TH.Quote + +import Data.Aeson.Schema (schema) + +data SchemaDef + = Field String String -- ^ { a: Int } + | Include String String -- ^ { a: #OtherSchema } + | Ref String -- ^ { #OtherSchema } + +genSchema :: Name -> [SchemaDef] -> DecQ +genSchema name = genSchema' name . genSchemaDef + +genSchema' :: Name -> String -> DecQ +genSchema' name = tySynD name [] . quoteType schema + +genSchemaDef :: [SchemaDef] -> String +genSchemaDef schemaDef = "{" ++ intercalate "," (map fromSchemaDef schemaDef) ++ "}" + where + fromSchemaDef = \case + Field key ty -> key ++ ": " ++ ty + Include key name -> key ++ ": #" ++ name + Ref name -> "#" ++ name + +keysTo :: Int -> [SchemaDef] +keysTo n = map (\i -> Field (mkField i) "Int") [1..n] + +mkField :: Int -> String +mkField i = "a" ++ show i diff --git a/bench/Benchmarks/FromJSON.hs b/bench/Benchmarks/FromJSON.hs new file mode 100644 --- /dev/null +++ b/bench/Benchmarks/FromJSON.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -freduction-depth=0 #-} + +module Benchmarks.FromJSON where + +import Control.DeepSeq (NFData(..)) +import Criterion.Main +import qualified Data.Aeson as Aeson + +import Data.Aeson.Schema (Object) + +import Benchmarks.Data.Objects +import Benchmarks.Data.Schemas + +benchmarks :: Benchmark +benchmarks = bgroup "FromJSON instance" + [ byKeys + , byNestedKeys + ] + where + byKeys = bgroup "# of keys" + [ bench "1" $ nf (Aeson.fromJSON @(Object Schema1)) (schemaValue @Schema1) + , bench "5" $ nf (Aeson.fromJSON @(Object Schema5)) (schemaValue @Schema5) + , bench "10" $ nf (Aeson.fromJSON @(Object Schema10)) (schemaValue @Schema10) + , bench "100" $ nf (Aeson.fromJSON @(Object Schema100)) (schemaValue @Schema100) + ] + + byNestedKeys = bgroup "# of nested keys" + [ bench "1" $ nf (Aeson.fromJSON @(Object SchemaNest1)) (schemaValue @SchemaNest1) + , bench "5" $ nf (Aeson.fromJSON @(Object SchemaNest5)) (schemaValue @SchemaNest5) + , bench "10" $ nf (Aeson.fromJSON @(Object SchemaNest10)) (schemaValue @SchemaNest10) + , bench "100" $ nf (Aeson.fromJSON @(Object SchemaNest100)) (schemaValue @SchemaNest100) + ] + +{- Orphans -} + +instance Show (Object schema) => NFData (Object schema) where + rnf = rnf . show diff --git a/bench/Benchmarks/SchemaQQ.hs b/bench/Benchmarks/SchemaQQ.hs new file mode 100644 --- /dev/null +++ b/bench/Benchmarks/SchemaQQ.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Benchmarks.SchemaQQ where + +import Criterion.Main +import Language.Haskell.TH.Quote (QuasiQuoter(quoteType)) +import Language.Haskell.TH.TestUtils + (QMode(..), QState(..), loadNames, runTestQ) + +import qualified Data.Aeson.Schema + +import Benchmarks.Data.Schemas +import Utils.DeepSeq () + +benchmarks :: Benchmark +benchmarks = bgroup "schema quasiquoter" + [ byKeys + , byNestedKeys + , byNumOfIncluded + , byKeysInIncluded + , byNumOfExtended + , byKeysInExtended + ] + where + byKeys = bgroup "# of keys" $ + flip map [1, 5, 10, 100] $ \n -> + let schemaDef = genSchemaDef $ keysTo n + in bench (show n) $ nf runSchema schemaDef + + byNestedKeys = bgroup "# of nested keys" $ + flip map [1, 5, 10, 100] $ \n -> + let schemaDef = iterateN n (\prev -> genSchemaDef [Field "a" prev]) "Int" + in bench (show n) $ nf runSchema schemaDef + + byNumOfIncluded = bgroup "Include given # of schemas" $ + flip map [1, 5, 10, 100] $ \n -> + let schemaDef = genSchemaDef $ map (\name -> Include name name) $ take n singleSchemas + in bench (show n) $ nf runSchema schemaDef + + byKeysInIncluded = bgroup "Include schema with given # of keys" $ + flip map sizedSchemas $ \(n, schema) -> + let schemaDef = genSchemaDef [Include "a" schema] + in bench (show n) $ nf runSchema schemaDef + + byNumOfExtended = bgroup "Extend given # of schemas" $ + flip map [1, 5, 10, 100] $ \n -> + let schemaDef = genSchemaDef $ map Ref $ take n singleSchemas + in bench (show n) $ nf runSchema schemaDef + + byKeysInExtended = bgroup "Extend schema with given # of keys" $ + flip map sizedSchemas $ \(n, schema) -> + let schemaDef = genSchemaDef [Field "a" "Int", Ref schema] + in bench (show n) $ nf runSchema schemaDef + + runSchema = + let qstate = QState + { mode = MockQ + , knownNames = sizedSchemasNames ++ singleSchemasNames + , reifyInfo = $(loadNames $ map snd $ sizedSchemasNames ++ singleSchemasNames) + } + in runTestQ qstate . quoteType Data.Aeson.Schema.schema + +{- Utilities -} + +-- | Apply the given functions the given number of times. +-- +-- The first parameter must be >= 0. +iterateN :: Int -> (a -> a) -> a -> a +iterateN n f x = iterate f x !! n diff --git a/bench/Benchmarks/Show.hs b/bench/Benchmarks/Show.hs new file mode 100644 --- /dev/null +++ b/bench/Benchmarks/Show.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -freduction-depth=0 #-} + +module Benchmarks.Show where + +import Criterion.Main + +import Benchmarks.Data.Objects +import Benchmarks.Data.Schemas + +benchmarks :: Benchmark +benchmarks = bgroup "Show instance" + [ byKeys + , byNestedKeys + ] + where + byKeys = bgroup "# of keys" + [ bench "1" $ nf show (schemaObject @Schema1) + , bench "5" $ nf show (schemaObject @Schema5) + , bench "10" $ nf show (schemaObject @Schema10) + , bench "100" $ nf show (schemaObject @Schema100) + ] + + byNestedKeys = bgroup "# of nested keys" + [ bench "1" $ nf show (schemaObject @SchemaNest1) + , bench "5" $ nf show (schemaObject @SchemaNest5) + , bench "10" $ nf show (schemaObject @SchemaNest10) + , bench "100" $ nf show (schemaObject @SchemaNest100) + ] diff --git a/bench/Benchmarks/ToJSON.hs b/bench/Benchmarks/ToJSON.hs new file mode 100644 --- /dev/null +++ b/bench/Benchmarks/ToJSON.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -freduction-depth=0 #-} + +module Benchmarks.ToJSON where + +import Criterion.Main +import qualified Data.Aeson as Aeson + +import Benchmarks.Data.Objects +import Benchmarks.Data.Schemas + +benchmarks :: Benchmark +benchmarks = bgroup "ToJSON instance" + [ byKeys + , byNestedKeys + ] + where + byKeys = bgroup "# of keys" + [ bench "1" $ nf Aeson.toJSON (schemaObject @Schema1) + , bench "5" $ nf Aeson.toJSON (schemaObject @Schema5) + , bench "10" $ nf Aeson.toJSON (schemaObject @Schema10) + , bench "100" $ nf Aeson.toJSON (schemaObject @Schema100) + ] + + byNestedKeys = bgroup "# of nested keys" + [ bench "1" $ nf Aeson.toJSON (schemaObject @SchemaNest1) + , bench "5" $ nf Aeson.toJSON (schemaObject @SchemaNest5) + , bench "10" $ nf Aeson.toJSON (schemaObject @SchemaNest10) + , bench "100" $ nf Aeson.toJSON (schemaObject @SchemaNest100) + ] diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,14 @@ +import Criterion.Main + +import qualified Benchmarks.FromJSON +import qualified Benchmarks.SchemaQQ +import qualified Benchmarks.Show +import qualified Benchmarks.ToJSON + +main :: IO () +main = defaultMain + [ Benchmarks.SchemaQQ.benchmarks + , Benchmarks.Show.benchmarks + , Benchmarks.FromJSON.benchmarks + , Benchmarks.ToJSON.benchmarks + ] diff --git a/bench/Utils/DeepSeq.hs b/bench/Utils/DeepSeq.hs new file mode 100644 --- /dev/null +++ b/bench/Utils/DeepSeq.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Utils.DeepSeq () where + +import Control.DeepSeq (NFData(..)) +#if MIN_VERSION_template_haskell(2,16,0) +import Control.DeepSeq (rwhnf) +import GHC.ForeignPtr (ForeignPtr) +#endif +import Language.Haskell.TH.Syntax + +instance NFData AnnTarget +instance NFData Bang +instance NFData Body +instance NFData Callconv +instance NFData Clause +instance NFData Con +instance NFData Dec +instance NFData DerivClause +instance NFData DerivStrategy +instance NFData Exp +instance NFData FamilyResultSig +instance NFData Fixity +instance NFData FixityDirection +instance NFData Foreign +instance NFData FunDep +instance NFData Guard +instance NFData InjectivityAnn +instance NFData Inline +instance NFData Lit +instance NFData Match +instance NFData ModName +instance NFData Name +instance NFData NameFlavour +instance NFData NameSpace +instance NFData OccName +instance NFData Overlap +instance NFData Pat +instance NFData PatSynArgs +instance NFData PatSynDir +instance NFData Phases +instance NFData PkgName +instance NFData Pragma +instance NFData Range +instance NFData Role +instance NFData RuleBndr +instance NFData RuleMatch +instance NFData Safety +instance NFData SourceStrictness +instance NFData SourceUnpackedness +instance NFData Stmt +instance NFData Type +instance NFData TypeFamilyHead +instance NFData TyLit +instance NFData TySynEqn +instance NFData TyVarBndr + +#if MIN_VERSION_template_haskell(2,16,0) +instance NFData Bytes + +instance NFData (ForeignPtr a) where + rnf = rwhnf +#endif diff --git a/src/Data/Aeson/Schema.hs b/src/Data/Aeson/Schema.hs --- a/src/Data/Aeson/Schema.hs +++ b/src/Data/Aeson/Schema.hs @@ -10,11 +10,13 @@ -} module Data.Aeson.Schema - ( -- * Types + ( -- * Object Object - , SchemaType - , IsSchemaObject - , SchemaResult + , toMap + -- * Schemas + , Schema + , IsSchema + , showSchema -- * Quasiquoters for extracting or manipulating JSON data or schemas , schema , get @@ -24,3 +26,4 @@ import Data.Aeson.Schema.Internal import Data.Aeson.Schema.TH +import Data.Aeson.Schema.Type diff --git a/src/Data/Aeson/Schema/Internal.hs b/src/Data/Aeson/Schema/Internal.hs --- a/src/Data/Aeson/Schema/Internal.hs +++ b/src/Data/Aeson/Schema/Internal.hs @@ -9,18 +9,16 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeInType #-} {-# LANGUAGE TypeOperators #-} @@ -28,240 +26,239 @@ module Data.Aeson.Schema.Internal where -import Control.Applicative ((<|>)) +import Control.Applicative (Alternative(..)) #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail (MonadFail) #endif -import Data.Aeson (FromJSON(..), Value(..)) +import Data.Aeson (FromJSON(..), ToJSON(..), Value(..)) +import qualified Data.Aeson as Aeson import Data.Aeson.Types (Parser) -import Data.Bifunctor (first) -import Data.Dynamic (Dynamic, fromDyn, fromDynamic, toDyn) +import Data.Dynamic (Dynamic, fromDynamic, toDyn) import Data.HashMap.Strict (HashMap, (!)) import qualified Data.HashMap.Strict as HashMap -import Data.Kind (Type) +import Data.List (intersperse) import Data.Maybe (fromMaybe) import Data.Proxy (Proxy(..)) import Data.Text (Text) import qualified Data.Text as Text -import Data.Typeable (Typeable, splitTyConApp, tyConName, typeRep, typeRepTyCon) +import Data.Typeable (Typeable) import Fcf (type (<=<), type (=<<)) import qualified Fcf import GHC.Exts (toList) import GHC.TypeLits (ErrorMessage(..), KnownSymbol, Symbol, TypeError, symbolVal) -import qualified Data.Aeson.Schema.Show as SchemaShow -import Data.Aeson.Schema.Utils.Sum (SumType) -import Data.Aeson.Schema.Utils.TypeFamilies (All) +import Data.Aeson.Schema.Key + ( IsSchemaKey(..) + , SchemaKey + , SchemaKey'(..) + , fromSchemaKeyV + , getContext + , showSchemaKey + , toContext + ) +import Data.Aeson.Schema.Type + ( FromSchema + , IsSchemaObjectMap + , IsSchemaType(..) + , Schema + , Schema'(..) + , SchemaType + , SchemaType'(..) + , ToSchemaObject + , showSchemaTypeV + ) +import Data.Aeson.Schema.Utils.All (All(..)) +import Data.Aeson.Schema.Utils.Invariant (unreachable) +import Data.Aeson.Schema.Utils.Sum (SumType(..)) {- Schema-validated JSON object -} -- | The object containing JSON data and its schema. -- --- Has a 'FromJSON' instance, so you can use the usual 'Data.Aeson' decoding functions. +-- Has a 'FromJSON' instance, so you can use the usual @Data.Aeson@ decoding functions. -- -- > obj = decode "{\"a\": 1}" :: Maybe (Object [schema| { a: Int } |]) -newtype Object (schema :: SchemaType) = UnsafeObject (HashMap Text Dynamic) +newtype Object (schema :: Schema) = UnsafeObject (HashMap Text Dynamic) --- | A constraint that checks if the given schema is a 'SchemaObject. -type IsSchemaObject schema = (IsSchemaType schema, SchemaResult schema ~ Object schema) +instance IsSchema schema => Show (Object schema) where + showsPrec _ = showValue @(ToSchemaObject schema) -instance IsSchemaObject schema => Show (Object schema) where - show = showValue @schema +instance IsSchema schema => Eq (Object schema) where + a == b = toJSON a == toJSON b -instance IsSchemaObject schema => FromJSON (Object schema) where - parseJSON = parseValue @schema [] +instance IsSchema schema => FromJSON (Object schema) where + parseJSON = parseValue @(ToSchemaObject schema) [] -{- Type-level schema definitions -} +instance IsSchema schema => ToJSON (Object schema) where + toJSON = toValue @(ToSchemaObject schema) --- | The type-level schema definition for JSON data. +-- | Convert an 'Object' into a 'HashMap', losing the type information in the schema. -- --- To view a schema for debugging, use 'showSchema'. -data SchemaType - = SchemaBool - | SchemaInt - | SchemaDouble - | SchemaText - | SchemaCustom Type - | SchemaMaybe SchemaType - | SchemaTry SchemaType - | SchemaList SchemaType - | SchemaObject [(SchemaKey, SchemaType)] - | SchemaUnion [SchemaType] -- ^ @since v1.1.0 - --- | Convert 'SchemaType' into 'SchemaShow.SchemaType'. -toSchemaTypeShow :: forall (a :: SchemaType). Typeable a => SchemaShow.SchemaType -toSchemaTypeShow = cast $ typeRep (Proxy @a) - where - cast tyRep = case splitTypeRep tyRep of - ("'SchemaBool", _) -> SchemaShow.SchemaBool - ("'SchemaInt", _) -> SchemaShow.SchemaInt - ("'SchemaDouble", _) -> SchemaShow.SchemaDouble - ("'SchemaText", _) -> SchemaShow.SchemaText - ("'SchemaCustom", [inner]) -> SchemaShow.SchemaCustom $ typeRepName inner - ("'SchemaMaybe", [inner]) -> SchemaShow.SchemaMaybe $ cast inner - ("'SchemaTry", [inner]) -> SchemaShow.SchemaTry $ cast inner - ("'SchemaList", [inner]) -> SchemaShow.SchemaList $ cast inner - ("'SchemaObject", [pairs]) -> SchemaShow.SchemaObject $ map getSchemaObjectPair $ typeRepToList pairs - ("'SchemaUnion", [schemas]) -> SchemaShow.SchemaUnion $ map cast $ typeRepToList schemas - _ -> error $ "Unknown schema type: " ++ show tyRep - - getSchemaObjectPair tyRep = - let (key, val) = typeRepToPair tyRep - fromTypeRep = tail . init . typeRepName -- strip leading + trailing quote - schemaKey = case splitTypeRep key of - ("'NormalKey", [key']) -> SchemaShow.NormalKey $ fromTypeRep key' - ("'PhantomKey", [key']) -> SchemaShow.PhantomKey $ fromTypeRep key' - _ -> error $ "Unknown schema key: " ++ show key - in (schemaKey, cast val) - - typeRepToPair tyRep = case splitTypeRep tyRep of - ("'(,)", [a, b]) -> (a, b) - _ -> error $ "Unknown pair: " ++ show tyRep - - typeRepToList tyRep = case splitTypeRep tyRep of - ("'[]", []) -> [] - ("':", [x, rest]) -> x : typeRepToList rest - _ -> error $ "Unknown list: " ++ show tyRep - - splitTypeRep = first tyConName . splitTyConApp - typeRepName = tyConName . typeRepTyCon - --- | Pretty show the given SchemaType. -showSchema :: forall (a :: SchemaType). Typeable a => String -showSchema = SchemaShow.showSchemaType $ toSchemaTypeShow @a - --- | The type-level analogue of 'Data.Aeson.Schema.Key.SchemaKey'. -data SchemaKey - = NormalKey Symbol - | PhantomKey Symbol - -type family FromSchemaKey (schemaKey :: SchemaKey) where - FromSchemaKey ('NormalKey key) = key - FromSchemaKey ('PhantomKey key) = key +-- @since 1.3.0 +toMap :: IsSchema ('Schema schema) => Object ('Schema schema) -> Aeson.Object +toMap = toValueMap -fromSchemaKey :: forall schemaKey. KnownSymbol (FromSchemaKey schemaKey) => Text -fromSchemaKey = Text.pack $ symbolVal $ Proxy @(FromSchemaKey schemaKey) +{- Type-level schema definitions -} -class - ( Typeable schemaKey - , KnownSymbol (FromSchemaKey schemaKey) - ) => KnownSchemaKey (schemaKey :: SchemaKey) where - getContext :: HashMap Text Value -> Value +-- | The constraint for most operations involving @Object schema@. If you're writing functions +-- on general Objects, you should use this constraint. e.g. +-- +-- > logObject :: (MonadLogger m, IsSchema schema) => Object schema -> m () +-- > logObject = logInfoN . Text.pack . show +-- +-- @since 1.3.0 +type IsSchema (schema :: Schema) = + ( HasSchemaResult (ToSchemaObject schema) + , All HasSchemaResultPair (FromSchema schema) + , SchemaResult (ToSchemaObject schema) ~ Object schema + ) -instance KnownSymbol key => KnownSchemaKey ('NormalKey key) where - getContext = fromMaybe Null . HashMap.lookup (fromSchemaKey @('NormalKey key)) +-- | Show the given schema. +-- +-- Usage: +-- +-- > type MySchema = [schema| { a: Int } |] +-- > showSchema @MySchema +-- +showSchema :: forall (schema :: Schema). IsSchema schema => String +showSchema = showSchemaType @(ToSchemaObject schema) -instance KnownSymbol key => KnownSchemaKey ('PhantomKey key) where - getContext = Object +showSchemaType :: forall (schemaType :: SchemaType). HasSchemaResult schemaType => String +showSchemaType = showSchemaTypeV schemaType + where + schemaType = toSchemaTypeV $ Proxy @schemaType {- Conversions from schema types into Haskell types -} -- | A type family mapping SchemaType to the corresponding Haskell type. type family SchemaResult (schema :: SchemaType) where - SchemaResult 'SchemaBool = Bool - SchemaResult 'SchemaInt = Int - SchemaResult 'SchemaDouble = Double - SchemaResult 'SchemaText = Text - SchemaResult ('SchemaCustom inner) = inner + SchemaResult ('SchemaScalar inner) = inner SchemaResult ('SchemaMaybe inner) = Maybe (SchemaResult inner) SchemaResult ('SchemaTry inner) = Maybe (SchemaResult inner) SchemaResult ('SchemaList inner) = [SchemaResult inner] - SchemaResult ('SchemaObject inner) = Object ('SchemaObject inner) SchemaResult ('SchemaUnion schemas) = SumType (SchemaResultList schemas) + SchemaResult ('SchemaObject inner) = Object ('Schema inner) type family SchemaResultList (xs :: [SchemaType]) where SchemaResultList '[] = '[] SchemaResultList (x ': xs) = SchemaResult x ': SchemaResultList xs -- | A type-class for types that can be parsed from JSON for an associated schema type. -class Typeable schema => IsSchemaType (schema :: SchemaType) where +class IsSchemaType schema => HasSchemaResult (schema :: SchemaType) where parseValue :: [Text] -> Value -> Parser (SchemaResult schema) default parseValue :: FromJSON (SchemaResult schema) => [Text] -> Value -> Parser (SchemaResult schema) parseValue path value = parseJSON value <|> parseFail @schema path value - showValue :: SchemaResult schema -> String - default showValue :: Show (SchemaResult schema) => SchemaResult schema -> String - showValue = show - -instance IsSchemaType 'SchemaBool - -instance IsSchemaType 'SchemaInt - -instance IsSchemaType 'SchemaDouble + toValue :: SchemaResult schema -> Value + default toValue :: ToJSON (SchemaResult schema) => SchemaResult schema -> Value + toValue = toJSON -instance IsSchemaType 'SchemaText + -- Note: Using ShowS here instead of just returning String to avoid quadratic performance when + -- using (++) + showValue :: SchemaResult schema -> ShowS + default showValue :: Show (SchemaResult schema) => SchemaResult schema -> ShowS + showValue = shows -instance (Show inner, Typeable inner, FromJSON inner) => IsSchemaType ('SchemaCustom inner) +instance (Show inner, Typeable inner, FromJSON inner, ToJSON inner) => HasSchemaResult ('SchemaScalar inner) -instance (IsSchemaType inner, Show (SchemaResult inner)) => IsSchemaType ('SchemaMaybe inner) where +instance (HasSchemaResult inner, Show (SchemaResult inner), ToJSON (SchemaResult inner)) => HasSchemaResult ('SchemaMaybe inner) where parseValue path = \case Null -> return Nothing value -> (Just <$> parseValue @inner path value) -instance (IsSchemaType inner, Show (SchemaResult inner)) => IsSchemaType ('SchemaTry inner) where +instance (HasSchemaResult inner, Show (SchemaResult inner), ToJSON (SchemaResult inner)) => HasSchemaResult ('SchemaTry inner) where parseValue path = wrapTry . parseValue @inner path where wrapTry parser = (Just <$> parser) <|> pure Nothing -instance (IsSchemaType inner, Show (SchemaResult inner)) => IsSchemaType ('SchemaList inner) where - parseValue path value = case value of +instance (HasSchemaResult inner, Show (SchemaResult inner), ToJSON (SchemaResult inner)) => HasSchemaResult ('SchemaList inner) where + parseValue path = \case Array a -> traverse (parseValue @inner path) (toList a) - _ -> parseFail @('SchemaList inner) path value + value -> parseFail @('SchemaList inner) path value -instance IsSchemaType ('SchemaObject '[]) where - parseValue path = \case - Object _ -> return $ UnsafeObject mempty - value -> parseFail @('SchemaObject '[]) path value +instance + ( All HasSchemaResult schemas + , All IsSchemaType schemas + , Show (SchemaResult ('SchemaUnion schemas)) + , FromJSON (SchemaResult ('SchemaUnion schemas)) + , ToJSON (SchemaResult ('SchemaUnion schemas)) + , ParseSumType schemas + ) => HasSchemaResult ('SchemaUnion (schemas :: [SchemaType])) where + parseValue path value = parseSumType @schemas path value <|> parseFail @('SchemaUnion schemas) path value - showValue _ = "{}" +class ParseSumType xs where + parseSumType :: [Text] -> Value -> Parser (SumType (SchemaResultList xs)) -instance - ( KnownSchemaKey schemaKey - , IsSchemaType inner - , Show (SchemaResult inner) - , Typeable (SchemaResult inner) - , IsSchemaObject ('SchemaObject rest) - , Typeable rest - ) => IsSchemaType ('SchemaObject ('(schemaKey, inner) ': rest)) where - parseValue path value = case value of - Object o -> do - let key = fromSchemaKey @schemaKey - innerVal = getContext @schemaKey o +instance ParseSumType '[] where + parseSumType _ _ = empty - inner <- parseValue @inner (key:path) innerVal - UnsafeObject rest <- parseValue @('SchemaObject rest) path value +instance (HasSchemaResult schema, ParseSumType schemas) => ParseSumType (schema ': schemas) where + parseSumType path value = parseHere <|> parseThere + where + parseHere = Here <$> parseValue @schema path value + parseThere = There <$> parseSumType @schemas path value - return $ UnsafeObject $ HashMap.insert key (toDyn inner) rest - _ -> parseFail @('SchemaObject ('(schemaKey, inner) ': rest)) path value +instance (All HasSchemaResultPair pairs, IsSchemaObjectMap pairs) => HasSchemaResult ('SchemaObject pairs) where + parseValue path = \case + Aeson.Object o -> UnsafeObject . HashMap.fromList <$> parseValueMap o + value -> parseFail @('SchemaObject pairs) path value + where + parseValueMap :: Aeson.Object -> Parser [(Text, Dynamic)] + parseValueMap o = sequence $ mapAll @HasSchemaResultPair @pairs $ \proxy -> parseValuePair proxy path o - showValue (UnsafeObject hm) = case showValue @('SchemaObject rest) (UnsafeObject hm) of - "{}" -> "{" ++ pair ++ "}" - '{':s -> "{" ++ pair ++ ", " ++ s - s -> error $ "Unknown result when showing Object: " ++ s + toValue = Aeson.Object . toValueMap + + showValue o = showString "{ " . intercalateShowS ", " (map fromPair pairs) . showString " }" where - key = fromSchemaKey @schemaKey - value = - let dynValue = hm ! key - in maybe (show dynValue) show $ fromDynamic @(SchemaResult inner) dynValue - pair = show key ++ ": " ++ value + fromPair (k, v) = showString k . showString ": " . v + pairs = mapAll @HasSchemaResultPair @pairs $ \proxy -> showValuePair proxy o + -- intercalate for ShowS + intercalateShowS :: String -> [ShowS] -> ShowS + intercalateShowS s = concatShowS . intersperse (showString s) + + concatShowS :: [ShowS] -> ShowS + concatShowS = foldr (.) id + +toValueMap :: forall pairs. All HasSchemaResultPair pairs => Object ('Schema pairs) -> Aeson.Object +toValueMap o = HashMap.unions $ mapAll @HasSchemaResultPair @pairs (\proxy -> toValuePair proxy o) + +class HasSchemaResultPair (a :: (SchemaKey, SchemaType)) where + parseValuePair :: Proxy a -> [Text] -> Aeson.Object -> Parser (Text, Dynamic) + toValuePair :: Proxy a -> Object schema -> Aeson.Object + showValuePair :: Proxy a -> Object schema -> (String, ShowS) + instance - ( All IsSchemaType schemas - , Typeable schemas - , Show (SchemaResult ('SchemaUnion schemas)) - , FromJSON (SchemaResult ('SchemaUnion schemas)) - ) => IsSchemaType ('SchemaUnion schemas) + ( IsSchemaKey key + , HasSchemaResult inner + , Typeable (SchemaResult inner) + ) => HasSchemaResultPair '(key, inner) where + parseValuePair _ path o = do + inner <- parseValue @inner (key:path) $ getContext schemaKey o + return (key, toDyn inner) + where + schemaKey = toSchemaKeyV $ Proxy @key + key = Text.pack $ fromSchemaKeyV schemaKey + toValuePair _ o = toContext schemaKey (toValue @inner val) + where + schemaKey = toSchemaKeyV $ Proxy @key + val = unsafeGetKey @inner (Proxy @(FromSchemaKey key)) o + + showValuePair _ o = (showSchemaKey @key, showValue @inner val) + where + val = unsafeGetKey @inner (Proxy @(FromSchemaKey key)) o + -- | A helper for creating fail messages when parsing a schema. -parseFail :: forall (schema :: SchemaType) m a. (MonadFail m, Typeable schema) => [Text] -> Value -> m a +parseFail :: forall (schema :: SchemaType) m a. (MonadFail m, HasSchemaResult schema) => [Text] -> Value -> m a parseFail path value = fail $ msg ++ ": " ++ ellipses 200 (show value) where msg = if null path then "Could not parse schema " ++ schema' else "Could not parse path '" ++ path' ++ "' with schema " ++ schema' path' = Text.unpack . Text.intercalate "." $ reverse path - schema' = "`" ++ showSchema @schema ++ "`" + schema' = "`" ++ showSchemaType @schema ++ "`" ellipses n s = if length s > n then take n s ++ "..." else s {- Lookups within SchemaObject -} @@ -274,8 +271,8 @@ type Lookup a = Fcf.Map Fcf.Snd <=< Fcf.Find (Fcf.TyEq a <=< Fcf.Fst) -- | The type-level function that return the schema of the given key in a 'SchemaObject'. -type family LookupSchema (key :: Symbol) (schema :: SchemaType) :: SchemaType where - LookupSchema key ('SchemaObject schema) = Fcf.Eval +type family LookupSchema (key :: Symbol) (schema :: Schema) :: SchemaType where + LookupSchema key ('Schema schema) = Fcf.Eval ( Fcf.FromMaybe (TypeError ( 'Text "Key '" ':<>: 'Text key @@ -285,12 +282,6 @@ ) =<< Lookup key =<< Fcf.Map (Fcf.Bimap UnSchemaKey Fcf.Pure) schema ) - LookupSchema key schema = TypeError - ( 'Text "Attempted to lookup key '" - ':<>: 'Text key - ':<>: 'Text "' in the following schema:" - ':$$: 'ShowType schema - ) -- | Get a key from the given 'Data.Aeson.Schema.Internal.Object', returned as the type encoded in -- its schema. @@ -305,22 +296,30 @@ -- > ] -- > ) -- > --- > getKey @"foo" o :: Bool --- > getKey @"bar" o :: Object ('SchemaObject '[ '("name", 'SchemaText) ]) --- > getKey @"name" $ getKey @"bar" o :: Text --- > getKey @"baz" o :: Maybe Bool +-- > getKey (Proxy @"foo") o :: Bool +-- > getKey (Proxy @"bar") o :: Object ('SchemaObject '[ '("name", 'SchemaText) ]) +-- > getKey (Proxy @"name") $ getKey @"bar" o :: Text +-- > getKey (Proxy @"baz") o :: Maybe Bool -- getKey - :: forall key schema endSchema result - . ( endSchema ~ LookupSchema key schema + :: forall (key :: Symbol) (schema :: Schema) (endSchema :: SchemaType) result. + ( endSchema ~ LookupSchema key schema , result ~ SchemaResult endSchema , KnownSymbol key , Typeable result , Typeable endSchema ) - => Object schema + => Proxy key + -> Object schema -> result -getKey (UnsafeObject object) = fromDyn (object ! Text.pack key) badCast +getKey = unsafeGetKey @endSchema + +unsafeGetKey + :: forall (endSchema :: SchemaType) (key :: Symbol) (schema :: Schema) + . (KnownSymbol key, Typeable (SchemaResult endSchema)) + => Proxy key -> Object schema -> SchemaResult endSchema +unsafeGetKey keyProxy (UnsafeObject object) = + fromMaybe (unreachable $ "Could not load key: " ++ key) $ + fromDynamic (object ! Text.pack key) where - key = symbolVal (Proxy @key) - badCast = error $ "Could not load key: " ++ key + key = symbolVal keyProxy diff --git a/src/Data/Aeson/Schema/Key.hs b/src/Data/Aeson/Schema/Key.hs --- a/src/Data/Aeson/Schema/Key.hs +++ b/src/Data/Aeson/Schema/Key.hs @@ -6,20 +6,100 @@ Defines a SchemaKey. -} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} module Data.Aeson.Schema.Key - ( SchemaKey(..) + ( SchemaKey'(..) + , SchemaKeyV + , fromSchemaKeyV + , showSchemaKeyV + , getContext + , toContext + , SchemaKey + , IsSchemaKey(..) , fromSchemaKey + , showSchemaKey ) where +import qualified Data.Aeson as Aeson +import Data.Hashable (Hashable) +import qualified Data.HashMap.Strict as HashMap +import Data.Proxy (Proxy(..)) +import qualified Data.Text as Text +import GHC.Generics (Generic) +import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) +import Language.Haskell.TH.Syntax (Lift) + +import Data.Aeson.Schema.Utils.Invariant (unreachable) + -- | A key in a JSON object schema. -data SchemaKey - = NormalKey String - | PhantomKey String +data SchemaKey' s + = NormalKey s + | PhantomKey s -- ^ A key that doesn't actually exist in the object, but whose content should be parsed from -- the current object. - deriving (Show) + deriving (Show, Eq, Generic, Hashable, Lift) -fromSchemaKey :: SchemaKey -> String -fromSchemaKey (NormalKey key) = key -fromSchemaKey (PhantomKey key) = key +-- | A value-level SchemaKey +type SchemaKeyV = SchemaKey' String + +fromSchemaKeyV :: SchemaKeyV -> String +fromSchemaKeyV (NormalKey key) = key +fromSchemaKeyV (PhantomKey key) = key + +showSchemaKeyV :: SchemaKeyV -> String +showSchemaKeyV (NormalKey key) = show key +showSchemaKeyV (PhantomKey key) = "[" ++ key ++ "]" + +-- | Given schema `{ key: innerSchema }` for JSON data `{ key: val1 }`, get the JSON +-- Value that `innerSchema` should parse. +getContext :: SchemaKeyV -> Aeson.Object -> Aeson.Value +getContext = \case + -- `innerSchema` should parse `val1` + NormalKey key -> HashMap.lookupDefault Aeson.Null (Text.pack key) + -- `innerSchema` should parse the same object that `key` is in + PhantomKey _ -> Aeson.Object + +-- | Given JSON data `val` adhering to `innerSchema`, get the JSON object that should be +-- merged with the outer JSON object. +toContext :: SchemaKeyV -> Aeson.Value -> Aeson.Object +toContext = \case + -- `val` should be inserted with key `key` + NormalKey key -> HashMap.singleton (Text.pack key) + -- If `val` is an object, it should be merged with the outer JSON object + PhantomKey _ -> \case + Aeson.Object o -> o + -- `Try` schema could store `Nothing`, which would return `Null`. In this case, there is no + -- context to merge + Aeson.Null -> mempty + v -> unreachable $ "Invalid value for phantom key: " ++ show v + +-- | A type-level SchemaKey +type SchemaKey = SchemaKey' Symbol + +class KnownSymbol (FromSchemaKey key) => IsSchemaKey (key :: SchemaKey) where + type FromSchemaKey key :: Symbol + toSchemaKeyV :: Proxy key -> SchemaKeyV + +instance KnownSymbol key => IsSchemaKey ('NormalKey key) where + type FromSchemaKey ('NormalKey key) = key + toSchemaKeyV _ = NormalKey $ symbolVal $ Proxy @key + +instance KnownSymbol key => IsSchemaKey ('PhantomKey key) where + type FromSchemaKey ('PhantomKey key) = key + toSchemaKeyV _ = PhantomKey $ symbolVal $ Proxy @key + +fromSchemaKey :: forall key. IsSchemaKey key => String +fromSchemaKey = fromSchemaKeyV $ toSchemaKeyV $ Proxy @key + +showSchemaKey :: forall key. IsSchemaKey key => String +showSchemaKey = showSchemaKeyV $ toSchemaKeyV $ Proxy @key diff --git a/src/Data/Aeson/Schema/Show.hs b/src/Data/Aeson/Schema/Show.hs --- a/src/Data/Aeson/Schema/Show.hs +++ b/src/Data/Aeson/Schema/Show.hs @@ -11,53 +11,39 @@ module Data.Aeson.Schema.Show ( SchemaType(..) , showSchemaType - -- * Re-exports - , SchemaKey(..) ) where import Data.List (intercalate) -import Data.Aeson.Schema.Key (SchemaKey(..), fromSchemaKey) +import Data.Aeson.Schema.Key (SchemaKeyV, showSchemaKeyV) -- | 'Data.Aeson.Schema.Internal.SchemaType', but for printing. data SchemaType - = SchemaBool - | SchemaInt - | SchemaDouble - | SchemaText - | SchemaCustom String + = SchemaScalar String | SchemaMaybe SchemaType | SchemaTry SchemaType | SchemaList SchemaType - | SchemaObject [(SchemaKey, SchemaType)] + | SchemaObject [(SchemaKeyV, SchemaType)] | SchemaUnion [SchemaType] - deriving (Show) + deriving (Show,Eq) -- | Pretty show the given SchemaType. showSchemaType :: SchemaType -> String showSchemaType schema = case schema of - SchemaBool -> "SchemaBool" - SchemaInt -> "SchemaInt" - SchemaDouble -> "SchemaDouble" - SchemaText -> "SchemaText" - SchemaCustom s -> "SchemaCustom " ++ s + SchemaScalar s -> "SchemaScalar " ++ s SchemaMaybe inner -> "SchemaMaybe " ++ showSchemaType' inner SchemaTry inner -> "SchemaTry " ++ showSchemaType' inner SchemaList inner -> "SchemaList " ++ showSchemaType' inner - SchemaObject _ -> "SchemaObject " ++ showSchemaType' schema SchemaUnion _ -> "SchemaUnion " ++ showSchemaType' schema + SchemaObject _ -> "SchemaObject " ++ showSchemaType' schema where showSchemaType' = \case - SchemaBool -> "Bool" - SchemaInt -> "Int" - SchemaDouble -> "Double" - SchemaText -> "Text" - SchemaCustom s -> s + SchemaScalar s -> s SchemaMaybe inner -> "Maybe " ++ showSchemaType' inner SchemaTry inner -> "Try " ++ showSchemaType' inner SchemaList inner -> "List " ++ showSchemaType' inner - SchemaObject pairs -> "{" ++ mapJoin showPair ", " pairs ++ "}" SchemaUnion schemas -> "( " ++ mapJoin showSchemaType' " | " schemas ++ " )" - showPair (key, inner) = "\"" ++ fromSchemaKey key ++ "\": " ++ showSchemaType' inner + SchemaObject pairs -> "{ " ++ mapJoin showPair ", " pairs ++ " }" + showPair (key, inner) = showSchemaKeyV key ++ ": " ++ showSchemaType' inner mapJoin f delim = intercalate delim . map f diff --git a/src/Data/Aeson/Schema/TH/Get.hs b/src/Data/Aeson/Schema/TH/Get.hs --- a/src/Data/Aeson/Schema/TH/Get.hs +++ b/src/Data/Aeson/Schema/TH/Get.hs @@ -13,17 +13,19 @@ module Data.Aeson.Schema.TH.Get where -import Control.Monad (unless, (>=>)) +import Control.Monad ((>=>)) +import Data.List (intercalate) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Maybe as Maybe import Data.Proxy (Proxy(..)) import GHC.Stack (HasCallStack) import Language.Haskell.TH import Language.Haskell.TH.Quote (QuasiQuoter(..)) -import Language.Haskell.TH.Syntax (lift) import Data.Aeson.Schema.Internal (getKey) -import Data.Aeson.Schema.TH.Parse (GetterExp(..), getterExp, parse) -import Data.Aeson.Schema.TH.Utils (GetterOperation(..), showGetterOps) +import Data.Aeson.Schema.TH.Parse + (GetterExp(..), GetterOperation(..), GetterOps, parseGetterExp) import Data.Aeson.Schema.Utils.Sum (fromSumType) -- | Defines a QuasiQuoter for extracting JSON data. @@ -80,52 +82,57 @@ -- the sum type contains an 'Int'. get :: QuasiQuoter get = QuasiQuoter - { quoteExp = parse getterExp >=> generateGetterExp + { quoteExp = parseGetterExp >=> generateGetterExp , quoteDec = error "Cannot use `get` for Dec" , quoteType = error "Cannot use `get` for Type" , quotePat = error "Cannot use `get` for Pat" } generateGetterExp :: GetterExp -> ExpQ -generateGetterExp GetterExp{..} = maybe expr (appE expr . varE . mkName) start +generateGetterExp GetterExp{..} = applyStart $ resolveGetterOpExps $ mkGetterOpExps [] getterOps where + applyStart expr = maybe expr (appE expr . varE . mkName) start + startDisplay = case start of Nothing -> "" Just s -> if '.' `elem` s then "(" ++ s ++ ")" else s - expr = mkGetterExp [] getterOps - applyToNext next = \case - Right f -> [| $next . $f |] - Left f -> infixE (Just next) f Nothing + mkGetterOpExps :: [GetterOperation] -> GetterOps -> GetterOpExps + mkGetterOpExps historyPrefix = mapWithHistory (mkGetterOpExp . (historyPrefix ++)) - applyToEach history fromElems elems = do - val <- newName "v" - let mkElem ops = appE (mkGetterExp history ops) (varE val) - lamE [varP val] $ fromElems $ map mkElem elems + mkGetterOpExp :: [GetterOperation] -> GetterOperation -> GetterOpExp + mkGetterOpExp history = \case + GetterKey key -> + let keyType = litT $ strTyLit key + in ApplyOp [| getKey (Proxy :: Proxy $keyType) |] - mkGetterExp history = \case - [] -> [| id |] - op:ops -> - let applyToNext' = applyToNext $ mkGetterExp (op:history) ops - applyToEach' = applyToEach history - checkLast label = unless (null ops) $ fail $ label ++ " operation MUST be last." - fromJustMsg = startDisplay ++ showGetterOps (reverse history) - in case op of - GetterKey key -> applyToNext' $ Right $ appTypeE [| getKey |] (litT $ strTyLit key) - GetterList elems -> checkLast ".[*]" >> applyToEach' listE elems - GetterTuple elems -> checkLast ".(*)" >> applyToEach' tupE elems - GetterBang -> applyToNext' $ Right [| fromJust $(lift fromJustMsg) |] - GetterMapMaybe -> applyToNext' $ Left [| (<$?>) |] - GetterMapList -> applyToNext' $ Left [| (<$:>) |] - GetterBranch branch -> - let branchTyLit = litT $ numTyLit $ fromIntegral branch - in applyToNext' $ Right [| fromSumType (Proxy :: Proxy $branchTyLit) |] + GetterBang -> + let expr = startDisplay ++ showGetterOps history + in ApplyOp [| fromJust expr |] + GetterMapMaybe -> + ApplyOpInfix [| (<$?>) |] + + GetterMapList -> + ApplyOpInfix [| (<$:>) |] + + GetterBranch branch -> + let branchType = litT $ numTyLit $ fromIntegral branch + in ApplyOp [| fromSumType (Proxy :: Proxy $branchType) |] + + GetterList elemOps -> + ApplyOpsIntoList $ mkGetterOpExps history <$> elemOps + + GetterTuple elemOps -> + ApplyOpsIntoTuple $ mkGetterOpExps history <$> elemOps + +{- Runtime helpers -} + -- | fromJust with helpful error message fromJust :: HasCallStack => String -> Maybe a -> a -fromJust msg = Maybe.fromMaybe (error errMsg) +fromJust expr = Maybe.fromMaybe (error errMsg) where - errMsg = "Called 'fromJust' on null expression" ++ if null msg then "" else ": " ++ msg + errMsg = "Called 'fromJust' on null expression" ++ if null expr then "" else ": " ++ expr -- | fmap specialized to Maybe (<$?>) :: (a -> b) -> Maybe a -> Maybe b @@ -134,3 +141,54 @@ -- | fmap specialized to [a] (<$:>) :: (a -> b) -> [a] -> [b] (<$:>) = (<$>) + +{- Code generation helpers -} + +data GetterOpExp + = ApplyOp ExpQ -- ^ next . f + | ApplyOpInfix ExpQ -- ^ (next `f`) + | ApplyOpsIntoList (NonEmpty GetterOpExps) -- ^ \v -> [f1 v, f2 v, ...] + | ApplyOpsIntoTuple (NonEmpty GetterOpExps) -- ^ \v -> (f1 v, f2 v, ...) + +type GetterOpExps = NonEmpty GetterOpExp + +resolveGetterOpExps :: GetterOpExps -> ExpQ +resolveGetterOpExps (op NonEmpty.:| ops) = + case op of + ApplyOp f -> [| $next . $f |] + ApplyOpInfix f -> infixE (Just next) f Nothing + + -- suffixes; ops should be empty + ApplyOpsIntoList elemOps -> resolveEach listE elemOps + ApplyOpsIntoTuple elemOps -> resolveEach tupE elemOps + where + next = maybe [| id |] resolveGetterOpExps $ NonEmpty.nonEmpty ops + + resolveEach fromElems elemOps = do + val <- newName "v" + let applyVal expr = appE expr (varE val) + lamE [varP val] $ fromElems $ map (applyVal . resolveGetterOpExps) $ NonEmpty.toList elemOps + +showGetterOps :: Foldable t => t GetterOperation -> String +showGetterOps = concatMap showGetterOp + where + showGetterOp = \case + GetterKey key -> '.':key + GetterBang -> "!" + GetterMapList -> "[]" + GetterMapMaybe -> "?" + GetterBranch x -> '@' : show x + GetterList elemOps -> ".[" ++ showGetterOpsList elemOps ++ "]" + GetterTuple elemOps -> ".(" ++ showGetterOpsList elemOps ++ ")" + + showGetterOpsList = intercalate "," . NonEmpty.toList . fmap showGetterOps + +{- Utilities -} + +-- | Run the given function for each element in the list, providing all elements seen so far. +-- +-- e.g. for a list [1,2,3], this will return the result of +-- +-- [f [] 1, f [1] 2, f [1,2] 3] +mapWithHistory :: ([a] -> a -> b) -> NonEmpty a -> NonEmpty b +mapWithHistory f xs = NonEmpty.zipWith f (NonEmpty.inits xs) xs diff --git a/src/Data/Aeson/Schema/TH/Getter.hs b/src/Data/Aeson/Schema/TH/Getter.hs --- a/src/Data/Aeson/Schema/TH/Getter.hs +++ b/src/Data/Aeson/Schema/TH/Getter.hs @@ -17,18 +17,23 @@ import Language.Haskell.TH import Data.Aeson.Schema.TH.Get (generateGetterExp) -import Data.Aeson.Schema.TH.Parse (GetterExp(..), getterExp, parse) -import Data.Aeson.Schema.TH.Utils (reifySchema, unwrapType) +import Data.Aeson.Schema.TH.Parse (GetterExp(..), parseGetterExp) +import Data.Aeson.Schema.TH.Unwrap + (FunctorHandler(..), unwrapSchema, unwrapSchemaUsing) +import Data.Aeson.Schema.TH.Utils (reifySchemaName, schemaVToTypeQ) -- | A helper that generates a 'Data.Aeson.Schema.TH.get' expression and a type alias for the result -- of the expression. -- --- > mkGetter "Node" "getNodes" ''MySchema ".nodes![]" +-- > mkGetter "Node" "getNodes" ''MySchema ".nodes[]" -- > --- > -- is equivalent to: --- > type Node = [unwrap| MySchema.nodes[] |] -- Object [schema| { b: Maybe Bool } |] +-- > {- is equivalent to -} +-- > +-- > -- | Node ~ { b: Maybe Bool } +-- > type Node = [unwrap| MySchema.nodes[] |] +-- > -- > getNodes :: Object MySchema -> [Node] --- > getNodes = [get| .nodes![] |] +-- > getNodes = [get| .nodes[] |] -- -- 'mkGetter' takes four arguments: -- @@ -44,42 +49,47 @@ -- There is one subtlety that occurs from the use of the same @ops@ string for both the -- 'Data.Aeson.Schema.TH.unwrap' and 'Data.Aeson.Schema.TH.get' quasiquoters: -- 'Data.Aeson.Schema.TH.unwrap' strips out intermediate functors, while 'Data.Aeson.Schema.TH.get' --- applies within the functor. So in the above example, @".nodes![]"@ strips out the list when --- saving the schema to @Node@, while in the below example, @".nodes!"@ doesn't strip out the list +-- applies within the functor. So in the above example, @".nodes[]"@ strips out the list when +-- saving the schema to @Node@, while in the below example, @".nodes"@ doesn't strip out the list -- when saving the schema to @Nodes@. -- -- > mkGetter "Nodes" "getNodes" ''MySchema ".nodes" -- > --- > -- is equivalent to: --- > type Nodes = [unwrap| MySchema.nodes! |] -- [Object [schema| { b: Maybe Bool } |]] +-- > {- is equivalent to -} +-- > +-- > -- | Nodes ~ List { b: Maybe Bool } +-- > type Nodes = [unwrap| MySchema.nodes |] +-- > -- > getNodes :: Object MySchema -> Nodes --- > getNodes = [get| .nodes! |] +-- > getNodes = [get| .nodes |] -- -- As another example, -- -- > mkGetter "MyName" "getMyName" ''MySchema ".f?[].name" -- > --- > -- is equivalent to: --- > type MyName = [unwrap| MySchema.f?[].name |] -- Text +-- > {- is equivalent to -} +-- > +-- > -- | MyName ~ Text +-- > type MyName = [unwrap| MySchema.f?[].name |] +-- > -- > getMyBool :: Object MySchema -> Maybe [MyName] -- > getMyBool = [get| .f?[].name |] mkGetter :: String -> String -> Name -> String -> DecsQ mkGetter unwrapName funcName startSchemaName ops = do - -- TODO: allow (Object schema) - startSchemaType <- reifySchema startSchemaName - - getterExp'@GetterExp{..} <- parse getterExp ops + getterExp@GetterExp{..} <- parseGetterExp ops unless (isNothing start) $ fail $ "Getter expression should start with '.': " ++ ops - let unwrapResult = unwrapType False getterOps startSchemaType - funcResult = unwrapType True getterOps startSchemaType - getterFunc = generateGetterExp getterExp' + startSchema <- reifySchemaName startSchemaName + + let unwrapResult = unwrapSchema getterOps startSchema + funcResult = unwrapSchemaUsing ApplyFunctors getterOps startSchema + getterFunc = generateGetterExp getterExp unwrapName' = mkName unwrapName funcName' = mkName funcName sequence [ tySynD unwrapName' [] unwrapResult - , sigD funcName' [t| Object $(pure startSchemaType) -> $funcResult |] + , sigD funcName' [t| Object $(schemaVToTypeQ startSchema) -> $funcResult |] , funD funcName' [clause [] (normalB getterFunc) []] ] diff --git a/src/Data/Aeson/Schema/TH/Parse.hs b/src/Data/Aeson/Schema/TH/Parse.hs --- a/src/Data/Aeson/Schema/TH/Parse.hs +++ b/src/Data/Aeson/Schema/TH/Parse.hs @@ -12,22 +12,20 @@ module Data.Aeson.Schema.TH.Parse where -#if !MIN_VERSION_megaparsec(6,4,0) -import Control.Applicative (empty) -#endif -import Control.Monad (void) +import Control.Monad (MonadPlus, void) #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail (MonadFail) #endif import Data.Functor (($>)) import Data.List (intercalate) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty import Data.Void (Void) -import Text.Megaparsec +import Text.Megaparsec hiding (sepBy1, sepEndBy1, some) +import qualified Text.Megaparsec as Megaparsec import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as L -import Data.Aeson.Schema.TH.Utils (GetterOperation(..), GetterOps) - type Parser = Parsec Void String #if !MIN_VERSION_megaparsec(7,0,0) @@ -35,31 +33,43 @@ errorBundlePretty = parseErrorPretty #endif -parse :: MonadFail m => Parser a -> String -> m a -parse parser s = either (fail . errorBundlePretty) return $ runParser parser s s +runParserFail :: MonadFail m => Parser a -> String -> m a +runParserFail parser s = either (fail . errorBundlePretty) return $ runParser parser s s -{- Parser primitives -} +{- SchemaDef -} -parseGetterOp :: Parser GetterOperation -parseGetterOp = choice - [ lexeme "!" $> GetterBang - , lexeme "[]" $> GetterMapList - , lexeme "?" $> GetterMapMaybe - , lexeme "@" *> (GetterBranch . read <$> some digitChar) - , optional (lexeme ".") *> choice - [ GetterKey <$> jsonKey - , fmap GetterList $ between (lexeme "[") (lexeme "]") $ some parseGetterOp `sepBy1` lexeme "," - , fmap GetterTuple $ between (lexeme "(") (lexeme ")") $ some parseGetterOp `sepBy1` lexeme "," - ] - ] +data SchemaDef + = SchemaDefType String + | SchemaDefMaybe SchemaDef + | SchemaDefTry SchemaDef + | SchemaDefList SchemaDef + | SchemaDefInclude String + | SchemaDefObj (NonEmpty SchemaDefObjItem) + | SchemaDefUnion (NonEmpty SchemaDef) + deriving (Show) -parseSchemaDef :: Parser SchemaDef -parseSchemaDef = parseSchemaDefWithUnions +data SchemaDefObjItem + = SchemaDefObjPair (SchemaDefObjKey, SchemaDef) + | SchemaDefObjExtend String + deriving (Show) + +data SchemaDefObjKey + = SchemaDefObjKeyNormal String + | SchemaDefObjKeyPhantom String + deriving (Show) + +parseSchemaDef :: MonadFail m => String -> m SchemaDef +parseSchemaDef = runParserFail $ do + space + def <- parseSchemaDefWithUnions + space + void eof + return def where parseSchemaDefWithUnions = - let parseSchemaUnion [] = error "Parsed no schema definitions" -- should not happen; sepBy1 returns one or more - parseSchemaUnion [schemaDef'] = schemaDef' - parseSchemaUnion schemaDefs = SchemaDefUnion schemaDefs + let parseSchemaUnion schemaDefs + | length schemaDefs == 1 = NonEmpty.head schemaDefs + | otherwise = SchemaDefUnion schemaDefs in fmap parseSchemaUnion $ parseSchemaDefWithoutUnions `sepBy1` lexeme "|" parseSchemaDefWithoutUnions = choice @@ -80,20 +90,97 @@ parseSchemaDefPair = do key <- choice [ SchemaDefObjKeyNormal <$> jsonKey - , SchemaDefObjKeyPhantom <$> between (lexeme "[") (lexeme "]") jsonKey + , SchemaDefObjKeyPhantom <$> between (lexeme' "[") (lexeme' "]") jsonKey' ] lexeme ":" value <- parseSchemaDefWithUnions return (key, value) parseSchemaReference = char '#' *> namespacedIdentifier upperChar +{- GetterExp -} + +data GetterExp = GetterExp + { start :: Maybe String + , getterOps :: GetterOps + } deriving (Show) + +parseGetterExp :: MonadFail m => String -> m GetterExp +parseGetterExp = runParserFail $ do + space + start <- optional $ namespacedIdentifier lowerChar + getterOps <- parseGetterOps + space + void eof + return GetterExp{..} + +{- UnwrapSchema -} + +data UnwrapSchema = UnwrapSchema + { startSchema :: String + , getterOps :: GetterOps + } deriving (Show) + +parseUnwrapSchema :: MonadFail m => String -> m UnwrapSchema +parseUnwrapSchema = runParserFail $ do + space + startSchema <- namespacedIdentifier upperChar + getterOps <- parseGetterOps + space + void eof + return UnwrapSchema{..} + +{- GetterOps -} + +-- | A non-empty list of GetterOperations. +-- +-- Invariant: Any GetterList/GetterTuple operations MUST be last. +type GetterOps = NonEmpty GetterOperation + +parseGetterOps :: Parser GetterOps +parseGetterOps = someWith [parseGetterOp, parseGetterOpSuffix] + +data GetterOperation + = GetterKey String + | GetterBang + | GetterMapList + | GetterMapMaybe + | GetterBranch Int + -- suffixes + | GetterList (NonEmpty GetterOps) + | GetterTuple (NonEmpty GetterOps) + deriving (Show) + +parseGetterOp :: Parser GetterOperation +parseGetterOp = choice + [ lexeme "!" $> GetterBang + , lexeme "[]" $> GetterMapList + , lexeme "?" $> GetterMapMaybe + , lexeme "@" *> (GetterBranch . read . NonEmpty.toList <$> some digitChar) + , optional (lexeme ".") *> (GetterKey <$> jsonKey) + ] + +parseGetterOpSuffix :: Parser GetterOperation +parseGetterOpSuffix = optional (lexeme ".") *> choice + [ fmap GetterList $ between (lexeme "[") (lexeme "]") $ parseGetterOps `sepBy1` lexeme "," + , fmap GetterTuple $ between (lexeme "(") (lexeme ")") $ parseGetterOps `sepBy1` lexeme "," + ] + +{- Parser primitives -} + -- | A Haskell identifier, with the given first character. identifier :: Parser Char -> Parser String identifier start = (:) <$> start <*> many (alphaNumChar <|> char '\'') lexeme :: String -> Parser () -lexeme = void . L.lexeme (L.space space1 (L.skipLineComment "//") empty) . string +lexeme = lexemeUsingLineComment $ L.skipLineComment "//" +-- | Same as 'lexeme', but without parsing comments. +lexeme' :: String -> Parser () +lexeme' = lexemeUsingLineComment empty + +lexemeUsingLineComment :: Parser () -> String -> Parser () +lexemeUsingLineComment lineComment = void . L.lexeme (L.space space1 lineComment empty) . string + -- | Parses `identifier`, but if parentheses are provided, parses a namespaced identifier. namespacedIdentifier :: Parser Char -> Parser String namespacedIdentifier start = choice [lexeme "(" *> namespaced <* lexeme ")", ident] @@ -105,73 +192,52 @@ , (:[]) <$> end ] --- | A string that can be used as a JSON key. +-- | An optionally quoted JSON key. jsonKey :: Parser String -jsonKey = some $ noneOf $ " " ++ schemaChars ++ getChars +jsonKey = choice [char '"' *> jsonKey' <* char '"', jsonKey'] + +-- | A string that can be used as a JSON key. +jsonKey' :: Parser String +jsonKey' = fmap NonEmpty.toList $ some $ choice + [ try $ char '\\' *> anySingle' + , noneOf $ [' ', '\\', '"'] ++ schemaChars ++ getChars + ] where +#if MIN_VERSION_megaparsec(7,0,0) + anySingle' = anySingle +#else + anySingle' = anyChar +#endif + -- characters that cause ambiguity when parsing 'get' expressions getChars = "!?[](),.@" -- characters that should not indicate the start of a key when parsing 'schema' definitions schemaChars = ":{}#" -{- SchemaDef -} - -data SchemaDef - = SchemaDefType String - | SchemaDefMaybe SchemaDef - | SchemaDefTry SchemaDef - | SchemaDefList SchemaDef - | SchemaDefInclude String - | SchemaDefObj [SchemaDefObjItem] - | SchemaDefUnion [SchemaDef] - deriving (Show) - -data SchemaDefObjItem - = SchemaDefObjPair (SchemaDefObjKey, SchemaDef) - | SchemaDefObjExtend String - deriving (Show) - -data SchemaDefObjKey - = SchemaDefObjKeyNormal String - | SchemaDefObjKeyPhantom String - deriving (Show) - -schemaDef :: Parser SchemaDef -schemaDef = do - space - def <- parseSchemaDef - space - void eof - return def - -{- GetterExp -} - -data GetterExp = GetterExp - { start :: Maybe String - , getterOps :: GetterOps - } deriving (Show) +{- Parsing utilities -} -getterExp :: Parser GetterExp -getterExp = do - space - start <- optional $ namespacedIdentifier lowerChar - getterOps <- some parseGetterOp - space - void eof - return GetterExp{..} +-- | Same as 'Megaparsec.some', except returns a 'NonEmpty' +some :: MonadPlus f => f a -> f (NonEmpty a) +some p = NonEmpty.fromList <$> Megaparsec.some p -{- UnwrapSchema -} +-- | Same as 'Megaparsec.sepBy1', except returns a 'NonEmpty' +sepBy1 :: MonadPlus f => f a -> f sep -> f (NonEmpty a) +sepBy1 p sep = NonEmpty.fromList <$> Megaparsec.sepBy1 p sep -data UnwrapSchema = UnwrapSchema - { startSchema :: String - , getterOps :: GetterOps - } deriving (Show) +-- | Same as 'Megaparsec.sepEndBy1', except returns a 'NonEmpty' +sepEndBy1 :: MonadPlus f => f a -> f sep -> f (NonEmpty a) +sepEndBy1 p sep = NonEmpty.fromList <$> Megaparsec.sepEndBy1 p sep -unwrapSchema :: Parser UnwrapSchema -unwrapSchema = do - space - startSchema <- namespacedIdentifier upperChar - getterOps <- some parseGetterOp - space - void eof - return UnwrapSchema{..} +-- | Return a non-empty list containing elements from the given parsers in order. +-- +-- i.e. for `someWith [p1, p2, p3]`, elements parsed with `p1` will come before +-- elements parsed with `p2` and `p3`, etc. +-- +-- An individual parser in the list may not parse anything, but at least one parser must return +-- something. +someWith :: MonadParsec e s m => [m a] -> m (NonEmpty a) +someWith ps = do + as <- concatMapM (many . try) ps + maybe empty return $ NonEmpty.nonEmpty as + where + concatMapM f = fmap concat . mapM f diff --git a/src/Data/Aeson/Schema/TH/Schema.hs b/src/Data/Aeson/Schema/TH/Schema.hs --- a/src/Data/Aeson/Schema/TH/Schema.hs +++ b/src/Data/Aeson/Schema/TH/Schema.hs @@ -7,28 +7,39 @@ The 'schema' quasiquoter. -} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} module Data.Aeson.Schema.TH.Schema (schema) where -import Control.Monad (unless, (<=<), (>=>)) -import Data.Bifunctor (second) +import Control.Monad (unless, (>=>)) +import Data.Function (on) +import Data.Hashable (Hashable) import qualified Data.HashMap.Strict as HashMap -import Data.Maybe (mapMaybe) +import Data.List (nubBy) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty import Language.Haskell.TH import Language.Haskell.TH.Quote (QuasiQuoter(..)) -import Data.Aeson.Schema.Internal (SchemaType(..)) -import Data.Aeson.Schema.Key (SchemaKey(..), fromSchemaKey) -import qualified Data.Aeson.Schema.Show as SchemaShow +import Data.Aeson.Schema.Key (SchemaKey'(..), SchemaKeyV, fromSchemaKeyV) import Data.Aeson.Schema.TH.Parse -import Data.Aeson.Schema.TH.Utils - (parseSchemaType, schemaPairsToTypeQ, typeQListToTypeQ, typeToSchemaPairs) + (SchemaDef(..), SchemaDefObjItem(..), SchemaDefObjKey(..), parseSchemaDef) +import Data.Aeson.Schema.TH.Utils (reifySchema, schemaVToTypeQ) +import Data.Aeson.Schema.Type + ( NameLike(..) + , Schema'(..) + , SchemaObjectMapV + , SchemaType'(..) + , SchemaTypeV + , fromSchemaV + , showSchemaTypeV + , toSchemaObjectV + ) +import Data.Aeson.Schema.Utils.Invariant (unreachable) -- | Defines a QuasiQuoter for writing schemas. -- @@ -64,8 +75,10 @@ -- * @Maybe \@ and @List \@ correspond to @Maybe@ and @[]@, containing values -- specified by the provided schema (no parentheses needed). -- --- * @Try \@ correspond to @Maybe@, where the value will be @Just@ if the given schema --- successfully parses the value, or @Nothing@ otherwise. +-- * @Try \@ corresponds to @Maybe@, where the value will be @Just@ if the given schema +-- successfully parses the value, or @Nothing@ otherwise. Different from @Maybe \@, +-- where parsing @{ "foo": true }@ with @{ foo: Try Int }@ returns @Nothing@, whereas it would +-- be a parse error with @{ foo: Maybe Int }@ (added in v1.2.0) -- -- * Any other uppercase identifier corresponds to the respective type in scope -- requires a -- FromJSON instance. @@ -77,106 +90,119 @@ -- 'Data.Aeson.Schema.Utils.Sum.JSONSum' object. (added in v1.1.0) -- -- * @{ [key]: \ }@ uses the current object to resolve the keys in the given schema. Only --- object schemas are allowed here. +-- object schemas are allowed here. (added in v1.2.0) -- --- * @{ key: #Other, ... }@ maps the given key to the @Other@ schema. +-- * @{ key: #Other, ... }@ maps the given key to the @Other@ schema. The @Other@ schema needs to +-- be defined in another module. -- --- * @{ #Other, ... }@ extends this schema with the @Other@ schema. +-- * @{ #Other, ... }@ extends this schema with the @Other@ schema. The @Other@ schema needs to +-- be defined in another module. schema :: QuasiQuoter schema = QuasiQuoter { quoteExp = error "Cannot use `schema` for Exp" , quoteDec = error "Cannot use `schema` for Dec" - , quoteType = parse schemaDef >=> \case + , quoteType = parseSchemaDef >=> \case SchemaDefObj items -> generateSchemaObject items _ -> fail "`schema` definition must be an object" , quotePat = error "Cannot use `schema` for Pat" } - -generateSchemaObject :: [SchemaDefObjItem] -> TypeQ -generateSchemaObject items = [t| 'SchemaObject $(fromItems items) |] where - fromItems = schemaPairsToTypeQ <=< resolveParts . concat <=< mapM toParts - -generateSchema :: SchemaDef -> TypeQ -generateSchema = \case - SchemaDefType "Bool" -> [t| 'SchemaBool |] - SchemaDefType "Int" -> [t| 'SchemaInt |] - SchemaDefType "Double" -> [t| 'SchemaDouble |] - SchemaDefType "Text" -> [t| 'SchemaText |] - SchemaDefType other -> [t| 'SchemaCustom $(getType other) |] - SchemaDefMaybe inner -> [t| 'SchemaMaybe $(generateSchema inner) |] - SchemaDefTry inner -> [t| 'SchemaTry $(generateSchema inner) |] - SchemaDefList inner -> [t| 'SchemaList $(generateSchema inner) |] - SchemaDefInclude other -> getType other - SchemaDefObj items -> generateSchemaObject items - SchemaDefUnion schemas -> [t| 'SchemaUnion $(typeQListToTypeQ $ map generateSchema schemas) |] + generateSchemaObject items = schemaVToTypeQ . Schema =<< generateSchemaObjectV items -{- Helpers -} +data KeySource = Provided | Imported + deriving (Show, Eq) -getName :: String -> Q Name -getName ty = maybe (fail $ "Unknown type: " ++ ty) return =<< lookupTypeName ty +generateSchemaObjectV :: NonEmpty SchemaDefObjItem -> Q SchemaObjectMapV +generateSchemaObjectV schemaDefObjItems = do + schemaObjectMapsWithSource <- mapM getSchemaObjectMap schemaDefObjItems -getType :: String -> TypeQ -getType = getName >=> conT + let schemaObjectMaps :: LookupMap SchemaKeyV (KeySource, SchemaTypeV) + schemaObjectMaps = concatMap (uncurry distribute) schemaObjectMapsWithSource -data KeySource = Provided | Imported - deriving (Show,Eq) + either fail return $ resolveKeys schemaObjectMaps --- | Parse SchemaDefObjItem into a list of tuples, each containing a key to add to the schema, --- the value for the key, and the source of the key. -toParts :: SchemaDefObjItem -> Q [(SchemaKey, TypeQ, KeySource)] -toParts = \case +-- | Get the SchemaObjectMapV for the given SchemaDefObjItem, along with where the SchemaObjectMapV +-- came from. +getSchemaObjectMap :: SchemaDefObjItem -> Q (SchemaObjectMapV, KeySource) +getSchemaObjectMap = \case SchemaDefObjPair (schemaDefKey, schemaDefType) -> do - let schemaKey = schemaDefToSchemaKey schemaDefKey - schemaType <- generateSchema schemaDefType + let schemaKey = fromSchemaDefKey schemaDefKey + schemaType <- fromSchemaDefType schemaDefType case schemaKey of - PhantomKey _ -> do - let schemaTypeShow = parseSchemaType schemaType - unless (isValidPhantomSchema schemaTypeShow) $ - fail $ "Invalid schema for '" ++ fromSchemaKey schemaKey ++ "': " ++ SchemaShow.showSchemaType schemaTypeShow + PhantomKey _ -> + unless (isValidPhantomSchema schemaType) $ + fail $ "Invalid schema for '" ++ fromSchemaKeyV schemaKey ++ "': " ++ showSchemaTypeV schemaType _ -> return () - pure . tagAs Provided $ [(schemaKey, pure schemaType)] + return ([(schemaKey, schemaType)], Provided) + SchemaDefObjExtend other -> do - name <- getName other - reify name >>= \case - TyConI (TySynD _ _ (AppT (PromotedT ty) inner)) | ty == 'SchemaObject -> - pure . tagAs Imported . map (second pure) $ typeToSchemaPairs inner - _ -> fail $ "'" ++ show name ++ "' is not a SchemaObject" + schemaV <- reifySchema other + return (fromSchemaV schemaV, Imported) where - tagAs source = map $ \(k,v) -> (k,v,source) - schemaDefToSchemaKey = \case - SchemaDefObjKeyNormal key -> NormalKey key - SchemaDefObjKeyPhantom key -> PhantomKey key + -- should return true if it's at all possible to get a valid parse isValidPhantomSchema = \case - SchemaShow.SchemaTry _ -> True - SchemaShow.SchemaObject _ -> True - SchemaShow.SchemaUnion schemas -> all isValidPhantomSchema schemas + SchemaMaybe inner -> isValidPhantomSchema inner + SchemaTry _ -> True -- even if inner is a non-object schema, it'll still parse to be Nothing + SchemaUnion schemas -> any isValidPhantomSchema schemas + SchemaObject _ -> True _ -> False --- | Resolve the parts returned by 'toParts' as such: +-- | Resolve the given keys with the following rules: -- -- 1. Any explicitly provided keys shadow/overwrite imported keys -- 2. Fail if duplicate keys are both explicitly provided -- 3. Fail if duplicate keys are both imported -resolveParts :: [(SchemaKey, TypeQ, KeySource)] -> Q [(SchemaKey, TypeQ)] -resolveParts parts = do - resolved <- resolveParts' $ HashMap.fromListWith (++) $ map nameAndSource parts - return $ mapMaybe (alignWithResolved resolved) parts +resolveKeys :: Show a => LookupMap SchemaKeyV (KeySource, a) -> Either String (LookupMap SchemaKeyV a) +resolveKeys = mapM (uncurry resolveKey) . groupByKeyWith fromSchemaKeyV where - nameAndSource (name, _, source) = (fromSchemaKey name, [source]) - resolveParts' = HashMap.traverseWithKey $ \name sources -> do - -- invariant: length sources > 0 - let numOf source = length $ filter (== source) sources - case (numOf Provided, numOf Imported) of - (1, _) -> return Provided - (0, 1) -> return Imported - (x, _) | x > 1 -> fail $ "Key '" ++ name ++ "' specified multiple times" - (_, x) | x > 1 -> fail $ "Key '" ++ name ++ "' declared in multiple imported schemas" - _ -> fail "Broken invariant in resolveParts" - alignWithResolved resolved (key, ty, source) = - let resolvedSource = resolved HashMap.! fromSchemaKey key - in if resolvedSource == source - then Just (key, ty) - else Nothing + resolveKey key sourcesAndVals = + let filterSource source = map snd $ filter ((== source) . fst) sourcesAndVals + numProvided = length $ filterSource Provided + numImported = length $ filterSource Imported + in if + | numProvided > 1 -> Left $ "Key '" ++ fromSchemaKeyV key ++ "' specified multiple times" + | [val] <- filterSource Provided -> Right (key, val) + | numImported > 1 -> Left $ "Key '" ++ fromSchemaKeyV key ++ "' declared in multiple imported schemas" + | [val] <- filterSource Imported -> Right (key, val) + | otherwise -> unreachable $ "resolveKey received: " ++ show (key, sourcesAndVals) + +{- SchemaDef conversions -} + +fromSchemaDefKey :: SchemaDefObjKey -> SchemaKeyV +fromSchemaDefKey = \case + SchemaDefObjKeyNormal key -> NormalKey key + SchemaDefObjKeyPhantom key -> PhantomKey key + +fromSchemaDefType :: SchemaDef -> Q SchemaTypeV +fromSchemaDefType = \case + SchemaDefType name -> return $ SchemaScalar $ NameRef name + SchemaDefMaybe inner -> SchemaMaybe <$> fromSchemaDefType inner + SchemaDefTry inner -> SchemaTry <$> fromSchemaDefType inner + SchemaDefList inner -> SchemaList <$> fromSchemaDefType inner + SchemaDefInclude other -> toSchemaObjectV <$> reifySchema other + SchemaDefUnion schemas -> SchemaUnion . NonEmpty.toList <$> mapM fromSchemaDefType schemas + SchemaDefObj items -> SchemaObject <$> generateSchemaObjectV items + +{- LookupMap utilities -} + +type LookupMap k v = [(k, v)] + +-- | Distribute the given element across the values in the map. +distribute :: LookupMap k v -> a -> LookupMap k (a, v) +distribute lookupMap a = map (fmap (a,)) lookupMap + +-- | Find all values with the same key (according to the given function) and group them. +-- +-- Invariants: +-- * [v] has length > 0 +-- * If the first occurence of k1 is before the first occurence of k2, k1 is before k2 +-- in the result +groupByKeyWith :: (Eq a, Hashable a) => (k -> a) -> LookupMap k v -> LookupMap k [v] +groupByKeyWith f pairs = map (\key -> (key, groups HashMap.! f key)) distinctKeys + where + -- don't use sort; keys should stay in the same order + distinctKeys = nubBy ((==) `on` f) $ map fst pairs + + groups = HashMap.fromListWith (flip (++)) $ map (\(k, v) -> (f k, [v])) pairs diff --git a/src/Data/Aeson/Schema/TH/Unwrap.hs b/src/Data/Aeson/Schema/TH/Unwrap.hs --- a/src/Data/Aeson/Schema/TH/Unwrap.hs +++ b/src/Data/Aeson/Schema/TH/Unwrap.hs @@ -6,19 +6,37 @@ The 'unwrap' quasiquoter. -} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} module Data.Aeson.Schema.TH.Unwrap where import Control.Monad ((>=>)) +import Data.Bifunctor (first) +import qualified Data.List.NonEmpty as NonEmpty import Language.Haskell.TH import Language.Haskell.TH.Quote (QuasiQuoter(..)) -import Data.Aeson.Schema.TH.Parse (UnwrapSchema(..), parse, unwrapSchema) -import Data.Aeson.Schema.TH.Utils (reifySchema, unwrapType) +import Data.Aeson.Schema.Internal (Object, SchemaResult) +import Data.Aeson.Schema.Key (fromSchemaKeyV) +import Data.Aeson.Schema.TH.Parse + (GetterOperation(..), GetterOps, UnwrapSchema(..), parseUnwrapSchema) +import Data.Aeson.Schema.TH.Utils + (reifySchema, schemaTypeVToTypeQ, schemaVToTypeQ) +import Data.Aeson.Schema.Type + ( Schema'(..) + , SchemaType'(..) + , SchemaTypeV + , SchemaV + , showSchemaTypeV + , toSchemaObjectV + ) -- | Defines a QuasiQuoter to extract a schema within the given schema. -- +-- The base schema needs to be defined in a separate module. +-- -- For example: -- -- > -- | MyFoo ~ Object [schema| { b: Maybe Bool } |] @@ -50,14 +68,100 @@ unwrap = QuasiQuoter { quoteExp = error "Cannot use `unwrap` for Exp" , quoteDec = error "Cannot use `unwrap` for Dec" - , quoteType = parse unwrapSchema >=> generateUnwrapSchema + , quoteType = parseUnwrapSchema >=> generateUnwrapSchema , quotePat = error "Cannot use `unwrap` for Pat" } generateUnwrapSchema :: UnwrapSchema -> TypeQ -generateUnwrapSchema UnwrapSchema{..} = do - startSchemaName <- maybe unknownSchema return =<< lookupTypeName startSchema - startSchemaType <- reifySchema startSchemaName - unwrapType False getterOps startSchemaType +generateUnwrapSchema UnwrapSchema{..} = reifySchema startSchema >>= unwrapSchema getterOps + +-- | Unwrap the given schema by applying the given operations, stripping out functors. +unwrapSchema :: GetterOps -> SchemaV -> TypeQ +unwrapSchema = unwrapSchemaUsing StripFunctors + +-- | Unwrap the given schema by applying the given operations, using the given 'FunctorHandler'. +unwrapSchemaUsing :: FunctorHandler -> GetterOps -> SchemaV -> TypeQ +unwrapSchemaUsing functorHandler getterOps = either fail toResultTypeQ . flip go (NonEmpty.toList getterOps) . toSchemaObjectV where - unknownSchema = fail $ "Unknown schema: " ++ startSchema + toResultTypeQ :: UnwrapSchemaResult -> TypeQ + toResultTypeQ = \case + -- special case SchemaObject to make it further inspectable + SchemaResult (SchemaObject pairs) -> [t| Object $(schemaVToTypeQ (Schema pairs)) |] + SchemaResult schemaType -> [t| SchemaResult $(schemaTypeVToTypeQ schemaType) |] + SchemaResultList schemaResult -> appT listT (toResultTypeQ schemaResult) + SchemaResultTuple schemaResults -> foldl appT (tupleT $ length schemaResults) $ map toResultTypeQ schemaResults + SchemaResultWrapped functorTy schemaResult -> + let handleFunctor ty = + case functorHandler of + ApplyFunctors -> AppT functorTy ty + StripFunctors -> ty + in handleFunctor <$> toResultTypeQ schemaResult + + go :: SchemaTypeV -> [GetterOperation] -> Either String UnwrapSchemaResult + go schemaType [] = pure $ SchemaResult schemaType + go schemaType (op:ops) = + let invalid message = Left $ message ++ ": " ++ showSchemaTypeV schemaType + wrapMaybe = SchemaResultWrapped (ConT ''Maybe) + wrapList = SchemaResultWrapped ListT + in case op of + GetterKey key -> + case schemaType of + SchemaObject pairs -> + case lookup key $ map (first fromSchemaKeyV) pairs of + Just inner -> go inner ops + Nothing -> invalid $ "Key '" ++ key ++ "' does not exist in schema" + _ -> invalid $ "Cannot get key '" ++ key ++ "' in schema" + + GetterBang -> + case schemaType of + SchemaMaybe inner -> go inner ops + SchemaTry inner -> go inner ops + _ -> invalid "Cannot use `!` operator on schema" + + GetterMapMaybe -> + case schemaType of + SchemaMaybe inner -> wrapMaybe <$> go inner ops + SchemaTry inner -> wrapMaybe <$> go inner ops + _ -> invalid "Cannot use `?` operator on schema" + + GetterMapList -> + case schemaType of + SchemaList inner -> wrapList <$> go inner ops + _ -> invalid "Cannot use `[]` operator on schema" + + GetterBranch branch -> + case schemaType of + SchemaUnion schemas -> + if branch < length schemas + then go (schemas !! branch) ops + else invalid "Branch out of bounds for schema" + _ -> invalid "Cannot use `@` operator on schema" + + -- suffixes; ops should be empty + + GetterList elemOps -> + case schemaType of + SchemaObject _ -> do + elemSchemas <- traverse (go schemaType . NonEmpty.toList) elemOps + let elemSchema = NonEmpty.head elemSchemas + if all (== elemSchema) elemSchemas + then pure $ SchemaResultList elemSchema + else invalid "List contains different types in schema" + _ -> invalid "Cannot get keys in schema" + + GetterTuple elemOps -> + case schemaType of + SchemaObject _ -> SchemaResultTuple <$> mapM (go schemaType . NonEmpty.toList) (NonEmpty.toList elemOps) + _ -> invalid "Cannot get keys in schema" + +data UnwrapSchemaResult + = SchemaResult SchemaTypeV + | SchemaResultList UnwrapSchemaResult + | SchemaResultTuple [UnwrapSchemaResult] + | SchemaResultWrapped Type UnwrapSchemaResult -- ^ Type should be of kind `* -> *` + deriving (Eq) + +-- | A data type that indicates how to handle functors when unwrapping a schema. +data FunctorHandler + = ApplyFunctors -- ^ handleFunctor Maybe Int ==> Maybe Int + | StripFunctors -- ^ handleFunctor Maybe Int ==> Int diff --git a/src/Data/Aeson/Schema/TH/Utils.hs b/src/Data/Aeson/Schema/TH/Utils.hs --- a/src/Data/Aeson/Schema/TH/Utils.hs +++ b/src/Data/Aeson/Schema/TH/Utils.hs @@ -4,191 +4,219 @@ Stability : experimental Portability : portable -} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveLift #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} -module Data.Aeson.Schema.TH.Utils where +module Data.Aeson.Schema.TH.Utils + ( reifySchema + , reifySchemaName + , schemaVToTypeQ + , schemaTypeVToTypeQ + ) where -import Control.Monad ((>=>)) -import Data.Bifunctor (bimap, first, second) -import Data.List (intercalate) +import Control.Monad (forM, (>=>)) +import Data.Bifunctor (bimap) import Data.Text (Text) -import GHC.Stack (HasCallStack) import Language.Haskell.TH -import Language.Haskell.TH.Syntax (Lift) -import Data.Aeson.Schema.Internal (Object, SchemaResult, SchemaType(..)) -import qualified Data.Aeson.Schema.Internal as Internal -import Data.Aeson.Schema.Key (SchemaKey(..), fromSchemaKey) -import qualified Data.Aeson.Schema.Show as SchemaShow +import Data.Aeson.Schema.Internal (Object) +import Data.Aeson.Schema.Key (SchemaKey'(..), SchemaKeyV) +import Data.Aeson.Schema.Type + ( NameLike(..) + , Schema'(..) + , SchemaObjectMapV + , SchemaType'(..) + , SchemaTypeV + , SchemaV + , fromSchemaV + ) --- | Show the given schema as a type. -showSchemaType :: HasCallStack => Type -> String -showSchemaType = SchemaShow.showSchemaType . parseSchemaType +reifySchema :: String -> Q SchemaV +reifySchema name = lookupTypeName name >>= maybe unknownSchemaErr reifySchemaName + where + unknownSchemaErr = fail $ "Unknown schema: " ++ name -parseSchemaType :: HasCallStack => Type -> SchemaShow.SchemaType -parseSchemaType = \case - PromotedT name - | name == 'SchemaBool -> SchemaShow.SchemaBool - | name == 'SchemaInt -> SchemaShow.SchemaInt - | name == 'SchemaDouble -> SchemaShow.SchemaDouble - | name == 'SchemaText -> SchemaShow.SchemaText - AppT (PromotedT name) (ConT inner) - | name == 'SchemaCustom -> SchemaShow.SchemaCustom $ nameBase inner - AppT (PromotedT name) inner - | name == 'SchemaMaybe -> SchemaShow.SchemaMaybe $ parseSchemaType inner - | name == 'SchemaTry -> SchemaShow.SchemaTry $ parseSchemaType inner - | name == 'SchemaList -> SchemaShow.SchemaList $ parseSchemaType inner - | name == 'SchemaObject -> SchemaShow.SchemaObject $ fromPairs inner - | name == 'SchemaUnion -> SchemaShow.SchemaUnion $ map parseSchemaType $ typeToList inner - ty -> error $ "Unknown type: " ++ show ty +reifySchemaName :: Name -> Q SchemaV +reifySchemaName = reifySchemaType >=> parseSchema where - fromPairs pairs = map (second parseSchemaType) $ typeToSchemaPairs pairs + reifySchemaType :: Name -> Q TypeWithoutKinds + reifySchemaType schemaName = reify schemaName >>= \case + TyConI (TySynD _ _ (stripKinds -> ty)) + -- `type MySchema = 'Schema '[ ... ]` + | isPromotedSchema ty + -> return ty -typeToList :: HasCallStack => Type -> [Type] -typeToList = \case - PromotedNilT -> [] - AppT (AppT PromotedConsT x) xs -> x : typeToList xs - SigT ty _ -> typeToList ty - ty -> error $ "Not a type-level list: " ++ show ty + -- `type MySchema = Object ('Schema '[ ... ])` + | Just inner <- unwrapObject ty + , isPromotedSchema inner + -> return inner -typeToPair :: HasCallStack => Type -> (Type, Type) -typeToPair = \case - AppT (AppT (PromotedTupleT 2) a) b -> (a, b) - SigT ty _ -> typeToPair ty - ty -> error $ "Not a type-level pair: " ++ show ty + -- `type MySchema = Object OtherSchema` + | Just (ConT schemaName') <- unwrapObject ty + -> reifySchemaType schemaName' -typeToSchemaPairs :: HasCallStack => Type -> [(SchemaKey, Type)] -typeToSchemaPairs = map (bimap parseSchemaKey stripSigs . typeToPair) . typeToList + _ -> fail $ "'" ++ show schemaName ++ "' is not a Schema" -typeQListToTypeQ :: [TypeQ] -> TypeQ -typeQListToTypeQ = foldr consT promotedNilT - where - -- nb. https://stackoverflow.com/a/34457936 - consT x xs = appT (appT promotedConsT x) xs + -- If the given type is of the format `Object a`, return `a`. + unwrapObject :: TypeWithoutKinds -> Maybe TypeWithoutKinds + unwrapObject = \case + AppT (ConT name) inner | name == ''Object -> Just inner + _ -> Nothing -schemaPairsToTypeQ :: [(SchemaKey, TypeQ)] -> TypeQ -schemaPairsToTypeQ = typeQListToTypeQ . map pairT + -- Return True if the given type is of the format: 'Schema '[ ... ] + isPromotedSchema :: TypeWithoutKinds -> Bool + isPromotedSchema = \case + AppT (PromotedT name) _ | name == 'Schema -> True + _ -> False + + parseSchema :: TypeWithoutKinds -> Q SchemaV + parseSchema ty = maybe (fail $ "Could not parse schema: " ++ show ty) return $ do + schemaObjectType <- case ty of + AppT (PromotedT name) schemaType | name == 'Schema -> Just schemaType + _ -> Nothing + + Schema <$> parseSchemaObjectType schemaObjectType + + parseSchemaObjectType :: TypeWithoutKinds -> Maybe SchemaObjectMapV + parseSchemaObjectType schemaObjectType = do + schemaObjectListOfPairs <- mapM typeToPair =<< typeToList schemaObjectType + forM schemaObjectListOfPairs $ \(schemaKeyType, schemaTypeType) -> do + schemaKey <- parseSchemaKey schemaKeyType + schemaType <- parseSchemaType schemaTypeType + Just (schemaKey, schemaType) + + parseSchemaKey :: TypeWithoutKinds -> Maybe SchemaKeyV + parseSchemaKey = \case + AppT (PromotedT ty) (LitT (StrTyLit key)) + | ty == 'NormalKey -> Just $ NormalKey key + | ty == 'PhantomKey -> Just $ PhantomKey key + _ -> Nothing + + parseSchemaType :: TypeWithoutKinds -> Maybe SchemaTypeV + parseSchemaType = \case + AppT (PromotedT name) (ConT inner) + | name == 'SchemaScalar -> Just $ SchemaScalar $ NameTH inner + + AppT (PromotedT name) inner + | name == 'SchemaMaybe -> SchemaMaybe <$> parseSchemaType inner + + | name == 'SchemaTry -> SchemaTry <$> parseSchemaType inner + + | name == 'SchemaList -> SchemaList <$> parseSchemaType inner + + | name == 'SchemaUnion -> do + schemas <- typeToList inner + SchemaUnion <$> mapM parseSchemaType schemas + + | name == 'SchemaObject -> SchemaObject <$> parseSchemaObjectType inner + + _ -> Nothing + +schemaVToTypeQ :: SchemaV -> TypeQ +schemaVToTypeQ = appT [t| 'Schema |] . schemaObjectMapVToTypeQ . fromSchemaV + +schemaObjectMapVToTypeQ :: SchemaObjectMapV -> TypeQ +schemaObjectMapVToTypeQ = promotedListT . map schemaObjectPairVToTypeQ where - pairT (k, v) = - let schemaKey = case k of - NormalKey key -> [t| 'Internal.NormalKey $(litT $ strTyLit key) |] - PhantomKey key -> [t| 'Internal.PhantomKey $(litT $ strTyLit key) |] - in [t| '($schemaKey, $v) |] + schemaObjectPairVToTypeQ :: (SchemaKeyV, SchemaTypeV) -> TypeQ + schemaObjectPairVToTypeQ = promotedPairT . bimap schemaKeyVToTypeQ schemaTypeVToTypeQ -parseSchemaKey :: HasCallStack => Type -> SchemaKey -parseSchemaKey = \case - AppT (PromotedT ty) (LitT (StrTyLit key)) - | ty == 'Internal.NormalKey -> NormalKey key - | ty == 'Internal.PhantomKey -> PhantomKey key - SigT ty _ -> parseSchemaKey ty - ty -> error $ "Could not parse a schema key: " ++ show ty + schemaKeyVToTypeQ :: SchemaKeyV -> TypeQ + schemaKeyVToTypeQ = \case + NormalKey key -> [t| 'NormalKey $(litT $ strTyLit key) |] + PhantomKey key -> [t| 'PhantomKey $(litT $ strTyLit key) |] --- | Strip all kind signatures from the given type. -stripSigs :: Type -> Type -stripSigs = \case - ForallT tyVars ctx ty -> ForallT tyVars ctx (stripSigs ty) - AppT ty1 ty2 -> AppT (stripSigs ty1) (stripSigs ty2) - SigT ty _ -> stripSigs ty - InfixT ty1 name ty2 -> InfixT (stripSigs ty1) name (stripSigs ty2) - UInfixT ty1 name ty2 -> UInfixT (stripSigs ty1) name (stripSigs ty2) - ParensT ty -> ParensT (stripSigs ty) - ty -> ty +schemaTypeVToTypeQ :: SchemaTypeV -> TypeQ +schemaTypeVToTypeQ = \case + SchemaScalar name -> [t| 'SchemaScalar $(resolveName name >>= conT) |] + SchemaMaybe inner -> [t| 'SchemaMaybe $(schemaTypeVToTypeQ inner) |] + SchemaTry inner -> [t| 'SchemaTry $(schemaTypeVToTypeQ inner) |] + SchemaList inner -> [t| 'SchemaList $(schemaTypeVToTypeQ inner) |] + SchemaUnion schemas -> [t| 'SchemaUnion $(promotedListT $ map schemaTypeVToTypeQ schemas) |] + SchemaObject pairs -> [t| 'SchemaObject $(schemaObjectMapVToTypeQ pairs) |] -reifySchema :: Name -> TypeQ -reifySchema = reify >=> \case - TyConI (TySynD _ _ ty) -> pure $ stripSigs ty - info -> fail $ "Unknown reified schema: " ++ show info +resolveName :: NameLike -> Q Name +resolveName = \case + -- some hardcoded cases + NameRef "Bool" -> pure ''Bool + NameRef "Int" -> pure ''Int + NameRef "Double" -> pure ''Double + NameRef "Text" -> pure ''Text --- | Unwrap the given type using the given getter operations. + -- general cases + NameRef name -> lookupTypeName name >>= maybe (fail $ "Unknown type: " ++ name) pure + NameTH name -> pure name + +{- TH utilities -} + +-- | Same as 'Type' except without any kind signatures or applications at any depth. -- --- Accepts Bool for whether to maintain functor structure (True) or strip away functor applications --- (False). -unwrapType :: Bool -> GetterOps -> Type -> TypeQ -unwrapType _ [] = fromSchemaType - where - fromSchemaType schema = case schema of - AppT (PromotedT ty) inner - | ty == 'SchemaCustom -> [t| SchemaResult $(pure schema) |] - | ty == 'SchemaMaybe -> [t| Maybe $(fromSchemaType inner) |] - | ty == 'SchemaTry -> [t| Maybe $(fromSchemaType inner) |] - | ty == 'SchemaList -> [t| [$(fromSchemaType inner)] |] - | ty == 'SchemaObject -> [t| Object $(pure schema) |] - | ty == 'SchemaUnion -> [t| SchemaResult $(pure schema) |] - PromotedT ty - | ty == 'SchemaBool -> [t| Bool |] - | ty == 'SchemaInt -> [t| Int |] - | ty == 'SchemaDouble -> [t| Double |] - | ty == 'SchemaText -> [t| Text |] - AppT t1 t2 -> appT (fromSchemaType t1) (fromSchemaType t2) - TupleT _ -> pure schema - _ -> fail $ "Could not convert schema: " ++ showSchemaType schema -unwrapType keepFunctor (op:ops) = \case - schema@(AppT (PromotedT ty) inner) -> - case op of - GetterKey key | ty == 'SchemaObject -> - case lookup key (getObjectSchema inner) of - Just schema' -> unwrapType' ops schema' - Nothing -> fail $ "Key '" ++ key ++ "' does not exist in schema: " ++ showSchemaType schema - GetterKey key -> fail $ "Cannot get key '" ++ key ++ "' in schema: " ++ showSchemaType schema - GetterList elems | ty == 'SchemaObject -> do - (elem':rest) <- mapM (`unwrapType'` schema) elems - if all (== elem') rest - then unwrapType' ops elem' - else fail $ "List contains different types with schema: " ++ showSchemaType schema - GetterList _ -> fail $ "Cannot get keys in schema: " ++ showSchemaType schema - GetterTuple elems | ty == 'SchemaObject -> - foldl appT (tupleT $ length elems) $ map (`unwrapType'` schema) elems - GetterTuple _ -> fail $ "Cannot get keys in schema: " ++ showSchemaType schema - GetterBang | ty == 'SchemaMaybe -> unwrapType' ops inner - GetterBang | ty == 'SchemaTry -> unwrapType' ops inner - GetterBang -> fail $ "Cannot use `!` operator on schema: " ++ showSchemaType schema - GetterMapMaybe | ty == 'SchemaMaybe -> withFunctor [t| Maybe |] $ unwrapType' ops inner - GetterMapMaybe | ty == 'SchemaTry -> withFunctor [t| Maybe |] $ unwrapType' ops inner - GetterMapMaybe -> fail $ "Cannot use `?` operator on schema: " ++ showSchemaType schema - GetterMapList | ty == 'SchemaList -> withFunctor (pure ListT) $ unwrapType' ops inner - GetterMapList -> fail $ "Cannot use `[]` operator on schema: " ++ showSchemaType schema - GetterBranch branch | ty == 'SchemaUnion -> - let subTypes = typeToList inner - in if branch >= length subTypes - then fail $ "Branch out of bounds for schema: " ++ showSchemaType schema - else unwrapType' ops $ subTypes !! branch - GetterBranch _ -> fail $ "Cannot use `@` operator on schema: " ++ showSchemaType schema - -- allow starting from (Object schema) - AppT (ConT ty) inner | ty == ''Object -> unwrapType' (op:ops) inner - schema -> fail $ unlines ["Cannot get type:", show schema, show op] - where - unwrapType' = unwrapType keepFunctor - getObjectSchema = map (first getSchemaKey . typeToPair) . typeToList - getSchemaKey = fromSchemaKey . parseSchemaKey - withFunctor f = if keepFunctor then appT f else id +-- Provides no actual guarantees. The caller is responsible for making sure the value +-- has been run through 'stripKinds' at one point. +type TypeWithoutKinds = Type -{- GetterOps -} +-- | Recursively strip all kind signatures and applications. +stripKinds :: Type -> TypeWithoutKinds +stripKinds ty = + case ty of + -- cases that strip + recurse + SigT ty1 _ -> stripKinds ty1 +#if MIN_VERSION_template_haskell(2,15,0) + AppKindT ty1 _ -> stripKinds ty1 +#endif -type GetterOps = [GetterOperation] + -- cases that recurse + ForallT tyVars ctx ty1 -> ForallT tyVars ctx (stripKinds ty1) +#if MIN_VERSION_template_haskell(2,16,0) + ForallVisT tyVars ty1 -> ForallVisT tyVars (stripKinds ty1) +#endif + AppT ty1 ty2 -> AppT (stripKinds ty1) (stripKinds ty2) + InfixT ty1 name ty2 -> InfixT (stripKinds ty1) name (stripKinds ty2) + UInfixT ty1 name ty2 -> UInfixT (stripKinds ty1) name (stripKinds ty2) + ParensT ty1 -> ParensT (stripKinds ty1) +#if MIN_VERSION_template_haskell(2,15,0) + ImplicitParamT str ty1 -> ImplicitParamT str (stripKinds ty1) +#endif -data GetterOperation - = GetterKey String - | GetterList [GetterOps] - | GetterTuple [GetterOps] - | GetterBang - | GetterMapList - | GetterMapMaybe - | GetterBranch Int - deriving (Show,Lift) + -- base cases + VarT _ -> ty + ConT _ -> ty + PromotedT _ -> ty + TupleT _ -> ty + UnboxedTupleT _ -> ty + UnboxedSumT _ -> ty + ArrowT -> ty + EqualityT -> ty + ListT -> ty + PromotedTupleT _ -> ty + PromotedNilT -> ty + PromotedConsT -> ty + StarT -> ty + ConstraintT -> ty + LitT _ -> ty + WildCardT -> ty -showGetterOps :: GetterOps -> String -showGetterOps = concatMap showGetterOp +typeToList :: TypeWithoutKinds -> Maybe [TypeWithoutKinds] +typeToList = \case + PromotedNilT -> Just [] + AppT (AppT PromotedConsT x) xs -> (x:) <$> typeToList xs + _ -> Nothing + +typeToPair :: TypeWithoutKinds -> Maybe (TypeWithoutKinds, TypeWithoutKinds) +typeToPair = \case + AppT (AppT (PromotedTupleT 2) a) b -> Just (a, b) + _ -> Nothing + +promotedListT :: [TypeQ] -> TypeQ +promotedListT = foldr consT promotedNilT where - showGetterOp = \case - GetterKey key -> '.':key - GetterList elems -> ".[" ++ intercalate "," (map showGetterOps elems) ++ "]" - GetterTuple elems -> ".(" ++ intercalate "," (map showGetterOps elems) ++ ")" - GetterBang -> "!" - GetterMapList -> "[]" - GetterMapMaybe -> "?" - GetterBranch x -> '@' : show x + -- nb. https://stackoverflow.com/a/34457936 + consT x xs = appT (appT promotedConsT x) xs + +promotedPairT :: (TypeQ, TypeQ) -> TypeQ +promotedPairT (a, b) = [t| '( $a, $b ) |] diff --git a/src/Data/Aeson/Schema/Type.hs b/src/Data/Aeson/Schema/Type.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Schema/Type.hs @@ -0,0 +1,159 @@ +{-| +Module : Data.Aeson.Schema.Type +Maintainer : Brandon Chinn +Stability : experimental +Portability : portable + +Defines SchemaType, the AST that defines a JSON schema. +-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} + +module Data.Aeson.Schema.Type + ( Schema'(..) + , SchemaType'(..) + , SchemaV + , SchemaTypeV + , SchemaObjectMapV + , NameLike(..) + , toSchemaObjectV + , fromSchemaV + , showSchemaV + , showSchemaTypeV + , Schema + , SchemaType + , ToSchemaObject + , FromSchema + , IsSchemaType(..) + , IsSchemaObjectMap + ) where + +import Data.Kind (Type) +import Data.List (intercalate) +import Data.Proxy (Proxy(..)) +import Data.Typeable (Typeable, tyConName, typeRep, typeRepTyCon) +import GHC.TypeLits (Symbol) +import Language.Haskell.TH.Syntax (Lift, Name, nameBase) + +import Data.Aeson.Schema.Key + (IsSchemaKey(..), SchemaKey, SchemaKey', SchemaKeyV, showSchemaKeyV) +import Data.Aeson.Schema.Utils.All (All(..)) + +-- | The schema definition for a JSON object. +data Schema' s ty = Schema (SchemaObjectMap' s ty) + deriving (Show, Eq, Lift) + +-- | The AST defining a JSON schema. +data SchemaType' s ty + = SchemaScalar ty + | SchemaMaybe (SchemaType' s ty) + | SchemaTry (SchemaType' s ty) -- ^ @since v1.2.0 + | SchemaList (SchemaType' s ty) + | SchemaUnion [SchemaType' s ty] -- ^ @since v1.1.0 + | SchemaObject (SchemaObjectMap' s ty) + deriving (Show, Eq, Lift) + +type SchemaObjectMap' s ty = [(SchemaKey' s, SchemaType' s ty)] + +data NameLike = NameRef String | NameTH Name + +instance Eq NameLike where + ty1 == ty2 = show ty1 == show ty2 + +instance Show NameLike where + show (NameRef ty) = ty + show (NameTH ty) = nameBase ty + +{- Value-level schema types -} + +type SchemaV = Schema' String NameLike +type SchemaTypeV = SchemaType' String NameLike +type SchemaObjectMapV = SchemaObjectMap' String NameLike + +toSchemaObjectV :: SchemaV -> SchemaTypeV +toSchemaObjectV (Schema schema) = SchemaObject schema + +fromSchemaV :: SchemaV -> SchemaObjectMapV +fromSchemaV (Schema schema) = schema + +-- | Show the given schema, as "{ key: Schema, ... }" +showSchemaV :: SchemaV -> String +showSchemaV = showSchemaTypeV' . toSchemaObjectV + +-- | Pretty show the given SchemaType. +showSchemaTypeV :: SchemaTypeV -> String +showSchemaTypeV schema = case schema of + SchemaScalar _ -> "SchemaScalar " ++ showSchemaTypeV' schema + SchemaMaybe inner -> "SchemaMaybe " ++ showSchemaTypeV' inner + SchemaTry inner -> "SchemaTry " ++ showSchemaTypeV' inner + SchemaList inner -> "SchemaList " ++ showSchemaTypeV' inner + SchemaUnion _ -> "SchemaUnion " ++ showSchemaTypeV' schema + SchemaObject _ -> "SchemaObject " ++ showSchemaTypeV' schema + +showSchemaTypeV' :: SchemaTypeV -> String +showSchemaTypeV' = \case + SchemaScalar ty -> show ty + SchemaMaybe inner -> "Maybe " ++ showSchemaTypeV' inner + SchemaTry inner -> "Try " ++ showSchemaTypeV' inner + SchemaList inner -> "List " ++ showSchemaTypeV' inner + SchemaUnion schemas -> "( " ++ mapJoin showSchemaTypeV' " | " schemas ++ " )" + SchemaObject pairs -> "{ " ++ mapJoin showPair ", " pairs ++ " }" + where + showPair (key, inner) = showSchemaKeyV key ++ ": " ++ showSchemaTypeV' inner + + mapJoin f delim = intercalate delim . map f + +{- Type-level schema types -} + +-- | The kind of schemas that may be used with Object; e.g. +-- +-- > data Payload (schema :: Schema) = Payload +-- > { getPayload :: Object schema +-- > , timestamp :: UTCTime +-- > } +type Schema = Schema' Symbol Type + +type SchemaType = SchemaType' Symbol Type + +type SchemaObjectMap = SchemaObjectMap' Symbol Type + +type family ToSchemaObject (schema :: Schema) :: SchemaType where + ToSchemaObject ('Schema schema) = 'SchemaObject schema + +type family FromSchema (schema :: Schema) :: SchemaObjectMap where + FromSchema ('Schema schema) = schema + +class IsSchemaType (schemaType :: SchemaType) where + toSchemaTypeV :: Proxy schemaType -> SchemaTypeV + +instance Typeable inner => IsSchemaType ('SchemaScalar inner) where + toSchemaTypeV _ = SchemaScalar (NameRef $ tyConName $ typeRepTyCon $ typeRep $ Proxy @inner) + +instance IsSchemaType inner => IsSchemaType ('SchemaMaybe inner) where + toSchemaTypeV _ = SchemaMaybe (toSchemaTypeV $ Proxy @inner) + +instance IsSchemaType inner => IsSchemaType ('SchemaTry inner) where + toSchemaTypeV _ = SchemaTry (toSchemaTypeV $ Proxy @inner) + +instance IsSchemaType inner => IsSchemaType ('SchemaList inner) where + toSchemaTypeV _ = SchemaList (toSchemaTypeV $ Proxy @inner) + +instance All IsSchemaType schemas => IsSchemaType ('SchemaUnion schemas) where + toSchemaTypeV _ = SchemaUnion (mapAll @IsSchemaType @schemas toSchemaTypeV) + +instance IsSchemaObjectMap pairs => IsSchemaType ('SchemaObject pairs) where + toSchemaTypeV _ = SchemaObject (mapAll @IsSchemaObjectPair @pairs toSchemaTypePairV) + +type IsSchemaObjectMap (pairs :: SchemaObjectMap) = All IsSchemaObjectPair pairs + +class IsSchemaObjectPair (a :: (SchemaKey, SchemaType)) where + toSchemaTypePairV :: Proxy a -> (SchemaKeyV, SchemaTypeV) + +instance (IsSchemaKey key, IsSchemaType inner) => IsSchemaObjectPair '(key, inner) where + toSchemaTypePairV _ = (toSchemaKeyV $ Proxy @key, toSchemaTypeV $ Proxy @inner) diff --git a/src/Data/Aeson/Schema/Utils/All.hs b/src/Data/Aeson/Schema/Utils/All.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Schema/Utils/All.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Aeson.Schema.Utils.All + ( All(..) + ) where + +import Data.Proxy (Proxy(..)) + +-- | A type family for traversing a type-level list. +class All f xs where + mapAll :: forall a. (forall x. f x => Proxy x -> a) -> [a] + mapAll f = foldrAll @f @xs f' [] + where + f' :: forall x. f x => Proxy x -> [a] -> [a] + f' proxy acc = f proxy : acc + + foldrAll :: (forall x. f x => Proxy x -> a -> a) -> a -> a + +instance All f '[] where + foldrAll _ acc = acc + +instance (f x, All f xs) => All f (x ': xs) where + foldrAll f acc = f (Proxy @x) (foldrAll @f @xs f acc) diff --git a/src/Data/Aeson/Schema/Utils/Invariant.hs b/src/Data/Aeson/Schema/Utils/Invariant.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Schema/Utils/Invariant.hs @@ -0,0 +1,11 @@ +module Data.Aeson.Schema.Utils.Invariant + ( unreachable + ) where + +-- | An error function to indicate that a branch is unreachable. Provides a useful error message +-- if it ends up happening, pointing users to write a bug report. +unreachable :: String -> a +unreachable msg = error $ unlines + [ "`aeson-schemas` internal error: " ++ msg + , "Please file a bug report at https://github.com/LeapYear/aeson-schemas/issues/" + ] diff --git a/src/Data/Aeson/Schema/Utils/Sum.hs b/src/Data/Aeson/Schema/Utils/Sum.hs --- a/src/Data/Aeson/Schema/Utils/Sum.hs +++ b/src/Data/Aeson/Schema/Utils/Sum.hs @@ -8,11 +8,10 @@ specified in a type-level list. -} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} @@ -29,7 +28,7 @@ ) where import Control.Applicative ((<|>)) -import Data.Aeson (FromJSON(..)) +import Data.Aeson (FromJSON(..), ToJSON(..)) import Data.Kind (Constraint, Type) import Data.Proxy (Proxy(..)) import GHC.TypeLits (type (-), ErrorMessage(..), Nat, TypeError) @@ -63,21 +62,29 @@ deriving instance (Show x, Show (SumType xs)) => Show (SumType (x ': xs)) instance Show (SumType '[]) where - show = error "impossible" + show = \case {} deriving instance (Eq x, Eq (SumType xs)) => Eq (SumType (x ': xs)) instance Eq (SumType '[]) where - (==) = error "impossible" + _ == _ = True deriving instance (Ord x, Ord (SumType xs)) => Ord (SumType (x ': xs)) instance Ord (SumType '[]) where - compare = error "impossible" + compare _ _ = EQ instance (FromJSON x, FromJSON (SumType xs)) => FromJSON (SumType (x ': xs)) where parseJSON v = (Here <$> parseJSON v) <|> (There <$> parseJSON v) instance FromJSON (SumType '[]) where parseJSON _ = fail "Could not parse sum type" + +instance (ToJSON x, ToJSON (SumType xs)) => ToJSON (SumType (x ': xs)) where + toJSON = \case + Here x -> toJSON x + There xs -> toJSON xs + +instance ToJSON (SumType '[]) where + toJSON = \case {} {- Extracting sum type branches -} diff --git a/src/Data/Aeson/Schema/Utils/TypeFamilies.hs b/src/Data/Aeson/Schema/Utils/TypeFamilies.hs deleted file mode 100644 --- a/src/Data/Aeson/Schema/Utils/TypeFamilies.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-| -Module : Data.Aeson.Schema.Utils.TypeFamilies -Maintainer : Brandon Chinn -Stability : experimental -Portability : portable - -Utilities for working with type families. --} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -module Data.Aeson.Schema.Utils.TypeFamilies - ( All - ) where - -import Data.Kind (Constraint) - -type family All (f :: a -> Constraint) (xs :: [a]) :: Constraint where - All _ '[] = () - All f (x ': xs) = (f x, All f xs) diff --git a/test/AllTypes.hs b/test/AllTypes.hs deleted file mode 100644 --- a/test/AllTypes.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} - -module AllTypes where - -import Data.Aeson (FromJSON(..), withText) -import Data.Aeson.Schema -import Data.Aeson.Schema.TH (mkEnum) -import qualified Data.Text as Text - -import Util (getMockedResult) - -{- Greeting enum -} - -mkEnum "Greeting" ["HELLO", "GOODBYE"] - -{- Coordinate scalar -} - -newtype Coordinate = Coordinate (Int, Int) - deriving (Show) - -instance FromJSON Coordinate where - parseJSON = withText "Coordinate" $ \s -> - case map (read . Text.unpack) $ Text.splitOn "," s of - [x, y] -> return $ Coordinate (x, y) - _ -> fail $ "Bad Coordinate: " ++ Text.unpack s - -{- AllTypes result -} - -type Schema = [schema| - { - bool: Bool, - int: Int, - int2: Int, - double: Double, - text: Text, - scalar: Coordinate, - enum: Greeting, - maybeObject: Maybe { - text: Text, - }, - maybeObjectNull: Maybe { - text: Text, - }, - tryObject: Try { - a: Int, - }, - tryObjectNull: Try { - a: Int, - }, - maybeList: Maybe List { - text: Text, - }, - maybeListNull: Maybe List { - text: Text, - }, - // this is a comment - list: List { - type: Text, - maybeBool: Maybe Bool, - maybeInt: Maybe Int, - maybeNull: Maybe Bool, - }, - nonexistent: Maybe Text, - // future_key: Int, - union: List ( - { a: Int } | List Bool | Text - ), - [phantom]: { - keyForPhantom: Int, - }, - } -|] - -result :: Object Schema -result = $(getMockedResult "test/all_types.json") - -{- AllTypes getters -} - -mkGetter "ListItem" "getList" ''AllTypes.Schema ".list[]" diff --git a/test/Enums.hs b/test/Enums.hs deleted file mode 100644 --- a/test/Enums.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module Enums (State(..), Color(..)) where - -import Data.Aeson.Schema.TH (genFromJSONEnum, genToJSONEnum, mkEnum) - -mkEnum "State" ["OPEN", "CLOSED"] - -data Color = Red | LightBlue | Yellow | DarkGreen | Black | JustABitOffWhite - deriving (Show, Eq, Enum) - -genFromJSONEnum ''Color -genToJSONEnum ''Color diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,301 +1,20 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - -import Data.Aeson (ToJSON, decode, eitherDecode, encode) -import Data.Aeson.Schema (Object, get, unwrap) -import Data.Aeson.Schema.Utils.Sum (SumType(..), fromSumType) -import qualified Data.ByteString.Lazy.Char8 as ByteString -import Data.Char (toLower, toUpper) -import Data.Maybe (fromMaybe) -import Data.Proxy (Proxy(..)) -import qualified Data.Text as Text -import Language.Haskell.TH.TestUtils (tryQErr') -import Test.Tasty (TestTree, defaultMain, testGroup) -import Test.Tasty.Golden (goldenVsString) -import Test.Tasty.HUnit (testCase, (@?=)) -import Test.Tasty.QuickCheck - (arbitrary, elements, infiniteListOf, oneof, testProperty, (===)) -import Text.RawString.QQ (r) - -import qualified AllTypes -import Enums -import qualified Nested -import Schema -import SumType -import Util +import Test.Tasty (defaultMain, testGroup) -allTypes :: Object AllTypes.Schema -allTypes = AllTypes.result +import qualified Tests.EnumTH +import qualified Tests.GetQQ +import qualified Tests.MkGetter +import qualified Tests.Object +import qualified Tests.SchemaQQ +import qualified Tests.SumType +import qualified Tests.UnwrapQQ main :: IO () main = defaultMain $ testGroup "aeson-schemas" - [ testGetterExp - , testFromObjectAllTypes - , testFromObjectNested - , testFromObjectNamespaced - , testUnwrapSchema - , testSchemaDef - , testMkGetter - , testEnumTH - , testSumType - ] - -goldens' :: String -> String -> TestTree -goldens' name = goldenVsString name fp . pure . ByteString.pack - where - fp = "test/goldens/" ++ name ++ ".golden" - -goldens :: Show s => String -> s -> TestTree -goldens name = goldens' name . show - -testGetterExp :: TestTree -testGetterExp = testGroup "Test getter expressions" - [ goldens "bool" [get| allTypes.bool |] - , goldens "lambda_bool" ([get| .bool |] allTypes) - , goldens "int" [get| allTypes.int |] - , goldens "int_int2" [get| allTypes.[int,int2] |] - , goldens "double" [get| allTypes.double |] - , goldens "bool_int_double" [get| allTypes.(bool,int,double) |] - , goldens "text" [get| allTypes.text |] - , goldens "scalar" [get| allTypes.scalar |] - , goldens "enum" [get| allTypes.enum |] - , goldens "maybeObj" [get| allTypes.maybeObject |] - , goldens "maybeObj_bang" [get| allTypes.maybeObject! |] - , goldens "maybeObj_text" [get| allTypes.maybeObject?.text |] - , goldens "maybeObj_bang_text" [get| allTypes.maybeObject!.text |] - , goldens "maybeObjNull" [get| allTypes.maybeObjectNull |] - , goldens "maybeObjNull_text" [get| allTypes.maybeObjectNull?.text |] - , goldens "tryObj" [get| allTypes.tryObject |] - , goldens "tryObjNull" [get| allTypes.tryObjectNull |] - , goldens "tryObj_bang" [get| allTypes.tryObject! |] - , goldens "tryObj_a" [get| allTypes.tryObject?.a |] - , goldens "tryObj_bang_a" [get| allTypes.tryObject!.a |] - , goldens "tryObjNull_a" [get| allTypes.tryObjectNull?.a |] - , goldens "maybeList" [get| allTypes.maybeList |] - , goldens "maybeList_bang" [get| allTypes.maybeList! |] - , goldens "maybeList_bang_list" [get| allTypes.maybeList![] |] - , goldens "maybeList_bang_list_text" [get| allTypes.maybeList![].text |] - , goldens "maybeList_list" [get| allTypes.maybeList?[] |] - , goldens "maybeList_list_text" [get| allTypes.maybeList?[].text |] - , goldens "maybeListNull" [get| allTypes.maybeListNull |] - , goldens "maybeListNull_list" [get| allTypes.maybeListNull?[] |] - , goldens "maybeListNull_list_text" [get| allTypes.maybeListNull?[].text |] - , goldens "list" [get| allTypes.list |] - , goldens "list_explicit" [get| allTypes.list[] |] - , goldens "list_type" [get| allTypes.list[].type |] - , goldens "list_maybeBool" [get| allTypes.list[].maybeBool |] - , goldens "list_maybeInt" [get| allTypes.list[].maybeInt |] - , goldens "nonexistent" [get| allTypes.nonexistent |] - , goldens "union" [get| allTypes.union |] - , goldens "union_0" [get| allTypes.union[]@0 |] - , goldens "union_0_a" [get| allTypes.union[]@0?.a |] - , goldens "union_1" [get| allTypes.union[]@1 |] - , goldens "union_2" [get| allTypes.union[]@2 |] - , goldens "phantom" [get| allTypes.phantom.keyForPhantom |] - -- bad 'get' expressions - , goldens' "maybeListNull_bang" $(getError [get| (AllTypes.result).maybeListNull! |]) -#if MIN_VERSION_megaparsec(7,0,0) - , goldens' "get_empty" $(tryQErr' $ showGet "") - , goldens' "get_just_start" $(tryQErr' $ showGet "allTypes") -#endif - , goldens' "get_ops_after_tuple" $(tryQErr' $ showGet "allTypes.(bool,int).foo") - , goldens' "get_ops_after_list" $(tryQErr' $ showGet "allTypes.[int,int2].foo") - ] - -testFromObjectAllTypes :: TestTree -testFromObjectAllTypes = - goldens "from_object_all_types" $ map fromObj [get| allTypes.list |] - where - fromObj o = case Text.unpack [get| o.type |] of - "bool" -> show [get| o.maybeBool! |] - "int" -> show [get| o.maybeInt! |] - "null" -> show [get| o.maybeNull |] - _ -> error "unreachable" - -testFromObjectNested :: TestTree -testFromObjectNested = goldens "from_object_nested" $ map fromObj [get| (Nested.result).list |] - where - fromObj obj = case [get| obj.a |] of - Just field -> [get| field.b |] - Nothing -> [get| obj.b |] - -testFromObjectNamespaced :: TestTree -testFromObjectNamespaced = goldens "from_object_namespaced" $ - map fromAllTypes [get| allTypes.list |] - ++ map fromNested [get| (Nested.result).list |] - where - fromAllTypes o = Text.unpack [get| o.type |] - fromNested o = show [get| o.b |] - -type NestedObject = [unwrap| (Nested.Schema).list[] |] - -parseNestedObject :: NestedObject -> Int -parseNestedObject obj = fromMaybe [get| obj.b |] [get| obj.a?.b |] - -nestedList :: [NestedObject] -nestedList = [get| (Nested.result).list[] |] - -testUnwrapSchema :: TestTree -testUnwrapSchema = testGroup "Test unwrapping schemas" - [ goldens' "unwrap_schema" $(showUnwrap "(Nested.Schema).list[]") - , goldens "unwrap_schema_nested_list" nestedList - , goldens "unwrap_schema_nested_object" $ map parseNestedObject nestedList - -- bad unwrap types - , goldens' "unwrap_schema_bad_bang" $(tryQErr' $ showUnwrap "(AllTypes.Schema).list[]!") - , goldens' "unwrap_schema_bad_question" $(tryQErr' $ showUnwrap "(AllTypes.Schema).list[]?") - , goldens' "unwrap_schema_bad_list" $(tryQErr' $ showUnwrap "(AllTypes.Schema).list[][]") - , goldens' "unwrap_schema_bad_key" $(tryQErr' $ showUnwrap "(AllTypes.Schema).list.a") - , goldens' "unwrap_schema_bad_branch" $(tryQErr' $ showUnwrap "(AllTypes.Schema).list@0") - , goldens' "unwrap_schema_branch_out_of_bounds" $(tryQErr' $ showUnwrap "(AllTypes.Schema).union[]@10") - ] - -testSchemaDef :: TestTree -testSchemaDef = testGroup "Test generating schema definitions" - [ goldens' "schema_def_bool" $(showSchema [r| { a: Bool } |]) - , goldens' "schema_def_int" $(showSchema [r| { a: Int } |]) - , goldens' "schema_def_double" $(showSchema [r| { foo123: Double } |]) - , goldens' "schema_def_text" $(showSchema [r| { some_text: Text } |]) - , goldens' "schema_def_custom" $(showSchema [r| { status: Status } |]) - , goldens' "schema_def_maybe" $(showSchema [r| { a: Maybe Int } |]) - , goldens' "schema_def_list" $(showSchema [r| { a: List Int } |]) - , goldens' "schema_def_obj" $(showSchema [r| { a: { b: Int } } |]) - , goldens' "schema_def_maybe_obj" $(showSchema [r| { a: Maybe { b: Int } } |]) - , goldens' "schema_def_list_obj" $(showSchema [r| { a: List { b: Int } } |]) - , goldens' "schema_def_import_user" $(showSchema [r| { user: #UserSchema } |]) - , goldens' "schema_def_extend" $(showSchema [r| { a: Int, #(Schema.MySchema) } |]) - , goldens' "schema_def_shadow" $(showSchema [r| { extra: Bool, #(Schema.MySchema) } |]) - , goldens' "schema_def_union" $(showSchema [r| { a: List Int | Text } |]) - , goldens' "schema_def_union_grouped" $(showSchema [r| { a: List (Int | Text) } |]) - -- bad schema definitions - , goldens' "schema_def_duplicate" $(tryQErr' $ showSchema [r| { a: Int, a: Bool } |]) - , goldens' "schema_def_duplicate_phantom" $(tryQErr' $ showSchema [r| { a: Int, [a]: { b: Bool } } |]) - , goldens' "schema_def_duplicate_extend" $(tryQErr' $ showSchema [r| { #MySchema, #MySchema2 } |]) - , goldens' "schema_def_not_object" $(tryQErr' $ showSchema [r| List { a: Int } |]) - , goldens' "schema_def_unknown_type" $(tryQErr' $ showSchema [r| HelloWorld |]) - , goldens' "schema_def_invalid_extend" $(tryQErr' $ showSchema [r| { #Int } |]) - , goldens' "schema_def_nonobject_phantom" $(tryQErr' $ showSchema [r| { [a]: Int } |]) - ] - -testMkGetter :: TestTree -testMkGetter = testGroup "Test the mkGetter helper" - [ goldens "getter_all_types_list" list - , goldens "getter_all_types_list_item" $ map getType list - ] - where - list :: [AllTypes.ListItem] - list = AllTypes.getList AllTypes.result - - getType :: AllTypes.ListItem -> Text.Text - getType = [get| .type |] - -testEnumTH :: TestTree -testEnumTH = testGroup "Test the Enum TH helpers" - -- State - [ testProperty "mkEnum decode is case insensitive" $ do - (val, enumVal) <- elements - [ ("OPEN", OPEN) - , ("CLOSED", CLOSED) - ] - casedVal <- randomlyCased val - return $ decode (ByteString.pack $ show casedVal) === Just enumVal - , testCase "mkEnum encode keeps case of constructor" $ do - encode OPEN @?= "\"OPEN\"" - encode CLOSED @?= "\"CLOSED\"" - , testProperty "mkEnum: (fromJust . decode . encode) === id" $ do - enumVal <- elements [OPEN, CLOSED] - return $ (decode . encode) enumVal === Just enumVal - - -- Color - , testProperty "genFromJSONEnum decode is case insensitive" $ do - (val, enumVal) <- elements - [ ("Red", Red) - , ("LightBlue", LightBlue) - , ("Yellow", Yellow) - , ("DarkGreen", DarkGreen) - , ("Black", Black) - , ("JustABitOffWhite", JustABitOffWhite) - ] - casedVal <- randomlyCased val - return $ decode (ByteString.pack $ show casedVal) === Just enumVal - , testCase "genToJSONEnum encode keeps case of constructor" $ do - encode Red @?= "\"Red\"" - encode LightBlue @?= "\"LightBlue\"" - encode Yellow @?= "\"Yellow\"" - encode DarkGreen @?= "\"DarkGreen\"" - encode Black @?= "\"Black\"" - encode JustABitOffWhite @?= "\"JustABitOffWhite\"" - , testProperty "genFromJSONEnum + genToJSONEnum: (fromJust . decode . encode) === id" $ do - enumVal <- elements - [ Red - , LightBlue - , Yellow - , DarkGreen - , Black - , JustABitOffWhite - ] - return $ (decode . encode) enumVal === Just enumVal - ] - where - randomlyCased s = do - caseFuncs <- infiniteListOf $ elements [toLower, toUpper] - return $ zipWith ($) caseFuncs s - -testSumType :: TestTree -testSumType = testGroup "Test the SumType helper" - [ testCase "Sanity checks" $ - let values = - [ Here True - , Here False - , There (Here 1) - , There (Here 10) - , There (There (Here [])) - , There (There (Here ["a"])) - ] :: [SpecialJSON] - in values @?= values - , testGroup "Decode SumType" - [ testProperty "branch 1" $ \(b :: Bool) -> - toSpecialJSON b === Right (Here b) - , testProperty "branch 2" $ \(x :: Int) -> - toSpecialJSON x === Right (There (Here x)) - , testProperty "branch 3" $ \(l :: [String]) -> - toSpecialJSON l === Right (There (There (Here l))) - , testCase "invalid SumType" $ - toSpecialJSON [True] @?= Left "Error in $: Could not parse sum type" - ] - , testGroup "fromSumType" - [ testProperty "branch 0 valid" $ \b -> - fromSumType (Proxy @0) (Here b :: SpecialJSON) === Just b - , testProperty "branch 0 invalid" $ do - value <- oneof - [ There . Here <$> arbitrary - , There . There . Here <$> arbitrary - ] - return $ fromSumType (Proxy @0) (value :: SpecialJSON) === Nothing - , testProperty "branch 1 valid" $ \x -> - fromSumType (Proxy @1) (There (Here x) :: SpecialJSON) === Just x - , testProperty "branch 1 invalid" $ do - value <- oneof - [ Here <$> arbitrary - , There . There . Here <$> arbitrary - ] - return $ fromSumType (Proxy @1) (value :: SpecialJSON) === Nothing - , testProperty "branch 2 valid" $ \l -> - fromSumType (Proxy @2) (There (There (Here l)) :: SpecialJSON) === Just l - , testProperty "branch 2 invalid" $ do - value <- oneof - [ Here <$> arbitrary - , There . Here <$> arbitrary - ] - return $ fromSumType (Proxy @2) (value :: SpecialJSON) === Nothing - ] + [ Tests.Object.test + , Tests.GetQQ.test + , Tests.UnwrapQQ.test + , Tests.SchemaQQ.test + , Tests.MkGetter.test + , Tests.EnumTH.test + , Tests.SumType.test ] - where - toSpecialJSON :: ToJSON a => a -> Either String SpecialJSON - toSpecialJSON = eitherDecode . encode diff --git a/test/Nested.hs b/test/Nested.hs deleted file mode 100644 --- a/test/Nested.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} - -module Nested where - -import Data.Aeson.Schema - -import Util (getMockedResult) - -type Schema = [schema| - { - list: List { - a: Maybe { - b: Int, - }, - b: Int, - }, - } -|] - -result :: Object Schema -result = $(getMockedResult "test/nested.json") diff --git a/test/Schema.hs b/test/Schema.hs deleted file mode 100644 --- a/test/Schema.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE QuasiQuotes #-} - -module Schema where - -import Data.Aeson (FromJSON) -import Data.Aeson.Schema (schema) - -newtype Status = Status Int - deriving (Show,FromJSON) - -type UserSchema = [schema| { name: Text } |] -type MySchema = [schema| { extra: Text } |] -type MySchema2 = [schema| { extra: Maybe Text } |] diff --git a/test/SumType.hs b/test/SumType.hs deleted file mode 100644 --- a/test/SumType.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE DataKinds #-} - -module SumType where - -import Data.Aeson.Schema.Utils.Sum (SumType(..)) - -type SpecialJSON = SumType '[Bool, Int, [String]] diff --git a/test/TestUtils.hs b/test/TestUtils.hs new file mode 100644 --- /dev/null +++ b/test/TestUtils.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module TestUtils + ( ShowSchemaResult(..) + , json + , parseValue + , parseObject + , parseProxy + , mkExpQQ + , testGolden + , testGoldenIO + , testParseError + ) where + +import Data.Aeson (FromJSON(..), Value, eitherDecode) +import Data.Aeson.Types (parseEither) +#if !MIN_VERSION_megaparsec(7,0,0) +import Data.Char (isDigit, isSpace) +#endif +import Data.Proxy (Proxy(..)) +import Data.String (fromString) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL +import Data.Typeable (Typeable, typeRep) +import Language.Haskell.TH (ExpQ) +import Language.Haskell.TH.Quote (QuasiQuoter(..)) +import Test.Tasty (TestTree) +import Test.Tasty.Golden (goldenVsString) +import Test.Tasty.Golden.Advanced (goldenTest) + +import Data.Aeson.Schema (IsSchema, Object, schema) +import qualified Data.Aeson.Schema.Internal as Internal + +{- ShowSchemaResult -} + +class ShowSchemaResult a where + showSchemaResult :: String + +instance IsSchema schema => ShowSchemaResult (Object schema) where + showSchemaResult = "Object (" ++ Internal.showSchema @schema ++ ")" + +instance ShowSchemaResult a => ShowSchemaResult [a] where + showSchemaResult = "[" ++ showSchemaResult @a ++ "]" + +instance {-# OVERLAPPABLE #-} Typeable a => ShowSchemaResult a where + showSchemaResult = show $ typeRep (Proxy @a) + +{- Loading JSON data -} + +json :: QuasiQuoter +json = mkExpQQ $ \s -> [| (either error id . eitherDecode . fromString) s |] + +parseValue :: FromJSON a => Value -> a +parseValue = either error id . parseEither parseJSON + +parseProxy :: FromJSON a => Proxy a -> Value -> Either String a +parseProxy _ = parseEither parseJSON + +parseObject :: String -> ExpQ +parseObject schemaString = [| parseValue :: Value -> Object $schemaType |] + where + schemaType = quoteType schema schemaString + +{- QuasiQuotation -} + +mkExpQQ :: (String -> ExpQ) -> QuasiQuoter +mkExpQQ f = QuasiQuoter + { quoteExp = f + , quotePat = error "Cannot use this QuasiQuoter for patterns" + , quoteType = error "Cannot use this QuasiQuoter for types" + , quoteDec = error "Cannot use this QuasiQuoter for declarations" + } + +{- Tasty test trees -} + +testGolden :: String -> FilePath -> String -> TestTree +testGolden name fp = testGoldenIO name fp . return + +testGoldenIO :: String -> FilePath -> IO String -> TestTree +testGoldenIO name fp = goldenVsString name ("test/goldens/" ++ fp) . fmap toByteString + where + toByteString = TextL.encodeUtf8 . TextL.fromStrict . Text.pack + +-- | A golden test for testing parse errors. +testParseError :: String -> FilePath -> String -> TestTree +testParseError name fp s = goldenTest name getExpected getActual cmp update + where + goldenFile = "test/goldens/" ++ fp + getExpected = sanitize <$> Text.readFile goldenFile + getActual = return $ Text.pack s + cmp expected actual = return $ if expected == actual + then Nothing + else Just $ "Test output was different from '" ++ goldenFile ++ "'. It was:\n" ++ Text.unpack actual + update = Text.writeFile goldenFile + +#if MIN_VERSION_megaparsec(7,0,0) + sanitize = id +#else + -- megaparsec before version 7.0.0 doesn't display the offending lines, so we need to strip + -- out those lines from the golden before comparing them. + -- + -- e.g. + -- + -- { "a:b": Int } :1:6: + -- > | + -- > 1 | { "a:b": Int } + -- > | ^ + -- unexpected ':' + -- expecting '"' or '\' + sanitize = Text.unlines . filter (not . isOffendingLine) . Text.lines + + isOffendingLine line = case Text.splitOn "|" line of + [prefix, _] -> Text.all (\c -> isDigit c || isSpace c) prefix + _ -> False +#endif diff --git a/test/TestUtils/Arbitrary.hs b/test/TestUtils/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/test/TestUtils/Arbitrary.hs @@ -0,0 +1,341 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module TestUtils.Arbitrary + ( ArbitraryObject(..) + , forAllArbitraryObjects + ) where + +import Control.Monad (forM) +import Data.Aeson (ToJSON(..), Value(..), encode) +import qualified Data.Aeson as Aeson +import qualified Data.HashMap.Strict as HashMap +import Data.List (nub) +import Data.Proxy (Proxy(..)) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Typeable (Typeable) +import GHC.Exts (fromList) +import GHC.TypeLits (KnownSymbol) +import Language.Haskell.TH (ExpQ, listE, runIO) +import Language.Haskell.TH.Instances () +import Language.Haskell.TH.Quote (QuasiQuoter(quoteType)) +import Language.Haskell.TH.Syntax (Lift) +import Test.QuickCheck + +import Data.Aeson.Schema (IsSchema, Object, schema) +import Data.Aeson.Schema.Key + (IsSchemaKey(..), SchemaKey, SchemaKey'(..), SchemaKeyV, toContext) +import Data.Aeson.Schema.Type + ( NameLike(..) + , Schema'(..) + , SchemaObjectMapV + , SchemaType + , SchemaType'(..) + , SchemaV + , showSchemaV + , toSchemaObjectV + ) +import Data.Aeson.Schema.Utils.All (All(..)) + +data ArbitraryObject where + ArbitraryObject + :: IsSchema schema + => Proxy (Object schema) + -> Value + -> SchemaV + -> ArbitraryObject + +-- Show the value and schema as something that could be copied/pasted into GHCi. +instance Show ArbitraryObject where + show (ArbitraryObject _ v schemaV) = unlines + [ "ArbitraryObject:" + , " " ++ show (encode v) + , " [schema| " ++ showSchemaV schemaV ++ " |]" + ] + +-- | A Template Haskell function to generate a splice for QuickCheck tests to generate arbitrary +-- objects with arbitrary schemas. +-- +-- Note that for repeated runs of the test suite, the schemas will be the same, with the actual +-- JSON values generated randomly. You need to recompile in order to generate different schemas. +arbitraryObject :: ExpQ +arbitraryObject = do + arbitrarySchemas <- runIO $ genSchemaTypes 20 + + [| oneof $(listE $ map mkSchemaGen arbitrarySchemas) |] + where + mkSchemaGen schemaV = + let schemaType = quoteType schema $ showSchemaV schemaV + in [| genSchema' (Proxy :: Proxy (Object $schemaType)) schemaV |] + +-- | Splices to a 'forAll' with 'arbitraryObject', outputting information about the object +-- generated, to ensure we get good generation. +-- +-- $(forAllArbitraryObjects) :: Testable prop => ArbitraryObject -> prop +forAllArbitraryObjects :: ExpQ +forAllArbitraryObjects = [| forAllArbitraryObjects' $arbitraryObject |] + +forAllArbitraryObjects' :: Gen ArbitraryObject -> (ArbitraryObject -> Property) -> Property +forAllArbitraryObjects' genArbitraryObject runTest = + forAll @_ @Property genArbitraryObject $ \o@(ArbitraryObject _ _ schemaType) -> + tabulate' "Key types" (map getKeyType $ getKeys schemaType) $ + tabulate' "Schema types" (getSchemaTypes schemaType) $ + tabulate' "Object sizes" (map show $ getObjectSizes schemaType) $ + tabulate' "Object depth" [show $ getObjectDepth schemaType] $ + runTest o + +{- Run time helpers -} + +deriving instance Lift NameLike + +genSchema' :: forall schema. + ( ArbitrarySchema ('SchemaObject schema) + , IsSchema ('Schema schema) + ) + => Proxy (Object ('Schema schema)) -> SchemaV -> Gen ArbitraryObject +genSchema' proxy schemaV = do + v <- genSchema @('SchemaObject schema) + return $ ArbitraryObject proxy v schemaV + +getKeyType :: SchemaKeyV -> String +getKeyType = \case + NormalKey _ -> "Normal" + PhantomKey _ -> "Phantom" + +getKeys :: SchemaV -> [SchemaKeyV] +getKeys = getKeys' . toSchemaObjectV + where + getKeys' = \case + SchemaMaybe inner -> getKeys' inner + SchemaTry inner -> getKeys' inner + SchemaList inner -> getKeys' inner + SchemaUnion schemas -> concatMap getKeys' schemas + SchemaObject pairs -> concatMap (\(key, inner) -> key : getKeys' inner) pairs + _ -> [] + +getSchemaTypes :: SchemaV -> [String] +getSchemaTypes = getSchemaTypes' . toSchemaObjectV + where + getSchemaTypes' = \case + SchemaScalar name -> [show name] + SchemaMaybe inner -> "SchemaMaybe" : getSchemaTypes' inner + SchemaTry inner -> "SchemaTry" : getSchemaTypes' inner + SchemaList inner -> "SchemaList" : getSchemaTypes' inner + SchemaUnion schemas -> "SchemaUnion" : concatMap getSchemaTypes' schemas + SchemaObject pairs -> "SchemaObject" : concatMap (getSchemaTypes' . snd) pairs + +getObjectSizes :: SchemaV -> [Int] +getObjectSizes = getObjectSizes' . toSchemaObjectV + where + getObjectSizes' = \case + SchemaScalar _ -> [] + SchemaMaybe inner -> getObjectSizes' inner + SchemaTry inner -> getObjectSizes' inner + SchemaList inner -> getObjectSizes' inner + SchemaUnion schemas -> concatMap getObjectSizes' schemas + SchemaObject pairs -> length pairs : concatMap (getObjectSizes' . snd) pairs + +getObjectDepth :: SchemaV -> Int +getObjectDepth = getObjectDepth' . toSchemaObjectV + where + getObjectDepth' = \case + SchemaScalar _ -> 0 + SchemaMaybe inner -> getObjectDepth' inner + SchemaTry inner -> getObjectDepth' inner + SchemaList inner -> getObjectDepth' inner + SchemaUnion schemas -> maximum $ map getObjectDepth' schemas + SchemaObject pairs -> 1 + maximum (map (getObjectDepth' . snd) pairs) + +tabulate' :: String -> [String] -> Property -> Property +#if MIN_VERSION_QuickCheck(2,12,0) +tabulate' = tabulate +#else +tabulate' _ _ = id +#endif + +{- Generating schemas -} + +class ArbitrarySchema (schema :: SchemaType) where + genSchema :: Gen Value + +instance {-# OVERLAPS #-} ArbitrarySchema ('SchemaScalar Text) where + genSchema = toJSON <$> arbitrary @String + +instance (Arbitrary inner, ToJSON inner, Typeable inner) => ArbitrarySchema ('SchemaScalar inner) where + genSchema = toJSON <$> arbitrary @inner + +instance ArbitrarySchema inner => ArbitrarySchema ('SchemaMaybe inner) where + genSchema = frequency + [ (3, genSchema @inner) + , (1, pure Null) + ] + +instance ArbitrarySchema inner => ArbitrarySchema ('SchemaTry inner) where + genSchema = frequency + [ (3, genSchema @inner) + , (1, genValue) + ] + where + genValue = oneof + [ pure Null + , Number . realToFrac <$> arbitrary @Double + , Bool <$> arbitrary + , String . Text.pack <$> arbitrary + ] + +instance ArbitrarySchema inner => ArbitrarySchema ('SchemaList inner) where + genSchema = Array . fromList <$> listOf (genSchema @inner) + +instance All ArbitrarySchema schemas => ArbitrarySchema ('SchemaUnion schemas) where + genSchema = oneof $ mapAll @ArbitrarySchema @schemas genSchemaElem + where + genSchemaElem :: forall schema. ArbitrarySchema schema => Proxy schema -> Gen Value + genSchemaElem _ = genSchema @schema + +instance All ArbitraryObjectPair pairs => ArbitrarySchema ('SchemaObject (pairs :: [(SchemaKey, SchemaType)])) where + genSchema = Object . HashMap.unions <$> genSchemaPairs + where + genSchemaPairs :: Gen [Aeson.Object] + genSchemaPairs = sequence $ mapAll @ArbitraryObjectPair @pairs genSchemaPair + +class IsSchemaKey (Fst pair) => ArbitraryObjectPair (pair :: (SchemaKey, SchemaType)) where + genSchemaPair :: Proxy pair -> Gen Aeson.Object + genSchemaPair _ = toContext schemaKey <$> genInnerSchema @pair + where + schemaKey = toSchemaKeyV $ Proxy @(Fst pair) + + genInnerSchema :: Gen Value + +instance (IsSchemaKey key, ArbitrarySchema schema) => ArbitraryObjectPair '(key, schema) where + genInnerSchema = genSchema @schema + +-- For phantom keys, Maybe is only valid for Objects. Since phantom keys parse the schema with +-- the current object as the context, we should guarantee that this only generates objects, and +-- not Null. +instance {-# OVERLAPS #-} (KnownSymbol key, inner ~ 'SchemaObject a, ArbitrarySchema inner) + => ArbitraryObjectPair '( 'PhantomKey key, 'SchemaMaybe inner ) where + genInnerSchema = genSchema @inner + +-- For phantom keys, Try can be used on any schema, but for all non-object schemas, need to ensure +-- we generate 'Null', because Try on a non-object schema will always be an invalid parse. +instance {-# OVERLAPS #-} (KnownSymbol key, ArbitrarySchema ('SchemaTry inner)) + => ArbitraryObjectPair '( 'PhantomKey key, 'SchemaTry inner ) where + genInnerSchema = castNull <$> genSchema @('SchemaTry inner) + where + castNull inner = + case inner of + Object _ -> inner + _ -> Null + +-- For phantom keys, Union can be used on any schemas, as long as at least one is an object schema. +instance {-# OVERLAPS #-} (KnownSymbol key, FilterObjectSchemas schemas ~ objectSchemas, ArbitrarySchema ('SchemaUnion objectSchemas)) + => ArbitraryObjectPair '( 'PhantomKey key, 'SchemaUnion schemas ) where + genInnerSchema = genSchema @('SchemaUnion objectSchemas) + +{- Generating schema definitions -} + +genSchemaTypes :: Int -> IO [SchemaV] +genSchemaTypes numSchemasToGenerate = + generate $ sequence $ take numSchemasToGenerate + [ resize n arbitrary | n <- [0,2..] ] + +instance Arbitrary SchemaV where + arbitrary = Schema <$> sized genSchemaObject + +-- | Generate an arbitrary schema. +-- +-- SchemaType is a recursive definition, so we want to make sure that generating a schema will +-- terminate, and also not take too long. The ways we account for that are: +-- * Providing an upper bound on the depth of any object schemas in the current object (n / 2) +-- * Providing an upper bound on the number of keys in the current object (n / 3) +-- * Providing an upper bound on the number of schemas in a union (n / 5) +genSchemaObject :: Int -> Gen SchemaObjectMapV +genSchemaObject n = do + keys <- genUniqList1 (n `div` 3) genKey + forM keys $ \key -> frequency + [ (10, genSchemaObjectPairNormal key) + , (1, genSchemaObjectPairPhantom key) + ] + where + genSchemaObject' = do + n' <- choose (0, n `div` 2) + SchemaObject <$> genSchemaObject n' + + genSchemaObjectPairNormal key = do + schemaType <- frequency $ if n == 0 + then scalarSchemaTypes + else allSchemaTypes + return (NormalKey key, schemaType) + + genSchemaObjectPairPhantom key = do + schemaType <- frequency + [ (2, SchemaMaybe <$> genSchemaObject') + , (2, SchemaTry <$> frequency nonNullableSchemaTypes) + , (4, genSchemaObject') + , (1, genSchemaUnion genSchemaObject') + ] + return (PhantomKey key, schemaType) + + scalarSchemaTypes = + [ (4, pure $ SchemaScalar $ NameRef "Bool") + , (4, pure $ SchemaScalar $ NameRef "Int") + , (4, pure $ SchemaScalar $ NameRef "Double") + , (4, pure $ SchemaScalar $ NameRef "Text") + ] + + nonNullableSchemaTypes = + scalarSchemaTypes ++ + [ (2, SchemaList <$> frequency allSchemaTypes) + , (1, genSchemaUnion $ frequency allSchemaTypes) + , (2, genSchemaObject') + ] + + allSchemaTypes = + nonNullableSchemaTypes ++ + [ (2, SchemaMaybe <$> frequency nonNullableSchemaTypes) + , (2, SchemaTry <$> frequency nonNullableSchemaTypes) + ] + + -- avoid generating big unions by scaling list length + genSchemaUnion gen = SchemaUnion <$> genUniqList1 (n `div` 5) gen + + +-- | Generate a valid JSON key +-- See Data.Aeson.Schema.TH.Parse.jsonKey' +genKey :: Gen String +genKey = listOf1 $ arbitraryPrintableChar `suchThat` (`notElem` " \"\\!?[](),.@:{}#") + +-- | Generate a non-empty and unique list of the given generator. +-- +-- Takes in the max size of the list. +genUniqList1 :: Eq a => Int -> Gen a -> Gen [a] +genUniqList1 n gen = do + k <- choose (1, max 1 n) + take k . nub <$> infiniteListOf gen + +{- Helper type families -} + +type family Fst x where + Fst '(a, _) = a + +type family FilterObjectSchemas schemas where + FilterObjectSchemas '[] = '[] + FilterObjectSchemas ('SchemaObject inner ': xs) = 'SchemaObject inner : FilterObjectSchemas xs + FilterObjectSchemas (_ ': xs) = FilterObjectSchemas xs diff --git a/test/TestUtils/DeepSeq.hs b/test/TestUtils/DeepSeq.hs new file mode 100644 --- /dev/null +++ b/test/TestUtils/DeepSeq.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module TestUtils.DeepSeq () where + +import Control.DeepSeq (NFData(..)) +#if MIN_VERSION_template_haskell(2,16,0) +import Control.DeepSeq (rwhnf) +import GHC.ForeignPtr (ForeignPtr) +#endif +import Language.Haskell.TH.Syntax + +instance NFData AnnTarget +instance NFData Bang +instance NFData Body +instance NFData Callconv +instance NFData Clause +instance NFData Con +instance NFData Dec +instance NFData DerivClause +instance NFData DerivStrategy +instance NFData Exp +instance NFData FamilyResultSig +instance NFData Fixity +instance NFData FixityDirection +instance NFData Foreign +instance NFData FunDep +instance NFData Guard +instance NFData InjectivityAnn +instance NFData Inline +instance NFData Lit +instance NFData Match +instance NFData ModName +instance NFData Name +instance NFData NameFlavour +instance NFData NameSpace +instance NFData OccName +instance NFData Overlap +instance NFData Pat +instance NFData PatSynArgs +instance NFData PatSynDir +instance NFData Phases +instance NFData PkgName +instance NFData Pragma +instance NFData Range +instance NFData Role +instance NFData RuleBndr +instance NFData RuleMatch +instance NFData Safety +instance NFData SourceStrictness +instance NFData SourceUnpackedness +instance NFData Stmt +instance NFData Type +instance NFData TypeFamilyHead +instance NFData TyLit +instance NFData TySynEqn +instance NFData TyVarBndr + +#if MIN_VERSION_template_haskell(2,16,0) +instance NFData Bytes + +instance NFData (ForeignPtr a) where + rnf = rwhnf +#endif diff --git a/test/Tests/EnumTH.hs b/test/Tests/EnumTH.hs new file mode 100644 --- /dev/null +++ b/test/Tests/EnumTH.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Tests.EnumTH where + +import Data.Aeson (decode, encode) +import Data.Char (toLower, toUpper) +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +import Data.Aeson.Schema.TH (genFromJSONEnum, genToJSONEnum, mkEnum) + +mkEnum "State" ["OPEN", "CLOSED"] + +data Color = Red | LightBlue | Yellow | DarkGreen | Black | JustABitOffWhite + deriving (Show, Eq, Enum) + +genFromJSONEnum ''Color +genToJSONEnum ''Color + +{- Tests -} + +test :: TestTree +test = testGroup "Enum TH helpers" + [ testMkEnum + , testGenJSONEnum + ] + +testMkEnum :: TestTree +testMkEnum = testGroup "mkEnum" + [ testProperty "mkEnum decode is case insensitive" $ do + (val, enumVal) <- elements + [ ("OPEN", OPEN) + , ("CLOSED", CLOSED) + ] + casedVal <- randomlyCased val + return $ decode (encode casedVal) === Just enumVal + , testCase "mkEnum encode keeps case of constructor" $ do + encode OPEN @?= "\"OPEN\"" + encode CLOSED @?= "\"CLOSED\"" + , testProperty "mkEnum: (fromJust . decode . encode) === id" $ do + enumVal <- elements [OPEN, CLOSED] + return $ (decode . encode) enumVal === Just enumVal + ] + +testGenJSONEnum :: TestTree +testGenJSONEnum = testGroup "gen{To,From}JSONEnum" + [ testProperty "genFromJSONEnum decode is case insensitive" $ do + (val, enumVal) <- elements + [ ("Red", Red) + , ("LightBlue", LightBlue) + , ("Yellow", Yellow) + , ("DarkGreen", DarkGreen) + , ("Black", Black) + , ("JustABitOffWhite", JustABitOffWhite) + ] + casedVal <- randomlyCased val + return $ decode (encode casedVal) === Just enumVal + , testCase "genToJSONEnum encode keeps case of constructor" $ do + encode Red @?= "\"Red\"" + encode LightBlue @?= "\"LightBlue\"" + encode Yellow @?= "\"Yellow\"" + encode DarkGreen @?= "\"DarkGreen\"" + encode Black @?= "\"Black\"" + encode JustABitOffWhite @?= "\"JustABitOffWhite\"" + , testProperty "genFromJSONEnum + genToJSONEnum: (fromJust . decode . encode) === id" $ do + enumVal <- elements + [ Red + , LightBlue + , Yellow + , DarkGreen + , Black + , JustABitOffWhite + ] + return $ (decode . encode) enumVal === Just enumVal + ] + +randomlyCased :: String -> Gen String +randomlyCased s = do + caseFuncs <- infiniteListOf $ elements [toLower, toUpper] + return $ zipWith ($) caseFuncs s diff --git a/test/Tests/GetQQ.hs b/test/Tests/GetQQ.hs new file mode 100644 --- /dev/null +++ b/test/Tests/GetQQ.hs @@ -0,0 +1,405 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +module Tests.GetQQ where + +import Control.DeepSeq (deepseq) +import Control.Exception (SomeException, try) +import Data.Aeson (FromJSON(..), ToJSON(..), withText) +import Data.Aeson.QQ (aesonQQ) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Language.Haskell.Interpreter as Hint +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +import Data.Aeson.Schema (Object, schema) +import Data.Aeson.Schema.TH (mkEnum) +import Data.Aeson.Schema.Utils.Sum (SumType(..)) +import Tests.GetQQ.TH +import TestUtils (parseObject, testGoldenIO, testParseError) + +mkEnum "Greeting" ["HELLO", "GOODBYE"] + +newtype Coordinate = Coordinate (Int, Int) + deriving (Show,Eq) + +instance ToJSON Coordinate where + toJSON (Coordinate (x, y)) = toJSON $ show x ++ "," ++ show y + +instance FromJSON Coordinate where + parseJSON = withText "Coordinate" $ \s -> + case map (read . Text.unpack) $ Text.splitOn "," s of + [x, y] -> return $ Coordinate (x, y) + _ -> fail $ "Bad Coordinate: " ++ Text.unpack s + +{- Tests -} + +test :: TestTree +test = testGroup "`get` quasiquoter" + [ testValidExpressions + , testInvalidExpressions + , testCompileTimeErrors + ] + +testValidExpressions :: TestTree +testValidExpressions = testGroup "Valid get expressions" + [ testScalarExpressions + , testBasicExpressions + , testNullableExpressions + , testListExpressions + , testUnionExpressions + , testPhantomExpressions + , testNestedExpressions + ] + +testScalarExpressions :: TestTree +testScalarExpressions = testGroup "Scalar expressions" + [ testProperty "Get Bool key from object" $ \b -> + let o = $(parseObject "{ foo: Bool }") [aesonQQ| { "foo": #{b} } |] + in [runGet| o.foo |] === b + + , testProperty "Get Int key from object" $ \x -> + let o = $(parseObject "{ foo: Int }") [aesonQQ| { "foo": #{x} } |] + in [runGet| o.foo |] === x + + , testProperty "Get Double key from object" $ \x -> + let o = $(parseObject "{ foo: Double }") [aesonQQ| { "foo": #{x} } |] + in [runGet| o.foo |] === x + + , testProperty "Get Text key from object" $ \(UnicodeText s) -> + let o = $(parseObject "{ foo: Text }") [aesonQQ| { "foo": #{s} } |] + in [runGet| o.foo |] === s + + , testProperty "Get Custom key from object" $ \coordinate -> + let o = $(parseObject "{ foo: Coordinate }") [aesonQQ| { "foo": #{coordinate} } |] + in [runGet| o.foo |] === coordinate + + , testProperty "Get Enum key from object" $ \greeting -> + let o = $(parseObject "{ foo: Greeting }") [aesonQQ| { "foo": #{greeting} } |] + in [runGet| o.foo |] === greeting + ] + +testBasicExpressions :: TestTree +testBasicExpressions = testGroup "Basic expressions" + [ testCase "Can query fields on namespaced object" $ + [runGet| (Tests.GetQQ.TH.testData).foo |] @?= [runGet| testData.foo |] + + , testProperty "Can query quoted keys" $ \x -> + let o = $(parseObject "{ foo: Int }") [aesonQQ| { "foo": #{x :: Int} } |] + in [runGet| o."foo" |] === [runGet| o.foo |] + + , testProperty "Can query nested fields" $ \x -> + let o = $(parseObject "{ foo: { bar: Int } }") [aesonQQ| { "foo": { "bar": #{x} } } |] + in [runGet| o.foo.bar |] === x + + , testProperty "Can generate a lambda expression" $ \x -> + let o = $(parseObject "{ foo: Int }") [aesonQQ| { "foo": #{x} } |] + in [runGet| .foo |] o === x + + , testProperty "Can extract a list of elements" $ \x y bar -> + let o = $(parseObject "{ x: Int, y: Int, foo: { bar: Int } }") [aesonQQ| + { + "x": #{x}, + "y": #{y}, + "foo": { "bar": #{bar} } + } + |] + in [runGet| o.[x, y, x, foo.bar] |] === [x, y, x, bar] + + , testProperty "Can extract a tuple of elements" $ \x b bar -> + let o = $(parseObject "{ x: Int, b: Bool, foo: { bar: Int } }") [aesonQQ| + { + "x": #{x}, + "b": #{b}, + "foo": { "bar": #{bar} } + } + |] + in [runGet| o.(x,b,x,foo.bar) |] === (x, b, x, bar) + ] + +testNullableExpressions :: TestTree +testNullableExpressions = testGroup "Nullable expressions" + [ testCase "Get Maybe key from object with value" $ do + let o = $(parseObject "{ foo: Maybe Bool }") [aesonQQ| { "foo": true } |] + [runGet| o.foo |] @?= Just True + [runGet| o.foo! |] @?= True + + , testCase "Get Maybe key from object with null value" $ + let o = $(parseObject "{ foo: Maybe Bool }") [aesonQQ| { "foo": null } |] + in [runGet| o.foo |] @?= Nothing + + , testCase "Get Maybe key from object without value" $ + let o = $(parseObject "{ foo: Maybe Bool }") [aesonQQ| {} |] + in [runGet| o.foo |] @?= Nothing + + , testCase "Can run operations within existing Maybe value" $ + let o = $(parseObject "{ foo: Maybe List { bar: Bool } }") [aesonQQ| + { + "foo": [ + { "bar": true }, + { "bar": true }, + { "bar": false } + ] + } + |] + in [runGet| o.foo?[].bar |] @?= Just [True, True, False] + + , testCase "Can run operations within nonexisting Maybe value" $ + let o = $(parseObject "{ foo: Maybe List { bar: Bool } }") [aesonQQ| { "foo": null } |] + in [runGet| o.foo?[].bar |] @?= Nothing + + , testCase "Can run operations after unwrapping Maybe value" $ + let o = $(parseObject "{ foo: Maybe List { bar: Bool } }") [aesonQQ| + { + "foo": [ + { "bar": true }, + { "bar": true }, + { "bar": false } + ] + } + |] + in [runGet| o.foo![].bar |] @?= [True, True, False] + + , testCase "Get Try key from object with parsed value" $ do + let o = $(parseObject "{ foo: Try Bool }") [aesonQQ| { "foo": true } |] + [runGet| o.foo |] @?= Just True + [runGet| o.foo! |] @?= True + + , testCase "Get Try key from object with invalid value" $ + let o = $(parseObject "{ foo: Try Bool }") [aesonQQ| { "foo": 1 } |] + in [runGet| o.foo |] @?= Nothing + + , testCase "Can run operations within parsed Try value" $ + let o = $(parseObject "{ foo: Try List { bar: Bool } }") [aesonQQ| + { + "foo": [ + { "bar": true }, + { "bar": true }, + { "bar": false } + ] + } + |] + in [runGet| o.foo?[].bar |] @?= Just [True, True, False] + + , testCase "Can run operations within invalid Try value" $ + let o = $(parseObject "{ foo: Try List { bar: Bool } }") [aesonQQ| { "foo": [{ "baz": 1 }] } |] + in [runGet| o.foo?[].bar |] @?= Nothing + + , testCase "Can run operations after unwrapping Try value" $ + let o = $(parseObject "{ foo: Try List { bar: Bool } }") [aesonQQ| + { + "foo": [ + { "bar": true }, + { "bar": true }, + { "bar": false } + ] + } + |] + in [runGet| o.foo![].bar |] @?= [True, True, False] + + , testFromJustErrors + ] + +-- test error message for bang operator, to get some coverage on startDisplay + showGetterOps +testFromJustErrors :: TestTree +testFromJustErrors = testGroup "fromJust errors" + [ testCase "Plain fromJust" $ + assertError "Called 'fromJust' on null expression" $ [runGet| ! |] (Nothing :: Maybe Int) + + , testCase "With start" $ do + let o = $(parseObject "{ foo: Maybe Bool }") [aesonQQ| { "foo": null } |] + assertError "Called 'fromJust' on null expression: o.foo" + [runGet| o.foo! |] + + , testCase "With qualified start" $ + assertError "Called 'fromJust' on null expression: (Tests.GetQQ.TH.testData).foo" + [runGet| (Tests.GetQQ.TH.testData).foo! |] + + , testCase "With lambda" $ do + let o = $(parseObject "{ foo: Maybe Bool }") [aesonQQ| { "foo": null } |] + assertError "Called 'fromJust' on null expression: .foo" $ [runGet| .foo! |] o + + , testCase "Within nested list of keys" $ do + let o = $(parseObject "{ foo: { a: Bool, b: Maybe Bool } }") [aesonQQ| { "foo": { "a": true, "b": null } } |] + assertError "Called 'fromJust' on null expression: o.foo.b" [runGet| o.foo.[a, b!] |] + + , testCase "Within list of keys" $ do + let o = $(parseObject "{ foo: Bool, bar: Maybe Bool }") [aesonQQ| { "foo": true, "bar": null } |] + assertError "Called 'fromJust' on null expression: o.bar" [runGet| o.[foo, bar!] |] + + , testCase "Within nested tuple of keys" $ do + let o = $(parseObject "{ foo: { a: Int, b: Maybe Bool } }") [aesonQQ| { "foo": { "a": 1, "b": null } } |] + assertError "Called 'fromJust' on null expression: o.foo.b" [runGet| o.foo.(a, b!) |] + + , testCase "Within tuple of keys" $ do + let o = $(parseObject "{ foo: Int, bar: Maybe Bool }") [aesonQQ| { "foo": 1, "bar": null } |] + assertError "Called 'fromJust' on null expression: o.bar" [runGet| o.(foo, bar!) |] + + , testCase "Within list" $ do + let o = $(parseObject "{ foo: List Maybe Bool }") [aesonQQ| { "foo": [null] } |] + assertError "Called 'fromJust' on null expression: o.foo[]" [runGet| o.foo[]! |] + + , testCase "On incorrect branch selector" $ do + let o = $(parseObject "{ foo: Bool | Int }") [aesonQQ| { "foo": 1 } |] + assertError "Called 'fromJust' on null expression: o.foo@0" [runGet| o.foo@0! |] + ] + where + assertError msg x = try @SomeException (x `deepseq` pure ()) >>= \case + Right _ -> error "Unexpectedly succeeded" + Left e -> (head . lines . show) e @?= msg + +testListExpressions :: TestTree +testListExpressions = testGroup "List expressions" + [ testCase "Get List key from object" $ + let o = $(parseObject "{ foo: List Int }") [aesonQQ| { "foo": [1,2,3] } |] + in [runGet| o.foo |] @?= [1,2,3] + + , testProperty "Ending with a `[]` operator is a noop" $ \(xs :: [Int]) -> + let o = $(parseObject "{ foo: List Int }") [aesonQQ| { "foo": #{xs} } |] + in [runGet| o.foo |] === [runGet| o.foo[] |] + + , testCase "Can run operations within list" $ + let o = $(parseObject "{ foo: List Maybe { bar: Int } }") [aesonQQ| + { + "foo": [ + { "bar": 1 }, + { "bar": 2 }, + null, + { "bar": 3 } + ] + } + |] + in [runGet| o.foo[]?.bar |] @?= [Just 1, Just 2, Nothing, Just 3] + ] + +testUnionExpressions :: TestTree +testUnionExpressions = testGroup "Union expressions" + [ testCase "Get Union key from object" $ do + let o = $(parseObject "{ foo: Bool | Int }") [aesonQQ| { "foo": 1 } |] + [runGet| o.foo |] @?= There (Here 1) + [runGet| o.foo@0 |] @?= Nothing + [runGet| o.foo@1 |] @?= Just 1 + + , testCase "Can run operations after extracting branch" $ do + let o = $(parseObject "{ foo: { bar: Bool } | { baz: Int } }") [aesonQQ| { "foo": { "bar": true } } |] + [runGet| o.foo@0?.bar |] @?= Just True + [runGet| o.foo@0!.bar |] @?= True + [runGet| o.foo@1?.baz |] @?= Nothing + ] + +testPhantomExpressions :: TestTree +testPhantomExpressions = testGroup "Phantom expressions" + [ testProperty "Get Phantom object key from object" $ \x -> + let o = $(parseObject "{ [foo]: { bar: Int } }") [aesonQQ| { "bar": #{x} } |] + in [runGet| o.foo.bar |] === x + + , testProperty "Get Phantom object Try key from object" $ \x -> + let o = $(parseObject "{ [foo]: Try { bar: Int } }") [aesonQQ| { "bar": #{x} } |] + in [runGet| o.foo?.bar |] === Just x + + , testProperty "Get Phantom non-object Try key from object" $ \(x :: Int) -> + let o = $(parseObject "{ [foo]: Try Int }") [aesonQQ| { "foo": #{x} } |] + in [runGet| o.foo |] === Nothing + ] + +testNestedExpressions :: TestTree +testNestedExpressions = testGroup "Nested expressions" + [ testProperty "Extracted object from Object can be queried further" $ \x -> + let o = $(parseObject "{ foo: { bar: Int } }") [aesonQQ| { "foo": { "bar": #{x} } } |] + foo = [runGet| o.foo |] + in [runGet| foo.bar |] === x + + , testProperty "Extracted object from Maybe can be queried further" $ \x -> + let o = $(parseObject "{ foo: Maybe { bar: Int } }") [aesonQQ| { "foo": { "bar": #{x} } } |] + foo = [runGet| o.foo! |] + in [runGet| foo.bar |] === x + + , testProperty "Extracted object from Try can be queried further" $ \x -> + let o = $(parseObject "{ foo: Try { bar: Int } }") [aesonQQ| { "foo": { "bar": #{x} } } |] + foo = [runGet| o.foo! |] + in [runGet| foo.bar |] === x + + , testProperty "Extracted object from List can be queried further" $ \xs -> + classify (length xs > 1) "non-trivial" $ + let bars = map (\x -> [aesonQQ| { "bar": #{x} } |]) xs + o = $(parseObject "{ foo: List { bar: Int } }") [aesonQQ| { "foo": #{bars} } |] + getBar :: Object [schema| { bar: Int } |] -> Int + getBar foo = [runGet| foo.bar |] + in map getBar [runGet| o.foo |] === xs + + , testProperty "Extracted objects from list of keys can be queried further" $ \fooId barId -> + let o = $(parseObject "{ foo: { id: Int }, bar: { id: Int } }") [aesonQQ| + { + "foo": { "id": #{fooId} }, + "bar": { "id": #{barId} } + } + |] + getId :: Object [schema| { id: Int } |] -> Int + getId inner = [runGet| inner.id |] + in map getId [runGet| o.[foo, bar] |] === [fooId, barId] + + , testProperty "Extracted objects from tuple of keys can be queried further" $ \a b -> + let o = $(parseObject "{ foo: { a: Int }, bar: { b: Bool } }") [aesonQQ| + { + "foo": { "a": #{a} }, + "bar": { "b": #{b} } + } + |] + (foo, bar) = [runGet| o.(foo, bar) |] + in [runGet| foo.a |] === a .&&. [runGet| bar.b |] === b + + , testProperty "Extracted objects from union can be queried further" $ \x -> + let o = $(parseObject "{ foo: { x: Bool } | { x: Int } }") [aesonQQ| { "foo": { "x": #{x} } } |] + in case [runGet| o.foo |] of + There (Here foo) -> [runGet| foo.x |] === x + foo -> error $ "Unexpected failure: o.foo = " ++ show foo ++ ", x = " ++ show x + ] + +testInvalidExpressions :: TestTree +testInvalidExpressions = testGroup "Invalid expressions" + [ testParseError "Empty expression" "getqq_empty_expression.golden" + [getErr| |] + , testParseError "No operators" "getqq_no_operators.golden" + [getErr| o |] + , testParseError "Operators after tuple of keys" "getqq_ops_after_tuple.golden" + [getErr| o.(a,b).foo |] + , testParseError "Operators after list of keys" "getqq_ops_after_list.golden" + [getErr| o.[a,b].foo |] + ] + +testCompileTimeErrors :: TestTree +testCompileTimeErrors = testGroup "Compile-time errors" + [ testGoldenIO "Key not in schema" "getqq_missing_key.golden" $ + getCompileError "GetMissingKey" + ] + where + getCompileError name = do + let fp = "test/wont-compile/" ++ name ++ ".hs" + Hint.runInterpreter (Hint.loadModules [fp]) >>= \case + Left (Hint.WontCompile errors) -> return $ unlines $ map Hint.errMsg errors + Left e -> fail $ show e + Right _ -> fail "Compilation unexpectedly succeeded" + +{- Helpers -} + +instance Arbitrary Greeting where + arbitrary = elements [HELLO, GOODBYE] + +instance Arbitrary Coordinate where + arbitrary = Coordinate <$> arbitrary + +newtype UnicodeText = UnicodeText Text + deriving (Show) + +instance Arbitrary UnicodeText where + arbitrary = UnicodeText . Text.pack . getUnicodeString <$> arbitrary diff --git a/test/Tests/GetQQ/TH.hs b/test/Tests/GetQQ/TH.hs new file mode 100644 --- /dev/null +++ b/test/Tests/GetQQ/TH.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Tests.GetQQ.TH where + +import Control.DeepSeq (deepseq) +import Data.Aeson.QQ (aesonQQ) +import Language.Haskell.TH.Quote (QuasiQuoter(..)) +import Language.Haskell.TH.TestUtils + (MockedMode(..), QMode(..), QState(..), runTestQ, runTestQErr) + +import Data.Aeson.Schema (Object, get, schema) +import TestUtils (mkExpQQ, parseValue) +import TestUtils.DeepSeq () + +-- For testing namespaced object +testData :: Object [schema| { foo: Maybe Int } |] +testData = parseValue [aesonQQ| { "foo": null } |] + +qState :: QState 'FullyMocked +qState = QState + { mode = MockQ + , knownNames = [] + , reifyInfo = [] + } + +-- | Run the `get` quasiquoter at both runtime and compile-time, to get coverage. +-- +-- The `get` Quasiquoter doesn't reify anything, so this should work. +runGet :: QuasiQuoter +runGet = mkExpQQ $ \s -> [| runTestQ qState (quoteExp get s) `deepseq` $(quoteExp get s) |] + +getErr :: QuasiQuoter +getErr = mkExpQQ $ \s -> [| runTestQErr qState (quoteExp get s) |] diff --git a/test/Tests/MkGetter.hs b/test/Tests/MkGetter.hs new file mode 100644 --- /dev/null +++ b/test/Tests/MkGetter.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Tests.MkGetter where + +import Control.DeepSeq (deepseq) +import Data.Text (Text) +import Language.Haskell.TH.TestUtils + (QMode(..), QState(..), loadNames, runTestQ, runTestQErr) +import Test.Tasty +import Test.Tasty.HUnit +import Text.RawString.QQ (r) + +import Data.Aeson.Schema (Object, get, mkGetter, schema) +import TestUtils (json, showSchemaResult) +import TestUtils.DeepSeq () + +type MySchema = [schema| { users: List { name: Text } } |] + +mkGetter "User" "getUsers" ''MySchema ".users[]" + +test :: TestTree +test = runMkGetterQ `deepseq` testGroup "`mkGetter` helper" + [ testCase "Type synonym is generated" $ + showSchemaResult @User @?= [r|Object (SchemaObject { "name": Text })|] + + , testCase "Getter function is generated" $ + let users :: [User] + users = getUsers testData + + getName :: User -> Text + getName = [get| .name |] + + in map getName users @?= ["Alice", "Bob", "Claire"] + + , testCase "mkGetter expression should be a lambda expression" $ + let msg = runTestQErr qState $ mkGetter "User" "getUsers" ''MySchema "foo.users[]" + in msg @?= "Getter expression should start with '.': foo.users[]" + ] + where + qState = QState + { mode = MockQ + , knownNames = [] + , reifyInfo = $(loadNames [''MySchema]) + } + + -- run same mkGetter expression that was spliced, for coverage + runMkGetterQ = runTestQ qState $ mkGetter "User" "getUsers" ''MySchema ".users[]" + +testData :: Object MySchema +testData = [json| + { + "users": [ + { "name": "Alice" }, + { "name": "Bob" }, + { "name": "Claire" } + ] + } +|] diff --git a/test/Tests/Object.hs b/test/Tests/Object.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Object.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Tests.Object where + +import Data.Aeson (Value(..)) +import Data.Aeson.QQ (aesonQQ) +import qualified Data.HashMap.Lazy as HashMap +import Test.Tasty +import Test.Tasty.HUnit + +import Data.Aeson.Schema (Object, schema, toMap) +import qualified Tests.Object.Eq +import qualified Tests.Object.FromJSON +import qualified Tests.Object.Show +import qualified Tests.Object.ToJSON +import TestUtils (parseValue) + +test :: TestTree +test = testGroup "Object" + [ Tests.Object.Show.test + , Tests.Object.Eq.test + , Tests.Object.FromJSON.test + , Tests.Object.ToJSON.test + + , testCase "toMap smoketest" $ + let o :: Object [schema| { a: Bool } |] + o = parseValue [aesonQQ| { "a": true } |] + in toMap o @?= HashMap.fromList + [ ("a", Bool True) + ] + ] diff --git a/test/Tests/Object/Eq.hs b/test/Tests/Object/Eq.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Object/Eq.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} + +module Tests.Object.Eq where + +import Test.Tasty +import Test.Tasty.QuickCheck + +import TestUtils (parseProxy) +import TestUtils.Arbitrary (ArbitraryObject(..), forAllArbitraryObjects) + +test :: TestTree +test = testGroup "Eq instance" + [ testProperty "o === o" $ + $(forAllArbitraryObjects) $ \(ArbitraryObject proxy v _) -> + let o = either error id $ parseProxy proxy v + in o === o + ] diff --git a/test/Tests/Object/FromJSON.hs b/test/Tests/Object/FromJSON.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Object/FromJSON.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Tests.Object.FromJSON where + +import Data.Aeson (FromJSON(..), Value) +import Data.Aeson.QQ (aesonQQ) +import Data.Aeson.Types (parseEither) +import Data.Proxy (Proxy) +import Test.Tasty +import Test.Tasty.QuickCheck + +import Data.Aeson.Schema (Object) +import Tests.Object.FromJSON.TH +import TestUtils (parseProxy, testGolden) +import TestUtils.Arbitrary (ArbitraryObject(..), forAllArbitraryObjects) + +test :: TestTree +test = testGroup "FromJSON instance" $ + map runTestCase testCases ++ + [ testProperty "QuickCheck arbitrary Schema" $ + $(forAllArbitraryObjects) $ \(ArbitraryObject proxy v _) -> + case parseProxy proxy v of + Right _ -> property () + Left e -> error $ "Could not parse: " ++ e + ] + +testCases :: [FromJSONTestCase] +testCases = + [ CheckValid "Scalar valid" + [schemaProxy| { foo: Text } |] + $ \(s :: String) -> [aesonQQ| { "foo": #{s} } |] + , CheckError "Scalar invalid" "fromjson_scalar_invalid.golden" + [schemaProxy| { foo: Text } |] + [aesonQQ| { "foo": 1 } |] + + , CheckValid "Maybe valid" + [schemaProxy| { foo: Maybe Int } |] + $ \(x :: Maybe Int) -> [aesonQQ| { "foo": #{x} } |] + , CheckError "Maybe invalid" "fromjson_maybe_invalid.golden" + [schemaProxy| { foo: Maybe Int } |] + [aesonQQ| { "foo": true } |] + + , CheckValid "Try valid with valid parse" + [schemaProxy| { foo: Try Bool } |] + $ \(x :: Bool) -> [aesonQQ| { "foo": #{x} } |] + , CheckValid "Try valid with invalid parse" + [schemaProxy| { foo: Try Bool } |] + $ \(s :: String) -> [aesonQQ| { "foo": #{s} } |] + + , CheckValid "List valid" + [schemaProxy| { foo: List Double } |] + $ \(xs :: [Double]) -> [aesonQQ| { "foo": #{xs} } |] + , CheckError "List invalid" "fromjson_list_invalid.golden" + [schemaProxy| { foo: List Double } |] + [aesonQQ| { "foo": true } |] + , CheckError "List invalid inner" "fromjson_list_inner_invalid.golden" + [schemaProxy| { foo: List Double } |] + [aesonQQ| { "foo": [true] } |] + + , CheckError "Object invalid" "fromjson_object_invalid.golden" + [schemaProxy| { foo: Int } |] + [aesonQQ| 1 |] + , CheckError "Object invalid in later keys" "fromjson_object_later_keys_invalid.golden" + [schemaProxy| { foo: Int, bar: Int } |] + [aesonQQ| { "foo": 1, "bar": true } |] + + , CheckValid "Nested object valid" + [schemaProxy| { foo: { bar: Int } } |] + $ \(x :: Int) -> [aesonQQ| { "foo": { "bar": #{x} } } |] + , CheckError "Nested object invalid" "fromjson_nested_invalid.golden" + [schemaProxy| { foo: { bar: Int } } |] + [aesonQQ| { "foo": true } |] + , CheckError "Nested object invalid inner" "fromjson_nested_inner_invalid.golden" + [schemaProxy| { foo: { bar: Int } } |] + [aesonQQ| { "foo": { "bar": true } } |] + + , CheckValid "Union object valid" + [schemaProxy| { foo: Int | Text } |] + $ \(x :: Int) -> [aesonQQ| { "foo": #{x} } |] + , CheckError "Union object invalid" "fromjson_union_invalid.golden" + [schemaProxy| { foo: Int | Text } |] + [aesonQQ| { "foo": true } |] + + , CheckValid "Phantom key valid object" + [schemaProxy| { [foo]: { bar: Int } } |] + $ \(x :: Int) -> [aesonQQ| { "bar": #{x} } |] + , CheckValid "Phantom key valid non-object try" + [schemaProxy| { [foo]: Try Bool } |] + $ \(b :: Bool) -> [aesonQQ| { "bar": #{b} } |] + , CheckError "Phantom key invalid" "fromjson_phantom_invalid.golden" + [schemaProxy| { [foo]: { bar: Int } } |] + [aesonQQ| 1 |] + , CheckError "Phantom key missing inner" "fromjson_phantom_inner_missing.golden" + [schemaProxy| { [foo]: { bar: Int } } |] + [aesonQQ| { "foo": true } |] + , CheckError "Phantom key invalid inner" "fromjson_phantom_inner_invalid.golden" + [schemaProxy| { [foo]: { bar: Int } } |] + [aesonQQ| { "bar": true } |] + + , CheckError "Decode failure messages are truncated" "fromjson_error_messages_truncate.golden" + [schemaProxy| { foo: Int } |] + [aesonQQ| + { + "foo": [ + { "bar": 1, "baz": "a" }, + { "bar": 2, "baz": "b" }, + { "bar": 3, "baz": "c" }, + { "bar": 4, "baz": "d" } + ] + } + |] + ] + +{- Helpers -} + +data FromJSONTestCase where + CheckValid + :: (Arbitrary a, Show a, FromJSON (Object schema)) + => TestName -- ^ Name of test case + -> Proxy (Object schema) -- ^ The schema to parse with + -> (a -> Value) -- ^ A function that builds a Value that should satisfy the schema + -> FromJSONTestCase + + CheckError + :: (FromJSON (Object schema), Show (Object schema)) + => TestName -- ^ Name of test case + -> String -- ^ Name of golden file + -> Proxy (Object schema) -- ^ The schema to parse with + -> Value -- ^ The value that should fail parsing the given schema + -> FromJSONTestCase + +runTestCase :: FromJSONTestCase -> TestTree +runTestCase = \case + CheckValid name schema valueGen -> + testProperty name $ \a -> + case parse schema (valueGen a) of + Right _ -> () + Left e -> error $ "Unexpected failure: " ++ e + + CheckError name fp schema value -> + testGolden name fp $ + case parse schema value of + Right o -> error $ "Unexpectedly parsed: " ++ show o + Left e -> e + +parse :: FromJSON a => Proxy a -> Value -> Either String a +parse _ = parseEither parseJSON diff --git a/test/Tests/Object/FromJSON/TH.hs b/test/Tests/Object/FromJSON/TH.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Object/FromJSON/TH.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Tests.Object.FromJSON.TH where + +import Data.Proxy (Proxy(..)) +import Language.Haskell.TH.Quote (QuasiQuoter(quoteType)) + +import Data.Aeson.Schema (Object, schema) +import TestUtils (mkExpQQ) + +schemaProxy :: QuasiQuoter +schemaProxy = mkExpQQ $ \s -> + let schemaType = [t| Object $(quoteType schema s) |] + in [| Proxy :: Proxy $schemaType |] diff --git a/test/Tests/Object/Show.hs b/test/Tests/Object/Show.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Object/Show.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Tests.Object.Show where + +import Data.Aeson.QQ (aesonQQ) +import Data.String.Interpolate (i) +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +import Tests.Object.Show.TH +import TestUtils (parseObject) + +test :: TestTree +test = testGroup "Show instance" + [ testProperty "Scalar key" $ \(s :: String) -> + let o = $(parseObject "{ foo: Text }") [aesonQQ| { "foo": #{s} } |] + in show o === [i|{ "foo": #{show s} }|] + + , testProperty "Object with multiple keys" $ \(b :: Double, x :: Int) -> + let o = $(parseObject "{ foo: Double, bar: Int }") [aesonQQ| { "foo": #{b}, "bar": #{x} } |] + in show o === [i|{ "foo": #{show b}, "bar": #{show x} }|] + + , testProperty "Nested object" $ \(x :: Int) -> + let o = $(parseObject "{ foo: { bar: Int } }") [aesonQQ| { "foo": { "bar": #{x} } } |] + in show o === [i|{ "foo": { "bar": #{show x} } }|] + + , testProperty "Object with existing Maybe key" $ \(x :: Bool) -> + let o = $(parseObject "{ foo: Maybe Bool }") [aesonQQ| { "foo": #{x} } |] + in show o === [i|{ "foo": Just #{show x} }|] + + , testCase "Object with non-existing Maybe key" $ + let o = $(parseObject "{ foo: Maybe Double }") [aesonQQ| { "foo": null } |] + in show o @?= [i|{ "foo": Nothing }|] + + , testProperty "Object with valid Try key" $ \(b :: Bool) -> + let o = $(parseObject "{ foo: Try Bool }") [aesonQQ| { "foo": #{b} } |] + in show o === [i|{ "foo": Just #{show b} }|] + + , testProperty "Object with invalid Try key" $ \(x :: Int) -> + let o = $(parseObject "{ foo: Try Bool }") [aesonQQ| { "foo": #{x} } |] + in show o === [i|{ "foo": Nothing }|] + + , testProperty "Object with List key" $ \(x :: [Int]) -> + let o = $(parseObject "{ foo: List Int }") [aesonQQ| { "foo": #{x} } |] + in show o === [i|{ "foo": #{show x} }|] + + , testProperty "Object with Union key branch 0" $ \(Positive (x :: Int)) -> + let o = $(parseObject "{ foo: Int | Text }") [aesonQQ| { "foo": #{x} } |] + in show o === [i|{ "foo": Here #{show x} }|] + + , testProperty "Object with Union key branch 1" $ \(s :: String) -> + let o = $(parseObject "{ foo: Int | Text }") [aesonQQ| { "foo": #{s} } |] + in show o === [i|{ "foo": There (Here #{show s}) }|] + + , testProperty "Object with referenced Object" $ \(name :: String) -> + let o = $(parseObject "{ user: #UserSchema }") [aesonQQ| { "user": { "name": #{name} } } |] + in show o === [i|{ "user": { "name": #{show name} } }|] + + , testProperty "Object with extended Object" $ \(name :: String, age :: Int) -> + let o = $(parseObject "{ #UserSchema, age: Int }") [aesonQQ| { "name": #{name}, "age": #{age} } |] + in show o === [i|{ "name": #{show name}, "age": #{show age} }|] + + , testProperty "Object with Phantom key" $ \(x :: Int) -> + let o = $(parseObject "{ [foo]: { bar: Int } }") [aesonQQ| { "bar": #{x} } |] + in show o === [i|{ [foo]: { "bar": #{show x} } }|] + ] diff --git a/test/Tests/Object/Show/TH.hs b/test/Tests/Object/Show/TH.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Object/Show/TH.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE QuasiQuotes #-} + +module Tests.Object.Show.TH where + +import Data.Aeson.Schema (schema) + +type UserSchema = [schema| { name: Text } |] diff --git a/test/Tests/Object/ToJSON.hs b/test/Tests/Object/ToJSON.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Object/ToJSON.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Tests.Object.ToJSON where + +import Data.Aeson (FromJSON(..), ToJSON(..)) +import qualified Data.Aeson.Types as Aeson +import Test.Tasty +import Test.Tasty.QuickCheck + +import TestUtils (parseProxy) +import TestUtils.Arbitrary (ArbitraryObject(..), forAllArbitraryObjects) + +test :: TestTree +test = testGroup "ToJSON instance" + [ testProperty "parseJSON . toJSON === pure" $ + $(forAllArbitraryObjects) $ \(ArbitraryObject proxy v _) -> + let o = either error id $ parseProxy proxy v + in (parseJSON . toJSON) o === pure o + ] + +{- Realizing Aeson.Parser -} + +-- We're defining two Parsers to be equivalent if they evaluate to the same result. +instance Eq a => Eq (Aeson.Parser a) where + a == b = runParser a == runParser b + +instance Show a => Show (Aeson.Parser a) where + show = show . runParser + +runParser :: Aeson.Parser a -> Aeson.Result a +runParser = Aeson.parse id diff --git a/test/Tests/SchemaQQ.hs b/test/Tests/SchemaQQ.hs new file mode 100644 --- /dev/null +++ b/test/Tests/SchemaQQ.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} + +module Tests.SchemaQQ where + +import qualified Data.Text as Text +import Test.Tasty +import Test.Tasty.HUnit +import Text.RawString.QQ (r) + +import Tests.SchemaQQ.TH +import TestUtils (testParseError) + +test :: TestTree +test = testGroup "`schema` quasiquoter" + [ testValidSchemas + , testInvalidSchemas + , testKeys + ] + +testValidSchemas :: TestTree +testValidSchemas = testGroup "Valid schemas" + [ testCase "Object with Bool field" $ + assertMatches + [schemaRep| { a: Bool } |] + [r| SchemaObject { "a": Bool } |] + + , testCase "Object with Int field" $ + assertMatches + [schemaRep| { a: Int } |] + [r| SchemaObject { "a": Int } |] + + , testCase "Object with Double field" $ + assertMatches + [schemaRep| { foo123: Double } |] + [r| SchemaObject { "foo123": Double } |] + + , testCase "Object with Text field" $ + assertMatches + [schemaRep| { some_text: Text } |] + [r| SchemaObject { "some_text": Text } |] + + , testCase "Object with a field with a custom type" $ + assertMatches + [schemaRep| { status: Status } |] + [r| SchemaObject { "status": Status } |] + + , testCase "Object with a field with a Maybe type" $ + assertMatches + [schemaRep| { a: Maybe Bool } |] + [r| SchemaObject { "a": Maybe Bool } |] + + , testCase "Object with a field with a Try type" $ + assertMatches + [schemaRep| { a: Try Bool } |] + [r| SchemaObject { "a": Try Bool } |] + + , testCase "Object with a nested object" $ + assertMatches + [schemaRep| { a: { b: Int } } |] + [r| SchemaObject { "a": { "b": Int } } |] + + , testCase "Object with a nullable nested object" $ + assertMatches + [schemaRep| { a: Maybe { b: Int } } |] + [r| SchemaObject { "a": Maybe { "b": Int } } |] + + , testCase "Object with a list of nested objects" $ + assertMatches + [schemaRep| { a: List { b: Int } } |] + [r| SchemaObject { "a": List { "b": Int } } |] + + , testCase "Object with an imported schema" $ + assertMatches + [schemaRep| { user: #UserSchema } |] + [r| SchemaObject { "user": { "name": Text } } |] + + , testCase "Object with a qualified imported schema" $ + assertMatches + [schemaRep| { user: #(Tests.SchemaQQ.TH.UserSchema) } |] + [r| SchemaObject { "user": { "name": Text } } |] + + , testCase "Object with an imported schema that uses a non-imported type" $ + assertMatches + [schemaRep| { a: #SchemaWithHiddenImport } |] + [r| SchemaObject { "a": { "a": CBool } } |] + + , testCase "Object with an extended schema" $ + assertMatches + [schemaRep| { a: Int, #ExtraSchema } |] + [r| SchemaObject { "a": Int, "extra": Text } |] + + , testCase "Object with a qualified extended schema" $ + assertMatches + [schemaRep| { a: Int, #(Tests.SchemaQQ.TH.ExtraSchema) } |] + [r| SchemaObject { "a": Int, "extra": Text } |] + + , testCase "Object with an extended schema that uses a non-imported type" $ + assertMatches + [schemaRep| { #SchemaWithHiddenImport } |] + [r| SchemaObject { "a": CBool } |] + + , testCase "Object with an extended schema with a shadowed key" $ + assertMatches + [schemaRep| { extra: Bool, #ExtraSchema } |] + [r| SchemaObject { "extra": Bool } |] + + , testCase "Object with a qualified extended schema with a shadowed key" $ + assertMatches + [schemaRep| { extra: Bool, #(Tests.SchemaQQ.TH.ExtraSchema) } |] + [r| SchemaObject { "extra": Bool } |] + + , testCase "Object with a union field" $ + assertMatches + [schemaRep| { a: List Int | Text } |] + [r| SchemaObject { "a": ( List Int | Text ) } |] + + , testCase "Object with a union field with a group" $ + assertMatches + [schemaRep| { a: List (Int | Text) } |] + [r| SchemaObject { "a": List ( Int | Text ) } |] + + , testCase "Object with a phantom key for an object" $ + assertMatches + [schemaRep| { [a]: { b: Int } } |] + [r| SchemaObject { [a]: { "b": Int } } |] + + , testCase "Object with a phantom key for a Maybe" $ + assertMatches + [schemaRep| { [a]: Maybe { b: Int } } |] + [r| SchemaObject { [a]: Maybe { "b": Int } } |] + + , testCase "Object with a phantom key for a Try" $ + assertMatches + [schemaRep| { [a]: Try { b: Int } } |] + [r| SchemaObject { [a]: Try { "b": Int } } |] + + , testCase "Object with a phantom key for a non-object Try" $ + assertMatches + [schemaRep| { [a]: Try Bool } |] + [r| SchemaObject { [a]: Try Bool } |] + + , testCase "Object with a phantom key for a union of valid schemas" $ + assertMatches + [schemaRep| { [a]: { b: Int } | Int } |] + [r| SchemaObject { [a]: ( { "b": Int } | Int ) } |] + ] + +testInvalidSchemas :: TestTree +testInvalidSchemas = testGroup "Invalid schemas" + [ testCase "Object with a duplicate key" $ + [schemaErr| { a: Int, a: Bool } |] @?= "Key 'a' specified multiple times" + + , testCase "Object with a duplicate phantom key" $ + [schemaErr| { a: Int, [a]: { b: Bool } } |] @?= "Key 'a' specified multiple times" + + , testCase "Object with a duplicate key from extending" $ + [schemaErr| { #ExtraSchema, #ExtraSchema2 } |] @?= "Key 'extra' declared in multiple imported schemas" + + , testCase "Quasiquoter defining a non-object" $ + [schemaErr| List { a: Int } |] @?= "`schema` definition must be an object" + + , testCase "Object with a field with an unknown type" $ + [schemaErr| { a: HelloWorld } |] @?= "Unknown type: HelloWorld" + + , testCase "Object extending a non-schema" $ + [schemaErr| { #Int } |] @?= "'GHC.Types.Int' is not a Schema" + + , testCase "Object importing an unknown schema" $ + [schemaErr| { foo: #FooSchema } |] @?= "Unknown schema: FooSchema" + + , testCase "Object extending an unknown schema" $ + [schemaErr| { #FooSchema } |] @?= "Unknown schema: FooSchema" + + , testCase "Object with a phantom key for a scalar" $ + [schemaErr| { [a]: Int } |] @?= "Invalid schema for 'a': SchemaScalar Int" + + , testCase "Object with a phantom key for a list" $ + [schemaErr| { [a]: List Int } |] @?= "Invalid schema for 'a': SchemaList Int" + + , testCase "Object with a phantom key for a non-object Maybe" $ + [schemaErr| { [a]: Maybe Int } |] @?= "Invalid schema for 'a': SchemaMaybe Int" + + , testCase "Object with a phantom key for an invalid union" $ + [schemaErr| { [a]: Bool | Int } |] @?= "Invalid schema for 'a': SchemaUnion ( Bool | Int )" + ] + +testKeys :: TestTree +testKeys = testGroup "Keys in schemas" + [ testCase "Quoted key same as plain key" $ + [schemaRep| { a: Int } |] @?= [schemaRep| { "a": Int } |] + + , testParseError "Key with invalid character" "schemaqq_key_with_invalid_character.golden" + [schemaErr| { "a:b": Int } |] + + , testCase "Key with escaped invalid character" $ + assertMatches + [schemaRep| { "a\:b": Int } |] + [r| SchemaObject { "a:b": Int } |] + + , testParseError "Key with trailing escape" "schemaqq_key_with_trailing_escape.golden" + [schemaErr| { "a\": Int } |] + + , testCase "Quoted key that starts with '//'" $ + assertMatches + [schemaRep| { "//a": { b: Int } } |] + [r| SchemaObject { "//a": { "b": Int } } |] + + , testCase "Phantom key that starts with '//'" $ + assertMatches + [schemaRep| { [//a]: { b: Int } } |] + [r| SchemaObject { [//a]: { "b": Int } } |] + ] + +{- Helpers -} + +assertMatches :: String -> String -> Assertion +assertMatches a b = strip a @?= strip b + where + strip = Text.unpack . Text.strip . Text.pack diff --git a/test/Tests/SchemaQQ/TH.hs b/test/Tests/SchemaQQ/TH.hs new file mode 100644 --- /dev/null +++ b/test/Tests/SchemaQQ/TH.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Tests.SchemaQQ.TH where + +import Control.DeepSeq (deepseq) +import Data.Aeson (FromJSON, ToJSON) +import Foreign.C (CBool(..)) +import Language.Haskell.TH.Quote (QuasiQuoter(..)) +import Language.Haskell.TH.TestUtils + (MockedMode(..), QMode(..), QState(..), loadNames, runTestQ, runTestQErr) + +import Data.Aeson.Schema (schema) +import Data.Aeson.Schema.Internal (showSchemaType) +import Data.Aeson.Schema.Type (ToSchemaObject) +import TestUtils (mkExpQQ) +import TestUtils.DeepSeq () + +type UserSchema = [schema| { name: Text } |] +type ExtraSchema = [schema| { extra: Text } |] +type ExtraSchema2 = [schema| { extra: Maybe Text } |] + +newtype Status = Status Int + deriving (Show,FromJSON,ToJSON) + +-- | The type referenced here should not be imported in SchemaQQ.hs nor included in 'knownNames'. +type SchemaWithHiddenImport = [schema| { a: CBool } |] +deriving instance ToJSON CBool +deriving instance FromJSON CBool + +-- Compile above types before reifying +$(return []) + +qState :: QState 'FullyMocked +qState = QState + { mode = MockQ + , knownNames = + [ ("Status", ''Status) + , ("UserSchema", ''UserSchema) + , ("ExtraSchema", ''ExtraSchema) + , ("ExtraSchema2", ''ExtraSchema2) + , ("Tests.SchemaQQ.TH.UserSchema", ''UserSchema) + , ("Tests.SchemaQQ.TH.ExtraSchema", ''ExtraSchema) + , ("SchemaWithHiddenImport", ''SchemaWithHiddenImport) + , ("Int", ''Int) + ] + , reifyInfo = $(loadNames + [ ''UserSchema + , ''ExtraSchema + , ''ExtraSchema2 + , ''SchemaWithHiddenImport + , ''Int + ] + ) + } + +-- | A quasiquoter for generating the string representation of a schema. +-- +-- Also runs the `schema` quasiquoter at runtime, to get coverage information. +schemaRep :: QuasiQuoter +schemaRep = mkExpQQ $ \s -> + let schemaType = quoteType schema s + in [| runTestQ qState (quoteType schema s) `deepseq` showSchemaType @(ToSchemaObject $schemaType) |] + +schemaErr :: QuasiQuoter +schemaErr = mkExpQQ $ \s -> [| runTestQErr qState (quoteType schema s) |] diff --git a/test/Tests/SumType.hs b/test/Tests/SumType.hs new file mode 100644 --- /dev/null +++ b/test/Tests/SumType.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + +module Tests.SumType where + +import Data.Aeson (ToJSON, eitherDecode, encode) +import Data.Proxy (Proxy(..)) +import Data.String (fromString) +import Test.Tasty +import Test.Tasty.Golden +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +import Data.Aeson.Schema.Utils.Sum (SumType(..), fromSumType) + +type SpecialJSON = SumType '[Bool, Int, [String]] + +toSpecialJSON :: ToJSON a => a -> SpecialJSON +toSpecialJSON = either (error . ("Invalid SpecialJSON: " ++) . show) id . toSpecialJSON' + +toSpecialJSON' :: ToJSON a => a -> Either String SpecialJSON +toSpecialJSON' = eitherDecode . encode + +{- Tests -} + +test :: TestTree +test = testGroup "SumType" + [ testCase "Sanity checks" $ + -- this should compile + let values = + [ Here True + , Here False + , There (Here 1) + , There (Here 10) + , There (There (Here [])) + , There (There (Here ["a"])) + ] :: [SpecialJSON] + in values @?= values + , testDecode + , testFromSumType + ] + +testDecode :: TestTree +testDecode = testGroup "Decode SumType" + [ testProperty "branch 1" $ \(b :: Bool) -> + toSpecialJSON' b === Right (Here b) + , testProperty "branch 2" $ \(x :: Int) -> + toSpecialJSON' x === Right (There (Here x)) + , testProperty "branch 3" $ \(l :: [String]) -> + toSpecialJSON' l === Right (There (There (Here l))) + , goldenVsString "invalid SumType" "test/goldens/sumtype_decode_invalid.golden" $ + case toSpecialJSON' [True] of + Right v -> error $ "Unexpectedly decoded value: " ++ show v + Left e -> pure $ fromString e + ] + +testFromSumType :: TestTree +testFromSumType = testGroup "fromSumType" + [ testProperty "branch 0 valid" $ \b -> + fromSumType (Proxy @0) (toSpecialJSON b) === Just b + , testProperty "branch 0 invalid" $ + forAll (specialJSONExcept 0) $ \(branch, value) -> + labelBranch branch $ fromSumType (Proxy @0) value === Nothing + + , testProperty "branch 1 valid" $ \x -> + fromSumType (Proxy @1) (toSpecialJSON x) === Just x + , testProperty "branch 1 invalid" $ + forAll (specialJSONExcept 1) $ \(branch, value) -> + labelBranch branch $ fromSumType (Proxy @1) value === Nothing + + , testProperty "branch 2 valid" $ \l -> + fromSumType (Proxy @2) (toSpecialJSON l) === Just l + , testProperty "branch 2 invalid" $ + forAll (specialJSONExcept 2) $ \(branch, value) -> + labelBranch branch $ fromSumType (Proxy @2) value === Nothing + ] + where + specialJSONExcept :: Int -> Gen (Int, SpecialJSON) + specialJSONExcept validBranch = + let fmapFst (a, gen) = (a,) <$> gen + in oneof $ map fmapFst $ filter ((/= validBranch) . fst) + [ (0, toSpecialJSON <$> arbitrary @Bool) + , (1, toSpecialJSON <$> arbitrary @Int) + , (2, toSpecialJSON <$> arbitrary @[String]) + ] + + labelBranch branch = label $ "branch " ++ show branch diff --git a/test/Tests/UnwrapQQ.hs b/test/Tests/UnwrapQQ.hs new file mode 100644 --- /dev/null +++ b/test/Tests/UnwrapQQ.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} + +module Tests.UnwrapQQ where + +import qualified Data.Text as Text +import Test.Tasty +import Test.Tasty.HUnit +import Text.RawString.QQ (r) + +import Data.Aeson.Schema (Object, get) +import Tests.UnwrapQQ.TH +import TestUtils (json, testParseError) + +test :: TestTree +test = testGroup "`unwrap` quasiquoter" + [ testValidUnwrapDefs + , testInvalidUnwrapDefs + ] + +testValidUnwrapDefs :: TestTree +testValidUnwrapDefs = testGroup "Valid unwrap definitions" + [ testCase "Can unwrap a list" $ do + [unwrapRep| ListSchema.ids |] @?= "[Int]" + [unwrapRep| ListSchema.ids[] |] @?= "Int" + + , testCase "Can unwrap a list of keys" $ + [unwrapRep| ABCSchema.[a, b] |] @?= "[Bool]" + + , testCase "Can unwrap a tuple of keys" $ + [unwrapRep| ABCSchema.(a, b, c) |] @?= "(Bool,Bool,Double)" + + , testCase "Can unwrap a maybe" $ do + [unwrapRep| MaybeSchema.class |] @?= "Maybe Text" + [unwrapRep| MaybeSchema.class! |] @?= "Text" + [unwrapRep| MaybeSchema.class? |] @?= "Text" + + , testCase "Can unwrap a sum type" $ do + [unwrapRep| SumSchema.verbosity@0 |] @?= "Int" + [unwrapRep| SumSchema.verbosity@1 |] @?= "Bool" + + , testCase "Can unwrap an included schema" $ + [unwrapRep| ListSchema2.list.ids |] @?= "[Int]" + + , testCase "Can unwrap an Object twice" $ + [unwrapRep| UnwrappedNestedSchema.b |] @?= "Object (SchemaObject { \"c\": Bool })" + + , testCase "Can use unwrapped type" $ do + let result :: Object MySchema + result = [json| + { + "users": [ + { "name": "Alice" }, + { "name": "Bob" }, + { "name": "Claire" } + ] + } + |] + + users :: [User] + users = [get| result.users |] + + getName :: User -> String + getName = Text.unpack . [get| .name |] + + map getName users @?= ["Alice", "Bob", "Claire"] + ] + +testInvalidUnwrapDefs :: TestTree +testInvalidUnwrapDefs = testGroup "Invalid unwrap definitions" + [ testCase "Unwrap unknown schema" $ + [unwrapErr| FooSchema.asdf |] @?= "Unknown schema: FooSchema" + + , testCase "Unwrap non-schema" $ + [unwrapErr| NotASchema.foo |] @?= "'Tests.UnwrapQQ.TH.NotASchema' is not a Schema" + + , testCase "Unwrap key on non-object" $ + [unwrapErr| ListSchema.ids.foo |] @?= "Cannot get key 'foo' in schema: SchemaList Int" + + , testCase "Unwrap maybe on non-maybe" $ do + [unwrapErr| ListSchema.ids! |] @?= "Cannot use `!` operator on schema: SchemaList Int" + [unwrapErr| ListSchema.ids? |] @?= "Cannot use `?` operator on schema: SchemaList Int" + + , testCase "Unwrap list on non-list" $ + [unwrapErr| MaybeSchema.class[] |] @?= "Cannot use `[]` operator on schema: SchemaMaybe Text" + + , testCase "Unwrap nonexistent key" $ + [unwrapErr| ListSchema.foo |] @?= [r|Key 'foo' does not exist in schema: SchemaObject { "ids": List Int }|] + + , testCase "Unwrap list of keys with different types" $ + [unwrapErr| ABCSchema.[a,b,c] |] @?= [r|List contains different types in schema: SchemaObject { "a": Bool, "b": Bool, "c": Double }|] + + , testCase "Unwrap list of keys on non-object schema" $ + [unwrapErr| ListSchema.ids.[a,b] |] @?= "Cannot get keys in schema: SchemaList Int" + + , testParseError "Unwrap beyond list of keys" "unwrapqq_unwrap_past_list.golden" + [unwrapErr| ABCSchema.[a,b].foo |] + + , testCase "Unwrap tuple of keys on non-object schema" $ + [unwrapErr| ListSchema.ids.(a,b) |] @?= "Cannot get keys in schema: SchemaList Int" + + , testParseError "Unwrap beyond tuple of keys" "unwrapqq_unwrap_past_tuple.golden" + [unwrapErr| ABCSchema.(a,b).foo |] + + , testCase "Unwrap branch on non-branch" $ + [unwrapErr| MaybeSchema.class@0 |] @?= "Cannot use `@` operator on schema: SchemaMaybe Text" + + , testCase "Unwrap out of bounds branch" $ + [unwrapErr| SumSchema.verbosity@10 |] @?= "Branch out of bounds for schema: SchemaUnion ( Int | Bool )" + ] diff --git a/test/Tests/UnwrapQQ/TH.hs b/test/Tests/UnwrapQQ/TH.hs new file mode 100644 --- /dev/null +++ b/test/Tests/UnwrapQQ/TH.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Tests.UnwrapQQ.TH where + +import Control.DeepSeq (deepseq) +import Language.Haskell.TH (appTypeE) +import Language.Haskell.TH.Quote (QuasiQuoter(..)) +import Language.Haskell.TH.TestUtils + (MockedMode(..), QMode(..), QState(..), loadNames, runTestQ, runTestQErr) + +import Data.Aeson.Schema (schema, unwrap) +import TestUtils (ShowSchemaResult(..), mkExpQQ) +import TestUtils.DeepSeq () + +type ListSchema = [schema| { ids: List Int } |] +type MaybeSchema = [schema| { class: Maybe Text } |] +type SumSchema = [schema| { verbosity: Int | Bool } |] +type ABCSchema = [schema| + { + a: Bool, + b: Bool, + c: Double, + } +|] + +type NestedSchema = [schema| + { + a: { + b: { + c: Bool, + }, + }, + } +|] + +type MySchema = [schema| + { + users: List { + name: Text, + }, + } +|] + +-- Compile above schemas before these schemas +$(return []) + +type ListSchema2 = [schema| { list: #ListSchema } |] +type User = [unwrap| MySchema.users[] |] +type UnwrappedNestedSchema = [unwrap| NestedSchema.a |] + +type NotASchema = Int + +-- Compile above types before reifying +$(return []) + +qState :: QState 'FullyMocked +qState = QState + { mode = MockQ + , knownNames = + [ ("ListSchema", ''ListSchema) + , ("ListSchema2", ''ListSchema2) + , ("MaybeSchema", ''MaybeSchema) + , ("SumSchema", ''SumSchema) + , ("ABCSchema", ''ABCSchema) + , ("NotASchema", ''NotASchema) + , ("UnwrappedNestedSchema", ''UnwrappedNestedSchema) + ] + , reifyInfo = $( + loadNames + [ ''ListSchema + , ''ListSchema2 + , ''MaybeSchema + , ''SumSchema + , ''ABCSchema + , ''NotASchema + , ''MySchema + , ''UnwrappedNestedSchema + ] + ) + } + +-- | A quasiquoter for generating the string representation of an unwrapped schema. +-- +-- Also runs the `unwrap` quasiquoter at runtime, to get coverage information. +unwrapRep :: QuasiQuoter +unwrapRep = mkExpQQ $ \s -> + let showSchemaResultQ = appTypeE [| showSchemaResult |] (quoteType unwrap s) + in [| runTestQ qState (quoteType unwrap s) `deepseq` $showSchemaResultQ |] + +unwrapErr :: QuasiQuoter +unwrapErr = mkExpQQ $ \s -> [| runTestQErr qState (quoteType unwrap s) |] diff --git a/test/Util.hs b/test/Util.hs deleted file mode 100644 --- a/test/Util.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} - -module Util where - -import Control.Exception (SomeException, try) -import Control.Monad ((<=<)) -import Data.Aeson (eitherDecode) -import qualified Data.ByteString.Lazy as ByteStringL -import qualified Data.ByteString.Lazy.Char8 as Char8L -import Data.List (isPrefixOf) -import Language.Haskell.TH -import Language.Haskell.TH.Quote (QuasiQuoter(..)) -import Language.Haskell.TH.Syntax (lift) - -import Data.Aeson.Schema (Object, get, schema, unwrap) -import qualified Data.Aeson.Schema.Internal as Internal - -getMockedResult :: FilePath -> ExpQ -getMockedResult fp = do - contents <- runIO $ ByteStringL.readFile fp - [| either error id $ eitherDecode $ Char8L.pack $(lift $ Char8L.unpack contents) |] - --- | Show the expression generated by passing the given string to the 'get' quasiquoter. -showGet :: String -> ExpQ -showGet = lift . pprint <=< quoteExp get - --- | Show the type generated by passing the given string to the 'unwrap' quasiquoter. -showUnwrap :: String -> ExpQ -showUnwrap = showType <=< quoteType unwrap - --- | Show the type generated by passing the given string to the 'schema' quasiquoter. -showSchema :: String -> ExpQ -showSchema = showSchemaType <=< quoteType schema - -showType :: Type -> ExpQ -showType = \case - AppT (ConT name) schema' | name == ''Object -> [| "Object (" ++ $(showSchemaType schema') ++ ")" |] - ty -> lift $ pprint ty - -showSchemaType :: Type -> ExpQ -showSchemaType = appTypeE [| Internal.showSchema |] . pure - --- | Return the 'error' message thrown when evaluating the given expresssion. -getError :: a -> ExpQ -getError x = runIO (try $ x `seq` pure ()) >>= \case - Right _ -> fail "'getError' expression unexpectedly succeeded" - Left e -> lift . unlines . stripCallStack . lines . show $ (e :: SomeException) - where - stripCallStack [] = [] - stripCallStack (l:ls) = if "CallStack" `isPrefixOf` l - then [] - else l : stripCallStack ls diff --git a/test/all_types.json b/test/all_types.json deleted file mode 100644 --- a/test/all_types.json +++ /dev/null @@ -1,47 +0,0 @@ -{ - "bool": true, - "int": 1, - "int2": 2, - "double": 2.5, - "text": "asdf", - "scalar": "12,34", - "enum": "HELLO", - "maybeObject": { - "text": "foo" - }, - "maybeObjectNull": null, - "maybeList": [ - { - "text": "foo" - }, - { - "text": "bar" - } - ], - "maybeListNull": null, - "tryObject": { - "a": 1 - }, - "tryObjectNull": true, - "list": [ - { - "type": "bool", - "maybeBool": true - }, - { - "type": "int", - "maybeInt": 2 - }, - { - "type": "null", - "maybeNull": null - } - ], - "union": [ - "Hello", - { "a": 1 }, - [true, false], - "World!" - ], - "keyForPhantom": 1 -} diff --git a/test/goldens/README_Quickstart.golden b/test/goldens/README_Quickstart.golden --- a/test/goldens/README_Quickstart.golden +++ b/test/goldens/README_Quickstart.golden @@ -2,7 +2,7 @@ Details for user #1: * Name: Alice * Age: 30 -* Groups: [{"id": 1, "name": "admin"}] +* Groups: [{ "id": 1, "name": "admin" }] Details for user #2: * Name: Bob * Age: N/A @@ -14,4 +14,4 @@ Details for user #4: * Name: Darlene * Age: 40 -* Groups: [{"id": 2, "name": "groupA"},{"id": 3, "name": "groupB"}] +* Groups: [{ "id": 2, "name": "groupA" },{ "id": 3, "name": "groupB" }] diff --git a/test/goldens/bool.golden b/test/goldens/bool.golden deleted file mode 100644 --- a/test/goldens/bool.golden +++ /dev/null @@ -1,1 +0,0 @@ -True diff --git a/test/goldens/bool_int_double.golden b/test/goldens/bool_int_double.golden deleted file mode 100644 --- a/test/goldens/bool_int_double.golden +++ /dev/null @@ -1,1 +0,0 @@ -(True,1,2.5) diff --git a/test/goldens/double.golden b/test/goldens/double.golden deleted file mode 100644 --- a/test/goldens/double.golden +++ /dev/null @@ -1,1 +0,0 @@ -2.5 diff --git a/test/goldens/enum.golden b/test/goldens/enum.golden deleted file mode 100644 --- a/test/goldens/enum.golden +++ /dev/null @@ -1,1 +0,0 @@ -HELLO diff --git a/test/goldens/from_object_all_types.golden b/test/goldens/from_object_all_types.golden deleted file mode 100644 --- a/test/goldens/from_object_all_types.golden +++ /dev/null @@ -1,1 +0,0 @@ -["True","2","Nothing"] diff --git a/test/goldens/from_object_namespaced.golden b/test/goldens/from_object_namespaced.golden deleted file mode 100644 --- a/test/goldens/from_object_namespaced.golden +++ /dev/null @@ -1,1 +0,0 @@ -["bool","int","null","1","3"] diff --git a/test/goldens/from_object_nested.golden b/test/goldens/from_object_nested.golden deleted file mode 100644 --- a/test/goldens/from_object_nested.golden +++ /dev/null @@ -1,1 +0,0 @@ -[1,2] diff --git a/test/goldens/fromjson_error_messages_truncate.golden b/test/goldens/fromjson_error_messages_truncate.golden new file mode 100644 --- /dev/null +++ b/test/goldens/fromjson_error_messages_truncate.golden @@ -0,0 +1,1 @@ +Error in $: Could not parse path 'foo' with schema `SchemaScalar Int`: Array [Object (fromList [("baz",String "a"),("bar",Number 1.0)]),Object (fromList [("baz",String "b"),("bar",Number 2.0)]),Object (fromList [("baz",String "c"),("bar",Number 3.0)]),Object (fromList [(... diff --git a/test/goldens/fromjson_list_inner_invalid.golden b/test/goldens/fromjson_list_inner_invalid.golden new file mode 100644 --- /dev/null +++ b/test/goldens/fromjson_list_inner_invalid.golden @@ -0,0 +1,1 @@ +Error in $: Could not parse path 'foo' with schema `SchemaScalar Double`: Bool True diff --git a/test/goldens/fromjson_list_invalid.golden b/test/goldens/fromjson_list_invalid.golden new file mode 100644 --- /dev/null +++ b/test/goldens/fromjson_list_invalid.golden @@ -0,0 +1,1 @@ +Error in $: Could not parse path 'foo' with schema `SchemaList Double`: Bool True diff --git a/test/goldens/fromjson_maybe_invalid.golden b/test/goldens/fromjson_maybe_invalid.golden new file mode 100644 --- /dev/null +++ b/test/goldens/fromjson_maybe_invalid.golden @@ -0,0 +1,1 @@ +Error in $: Could not parse path 'foo' with schema `SchemaScalar Int`: Bool True diff --git a/test/goldens/fromjson_nested_inner_invalid.golden b/test/goldens/fromjson_nested_inner_invalid.golden new file mode 100644 --- /dev/null +++ b/test/goldens/fromjson_nested_inner_invalid.golden @@ -0,0 +1,1 @@ +Error in $: Could not parse path 'foo.bar' with schema `SchemaScalar Int`: Bool True diff --git a/test/goldens/fromjson_nested_invalid.golden b/test/goldens/fromjson_nested_invalid.golden new file mode 100644 --- /dev/null +++ b/test/goldens/fromjson_nested_invalid.golden @@ -0,0 +1,1 @@ +Error in $: Could not parse path 'foo' with schema `SchemaObject { "bar": Int }`: Bool True diff --git a/test/goldens/fromjson_object_invalid.golden b/test/goldens/fromjson_object_invalid.golden new file mode 100644 --- /dev/null +++ b/test/goldens/fromjson_object_invalid.golden @@ -0,0 +1,1 @@ +Error in $: Could not parse schema `SchemaObject { "foo": Int }`: Number 1.0 diff --git a/test/goldens/fromjson_object_later_keys_invalid.golden b/test/goldens/fromjson_object_later_keys_invalid.golden new file mode 100644 --- /dev/null +++ b/test/goldens/fromjson_object_later_keys_invalid.golden @@ -0,0 +1,1 @@ +Error in $: Could not parse path 'bar' with schema `SchemaScalar Int`: Bool True diff --git a/test/goldens/fromjson_phantom_inner_invalid.golden b/test/goldens/fromjson_phantom_inner_invalid.golden new file mode 100644 --- /dev/null +++ b/test/goldens/fromjson_phantom_inner_invalid.golden @@ -0,0 +1,1 @@ +Error in $: Could not parse path 'foo.bar' with schema `SchemaScalar Int`: Bool True diff --git a/test/goldens/fromjson_phantom_inner_missing.golden b/test/goldens/fromjson_phantom_inner_missing.golden new file mode 100644 --- /dev/null +++ b/test/goldens/fromjson_phantom_inner_missing.golden @@ -0,0 +1,1 @@ +Error in $: Could not parse path 'foo.bar' with schema `SchemaScalar Int`: Null diff --git a/test/goldens/fromjson_phantom_invalid.golden b/test/goldens/fromjson_phantom_invalid.golden new file mode 100644 --- /dev/null +++ b/test/goldens/fromjson_phantom_invalid.golden @@ -0,0 +1,1 @@ +Error in $: Could not parse schema `SchemaObject { [foo]: { "bar": Int } }`: Number 1.0 diff --git a/test/goldens/fromjson_scalar_invalid.golden b/test/goldens/fromjson_scalar_invalid.golden new file mode 100644 --- /dev/null +++ b/test/goldens/fromjson_scalar_invalid.golden @@ -0,0 +1,1 @@ +Error in $: Could not parse path 'foo' with schema `SchemaScalar Text`: Number 1.0 diff --git a/test/goldens/fromjson_union_invalid.golden b/test/goldens/fromjson_union_invalid.golden new file mode 100644 --- /dev/null +++ b/test/goldens/fromjson_union_invalid.golden @@ -0,0 +1,1 @@ +Error in $: Could not parse path 'foo' with schema `SchemaUnion ( Int | Text )`: Bool True diff --git a/test/goldens/get_empty.golden b/test/goldens/get_empty.golden deleted file mode 100644 --- a/test/goldens/get_empty.golden +++ /dev/null @@ -1,6 +0,0 @@ -1:1: - | -1 | - | ^ -unexpected end of input -expecting "[]", '!', '(', '.', '?', '@', '[', lowercase letter, or white space diff --git a/test/goldens/get_just_start.golden b/test/goldens/get_just_start.golden deleted file mode 100644 --- a/test/goldens/get_just_start.golden +++ /dev/null @@ -1,6 +0,0 @@ -allTypes:1:9: - | -1 | allTypes - | ^ -unexpected end of input -expecting "[]", '!', ''', '(', '.', '?', '@', '[', or alphanumeric character diff --git a/test/goldens/get_ops_after_list.golden b/test/goldens/get_ops_after_list.golden deleted file mode 100644 --- a/test/goldens/get_ops_after_list.golden +++ /dev/null @@ -1,1 +0,0 @@ -.[*] operation MUST be last. diff --git a/test/goldens/get_ops_after_tuple.golden b/test/goldens/get_ops_after_tuple.golden deleted file mode 100644 --- a/test/goldens/get_ops_after_tuple.golden +++ /dev/null @@ -1,1 +0,0 @@ -.(*) operation MUST be last. diff --git a/test/goldens/getqq_empty_expression.golden b/test/goldens/getqq_empty_expression.golden new file mode 100644 --- /dev/null +++ b/test/goldens/getqq_empty_expression.golden @@ -0,0 +1,5 @@ + :1:2: + | +1 | + | ^ +expecting "[]", '!', '"', '(', '.', '?', '@', '[', '\', lowercase letter, or white space diff --git a/test/goldens/getqq_missing_key.golden b/test/goldens/getqq_missing_key.golden new file mode 100644 --- /dev/null +++ b/test/goldens/getqq_missing_key.golden @@ -0,0 +1,12 @@ +test/wont-compile/GetMissingKey.hs:16:1: error: + • Key 'missing' does not exist in the following schema: + '[ '( 'Data.Aeson.Schema.Key.NormalKey "foo", + 'Data.Aeson.Schema.Type.SchemaScalar Bool)] + • When checking the inferred type + result :: Data.Aeson.Schema.Internal.SchemaResult (TypeError ...) +test/wont-compile/GetMissingKey.hs:16:1: error: + • Key 'missing' does not exist in the following schema: + '[ '( 'Data.Aeson.Schema.Key.NormalKey "foo", + 'Data.Aeson.Schema.Type.SchemaScalar Bool)] + • When checking the inferred type + result :: Data.Aeson.Schema.Internal.SchemaResult (TypeError ...) diff --git a/test/goldens/getqq_no_operators.golden b/test/goldens/getqq_no_operators.golden new file mode 100644 --- /dev/null +++ b/test/goldens/getqq_no_operators.golden @@ -0,0 +1,5 @@ + o :1:3: + | +1 | o + | ^ +expecting "[]", '!', '"', ''', '(', '.', '?', '@', '[', '\', or alphanumeric character diff --git a/test/goldens/getqq_ops_after_list.golden b/test/goldens/getqq_ops_after_list.golden new file mode 100644 --- /dev/null +++ b/test/goldens/getqq_ops_after_list.golden @@ -0,0 +1,6 @@ + o.[a,b].foo :1:9: + | +1 | o.[a,b].foo + | ^ +unexpected '.' +expecting end of input or white space diff --git a/test/goldens/getqq_ops_after_tuple.golden b/test/goldens/getqq_ops_after_tuple.golden new file mode 100644 --- /dev/null +++ b/test/goldens/getqq_ops_after_tuple.golden @@ -0,0 +1,6 @@ + o.(a,b).foo :1:9: + | +1 | o.(a,b).foo + | ^ +unexpected '.' +expecting end of input or white space diff --git a/test/goldens/getter_all_types_list.golden b/test/goldens/getter_all_types_list.golden deleted file mode 100644 --- a/test/goldens/getter_all_types_list.golden +++ /dev/null @@ -1,1 +0,0 @@ -[{"type": "bool", "maybeBool": Just True, "maybeInt": Nothing, "maybeNull": Nothing},{"type": "int", "maybeBool": Nothing, "maybeInt": Just 2, "maybeNull": Nothing},{"type": "null", "maybeBool": Nothing, "maybeInt": Nothing, "maybeNull": Nothing}] diff --git a/test/goldens/getter_all_types_list_item.golden b/test/goldens/getter_all_types_list_item.golden deleted file mode 100644 --- a/test/goldens/getter_all_types_list_item.golden +++ /dev/null @@ -1,1 +0,0 @@ -["bool","int","null"] diff --git a/test/goldens/int.golden b/test/goldens/int.golden deleted file mode 100644 --- a/test/goldens/int.golden +++ /dev/null @@ -1,1 +0,0 @@ -1 diff --git a/test/goldens/int_int2.golden b/test/goldens/int_int2.golden deleted file mode 100644 --- a/test/goldens/int_int2.golden +++ /dev/null @@ -1,1 +0,0 @@ -[1,2] diff --git a/test/goldens/lambda_bool.golden b/test/goldens/lambda_bool.golden deleted file mode 100644 --- a/test/goldens/lambda_bool.golden +++ /dev/null @@ -1,1 +0,0 @@ -True diff --git a/test/goldens/list.golden b/test/goldens/list.golden deleted file mode 100644 --- a/test/goldens/list.golden +++ /dev/null @@ -1,1 +0,0 @@ -[{"type": "bool", "maybeBool": Just True, "maybeInt": Nothing, "maybeNull": Nothing},{"type": "int", "maybeBool": Nothing, "maybeInt": Just 2, "maybeNull": Nothing},{"type": "null", "maybeBool": Nothing, "maybeInt": Nothing, "maybeNull": Nothing}] diff --git a/test/goldens/list_explicit.golden b/test/goldens/list_explicit.golden deleted file mode 100644 --- a/test/goldens/list_explicit.golden +++ /dev/null @@ -1,1 +0,0 @@ -[{"type": "bool", "maybeBool": Just True, "maybeInt": Nothing, "maybeNull": Nothing},{"type": "int", "maybeBool": Nothing, "maybeInt": Just 2, "maybeNull": Nothing},{"type": "null", "maybeBool": Nothing, "maybeInt": Nothing, "maybeNull": Nothing}] diff --git a/test/goldens/list_maybeBool.golden b/test/goldens/list_maybeBool.golden deleted file mode 100644 --- a/test/goldens/list_maybeBool.golden +++ /dev/null @@ -1,1 +0,0 @@ -[Just True,Nothing,Nothing] diff --git a/test/goldens/list_maybeInt.golden b/test/goldens/list_maybeInt.golden deleted file mode 100644 --- a/test/goldens/list_maybeInt.golden +++ /dev/null @@ -1,1 +0,0 @@ -[Nothing,Just 2,Nothing] diff --git a/test/goldens/list_type.golden b/test/goldens/list_type.golden deleted file mode 100644 --- a/test/goldens/list_type.golden +++ /dev/null @@ -1,1 +0,0 @@ -["bool","int","null"] diff --git a/test/goldens/maybeList.golden b/test/goldens/maybeList.golden deleted file mode 100644 --- a/test/goldens/maybeList.golden +++ /dev/null @@ -1,1 +0,0 @@ -Just [{"text": "foo"},{"text": "bar"}] diff --git a/test/goldens/maybeListNull.golden b/test/goldens/maybeListNull.golden deleted file mode 100644 --- a/test/goldens/maybeListNull.golden +++ /dev/null @@ -1,1 +0,0 @@ -Nothing diff --git a/test/goldens/maybeListNull_bang.golden b/test/goldens/maybeListNull_bang.golden deleted file mode 100644 --- a/test/goldens/maybeListNull_bang.golden +++ /dev/null @@ -1,1 +0,0 @@ -Called 'fromJust' on null expression: (AllTypes.result).maybeListNull diff --git a/test/goldens/maybeListNull_list.golden b/test/goldens/maybeListNull_list.golden deleted file mode 100644 --- a/test/goldens/maybeListNull_list.golden +++ /dev/null @@ -1,1 +0,0 @@ -Nothing diff --git a/test/goldens/maybeListNull_list_text.golden b/test/goldens/maybeListNull_list_text.golden deleted file mode 100644 --- a/test/goldens/maybeListNull_list_text.golden +++ /dev/null @@ -1,1 +0,0 @@ -Nothing diff --git a/test/goldens/maybeList_bang.golden b/test/goldens/maybeList_bang.golden deleted file mode 100644 --- a/test/goldens/maybeList_bang.golden +++ /dev/null @@ -1,1 +0,0 @@ -[{"text": "foo"},{"text": "bar"}] diff --git a/test/goldens/maybeList_bang_list.golden b/test/goldens/maybeList_bang_list.golden deleted file mode 100644 --- a/test/goldens/maybeList_bang_list.golden +++ /dev/null @@ -1,1 +0,0 @@ -[{"text": "foo"},{"text": "bar"}] diff --git a/test/goldens/maybeList_bang_list_text.golden b/test/goldens/maybeList_bang_list_text.golden deleted file mode 100644 --- a/test/goldens/maybeList_bang_list_text.golden +++ /dev/null @@ -1,1 +0,0 @@ -["foo","bar"] diff --git a/test/goldens/maybeList_list.golden b/test/goldens/maybeList_list.golden deleted file mode 100644 --- a/test/goldens/maybeList_list.golden +++ /dev/null @@ -1,1 +0,0 @@ -Just [{"text": "foo"},{"text": "bar"}] diff --git a/test/goldens/maybeList_list_text.golden b/test/goldens/maybeList_list_text.golden deleted file mode 100644 --- a/test/goldens/maybeList_list_text.golden +++ /dev/null @@ -1,1 +0,0 @@ -Just ["foo","bar"] diff --git a/test/goldens/maybeObj.golden b/test/goldens/maybeObj.golden deleted file mode 100644 --- a/test/goldens/maybeObj.golden +++ /dev/null @@ -1,1 +0,0 @@ -Just {"text": "foo"} diff --git a/test/goldens/maybeObjNull.golden b/test/goldens/maybeObjNull.golden deleted file mode 100644 --- a/test/goldens/maybeObjNull.golden +++ /dev/null @@ -1,1 +0,0 @@ -Nothing diff --git a/test/goldens/maybeObjNull_text.golden b/test/goldens/maybeObjNull_text.golden deleted file mode 100644 --- a/test/goldens/maybeObjNull_text.golden +++ /dev/null @@ -1,1 +0,0 @@ -Nothing diff --git a/test/goldens/maybeObj_bang.golden b/test/goldens/maybeObj_bang.golden deleted file mode 100644 --- a/test/goldens/maybeObj_bang.golden +++ /dev/null @@ -1,1 +0,0 @@ -{"text": "foo"} diff --git a/test/goldens/maybeObj_bang_text.golden b/test/goldens/maybeObj_bang_text.golden deleted file mode 100644 --- a/test/goldens/maybeObj_bang_text.golden +++ /dev/null @@ -1,1 +0,0 @@ -"foo" diff --git a/test/goldens/maybeObj_text.golden b/test/goldens/maybeObj_text.golden deleted file mode 100644 --- a/test/goldens/maybeObj_text.golden +++ /dev/null @@ -1,1 +0,0 @@ -Just "foo" diff --git a/test/goldens/nonexistent.golden b/test/goldens/nonexistent.golden deleted file mode 100644 --- a/test/goldens/nonexistent.golden +++ /dev/null @@ -1,1 +0,0 @@ -Nothing diff --git a/test/goldens/phantom.golden b/test/goldens/phantom.golden deleted file mode 100644 --- a/test/goldens/phantom.golden +++ /dev/null @@ -1,1 +0,0 @@ -1 diff --git a/test/goldens/scalar.golden b/test/goldens/scalar.golden deleted file mode 100644 --- a/test/goldens/scalar.golden +++ /dev/null @@ -1,1 +0,0 @@ -Coordinate (12,34) diff --git a/test/goldens/schema_def_bool.golden b/test/goldens/schema_def_bool.golden deleted file mode 100644 --- a/test/goldens/schema_def_bool.golden +++ /dev/null @@ -1,1 +0,0 @@ -SchemaObject {"a": Bool} diff --git a/test/goldens/schema_def_custom.golden b/test/goldens/schema_def_custom.golden deleted file mode 100644 --- a/test/goldens/schema_def_custom.golden +++ /dev/null @@ -1,1 +0,0 @@ -SchemaObject {"status": Status} diff --git a/test/goldens/schema_def_double.golden b/test/goldens/schema_def_double.golden deleted file mode 100644 --- a/test/goldens/schema_def_double.golden +++ /dev/null @@ -1,1 +0,0 @@ -SchemaObject {"foo123": Double} diff --git a/test/goldens/schema_def_duplicate.golden b/test/goldens/schema_def_duplicate.golden deleted file mode 100644 --- a/test/goldens/schema_def_duplicate.golden +++ /dev/null @@ -1,1 +0,0 @@ -Key 'a' specified multiple times diff --git a/test/goldens/schema_def_duplicate_extend.golden b/test/goldens/schema_def_duplicate_extend.golden deleted file mode 100644 --- a/test/goldens/schema_def_duplicate_extend.golden +++ /dev/null @@ -1,1 +0,0 @@ -Key 'extra' declared in multiple imported schemas diff --git a/test/goldens/schema_def_duplicate_phantom.golden b/test/goldens/schema_def_duplicate_phantom.golden deleted file mode 100644 --- a/test/goldens/schema_def_duplicate_phantom.golden +++ /dev/null @@ -1,1 +0,0 @@ -Key 'a' specified multiple times diff --git a/test/goldens/schema_def_extend.golden b/test/goldens/schema_def_extend.golden deleted file mode 100644 --- a/test/goldens/schema_def_extend.golden +++ /dev/null @@ -1,1 +0,0 @@ -SchemaObject {"a": Int, "extra": Text} diff --git a/test/goldens/schema_def_import_user.golden b/test/goldens/schema_def_import_user.golden deleted file mode 100644 --- a/test/goldens/schema_def_import_user.golden +++ /dev/null @@ -1,1 +0,0 @@ -SchemaObject {"user": {"name": Text}} diff --git a/test/goldens/schema_def_int.golden b/test/goldens/schema_def_int.golden deleted file mode 100644 --- a/test/goldens/schema_def_int.golden +++ /dev/null @@ -1,1 +0,0 @@ -SchemaObject {"a": Int} diff --git a/test/goldens/schema_def_invalid_extend.golden b/test/goldens/schema_def_invalid_extend.golden deleted file mode 100644 --- a/test/goldens/schema_def_invalid_extend.golden +++ /dev/null @@ -1,1 +0,0 @@ -'GHC.Types.Int' is not a SchemaObject diff --git a/test/goldens/schema_def_list.golden b/test/goldens/schema_def_list.golden deleted file mode 100644 --- a/test/goldens/schema_def_list.golden +++ /dev/null @@ -1,1 +0,0 @@ -SchemaObject {"a": List Int} diff --git a/test/goldens/schema_def_list_obj.golden b/test/goldens/schema_def_list_obj.golden deleted file mode 100644 --- a/test/goldens/schema_def_list_obj.golden +++ /dev/null @@ -1,1 +0,0 @@ -SchemaObject {"a": List {"b": Int}} diff --git a/test/goldens/schema_def_maybe.golden b/test/goldens/schema_def_maybe.golden deleted file mode 100644 --- a/test/goldens/schema_def_maybe.golden +++ /dev/null @@ -1,1 +0,0 @@ -SchemaObject {"a": Maybe Int} diff --git a/test/goldens/schema_def_maybe_obj.golden b/test/goldens/schema_def_maybe_obj.golden deleted file mode 100644 --- a/test/goldens/schema_def_maybe_obj.golden +++ /dev/null @@ -1,1 +0,0 @@ -SchemaObject {"a": Maybe {"b": Int}} diff --git a/test/goldens/schema_def_nonobject_phantom.golden b/test/goldens/schema_def_nonobject_phantom.golden deleted file mode 100644 --- a/test/goldens/schema_def_nonobject_phantom.golden +++ /dev/null @@ -1,1 +0,0 @@ -Invalid schema for 'a': SchemaInt diff --git a/test/goldens/schema_def_not_object.golden b/test/goldens/schema_def_not_object.golden deleted file mode 100644 --- a/test/goldens/schema_def_not_object.golden +++ /dev/null @@ -1,1 +0,0 @@ -`schema` definition must be an object diff --git a/test/goldens/schema_def_obj.golden b/test/goldens/schema_def_obj.golden deleted file mode 100644 --- a/test/goldens/schema_def_obj.golden +++ /dev/null @@ -1,1 +0,0 @@ -SchemaObject {"a": {"b": Int}} diff --git a/test/goldens/schema_def_shadow.golden b/test/goldens/schema_def_shadow.golden deleted file mode 100644 --- a/test/goldens/schema_def_shadow.golden +++ /dev/null @@ -1,1 +0,0 @@ -SchemaObject {"extra": Bool} diff --git a/test/goldens/schema_def_text.golden b/test/goldens/schema_def_text.golden deleted file mode 100644 --- a/test/goldens/schema_def_text.golden +++ /dev/null @@ -1,1 +0,0 @@ -SchemaObject {"some_text": Text} diff --git a/test/goldens/schema_def_union.golden b/test/goldens/schema_def_union.golden deleted file mode 100644 --- a/test/goldens/schema_def_union.golden +++ /dev/null @@ -1,1 +0,0 @@ -SchemaObject {"a": ( List Int | Text )} diff --git a/test/goldens/schema_def_union_grouped.golden b/test/goldens/schema_def_union_grouped.golden deleted file mode 100644 --- a/test/goldens/schema_def_union_grouped.golden +++ /dev/null @@ -1,1 +0,0 @@ -SchemaObject {"a": List ( Int | Text )} diff --git a/test/goldens/schema_def_unknown_type.golden b/test/goldens/schema_def_unknown_type.golden deleted file mode 100644 --- a/test/goldens/schema_def_unknown_type.golden +++ /dev/null @@ -1,1 +0,0 @@ -`schema` definition must be an object diff --git a/test/goldens/schemaqq_key_with_invalid_character.golden b/test/goldens/schemaqq_key_with_invalid_character.golden new file mode 100644 --- /dev/null +++ b/test/goldens/schemaqq_key_with_invalid_character.golden @@ -0,0 +1,6 @@ + { "a:b": Int } :1:6: + | +1 | { "a:b": Int } + | ^ +unexpected ':' +expecting '"' or '\' diff --git a/test/goldens/schemaqq_key_with_trailing_escape.golden b/test/goldens/schemaqq_key_with_trailing_escape.golden new file mode 100644 --- /dev/null +++ b/test/goldens/schemaqq_key_with_trailing_escape.golden @@ -0,0 +1,6 @@ + { "a\": Int } :1:8: + | +1 | { "a\": Int } + | ^ +unexpected ':' +expecting '"' or '\' diff --git a/test/goldens/sumtype_decode_invalid.golden b/test/goldens/sumtype_decode_invalid.golden new file mode 100644 --- /dev/null +++ b/test/goldens/sumtype_decode_invalid.golden @@ -0,0 +1,1 @@ +Error in $: Could not parse sum type diff --git a/test/goldens/text.golden b/test/goldens/text.golden deleted file mode 100644 --- a/test/goldens/text.golden +++ /dev/null @@ -1,1 +0,0 @@ -"asdf" diff --git a/test/goldens/tryObj.golden b/test/goldens/tryObj.golden deleted file mode 100644 --- a/test/goldens/tryObj.golden +++ /dev/null @@ -1,1 +0,0 @@ -Just {"a": 1} diff --git a/test/goldens/tryObjNull.golden b/test/goldens/tryObjNull.golden deleted file mode 100644 --- a/test/goldens/tryObjNull.golden +++ /dev/null @@ -1,1 +0,0 @@ -Nothing diff --git a/test/goldens/tryObjNull_a.golden b/test/goldens/tryObjNull_a.golden deleted file mode 100644 --- a/test/goldens/tryObjNull_a.golden +++ /dev/null @@ -1,1 +0,0 @@ -Nothing diff --git a/test/goldens/tryObj_a.golden b/test/goldens/tryObj_a.golden deleted file mode 100644 --- a/test/goldens/tryObj_a.golden +++ /dev/null @@ -1,1 +0,0 @@ -Just 1 diff --git a/test/goldens/tryObj_bang.golden b/test/goldens/tryObj_bang.golden deleted file mode 100644 --- a/test/goldens/tryObj_bang.golden +++ /dev/null @@ -1,1 +0,0 @@ -{"a": 1} diff --git a/test/goldens/tryObj_bang_a.golden b/test/goldens/tryObj_bang_a.golden deleted file mode 100644 --- a/test/goldens/tryObj_bang_a.golden +++ /dev/null @@ -1,1 +0,0 @@ -1 diff --git a/test/goldens/union.golden b/test/goldens/union.golden deleted file mode 100644 --- a/test/goldens/union.golden +++ /dev/null @@ -1,1 +0,0 @@ -[There (There (Here "Hello")),Here {"a": 1},There (Here [True,False]),There (There (Here "World!"))] diff --git a/test/goldens/union_0.golden b/test/goldens/union_0.golden deleted file mode 100644 --- a/test/goldens/union_0.golden +++ /dev/null @@ -1,1 +0,0 @@ -[Nothing,Just {"a": 1},Nothing,Nothing] diff --git a/test/goldens/union_0_a.golden b/test/goldens/union_0_a.golden deleted file mode 100644 --- a/test/goldens/union_0_a.golden +++ /dev/null @@ -1,1 +0,0 @@ -[Nothing,Just 1,Nothing,Nothing] diff --git a/test/goldens/union_1.golden b/test/goldens/union_1.golden deleted file mode 100644 --- a/test/goldens/union_1.golden +++ /dev/null @@ -1,1 +0,0 @@ -[Nothing,Nothing,Just [True,False],Nothing] diff --git a/test/goldens/union_2.golden b/test/goldens/union_2.golden deleted file mode 100644 --- a/test/goldens/union_2.golden +++ /dev/null @@ -1,1 +0,0 @@ -[Just "Hello",Nothing,Nothing,Just "World!"] diff --git a/test/goldens/unwrap_schema.golden b/test/goldens/unwrap_schema.golden deleted file mode 100644 --- a/test/goldens/unwrap_schema.golden +++ /dev/null @@ -1,1 +0,0 @@ -Object (SchemaObject {"a": Maybe {"b": Int}, "b": Int}) diff --git a/test/goldens/unwrap_schema_bad_bang.golden b/test/goldens/unwrap_schema_bad_bang.golden deleted file mode 100644 --- a/test/goldens/unwrap_schema_bad_bang.golden +++ /dev/null @@ -1,1 +0,0 @@ -Cannot use `!` operator on schema: SchemaObject {"type": Text, "maybeBool": Maybe Bool, "maybeInt": Maybe Int, "maybeNull": Maybe Bool} diff --git a/test/goldens/unwrap_schema_bad_branch.golden b/test/goldens/unwrap_schema_bad_branch.golden deleted file mode 100644 --- a/test/goldens/unwrap_schema_bad_branch.golden +++ /dev/null @@ -1,1 +0,0 @@ -Cannot use `@` operator on schema: SchemaList {"type": Text, "maybeBool": Maybe Bool, "maybeInt": Maybe Int, "maybeNull": Maybe Bool} diff --git a/test/goldens/unwrap_schema_bad_key.golden b/test/goldens/unwrap_schema_bad_key.golden deleted file mode 100644 --- a/test/goldens/unwrap_schema_bad_key.golden +++ /dev/null @@ -1,1 +0,0 @@ -Cannot get key 'a' in schema: SchemaList {"type": Text, "maybeBool": Maybe Bool, "maybeInt": Maybe Int, "maybeNull": Maybe Bool} diff --git a/test/goldens/unwrap_schema_bad_list.golden b/test/goldens/unwrap_schema_bad_list.golden deleted file mode 100644 --- a/test/goldens/unwrap_schema_bad_list.golden +++ /dev/null @@ -1,1 +0,0 @@ -Cannot use `[]` operator on schema: SchemaObject {"type": Text, "maybeBool": Maybe Bool, "maybeInt": Maybe Int, "maybeNull": Maybe Bool} diff --git a/test/goldens/unwrap_schema_bad_question.golden b/test/goldens/unwrap_schema_bad_question.golden deleted file mode 100644 --- a/test/goldens/unwrap_schema_bad_question.golden +++ /dev/null @@ -1,1 +0,0 @@ -Cannot use `?` operator on schema: SchemaObject {"type": Text, "maybeBool": Maybe Bool, "maybeInt": Maybe Int, "maybeNull": Maybe Bool} diff --git a/test/goldens/unwrap_schema_branch_out_of_bounds.golden b/test/goldens/unwrap_schema_branch_out_of_bounds.golden deleted file mode 100644 --- a/test/goldens/unwrap_schema_branch_out_of_bounds.golden +++ /dev/null @@ -1,1 +0,0 @@ -Branch out of bounds for schema: SchemaUnion ( {"a": Int} | List Bool | Text ) diff --git a/test/goldens/unwrap_schema_nested_list.golden b/test/goldens/unwrap_schema_nested_list.golden deleted file mode 100644 --- a/test/goldens/unwrap_schema_nested_list.golden +++ /dev/null @@ -1,1 +0,0 @@ -[{"a": Nothing, "b": 1},{"a": Just {"b": 2}, "b": 3}] diff --git a/test/goldens/unwrap_schema_nested_object.golden b/test/goldens/unwrap_schema_nested_object.golden deleted file mode 100644 --- a/test/goldens/unwrap_schema_nested_object.golden +++ /dev/null @@ -1,1 +0,0 @@ -[1,2] diff --git a/test/goldens/unwrapqq_unwrap_past_list.golden b/test/goldens/unwrapqq_unwrap_past_list.golden new file mode 100644 --- /dev/null +++ b/test/goldens/unwrapqq_unwrap_past_list.golden @@ -0,0 +1,6 @@ + ABCSchema.[a,b].foo :1:17: + | +1 | ABCSchema.[a,b].foo + | ^ +unexpected '.' +expecting end of input or white space diff --git a/test/goldens/unwrapqq_unwrap_past_tuple.golden b/test/goldens/unwrapqq_unwrap_past_tuple.golden new file mode 100644 --- /dev/null +++ b/test/goldens/unwrapqq_unwrap_past_tuple.golden @@ -0,0 +1,6 @@ + ABCSchema.(a,b).foo :1:17: + | +1 | ABCSchema.(a,b).foo + | ^ +unexpected '.' +expecting end of input or white space diff --git a/test/nested.json b/test/nested.json deleted file mode 100644 --- a/test/nested.json +++ /dev/null @@ -1,14 +0,0 @@ -{ - "list": [ - { - "a": null, - "b": 1 - }, - { - "a": { - "b": 2 - }, - "b": 3 - } - ] -}