aeson-schemas 1.2.0 → 1.3.0

raw patch · 162 files changed

+3895/−1400 lines, 162 filesdep +aeson-qqdep +criteriondep +deepseqdep −bytestringdep ~QuickCheckdep ~raw-strings-qqdep ~tastyPVP ok

version bump matches the API change (PVP)

Dependencies added: aeson-qq, criterion, deepseq, hashable, hint, interpolate, th-orphans

Dependencies removed: bytestring

Dependency ranges changed: QuickCheck, raw-strings-qq, tasty, tasty-golden, tasty-hunit, tasty-quickcheck, th-test-utils

API changes (from Hackage documentation)

Files

• CHANGELOG.md +38/−0
• README.md +15/−13
• aeson-schemas.cabal +99/−106
• bench/Benchmarks/Data/Objects.hs +55/−0
• bench/Benchmarks/Data/Schemas.hs +96/−0
• bench/Benchmarks/Data/Schemas/TH.hs +41/−0
• bench/Benchmarks/FromJSON.hs +41/−0
• bench/Benchmarks/SchemaQQ.hs +69/−0
• bench/Benchmarks/Show.hs +29/−0
• bench/Benchmarks/ToJSON.hs +30/−0
• bench/Main.hs +14/−0
• bench/Utils/DeepSeq.hs +64/−0
• src/Data/Aeson/Schema.hs +7/−4
• src/Data/Aeson/Schema/Internal.hs +175/−176
• src/Data/Aeson/Schema/Key.hs +88/−8
• src/Data/Aeson/Schema/Show.hs +9/−23
• src/Data/Aeson/Schema/TH/Get.hs +91/−33
• src/Data/Aeson/Schema/TH/Getter.hs +31/−21
• src/Data/Aeson/Schema/TH/Parse.hs +154/−88
• src/Data/Aeson/Schema/TH/Schema.hs +111/−85
• src/Data/Aeson/Schema/TH/Unwrap.hs +112/−8
• src/Data/Aeson/Schema/TH/Utils.hs +187/−159
• src/Data/Aeson/Schema/Type.hs +159/−0
• src/Data/Aeson/Schema/Utils/All.hs +32/−0
• src/Data/Aeson/Schema/Utils/Invariant.hs +11/−0
• src/Data/Aeson/Schema/Utils/Sum.hs +13/−6
• src/Data/Aeson/Schema/Utils/TypeFamilies.hs +0/−23
• test/AllTypes.hs +0/−83
• test/Enums.hs +0/−13
• test/Main.hs +15/−296
• test/Nested.hs +0/−23
• test/Schema.hs +0/−15
• test/SumType.hs +0/−7
• test/TestUtils.hs +127/−0
• test/TestUtils/Arbitrary.hs +341/−0
• test/TestUtils/DeepSeq.hs +64/−0
• test/Tests/EnumTH.hs +82/−0
• test/Tests/GetQQ.hs +405/−0
• test/Tests/GetQQ/TH.hs +35/−0
• test/Tests/MkGetter.hs +64/−0
• test/Tests/Object.hs +33/−0
• test/Tests/Object/Eq.hs +18/−0
• test/Tests/Object/FromJSON.hs +155/−0
• test/Tests/Object/FromJSON/TH.hs +14/−0
• test/Tests/Object/Show.hs +70/−0
• test/Tests/Object/Show/TH.hs +8/−0
• test/Tests/Object/ToJSON.hs +34/−0
• test/Tests/SchemaQQ.hs +221/−0
• test/Tests/SchemaQQ/TH.hs +71/−0
• test/Tests/SumType.hs +89/−0
• test/Tests/UnwrapQQ.hs +111/−0
• test/Tests/UnwrapQQ/TH.hs +93/−0
• test/Util.hs +0/−54
• test/all_types.json +0/−47
• test/goldens/README_Quickstart.golden +2/−2
• test/goldens/bool.golden +0/−1
• test/goldens/bool_int_double.golden +0/−1
• test/goldens/double.golden +0/−1
• test/goldens/enum.golden +0/−1
• test/goldens/from_object_all_types.golden +0/−1
• test/goldens/from_object_namespaced.golden +0/−1
• test/goldens/from_object_nested.golden +0/−1
• test/goldens/fromjson_error_messages_truncate.golden +1/−0
• test/goldens/fromjson_list_inner_invalid.golden +1/−0
• test/goldens/fromjson_list_invalid.golden +1/−0
• test/goldens/fromjson_maybe_invalid.golden +1/−0
• test/goldens/fromjson_nested_inner_invalid.golden +1/−0
• test/goldens/fromjson_nested_invalid.golden +1/−0
• test/goldens/fromjson_object_invalid.golden +1/−0
• test/goldens/fromjson_object_later_keys_invalid.golden +1/−0
• test/goldens/fromjson_phantom_inner_invalid.golden +1/−0
• test/goldens/fromjson_phantom_inner_missing.golden +1/−0
• test/goldens/fromjson_phantom_invalid.golden +1/−0
• test/goldens/fromjson_scalar_invalid.golden +1/−0
• test/goldens/fromjson_union_invalid.golden +1/−0
• test/goldens/get_empty.golden +0/−6
• test/goldens/get_just_start.golden +0/−6
• test/goldens/get_ops_after_list.golden +0/−1
• test/goldens/get_ops_after_tuple.golden +0/−1
• test/goldens/getqq_empty_expression.golden +5/−0
• test/goldens/getqq_missing_key.golden +12/−0
• test/goldens/getqq_no_operators.golden +5/−0
• test/goldens/getqq_ops_after_list.golden +6/−0
• test/goldens/getqq_ops_after_tuple.golden +6/−0
• test/goldens/getter_all_types_list.golden +0/−1
• test/goldens/getter_all_types_list_item.golden +0/−1
• test/goldens/int.golden +0/−1
• test/goldens/int_int2.golden +0/−1
• test/goldens/lambda_bool.golden +0/−1
• test/goldens/list.golden +0/−1
• test/goldens/list_explicit.golden +0/−1
• test/goldens/list_maybeBool.golden +0/−1
• test/goldens/list_maybeInt.golden +0/−1
• test/goldens/list_type.golden +0/−1
• test/goldens/maybeList.golden +0/−1
• test/goldens/maybeListNull.golden +0/−1
• test/goldens/maybeListNull_bang.golden +0/−1
• test/goldens/maybeListNull_list.golden +0/−1
• test/goldens/maybeListNull_list_text.golden +0/−1
• test/goldens/maybeList_bang.golden +0/−1
• test/goldens/maybeList_bang_list.golden +0/−1
• test/goldens/maybeList_bang_list_text.golden +0/−1
• test/goldens/maybeList_list.golden +0/−1
• test/goldens/maybeList_list_text.golden +0/−1
• test/goldens/maybeObj.golden +0/−1
• test/goldens/maybeObjNull.golden +0/−1
• test/goldens/maybeObjNull_text.golden +0/−1
• test/goldens/maybeObj_bang.golden +0/−1
• test/goldens/maybeObj_bang_text.golden +0/−1
• test/goldens/maybeObj_text.golden +0/−1
• test/goldens/nonexistent.golden +0/−1
• test/goldens/phantom.golden +0/−1
• test/goldens/scalar.golden +0/−1
• test/goldens/schema_def_bool.golden +0/−1
• test/goldens/schema_def_custom.golden +0/−1
• test/goldens/schema_def_double.golden +0/−1
• test/goldens/schema_def_duplicate.golden +0/−1
• test/goldens/schema_def_duplicate_extend.golden +0/−1
• test/goldens/schema_def_duplicate_phantom.golden +0/−1
• test/goldens/schema_def_extend.golden +0/−1
• test/goldens/schema_def_import_user.golden +0/−1
• test/goldens/schema_def_int.golden +0/−1
• test/goldens/schema_def_invalid_extend.golden +0/−1
• test/goldens/schema_def_list.golden +0/−1
• test/goldens/schema_def_list_obj.golden +0/−1
• test/goldens/schema_def_maybe.golden +0/−1
• test/goldens/schema_def_maybe_obj.golden +0/−1
• test/goldens/schema_def_nonobject_phantom.golden +0/−1
• test/goldens/schema_def_not_object.golden +0/−1
• test/goldens/schema_def_obj.golden +0/−1
• test/goldens/schema_def_shadow.golden +0/−1
• test/goldens/schema_def_text.golden +0/−1
• test/goldens/schema_def_union.golden +0/−1
• test/goldens/schema_def_union_grouped.golden +0/−1
• test/goldens/schema_def_unknown_type.golden +0/−1
• test/goldens/schemaqq_key_with_invalid_character.golden +6/−0
• test/goldens/schemaqq_key_with_trailing_escape.golden +6/−0
• test/goldens/sumtype_decode_invalid.golden +1/−0
• test/goldens/text.golden +0/−1
• test/goldens/tryObj.golden +0/−1
• test/goldens/tryObjNull.golden +0/−1
• test/goldens/tryObjNull_a.golden +0/−1
• test/goldens/tryObj_a.golden +0/−1
• test/goldens/tryObj_bang.golden +0/−1
• test/goldens/tryObj_bang_a.golden +0/−1
• test/goldens/union.golden +0/−1
• test/goldens/union_0.golden +0/−1
• test/goldens/union_0_a.golden +0/−1
• test/goldens/union_1.golden +0/−1
• test/goldens/union_2.golden +0/−1
• test/goldens/unwrap_schema.golden +0/−1
• test/goldens/unwrap_schema_bad_bang.golden +0/−1
• test/goldens/unwrap_schema_bad_branch.golden +0/−1
• test/goldens/unwrap_schema_bad_key.golden +0/−1
• test/goldens/unwrap_schema_bad_list.golden +0/−1
• test/goldens/unwrap_schema_bad_question.golden +0/−1
• test/goldens/unwrap_schema_branch_out_of_bounds.golden +0/−1
• test/goldens/unwrap_schema_nested_list.golden +0/−1
• test/goldens/unwrap_schema_nested_object.golden +0/−1
• test/goldens/unwrapqq_unwrap_past_list.golden +6/−0
• test/goldens/unwrapqq_unwrap_past_tuple.golden +6/−0
• test/nested.json +0/−14

@@ -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:

@@ -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 |]

@@ -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

@@ -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)

@@ -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))+      |]+    ]+  )

@@ -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

@@ -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

@@ -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

@@ -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)+      ]

@@ -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)+      ]

@@ -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+  ]

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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) []]     ]

@@ -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

@@ -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 \<schema\>@ and @List \<schema\>@ correspond to @Maybe@ and @[]@, containing values --   specified by the provided schema (no parentheses needed). ----- * @Try \<schema\>@ correspond to @Maybe@, where the value will be @Just@ if the given schema---   successfully parses the value, or @Nothing@ otherwise.+-- * @Try \<schema\>@ corresponds to @Maybe@, where the value will be @Just@ if the given schema+--   successfully parses the value, or @Nothing@ otherwise. Different from @Maybe \<schema\>@,+--   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]: \<schema\> }@ 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

@@ -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

@@ -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 ) |]

@@ -0,0 +1,159 @@+{-|+Module      :  Data.Aeson.Schema.Type+Maintainer  :  Brandon Chinn <brandon@leapyear.io>+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)

@@ -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)

@@ -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/"+  ]

@@ -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 -} 

@@ -1,23 +0,0 @@-{-|-Module      :  Data.Aeson.Schema.Utils.TypeFamilies-Maintainer  :  Brandon Chinn <brandon@leapyear.io>-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)

@@ -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[]"

@@ -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

@@ -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

@@ -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")

@@ -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 } |]

@@ -1,7 +0,0 @@-{-# LANGUAGE DataKinds #-}--module SumType where--import Data.Aeson.Schema.Utils.Sum (SumType(..))--type SpecialJSON = SumType '[Bool, Int, [String]]

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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) |]

@@ -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" }+    ]+  }+|]

@@ -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)+        ]+  ]

@@ -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+  ]

@@ -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

@@ -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 |]

@@ -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} } }|]+  ]

@@ -0,0 +1,8 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE QuasiQuotes #-}++module Tests.Object.Show.TH where++import Data.Aeson.Schema (schema)++type UserSchema = [schema| { name: Text } |]

@@ -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

@@ -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

@@ -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) |]

@@ -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

@@ -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 )"+  ]

@@ -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) |]

@@ -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

@@ -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-}

@@ -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" }]

@@ -1,1 +0,0 @@-True

@@ -1,1 +0,0 @@-(True,1,2.5)

@@ -1,1 +0,0 @@-2.5

@@ -1,1 +0,0 @@-HELLO

@@ -1,1 +0,0 @@-["True","2","Nothing"]

@@ -1,1 +0,0 @@-["bool","int","null","1","3"]

@@ -1,1 +0,0 @@-[1,2]

@@ -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 [(...

@@ -0,0 +1,1 @@+Error in $: Could not parse path 'foo' with schema `SchemaScalar Double`: Bool True

@@ -0,0 +1,1 @@+Error in $: Could not parse path 'foo' with schema `SchemaList Double`: Bool True

@@ -0,0 +1,1 @@+Error in $: Could not parse path 'foo' with schema `SchemaScalar Int`: Bool True

@@ -0,0 +1,1 @@+Error in $: Could not parse path 'foo.bar' with schema `SchemaScalar Int`: Bool True

@@ -0,0 +1,1 @@+Error in $: Could not parse path 'foo' with schema `SchemaObject { "bar": Int }`: Bool True

@@ -0,0 +1,1 @@+Error in $: Could not parse schema `SchemaObject { "foo": Int }`: Number 1.0

@@ -0,0 +1,1 @@+Error in $: Could not parse path 'bar' with schema `SchemaScalar Int`: Bool True

@@ -0,0 +1,1 @@+Error in $: Could not parse path 'foo.bar' with schema `SchemaScalar Int`: Bool True

@@ -0,0 +1,1 @@+Error in $: Could not parse path 'foo.bar' with schema `SchemaScalar Int`: Null

@@ -0,0 +1,1 @@+Error in $: Could not parse schema `SchemaObject { [foo]: { "bar": Int } }`: Number 1.0

@@ -0,0 +1,1 @@+Error in $: Could not parse path 'foo' with schema `SchemaScalar Text`: Number 1.0

@@ -0,0 +1,1 @@+Error in $: Could not parse path 'foo' with schema `SchemaUnion ( Int | Text )`: Bool True

@@ -1,6 +0,0 @@-1:1:-  |-1 | <empty line>-  | ^-unexpected end of input-expecting "[]", '!', '(', '.', '?', '@', '[', lowercase letter, or white space

@@ -1,6 +0,0 @@-allTypes:1:9:-  |-1 | allTypes-  |         ^-unexpected end of input-expecting "[]", '!', ''', '(', '.', '?', '@', '[', or alphanumeric character

@@ -1,1 +0,0 @@-.[*] operation MUST be last.

@@ -1,1 +0,0 @@-.(*) operation MUST be last.

@@ -0,0 +1,5 @@+ :1:2:+  |+1 |  +  |  ^+expecting "[]", '!', '"', '(', '.', '?', '@', '[', '\', lowercase letter, or white space

@@ -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 ...)

@@ -0,0 +1,5 @@+ o :1:3:+  |+1 |  o +  |   ^+expecting "[]", '!', '"', ''', '(', '.', '?', '@', '[', '\', or alphanumeric character

@@ -0,0 +1,6 @@+ o.[a,b].foo :1:9:+  |+1 |  o.[a,b].foo +  |         ^+unexpected '.'+expecting end of input or white space

@@ -0,0 +1,6 @@+ o.(a,b).foo :1:9:+  |+1 |  o.(a,b).foo +  |         ^+unexpected '.'+expecting end of input or white space

@@ -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}]

@@ -1,1 +0,0 @@-["bool","int","null"]

@@ -1,1 +0,0 @@-1

@@ -1,1 +0,0 @@-[1,2]

@@ -1,1 +0,0 @@-True

@@ -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}]

@@ -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}]

@@ -1,1 +0,0 @@-[Just True,Nothing,Nothing]

@@ -1,1 +0,0 @@-[Nothing,Just 2,Nothing]

@@ -1,1 +0,0 @@-["bool","int","null"]

@@ -1,1 +0,0 @@-Just [{"text": "foo"},{"text": "bar"}]

@@ -1,1 +0,0 @@-Nothing

@@ -1,1 +0,0 @@-Called 'fromJust' on null expression: (AllTypes.result).maybeListNull

@@ -1,1 +0,0 @@-Nothing

@@ -1,1 +0,0 @@-Nothing

@@ -1,1 +0,0 @@-[{"text": "foo"},{"text": "bar"}]

@@ -1,1 +0,0 @@-[{"text": "foo"},{"text": "bar"}]

@@ -1,1 +0,0 @@-["foo","bar"]

@@ -1,1 +0,0 @@-Just [{"text": "foo"},{"text": "bar"}]

@@ -1,1 +0,0 @@-Just ["foo","bar"]

@@ -1,1 +0,0 @@-Just {"text": "foo"}

@@ -1,1 +0,0 @@-Nothing

@@ -1,1 +0,0 @@-Nothing

@@ -1,1 +0,0 @@-{"text": "foo"}

@@ -1,1 +0,0 @@-"foo"

@@ -1,1 +0,0 @@-Just "foo"

@@ -1,1 +0,0 @@-Nothing

@@ -1,1 +0,0 @@-1

@@ -1,1 +0,0 @@-Coordinate (12,34)

@@ -1,1 +0,0 @@-SchemaObject {"a": Bool}

@@ -1,1 +0,0 @@-SchemaObject {"status": Status}

@@ -1,1 +0,0 @@-SchemaObject {"foo123": Double}

@@ -1,1 +0,0 @@-Key 'a' specified multiple times

@@ -1,1 +0,0 @@-Key 'extra' declared in multiple imported schemas

@@ -1,1 +0,0 @@-Key 'a' specified multiple times

@@ -1,1 +0,0 @@-SchemaObject {"a": Int, "extra": Text}

@@ -1,1 +0,0 @@-SchemaObject {"user": {"name": Text}}

@@ -1,1 +0,0 @@-SchemaObject {"a": Int}

@@ -1,1 +0,0 @@-'GHC.Types.Int' is not a SchemaObject

@@ -1,1 +0,0 @@-SchemaObject {"a": List Int}

@@ -1,1 +0,0 @@-SchemaObject {"a": List {"b": Int}}

@@ -1,1 +0,0 @@-SchemaObject {"a": Maybe Int}

@@ -1,1 +0,0 @@-SchemaObject {"a": Maybe {"b": Int}}

@@ -1,1 +0,0 @@-Invalid schema for 'a': SchemaInt

@@ -1,1 +0,0 @@-`schema` definition must be an object

@@ -1,1 +0,0 @@-SchemaObject {"a": {"b": Int}}

@@ -1,1 +0,0 @@-SchemaObject {"extra": Bool}

@@ -1,1 +0,0 @@-SchemaObject {"some_text": Text}

@@ -1,1 +0,0 @@-SchemaObject {"a": ( List Int | Text )}

@@ -1,1 +0,0 @@-SchemaObject {"a": List ( Int | Text )}

@@ -1,1 +0,0 @@-`schema` definition must be an object

@@ -0,0 +1,6 @@+ { "a:b": Int } :1:6:+  |+1 |  { "a:b": Int } +  |      ^+unexpected ':'+expecting '"' or '\'

@@ -0,0 +1,6 @@+ { "a\": Int } :1:8:+  |+1 |  { "a\": Int } +  |        ^+unexpected ':'+expecting '"' or '\'

@@ -0,0 +1,1 @@+Error in $: Could not parse sum type

@@ -1,1 +0,0 @@-"asdf"

@@ -1,1 +0,0 @@-Just {"a": 1}

@@ -1,1 +0,0 @@-Nothing

@@ -1,1 +0,0 @@-Nothing

@@ -1,1 +0,0 @@-Just 1

@@ -1,1 +0,0 @@-{"a": 1}

@@ -1,1 +0,0 @@-1

@@ -1,1 +0,0 @@-[There (There (Here "Hello")),Here {"a": 1},There (Here [True,False]),There (There (Here "World!"))]

@@ -1,1 +0,0 @@-[Nothing,Just {"a": 1},Nothing,Nothing]

@@ -1,1 +0,0 @@-[Nothing,Just 1,Nothing,Nothing]

@@ -1,1 +0,0 @@-[Nothing,Nothing,Just [True,False],Nothing]

@@ -1,1 +0,0 @@-[Just "Hello",Nothing,Nothing,Just "World!"]

@@ -1,1 +0,0 @@-Object (SchemaObject {"a": Maybe {"b": Int}, "b": Int})

@@ -1,1 +0,0 @@-Cannot use `!` operator on schema: SchemaObject {"type": Text, "maybeBool": Maybe Bool, "maybeInt": Maybe Int, "maybeNull": Maybe Bool}

@@ -1,1 +0,0 @@-Cannot use `@` operator on schema: SchemaList {"type": Text, "maybeBool": Maybe Bool, "maybeInt": Maybe Int, "maybeNull": Maybe Bool}

@@ -1,1 +0,0 @@-Cannot get key 'a' in schema: SchemaList {"type": Text, "maybeBool": Maybe Bool, "maybeInt": Maybe Int, "maybeNull": Maybe Bool}

@@ -1,1 +0,0 @@-Cannot use `[]` operator on schema: SchemaObject {"type": Text, "maybeBool": Maybe Bool, "maybeInt": Maybe Int, "maybeNull": Maybe Bool}

@@ -1,1 +0,0 @@-Cannot use `?` operator on schema: SchemaObject {"type": Text, "maybeBool": Maybe Bool, "maybeInt": Maybe Int, "maybeNull": Maybe Bool}

@@ -1,1 +0,0 @@-Branch out of bounds for schema: SchemaUnion ( {"a": Int} | List Bool | Text )

@@ -1,1 +0,0 @@-[{"a": Nothing, "b": 1},{"a": Just {"b": 2}, "b": 3}]

@@ -1,1 +0,0 @@-[1,2]

@@ -0,0 +1,6 @@+ ABCSchema.[a,b].foo :1:17:+  |+1 |  ABCSchema.[a,b].foo +  |                 ^+unexpected '.'+expecting end of input or white space

@@ -0,0 +1,6 @@+ ABCSchema.(a,b).foo :1:17:+  |+1 |  ABCSchema.(a,b).foo +  |                 ^+unexpected '.'+expecting end of input or white space

@@ -1,14 +0,0 @@-{-    "list": [-        {-            "a": null,-            "b": 1-        },-        {-            "a": {-                "b": 2-            },-            "b": 3-        }-    ]-}