├── test ├── goldens │ ├── sumtype_decode_invalid.golden │ ├── fromjson_list_invalid.golden │ ├── fromjson_maybe_invalid.golden │ ├── fromjson_object_invalid.golden │ ├── fromjson_scalar_invalid.golden │ ├── fromjson_list_inner_invalid.golden │ ├── fromjson_nested_inner_invalid.golden │ ├── fromjson_phantom_inner_missing.golden │ ├── fromjson_phantom_invalid.golden │ ├── fromjson_union_invalid.golden │ ├── fromjson_nested_invalid.golden │ ├── fromjson_object_later_keys_invalid.golden │ ├── fromjson_phantom_inner_invalid.golden │ ├── getqq_ops_after_list.golden │ ├── getqq_ops_after_tuple.golden │ ├── schemaqq_key_with_invalid_character.golden │ ├── schemaqq_key_with_trailing_escape.golden │ ├── getqq_empty_expression.golden │ ├── getqq_no_operators.golden │ ├── unwrapqq_unwrap_past_list.golden │ ├── unwrapqq_unwrap_past_tuple.golden │ ├── fromjson_error_messages_truncate.golden │ ├── README_Quickstart.golden │ └── ghc │ │ ├── 9.8 │ │ └── getqq_missing_key.golden │ │ ├── 9.10 │ │ └── getqq_missing_key.golden │ │ └── 9.12 │ │ └── getqq_missing_key.golden ├── Tests │ ├── Object │ │ ├── Show │ │ │ └── TH.hs │ │ ├── FromJSON │ │ │ └── TH.hs │ │ ├── Eq.hs │ │ ├── ToJSON.hs │ │ ├── Show.hs │ │ └── FromJSON.hs │ ├── Object.hs │ ├── GetQQ │ │ └── TH.hs │ ├── Quickstart.hs │ ├── MkGetter.hs │ ├── SchemaQQ │ │ └── TH.hs │ ├── UnwrapQQ │ │ └── TH.hs │ ├── EnumTH.hs │ ├── SumType.hs │ ├── UnwrapQQ.hs │ └── SchemaQQ.hs ├── wont-compile │ └── GetMissingKey.hs ├── Main.hs ├── TestUtils │ ├── DeepSeq.hs │ └── Arbitrary.hs └── TestUtils.hs ├── stack.yaml ├── .gitignore ├── fourmolu.yaml ├── .github └── workflows │ ├── ghc-nightly.yml │ ├── release.yml │ ├── ci.yml │ └── ghc-compat-test.yml ├── bench ├── Main.hs ├── Benchmarks │ ├── Show.hs │ ├── ToJSON.hs │ ├── Data │ │ ├── Schemas │ │ │ └── TH.hs │ │ ├── Objects.hs │ │ └── Schemas.hs │ ├── FromJSON.hs │ └── SchemaQQ.hs └── Utils │ └── DeepSeq.hs ├── src └── Data │ └── Aeson │ ├── Schema │ ├── Utils │ │ ├── Invariant.hs │ │ ├── Compat.hs │ │ ├── NameLike.hs │ │ ├── All.hs │ │ └── Sum.hs │ ├── TH.hs │ ├── TH │ │ ├── Getter.hs │ │ ├── Enum.hs │ │ ├── Unwrap.hs │ │ ├── Get.hs │ │ ├── Parse.hs │ │ ├── Schema.hs │ │ └── Utils.hs │ ├── Key.hs │ ├── Type.hs │ └── Internal.hs │ └── Schema.hs ├── stack.yaml.lock ├── examples └── input.json ├── LICENSE.md ├── package.yaml ├── DEVELOPER.md ├── CHANGELOG.md ├── aeson-schemas.cabal └── README.md /test/goldens/sumtype_decode_invalid.golden: -------------------------------------------------------------------------------- 1 | Error in $: Could not parse sum type -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2024-12-20 2 | 3 | extra-deps: 4 | - th-test-utils-1.2.2 5 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store 2 | 3 | .stack-work/ 4 | stack-ghc-*.yaml.lock 5 | 6 | cabal.project.local* 7 | dist-newstyle/ 8 | -------------------------------------------------------------------------------- /test/goldens/fromjson_list_invalid.golden: -------------------------------------------------------------------------------- 1 | Error in $: Could not parse path 'foo' with schema `SchemaList Double`: Bool True -------------------------------------------------------------------------------- /test/goldens/fromjson_maybe_invalid.golden: -------------------------------------------------------------------------------- 1 | Error in $: Could not parse path 'foo' with schema `SchemaScalar Int`: Bool True -------------------------------------------------------------------------------- /test/goldens/fromjson_object_invalid.golden: -------------------------------------------------------------------------------- 1 | Error in $: Could not parse schema `SchemaObject { "foo": Int }`: Number 1.0 -------------------------------------------------------------------------------- /test/goldens/fromjson_scalar_invalid.golden: -------------------------------------------------------------------------------- 1 | Error in $: Could not parse path 'foo' with schema `SchemaScalar Text`: Number 1.0 -------------------------------------------------------------------------------- /test/goldens/fromjson_list_inner_invalid.golden: -------------------------------------------------------------------------------- 1 | Error in $: Could not parse path 'foo' with schema `SchemaScalar Double`: Bool True -------------------------------------------------------------------------------- /test/goldens/fromjson_nested_inner_invalid.golden: -------------------------------------------------------------------------------- 1 | Error in $: Could not parse path 'foo.bar' with schema `SchemaScalar Int`: Bool True -------------------------------------------------------------------------------- /test/goldens/fromjson_phantom_inner_missing.golden: -------------------------------------------------------------------------------- 1 | Error in $: Could not parse path 'foo.bar' with schema `SchemaScalar Int`: Null -------------------------------------------------------------------------------- /test/goldens/fromjson_phantom_invalid.golden: -------------------------------------------------------------------------------- 1 | Error in $: Could not parse schema `SchemaObject { [foo]: { "bar": Int } }`: Number 1.0 -------------------------------------------------------------------------------- /test/goldens/fromjson_union_invalid.golden: -------------------------------------------------------------------------------- 1 | Error in $: Could not parse path 'foo' with schema `SchemaUnion ( Int | Text )`: Bool True -------------------------------------------------------------------------------- /test/goldens/fromjson_nested_invalid.golden: -------------------------------------------------------------------------------- 1 | Error in $: Could not parse path 'foo' with schema `SchemaObject { "bar": Int }`: Bool True -------------------------------------------------------------------------------- /test/goldens/fromjson_object_later_keys_invalid.golden: -------------------------------------------------------------------------------- 1 | Error in $: Could not parse path 'bar' with schema `SchemaScalar Int`: Bool True -------------------------------------------------------------------------------- /test/goldens/fromjson_phantom_inner_invalid.golden: -------------------------------------------------------------------------------- 1 | Error in $: Could not parse path 'foo.bar' with schema `SchemaScalar Int`: Bool True -------------------------------------------------------------------------------- /fourmolu.yaml: -------------------------------------------------------------------------------- 1 | indentation: 2 2 | indent-wheres: true 3 | function-arrows: leading-args 4 | haddock-style: single-line 5 | haddock-style-module: multi-line-compact 6 | -------------------------------------------------------------------------------- /test/goldens/getqq_ops_after_list.golden: -------------------------------------------------------------------------------- 1 | o.[a,b].foo :1:9: 2 | | 3 | 1 | o.[a,b].foo 4 | | ^ 5 | unexpected '.' 6 | expecting end of input or white space 7 | -------------------------------------------------------------------------------- /test/goldens/getqq_ops_after_tuple.golden: -------------------------------------------------------------------------------- 1 | o.(a,b).foo :1:9: 2 | | 3 | 1 | o.(a,b).foo 4 | | ^ 5 | unexpected '.' 6 | expecting end of input or white space 7 | -------------------------------------------------------------------------------- /test/goldens/schemaqq_key_with_invalid_character.golden: -------------------------------------------------------------------------------- 1 | { "a:b": Int } :1:6: 2 | | 3 | 1 | { "a:b": Int } 4 | | ^ 5 | unexpected ':' 6 | expecting '"' or '\' 7 | -------------------------------------------------------------------------------- /test/goldens/schemaqq_key_with_trailing_escape.golden: -------------------------------------------------------------------------------- 1 | { "a\": Int } :1:8: 2 | | 3 | 1 | { "a\": Int } 4 | | ^ 5 | unexpected ':' 6 | expecting '"' or '\' 7 | -------------------------------------------------------------------------------- /test/goldens/getqq_empty_expression.golden: -------------------------------------------------------------------------------- 1 | :1:2: 2 | | 3 | 1 | 4 | | ^ 5 | expecting "[]", '!', '"', '(', '.', '?', '@', '[', '\', lowercase letter, or white space 6 | -------------------------------------------------------------------------------- /test/goldens/getqq_no_operators.golden: -------------------------------------------------------------------------------- 1 | o :1:3: 2 | | 3 | 1 | o 4 | | ^ 5 | expecting "[]", '!', '"', ''', '(', '.', '?', '@', '[', '\', or alphanumeric character 6 | -------------------------------------------------------------------------------- /test/goldens/unwrapqq_unwrap_past_list.golden: -------------------------------------------------------------------------------- 1 | ABCSchema.[a,b].foo :1:17: 2 | | 3 | 1 | ABCSchema.[a,b].foo 4 | | ^ 5 | unexpected '.' 6 | expecting end of input or white space 7 | -------------------------------------------------------------------------------- /test/goldens/unwrapqq_unwrap_past_tuple.golden: -------------------------------------------------------------------------------- 1 | ABCSchema.(a,b).foo :1:17: 2 | | 3 | 1 | ABCSchema.(a,b).foo 4 | | ^ 5 | unexpected '.' 6 | expecting end of input or white space 7 | -------------------------------------------------------------------------------- /test/Tests/Object/Show/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | 4 | module Tests.Object.Show.TH where 5 | 6 | import Data.Aeson.Schema (schema) 7 | 8 | type UserSchema = [schema| { name: Text } |] 9 | -------------------------------------------------------------------------------- /test/goldens/fromjson_error_messages_truncate.golden: -------------------------------------------------------------------------------- 1 | Error in $: Could not parse path 'foo' with schema `SchemaScalar Int`: Array [Object (fromList [("bar",Number 1.0)]),Object (fromList [("bar",Number 2.0)]),Object (fromList [("bar",Number 3.0)]),Object (fromList [("bar",Number 4.0)]),Object (fromList [("bar",Number 5.0)]... -------------------------------------------------------------------------------- /.github/workflows/ghc-nightly.yml: -------------------------------------------------------------------------------- 1 | name: Test against GHC nightly release 2 | on: 3 | pull_request: 4 | push: 5 | branches: 6 | - main 7 | schedule: 8 | - cron: '0 0 * * *' # nightly 9 | 10 | jobs: 11 | test_ghc_nightly: 12 | uses: ./.github/workflows/ghc-compat-test.yml 13 | with: 14 | ghc_version: latest-nightly 15 | -------------------------------------------------------------------------------- /bench/Main.hs: -------------------------------------------------------------------------------- 1 | import Criterion.Main 2 | 3 | import qualified Benchmarks.FromJSON 4 | import qualified Benchmarks.SchemaQQ 5 | import qualified Benchmarks.Show 6 | import qualified Benchmarks.ToJSON 7 | 8 | main :: IO () 9 | main = 10 | defaultMain 11 | [ Benchmarks.SchemaQQ.benchmarks 12 | , Benchmarks.Show.benchmarks 13 | , Benchmarks.FromJSON.benchmarks 14 | , Benchmarks.ToJSON.benchmarks 15 | ] 16 | -------------------------------------------------------------------------------- /test/goldens/README_Quickstart.golden: -------------------------------------------------------------------------------- 1 | [1,2,3,4] 2 | Details for user #1: 3 | * Name: Alice 4 | * Age: 30 5 | * Groups: [{ "id": 1, "name": "admin" }] 6 | Details for user #2: 7 | * Name: Bob 8 | * Age: N/A 9 | * No groups 10 | Details for user #3: 11 | * Name: Charlie 12 | * Age: 25 13 | * Groups: [] 14 | Details for user #4: 15 | * Name: Darlene 16 | * Age: 40 17 | * Groups: [{ "id": 2, "name": "groupA" },{ "id": 3, "name": "groupB" }] 18 | -------------------------------------------------------------------------------- /test/Tests/Object/FromJSON/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Tests.Object.FromJSON.TH where 4 | 5 | import Data.Proxy (Proxy (..)) 6 | import Language.Haskell.TH.Quote (QuasiQuoter (quoteType)) 7 | 8 | import Data.Aeson.Schema (Object, schema) 9 | import TestUtils (mkExpQQ) 10 | 11 | schemaProxy :: QuasiQuoter 12 | schemaProxy = mkExpQQ $ \s -> 13 | let schemaType = [t|Object $(quoteType schema s)|] 14 | in [|Proxy :: Proxy $schemaType|] 15 | -------------------------------------------------------------------------------- /src/Data/Aeson/Schema/Utils/Invariant.hs: -------------------------------------------------------------------------------- 1 | module Data.Aeson.Schema.Utils.Invariant ( 2 | unreachable, 3 | ) where 4 | 5 | -- | An error function to indicate that a branch is unreachable. Provides a useful error message 6 | -- if it ends up happening, pointing users to write a bug report. 7 | unreachable :: String -> a 8 | unreachable msg = 9 | error $ 10 | unlines 11 | [ "`aeson-schemas` internal error: " ++ msg 12 | , "Please file a bug report at https://github.com/brandonchinn178/aeson-schemas/issues/" 13 | ] 14 | -------------------------------------------------------------------------------- /test/wont-compile/GetMissingKey.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE PartialTypeSignatures #-} 5 | {-# LANGUAGE QuasiQuotes #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | 8 | import Data.Aeson (decode) 9 | import Data.Maybe (fromJust) 10 | 11 | import Data.Aeson.Schema 12 | 13 | o :: Object [schema| { foo: Bool } |] 14 | o = fromJust $ decode "{ \"foo\": true }" 15 | 16 | result :: _ 17 | result = [get| o.missing |] 18 | 19 | main :: IO () 20 | main = pure () 21 | -------------------------------------------------------------------------------- /test/Tests/Object/Eq.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module Tests.Object.Eq where 5 | 6 | import Test.Tasty 7 | import Test.Tasty.QuickCheck 8 | 9 | import TestUtils (parseProxy) 10 | import TestUtils.Arbitrary (ArbitraryObject (..), forAllArbitraryObjects) 11 | 12 | test :: TestTree 13 | test = 14 | testGroup 15 | "Eq instance" 16 | [ testProperty "o === o" $ 17 | $(forAllArbitraryObjects) $ \(ArbitraryObject proxy v _) -> 18 | let o = either error id $ parseProxy proxy v 19 | in o === o 20 | ] 21 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | import Test.Tasty (defaultMain, testGroup) 2 | 3 | import qualified Tests.EnumTH 4 | import qualified Tests.GetQQ 5 | import qualified Tests.MkGetter 6 | import qualified Tests.Object 7 | import qualified Tests.Quickstart 8 | import qualified Tests.SchemaQQ 9 | import qualified Tests.SumType 10 | import qualified Tests.UnwrapQQ 11 | 12 | main :: IO () 13 | main = 14 | defaultMain $ 15 | testGroup 16 | "aeson-schemas" 17 | [ Tests.Object.test 18 | , Tests.GetQQ.test 19 | , Tests.UnwrapQQ.test 20 | , Tests.SchemaQQ.test 21 | , Tests.MkGetter.test 22 | , Tests.EnumTH.test 23 | , Tests.SumType.test 24 | , Tests.Quickstart.test 25 | ] 26 | -------------------------------------------------------------------------------- /src/Data/Aeson/Schema.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Data.Aeson.Schema 3 | Maintainer : Brandon Chinn 4 | Stability : experimental 5 | Portability : portable 6 | 7 | This module defines a new way of parsing JSON data by defining type-level schemas and 8 | extracting information using quasiquoters that will check if a given query path is 9 | valid at compile-time. 10 | -} 11 | module Data.Aeson.Schema ( 12 | -- * Object 13 | Object, 14 | toMap, 15 | 16 | -- * Schemas 17 | Schema, 18 | IsSchema, 19 | showSchema, 20 | 21 | -- * Quasiquoters for extracting or manipulating JSON data or schemas 22 | schema, 23 | get, 24 | unwrap, 25 | mkGetter, 26 | ) where 27 | 28 | import Data.Aeson.Schema.Internal 29 | import Data.Aeson.Schema.TH 30 | import Data.Aeson.Schema.Type 31 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: th-test-utils-1.2.2@sha256:d7b02eb9d2613e5e624298826ba03d4c11e18fa2fb8d4e378569224ae687fc4e,2193 9 | pantry-tree: 10 | sha256: eacb82118c7a96fc0e4ee9a45e3283155987b13fa21b8f65954acb1a55cdf50f 11 | size: 620 12 | original: 13 | hackage: th-test-utils-1.2.2 14 | snapshots: 15 | - completed: 16 | sha256: 2413f1dbf803da9cab3b6970d868cf7cd4c013b8776dee3cebd8b8ecbf85514c 17 | size: 619614 18 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2024/12/20.yaml 19 | original: nightly-2024-12-20 20 | -------------------------------------------------------------------------------- /src/Data/Aeson/Schema/Utils/Compat.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Data.Aeson.Schema.Utils.Compat ( 4 | -- * Key 5 | Key, 6 | keyToText, 7 | 8 | -- * KeyMap 9 | KeyMap, 10 | KeyMap.singleton, 11 | KeyMap.fromList, 12 | KeyMap.lookup, 13 | unions, 14 | ) where 15 | 16 | #if !MIN_VERSION_base(4,20,0) 17 | import Data.List (foldl') 18 | #endif 19 | 20 | import Data.Text (Text) 21 | import Prelude hiding (lookup) 22 | 23 | #if MIN_VERSION_aeson(2,0,0) 24 | import Data.Aeson.Key (Key) 25 | import qualified Data.Aeson.Key as Key 26 | import Data.Aeson.KeyMap (KeyMap) 27 | import qualified Data.Aeson.KeyMap as KeyMap 28 | 29 | keyToText :: Key -> Text 30 | keyToText = Key.toText 31 | #else 32 | import Data.HashMap.Strict (HashMap) 33 | import qualified Data.HashMap.Strict as KeyMap 34 | 35 | type Key = Text 36 | type KeyMap = HashMap Key 37 | 38 | keyToText :: Key -> Text 39 | keyToText = id 40 | #endif 41 | 42 | unions :: [KeyMap v] -> KeyMap v 43 | unions = foldl' KeyMap.union KeyMap.empty 44 | -------------------------------------------------------------------------------- /src/Data/Aeson/Schema/Utils/NameLike.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE TemplateHaskellQuotes #-} 3 | 4 | module Data.Aeson.Schema.Utils.NameLike ( 5 | NameLike (..), 6 | fromName, 7 | resolveName, 8 | ) where 9 | 10 | import Data.Text (Text) 11 | import Language.Haskell.TH.Syntax (Name, Q, lookupTypeName, nameBase) 12 | 13 | data NameLike = NameRef String | NameTH Name 14 | 15 | instance Eq NameLike where 16 | ty1 == ty2 = fromName ty1 == fromName ty2 17 | 18 | instance Show NameLike where 19 | show = show . fromName 20 | 21 | fromName :: NameLike -> String 22 | fromName = \case 23 | NameRef s -> s 24 | NameTH name -> nameBase name 25 | 26 | resolveName :: NameLike -> Q Name 27 | resolveName = \case 28 | -- some hardcoded cases 29 | NameRef "Bool" -> pure ''Bool 30 | NameRef "Int" -> pure ''Int 31 | NameRef "Double" -> pure ''Double 32 | NameRef "Text" -> pure ''Text 33 | -- general cases 34 | NameRef name -> lookupTypeName name >>= maybe (fail $ "Unknown type: " ++ name) pure 35 | NameTH name -> pure name 36 | -------------------------------------------------------------------------------- /bench/Benchmarks/Show.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | {-# OPTIONS_GHC -freduction-depth=0 #-} 3 | 4 | module Benchmarks.Show where 5 | 6 | import Criterion.Main 7 | 8 | import Benchmarks.Data.Objects 9 | import Benchmarks.Data.Schemas 10 | 11 | benchmarks :: Benchmark 12 | benchmarks = 13 | bgroup 14 | "Show instance" 15 | [ byKeys 16 | , byNestedKeys 17 | ] 18 | where 19 | byKeys = 20 | bgroup 21 | "# of keys" 22 | [ bench "1" $ nf show (schemaObject @Schema1) 23 | , bench "5" $ nf show (schemaObject @Schema5) 24 | , bench "10" $ nf show (schemaObject @Schema10) 25 | , bench "100" $ nf show (schemaObject @Schema100) 26 | ] 27 | 28 | byNestedKeys = 29 | bgroup 30 | "# of nested keys" 31 | [ bench "1" $ nf show (schemaObject @SchemaNest1) 32 | , bench "5" $ nf show (schemaObject @SchemaNest5) 33 | , bench "10" $ nf show (schemaObject @SchemaNest10) 34 | , bench "100" $ nf show (schemaObject @SchemaNest100) 35 | ] 36 | -------------------------------------------------------------------------------- /src/Data/Aeson/Schema/Utils/All.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE PolyKinds #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | 12 | module Data.Aeson.Schema.Utils.All ( 13 | All (..), 14 | ) where 15 | 16 | import Data.Proxy (Proxy (..)) 17 | 18 | -- | A type family for traversing a type-level list. 19 | class All f xs where 20 | mapAll :: forall a. (forall x. (f x) => Proxy x -> a) -> [a] 21 | mapAll f = foldrAll @f @xs f' [] 22 | where 23 | f' :: forall x. (f x) => Proxy x -> [a] -> [a] 24 | f' proxy acc = f proxy : acc 25 | 26 | foldrAll :: (forall x. (f x) => Proxy x -> a -> a) -> a -> a 27 | 28 | instance All f '[] where 29 | foldrAll _ acc = acc 30 | 31 | instance (f x, All f xs) => All f (x ': xs) where 32 | foldrAll f acc = f (Proxy @x) (foldrAll @f @xs f acc) 33 | -------------------------------------------------------------------------------- /test/Tests/Object.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | 5 | module Tests.Object where 6 | 7 | import Data.Aeson (Value (..)) 8 | import Data.Aeson.QQ (aesonQQ) 9 | import Test.Tasty 10 | import Test.Tasty.HUnit 11 | 12 | import Data.Aeson.Schema (Object, schema, toMap) 13 | import qualified Data.Aeson.Schema.Utils.Compat as Compat 14 | import TestUtils (parseValue) 15 | import qualified Tests.Object.Eq 16 | import qualified Tests.Object.FromJSON 17 | import qualified Tests.Object.Show 18 | import qualified Tests.Object.ToJSON 19 | 20 | test :: TestTree 21 | test = 22 | testGroup 23 | "Object" 24 | [ Tests.Object.Show.test 25 | , Tests.Object.Eq.test 26 | , Tests.Object.FromJSON.test 27 | , Tests.Object.ToJSON.test 28 | , testCase "toMap smoketest" $ 29 | let o :: Object [schema| { a: Bool } |] 30 | o = parseValue [aesonQQ| { "a": true } |] 31 | in toMap o 32 | @?= Compat.fromList 33 | [ ("a", Bool True) 34 | ] 35 | ] 36 | -------------------------------------------------------------------------------- /bench/Benchmarks/ToJSON.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | {-# OPTIONS_GHC -freduction-depth=0 #-} 3 | 4 | module Benchmarks.ToJSON where 5 | 6 | import Criterion.Main 7 | import qualified Data.Aeson as Aeson 8 | 9 | import Benchmarks.Data.Objects 10 | import Benchmarks.Data.Schemas 11 | 12 | benchmarks :: Benchmark 13 | benchmarks = 14 | bgroup 15 | "ToJSON instance" 16 | [ byKeys 17 | , byNestedKeys 18 | ] 19 | where 20 | byKeys = 21 | bgroup 22 | "# of keys" 23 | [ bench "1" $ nf Aeson.toJSON (schemaObject @Schema1) 24 | , bench "5" $ nf Aeson.toJSON (schemaObject @Schema5) 25 | , bench "10" $ nf Aeson.toJSON (schemaObject @Schema10) 26 | , bench "100" $ nf Aeson.toJSON (schemaObject @Schema100) 27 | ] 28 | 29 | byNestedKeys = 30 | bgroup 31 | "# of nested keys" 32 | [ bench "1" $ nf Aeson.toJSON (schemaObject @SchemaNest1) 33 | , bench "5" $ nf Aeson.toJSON (schemaObject @SchemaNest5) 34 | , bench "10" $ nf Aeson.toJSON (schemaObject @SchemaNest10) 35 | , bench "100" $ nf Aeson.toJSON (schemaObject @SchemaNest100) 36 | ] 37 | -------------------------------------------------------------------------------- /examples/input.json: -------------------------------------------------------------------------------- 1 | { 2 | "users": [ 3 | { 4 | "id": 1, 5 | "name": "Alice", 6 | "age": 30, 7 | "enabled": true, 8 | "groups": [ 9 | { 10 | "id": 1, 11 | "name": "admin" 12 | } 13 | ] 14 | }, 15 | { 16 | "id": 2, 17 | "name": "Bob", 18 | "age": null, 19 | "enabled": false, 20 | "groups": null 21 | }, 22 | { 23 | "id": 3, 24 | "name": "Charlie", 25 | "age": 25, 26 | "enabled": true, 27 | "groups": [ 28 | ] 29 | }, 30 | { 31 | "id": 4, 32 | "name": "Darlene", 33 | "age": 40, 34 | "enabled": true, 35 | "groups": [ 36 | { 37 | "id": 2, 38 | "name": "groupA" 39 | }, 40 | { 41 | "id": 3, 42 | "name": "groupB" 43 | } 44 | ] 45 | } 46 | ] 47 | } 48 | -------------------------------------------------------------------------------- /test/Tests/Object/ToJSON.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# OPTIONS_GHC -Wno-orphans #-} 5 | 6 | module Tests.Object.ToJSON where 7 | 8 | import Data.Aeson (FromJSON (..), ToJSON (..)) 9 | import qualified Data.Aeson.Types as Aeson 10 | import Test.Tasty 11 | import Test.Tasty.QuickCheck 12 | 13 | import TestUtils (parseProxy) 14 | import TestUtils.Arbitrary (ArbitraryObject (..), forAllArbitraryObjects) 15 | 16 | test :: TestTree 17 | test = 18 | testGroup 19 | "ToJSON instance" 20 | [ testProperty "parseJSON . toJSON === pure" $ 21 | $(forAllArbitraryObjects) $ \(ArbitraryObject proxy v _) -> 22 | let o = either error id $ parseProxy proxy v 23 | in (parseJSON . toJSON) o === pure o 24 | ] 25 | 26 | {- Realizing Aeson.Parser -} 27 | 28 | -- We're defining two Parsers to be equivalent if they evaluate to the same result. 29 | instance (Eq a) => Eq (Aeson.Parser a) where 30 | a == b = runParser a == runParser b 31 | 32 | instance (Show a) => Show (Aeson.Parser a) where 33 | show = show . runParser 34 | 35 | runParser :: Aeson.Parser a -> Aeson.Result a 36 | runParser = Aeson.parse id 37 | -------------------------------------------------------------------------------- /bench/Benchmarks/Data/Schemas/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | module Benchmarks.Data.Schemas.TH ( 4 | SchemaDef (..), 5 | genSchema, 6 | genSchema', 7 | genSchemaDef, 8 | keysTo, 9 | mkField, 10 | ) where 11 | 12 | import Data.List (intercalate) 13 | import Language.Haskell.TH 14 | import Language.Haskell.TH.Quote 15 | 16 | import Data.Aeson.Schema (schema) 17 | 18 | data SchemaDef 19 | = -- | { a: Int } 20 | Field String String 21 | | -- | { a: #OtherSchema } 22 | Include String String 23 | | -- | { #OtherSchema } 24 | Ref String 25 | 26 | genSchema :: Name -> [SchemaDef] -> DecQ 27 | genSchema name = genSchema' name . genSchemaDef 28 | 29 | genSchema' :: Name -> String -> DecQ 30 | genSchema' name = tySynD name [] . quoteType schema 31 | 32 | genSchemaDef :: [SchemaDef] -> String 33 | genSchemaDef schemaDef = "{" ++ intercalate "," (map fromSchemaDef schemaDef) ++ "}" 34 | where 35 | fromSchemaDef = \case 36 | Field key ty -> key ++ ": " ++ ty 37 | Include key name -> key ++ ": #" ++ name 38 | Ref name -> "#" ++ name 39 | 40 | keysTo :: Int -> [SchemaDef] 41 | keysTo n = map (\i -> Field (mkField i) "Int") [1 .. n] 42 | 43 | mkField :: Int -> String 44 | mkField i = "a" ++ show i 45 | -------------------------------------------------------------------------------- /test/Tests/GetQQ/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | 5 | module Tests.GetQQ.TH where 6 | 7 | import Control.DeepSeq (deepseq) 8 | import Data.Aeson.QQ (aesonQQ) 9 | import Language.Haskell.TH.Quote (QuasiQuoter (..)) 10 | import Language.Haskell.TH.TestUtils ( 11 | MockedMode (..), 12 | QMode (..), 13 | QState (..), 14 | runTestQ, 15 | runTestQErr, 16 | ) 17 | 18 | import Data.Aeson.Schema (Object, get, schema) 19 | import TestUtils (mkExpQQ, parseValue) 20 | import TestUtils.DeepSeq () 21 | 22 | -- For testing namespaced object 23 | testData :: Object [schema| { foo: Maybe Int } |] 24 | testData = parseValue [aesonQQ| { "foo": null } |] 25 | 26 | qState :: QState 'FullyMocked 27 | qState = 28 | QState 29 | { mode = MockQ 30 | , knownNames = [] 31 | , reifyInfo = [] 32 | } 33 | 34 | -- | Run the `get` quasiquoter at both runtime and compile-time, to get coverage. 35 | -- 36 | -- The `get` Quasiquoter doesn't reify anything, so this should work. 37 | runGet :: QuasiQuoter 38 | runGet = mkExpQQ $ \s -> [|runTestQ qState (quoteExp get s) `deepseq` $(quoteExp get s)|] 39 | 40 | getErr :: QuasiQuoter 41 | getErr = mkExpQQ $ \s -> [|runTestQErr qState (quoteExp get s)|] 42 | -------------------------------------------------------------------------------- /src/Data/Aeson/Schema/TH.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Data.Aeson.Schema.TH 3 | Maintainer : Brandon Chinn 4 | Stability : experimental 5 | Portability : portable 6 | 7 | Template Haskell definitions for doing various @aeson-schemas@ operations. 8 | 9 | 'Data.Aeson.Schema.SchemaType' defines the shape of the JSON object stored in 10 | 'Data.Aeson.Schema.Object', and we can use 'Data.Aeson.Schema.Internal.getKey' to lookup a key that 11 | is checked at compile-time to exist in the object. 12 | 13 | To make it easier to extract deeply nested keys, this module defines QuasiQuoters that generate the 14 | corresponding 'Data.Aeson.Schema.Internal.getKey' expressions. 15 | 16 | In addition to the QuasiQuotes extension, the following extensions will need to be enabled to 17 | use these QuasiQuoters: 18 | 19 | * DataKinds 20 | * FlexibleContexts 21 | * TypeFamilies 22 | -} 23 | module Data.Aeson.Schema.TH ( 24 | schema, 25 | get, 26 | unwrap, 27 | 28 | -- * Utilities 29 | mkGetter, 30 | 31 | -- * Helpers for Enum types 32 | mkEnum, 33 | genFromJSONEnum, 34 | genToJSONEnum, 35 | ) where 36 | 37 | import Data.Aeson.Schema.TH.Enum 38 | import Data.Aeson.Schema.TH.Get 39 | import Data.Aeson.Schema.TH.Getter 40 | import Data.Aeson.Schema.TH.Schema 41 | import Data.Aeson.Schema.TH.Unwrap 42 | -------------------------------------------------------------------------------- /test/Tests/Quickstart.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Tests.Quickstart (test) where 4 | 5 | import Data.Maybe (fromMaybe) 6 | import Data.Text (Text) 7 | import qualified Data.Text as Text 8 | import qualified Data.Text.IO as Text 9 | import System.FilePath (()) 10 | import System.IO.Temp (withSystemTempDirectory) 11 | import System.Process (readProcess) 12 | import Test.Tasty (TestTree) 13 | 14 | import TestUtils (testGoldenIO) 15 | 16 | test :: TestTree 17 | test = testGoldenIO "README Quickstart works" "README_Quickstart.golden" $ 18 | withSystemTempDirectory "readme-quickstart" $ \tmpdir -> do 19 | let testfile = tmpdir "readme_quickstart.hs" 20 | readme <- Text.readFile "README.md" 21 | Text.writeFile testfile (getQuickstartCode readme) 22 | readProcess "runghc" [testfile] "" 23 | 24 | getQuickstartCode :: Text -> Text 25 | getQuickstartCode = Text.unlines . getQuickstartLines . Text.lines 26 | where 27 | getQuickstartLines readmeLines = 28 | fromMaybe (error "Could not find Quickstart in README") $ 29 | between (== "## Quickstart") ("## " `Text.isPrefixOf`) readmeLines 30 | >>= between (== "```haskell") (== "```") 31 | 32 | between start end xs = 33 | case dropWhile (not . start) xs of 34 | [] -> Nothing 35 | _ : afterStart -> Just $ takeWhile (not . end) afterStart 36 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright © 2023-present Brandon Chinn 2 | 3 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 4 | 5 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 6 | 7 | 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 8 | 9 | 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. 10 | 11 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 12 | -------------------------------------------------------------------------------- /bench/Benchmarks/FromJSON.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | {-# OPTIONS_GHC -Wno-orphans #-} 6 | {-# OPTIONS_GHC -freduction-depth=0 #-} 7 | 8 | module Benchmarks.FromJSON where 9 | 10 | import Control.DeepSeq (NFData (..)) 11 | import Criterion.Main 12 | import qualified Data.Aeson as Aeson 13 | 14 | import Data.Aeson.Schema (IsSchema, Object) 15 | 16 | import Benchmarks.Data.Objects 17 | import Benchmarks.Data.Schemas 18 | 19 | benchmarks :: Benchmark 20 | benchmarks = 21 | bgroup 22 | "FromJSON instance" 23 | [ byKeys 24 | , byNestedKeys 25 | ] 26 | where 27 | byKeys = 28 | bgroup 29 | "# of keys" 30 | [ bench "1" $ nf (Aeson.fromJSON @(Object Schema1)) (schemaValue @Schema1) 31 | , bench "5" $ nf (Aeson.fromJSON @(Object Schema5)) (schemaValue @Schema5) 32 | , bench "10" $ nf (Aeson.fromJSON @(Object Schema10)) (schemaValue @Schema10) 33 | , bench "100" $ nf (Aeson.fromJSON @(Object Schema100)) (schemaValue @Schema100) 34 | ] 35 | 36 | byNestedKeys = 37 | bgroup 38 | "# of nested keys" 39 | [ bench "1" $ nf (Aeson.fromJSON @(Object SchemaNest1)) (schemaValue @SchemaNest1) 40 | , bench "5" $ nf (Aeson.fromJSON @(Object SchemaNest5)) (schemaValue @SchemaNest5) 41 | , bench "10" $ nf (Aeson.fromJSON @(Object SchemaNest10)) (schemaValue @SchemaNest10) 42 | , bench "100" $ nf (Aeson.fromJSON @(Object SchemaNest100)) (schemaValue @SchemaNest100) 43 | ] 44 | 45 | {- Orphans -} 46 | 47 | instance (IsSchema schema) => NFData (Object schema) where 48 | rnf = rnf . show 49 | -------------------------------------------------------------------------------- /bench/Utils/DeepSeq.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# OPTIONS_GHC -Wno-orphans #-} 3 | 4 | module Utils.DeepSeq () where 5 | 6 | import Control.DeepSeq (NFData (..), rwhnf) 7 | import GHC.ForeignPtr (ForeignPtr) 8 | import Language.Haskell.TH.Syntax 9 | 10 | instance NFData AnnTarget 11 | instance NFData Bang 12 | instance NFData Body 13 | instance NFData Callconv 14 | instance NFData Clause 15 | instance NFData Con 16 | instance NFData Dec 17 | instance NFData DerivClause 18 | instance NFData DerivStrategy 19 | instance NFData Exp 20 | instance NFData FamilyResultSig 21 | instance NFData Fixity 22 | instance NFData FixityDirection 23 | instance NFData Foreign 24 | instance NFData FunDep 25 | instance NFData Guard 26 | instance NFData InjectivityAnn 27 | instance NFData Inline 28 | instance NFData Lit 29 | instance NFData Match 30 | instance NFData ModName 31 | instance NFData Name 32 | instance NFData NameFlavour 33 | instance NFData NameSpace 34 | instance NFData OccName 35 | instance NFData Overlap 36 | instance NFData Pat 37 | instance NFData PatSynArgs 38 | instance NFData PatSynDir 39 | instance NFData Phases 40 | instance NFData PkgName 41 | instance NFData Pragma 42 | instance NFData Range 43 | instance NFData Role 44 | instance NFData RuleBndr 45 | instance NFData RuleMatch 46 | instance NFData Safety 47 | instance NFData SourceStrictness 48 | instance NFData SourceUnpackedness 49 | instance NFData Stmt 50 | instance NFData Type 51 | instance NFData TypeFamilyHead 52 | instance NFData TyLit 53 | instance NFData TySynEqn 54 | instance NFData Specificity 55 | instance (NFData flag) => NFData (TyVarBndr flag) 56 | instance NFData BndrVis 57 | instance NFData Bytes 58 | 59 | #if MIN_VERSION_template_haskell(2,22,0) 60 | instance NFData NamespaceSpecifier 61 | #endif 62 | 63 | instance NFData (ForeignPtr a) where 64 | rnf = rwhnf 65 | -------------------------------------------------------------------------------- /test/TestUtils/DeepSeq.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# OPTIONS_GHC -Wno-orphans #-} 3 | 4 | module TestUtils.DeepSeq () where 5 | 6 | import Control.DeepSeq (NFData (..), rwhnf) 7 | import GHC.ForeignPtr (ForeignPtr) 8 | import Language.Haskell.TH.Syntax 9 | 10 | instance NFData AnnTarget 11 | instance NFData Bang 12 | instance NFData Body 13 | instance NFData Callconv 14 | instance NFData Clause 15 | instance NFData Con 16 | instance NFData Dec 17 | instance NFData DerivClause 18 | instance NFData DerivStrategy 19 | instance NFData Exp 20 | instance NFData FamilyResultSig 21 | instance NFData Fixity 22 | instance NFData FixityDirection 23 | instance NFData Foreign 24 | instance NFData FunDep 25 | instance NFData Guard 26 | instance NFData InjectivityAnn 27 | instance NFData Inline 28 | instance NFData Lit 29 | instance NFData Match 30 | instance NFData ModName 31 | instance NFData Name 32 | instance NFData NameFlavour 33 | instance NFData NameSpace 34 | instance NFData OccName 35 | instance NFData Overlap 36 | instance NFData Pat 37 | instance NFData PatSynArgs 38 | instance NFData PatSynDir 39 | instance NFData Phases 40 | instance NFData PkgName 41 | instance NFData Pragma 42 | instance NFData Range 43 | instance NFData Role 44 | instance NFData RuleBndr 45 | instance NFData RuleMatch 46 | instance NFData Safety 47 | instance NFData SourceStrictness 48 | instance NFData SourceUnpackedness 49 | instance NFData Stmt 50 | instance NFData Type 51 | instance NFData TypeFamilyHead 52 | instance NFData TyLit 53 | instance NFData TySynEqn 54 | instance NFData Specificity 55 | instance (NFData flag) => NFData (TyVarBndr flag) 56 | instance NFData BndrVis 57 | instance NFData Bytes 58 | 59 | #if MIN_VERSION_template_haskell(2,22,0) 60 | instance NFData NamespaceSpecifier 61 | #endif 62 | 63 | instance NFData (ForeignPtr a) where 64 | rnf = rwhnf 65 | -------------------------------------------------------------------------------- /test/goldens/ghc/9.8/getqq_missing_key.golden: -------------------------------------------------------------------------------- 1 | 2 | test/wont-compile/GetMissingKey.hs:17:15: error: [GHC-64725] 3 | • Key 'missing' does not exist in the following schema: 4 | '[ '(Data.Aeson.Schema.Key.NormalKey "foo", 5 | Data.Aeson.Schema.Type.SchemaScalar Bool)] 6 | • In the second argument of ‘(.)’, namely 7 | ‘Data.Aeson.Schema.Internal.getKey 8 | (Data.Proxy.Proxy :: Data.Proxy.Proxy "missing")’ 9 | In the expression: 10 | (id 11 | . Data.Aeson.Schema.Internal.getKey 12 | (Data.Proxy.Proxy :: Data.Proxy.Proxy "missing")) 13 | o 14 | In an equation for ‘result’: 15 | result 16 | = ((id 17 | . Data.Aeson.Schema.Internal.getKey 18 | (Data.Proxy.Proxy :: Data.Proxy.Proxy "missing")) 19 | o) 20 | | 21 | 17 | result = [get| o.missing |] 22 | | ^^^^^^^^^^^^^ 23 | 24 | test/wont-compile/GetMissingKey.hs:17:15: error: [GHC-64725] 25 | • Key 'missing' does not exist in the following schema: 26 | '[ '(Data.Aeson.Schema.Key.NormalKey "foo", 27 | Data.Aeson.Schema.Type.SchemaScalar Bool)] 28 | • In the second argument of ‘(.)’, namely 29 | ‘Data.Aeson.Schema.Internal.getKey 30 | (Data.Proxy.Proxy :: Data.Proxy.Proxy "missing")’ 31 | In the expression: 32 | (id 33 | . Data.Aeson.Schema.Internal.getKey 34 | (Data.Proxy.Proxy :: Data.Proxy.Proxy "missing")) 35 | o 36 | In an equation for ‘result’: 37 | result 38 | = ((id 39 | . Data.Aeson.Schema.Internal.getKey 40 | (Data.Proxy.Proxy :: Data.Proxy.Proxy "missing")) 41 | o) 42 | | 43 | 17 | result = [get| o.missing |] 44 | | ^^^^^^^^^^^^^ 45 | -------------------------------------------------------------------------------- /.github/workflows/release.yml: -------------------------------------------------------------------------------- 1 | name: Release 2 | on: workflow_dispatch 3 | 4 | jobs: 5 | ci: 6 | uses: ./.github/workflows/ci.yml 7 | 8 | release: 9 | runs-on: ubuntu-latest 10 | needs: 11 | - ci 12 | 13 | steps: 14 | - 15 | uses: actions/checkout@v3 16 | - 17 | uses: actions/download-artifact@v3 18 | with: 19 | name: aeson-schemas-sdist 20 | path: ./sdist/ 21 | - 22 | uses: haskell-actions/parse-cabal-file@v1 23 | id: cabal_file 24 | with: 25 | cabal_file: aeson-schemas.cabal 26 | - 27 | name: Set version label 28 | run: echo 'VERSION=v${{ steps.cabal_file.outputs.version }}' >> "${GITHUB_ENV}" 29 | - 30 | name: Get CHANGELOG section 31 | run: | 32 | sed '/^# Unreleased/,/^$/d' CHANGELOG.md > /tmp/changelog-without-unreleased 33 | if [[ "$(head -n 1 /tmp/changelog-without-unreleased)" != "# ${VERSION}" ]]; then 34 | echo "CHANGELOG doesn't look updated" >&2 35 | exit 1 36 | fi 37 | sed '1 d; /^# v/,$ d' /tmp/changelog-without-unreleased > /tmp/changelog-body 38 | - 39 | id: hackage_token_secret 40 | name: Load Hackage token secret name 41 | run: | 42 | USERNAME="$(echo "${GITHUB_ACTOR}" | tr '[:lower:]' '[:upper:]' | tr '-' '_')" 43 | echo "name=HACKAGE_TOKEN_${USERNAME}" >> "${GITHUB_OUTPUT}" 44 | - 45 | uses: haskell-actions/hackage-publish@v1 46 | with: 47 | hackageToken: ${{ secrets[steps.hackage_token_secret.outputs.name] }} 48 | packagesPath: ./sdist/ 49 | - 50 | uses: softprops/action-gh-release@v1 51 | with: 52 | tag_name: ${{ env.VERSION }} 53 | body_path: /tmp/changelog-body 54 | draft: true 55 | target_commitish: ${{ github.sha }} 56 | -------------------------------------------------------------------------------- /test/goldens/ghc/9.10/getqq_missing_key.golden: -------------------------------------------------------------------------------- 1 | test/wont-compile/GetMissingKey.hs:17:15: error: [GHC-64725] 2 | • Key 'missing' does not exist in the following schema: 3 | '[ '(Data.Aeson.Schema.Key.NormalKey "foo", 4 | Data.Aeson.Schema.Type.SchemaScalar Bool)] 5 | • In the second argument of ‘(.)’, namely 6 | ‘Data.Aeson.Schema.Internal.getKey 7 | (GHC.Internal.Data.Proxy.Proxy :: 8 | GHC.Internal.Data.Proxy.Proxy "missing")’ 9 | In the expression: 10 | (id 11 | . Data.Aeson.Schema.Internal.getKey 12 | (GHC.Internal.Data.Proxy.Proxy :: 13 | GHC.Internal.Data.Proxy.Proxy "missing")) 14 | o 15 | In an equation for ‘result’: 16 | result 17 | = ((id 18 | . Data.Aeson.Schema.Internal.getKey 19 | (GHC.Internal.Data.Proxy.Proxy :: 20 | GHC.Internal.Data.Proxy.Proxy "missing")) 21 | o) 22 | | 23 | 17 | result = [get| o.missing |] 24 | | ^^^^^^^^^^^^^ 25 | 26 | test/wont-compile/GetMissingKey.hs:17:15: error: [GHC-64725] 27 | • Key 'missing' does not exist in the following schema: 28 | '[ '(Data.Aeson.Schema.Key.NormalKey "foo", 29 | Data.Aeson.Schema.Type.SchemaScalar Bool)] 30 | • In the second argument of ‘(.)’, namely 31 | ‘Data.Aeson.Schema.Internal.getKey 32 | (GHC.Internal.Data.Proxy.Proxy :: 33 | GHC.Internal.Data.Proxy.Proxy "missing")’ 34 | In the expression: 35 | (id 36 | . Data.Aeson.Schema.Internal.getKey 37 | (GHC.Internal.Data.Proxy.Proxy :: 38 | GHC.Internal.Data.Proxy.Proxy "missing")) 39 | o 40 | In an equation for ‘result’: 41 | result 42 | = ((id 43 | . Data.Aeson.Schema.Internal.getKey 44 | (GHC.Internal.Data.Proxy.Proxy :: 45 | GHC.Internal.Data.Proxy.Proxy "missing")) 46 | o) 47 | | 48 | 17 | result = [get| o.missing |] 49 | | ^^^^^^^^^^^^^ 50 | 51 | -------------------------------------------------------------------------------- /test/goldens/ghc/9.12/getqq_missing_key.golden: -------------------------------------------------------------------------------- 1 | test/wont-compile/GetMissingKey.hs:17:15: error: [GHC-64725] 2 | • Key 'missing' does not exist in the following schema: 3 | '[ '(Data.Aeson.Schema.Key.NormalKey "foo", 4 | Data.Aeson.Schema.Type.SchemaScalar Bool)] 5 | • In the second argument of ‘(.)’, namely 6 | ‘Data.Aeson.Schema.Internal.getKey 7 | (GHC.Internal.Data.Proxy.Proxy :: 8 | GHC.Internal.Data.Proxy.Proxy "missing")’ 9 | In the expression: 10 | (id 11 | . Data.Aeson.Schema.Internal.getKey 12 | (GHC.Internal.Data.Proxy.Proxy :: 13 | GHC.Internal.Data.Proxy.Proxy "missing")) 14 | o 15 | In an equation for ‘result’: 16 | result 17 | = ((id 18 | . Data.Aeson.Schema.Internal.getKey 19 | (GHC.Internal.Data.Proxy.Proxy :: 20 | GHC.Internal.Data.Proxy.Proxy "missing")) 21 | o) 22 | | 23 | 17 | result = [get| o.missing |] 24 | | ^^^^^^^^^^^^^ 25 | 26 | test/wont-compile/GetMissingKey.hs:17:15: error: [GHC-64725] 27 | • Key 'missing' does not exist in the following schema: 28 | '[ '(Data.Aeson.Schema.Key.NormalKey "foo", 29 | Data.Aeson.Schema.Type.SchemaScalar Bool)] 30 | • In the second argument of ‘(.)’, namely 31 | ‘Data.Aeson.Schema.Internal.getKey 32 | (GHC.Internal.Data.Proxy.Proxy :: 33 | GHC.Internal.Data.Proxy.Proxy "missing")’ 34 | In the expression: 35 | (id 36 | . Data.Aeson.Schema.Internal.getKey 37 | (GHC.Internal.Data.Proxy.Proxy :: 38 | GHC.Internal.Data.Proxy.Proxy "missing")) 39 | o 40 | In an equation for ‘result’: 41 | result 42 | = ((id 43 | . Data.Aeson.Schema.Internal.getKey 44 | (GHC.Internal.Data.Proxy.Proxy :: 45 | GHC.Internal.Data.Proxy.Proxy "missing")) 46 | o) 47 | | 48 | 17 | result = [get| o.missing |] 49 | | ^^^^^^^^^^^^^ 50 | 51 | -------------------------------------------------------------------------------- /test/Tests/MkGetter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | 9 | module Tests.MkGetter where 10 | 11 | import Control.DeepSeq (deepseq) 12 | import Data.Text (Text) 13 | import Language.Haskell.TH.TestUtils ( 14 | QMode (..), 15 | QState (..), 16 | loadNames, 17 | runTestQ, 18 | runTestQErr, 19 | ) 20 | import Test.Tasty 21 | import Test.Tasty.HUnit 22 | import Text.RawString.QQ (r) 23 | 24 | import Data.Aeson.Schema (Object, get, mkGetter, schema) 25 | import TestUtils (json, showSchemaResult) 26 | import TestUtils.DeepSeq () 27 | 28 | type MySchema = [schema| { users: List { name: Text } } |] 29 | 30 | mkGetter "User" "getUsers" ''MySchema ".users[]" 31 | 32 | test :: TestTree 33 | test = 34 | runMkGetterQ `deepseq` 35 | testGroup 36 | "`mkGetter` helper" 37 | [ testCase "Type synonym is generated" $ 38 | showSchemaResult @User @?= [r|Object (SchemaObject { "name": Text })|] 39 | , testCase "Getter function is generated" $ 40 | let users :: [User] 41 | users = getUsers testData 42 | 43 | getName :: User -> Text 44 | getName = [get| .name |] 45 | in map getName users @?= ["Alice", "Bob", "Claire"] 46 | , testCase "mkGetter expression should be a lambda expression" $ 47 | let msg = runTestQErr qState $ mkGetter "User" "getUsers" ''MySchema "foo.users[]" 48 | in msg @?= "Getter expression should start with '.': foo.users[]" 49 | ] 50 | where 51 | qState = 52 | QState 53 | { mode = MockQ 54 | , knownNames = [] 55 | , reifyInfo = $(loadNames [''MySchema]) 56 | } 57 | 58 | -- run same mkGetter expression that was spliced, for coverage 59 | runMkGetterQ = runTestQ qState $ mkGetter "User" "getUsers" ''MySchema ".users[]" 60 | 61 | testData :: Object MySchema 62 | testData = 63 | [json| 64 | { 65 | "users": [ 66 | { "name": "Alice" }, 67 | { "name": "Bob" }, 68 | { "name": "Claire" } 69 | ] 70 | } 71 | |] 72 | -------------------------------------------------------------------------------- /bench/Benchmarks/Data/Objects.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeApplications #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | 12 | module Benchmarks.Data.Objects where 13 | 14 | import Data.Aeson (ToJSON (..), Value) 15 | import Data.Dynamic (Dynamic, Typeable, toDyn) 16 | import Data.Proxy (Proxy (..)) 17 | import Data.String (fromString) 18 | 19 | import Data.Aeson.Schema.Internal (Object (..), SchemaResult) 20 | import Data.Aeson.Schema.Key (IsSchemaKey, SchemaKey, fromSchemaKey) 21 | import Data.Aeson.Schema.Type ( 22 | IsSchemaObjectMap, 23 | SchemaType, 24 | SchemaType' (..), 25 | ToSchemaObject, 26 | ) 27 | import Data.Aeson.Schema.Utils.All (All (..)) 28 | import qualified Data.Aeson.Schema.Utils.Compat as Compat 29 | 30 | type MockSchema schema = 31 | ( MockSchemaResult (ToSchemaObject schema) 32 | , Object schema ~ SchemaResult (ToSchemaObject schema) 33 | , ToJSON (Object schema) 34 | ) 35 | 36 | schemaObject :: forall schema. (MockSchema schema) => Object schema 37 | schemaObject = schemaResult (Proxy @(ToSchemaObject schema)) 38 | 39 | schemaValue :: forall schema. (MockSchema schema) => Value 40 | schemaValue = toJSON $ schemaObject @schema 41 | 42 | class (Typeable (SchemaResult schema)) => MockSchemaResult (schema :: SchemaType) where 43 | schemaResult :: Proxy schema -> SchemaResult schema 44 | 45 | instance MockSchemaResult ('SchemaScalar Int) where 46 | schemaResult _ = 42 47 | 48 | instance 49 | ( All MockSchemaResultPair pairs 50 | , IsSchemaObjectMap pairs 51 | , Typeable pairs 52 | ) => 53 | MockSchemaResult ('SchemaObject pairs) 54 | where 55 | schemaResult _ = UnsafeObject $ Compat.fromList $ mapAll @MockSchemaResultPair @pairs schemaResultPair 56 | 57 | class MockSchemaResultPair (pair :: (SchemaKey, SchemaType)) where 58 | schemaResultPair :: Proxy pair -> (Compat.Key, Dynamic) 59 | 60 | instance (IsSchemaKey key, MockSchemaResult inner) => MockSchemaResultPair '(key, inner) where 61 | schemaResultPair _ = (fromString $ fromSchemaKey @key, toDyn $ schemaResult $ Proxy @inner) 62 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: aeson-schemas 2 | version: 1.4.3.0 3 | verbatim: 4 | cabal-version: '>= 1.10' 5 | license: BSD3 6 | license-file: LICENSE.md 7 | author: 8 | - Brandon Chinn 9 | maintainer: 10 | - Brandon Chinn 11 | category: JSON 12 | synopsis: Easily consume JSON data on-demand with type-safety 13 | description: | 14 | Parse JSON data easily and safely without defining new data types. Useful 15 | for deeply nested JSON data, which is difficult to parse using the default 16 | FromJSON instances. 17 | extra-source-files: 18 | - README.md 19 | - CHANGELOG.md 20 | - examples/*.json 21 | - test/**/*.golden 22 | - test/wont-compile/*.hs 23 | 24 | github: brandonchinn178/aeson-schemas 25 | 26 | ghc-options: 27 | - -Wall 28 | - -Wcompat 29 | - -Wincomplete-record-updates 30 | - -Wincomplete-uni-patterns 31 | - -Wnoncanonical-monad-instances 32 | - -Wunused-packages 33 | 34 | library: 35 | source-dirs: src 36 | other-modules: 37 | - Data.Aeson.Schema.TH.Enum 38 | - Data.Aeson.Schema.TH.Get 39 | - Data.Aeson.Schema.TH.Getter 40 | - Data.Aeson.Schema.TH.Parse 41 | - Data.Aeson.Schema.TH.Schema 42 | - Data.Aeson.Schema.TH.Unwrap 43 | - Data.Aeson.Schema.TH.Utils 44 | dependencies: 45 | - aeson < 3 46 | - base >= 4.17 && < 5 47 | - first-class-families < 0.9 48 | - hashable < 1.6 49 | - megaparsec < 10 50 | - template-haskell < 2.24 51 | - text < 2.2 52 | - unordered-containers < 0.3 53 | 54 | tests: 55 | aeson-schemas-test: 56 | source-dirs: test 57 | main: Main.hs 58 | dependencies: 59 | - aeson 60 | - aeson-qq >= 0.8.4 61 | - aeson-schemas 62 | - base 63 | - deepseq 64 | - filepath 65 | - interpolate 66 | - process 67 | - QuickCheck 68 | - raw-strings-qq 69 | - tasty 70 | - tasty-golden 71 | - tasty-hunit 72 | - tasty-quickcheck >= 0.8.1 73 | - template-haskell 74 | - temporary 75 | - text 76 | - th-orphans 77 | - th-test-utils 78 | 79 | benchmarks: 80 | aeson-schemas-bench: 81 | source-dirs: bench 82 | main: Main.hs 83 | dependencies: 84 | - aeson 85 | - aeson-schemas 86 | - base 87 | - criterion 88 | - deepseq 89 | - template-haskell 90 | - th-test-utils 91 | -------------------------------------------------------------------------------- /bench/Benchmarks/SchemaQQ.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Benchmarks.SchemaQQ where 4 | 5 | import Criterion.Main 6 | import Language.Haskell.TH.Quote (QuasiQuoter (quoteType)) 7 | import Language.Haskell.TH.TestUtils ( 8 | QMode (..), 9 | QState (..), 10 | loadNames, 11 | runTestQ, 12 | ) 13 | 14 | import qualified Data.Aeson.Schema 15 | 16 | import Benchmarks.Data.Schemas 17 | import Utils.DeepSeq () 18 | 19 | benchmarks :: Benchmark 20 | benchmarks = 21 | bgroup 22 | "schema quasiquoter" 23 | [ byKeys 24 | , byNestedKeys 25 | , byNumOfIncluded 26 | , byKeysInIncluded 27 | , byNumOfExtended 28 | , byKeysInExtended 29 | ] 30 | where 31 | byKeys = bgroup "# of keys" $ 32 | flip map [1, 5, 10, 100] $ \n -> 33 | let schemaDef = genSchemaDef $ keysTo n 34 | in bench (show n) $ nf runSchema schemaDef 35 | 36 | byNestedKeys = bgroup "# of nested keys" $ 37 | flip map [1, 5, 10, 100] $ \n -> 38 | let schemaDef = iterateN n (\prev -> genSchemaDef [Field "a" prev]) "Int" 39 | in bench (show n) $ nf runSchema schemaDef 40 | 41 | byNumOfIncluded = bgroup "Include given # of schemas" $ 42 | flip map [1, 5, 10, 100] $ \n -> 43 | let schemaDef = genSchemaDef $ map (\name -> Include name name) $ take n singleSchemas 44 | in bench (show n) $ nf runSchema schemaDef 45 | 46 | byKeysInIncluded = bgroup "Include schema with given # of keys" $ 47 | flip map sizedSchemas $ \(n, schema) -> 48 | let schemaDef = genSchemaDef [Include "a" schema] 49 | in bench (show n) $ nf runSchema schemaDef 50 | 51 | byNumOfExtended = bgroup "Extend given # of schemas" $ 52 | flip map [1, 5, 10, 100] $ \n -> 53 | let schemaDef = genSchemaDef $ map Ref $ take n singleSchemas 54 | in bench (show n) $ nf runSchema schemaDef 55 | 56 | byKeysInExtended = bgroup "Extend schema with given # of keys" $ 57 | flip map sizedSchemas $ \(n, schema) -> 58 | let schemaDef = genSchemaDef [Field "a" "Int", Ref schema] 59 | in bench (show n) $ nf runSchema schemaDef 60 | 61 | runSchema = 62 | let qstate = 63 | QState 64 | { mode = MockQ 65 | , knownNames = sizedSchemasNames ++ singleSchemasNames 66 | , reifyInfo = $(loadNames $ map snd $ sizedSchemasNames ++ singleSchemasNames) 67 | } 68 | in runTestQ qstate . quoteType Data.Aeson.Schema.schema 69 | 70 | {- Utilities -} 71 | 72 | -- | Apply the given functions the given number of times. 73 | -- 74 | -- The first parameter must be >= 0. 75 | iterateN :: Int -> (a -> a) -> a -> a 76 | iterateN n f x = iterate f x !! n 77 | -------------------------------------------------------------------------------- /DEVELOPER.md: -------------------------------------------------------------------------------- 1 | # Quickstart 2 | 3 | ## Build 4 | 5 | Builds must pass with Haddock enabled and no warnings in order for your PR to be accepted. 6 | 7 | ```bash 8 | stack build 9 | 10 | # with haddock 11 | stack build --haddock 12 | 13 | # with cabal 14 | cabal build --ghc-options -Werror 15 | ``` 16 | 17 | ## Lint 18 | 19 | The following linters must pass CI in order for your PR to be accepted. 20 | 21 | * fourmolu 22 | 23 | ```bash 24 | cabal install fourmolu-0.12.0.0 25 | fourmolu -i . 26 | ``` 27 | 28 | ## Run tests 29 | 30 | All tests must pass CI in order for your PR to be accepted. 31 | 32 | ```bash 33 | stack test 34 | 35 | # Note: use the global GHC; integration tests will not work with 36 | # --with-compiler set differently 37 | cabal exec -- cabal test 38 | ``` 39 | 40 | # Documentation 41 | 42 | All code should be fully documented, whether it's adding comments for future 43 | developers or adding Haddock docs for functionality exposed in Haddock. 44 | 45 | Changes that affect users should be mentioned in `CHANGELOG.md`. When doing so, 46 | add an entry under under the `Unreleased` header containing: 47 | * A description of the change 48 | * The type of change (breaking, bugfix, etc.) 49 | * If applicable, 50 | * How to migrate existing code 51 | * When it should be used 52 | * What it supersedes 53 | 54 | The format is not important, as the list will be curated when releasing. 55 | 56 | # Release 57 | 58 | Follow these steps to release this project: 59 | 60 | 1. Create a new branch 61 | 1. Bump version in `package.yaml` 62 | * All version bumps should follow [PvP](https://pvp.haskell.org/) 63 | 1. Curate `CHANGELOG.md`, creating a new section for this version and 64 | moving everything previously in `Unreleased` into the new section 65 | (keeping `Unreleased` as a section) 66 | 1. Add comments to new features indicating when it was added (e.g. 67 | `-- @since v2.0.0`) 68 | 1. Run `stack haddock` and skim through documentation 69 | 70 | 1. Create PR as usual and merge into `main` 71 | 1. In the `check_sdist` CI job, check the output of the `stack sdist` 72 | step for any warnings. 73 | 74 | 1. Ensure your Hackage token is set in Settings > Secrets > Actions as `HACKAGE_TOKEN_` (replace any non alphanumeric characters in username with `_`). 75 | * Generate a token from `https://hackage.haskell.org/user//manage` 76 | 77 | 1. Go to the GitHub Actions page, click on the "Release" workflow, and click "Run workflow" on the main branch 78 | 79 | 1. Publish the candidate: https://hackage.haskell.org/package/aeson-schemas/candidates 80 | 81 | 1. Publish the GitHub release: https://github.com/brandonchinn178/aeson-schemas/releases 82 | -------------------------------------------------------------------------------- /test/Tests/SchemaQQ/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | {-# LANGUAGE StandaloneDeriving #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | {-# OPTIONS_GHC -Wno-orphans #-} 8 | 9 | module Tests.SchemaQQ.TH where 10 | 11 | import Control.DeepSeq (deepseq) 12 | import Data.Aeson (FromJSON, ToJSON) 13 | import Foreign.C (CBool (..)) 14 | import Language.Haskell.TH.Quote (QuasiQuoter (..)) 15 | import Language.Haskell.TH.TestUtils ( 16 | MockedMode (..), 17 | QMode (..), 18 | QState (..), 19 | loadNames, 20 | runTestQ, 21 | runTestQErr, 22 | ) 23 | 24 | import Data.Aeson.Schema (schema, showSchema) 25 | import TestUtils (mkExpQQ) 26 | import TestUtils.DeepSeq () 27 | 28 | type UserSchema = [schema| { name: Text } |] 29 | type ExtraSchema = [schema| { extra: Text } |] 30 | type ExtraSchema2 = [schema| { extra: Maybe Text } |] 31 | 32 | newtype Status = Status Int 33 | deriving (Show, FromJSON, ToJSON) 34 | 35 | -- | The type referenced here should not be imported in SchemaQQ.hs nor included in 'knownNames'. 36 | type SchemaWithHiddenImport = [schema| { a: CBool } |] 37 | 38 | deriving instance ToJSON CBool 39 | deriving instance FromJSON CBool 40 | 41 | -- Compile above types before reifying 42 | $(return []) 43 | 44 | type WithUser = [schema| { user: #UserSchema } |] 45 | 46 | -- Compile above types before reifying 47 | $(return []) 48 | 49 | qState :: QState 'FullyMocked 50 | qState = 51 | QState 52 | { mode = MockQ 53 | , knownNames = 54 | [ ("Status", ''Status) 55 | , ("UserSchema", ''UserSchema) 56 | , ("ExtraSchema", ''ExtraSchema) 57 | , ("ExtraSchema2", ''ExtraSchema2) 58 | , ("Tests.SchemaQQ.TH.UserSchema", ''UserSchema) 59 | , ("Tests.SchemaQQ.TH.ExtraSchema", ''ExtraSchema) 60 | , ("SchemaWithHiddenImport", ''SchemaWithHiddenImport) 61 | , ("WithUser", ''WithUser) 62 | , ("Int", ''Int) 63 | ] 64 | , reifyInfo = 65 | $( loadNames 66 | [ ''UserSchema 67 | , ''ExtraSchema 68 | , ''ExtraSchema2 69 | , ''SchemaWithHiddenImport 70 | , ''WithUser 71 | , ''Int 72 | ] 73 | ) 74 | } 75 | 76 | -- | A quasiquoter for generating the string representation of a schema. 77 | -- 78 | -- Also runs the `schema` quasiquoter at runtime, to get coverage information. 79 | schemaRep :: QuasiQuoter 80 | schemaRep = mkExpQQ $ \s -> 81 | let schemaType = quoteType schema s 82 | in [|runTestQ qState (quoteType schema s) `deepseq` showSchema @($schemaType)|] 83 | 84 | schemaErr :: QuasiQuoter 85 | schemaErr = mkExpQQ $ \s -> [|runTestQErr qState (quoteType schema s)|] 86 | -------------------------------------------------------------------------------- /test/Tests/UnwrapQQ/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | 5 | module Tests.UnwrapQQ.TH where 6 | 7 | import Control.DeepSeq (deepseq) 8 | import Language.Haskell.TH (appTypeE) 9 | import Language.Haskell.TH.Quote (QuasiQuoter (..)) 10 | import Language.Haskell.TH.TestUtils ( 11 | MockedMode (..), 12 | QMode (..), 13 | QState (..), 14 | loadNames, 15 | runTestQ, 16 | runTestQErr, 17 | ) 18 | 19 | import Data.Aeson.Schema (schema, unwrap) 20 | import TestUtils (ShowSchemaResult (..), mkExpQQ) 21 | import TestUtils.DeepSeq () 22 | 23 | type ListSchema = [schema| { ids: List Int } |] 24 | type MaybeSchema = [schema| { class: Maybe Text } |] 25 | type SumSchema = [schema| { verbosity: Int | Bool } |] 26 | type ABCSchema = 27 | [schema| 28 | { 29 | a: Bool, 30 | b: Bool, 31 | c: Double, 32 | } 33 | |] 34 | 35 | type NestedSchema = 36 | [schema| 37 | { 38 | a: { 39 | b: { 40 | c: Bool, 41 | }, 42 | }, 43 | } 44 | |] 45 | 46 | type MySchema = 47 | [schema| 48 | { 49 | users: List { 50 | name: Text, 51 | }, 52 | } 53 | |] 54 | 55 | -- Compile above schemas before these schemas 56 | $(return []) 57 | 58 | type ListSchema2 = [schema| { list: #ListSchema } |] 59 | type User = [unwrap| MySchema.users[] |] 60 | type UnwrappedNestedSchema = [unwrap| NestedSchema.a |] 61 | 62 | type NotASchema = Int 63 | 64 | -- Compile above types before reifying 65 | $(return []) 66 | 67 | qState :: QState 'FullyMocked 68 | qState = 69 | QState 70 | { mode = MockQ 71 | , knownNames = 72 | [ ("ListSchema", ''ListSchema) 73 | , ("ListSchema2", ''ListSchema2) 74 | , ("MaybeSchema", ''MaybeSchema) 75 | , ("SumSchema", ''SumSchema) 76 | , ("ABCSchema", ''ABCSchema) 77 | , ("NotASchema", ''NotASchema) 78 | , ("UnwrappedNestedSchema", ''UnwrappedNestedSchema) 79 | ] 80 | , reifyInfo = 81 | $( loadNames 82 | [ ''ListSchema 83 | , ''ListSchema2 84 | , ''MaybeSchema 85 | , ''SumSchema 86 | , ''ABCSchema 87 | , ''NotASchema 88 | , ''MySchema 89 | , ''UnwrappedNestedSchema 90 | ] 91 | ) 92 | } 93 | 94 | -- | A quasiquoter for generating the string representation of an unwrapped schema. 95 | -- 96 | -- Also runs the `unwrap` quasiquoter at runtime, to get coverage information. 97 | unwrapRep :: QuasiQuoter 98 | unwrapRep = mkExpQQ $ \s -> 99 | let showSchemaResultQ = appTypeE [|showSchemaResult|] (quoteType unwrap s) 100 | in [|runTestQ qState (quoteType unwrap s) `deepseq` $showSchemaResultQ|] 101 | 102 | unwrapErr :: QuasiQuoter 103 | unwrapErr = mkExpQQ $ \s -> [|runTestQErr qState (quoteType unwrap s)|] 104 | -------------------------------------------------------------------------------- /test/Tests/EnumTH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module Tests.EnumTH where 5 | 6 | import Data.Aeson (decode, encode) 7 | import Data.Char (toLower, toUpper) 8 | import Test.Tasty 9 | import Test.Tasty.HUnit 10 | import Test.Tasty.QuickCheck 11 | 12 | import Data.Aeson.Schema.TH (genFromJSONEnum, genToJSONEnum, mkEnum) 13 | 14 | mkEnum "State" ["OPEN", "CLOSED"] 15 | 16 | data Color = Red | LightBlue | Yellow | DarkGreen | Black | JustABitOffWhite 17 | deriving (Show, Eq, Enum) 18 | 19 | genFromJSONEnum ''Color 20 | genToJSONEnum ''Color 21 | 22 | {- Tests -} 23 | 24 | test :: TestTree 25 | test = 26 | testGroup 27 | "Enum TH helpers" 28 | [ testMkEnum 29 | , testGenJSONEnum 30 | ] 31 | 32 | testMkEnum :: TestTree 33 | testMkEnum = 34 | testGroup 35 | "mkEnum" 36 | [ testProperty "mkEnum decode is case insensitive" $ do 37 | (val, enumVal) <- 38 | elements 39 | [ ("OPEN", OPEN) 40 | , ("CLOSED", CLOSED) 41 | ] 42 | casedVal <- randomlyCased val 43 | return $ decode (encode casedVal) === Just enumVal 44 | , testCase "mkEnum encode keeps case of constructor" $ do 45 | encode OPEN @?= "\"OPEN\"" 46 | encode CLOSED @?= "\"CLOSED\"" 47 | , testProperty "mkEnum: (fromJust . decode . encode) === id" $ do 48 | enumVal <- elements [OPEN, CLOSED] 49 | return $ (decode . encode) enumVal === Just enumVal 50 | ] 51 | 52 | testGenJSONEnum :: TestTree 53 | testGenJSONEnum = 54 | testGroup 55 | "gen{To,From}JSONEnum" 56 | [ testProperty "genFromJSONEnum decode is case insensitive" $ do 57 | (val, enumVal) <- 58 | elements 59 | [ ("Red", Red) 60 | , ("LightBlue", LightBlue) 61 | , ("Yellow", Yellow) 62 | , ("DarkGreen", DarkGreen) 63 | , ("Black", Black) 64 | , ("JustABitOffWhite", JustABitOffWhite) 65 | ] 66 | casedVal <- randomlyCased val 67 | return $ decode (encode casedVal) === Just enumVal 68 | , testCase "genToJSONEnum encode keeps case of constructor" $ do 69 | encode Red @?= "\"Red\"" 70 | encode LightBlue @?= "\"LightBlue\"" 71 | encode Yellow @?= "\"Yellow\"" 72 | encode DarkGreen @?= "\"DarkGreen\"" 73 | encode Black @?= "\"Black\"" 74 | encode JustABitOffWhite @?= "\"JustABitOffWhite\"" 75 | , testProperty "genFromJSONEnum + genToJSONEnum: (fromJust . decode . encode) === id" $ do 76 | enumVal <- 77 | elements 78 | [ Red 79 | , LightBlue 80 | , Yellow 81 | , DarkGreen 82 | , Black 83 | , JustABitOffWhite 84 | ] 85 | return $ (decode . encode) enumVal === Just enumVal 86 | ] 87 | 88 | randomlyCased :: String -> Gen String 89 | randomlyCased s = do 90 | caseFuncs <- infiniteListOf $ elements [toLower, toUpper] 91 | return $ zipWith ($) caseFuncs s 92 | -------------------------------------------------------------------------------- /test/Tests/Object/Show.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | 6 | module Tests.Object.Show where 7 | 8 | import Data.Aeson.QQ (aesonQQ) 9 | import Data.String.Interpolate (i) 10 | import Test.Tasty 11 | import Test.Tasty.HUnit 12 | import Test.Tasty.QuickCheck 13 | 14 | import TestUtils (parseObject) 15 | import Tests.Object.Show.TH 16 | 17 | test :: TestTree 18 | test = 19 | testGroup 20 | "Show instance" 21 | [ testProperty "Scalar key" $ \(s :: String) -> 22 | let o = $(parseObject "{ foo: Text }") [aesonQQ| { "foo": #{s} } |] 23 | in show o === [i|{ "foo": #{show s} }|] 24 | , testProperty "Object with multiple keys" $ \(b :: Double, x :: Int) -> 25 | let o = $(parseObject "{ foo: Double, bar: Int }") [aesonQQ| { "foo": #{b}, "bar": #{x} } |] 26 | in show o === [i|{ "foo": #{show b}, "bar": #{show x} }|] 27 | , testProperty "Nested object" $ \(x :: Int) -> 28 | let o = $(parseObject "{ foo: { bar: Int } }") [aesonQQ| { "foo": { "bar": #{x} } } |] 29 | in show o === [i|{ "foo": { "bar": #{show x} } }|] 30 | , testProperty "Object with existing Maybe key" $ \(x :: Bool) -> 31 | let o = $(parseObject "{ foo: Maybe Bool }") [aesonQQ| { "foo": #{x} } |] 32 | in show o === [i|{ "foo": Just #{show x} }|] 33 | , testCase "Object with non-existing Maybe key" $ 34 | let o = $(parseObject "{ foo: Maybe Double }") [aesonQQ| { "foo": null } |] 35 | in show o @?= [i|{ "foo": Nothing }|] 36 | , testProperty "Object with valid Try key" $ \(b :: Bool) -> 37 | let o = $(parseObject "{ foo: Try Bool }") [aesonQQ| { "foo": #{b} } |] 38 | in show o === [i|{ "foo": Just #{show b} }|] 39 | , testProperty "Object with invalid Try key" $ \(x :: Int) -> 40 | let o = $(parseObject "{ foo: Try Bool }") [aesonQQ| { "foo": #{x} } |] 41 | in show o === [i|{ "foo": Nothing }|] 42 | , testProperty "Object with List key" $ \(x :: [Int]) -> 43 | let o = $(parseObject "{ foo: List Int }") [aesonQQ| { "foo": #{x} } |] 44 | in show o === [i|{ "foo": #{show x} }|] 45 | , testProperty "Object with Union key branch 0" $ \(Positive (x :: Int)) -> 46 | let o = $(parseObject "{ foo: Int | Text }") [aesonQQ| { "foo": #{x} } |] 47 | in show o === [i|{ "foo": Here #{show x} }|] 48 | , testProperty "Object with Union key branch 1" $ \(s :: String) -> 49 | let o = $(parseObject "{ foo: Int | Text }") [aesonQQ| { "foo": #{s} } |] 50 | in show o === [i|{ "foo": There (Here #{show s}) }|] 51 | , testProperty "Object with referenced Object" $ \(name :: String) -> 52 | let o = $(parseObject "{ user: #UserSchema }") [aesonQQ| { "user": { "name": #{name} } } |] 53 | in show o === [i|{ "user": { "name": #{show name} } }|] 54 | , testProperty "Object with extended Object" $ \(name :: String, age :: Int) -> 55 | let o = $(parseObject "{ #UserSchema, age: Int }") [aesonQQ| { "name": #{name}, "age": #{age} } |] 56 | in show o === [i|{ "name": #{show name}, "age": #{show age} }|] 57 | , testProperty "Object with Phantom key" $ \(x :: Int) -> 58 | let o = $(parseObject "{ [foo]: { bar: Int } }") [aesonQQ| { "bar": #{x} } |] 59 | in show o === [i|{ [foo]: { "bar": #{show x} } }|] 60 | ] 61 | -------------------------------------------------------------------------------- /test/Tests/SumType.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE TupleSections #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | 6 | module Tests.SumType where 7 | 8 | import Data.Aeson (ToJSON, eitherDecode, encode) 9 | import Data.Proxy (Proxy (..)) 10 | import Data.String (fromString) 11 | import Test.Tasty 12 | import Test.Tasty.Golden 13 | import Test.Tasty.HUnit 14 | import Test.Tasty.QuickCheck 15 | 16 | import Data.Aeson.Schema.Utils.Sum (SumType (..), fromSumType) 17 | 18 | type SpecialJSON = SumType '[Bool, Int, [String]] 19 | 20 | toSpecialJSON :: (ToJSON a) => a -> SpecialJSON 21 | toSpecialJSON = either (error . ("Invalid SpecialJSON: " ++) . show) id . toSpecialJSON' 22 | 23 | toSpecialJSON' :: (ToJSON a) => a -> Either String SpecialJSON 24 | toSpecialJSON' = eitherDecode . encode 25 | 26 | {- Tests -} 27 | 28 | test :: TestTree 29 | test = 30 | testGroup 31 | "SumType" 32 | [ testCase "Sanity checks" $ 33 | -- this should compile 34 | let values = 35 | [ Here True 36 | , Here False 37 | , There (Here 1) 38 | , There (Here 10) 39 | , There (There (Here [])) 40 | , There (There (Here ["a"])) 41 | ] :: 42 | [SpecialJSON] 43 | in values @?= values 44 | , testDecode 45 | , testFromSumType 46 | ] 47 | 48 | testDecode :: TestTree 49 | testDecode = 50 | testGroup 51 | "Decode SumType" 52 | [ testProperty "branch 1" $ \(b :: Bool) -> 53 | toSpecialJSON' b === Right (Here b) 54 | , testProperty "branch 2" $ \(x :: Int) -> 55 | toSpecialJSON' x === Right (There (Here x)) 56 | , testProperty "branch 3" $ \(l :: [String]) -> 57 | toSpecialJSON' l === Right (There (There (Here l))) 58 | , goldenVsString "invalid SumType" "test/goldens/sumtype_decode_invalid.golden" $ 59 | case toSpecialJSON' [True] of 60 | Right v -> error $ "Unexpectedly decoded value: " ++ show v 61 | Left e -> pure $ fromString e 62 | ] 63 | 64 | testFromSumType :: TestTree 65 | testFromSumType = 66 | testGroup 67 | "fromSumType" 68 | [ testProperty "branch 0 valid" $ \b -> 69 | fromSumType (Proxy @0) (toSpecialJSON b) === Just b 70 | , testProperty "branch 0 invalid" $ 71 | forAll (specialJSONExcept 0) $ \(branch, value) -> 72 | labelBranch branch $ fromSumType (Proxy @0) value === Nothing 73 | , testProperty "branch 1 valid" $ \x -> 74 | fromSumType (Proxy @1) (toSpecialJSON x) === Just x 75 | , testProperty "branch 1 invalid" $ 76 | forAll (specialJSONExcept 1) $ \(branch, value) -> 77 | labelBranch branch $ fromSumType (Proxy @1) value === Nothing 78 | , testProperty "branch 2 valid" $ \l -> 79 | fromSumType (Proxy @2) (toSpecialJSON l) === Just l 80 | , testProperty "branch 2 invalid" $ 81 | forAll (specialJSONExcept 2) $ \(branch, value) -> 82 | labelBranch branch $ fromSumType (Proxy @2) value === Nothing 83 | ] 84 | where 85 | specialJSONExcept :: Int -> Gen (Int, SpecialJSON) 86 | specialJSONExcept validBranch = 87 | let fmapFst (a, gen) = (a,) <$> gen 88 | in oneof $ 89 | map fmapFst $ 90 | filter 91 | ((/= validBranch) . fst) 92 | [ (0, toSpecialJSON <$> arbitrary @Bool) 93 | , (1, toSpecialJSON <$> arbitrary @Int) 94 | , (2, toSpecialJSON <$> arbitrary @[String]) 95 | ] 96 | 97 | labelBranch branch = label $ "branch " ++ show branch 98 | -------------------------------------------------------------------------------- /bench/Benchmarks/Data/Schemas.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module Benchmarks.Data.Schemas ( 5 | module Benchmarks.Data.Schemas, 6 | module Benchmarks.Data.Schemas.TH, 7 | ) where 8 | 9 | import Control.Monad (forM) 10 | import Data.Char (chr, toUpper) 11 | import Language.Haskell.TH 12 | import Language.Haskell.TH.Syntax (lift) 13 | import Language.Haskell.TH.TestUtils () 14 | 15 | import Benchmarks.Data.Schemas.TH 16 | 17 | -- Generates: 18 | -- 19 | -- type Schema1 = { a1: Int } 20 | -- type Schema5 = { a1: Int, a2: Int, ... a5: Int } 21 | -- type Schema10 = { a1: Int, a2: Int, ... a10: Int } 22 | -- type Schema100 = { a1: Int, a2: Int, ... a100: Int } 23 | $( do 24 | -- The sizes of schemas to generate 25 | let schemaSizes = [1, 5, 10, 100] 26 | allSchemas = flip map schemaSizes $ \n -> 27 | let name = "Schema" ++ show n 28 | in (n, name, mkName name) 29 | 30 | concat 31 | <$> sequence 32 | [ forM allSchemas $ \(n, _, name) -> genSchema name $ keysTo n 33 | , [d| 34 | sizedSchemas :: [(Int, String)] 35 | sizedSchemas = $(lift $ flip map allSchemas $ \(n, name, _) -> (n, name)) 36 | 37 | sizedSchemasNames :: [(String, Name)] 38 | sizedSchemasNames = $(lift $ flip map allSchemas $ \(_, name, thName) -> (name, thName)) 39 | |] 40 | ] 41 | ) 42 | 43 | -- Generates: 44 | -- 45 | -- type SchemaNest1 = { a1: Int } 46 | -- type SchemaNest5 = { a1: { a2: { ... a5: Int } } 47 | -- type SchemaNest10 = { a1: { a2: { ... a10: Int } } 48 | -- type SchemaNest100 = { a1: { a2: { ... a100: Int } } 49 | $( do 50 | -- The depths of schemas to generate 51 | let schemaSizes = [1, 5, 10, 100] 52 | allSchemas = flip map schemaSizes $ \n -> 53 | let name = "SchemaNest" ++ show n 54 | in (n, name, mkName name) 55 | 56 | concat 57 | <$> sequence 58 | [ forM allSchemas $ \(n, _, name) -> 59 | genSchema' name $ 60 | foldr (\i inner -> genSchemaDef [Field (mkField i) inner]) "Int" [1 .. n] 61 | , [d| 62 | nestedSchemas :: [(Int, String)] 63 | nestedSchemas = $(lift $ flip map allSchemas $ \(n, name, _) -> (n, name)) 64 | 65 | nestedSchemasNames :: [(String, Name)] 66 | nestedSchemasNames = $(lift $ flip map allSchemas $ \(_, name, thName) -> (name, thName)) 67 | |] 68 | ] 69 | ) 70 | 71 | -- Generates: 72 | -- 73 | -- type SchemaA1 = { a1: Int } 74 | -- type SchemaB1 = { b1: Int } 75 | -- ... 76 | -- type SchemaZ1 = { z1: Int } 77 | -- type SchemaA2 = { a2: Int } 78 | -- type SchemaB2 = { a2: Int } 79 | -- ... 80 | $( do 81 | let numSchemas = 100 82 | allSchemas = flip map [1 .. numSchemas] $ \n -> 83 | let (q, r) = n `divMod` 26 84 | c = chr $ 97 + r -- a .. z 85 | field = c : show q 86 | name = "Schema" ++ map toUpper field 87 | in (field, name, mkName name) 88 | 89 | concat 90 | <$> sequence 91 | [ forM allSchemas $ \(field, _, name) -> genSchema name [Field field "Int"] 92 | , [d| 93 | singleSchemas :: [String] 94 | singleSchemas = $(lift $ flip map allSchemas $ \(_, name, _) -> name) 95 | 96 | singleSchemasNames :: [(String, Name)] 97 | singleSchemasNames = $(lift $ flip map allSchemas $ \(_, name, thName) -> (name, thName)) 98 | |] 99 | ] 100 | ) 101 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | on: 3 | pull_request: 4 | push: 5 | branches: 6 | - main 7 | workflow_call: 8 | 9 | jobs: 10 | build_and_test: 11 | runs-on: ubuntu-latest 12 | 13 | steps: 14 | - 15 | uses: actions/checkout@v3 16 | - 17 | uses: actions/cache@v3 18 | with: 19 | path: ~/.stack 20 | key: ${{ runner.os }}-stack-cache-${{ hashFiles('stack.yaml', 'package.yaml') }} 21 | - 22 | name: Build + Test 23 | run: stack test --ghc-options=-Werror --haddock --no-haddock-deps --coverage 24 | - 25 | name: Check that files are unmodified 26 | run: git add -A && git diff --staged --exit-code 27 | - 28 | name: Convert coverage output 29 | run: | 30 | HPC_LCOV_VERSION=1.2.0 31 | curl -fsSL \ 32 | "https://github.com/brandonchinn178/hpc-lcov/releases/download/v${HPC_LCOV_VERSION}/hpc-lcov-${HPC_LCOV_VERSION}-linux-x86_64" \ 33 | -o /usr/local/bin/hpc-lcov 34 | chmod +x /usr/local/bin/hpc-lcov 35 | hpc-lcov 36 | - 37 | uses: codecov/codecov-action@v3 38 | with: 39 | files: lcov.info 40 | 41 | ghc_compat_test: 42 | strategy: 43 | matrix: 44 | ghc_version: 45 | - '9.8' 46 | - '9.10' 47 | - '9.12' 48 | include: 49 | - ghc_version: 9.8.1 50 | oldest: true 51 | 52 | name: ghc_compat_test (${{ matrix.ghc_version }}) 53 | uses: ./.github/workflows/ghc-compat-test.yml 54 | with: 55 | ghc_version: ${{ matrix.ghc_version }} 56 | oldest: ${{ matrix.oldest || false }} 57 | 58 | lint: 59 | runs-on: ubuntu-latest 60 | env: 61 | FOURMOLU_VERSION: '0.12.0.0' 62 | steps: 63 | - 64 | uses: actions/checkout@v3 65 | - 66 | name: Install fourmolu 67 | run: | 68 | curl -fsSL \ 69 | "https://github.com/fourmolu/fourmolu/releases/download/v${FOURMOLU_VERSION}/fourmolu-${FOURMOLU_VERSION}-linux-x86_64" \ 70 | -o /usr/local/bin/fourmolu 71 | chmod +x /usr/local/bin/fourmolu 72 | - 73 | name: Run fourmolu 74 | run: fourmolu -m check . 75 | 76 | benchmarks: 77 | runs-on: ubuntu-latest 78 | steps: 79 | - 80 | uses: actions/checkout@v3 81 | - 82 | uses: actions/cache@v3 83 | with: 84 | path: ~/.stack 85 | key: ${{ runner.os }}-benchmarks-${{ hashFiles('stack.yaml', 'package.yaml') }} 86 | - 87 | name: Run benchmarks 88 | run: stack bench --ghc-options=-Werror --ba '--output=/tmp/benchmark-results.html' 89 | - 90 | uses: actions/upload-artifact@v3 91 | with: 92 | name: benchmark-results 93 | path: /tmp/benchmark-results.html 94 | 95 | check_sdist: 96 | runs-on: ubuntu-latest 97 | steps: 98 | - 99 | uses: actions/checkout@v3 100 | - 101 | uses: actions/cache@v3 102 | with: 103 | path: ~/.stack 104 | key: ${{ runner.os }}-check_sdist-${{ hashFiles('stack.yaml', 'package.yaml') }} 105 | 106 | - 107 | name: Strip unreleased section from CHANGELOG 108 | run: sed -i -n '/^# Unreleased/d; /^#/,$p' CHANGELOG.md 109 | - 110 | name: Create sdist bundle 111 | run: stack sdist --test-tarball --tar-dir . 112 | - 113 | uses: actions/upload-artifact@v3 114 | with: 115 | name: aeson-schemas-sdist 116 | path: aeson-schemas-*.tar.gz 117 | -------------------------------------------------------------------------------- /src/Data/Aeson/Schema/TH/Getter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | {-| 5 | Module : Data.Aeson.Schema.TH.Getter 6 | Maintainer : Brandon Chinn 7 | Stability : experimental 8 | Portability : portable 9 | 10 | Template Haskell functions for getter functions. 11 | -} 12 | module Data.Aeson.Schema.TH.Getter where 13 | 14 | import Control.Monad (unless) 15 | import Data.Aeson.Schema.Internal (Object) 16 | import Data.Maybe (isNothing) 17 | import Language.Haskell.TH 18 | 19 | import Data.Aeson.Schema.TH.Get (generateGetterExp) 20 | import Data.Aeson.Schema.TH.Parse (GetterExp (..), parseGetterExp) 21 | import Data.Aeson.Schema.TH.Unwrap ( 22 | FunctorHandler (..), 23 | unwrapSchema, 24 | unwrapSchemaUsing, 25 | ) 26 | import Data.Aeson.Schema.TH.Utils (loadSchema, lookupSchema, schemaVToTypeQ) 27 | import Data.Aeson.Schema.Utils.NameLike (NameLike (..)) 28 | 29 | -- | A helper that generates a 'Data.Aeson.Schema.TH.get' expression and a type alias for the result 30 | -- of the expression. 31 | -- 32 | -- > mkGetter "Node" "getNodes" ''MySchema ".nodes[]" 33 | -- > 34 | -- > {\- is equivalent to -\} 35 | -- > 36 | -- > -- | Node ~ { b: Maybe Bool } 37 | -- > type Node = [unwrap| MySchema.nodes[] |] 38 | -- > 39 | -- > getNodes :: Object MySchema -> [Node] 40 | -- > getNodes = [get| .nodes[] |] 41 | -- 42 | -- 'mkGetter' takes four arguments: 43 | -- 44 | -- [@unwrapName@] The name of the type synonym to store the unwrapped schema as 45 | -- 46 | -- [@funcName@] The name of the getter function 47 | -- 48 | -- [@startSchema@] The schema to extract/unwrap from 49 | -- 50 | -- [@ops@] The operation to pass to the 'Data.Aeson.Schema.TH.get' and 51 | -- 'Data.Aeson.Schema.TH.unwrap' quasiquoters 52 | -- 53 | -- There is one subtlety that occurs from the use of the same @ops@ string for both the 54 | -- 'Data.Aeson.Schema.TH.unwrap' and 'Data.Aeson.Schema.TH.get' quasiquoters: 55 | -- 'Data.Aeson.Schema.TH.unwrap' strips out intermediate functors, while 'Data.Aeson.Schema.TH.get' 56 | -- applies within the functor. So in the above example, @".nodes[]"@ strips out the list when 57 | -- saving the schema to @Node@, while in the below example, @".nodes"@ doesn't strip out the list 58 | -- when saving the schema to @Nodes@. 59 | -- 60 | -- > mkGetter "Nodes" "getNodes" ''MySchema ".nodes" 61 | -- > 62 | -- > {\- is equivalent to -\} 63 | -- > 64 | -- > -- | Nodes ~ List { b: Maybe Bool } 65 | -- > type Nodes = [unwrap| MySchema.nodes |] 66 | -- > 67 | -- > getNodes :: Object MySchema -> Nodes 68 | -- > getNodes = [get| .nodes |] 69 | -- 70 | -- As another example, 71 | -- 72 | -- > mkGetter "MyName" "getMyName" ''MySchema ".f?[].name" 73 | -- > 74 | -- > {\- is equivalent to -\} 75 | -- > 76 | -- > -- | MyName ~ Text 77 | -- > type MyName = [unwrap| MySchema.f?[].name |] 78 | -- > 79 | -- > getMyBool :: Object MySchema -> Maybe [MyName] 80 | -- > getMyBool = [get| .f?[].name |] 81 | mkGetter :: String -> String -> Name -> String -> DecsQ 82 | mkGetter unwrapName funcName startSchemaName ops = do 83 | getterExp@GetterExp{..} <- parseGetterExp ops 84 | unless (isNothing start) $ 85 | fail $ 86 | "Getter expression should start with '.': " ++ ops 87 | 88 | startSchema <- lookupSchema (NameTH startSchemaName) >>= loadSchema 89 | 90 | let unwrapResult = unwrapSchema getterOps startSchema 91 | funcResult = unwrapSchemaUsing ApplyFunctors getterOps startSchema 92 | getterFunc = generateGetterExp getterExp 93 | unwrapName' = mkName unwrapName 94 | funcName' = mkName funcName 95 | 96 | sequence 97 | [ tySynD unwrapName' [] unwrapResult 98 | , sigD funcName' [t|Object $(schemaVToTypeQ startSchema) -> $funcResult|] 99 | , funD funcName' [clause [] (normalB getterFunc) []] 100 | ] 101 | -------------------------------------------------------------------------------- /src/Data/Aeson/Schema/Key.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DeriveAnyClass #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE DeriveLift #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE LambdaCase #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | 12 | {-| 13 | Module : Data.Aeson.Schema.Key 14 | Maintainer : Brandon Chinn 15 | Stability : experimental 16 | Portability : portable 17 | 18 | Defines a SchemaKey. 19 | -} 20 | module Data.Aeson.Schema.Key ( 21 | SchemaKey' (..), 22 | SchemaKeyV, 23 | fromSchemaKeyV, 24 | showSchemaKeyV, 25 | getContext, 26 | toContext, 27 | SchemaKey, 28 | IsSchemaKey (..), 29 | fromSchemaKey, 30 | showSchemaKey, 31 | ) where 32 | 33 | import qualified Data.Aeson as Aeson 34 | import Data.Hashable (Hashable) 35 | import Data.Maybe (fromMaybe) 36 | import Data.Proxy (Proxy (..)) 37 | import Data.String (fromString) 38 | import GHC.Generics (Generic) 39 | import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) 40 | import Language.Haskell.TH.Syntax (Lift) 41 | 42 | import qualified Data.Aeson.Schema.Utils.Compat as Compat 43 | import Data.Aeson.Schema.Utils.Invariant (unreachable) 44 | 45 | -- | A key in a JSON object schema. 46 | data SchemaKey' s 47 | = NormalKey s 48 | | -- | A key that doesn't actually exist in the object, but whose content should be parsed from 49 | -- the current object. 50 | PhantomKey s 51 | deriving (Show, Eq, Generic, Hashable, Lift) 52 | 53 | -- | A value-level SchemaKey 54 | type SchemaKeyV = SchemaKey' String 55 | 56 | fromSchemaKeyV :: SchemaKeyV -> String 57 | fromSchemaKeyV (NormalKey key) = key 58 | fromSchemaKeyV (PhantomKey key) = key 59 | 60 | showSchemaKeyV :: SchemaKeyV -> String 61 | showSchemaKeyV (NormalKey key) = show key 62 | showSchemaKeyV (PhantomKey key) = "[" ++ key ++ "]" 63 | 64 | -- | Given schema `{ key: innerSchema }` for JSON data `{ key: val1 }`, get the JSON 65 | -- Value that `innerSchema` should parse. 66 | getContext :: SchemaKeyV -> Aeson.Object -> Aeson.Value 67 | getContext = \case 68 | -- `innerSchema` should parse `val1` 69 | NormalKey key -> fromMaybe Aeson.Null . Compat.lookup (fromString key) 70 | -- `innerSchema` should parse the same object that `key` is in 71 | PhantomKey _ -> Aeson.Object 72 | 73 | -- | Given JSON data `val` adhering to `innerSchema`, get the JSON object that should be 74 | -- merged with the outer JSON object. 75 | toContext :: SchemaKeyV -> Aeson.Value -> Aeson.Object 76 | toContext = \case 77 | -- `val` should be inserted with key `key` 78 | NormalKey key -> Compat.singleton (fromString key) 79 | -- If `val` is an object, it should be merged with the outer JSON object 80 | PhantomKey _ -> \case 81 | Aeson.Object o -> o 82 | -- `Try` schema could store `Nothing`, which would return `Null`. In this case, there is no 83 | -- context to merge 84 | Aeson.Null -> mempty 85 | v -> unreachable $ "Invalid value for phantom key: " ++ show v 86 | 87 | -- | A type-level SchemaKey 88 | type SchemaKey = SchemaKey' Symbol 89 | 90 | class (KnownSymbol (FromSchemaKey key)) => IsSchemaKey (key :: SchemaKey) where 91 | type FromSchemaKey key :: Symbol 92 | toSchemaKeyV :: Proxy key -> SchemaKeyV 93 | 94 | instance (KnownSymbol key) => IsSchemaKey ('NormalKey key) where 95 | type FromSchemaKey ('NormalKey key) = key 96 | toSchemaKeyV _ = NormalKey $ symbolVal $ Proxy @key 97 | 98 | instance (KnownSymbol key) => IsSchemaKey ('PhantomKey key) where 99 | type FromSchemaKey ('PhantomKey key) = key 100 | toSchemaKeyV _ = PhantomKey $ symbolVal $ Proxy @key 101 | 102 | fromSchemaKey :: forall key. (IsSchemaKey key) => String 103 | fromSchemaKey = fromSchemaKeyV $ toSchemaKeyV $ Proxy @key 104 | 105 | showSchemaKey :: forall key. (IsSchemaKey key) => String 106 | showSchemaKey = showSchemaKeyV $ toSchemaKeyV $ Proxy @key 107 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Unreleased 2 | 3 | # v1.4.3.0 4 | 5 | * Drop support for GHC 9.4 + 9.6 6 | * Add support for GHC 9.10 + 9.12 7 | 8 | # v1.4.2.1 9 | 10 | * Fix benchmarks for GHC 9.8 11 | 12 | # v1.4.2.0 13 | 14 | * Drop support for GHC 8.10 + 9.0 + 9.2 15 | * Add support for GHC 9.8 16 | 17 | # v1.4.1.0 18 | 19 | * Add support for GHC 9.6 20 | 21 | # v1.4.0.1 22 | 23 | * Add support for GHC 9.4 24 | 25 | # v1.4.0.0 26 | 27 | * Drop support for GHC < 8.10 28 | * Drop support for megaparsec < 7 29 | 30 | # v1.3.5.1 31 | 32 | * Fix benchmarks for `aeson-2` 33 | 34 | # v1.3.5 35 | 36 | * Support `aeson-2.0.0.0` 37 | 38 | # v1.3.4 39 | 40 | * Support `template-haskell-2.17.0.0` for GHC 9 41 | 42 | # v1.3.3 43 | 44 | * Fix test failure in newer Stack snapshots 45 | 46 | # v1.3.2 47 | 48 | Performance: 49 | 50 | * Optimized including other schemas in a schema, which previously caused a huge slowdown, and possibly even out-of-memory errors. 51 | 52 | # v1.3.1 53 | 54 | Bug fixes: 55 | 56 | * Update extra-source-files with files needed for testing 57 | 58 | # v1.3.0 59 | 60 | Breaking changes: 61 | 62 | * 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`. 63 | * 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. 64 | * `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`. 65 | 66 | New features: 67 | 68 | * Add support for unwrapping into included schemas 69 | * Add `toMap` 70 | * Re-export `showSchema` in `Data.Aeson.Schema` 71 | 72 | Bug fixes: 73 | 74 | * Avoid requiring `TypeApplications` when using `get` quasiquoter ([#16](https://github.com/brandonchinn178/aeson-schemas/issues/16)) 75 | * Allow optional quotes around keys, both in getter-expressions and in schema definitions 76 | * Allow `//` at the beginning of phantom keys (were previously parsed as comments) 77 | 78 | Performance: 79 | 80 | * 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. 81 | * Fixed the `Show` instance from being `O(n^2)` to `O(n)`, where `n` is the depth of the object. 82 | * 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: 83 | 84 | ``` 85 | { 86 | user: #UserSchema 87 | } 88 | ``` 89 | 90 | If this causes your build to be noticeably slower, please open an issue. Thanks! 91 | 92 | Miscellaneous changes: 93 | 94 | * The `Show` instance for objects added some whitespace, from `{"foo": 0}` to `{ "foo": 0 }` 95 | 96 | # v1.2.0 97 | 98 | New features: 99 | 100 | * Add support for phantom keys 101 | * Add support for `Try` schemas 102 | 103 | # v1.1.0 104 | 105 | New features: 106 | 107 | * Added support for unions 108 | * Added `ToJSON` instance for enums generated with `mkEnum` 109 | 110 | # v1.0.3 111 | 112 | Support GHC 8.8 113 | 114 | # v1.0.2 115 | 116 | Bundle test data files in release tarball 117 | 118 | # v1.0.1 119 | 120 | Add support with `first-class-families-0.6.0.0` 121 | 122 | # v1.0.0 123 | 124 | Initial release: 125 | 126 | * Defining JSON schemas with the `schema` quasiquoter 127 | * Extract JSON data using the `get` quasiquoter 128 | * Extracting intermediate schemas with the `unwrap` quasiquoter 129 | * Include `mkGetter` helper function for generating corresponding `get` and 130 | `unwrap` expressions. 131 | -------------------------------------------------------------------------------- /.github/workflows/ghc-compat-test.yml: -------------------------------------------------------------------------------- 1 | on: 2 | workflow_call: 3 | inputs: 4 | ghc_version: 5 | required: true 6 | type: string 7 | oldest: 8 | required: false 9 | type: boolean 10 | 11 | jobs: 12 | run: 13 | runs-on: ubuntu-latest 14 | 15 | steps: 16 | - 17 | uses: actions/checkout@v3 18 | - 19 | id: setup 20 | name: Set up GHC ${{ inputs.ghc_version }} 21 | uses: haskell-actions/setup@v2 22 | with: 23 | ghc-version: ${{ inputs.ghc_version }} 24 | cabal-version: '3.10' 25 | ghcup-release-channel: https://ghc.gitlab.haskell.org/ghcup-metadata/ghcup-nightlies-0.0.7.yaml 26 | - 27 | name: Configure the build 28 | run: 29 | cabal configure 30 | --ghc-options='-Werror -Wno-unused-packages' 31 | --enable-test 32 | --enable-bench 33 | --test-options=--color=always 34 | --test-show-details=streaming 35 | - 36 | # TODO: remove when packages are updated 37 | name: Allow building deps with GHC 9.12 38 | run: 39 | cabal configure --enable-append 40 | --allow-newer=aeson:ghc-prim 41 | --allow-newer=aeson:template-haskell 42 | --allow-newer=binary-orphans:base 43 | --allow-newer=haskell-src-meta:template-haskell 44 | --allow-newer=indexed-traversable-instances:base 45 | --allow-newer=indexed-traversable:base 46 | --allow-newer=integer-conversion:base 47 | --allow-newer=microstache:base 48 | --allow-newer=scientific:base 49 | --allow-newer=scientific:template-haskell 50 | --allow-newer=semialign:base 51 | --allow-newer=text:deepseq 52 | --allow-newer=these:base 53 | --allow-newer=time-compat:base 54 | --allow-newer=time-compat:time 55 | --allow-newer=unordered-containers:template-haskell 56 | --allow-newer=uuid-types:template-haskell 57 | - 58 | if: ${{ inputs.oldest }} 59 | name: Use oldest dependencies 60 | # https://github.com/pcapriotti/optparse-applicative/issues/497 61 | run: 62 | cabal configure --enable-append 63 | --prefer-oldest 64 | --constraint='prettyprinter-ansi-terminal >= 1.1.2' 65 | --constraint='haskell-src-meta >= 0.8.13' 66 | - 67 | if: ${{ inputs.ghc_version == 'latest-nightly' }} 68 | name: Add head.hackage 69 | run: | 70 | curl -fsSL -o /tmp/head.hackage.sh https://gitlab.haskell.org/ghc/head.hackage/-/raw/master/scripts/head.hackage.sh 71 | bash /tmp/head.hackage.sh dump-repo >> cabal.project.local 72 | cabal update 73 | 74 | # https://gitlab.haskell.org/ghc/head.hackage/-/blob/90570e1c4606c1d7d3d41797ec1b32d1b984067b/ci/MakeConstraints.hs#L40-49 75 | cabal configure --enable-append \ 76 | --allow-newer=base \ 77 | --allow-newer=template-haskell \ 78 | --allow-newer=ghc \ 79 | --allow-newer=ghc-prim \ 80 | --allow-newer=integer-gmp \ 81 | --allow-newer=ghc-bignum \ 82 | --allow-newer=time \ 83 | --allow-newer=binary \ 84 | --allow-newer=bytestring \ 85 | --allow-newer=Cabal \ 86 | --allow-newer=deepseq \ 87 | --allow-newer=text 88 | - 89 | name: Get build plan 90 | run: cabal build --dry-run 91 | - 92 | name: Get current month to clear cache 93 | run: echo "CURR_MONTH=$(date +%B)" | tee -a "$GITHUB_ENV" 94 | - 95 | uses: actions/cache@v3 96 | with: 97 | path: ${{ steps.setup.outputs.cabal-store }} 98 | key: ${{ runner.os }}-cabal-cache-${{ env.CURR_MONTH }}-${{ inputs.ghc_version }}-${{ hashFiles('**/plan.json') }} 99 | restore-keys: | 100 | ${{ runner.os }}-cabal-cache-${{ env.CURR_MONTH }}-${{ inputs.ghc_version }}- 101 | - 102 | name: Build + Test 103 | run: cabal build && cabal exec -- cabal test 104 | - 105 | name: Check that files are unmodified 106 | run: git add -A && git diff --staged --exit-code 107 | -------------------------------------------------------------------------------- /test/TestUtils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TemplateHaskell #-} 10 | {-# LANGUAGE TypeApplications #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | {-# LANGUAGE UndecidableInstances #-} 13 | 14 | module TestUtils ( 15 | ShowSchemaResult (..), 16 | json, 17 | parseValue, 18 | parseObject, 19 | parseProxy, 20 | mkExpQQ, 21 | testGolden, 22 | testGoldenIO, 23 | testParseError, 24 | ghcGoldenDir, 25 | ghcVersion, 26 | ) where 27 | 28 | import Data.Aeson (FromJSON (..), Value, eitherDecode) 29 | import Data.Aeson.Types (parseEither) 30 | 31 | import Data.Proxy (Proxy (..)) 32 | import Data.String (fromString) 33 | import qualified Data.Text as Text 34 | import qualified Data.Text.IO as Text 35 | import qualified Data.Text.Lazy as TextL 36 | import qualified Data.Text.Lazy.Encoding as TextL 37 | import Data.Typeable (Typeable, typeRep) 38 | import Data.Version (Version, makeVersion, showVersion, versionBranch) 39 | import Language.Haskell.TH (ExpQ) 40 | import Language.Haskell.TH.Quote (QuasiQuoter (..)) 41 | import System.FilePath (()) 42 | import Test.Tasty (TestTree) 43 | import Test.Tasty.Golden (goldenVsString) 44 | import Test.Tasty.Golden.Advanced (goldenTest) 45 | 46 | import Data.Aeson.Schema (IsSchema, Object, schema) 47 | import qualified Data.Aeson.Schema.Internal as Internal 48 | 49 | {- ShowSchemaResult -} 50 | 51 | class ShowSchemaResult a where 52 | showSchemaResult :: String 53 | 54 | instance (IsSchema schema) => ShowSchemaResult (Object schema) where 55 | showSchemaResult = "Object (" ++ Internal.showSchema @schema ++ ")" 56 | 57 | instance (ShowSchemaResult a) => ShowSchemaResult [a] where 58 | showSchemaResult = "[" ++ showSchemaResult @a ++ "]" 59 | 60 | instance {-# OVERLAPPABLE #-} (Typeable a) => ShowSchemaResult a where 61 | showSchemaResult = show $ typeRep (Proxy @a) 62 | 63 | {- Loading JSON data -} 64 | 65 | json :: QuasiQuoter 66 | json = mkExpQQ $ \s -> [|(either error id . eitherDecode . fromString) s|] 67 | 68 | parseValue :: (FromJSON a) => Value -> a 69 | parseValue = either error id . parseEither parseJSON 70 | 71 | parseProxy :: (FromJSON a) => Proxy a -> Value -> Either String a 72 | parseProxy _ = parseEither parseJSON 73 | 74 | parseObject :: String -> ExpQ 75 | parseObject schemaString = [|parseValue :: Value -> Object $schemaType|] 76 | where 77 | schemaType = quoteType schema schemaString 78 | 79 | {- QuasiQuotation -} 80 | 81 | mkExpQQ :: (String -> ExpQ) -> QuasiQuoter 82 | mkExpQQ f = 83 | QuasiQuoter 84 | { quoteExp = f 85 | , quotePat = error "Cannot use this QuasiQuoter for patterns" 86 | , quoteType = error "Cannot use this QuasiQuoter for types" 87 | , quoteDec = error "Cannot use this QuasiQuoter for declarations" 88 | } 89 | 90 | {- Tasty test trees -} 91 | 92 | testGolden :: String -> FilePath -> String -> TestTree 93 | testGolden name fp = testGoldenIO name fp . return 94 | 95 | testGoldenIO :: String -> FilePath -> IO String -> TestTree 96 | testGoldenIO name fp = goldenVsString name ("test/goldens/" ++ fp) . fmap toByteString 97 | where 98 | toByteString = TextL.encodeUtf8 . TextL.fromStrict . Text.pack 99 | 100 | -- | A golden test for testing parse errors. 101 | testParseError :: String -> FilePath -> String -> TestTree 102 | testParseError name fp s = goldenTest name getExpected getActual cmp update 103 | where 104 | goldenFile = "test/goldens/" ++ fp 105 | getExpected = Text.readFile goldenFile 106 | getActual = return $ Text.pack s 107 | cmp expected actual = 108 | return $ 109 | if expected == actual 110 | then Nothing 111 | else Just $ "Test output was different from '" ++ goldenFile ++ "'. It was:\n" ++ Text.unpack actual 112 | update = Text.writeFile goldenFile 113 | 114 | -- | The directory to put GHC version-specific golden files. 115 | ghcGoldenDir :: FilePath 116 | ghcGoldenDir = "ghc" showVersion ghcMinorVersion 117 | where 118 | ghcMinorVersion = makeVersion . take 2 . versionBranch $ ghcVersion 119 | 120 | ghcVersion :: Version 121 | ghcVersion = makeVersion . map (read . Text.unpack) $ Text.splitOn "." __GLASGOW_HASKELL_FULL_VERSION__ 122 | -------------------------------------------------------------------------------- /test/Tests/UnwrapQQ.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | 5 | module Tests.UnwrapQQ where 6 | 7 | import qualified Data.Text as Text 8 | import Test.Tasty 9 | import Test.Tasty.HUnit 10 | import Text.RawString.QQ (r) 11 | 12 | import Data.Aeson.Schema (Object, get) 13 | import TestUtils (json, testParseError) 14 | import Tests.UnwrapQQ.TH 15 | 16 | test :: TestTree 17 | test = 18 | testGroup 19 | "`unwrap` quasiquoter" 20 | [ testValidUnwrapDefs 21 | , testInvalidUnwrapDefs 22 | ] 23 | 24 | testValidUnwrapDefs :: TestTree 25 | testValidUnwrapDefs = 26 | testGroup 27 | "Valid unwrap definitions" 28 | [ testCase "Can unwrap a list" $ do 29 | [unwrapRep| ListSchema.ids |] @?= "[Int]" 30 | [unwrapRep| ListSchema.ids[] |] @?= "Int" 31 | , testCase "Can unwrap a list of keys" $ 32 | [unwrapRep| ABCSchema.[a, b] |] @?= "[Bool]" 33 | , testCase "Can unwrap a tuple of keys" $ 34 | [unwrapRep| ABCSchema.(a, b, c) |] @?= "(Bool,Bool,Double)" 35 | , testCase "Can unwrap a maybe" $ do 36 | [unwrapRep| MaybeSchema.class |] @?= "Maybe Text" 37 | [unwrapRep| MaybeSchema.class! |] @?= "Text" 38 | [unwrapRep| MaybeSchema.class? |] @?= "Text" 39 | , testCase "Can unwrap a sum type" $ do 40 | [unwrapRep| SumSchema.verbosity@0 |] @?= "Int" 41 | [unwrapRep| SumSchema.verbosity@1 |] @?= "Bool" 42 | , testCase "Can unwrap an included schema" $ 43 | [unwrapRep| ListSchema2.list.ids |] @?= "[Int]" 44 | , testCase "Can unwrap an Object twice" $ 45 | [unwrapRep| UnwrappedNestedSchema.b |] @?= "Object (SchemaObject { \"c\": Bool })" 46 | , testCase "Can use unwrapped type" $ do 47 | let result :: Object MySchema 48 | result = 49 | [json| 50 | { 51 | "users": [ 52 | { "name": "Alice" }, 53 | { "name": "Bob" }, 54 | { "name": "Claire" } 55 | ] 56 | } 57 | |] 58 | 59 | users :: [User] 60 | users = [get| result.users |] 61 | 62 | getName :: User -> String 63 | getName = Text.unpack . [get| .name |] 64 | 65 | map getName users @?= ["Alice", "Bob", "Claire"] 66 | ] 67 | 68 | testInvalidUnwrapDefs :: TestTree 69 | testInvalidUnwrapDefs = 70 | testGroup 71 | "Invalid unwrap definitions" 72 | [ testCase "Unwrap unknown schema" $ 73 | [unwrapErr| FooSchema.asdf |] @?= "Unknown schema: FooSchema" 74 | , testCase "Unwrap non-schema" $ 75 | [unwrapErr| NotASchema.foo |] @?= "'Tests.UnwrapQQ.TH.NotASchema' is not a Schema" 76 | , testCase "Unwrap key on non-object" $ 77 | [unwrapErr| ListSchema.ids.foo |] @?= "Cannot get key 'foo' in schema: SchemaList Int" 78 | , testCase "Unwrap maybe on non-maybe" $ do 79 | [unwrapErr| ListSchema.ids! |] @?= "Cannot use `!` operator on schema: SchemaList Int" 80 | [unwrapErr| ListSchema.ids? |] @?= "Cannot use `?` operator on schema: SchemaList Int" 81 | , testCase "Unwrap list on non-list" $ 82 | [unwrapErr| MaybeSchema.class[] |] @?= "Cannot use `[]` operator on schema: SchemaMaybe Text" 83 | , testCase "Unwrap nonexistent key" $ 84 | [unwrapErr| ListSchema.foo |] @?= [r|Key 'foo' does not exist in schema: SchemaObject { "ids": List Int }|] 85 | , testCase "Unwrap list of keys with different types" $ 86 | [unwrapErr| ABCSchema.[a,b,c] |] @?= [r|List contains different types in schema: SchemaObject { "a": Bool, "b": Bool, "c": Double }|] 87 | , testCase "Unwrap list of keys on non-object schema" $ 88 | [unwrapErr| ListSchema.ids.[a,b] |] @?= "Cannot get keys in schema: SchemaList Int" 89 | , testParseError 90 | "Unwrap beyond list of keys" 91 | "unwrapqq_unwrap_past_list.golden" 92 | [unwrapErr| ABCSchema.[a,b].foo |] 93 | , testCase "Unwrap tuple of keys on non-object schema" $ 94 | [unwrapErr| ListSchema.ids.(a,b) |] @?= "Cannot get keys in schema: SchemaList Int" 95 | , testParseError 96 | "Unwrap beyond tuple of keys" 97 | "unwrapqq_unwrap_past_tuple.golden" 98 | [unwrapErr| ABCSchema.(a,b).foo |] 99 | , testCase "Unwrap branch on non-branch" $ 100 | [unwrapErr| MaybeSchema.class@0 |] @?= "Cannot use `@` operator on schema: SchemaMaybe Text" 101 | , testCase "Unwrap out of bounds branch" $ 102 | [unwrapErr| SumSchema.verbosity@10 |] @?= "Branch out of bounds for schema: SchemaUnion ( Int | Bool )" 103 | ] 104 | -------------------------------------------------------------------------------- /src/Data/Aeson/Schema/Utils/Sum.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE EmptyCase #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE StandaloneDeriving #-} 11 | {-# LANGUAGE TypeApplications #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE TypeOperators #-} 14 | {-# LANGUAGE UndecidableInstances #-} 15 | 16 | {-| 17 | Module : Data.Aeson.Schema.Utils.Sum 18 | Maintainer : Brandon Chinn 19 | Stability : experimental 20 | Portability : portable 21 | 22 | The 'SumType' data type that represents a sum type consisting of types 23 | specified in a type-level list. 24 | -} 25 | module Data.Aeson.Schema.Utils.Sum ( 26 | SumType (..), 27 | fromSumType, 28 | ) where 29 | 30 | import Control.Applicative ((<|>)) 31 | import Data.Aeson (FromJSON (..), ToJSON (..)) 32 | import Data.Kind (Constraint, Type) 33 | import Data.Proxy (Proxy (..)) 34 | import GHC.TypeLits (ErrorMessage (..), Nat, TypeError, type (-)) 35 | 36 | -- | Represents a sum type. 37 | -- 38 | -- Loads the first type that successfully parses the JSON value. 39 | -- 40 | -- Example: 41 | -- 42 | -- @ 43 | -- data Owl = Owl 44 | -- data Cat = Cat 45 | -- data Toad = Toad 46 | -- type Animal = SumType '[Owl, Cat, Toad] 47 | -- 48 | -- Here Owl :: Animal 49 | -- There (Here Cat) :: Animal 50 | -- There (There (Here Toad)) :: Animal 51 | -- 52 | -- {\- Fails at compile-time 53 | -- Here True :: Animal 54 | -- Here Cat :: Animal 55 | -- There (Here Owl) :: Animal 56 | -- There (There (There (Here Owl))) :: Animal 57 | -- -\} 58 | -- @ 59 | data SumType (types :: [Type]) where 60 | Here :: forall x xs. x -> SumType (x ': xs) 61 | There :: forall x xs. SumType xs -> SumType (x ': xs) 62 | 63 | deriving instance (Show x, Show (SumType xs)) => Show (SumType (x ': xs)) 64 | instance Show (SumType '[]) where 65 | show = \case {} 66 | 67 | deriving instance (Eq x, Eq (SumType xs)) => Eq (SumType (x ': xs)) 68 | instance Eq (SumType '[]) where 69 | _ == _ = True 70 | 71 | deriving instance (Ord x, Ord (SumType xs)) => Ord (SumType (x ': xs)) 72 | instance Ord (SumType '[]) where 73 | compare _ _ = EQ 74 | 75 | instance (FromJSON x, FromJSON (SumType xs)) => FromJSON (SumType (x ': xs)) where 76 | parseJSON v = (Here <$> parseJSON v) <|> (There <$> parseJSON v) 77 | 78 | instance FromJSON (SumType '[]) where 79 | parseJSON _ = fail "Could not parse sum type" 80 | 81 | instance (ToJSON x, ToJSON (SumType xs)) => ToJSON (SumType (x ': xs)) where 82 | toJSON = \case 83 | Here x -> toJSON x 84 | There xs -> toJSON xs 85 | 86 | instance ToJSON (SumType '[]) where 87 | toJSON = \case {} 88 | 89 | {- Extracting sum type branches -} 90 | 91 | class FromSumType (n :: Nat) (types :: [Type]) (x :: Type) where 92 | fromSumType' :: ('Just x ~ GetIndex n types) => proxy1 n -> SumType types -> Maybe x 93 | 94 | instance {-# OVERLAPPING #-} FromSumType 0 (x ': xs) x where 95 | fromSumType' _ = \case 96 | Here x -> Just x 97 | There _ -> Nothing 98 | 99 | instance 100 | {-# OVERLAPPABLE #-} 101 | ( FromSumType (n - 1) xs x 102 | , 'Just x ~ GetIndex (n - 1) xs 103 | ) => 104 | FromSumType n (_x ': xs) x 105 | where 106 | fromSumType' _ = \case 107 | Here _ -> Nothing 108 | There xs -> fromSumType' (Proxy @(n - 1)) xs 109 | 110 | -- | Extract a value from a 'SumType' 111 | -- 112 | -- Example: 113 | -- 114 | -- @ 115 | -- type Animal = SumType '[Owl, Cat, Toad] 116 | -- let someAnimal = ... :: Animal 117 | -- 118 | -- fromSumType (Proxy :: Proxy 0) someAnimal :: Maybe Owl 119 | -- fromSumType (Proxy :: Proxy 1) someAnimal :: Maybe Cat 120 | -- fromSumType (Proxy :: Proxy 2) someAnimal :: Maybe Toad 121 | -- 122 | -- -- Compile-time error 123 | -- -- fromSumType (Proxy :: Proxy 3) someAnimal 124 | -- @ 125 | fromSumType :: 126 | ( IsInRange n types 127 | , 'Just result ~ GetIndex n types 128 | , FromSumType n types result 129 | ) => 130 | proxy n 131 | -> SumType types 132 | -> Maybe result 133 | fromSumType = fromSumType' 134 | 135 | {- Helpers -} 136 | 137 | type family IsInRange (n :: Nat) (xs :: [Type]) :: Constraint where 138 | IsInRange n xs = 139 | IsInRange' 140 | ( TypeError 141 | ( 'Text "Index " 142 | ':<>: 'ShowType n 143 | ':<>: 'Text " does not exist in list: " 144 | ':<>: 'ShowType xs 145 | ) 146 | ) 147 | n 148 | xs 149 | 150 | type family IsInRange' typeErr (n :: Nat) (xs :: [Type]) :: Constraint where 151 | IsInRange' typeErr _ '[] = typeErr 152 | IsInRange' _ 0 (_ ': _) = () 153 | IsInRange' typeErr n (_ ': xs) = IsInRange' typeErr (n - 1) xs 154 | 155 | type family GetIndex (n :: Nat) (types :: [Type]) :: Maybe Type where 156 | GetIndex 0 (x ': xs) = 'Just x 157 | GetIndex _ '[] = 'Nothing 158 | GetIndex n (_ ': xs) = GetIndex (n - 1) xs 159 | -------------------------------------------------------------------------------- /src/Data/Aeson/Schema/TH/Enum.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | {-| 5 | Module : Data.Aeson.Schema.TH.Enum 6 | Maintainer : Brandon Chinn 7 | Stability : experimental 8 | Portability : portable 9 | 10 | Template Haskell functions for Enum types. 11 | -} 12 | module Data.Aeson.Schema.TH.Enum ( 13 | genFromJSONEnum, 14 | genToJSONEnum, 15 | mkEnum, 16 | ) where 17 | 18 | import Control.Monad (forM, unless) 19 | import Data.Aeson (FromJSON (..), ToJSON (..), Value (..)) 20 | import Data.Char (toLower) 21 | import Data.Maybe (mapMaybe) 22 | import qualified Data.Text as Text 23 | import Language.Haskell.TH 24 | import Language.Haskell.TH.Syntax (lift) 25 | 26 | -- | Make an enum type with the given constructors, that can be parsed from JSON. 27 | -- 28 | -- The 'FromJSON' instance will match to a string value matching the constructor name, 29 | -- case-insensitive. 30 | -- 31 | -- @ 32 | -- mkEnum \"State" [\"OPEN", \"CLOSED"] 33 | -- 34 | -- -- generates equivalent of: 35 | -- -- data State = OPEN | CLOSED deriving (...) 36 | -- -- genFromJSONEnum ''State 37 | -- -- genToJSONEnum ''State 38 | -- @ 39 | mkEnum :: String -> [String] -> Q [Dec] 40 | mkEnum name vals = 41 | concat 42 | <$> sequence 43 | [ (: []) <$> dataDec 44 | , mkFromJSON name' vals' 45 | , mkToJSON name' vals' 46 | ] 47 | where 48 | name' = mkName name 49 | vals' = map mkName vals 50 | dataDec = dataD (pure []) name' [] Nothing (map toCon vals') [derivClause Nothing deriveClasses] 51 | deriveClasses = 52 | [ [t|Eq|] 53 | , [t|Ord|] 54 | , [t|Show|] 55 | , [t|Enum|] 56 | ] 57 | toCon val = normalC val [] 58 | 59 | -- | Generate an instance of 'FromJSON' for the given data type. 60 | -- 61 | -- Prefer using 'mkEnum'; this function is useful for data types in which you want greater control 62 | -- over the actual data type. 63 | -- 64 | -- The 'FromJSON' instance will match to a string value matching the constructor name, 65 | -- case-insensitive. 66 | -- 67 | -- @ 68 | -- data State = Open | CLOSED deriving (Show,Enum) 69 | -- genFromJSONEnum ''State 70 | -- 71 | -- -- outputs: 72 | -- -- Just Open 73 | -- -- Just Open 74 | -- -- Just CLOSED 75 | -- -- Just CLOSED 76 | -- main = mapM_ print 77 | -- [ decodeState \"open" 78 | -- , decodeState \"OPEN" 79 | -- , decodeState \"closed" 80 | -- , decodeState \"CLOSED" 81 | -- ] 82 | -- where 83 | -- decodeState :: String -> Maybe State 84 | -- decodeState = decode . show 85 | -- @ 86 | genFromJSONEnum :: Name -> Q [Dec] 87 | genFromJSONEnum name = getEnumConstructors name >>= mkFromJSON name 88 | 89 | -- | Generate an instance of 'ToJSON' for the given data type. 90 | -- 91 | -- Prefer using 'mkEnum'; this function is useful for data types in which you want greater control 92 | -- over the actual data type. 93 | -- 94 | -- The 'ToJSON' instance will encode the enum as a string matching the constructor name. 95 | -- 96 | -- @ 97 | -- data State = Open | CLOSED deriving (Show,Enum) 98 | -- genToJSONEnum ''State 99 | -- 100 | -- -- outputs: 101 | -- -- \"Open" 102 | -- -- \"CLOSED" 103 | -- main = mapM_ print 104 | -- [ encode Open 105 | -- , encode CLOSED 106 | -- ] 107 | -- @ 108 | genToJSONEnum :: Name -> Q [Dec] 109 | genToJSONEnum name = getEnumConstructors name >>= mkToJSON name 110 | 111 | {- Helpers -} 112 | 113 | getEnumConstructors :: Name -> Q [Name] 114 | getEnumConstructors name = do 115 | -- check if 'name' is an Enum 116 | ClassI _ instances <- reify ''Enum 117 | let instanceNames = flip mapMaybe instances $ \case 118 | InstanceD _ _ (AppT _ (ConT n)) _ -> Just n 119 | _ -> Nothing 120 | unless (name `elem` instanceNames) $ fail $ "Not an Enum type: " ++ show name 121 | 122 | -- extract constructor names 123 | reify name >>= \case 124 | TyConI (DataD _ _ _ _ cons _) -> forM cons $ \case 125 | NormalC con [] -> return con 126 | con -> fail $ "Invalid constructor: " ++ show con 127 | info -> fail $ "Invalid data type: " ++ show info 128 | 129 | mkFromJSON :: Name -> [Name] -> Q [Dec] 130 | mkFromJSON name cons = do 131 | let toPattern = litP . stringL . map toLower . nameBase 132 | toMatch con = match (toPattern con) (normalB [|pure $(conE con)|]) [] 133 | 134 | t <- newName "t" 135 | let parseEnum = 136 | caseE [|Text.unpack $ Text.toLower $(varE t)|] $ 137 | map toMatch cons ++ [match wildP (normalB $ appE badParse $ varE t) []] 138 | 139 | [d| 140 | instance FromJSON $(conT name) where 141 | parseJSON (String $(varP t)) = $parseEnum 142 | parseJSON v = $badParse v 143 | |] 144 | where 145 | badParse = 146 | let prefix = litE $ stringL $ "Bad " ++ nameBase name ++ ": " 147 | in [|fail . ($prefix ++) . show|] 148 | 149 | mkToJSON :: Name -> [Name] -> Q [Dec] 150 | mkToJSON name cons = 151 | [d| 152 | instance ToJSON $(conT name) where 153 | toJSON = $(lamCaseE $ map encodeConstructor cons) 154 | |] 155 | where 156 | encodeConstructor con = match (conP con []) (normalB [|String $ Text.pack $(lift $ nameBase con)|]) [] 157 | -------------------------------------------------------------------------------- /aeson-schemas.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >= 1.10 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.37.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: aeson-schemas 8 | version: 1.4.3.0 9 | synopsis: Easily consume JSON data on-demand with type-safety 10 | description: Parse JSON data easily and safely without defining new data types. Useful 11 | for deeply nested JSON data, which is difficult to parse using the default 12 | FromJSON instances. 13 | category: JSON 14 | homepage: https://github.com/brandonchinn178/aeson-schemas#readme 15 | bug-reports: https://github.com/brandonchinn178/aeson-schemas/issues 16 | author: Brandon Chinn 17 | maintainer: Brandon Chinn 18 | license: BSD3 19 | license-file: LICENSE.md 20 | build-type: Simple 21 | extra-source-files: 22 | README.md 23 | CHANGELOG.md 24 | examples/input.json 25 | test/goldens/fromjson_error_messages_truncate.golden 26 | test/goldens/fromjson_list_inner_invalid.golden 27 | test/goldens/fromjson_list_invalid.golden 28 | test/goldens/fromjson_maybe_invalid.golden 29 | test/goldens/fromjson_nested_inner_invalid.golden 30 | test/goldens/fromjson_nested_invalid.golden 31 | test/goldens/fromjson_object_invalid.golden 32 | test/goldens/fromjson_object_later_keys_invalid.golden 33 | test/goldens/fromjson_phantom_inner_invalid.golden 34 | test/goldens/fromjson_phantom_inner_missing.golden 35 | test/goldens/fromjson_phantom_invalid.golden 36 | test/goldens/fromjson_scalar_invalid.golden 37 | test/goldens/fromjson_union_invalid.golden 38 | test/goldens/getqq_empty_expression.golden 39 | test/goldens/getqq_no_operators.golden 40 | test/goldens/getqq_ops_after_list.golden 41 | test/goldens/getqq_ops_after_tuple.golden 42 | test/goldens/ghc/9.10/getqq_missing_key.golden 43 | test/goldens/ghc/9.12/getqq_missing_key.golden 44 | test/goldens/ghc/9.8/getqq_missing_key.golden 45 | test/goldens/README_Quickstart.golden 46 | test/goldens/schemaqq_key_with_invalid_character.golden 47 | test/goldens/schemaqq_key_with_trailing_escape.golden 48 | test/goldens/sumtype_decode_invalid.golden 49 | test/goldens/unwrapqq_unwrap_past_list.golden 50 | test/goldens/unwrapqq_unwrap_past_tuple.golden 51 | test/wont-compile/GetMissingKey.hs 52 | 53 | source-repository head 54 | type: git 55 | location: https://github.com/brandonchinn178/aeson-schemas 56 | 57 | library 58 | exposed-modules: 59 | Data.Aeson.Schema 60 | Data.Aeson.Schema.Internal 61 | Data.Aeson.Schema.Key 62 | Data.Aeson.Schema.TH 63 | Data.Aeson.Schema.Type 64 | Data.Aeson.Schema.Utils.All 65 | Data.Aeson.Schema.Utils.Compat 66 | Data.Aeson.Schema.Utils.Invariant 67 | Data.Aeson.Schema.Utils.NameLike 68 | Data.Aeson.Schema.Utils.Sum 69 | other-modules: 70 | Data.Aeson.Schema.TH.Enum 71 | Data.Aeson.Schema.TH.Get 72 | Data.Aeson.Schema.TH.Getter 73 | Data.Aeson.Schema.TH.Parse 74 | Data.Aeson.Schema.TH.Schema 75 | Data.Aeson.Schema.TH.Unwrap 76 | Data.Aeson.Schema.TH.Utils 77 | hs-source-dirs: 78 | src 79 | ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances -Wunused-packages 80 | build-depends: 81 | aeson <3 82 | , base >=4.17 && <5 83 | , first-class-families <0.9 84 | , hashable <1.6 85 | , megaparsec <10 86 | , template-haskell <2.24 87 | , text <2.2 88 | , unordered-containers <0.3 89 | default-language: Haskell2010 90 | 91 | test-suite aeson-schemas-test 92 | type: exitcode-stdio-1.0 93 | main-is: Main.hs 94 | other-modules: 95 | Tests.EnumTH 96 | Tests.GetQQ 97 | Tests.GetQQ.TH 98 | Tests.MkGetter 99 | Tests.Object 100 | Tests.Object.Eq 101 | Tests.Object.FromJSON 102 | Tests.Object.FromJSON.TH 103 | Tests.Object.Show 104 | Tests.Object.Show.TH 105 | Tests.Object.ToJSON 106 | Tests.Quickstart 107 | Tests.SchemaQQ 108 | Tests.SchemaQQ.TH 109 | Tests.SumType 110 | Tests.UnwrapQQ 111 | Tests.UnwrapQQ.TH 112 | TestUtils 113 | TestUtils.Arbitrary 114 | TestUtils.DeepSeq 115 | Paths_aeson_schemas 116 | hs-source-dirs: 117 | test 118 | ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances -Wunused-packages 119 | build-depends: 120 | QuickCheck 121 | , aeson 122 | , aeson-qq >=0.8.4 123 | , aeson-schemas 124 | , base 125 | , deepseq 126 | , filepath 127 | , interpolate 128 | , process 129 | , raw-strings-qq 130 | , tasty 131 | , tasty-golden 132 | , tasty-hunit 133 | , tasty-quickcheck >=0.8.1 134 | , template-haskell 135 | , temporary 136 | , text 137 | , th-orphans 138 | , th-test-utils 139 | default-language: Haskell2010 140 | 141 | benchmark aeson-schemas-bench 142 | type: exitcode-stdio-1.0 143 | main-is: Main.hs 144 | other-modules: 145 | Benchmarks.Data.Objects 146 | Benchmarks.Data.Schemas 147 | Benchmarks.Data.Schemas.TH 148 | Benchmarks.FromJSON 149 | Benchmarks.SchemaQQ 150 | Benchmarks.Show 151 | Benchmarks.ToJSON 152 | Utils.DeepSeq 153 | Paths_aeson_schemas 154 | hs-source-dirs: 155 | bench 156 | ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances -Wunused-packages 157 | build-depends: 158 | aeson 159 | , aeson-schemas 160 | , base 161 | , criterion 162 | , deepseq 163 | , template-haskell 164 | , th-test-utils 165 | default-language: Haskell2010 166 | -------------------------------------------------------------------------------- /test/Tests/Object/FromJSON.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE KindSignatures #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE QuasiQuotes #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TemplateHaskell #-} 10 | 11 | module Tests.Object.FromJSON where 12 | 13 | import Data.Aeson (FromJSON (..), Value) 14 | import Data.Aeson.QQ (aesonQQ) 15 | import Data.Aeson.Types (parseEither) 16 | import Data.Proxy (Proxy) 17 | import Test.Tasty 18 | import Test.Tasty.QuickCheck 19 | 20 | import Data.Aeson.Schema (Object) 21 | import TestUtils (parseProxy, testGolden) 22 | import TestUtils.Arbitrary (ArbitraryObject (..), forAllArbitraryObjects) 23 | import Tests.Object.FromJSON.TH 24 | 25 | test :: TestTree 26 | test = 27 | testGroup "FromJSON instance" $ 28 | map runTestCase testCases 29 | ++ [ testProperty "QuickCheck arbitrary Schema" $ 30 | $(forAllArbitraryObjects) $ \(ArbitraryObject proxy v _) -> 31 | case parseProxy proxy v of 32 | Right _ -> property () 33 | Left e -> error $ "Could not parse: " ++ e 34 | ] 35 | 36 | testCases :: [FromJSONTestCase] 37 | testCases = 38 | [ CheckValid 39 | "Scalar valid" 40 | [schemaProxy| { foo: Text } |] 41 | $ \(s :: String) -> [aesonQQ| { "foo": #{s} } |] 42 | , CheckError 43 | "Scalar invalid" 44 | "fromjson_scalar_invalid.golden" 45 | [schemaProxy| { foo: Text } |] 46 | [aesonQQ| { "foo": 1 } |] 47 | , CheckValid 48 | "Maybe valid" 49 | [schemaProxy| { foo: Maybe Int } |] 50 | $ \(x :: Maybe Int) -> [aesonQQ| { "foo": #{x} } |] 51 | , CheckError 52 | "Maybe invalid" 53 | "fromjson_maybe_invalid.golden" 54 | [schemaProxy| { foo: Maybe Int } |] 55 | [aesonQQ| { "foo": true } |] 56 | , CheckValid 57 | "Try valid with valid parse" 58 | [schemaProxy| { foo: Try Bool } |] 59 | $ \(x :: Bool) -> [aesonQQ| { "foo": #{x} } |] 60 | , CheckValid 61 | "Try valid with invalid parse" 62 | [schemaProxy| { foo: Try Bool } |] 63 | $ \(s :: String) -> [aesonQQ| { "foo": #{s} } |] 64 | , CheckValid 65 | "List valid" 66 | [schemaProxy| { foo: List Double } |] 67 | $ \(xs :: [Double]) -> [aesonQQ| { "foo": #{xs} } |] 68 | , CheckError 69 | "List invalid" 70 | "fromjson_list_invalid.golden" 71 | [schemaProxy| { foo: List Double } |] 72 | [aesonQQ| { "foo": true } |] 73 | , CheckError 74 | "List invalid inner" 75 | "fromjson_list_inner_invalid.golden" 76 | [schemaProxy| { foo: List Double } |] 77 | [aesonQQ| { "foo": [true] } |] 78 | , CheckError 79 | "Object invalid" 80 | "fromjson_object_invalid.golden" 81 | [schemaProxy| { foo: Int } |] 82 | [aesonQQ| 1 |] 83 | , CheckError 84 | "Object invalid in later keys" 85 | "fromjson_object_later_keys_invalid.golden" 86 | [schemaProxy| { foo: Int, bar: Int } |] 87 | [aesonQQ| { "foo": 1, "bar": true } |] 88 | , CheckValid 89 | "Nested object valid" 90 | [schemaProxy| { foo: { bar: Int } } |] 91 | $ \(x :: Int) -> [aesonQQ| { "foo": { "bar": #{x} } } |] 92 | , CheckError 93 | "Nested object invalid" 94 | "fromjson_nested_invalid.golden" 95 | [schemaProxy| { foo: { bar: Int } } |] 96 | [aesonQQ| { "foo": true } |] 97 | , CheckError 98 | "Nested object invalid inner" 99 | "fromjson_nested_inner_invalid.golden" 100 | [schemaProxy| { foo: { bar: Int } } |] 101 | [aesonQQ| { "foo": { "bar": true } } |] 102 | , CheckValid 103 | "Union object valid" 104 | [schemaProxy| { foo: Int | Text } |] 105 | $ \(x :: Int) -> [aesonQQ| { "foo": #{x} } |] 106 | , CheckError 107 | "Union object invalid" 108 | "fromjson_union_invalid.golden" 109 | [schemaProxy| { foo: Int | Text } |] 110 | [aesonQQ| { "foo": true } |] 111 | , CheckValid 112 | "Phantom key valid object" 113 | [schemaProxy| { [foo]: { bar: Int } } |] 114 | $ \(x :: Int) -> [aesonQQ| { "bar": #{x} } |] 115 | , CheckValid 116 | "Phantom key valid non-object try" 117 | [schemaProxy| { [foo]: Try Bool } |] 118 | $ \(b :: Bool) -> [aesonQQ| { "bar": #{b} } |] 119 | , CheckError 120 | "Phantom key invalid" 121 | "fromjson_phantom_invalid.golden" 122 | [schemaProxy| { [foo]: { bar: Int } } |] 123 | [aesonQQ| 1 |] 124 | , CheckError 125 | "Phantom key missing inner" 126 | "fromjson_phantom_inner_missing.golden" 127 | [schemaProxy| { [foo]: { bar: Int } } |] 128 | [aesonQQ| { "foo": true } |] 129 | , CheckError 130 | "Phantom key invalid inner" 131 | "fromjson_phantom_inner_invalid.golden" 132 | [schemaProxy| { [foo]: { bar: Int } } |] 133 | [aesonQQ| { "bar": true } |] 134 | , CheckError 135 | "Decode failure messages are truncated" 136 | "fromjson_error_messages_truncate.golden" 137 | [schemaProxy| { foo: Int } |] 138 | [aesonQQ| 139 | { 140 | "foo": [ 141 | { "bar": 1 }, 142 | { "bar": 2 }, 143 | { "bar": 3 }, 144 | { "bar": 4 }, 145 | { "bar": 5 }, 146 | { "bar": 6 }, 147 | { "bar": 7 }, 148 | { "bar": 8 }, 149 | { "bar": 9 } 150 | ] 151 | } 152 | |] 153 | ] 154 | 155 | {- Helpers -} 156 | 157 | data FromJSONTestCase where 158 | CheckValid :: 159 | (Arbitrary a, Show a, FromJSON (Object schema)) => 160 | TestName 161 | -- ^ Name of test case 162 | -> Proxy (Object schema) 163 | -- ^ The schema to parse with 164 | -> (a -> Value) 165 | -- ^ A function that builds a Value that should satisfy the schema 166 | -> FromJSONTestCase 167 | CheckError :: 168 | (FromJSON (Object schema), Show (Object schema)) => 169 | TestName 170 | -- ^ Name of test case 171 | -> String 172 | -- ^ Name of golden file 173 | -> Proxy (Object schema) 174 | -- ^ The schema to parse with 175 | -> Value 176 | -- ^ The value that should fail parsing the given schema 177 | -> FromJSONTestCase 178 | 179 | runTestCase :: FromJSONTestCase -> TestTree 180 | runTestCase = \case 181 | CheckValid name schema valueGen -> 182 | testProperty name $ \a -> 183 | case parse schema (valueGen a) of 184 | Right _ -> () 185 | Left e -> error $ "Unexpected failure: " ++ e 186 | CheckError name fp schema value -> 187 | testGolden name fp $ 188 | case parse schema value of 189 | Right o -> error $ "Unexpectedly parsed: " ++ show o 190 | Left e -> e 191 | 192 | parse :: (FromJSON a) => Proxy a -> Value -> Either String a 193 | parse _ = parseEither parseJSON 194 | -------------------------------------------------------------------------------- /src/Data/Aeson/Schema/Type.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | 11 | {-| 12 | Module : Data.Aeson.Schema.Type 13 | Maintainer : Brandon Chinn 14 | Stability : experimental 15 | Portability : portable 16 | 17 | Defines SchemaType, the AST that defines a JSON schema. 18 | -} 19 | module Data.Aeson.Schema.Type ( 20 | Schema' (..), 21 | SchemaType' (..), 22 | SchemaV, 23 | SchemaTypeV, 24 | SchemaObjectMapV, 25 | toSchemaObjectV, 26 | fromSchemaV, 27 | showSchemaV, 28 | showSchemaTypeV, 29 | Schema, 30 | SchemaType, 31 | ToSchemaObject, 32 | FromSchema, 33 | IsSchemaType (..), 34 | IsSchemaObjectMap, 35 | toSchemaV, 36 | ) where 37 | 38 | import Data.Kind (Type) 39 | import Data.List (intercalate) 40 | import Data.Proxy (Proxy (..)) 41 | import Data.Typeable (Typeable, tyConName, typeRep, typeRepTyCon) 42 | import GHC.TypeLits (Symbol) 43 | 44 | import Data.Aeson.Schema.Key ( 45 | IsSchemaKey (..), 46 | SchemaKey, 47 | SchemaKey', 48 | SchemaKeyV, 49 | showSchemaKeyV, 50 | ) 51 | import Data.Aeson.Schema.Utils.All (All (..)) 52 | import Data.Aeson.Schema.Utils.Invariant (unreachable) 53 | import Data.Aeson.Schema.Utils.NameLike (NameLike (..), fromName) 54 | 55 | -- | The schema definition for a JSON object. 56 | data Schema' s ty = Schema (SchemaObjectMap' s ty) 57 | deriving (Show, Eq) 58 | 59 | -- | The AST defining a JSON schema. 60 | data SchemaType' s ty 61 | = SchemaScalar ty 62 | | SchemaMaybe (SchemaType' s ty) 63 | | -- | @since v1.2.0 64 | SchemaTry (SchemaType' s ty) 65 | | SchemaList (SchemaType' s ty) 66 | | -- | @since v1.1.0 67 | SchemaUnion [SchemaType' s ty] 68 | | SchemaObject (SchemaObjectMap' s ty) 69 | | -- | An optimization for including schemas. 70 | -- 71 | -- Will always be 'Left' when used in a value-level schema and 'Right' when used in 72 | -- a type-level schema. We can't use a type parameter for this because type synonyms 73 | -- can't be recursive (e.g. `type Schema = Schema' Symbol Type Schema`). 74 | -- 75 | -- @since v1.3.2 76 | SchemaInclude (Either ty (Schema' s ty)) 77 | deriving (Show, Eq) 78 | 79 | type SchemaObjectMap' s ty = [(SchemaKey' s, SchemaType' s ty)] 80 | 81 | {- Value-level schema types -} 82 | 83 | type SchemaV = Schema' String NameLike 84 | type SchemaTypeV = SchemaType' String NameLike 85 | type SchemaObjectMapV = SchemaObjectMap' String NameLike 86 | 87 | toSchemaObjectV :: SchemaV -> SchemaTypeV 88 | toSchemaObjectV (Schema schema) = SchemaObject schema 89 | 90 | fromSchemaV :: SchemaV -> SchemaObjectMapV 91 | fromSchemaV (Schema schema) = schema 92 | 93 | -- | Show the given schema, as "{ key: Schema, ... }" 94 | showSchemaV :: SchemaV -> String 95 | showSchemaV = showSchemaTypeV' . toSchemaObjectV 96 | 97 | -- | Pretty show the given SchemaType. 98 | showSchemaTypeV :: SchemaTypeV -> String 99 | showSchemaTypeV schema = case schema of 100 | SchemaScalar _ -> "SchemaScalar " ++ showSchemaTypeV' schema 101 | SchemaMaybe inner -> "SchemaMaybe " ++ showSchemaTypeV' inner 102 | SchemaTry inner -> "SchemaTry " ++ showSchemaTypeV' inner 103 | SchemaList inner -> "SchemaList " ++ showSchemaTypeV' inner 104 | SchemaUnion _ -> "SchemaUnion " ++ showSchemaTypeV' schema 105 | SchemaObject _ -> "SchemaObject " ++ showSchemaTypeV' schema 106 | SchemaInclude _ -> "SchemaInclude " ++ showSchemaTypeV' schema 107 | 108 | showSchemaTypeV' :: SchemaTypeV -> String 109 | showSchemaTypeV' = \case 110 | SchemaScalar ty -> fromName ty 111 | SchemaMaybe inner -> "Maybe " ++ showSchemaTypeV' inner 112 | SchemaTry inner -> "Try " ++ showSchemaTypeV' inner 113 | SchemaList inner -> "List " ++ showSchemaTypeV' inner 114 | SchemaUnion schemas -> "( " ++ mapJoin showSchemaTypeV' " | " schemas ++ " )" 115 | SchemaObject pairs -> "{ " ++ mapJoin showPair ", " pairs ++ " }" 116 | SchemaInclude (Left name) -> fromName name 117 | SchemaInclude (Right _) -> unreachable "Found 'SchemaInclude Right' when showing schema type" 118 | where 119 | showPair (key, inner) = showSchemaKeyV key ++ ": " ++ showSchemaTypeV' inner 120 | 121 | mapJoin f delim = intercalate delim . map f 122 | 123 | {- Type-level schema types -} 124 | 125 | -- | The kind of schemas that may be used with Object; e.g. 126 | -- 127 | -- > data Payload (schema :: Schema) = Payload 128 | -- > { getPayload :: Object schema 129 | -- > , timestamp :: UTCTime 130 | -- > } 131 | type Schema = Schema' Symbol Type 132 | 133 | type SchemaType = SchemaType' Symbol Type 134 | 135 | type SchemaObjectMap = SchemaObjectMap' Symbol Type 136 | 137 | type family ToSchemaObject (schema :: Schema) :: SchemaType where 138 | ToSchemaObject ('Schema schema) = 'SchemaObject schema 139 | 140 | type family FromSchema (schema :: Schema) :: SchemaObjectMap where 141 | FromSchema ('Schema schema) = schema 142 | 143 | toSchemaV :: forall schema. (IsSchemaObjectMap (FromSchema schema)) => Proxy schema -> SchemaV 144 | toSchemaV _ = Schema $ toSchemaTypeMapV $ Proxy @(FromSchema schema) 145 | 146 | toSchemaTypeMapV :: forall pairs. (IsSchemaObjectMap pairs) => Proxy pairs -> SchemaObjectMapV 147 | toSchemaTypeMapV _ = mapAll @IsSchemaObjectPair @pairs toSchemaTypePairV 148 | 149 | class IsSchemaType (schemaType :: SchemaType) where 150 | toSchemaTypeV :: Proxy schemaType -> SchemaTypeV 151 | 152 | instance (Typeable inner) => IsSchemaType ('SchemaScalar inner) where 153 | toSchemaTypeV _ = SchemaScalar (NameRef $ tyConName $ typeRepTyCon $ typeRep $ Proxy @inner) 154 | 155 | instance (IsSchemaType inner) => IsSchemaType ('SchemaMaybe inner) where 156 | toSchemaTypeV _ = SchemaMaybe (toSchemaTypeV $ Proxy @inner) 157 | 158 | instance (IsSchemaType inner) => IsSchemaType ('SchemaTry inner) where 159 | toSchemaTypeV _ = SchemaTry (toSchemaTypeV $ Proxy @inner) 160 | 161 | instance (IsSchemaType inner) => IsSchemaType ('SchemaList inner) where 162 | toSchemaTypeV _ = SchemaList (toSchemaTypeV $ Proxy @inner) 163 | 164 | instance (All IsSchemaType schemas) => IsSchemaType ('SchemaUnion schemas) where 165 | toSchemaTypeV _ = SchemaUnion (mapAll @IsSchemaType @schemas toSchemaTypeV) 166 | 167 | instance (IsSchemaObjectMap pairs) => IsSchemaType ('SchemaObject pairs) where 168 | toSchemaTypeV _ = SchemaObject (toSchemaTypeMapV $ Proxy @pairs) 169 | 170 | instance (IsSchemaObjectMap (FromSchema schema)) => IsSchemaType ('SchemaInclude ('Right schema)) where 171 | toSchemaTypeV _ = toSchemaObjectV $ toSchemaV $ Proxy @schema 172 | 173 | type IsSchemaObjectMap (pairs :: SchemaObjectMap) = All IsSchemaObjectPair pairs 174 | 175 | class IsSchemaObjectPair (a :: (SchemaKey, SchemaType)) where 176 | toSchemaTypePairV :: Proxy a -> (SchemaKeyV, SchemaTypeV) 177 | 178 | instance (IsSchemaKey key, IsSchemaType inner) => IsSchemaObjectPair '(key, inner) where 179 | toSchemaTypePairV _ = (toSchemaKeyV $ Proxy @key, toSchemaTypeV $ Proxy @inner) 180 | -------------------------------------------------------------------------------- /src/Data/Aeson/Schema/TH/Unwrap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | 5 | {-| 6 | Module : Data.Aeson.Schema.TH.Unwrap 7 | Maintainer : Brandon Chinn 8 | Stability : experimental 9 | Portability : portable 10 | 11 | The 'unwrap' quasiquoter. 12 | -} 13 | module Data.Aeson.Schema.TH.Unwrap where 14 | 15 | import Control.Monad ((<=<), (>=>)) 16 | import Data.Bifunctor (first) 17 | import qualified Data.List.NonEmpty as NonEmpty 18 | import Language.Haskell.TH 19 | import Language.Haskell.TH.Quote (QuasiQuoter (..)) 20 | 21 | import Data.Aeson.Schema.Internal (Object, SchemaResult) 22 | import Data.Aeson.Schema.Key (fromSchemaKeyV) 23 | import Data.Aeson.Schema.TH.Parse ( 24 | GetterOperation (..), 25 | GetterOps, 26 | UnwrapSchema (..), 27 | parseUnwrapSchema, 28 | ) 29 | import Data.Aeson.Schema.TH.Utils ( 30 | reifySchema, 31 | resolveSchemaType, 32 | schemaTypeVToTypeQ, 33 | schemaVToTypeQ, 34 | ) 35 | import Data.Aeson.Schema.Type ( 36 | Schema' (..), 37 | SchemaType' (..), 38 | SchemaTypeV, 39 | SchemaV, 40 | showSchemaTypeV, 41 | toSchemaObjectV, 42 | ) 43 | 44 | -- | Defines a QuasiQuoter to extract a schema within the given schema. 45 | -- 46 | -- The base schema needs to be defined in a separate module. 47 | -- 48 | -- For example: 49 | -- 50 | -- > -- | MyFoo ~ Object [schema| { b: Maybe Bool } |] 51 | -- > type MyFoo = [unwrap| MySchema.foo.nodes[] |] 52 | -- 53 | -- If the schema is imported qualified, you can use parentheses to distinguish it from the 54 | -- expression: 55 | -- 56 | -- > type MyFoo = [unwrap| (MyModule.Schema).foo.nodes[] |] 57 | -- 58 | -- You can then use the type alias as usual: 59 | -- 60 | -- > parseBar :: MyFoo -> String 61 | -- > parseBar = maybe "null" show . [get| .b |] 62 | -- > 63 | -- > foo = map parseBar [get| result.foo.nodes[] |] 64 | -- 65 | -- The syntax is mostly the same as 'Data.Aeson.Schema.TH.get', except the operations run on the 66 | -- type itself, instead of the values. Differences from 'Data.Aeson.Schema.TH.get': 67 | -- 68 | -- * @x!@ is only valid if @x@ is a @Maybe a@ type. Returns @a@, the type wrapped in the 'Maybe'. 69 | -- 70 | -- * @x?@ is the same as @x!@. 71 | -- 72 | -- * @x[]@ is only valid if @x@ is a @[a]@ type. Returns @a@, the type contained in the list. 73 | -- 74 | -- * @x\@#@ is only valid if @x@ is a @SumType@. Returns the type at that branch in the sum type. 75 | unwrap :: QuasiQuoter 76 | unwrap = 77 | QuasiQuoter 78 | { quoteExp = error "Cannot use `unwrap` for Exp" 79 | , quoteDec = error "Cannot use `unwrap` for Dec" 80 | , quoteType = parseUnwrapSchema >=> generateUnwrapSchema 81 | , quotePat = error "Cannot use `unwrap` for Pat" 82 | } 83 | 84 | generateUnwrapSchema :: UnwrapSchema -> TypeQ 85 | generateUnwrapSchema UnwrapSchema{..} = reifySchema startSchema >>= unwrapSchema getterOps 86 | 87 | -- | Unwrap the given schema by applying the given operations, stripping out functors. 88 | unwrapSchema :: GetterOps -> SchemaV -> TypeQ 89 | unwrapSchema = unwrapSchemaUsing StripFunctors 90 | 91 | -- | Unwrap the given schema by applying the given operations, using the given 'FunctorHandler'. 92 | unwrapSchemaUsing :: FunctorHandler -> GetterOps -> SchemaV -> TypeQ 93 | unwrapSchemaUsing functorHandler getterOps = toResultTypeQ <=< flip go (NonEmpty.toList getterOps) . toSchemaObjectV 94 | where 95 | toResultTypeQ :: UnwrapSchemaResult -> TypeQ 96 | toResultTypeQ = \case 97 | -- special case SchemaObject to make it further inspectable 98 | SchemaResult (SchemaObject pairs) -> [t|Object $(schemaVToTypeQ (Schema pairs))|] 99 | SchemaResult schemaType -> [t|SchemaResult $(schemaTypeVToTypeQ schemaType)|] 100 | SchemaResultList schemaResult -> appT listT (toResultTypeQ schemaResult) 101 | SchemaResultTuple schemaResults -> foldl appT (tupleT $ length schemaResults) $ map toResultTypeQ schemaResults 102 | SchemaResultWrapped functorTy schemaResult -> 103 | let handleFunctor ty = 104 | case functorHandler of 105 | ApplyFunctors -> AppT functorTy ty 106 | StripFunctors -> ty 107 | in handleFunctor <$> toResultTypeQ schemaResult 108 | 109 | go :: SchemaTypeV -> [GetterOperation] -> Q UnwrapSchemaResult 110 | go schemaType [] = pure $ SchemaResult schemaType 111 | go schemaType' (op : ops) = do 112 | schemaType <- resolveSchemaType schemaType' 113 | 114 | let invalid message = fail $ message ++ ": " ++ showSchemaTypeV schemaType 115 | wrapMaybe = SchemaResultWrapped (ConT ''Maybe) 116 | wrapList = SchemaResultWrapped ListT 117 | 118 | case op of 119 | GetterKey key -> 120 | case schemaType of 121 | SchemaObject pairs -> 122 | case lookup key $ map (first fromSchemaKeyV) pairs of 123 | Just inner -> go inner ops 124 | Nothing -> invalid $ "Key '" ++ key ++ "' does not exist in schema" 125 | _ -> invalid $ "Cannot get key '" ++ key ++ "' in schema" 126 | GetterBang -> 127 | case schemaType of 128 | SchemaMaybe inner -> go inner ops 129 | SchemaTry inner -> go inner ops 130 | _ -> invalid "Cannot use `!` operator on schema" 131 | GetterMapMaybe -> 132 | case schemaType of 133 | SchemaMaybe inner -> wrapMaybe <$> go inner ops 134 | SchemaTry inner -> wrapMaybe <$> go inner ops 135 | _ -> invalid "Cannot use `?` operator on schema" 136 | GetterMapList -> 137 | case schemaType of 138 | SchemaList inner -> wrapList <$> go inner ops 139 | _ -> invalid "Cannot use `[]` operator on schema" 140 | GetterBranch branch -> 141 | case schemaType of 142 | SchemaUnion schemas -> 143 | if branch < length schemas 144 | then go (schemas !! branch) ops 145 | else invalid "Branch out of bounds for schema" 146 | _ -> invalid "Cannot use `@` operator on schema" 147 | -- suffixes; ops should be empty 148 | 149 | GetterList elemOps -> 150 | case schemaType of 151 | SchemaObject _ -> do 152 | elemSchemas <- traverse (go schemaType . NonEmpty.toList) elemOps 153 | let elemSchema = NonEmpty.head elemSchemas 154 | if all (== elemSchema) elemSchemas 155 | then pure $ SchemaResultList elemSchema 156 | else invalid "List contains different types in schema" 157 | _ -> invalid "Cannot get keys in schema" 158 | GetterTuple elemOps -> 159 | case schemaType of 160 | SchemaObject _ -> SchemaResultTuple <$> mapM (go schemaType . NonEmpty.toList) (NonEmpty.toList elemOps) 161 | _ -> invalid "Cannot get keys in schema" 162 | 163 | data UnwrapSchemaResult 164 | = SchemaResult SchemaTypeV 165 | | SchemaResultList UnwrapSchemaResult 166 | | SchemaResultTuple [UnwrapSchemaResult] 167 | | -- | Type should be of kind `* -> *` 168 | SchemaResultWrapped Type UnwrapSchemaResult 169 | deriving (Eq) 170 | 171 | -- | A data type that indicates how to handle functors when unwrapping a schema. 172 | data FunctorHandler 173 | = -- | handleFunctor Maybe Int ==> Maybe Int 174 | ApplyFunctors 175 | | -- | handleFunctor Maybe Int ==> Int 176 | StripFunctors 177 | -------------------------------------------------------------------------------- /src/Data/Aeson/Schema/TH/Get.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | 6 | {-| 7 | Module : Data.Aeson.Schema.TH.Get 8 | Maintainer : Brandon Chinn 9 | Stability : experimental 10 | Portability : portable 11 | 12 | The 'get' quasiquoter. 13 | -} 14 | module Data.Aeson.Schema.TH.Get where 15 | 16 | import Control.Monad ((>=>)) 17 | import Data.List (intercalate) 18 | import Data.List.NonEmpty (NonEmpty) 19 | import qualified Data.List.NonEmpty as NonEmpty 20 | import qualified Data.Maybe as Maybe 21 | import Data.Proxy (Proxy (..)) 22 | import GHC.Stack (HasCallStack) 23 | import Language.Haskell.TH 24 | import Language.Haskell.TH.Quote (QuasiQuoter (..)) 25 | 26 | import Data.Aeson.Schema.Internal (getKey) 27 | import Data.Aeson.Schema.TH.Parse ( 28 | GetterExp (..), 29 | GetterOperation (..), 30 | GetterOps, 31 | parseGetterExp, 32 | ) 33 | import Data.Aeson.Schema.Utils.Sum (fromSumType) 34 | 35 | -- | Defines a QuasiQuoter for extracting JSON data. 36 | -- 37 | -- Example: 38 | -- 39 | -- > let Just result = decode ... :: Maybe (Object MySchema) 40 | -- > 41 | -- > [get| result.foo.a |] :: Int 42 | -- > [get| result.foo.nodes |] :: [Object (..)] 43 | -- > [get| result.foo.nodes[] |] :: [Object (..)] 44 | -- > [get| result.foo.nodes[].b |] :: [Maybe Bool] 45 | -- > [get| result.foo.nodes[].b! |] :: [Bool] -- runtime error if any values are Nothing 46 | -- > [get| result.foo.c |] :: Text 47 | -- > [get| result.foo.(a,c) |] :: (Int, Text) 48 | -- > [get| result.foo.[c,d] |] :: [Text] 49 | -- > 50 | -- > let nodes = [get| result.foo.nodes |] 51 | -- > flip map nodes $ \node -> fromMaybe ([get| node.num |] == 0) [get| node.b |] 52 | -- > map [get| .num |] nodes 53 | -- 54 | -- Syntax: 55 | -- 56 | -- * @x.y@ is only valid if @x@ is an 'Data.Aeson.Schema.Object'. Returns the value of the key @y@. 57 | -- 58 | -- * @.y@ returns a function that takes in an 'Data.Aeson.Schema.Object' and returns the value of 59 | -- the key @y@. 60 | -- 61 | -- * @x.[y,z.a]@ is only valid if @x@ is an 'Data.Aeson.Schema.Object', and if @y@ and @z.a@ have 62 | -- the same type. Returns the value of the operations @y@ and @z.a@ as a list. 63 | -- MUST be the last operation. 64 | -- 65 | -- * @x.(y,z.a)@ is only valid if @x@ is an 'Data.Aeson.Schema.Object'. Returns the value of the 66 | -- operations @y@ and @z.a@ as a tuple. 67 | -- MUST be the last operation. 68 | -- 69 | -- * @x!@ is only valid if @x@ is a 'Maybe'. Unwraps the value of @x@ from a 'Just' value and 70 | -- errors (at runtime!) if @x@ is 'Nothing'. 71 | -- 72 | -- * @x[]@ is only valid if @x@ is a list. Applies the remaining rules as an 'fmap' over the 73 | -- values in the list, e.g. 74 | -- 75 | -- * @x[]@ without anything after is equivalent to @x@ 76 | -- * @x[].y@ gets the key @y@ in all the Objects in @x@ 77 | -- * @x[]!@ unwraps all 'Just' values in @x@ (and errors if any 'Nothing' values exist in @x@) 78 | -- 79 | -- * @x?@ follows the same rules as @x[]@ except it's only valid if @x@ is a 'Maybe'. 80 | -- 81 | -- * @x\@#@ is only valid if @x@ is a 'SumType'. If the sum type contains a value at the given 82 | -- branch (e.g. @x\@0@ for @Here v@), return 'Just' that value, otherwise 'Nothing'. (added in 83 | -- v1.1.0) 84 | -- 85 | -- e.g. with the schema @{ a: Int | Bool }@, calling @[get| .a\@0 |]@ will return @Maybe Int@ if 86 | -- the sum type contains an 'Int'. 87 | get :: QuasiQuoter 88 | get = 89 | QuasiQuoter 90 | { quoteExp = parseGetterExp >=> generateGetterExp 91 | , quoteDec = error "Cannot use `get` for Dec" 92 | , quoteType = error "Cannot use `get` for Type" 93 | , quotePat = error "Cannot use `get` for Pat" 94 | } 95 | 96 | generateGetterExp :: GetterExp -> ExpQ 97 | generateGetterExp GetterExp{..} = applyStart $ resolveGetterOpExps $ mkGetterOpExps [] getterOps 98 | where 99 | applyStart expr = maybe expr (appE expr . varE . mkName) start 100 | 101 | startDisplay = case start of 102 | Nothing -> "" 103 | Just s -> if '.' `elem` s then "(" ++ s ++ ")" else s 104 | 105 | mkGetterOpExps :: [GetterOperation] -> GetterOps -> GetterOpExps 106 | mkGetterOpExps historyPrefix = mapWithHistory (mkGetterOpExp . (historyPrefix ++)) 107 | 108 | mkGetterOpExp :: [GetterOperation] -> GetterOperation -> GetterOpExp 109 | mkGetterOpExp history = \case 110 | GetterKey key -> 111 | let keyType = litT $ strTyLit key 112 | in ApplyOp [|getKey (Proxy :: Proxy $keyType)|] 113 | GetterBang -> 114 | let expr = startDisplay ++ showGetterOps history 115 | in ApplyOp [|fromJust expr|] 116 | GetterMapMaybe -> 117 | ApplyOpInfix [|(<$?>)|] 118 | GetterMapList -> 119 | ApplyOpInfix [|(<$:>)|] 120 | GetterBranch branch -> 121 | let branchType = litT $ numTyLit $ fromIntegral branch 122 | in ApplyOp [|fromSumType (Proxy :: Proxy $branchType)|] 123 | GetterList elemOps -> 124 | ApplyOpsIntoList $ mkGetterOpExps history <$> elemOps 125 | GetterTuple elemOps -> 126 | ApplyOpsIntoTuple $ mkGetterOpExps history <$> elemOps 127 | 128 | {- Runtime helpers -} 129 | 130 | -- | fromJust with helpful error message 131 | fromJust :: (HasCallStack) => String -> Maybe a -> a 132 | fromJust expr = Maybe.fromMaybe (error errMsg) 133 | where 134 | errMsg = "Called 'fromJust' on null expression" ++ if null expr then "" else ": " ++ expr 135 | 136 | -- | fmap specialized to Maybe 137 | (<$?>) :: (a -> b) -> Maybe a -> Maybe b 138 | (<$?>) = (<$>) 139 | 140 | -- | fmap specialized to [a] 141 | (<$:>) :: (a -> b) -> [a] -> [b] 142 | (<$:>) = (<$>) 143 | 144 | {- Code generation helpers -} 145 | 146 | data GetterOpExp 147 | = -- | next . f 148 | ApplyOp ExpQ 149 | | -- | (next `f`) 150 | ApplyOpInfix ExpQ 151 | | -- | \v -> [f1 v, f2 v, ...] 152 | ApplyOpsIntoList (NonEmpty GetterOpExps) 153 | | -- | \v -> (f1 v, f2 v, ...) 154 | ApplyOpsIntoTuple (NonEmpty GetterOpExps) 155 | 156 | type GetterOpExps = NonEmpty GetterOpExp 157 | 158 | resolveGetterOpExps :: GetterOpExps -> ExpQ 159 | resolveGetterOpExps (op NonEmpty.:| ops) = 160 | case op of 161 | ApplyOp f -> [|$next . $f|] 162 | ApplyOpInfix f -> infixE (Just next) f Nothing 163 | -- suffixes; ops should be empty 164 | ApplyOpsIntoList elemOps -> resolveEach listE elemOps 165 | ApplyOpsIntoTuple elemOps -> resolveEach tupE elemOps 166 | where 167 | next = maybe [|id|] resolveGetterOpExps $ NonEmpty.nonEmpty ops 168 | 169 | resolveEach fromElems elemOps = do 170 | val <- newName "v" 171 | let applyVal expr = appE expr (varE val) 172 | lamE [varP val] $ fromElems $ map (applyVal . resolveGetterOpExps) $ NonEmpty.toList elemOps 173 | 174 | showGetterOps :: (Foldable t) => t GetterOperation -> String 175 | showGetterOps = concatMap showGetterOp 176 | where 177 | showGetterOp = \case 178 | GetterKey key -> '.' : key 179 | GetterBang -> "!" 180 | GetterMapList -> "[]" 181 | GetterMapMaybe -> "?" 182 | GetterBranch x -> '@' : show x 183 | GetterList elemOps -> ".[" ++ showGetterOpsList elemOps ++ "]" 184 | GetterTuple elemOps -> ".(" ++ showGetterOpsList elemOps ++ ")" 185 | 186 | showGetterOpsList = intercalate "," . NonEmpty.toList . fmap showGetterOps 187 | 188 | {- Utilities -} 189 | 190 | -- | Run the given function for each element in the list, providing all elements seen so far. 191 | -- 192 | -- e.g. for a list [1,2,3], this will return the result of 193 | -- 194 | -- [f [] 1, f [1] 2, f [1,2] 3] 195 | mapWithHistory :: ([a] -> a -> b) -> NonEmpty a -> NonEmpty b 196 | mapWithHistory f xs = NonEmpty.zipWith f (NonEmpty.inits xs) xs 197 | -------------------------------------------------------------------------------- /src/Data/Aeson/Schema/TH/Parse.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | 4 | {-| 5 | Module : Data.Aeson.Schema.TH.Parse 6 | Maintainer : Brandon Chinn 7 | Stability : experimental 8 | Portability : portable 9 | 10 | Definitions for parsing input text in QuasiQuoters. 11 | -} 12 | module Data.Aeson.Schema.TH.Parse where 13 | 14 | import Control.Monad (MonadPlus, void) 15 | 16 | import Data.Functor (($>)) 17 | import Data.List (intercalate) 18 | import Data.List.NonEmpty (NonEmpty) 19 | import qualified Data.List.NonEmpty as NonEmpty 20 | import Data.Void (Void) 21 | import Text.Megaparsec hiding (sepBy1, sepEndBy1, some) 22 | import qualified Text.Megaparsec as Megaparsec 23 | import Text.Megaparsec.Char 24 | import qualified Text.Megaparsec.Char.Lexer as L 25 | 26 | type Parser = Parsec Void String 27 | 28 | runParserFail :: (MonadFail m) => Parser a -> String -> m a 29 | runParserFail parser s = either (fail . errorBundlePretty) return $ runParser parser s s 30 | 31 | {- SchemaDef -} 32 | 33 | data SchemaDef 34 | = SchemaDefType String 35 | | SchemaDefMaybe SchemaDef 36 | | SchemaDefTry SchemaDef 37 | | SchemaDefList SchemaDef 38 | | SchemaDefInclude String 39 | | SchemaDefObj (NonEmpty SchemaDefObjItem) 40 | | SchemaDefUnion (NonEmpty SchemaDef) 41 | deriving (Show) 42 | 43 | data SchemaDefObjItem 44 | = SchemaDefObjPair (SchemaDefObjKey, SchemaDef) 45 | | SchemaDefObjExtend String 46 | deriving (Show) 47 | 48 | data SchemaDefObjKey 49 | = SchemaDefObjKeyNormal String 50 | | SchemaDefObjKeyPhantom String 51 | deriving (Show) 52 | 53 | parseSchemaDef :: (MonadFail m) => String -> m SchemaDef 54 | parseSchemaDef = runParserFail $ do 55 | space 56 | def <- parseSchemaDefWithUnions 57 | space 58 | void eof 59 | return def 60 | where 61 | parseSchemaDefWithUnions = 62 | let parseSchemaUnion schemaDefs 63 | | length schemaDefs == 1 = NonEmpty.head schemaDefs 64 | | otherwise = SchemaDefUnion schemaDefs 65 | in fmap parseSchemaUnion $ parseSchemaDefWithoutUnions `sepBy1` lexeme "|" 66 | 67 | parseSchemaDefWithoutUnions = 68 | choice 69 | [ between (lexeme "{") (lexeme "}") $ SchemaDefObj <$> parseSchemaDefObjItems 70 | , between (lexeme "(") (lexeme ")") parseSchemaDefWithUnions 71 | , lexeme "Maybe" *> (SchemaDefMaybe <$> parseSchemaDefWithoutUnions) 72 | , lexeme "Try" *> (SchemaDefTry <$> parseSchemaDefWithoutUnions) 73 | , lexeme "List" *> (SchemaDefList <$> parseSchemaDefWithoutUnions) 74 | , SchemaDefType <$> identifier upperChar 75 | , SchemaDefInclude <$> parseSchemaReference 76 | ] 77 | <* space -- allow any trailing spaces 78 | parseSchemaDefObjItems = parseSchemaDefObjItem `sepEndBy1` lexeme "," 79 | parseSchemaDefObjItem = 80 | choice 81 | [ SchemaDefObjPair <$> parseSchemaDefPair 82 | , SchemaDefObjExtend <$> parseSchemaReference 83 | ] 84 | <* space -- allow any trailing spaces 85 | parseSchemaDefPair = do 86 | key <- 87 | choice 88 | [ SchemaDefObjKeyNormal <$> jsonKey 89 | , SchemaDefObjKeyPhantom <$> between (lexeme' "[") (lexeme' "]") jsonKey' 90 | ] 91 | lexeme ":" 92 | value <- parseSchemaDefWithUnions 93 | return (key, value) 94 | parseSchemaReference = char '#' *> namespacedIdentifier upperChar 95 | 96 | {- GetterExp -} 97 | 98 | data GetterExp = GetterExp 99 | { start :: Maybe String 100 | , getterOps :: GetterOps 101 | } 102 | deriving (Show) 103 | 104 | parseGetterExp :: (MonadFail m) => String -> m GetterExp 105 | parseGetterExp = runParserFail $ do 106 | space 107 | start <- optional $ namespacedIdentifier lowerChar 108 | getterOps <- parseGetterOps 109 | space 110 | void eof 111 | return GetterExp{..} 112 | 113 | {- UnwrapSchema -} 114 | 115 | data UnwrapSchema = UnwrapSchema 116 | { startSchema :: String 117 | , getterOps :: GetterOps 118 | } 119 | deriving (Show) 120 | 121 | parseUnwrapSchema :: (MonadFail m) => String -> m UnwrapSchema 122 | parseUnwrapSchema = runParserFail $ do 123 | space 124 | startSchema <- namespacedIdentifier upperChar 125 | getterOps <- parseGetterOps 126 | space 127 | void eof 128 | return UnwrapSchema{..} 129 | 130 | {- GetterOps -} 131 | 132 | -- | A non-empty list of GetterOperations. 133 | -- 134 | -- Invariant: Any GetterList/GetterTuple operations MUST be last. 135 | type GetterOps = NonEmpty GetterOperation 136 | 137 | parseGetterOps :: Parser GetterOps 138 | parseGetterOps = someWith [parseGetterOp, parseGetterOpSuffix] 139 | 140 | data GetterOperation 141 | = GetterKey String 142 | | GetterBang 143 | | GetterMapList 144 | | GetterMapMaybe 145 | | GetterBranch Int 146 | | -- suffixes 147 | GetterList (NonEmpty GetterOps) 148 | | GetterTuple (NonEmpty GetterOps) 149 | deriving (Show) 150 | 151 | parseGetterOp :: Parser GetterOperation 152 | parseGetterOp = 153 | choice 154 | [ lexeme "!" $> GetterBang 155 | , lexeme "[]" $> GetterMapList 156 | , lexeme "?" $> GetterMapMaybe 157 | , lexeme "@" *> (GetterBranch . read . NonEmpty.toList <$> some digitChar) 158 | , optional (lexeme ".") *> (GetterKey <$> jsonKey) 159 | ] 160 | 161 | parseGetterOpSuffix :: Parser GetterOperation 162 | parseGetterOpSuffix = 163 | optional (lexeme ".") 164 | *> choice 165 | [ fmap GetterList $ between (lexeme "[") (lexeme "]") $ parseGetterOps `sepBy1` lexeme "," 166 | , fmap GetterTuple $ between (lexeme "(") (lexeme ")") $ parseGetterOps `sepBy1` lexeme "," 167 | ] 168 | 169 | {- Parser primitives -} 170 | 171 | -- | A Haskell identifier, with the given first character. 172 | identifier :: Parser Char -> Parser String 173 | identifier start = (:) <$> start <*> many (alphaNumChar <|> char '\'') 174 | 175 | lexeme :: String -> Parser () 176 | lexeme = lexemeUsingLineComment $ L.skipLineComment "//" 177 | 178 | -- | Same as 'lexeme', but without parsing comments. 179 | lexeme' :: String -> Parser () 180 | lexeme' = lexemeUsingLineComment empty 181 | 182 | lexemeUsingLineComment :: Parser () -> String -> Parser () 183 | lexemeUsingLineComment lineComment = void . L.lexeme (L.space space1 lineComment empty) . string 184 | 185 | -- | Parses `identifier`, but if parentheses are provided, parses a namespaced identifier. 186 | namespacedIdentifier :: Parser Char -> Parser String 187 | namespacedIdentifier start = choice [lexeme "(" *> namespaced <* lexeme ")", ident] 188 | where 189 | ident = identifier start 190 | namespaced = intercalate "." <$> manyAndEnd (identifier upperChar <* lexeme ".") ident 191 | manyAndEnd p end = 192 | choice 193 | [ try $ p >>= \x -> (x :) <$> manyAndEnd p end 194 | , (: []) <$> end 195 | ] 196 | 197 | -- | An optionally quoted JSON key. 198 | jsonKey :: Parser String 199 | jsonKey = choice [char '"' *> jsonKey' <* char '"', jsonKey'] 200 | 201 | -- | A string that can be used as a JSON key. 202 | jsonKey' :: Parser String 203 | jsonKey' = 204 | fmap NonEmpty.toList $ 205 | some $ 206 | choice 207 | [ try $ char '\\' *> anySingle 208 | , noneOf $ [' ', '\\', '"'] ++ schemaChars ++ getChars 209 | ] 210 | where 211 | -- characters that cause ambiguity when parsing 'get' expressions 212 | getChars = "!?[](),.@" 213 | -- characters that should not indicate the start of a key when parsing 'schema' definitions 214 | schemaChars = ":{}#" 215 | 216 | {- Parsing utilities -} 217 | 218 | -- | Same as 'Megaparsec.some', except returns a 'NonEmpty' 219 | some :: (MonadPlus f) => f a -> f (NonEmpty a) 220 | some p = NonEmpty.fromList <$> Megaparsec.some p 221 | 222 | -- | Same as 'Megaparsec.sepBy1', except returns a 'NonEmpty' 223 | sepBy1 :: (MonadPlus f) => f a -> f sep -> f (NonEmpty a) 224 | sepBy1 p sep = NonEmpty.fromList <$> Megaparsec.sepBy1 p sep 225 | 226 | -- | Same as 'Megaparsec.sepEndBy1', except returns a 'NonEmpty' 227 | sepEndBy1 :: (MonadPlus f) => f a -> f sep -> f (NonEmpty a) 228 | sepEndBy1 p sep = NonEmpty.fromList <$> Megaparsec.sepEndBy1 p sep 229 | 230 | -- | Return a non-empty list containing elements from the given parsers in order. 231 | -- 232 | -- i.e. for `someWith [p1, p2, p3]`, elements parsed with `p1` will come before 233 | -- elements parsed with `p2` and `p3`, etc. 234 | -- 235 | -- An individual parser in the list may not parse anything, but at least one parser must return 236 | -- something. 237 | someWith :: (MonadParsec e s m) => [m a] -> m (NonEmpty a) 238 | someWith ps = do 239 | as <- concatMapM (many . try) ps 240 | maybe empty return $ NonEmpty.nonEmpty as 241 | where 242 | concatMapM f = fmap concat . mapM f 243 | -------------------------------------------------------------------------------- /test/Tests/SchemaQQ.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | 5 | module Tests.SchemaQQ where 6 | 7 | import qualified Data.Text as Text 8 | import Test.Tasty 9 | import Test.Tasty.HUnit 10 | import Text.RawString.QQ (r) 11 | 12 | import TestUtils (testParseError) 13 | import Tests.SchemaQQ.TH 14 | 15 | test :: TestTree 16 | test = 17 | testGroup 18 | "`schema` quasiquoter" 19 | [ testValidSchemas 20 | , testInvalidSchemas 21 | , testKeys 22 | ] 23 | 24 | testValidSchemas :: TestTree 25 | testValidSchemas = 26 | testGroup 27 | "Valid schemas" 28 | [ testCase "Object with Bool field" $ 29 | assertMatches 30 | [schemaRep| { a: Bool } |] 31 | [r| SchemaObject { "a": Bool } |] 32 | , testCase "Object with Int field" $ 33 | assertMatches 34 | [schemaRep| { a: Int } |] 35 | [r| SchemaObject { "a": Int } |] 36 | , testCase "Object with Double field" $ 37 | assertMatches 38 | [schemaRep| { foo123: Double } |] 39 | [r| SchemaObject { "foo123": Double } |] 40 | , testCase "Object with Text field" $ 41 | assertMatches 42 | [schemaRep| { some_text: Text } |] 43 | [r| SchemaObject { "some_text": Text } |] 44 | , testCase "Object with a field with a custom type" $ 45 | assertMatches 46 | [schemaRep| { status: Status } |] 47 | [r| SchemaObject { "status": Status } |] 48 | , testCase "Object with a field with a Maybe type" $ 49 | assertMatches 50 | [schemaRep| { a: Maybe Bool } |] 51 | [r| SchemaObject { "a": Maybe Bool } |] 52 | , testCase "Object with a field with a Try type" $ 53 | assertMatches 54 | [schemaRep| { a: Try Bool } |] 55 | [r| SchemaObject { "a": Try Bool } |] 56 | , testCase "Object with a nested object" $ 57 | assertMatches 58 | [schemaRep| { a: { b: Int } } |] 59 | [r| SchemaObject { "a": { "b": Int } } |] 60 | , testCase "Object with a nullable nested object" $ 61 | assertMatches 62 | [schemaRep| { a: Maybe { b: Int } } |] 63 | [r| SchemaObject { "a": Maybe { "b": Int } } |] 64 | , testCase "Object with a list of nested objects" $ 65 | assertMatches 66 | [schemaRep| { a: List { b: Int } } |] 67 | [r| SchemaObject { "a": List { "b": Int } } |] 68 | , testCase "Object with an imported schema" $ 69 | assertMatches 70 | [schemaRep| { user: #UserSchema } |] 71 | [r| SchemaObject { "user": { "name": Text } } |] 72 | , testCase "Object with a qualified imported schema" $ 73 | assertMatches 74 | [schemaRep| { user: #(Tests.SchemaQQ.TH.UserSchema) } |] 75 | [r| SchemaObject { "user": { "name": Text } } |] 76 | , testCase "Object with an imported schema that uses a non-imported type" $ 77 | assertMatches 78 | [schemaRep| { a: #SchemaWithHiddenImport } |] 79 | [r| SchemaObject { "a": { "a": CBool } } |] 80 | , testCase "Object with an imported schema that itself imports a schema" $ 81 | assertMatches 82 | [schemaRep| { a: #WithUser } |] 83 | [r| SchemaObject { "a": { "user": { "name": Text } } } |] 84 | , testCase "Object with an extended schema" $ 85 | assertMatches 86 | [schemaRep| { a: Int, #ExtraSchema } |] 87 | [r| SchemaObject { "a": Int, "extra": Text } |] 88 | , testCase "Object with a qualified extended schema" $ 89 | assertMatches 90 | [schemaRep| { a: Int, #(Tests.SchemaQQ.TH.ExtraSchema) } |] 91 | [r| SchemaObject { "a": Int, "extra": Text } |] 92 | , testCase "Object with an extended schema that uses a non-imported type" $ 93 | assertMatches 94 | [schemaRep| { #SchemaWithHiddenImport } |] 95 | [r| SchemaObject { "a": CBool } |] 96 | , testCase "Object with an extended schema with a shadowed key" $ 97 | assertMatches 98 | [schemaRep| { extra: Bool, #ExtraSchema } |] 99 | [r| SchemaObject { "extra": Bool } |] 100 | , testCase "Object with a qualified extended schema with a shadowed key" $ 101 | assertMatches 102 | [schemaRep| { extra: Bool, #(Tests.SchemaQQ.TH.ExtraSchema) } |] 103 | [r| SchemaObject { "extra": Bool } |] 104 | , testCase "Object with a union field" $ 105 | assertMatches 106 | [schemaRep| { a: List Int | Text } |] 107 | [r| SchemaObject { "a": ( List Int | Text ) } |] 108 | , testCase "Object with a union field with a group" $ 109 | assertMatches 110 | [schemaRep| { a: List (Int | Text) } |] 111 | [r| SchemaObject { "a": List ( Int | Text ) } |] 112 | , testCase "Object with a phantom key for an object" $ 113 | assertMatches 114 | [schemaRep| { [a]: { b: Int } } |] 115 | [r| SchemaObject { [a]: { "b": Int } } |] 116 | , testCase "Object with a phantom key for a Maybe" $ 117 | assertMatches 118 | [schemaRep| { [a]: Maybe { b: Int } } |] 119 | [r| SchemaObject { [a]: Maybe { "b": Int } } |] 120 | , testCase "Object with a phantom key for a Try" $ 121 | assertMatches 122 | [schemaRep| { [a]: Try { b: Int } } |] 123 | [r| SchemaObject { [a]: Try { "b": Int } } |] 124 | , testCase "Object with a phantom key for a non-object Try" $ 125 | assertMatches 126 | [schemaRep| { [a]: Try Bool } |] 127 | [r| SchemaObject { [a]: Try Bool } |] 128 | , testCase "Object with a phantom key for a union of valid schemas" $ 129 | assertMatches 130 | [schemaRep| { [a]: { b: Int } | Int } |] 131 | [r| SchemaObject { [a]: ( { "b": Int } | Int ) } |] 132 | ] 133 | 134 | testInvalidSchemas :: TestTree 135 | testInvalidSchemas = 136 | testGroup 137 | "Invalid schemas" 138 | [ testCase "Object with a duplicate key" $ 139 | [schemaErr| { a: Int, a: Bool } |] @?= "Key 'a' specified multiple times" 140 | , testCase "Object with a duplicate phantom key" $ 141 | [schemaErr| { a: Int, [a]: { b: Bool } } |] @?= "Key 'a' specified multiple times" 142 | , testCase "Object with a duplicate key from extending" $ 143 | [schemaErr| { #ExtraSchema, #ExtraSchema2 } |] @?= "Key 'extra' declared in multiple imported schemas" 144 | , testCase "Quasiquoter defining a non-object" $ 145 | [schemaErr| List { a: Int } |] @?= "`schema` definition must be an object" 146 | , testCase "Object with a field with an unknown type" $ 147 | [schemaErr| { a: HelloWorld } |] @?= "Unknown type: HelloWorld" 148 | , testCase "Object extending a non-schema" $ 149 | [schemaErr| { #Int } |] @?= "'GHC.Types.Int' is not a Schema" 150 | , testCase "Object importing an unknown schema" $ 151 | [schemaErr| { foo: #FooSchema } |] @?= "Unknown schema: FooSchema" 152 | , testCase "Object extending an unknown schema" $ 153 | [schemaErr| { #FooSchema } |] @?= "Unknown schema: FooSchema" 154 | , testCase "Object with a phantom key for a scalar" $ 155 | [schemaErr| { [a]: Int } |] @?= "Invalid schema for 'a': SchemaScalar Int" 156 | , testCase "Object with a phantom key for a list" $ 157 | [schemaErr| { [a]: List Int } |] @?= "Invalid schema for 'a': SchemaList Int" 158 | , testCase "Object with a phantom key for a non-object Maybe" $ 159 | [schemaErr| { [a]: Maybe Int } |] @?= "Invalid schema for 'a': SchemaMaybe Int" 160 | , testCase "Object with a phantom key for an invalid union" $ 161 | [schemaErr| { [a]: Bool | Int } |] @?= "Invalid schema for 'a': SchemaUnion ( Bool | Int )" 162 | ] 163 | 164 | testKeys :: TestTree 165 | testKeys = 166 | testGroup 167 | "Keys in schemas" 168 | [ testCase "Quoted key same as plain key" $ 169 | [schemaRep| { a: Int } |] @?= [schemaRep| { "a": Int } |] 170 | , testParseError 171 | "Key with invalid character" 172 | "schemaqq_key_with_invalid_character.golden" 173 | [schemaErr| { "a:b": Int } |] 174 | , testCase "Key with escaped invalid character" $ 175 | assertMatches 176 | [schemaRep| { "a\:b": Int } |] 177 | [r| SchemaObject { "a:b": Int } |] 178 | , testParseError 179 | "Key with trailing escape" 180 | "schemaqq_key_with_trailing_escape.golden" 181 | [schemaErr| { "a\": Int } |] 182 | , testCase "Quoted key that starts with '//'" $ 183 | assertMatches 184 | [schemaRep| { "//a": { b: Int } } |] 185 | [r| SchemaObject { "//a": { "b": Int } } |] 186 | , testCase "Phantom key that starts with '//'" $ 187 | assertMatches 188 | [schemaRep| { [//a]: { b: Int } } |] 189 | [r| SchemaObject { [//a]: { "b": Int } } |] 190 | ] 191 | 192 | {- Helpers -} 193 | 194 | assertMatches :: String -> String -> Assertion 195 | assertMatches a b = strip a @?= strip b 196 | where 197 | strip = Text.unpack . Text.strip . Text.pack 198 | -------------------------------------------------------------------------------- /src/Data/Aeson/Schema/TH/Schema.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE MultiWayIf #-} 4 | {-# LANGUAGE PolyKinds #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TupleSections #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | 9 | {-| 10 | Module : Data.Aeson.Schema.TH.Schema 11 | Maintainer : Brandon Chinn 12 | Stability : experimental 13 | Portability : portable 14 | 15 | The 'schema' quasiquoter. 16 | -} 17 | module Data.Aeson.Schema.TH.Schema (schema) where 18 | 19 | import Control.Monad (unless, (>=>)) 20 | import Data.Function (on) 21 | import qualified Data.HashMap.Strict as HashMap 22 | import Data.Hashable (Hashable) 23 | import Data.List (nubBy) 24 | import Data.List.NonEmpty (NonEmpty) 25 | import qualified Data.List.NonEmpty as NonEmpty 26 | import Language.Haskell.TH 27 | import Language.Haskell.TH.Quote (QuasiQuoter (..)) 28 | 29 | import Data.Aeson.Schema.Key (SchemaKey' (..), SchemaKeyV, fromSchemaKeyV) 30 | import Data.Aeson.Schema.TH.Parse ( 31 | SchemaDef (..), 32 | SchemaDefObjItem (..), 33 | SchemaDefObjKey (..), 34 | parseSchemaDef, 35 | ) 36 | import Data.Aeson.Schema.TH.Utils (reifySchema, schemaVToTypeQ) 37 | import Data.Aeson.Schema.Type ( 38 | Schema' (..), 39 | SchemaObjectMapV, 40 | SchemaType' (..), 41 | SchemaTypeV, 42 | fromSchemaV, 43 | showSchemaTypeV, 44 | ) 45 | import Data.Aeson.Schema.Utils.Invariant (unreachable) 46 | import Data.Aeson.Schema.Utils.NameLike (NameLike (..)) 47 | 48 | -- | Defines a QuasiQuoter for writing schemas. 49 | -- 50 | -- Example: 51 | -- 52 | -- > import Data.Aeson.Schema (schema) 53 | -- > 54 | -- > type MySchema = [schema| 55 | -- > { 56 | -- > foo: { 57 | -- > a: Int, 58 | -- > // you can add comments like this 59 | -- > nodes: List { 60 | -- > b: Maybe Bool, 61 | -- > }, 62 | -- > c: Text, 63 | -- > d: Text, 64 | -- > e: MyType, 65 | -- > f: Maybe List { 66 | -- > name: Text, 67 | -- > }, 68 | -- > }, 69 | -- > } 70 | -- > |] 71 | -- 72 | -- Syntax: 73 | -- 74 | -- * @{ key: \, ... }@ corresponds to a JSON 'Data.Aeson.Schema.Object' with the given key 75 | -- mapping to the given schema. 76 | -- 77 | -- * @Bool@, @Int@, @Double@, and @Text@ correspond to the usual Haskell values. 78 | -- 79 | -- * @Maybe \@ and @List \@ correspond to @Maybe@ and @[]@, containing values 80 | -- specified by the provided schema (no parentheses needed). 81 | -- 82 | -- * @Try \@ corresponds to @Maybe@, where the value will be @Just@ if the given schema 83 | -- successfully parses the value, or @Nothing@ otherwise. Different from @Maybe \@, 84 | -- where parsing @{ "foo": true }@ with @{ foo: Try Int }@ returns @Nothing@, whereas it would 85 | -- be a parse error with @{ foo: Maybe Int }@ (added in v1.2.0) 86 | -- 87 | -- * Any other uppercase identifier corresponds to the respective type in scope -- requires a 88 | -- FromJSON instance. 89 | -- 90 | -- Advanced syntax: 91 | -- 92 | -- * @\ | \@ corresponds to a JSON value that matches one of the given schemas. 93 | -- When extracted from an 'Data.Aeson.Schema.Object', it deserializes into a 94 | -- 'Data.Aeson.Schema.Utils.Sum.JSONSum' object. (added in v1.1.0) 95 | -- 96 | -- * @{ [key]: \ }@ uses the current object to resolve the keys in the given schema. Only 97 | -- object schemas are allowed here. (added in v1.2.0) 98 | -- 99 | -- * @{ key: #Other, ... }@ maps the given key to the @Other@ schema. The @Other@ schema needs to 100 | -- be defined in another module. 101 | -- 102 | -- * @{ #Other, ... }@ extends this schema with the @Other@ schema. The @Other@ schema needs to 103 | -- be defined in another module. 104 | schema :: QuasiQuoter 105 | schema = 106 | QuasiQuoter 107 | { quoteExp = error "Cannot use `schema` for Exp" 108 | , quoteDec = error "Cannot use `schema` for Dec" 109 | , quoteType = 110 | parseSchemaDef >=> \case 111 | SchemaDefObj items -> generateSchemaObject items 112 | _ -> fail "`schema` definition must be an object" 113 | , quotePat = error "Cannot use `schema` for Pat" 114 | } 115 | where 116 | generateSchemaObject items = schemaVToTypeQ . Schema =<< generateSchemaObjectV items 117 | 118 | data KeySource = Provided | Imported 119 | deriving (Show, Eq) 120 | 121 | generateSchemaObjectV :: NonEmpty SchemaDefObjItem -> Q SchemaObjectMapV 122 | generateSchemaObjectV schemaDefObjItems = do 123 | schemaObjectMapsWithSource <- mapM getSchemaObjectMap schemaDefObjItems 124 | 125 | let schemaObjectMaps :: LookupMap SchemaKeyV (KeySource, SchemaTypeV) 126 | schemaObjectMaps = concatMap (uncurry distribute) schemaObjectMapsWithSource 127 | 128 | either fail return $ resolveKeys schemaObjectMaps 129 | 130 | -- | Get the SchemaObjectMapV for the given SchemaDefObjItem, along with where the SchemaObjectMapV 131 | -- came from. 132 | getSchemaObjectMap :: SchemaDefObjItem -> Q (SchemaObjectMapV, KeySource) 133 | getSchemaObjectMap = \case 134 | SchemaDefObjPair (schemaDefKey, schemaDefType) -> do 135 | let schemaKey = fromSchemaDefKey schemaDefKey 136 | schemaType <- fromSchemaDefType schemaDefType 137 | 138 | case schemaKey of 139 | PhantomKey _ -> 140 | unless (isValidPhantomSchema schemaType) $ 141 | fail $ 142 | "Invalid schema for '" ++ fromSchemaKeyV schemaKey ++ "': " ++ showSchemaTypeV schemaType 143 | _ -> return () 144 | 145 | return ([(schemaKey, schemaType)], Provided) 146 | SchemaDefObjExtend other -> do 147 | schemaV <- reifySchema other 148 | return (fromSchemaV schemaV, Imported) 149 | where 150 | -- should return true if it's at all possible to get a valid parse 151 | isValidPhantomSchema = \case 152 | SchemaMaybe inner -> isValidPhantomSchema inner 153 | SchemaTry _ -> True -- even if inner is a non-object schema, it'll still parse to be Nothing 154 | SchemaUnion schemas -> any isValidPhantomSchema schemas 155 | SchemaObject _ -> True 156 | SchemaInclude _ -> True 157 | _ -> False 158 | 159 | -- | Resolve the given keys with the following rules: 160 | -- 161 | -- 1. Any explicitly provided keys shadow/overwrite imported keys 162 | -- 2. Fail if duplicate keys are both explicitly provided 163 | -- 3. Fail if duplicate keys are both imported 164 | resolveKeys :: forall a. (Show a) => LookupMap SchemaKeyV (KeySource, a) -> Either String (LookupMap SchemaKeyV a) 165 | resolveKeys = mapM (uncurry resolveKey) . groupByKeyWith fromSchemaKeyV 166 | where 167 | resolveKey :: SchemaKeyV -> [(KeySource, a)] -> Either String (SchemaKeyV, a) 168 | resolveKey key sourcesAndVals = 169 | let provided = lookupAll Provided sourcesAndVals 170 | imported = lookupAll Imported sourcesAndVals 171 | in if 172 | | length provided > 1 -> Left $ "Key '" ++ fromSchemaKeyV key ++ "' specified multiple times" 173 | | [val] <- provided -> Right (key, val) 174 | | length imported > 1 -> Left $ "Key '" ++ fromSchemaKeyV key ++ "' declared in multiple imported schemas" 175 | | [val] <- imported -> Right (key, val) 176 | | otherwise -> unreachable $ "resolveKey received: " ++ show (key, sourcesAndVals) 177 | 178 | {- SchemaDef conversions -} 179 | 180 | fromSchemaDefKey :: SchemaDefObjKey -> SchemaKeyV 181 | fromSchemaDefKey = \case 182 | SchemaDefObjKeyNormal key -> NormalKey key 183 | SchemaDefObjKeyPhantom key -> PhantomKey key 184 | 185 | fromSchemaDefType :: SchemaDef -> Q SchemaTypeV 186 | fromSchemaDefType = \case 187 | SchemaDefType name -> return $ SchemaScalar $ NameRef name 188 | SchemaDefMaybe inner -> SchemaMaybe <$> fromSchemaDefType inner 189 | SchemaDefTry inner -> SchemaTry <$> fromSchemaDefType inner 190 | SchemaDefList inner -> SchemaList <$> fromSchemaDefType inner 191 | SchemaDefInclude other -> return $ SchemaInclude $ Left $ NameRef other 192 | SchemaDefUnion schemas -> SchemaUnion . NonEmpty.toList <$> mapM fromSchemaDefType schemas 193 | SchemaDefObj items -> SchemaObject <$> generateSchemaObjectV items 194 | 195 | {- LookupMap utilities -} 196 | 197 | type LookupMap k v = [(k, v)] 198 | 199 | -- | Distribute the given element across the values in the map. 200 | distribute :: LookupMap k v -> a -> LookupMap k (a, v) 201 | distribute lookupMap a = map (fmap (a,)) lookupMap 202 | 203 | -- | Find all values with the same key (according to the given function) and group them. 204 | -- 205 | -- Invariants: 206 | -- * [v] has length > 0 207 | -- * If the first occurence of k1 is before the first occurence of k2, k1 is before k2 208 | -- in the result 209 | groupByKeyWith :: (Eq a, Hashable a) => (k -> a) -> LookupMap k v -> LookupMap k [v] 210 | groupByKeyWith f pairs = map (\key -> (key, groups HashMap.! f key)) distinctKeys 211 | where 212 | -- don't use sort; keys should stay in the same order 213 | distinctKeys = nubBy ((==) `on` f) $ map fst pairs 214 | 215 | groups = HashMap.fromListWith (flip (++)) $ map (\(k, v) -> (f k, [v])) pairs 216 | 217 | {- Utilities -} 218 | 219 | lookupAll :: (Eq a) => a -> [(a, b)] -> [b] 220 | lookupAll a = map snd . filter ((== a) . fst) 221 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # aeson-schemas 2 | 3 | [![GitHub Actions](https://img.shields.io/github/actions/workflow/status/brandonchinn178/aeson-schemas/ci.yml?branch=main)](https://github.com/brandonchinn178/aeson-schemas/actions?query=branch%3Amain) 4 | [![codecov](https://codecov.io/gh/brandonchinn178/aeson-schemas/branch/main/graph/badge.svg)](https://codecov.io/gh/brandonchinn178/aeson-schemas) 5 | [![Hackage](https://img.shields.io/hackage/v/aeson-schemas)](https://hackage.haskell.org/package/aeson-schemas) 6 | 7 | A library that extracts information from JSON input using type-level schemas 8 | and quasiquoters, consuming JSON data in a type-safe manner. Better than 9 | `aeson` for decoding nested JSON data that would be cumbersome to represent as 10 | Haskell ADTs. 11 | 12 | Not related to [JSON Schema](https://json-schema.org/). 13 | 14 | ## Quickstart 15 | 16 | ```haskell 17 | {-# LANGUAGE DataKinds #-} 18 | {-# LANGUAGE QuasiQuotes #-} 19 | 20 | import Data.Aeson (eitherDecodeFileStrict) 21 | import Data.Aeson.Schema 22 | import qualified Data.Text as T 23 | 24 | -- First, define the schema of the JSON data 25 | type MySchema = [schema| 26 | { 27 | users: List { 28 | id: Int, 29 | name: Text, 30 | age: Maybe Int, 31 | enabled: Bool, 32 | groups: Maybe List { 33 | id: Int, 34 | name: Text, 35 | }, 36 | }, 37 | } 38 | |] 39 | 40 | main :: IO () 41 | main = do 42 | -- Then, load data from a file 43 | obj <- either fail return =<< 44 | eitherDecodeFileStrict "examples/input.json" :: IO (Object MySchema) 45 | 46 | -- print all the users' ids 47 | print [get| obj.users[].id |] 48 | 49 | flip mapM_ [get| obj.users |] $ \user -> do 50 | -- for each user, print out some information 51 | putStrLn $ "Details for user #" ++ show [get| user.id |] ++ ":" 52 | putStrLn $ "* Name: " ++ T.unpack [get| user.name |] 53 | putStrLn $ "* Age: " ++ maybe "N/A" show [get| user.age |] 54 | case [get| user.groups |] of 55 | Nothing -> putStrLn "* No groups" 56 | Just groups -> putStrLn $ "* Groups: " ++ show groups 57 | ``` 58 | 59 | ## Features 60 | 61 | ### Type safe 62 | 63 | Since schemas are defined at the type level, extracting data from JSON objects 64 | is checked at compile-time, meaning that using the `get` quasiquoter should 65 | never throw an error at runtime. 66 | 67 | ``` 68 | -- using schema from above 69 | >>> [get| obj.users[].isEnabled |] 70 | 71 | :1:6: error: 72 | • Key 'isEnabled' does not exist in the following schema: 73 | '[ '("id", 'Data.Aeson.Schema.SchemaInt), 74 | '("name", 'Data.Aeson.Schema.SchemaText), 75 | '("age", 76 | 'Data.Aeson.Schema.SchemaMaybe 'Data.Aeson.Schema.SchemaInt), 77 | '("enabled", 'Data.Aeson.Schema.SchemaBool), 78 | '("groups", 79 | 'Data.Aeson.Schema.SchemaMaybe 80 | ('Data.Aeson.Schema.SchemaList 81 | ('Data.Aeson.Schema.SchemaObject 82 | '[ '("id", 'Data.Aeson.Schema.SchemaInt), 83 | '("name", 'Data.Aeson.Schema.SchemaText)])))] 84 | • In the second argument of ‘(.)’, namely ‘getKey (Proxy :: Proxy "isEnabled")’ 85 | In the first argument of ‘(<$:>)’, namely 86 | ‘(id . getKey (Proxy :: Proxy "isEnabled"))’ 87 | In the first argument of ‘(.)’, namely 88 | ‘((id . getKey (Proxy :: Proxy "isEnabled")) <$:>)’ 89 | ``` 90 | 91 | ### Point-free definitions 92 | 93 | You can also use the `get` quasiquoter to define a pointfree function: 94 | 95 | ```haskell 96 | getNames :: Object MySchema -> [Text] 97 | getNames = [get| .users[].name |] 98 | ``` 99 | 100 | If you'd like to extract intermediate schemas, you can use the `unwrap` 101 | quasiquoter: 102 | 103 | ```haskell 104 | type User = [unwrap| MySchema.users[] |] 105 | 106 | getUsers :: Object MySchema -> [User] 107 | getUsers = [get| .users[] |] 108 | 109 | groupNames :: User -> Maybe [Text] 110 | groupNames = [get| .groups?[].name |] 111 | ``` 112 | 113 | ## Advantages over `aeson` 114 | 115 | ### JSON keys that are invalid Haskell field names 116 | 117 | `aeson` does a really good job of encoding and decoding JSON data into Haskell 118 | values. Most of the time, however, you don't deal with encoding/decoding data 119 | types manually, you would derive `Generic` and automatically derive `FromJSON`. 120 | In this case, you would match the constructor field names with the keys in the 121 | JSON data. The problem is that sometimes, JSON data just isn't suited for being 122 | defined as Haskell ADTs. For example, take the following JSON data: 123 | 124 | ```json 125 | { 126 | "id": 1, 127 | "type": "admin", 128 | "DOB": "5/23/90" 129 | } 130 | ``` 131 | 132 | The `FromJSON` instance for this data is not able to be automatically generated 133 | from `Generic` because the keys are not valid/ideal field names in Haskell: 134 | 135 | ```haskell 136 | data Result = Result 137 | { id :: Int 138 | -- ^ `id` shadows `Prelude.id` 139 | , type :: String 140 | -- ^ `type` is a reserved keyword 141 | , DOB :: String 142 | -- ^ fields can't start with an uppercase letter 143 | } deriving (Generic, FromJSON) 144 | ``` 145 | 146 | The only option is to manually define `FromJSON` -- not a bad option, but less 147 | than ideal. 148 | 149 | With this library, you don't have these limitations: 150 | 151 | ```haskell 152 | type Result = [schema| 153 | { 154 | id: Int, 155 | type: Text, 156 | DOB: Text, 157 | } 158 | |] 159 | ``` 160 | 161 | ### Nested data 162 | 163 | What about nested data? If we wanted to represent nested JSON data as Haskell 164 | data types, you would need to define a Haskell data type for each level. 165 | 166 | ```json 167 | { 168 | "permissions": [ 169 | { 170 | "resource": { 171 | "name": "secretdata.txt", 172 | "owner": { 173 | "username": "john@example.com" 174 | } 175 | }, 176 | "access": "READ" 177 | } 178 | ] 179 | } 180 | ``` 181 | 182 | ```haskell 183 | data Result = Result 184 | { permissions :: [Permission] 185 | } deriving (Show, Generic, FromJSON) 186 | 187 | data Permission = Permission 188 | { resource :: Resource 189 | , access :: String 190 | } deriving (Show, Generic, FromJSON) 191 | 192 | data Resource = Resource 193 | { name :: String 194 | , owner :: Owner 195 | } deriving (Show, Generic, FromJSON) 196 | 197 | data Owner = Owner 198 | { username :: String 199 | } deriving (Show, Generic, FromJSON) 200 | ``` 201 | 202 | It might be fine for a single example like this, but if you have to parse this 203 | kind of data often, it'll quickly become cumbersome defining multiple data 204 | types for each JSON schema. Additionally, the namespace becomes more polluted 205 | with each data type. For example, if you imported all four of these data types, 206 | you wouldn't be able to use `name`, `username`, `resource`, etc. as variable 207 | names, which can become a pain. 208 | 209 | Compared with this library: 210 | 211 | ```haskell 212 | type Result = [schema| 213 | { 214 | permissions: List { 215 | resource: { 216 | name: Text, 217 | owner: { 218 | username: Text, 219 | }, 220 | }, 221 | access: Text, 222 | } 223 | } 224 | |] 225 | ``` 226 | 227 | The only identifier added to the namespace is `Result`, and extracting data 228 | is easier and more readable: 229 | 230 | ```haskell 231 | -- without aeson-schemas 232 | map (username . owner . resource) . permissions 233 | 234 | -- with aeson-schemas 235 | [get| result.permissions[].resource.owner.username |] 236 | ``` 237 | 238 | ### Duplicate JSON keys 239 | 240 | Maybe you have nested data with JSON keys reused: 241 | 242 | ```json 243 | { 244 | "_type": "user", 245 | "node": { 246 | "name": "John", 247 | "groups": [ 248 | { 249 | "_type": "group", 250 | "node": { 251 | "name": "Admin", 252 | "writeAccess": true 253 | } 254 | } 255 | ] 256 | } 257 | } 258 | ``` 259 | 260 | This might be represented as: 261 | 262 | ```haskell 263 | data UserNode = UserNode 264 | { _type :: String 265 | , node :: User 266 | } 267 | 268 | data User = User 269 | { name :: String 270 | , groups :: [GroupNode] 271 | } 272 | 273 | data GroupNode = GroupNode 274 | { _type :: String 275 | , node :: Group 276 | } 277 | 278 | data Group = Group 279 | { name :: String 280 | , writeAccess :: Bool 281 | } 282 | ``` 283 | 284 | Here, `_type`, `name`, and `node` are repeated. This works with 285 | `{-# LANGUAGE DuplicateRecordFields #-}`, but you wouldn't be able to use the 286 | accessor function anymore: 287 | 288 | ``` 289 | >>> node userNode 290 | 291 | :1:1: error: 292 | Ambiguous occurrence 'node' 293 | It could refer to either the field 'node', 294 | defined at MyModule.hs:3:5 295 | or the field 'node', defined at MyModule.hs:13:5 296 | ``` 297 | 298 | So you'd have to pattern match out the data you want: 299 | 300 | ```haskell 301 | let UserNode{node = User{groups = userGroups}} = userNode 302 | groupNames = map (\GroupNode{node = Group{name = name}} -> name) userGroups 303 | ``` 304 | 305 | With this library, extraction is much more straightforward 306 | 307 | ```haskell 308 | let groupNames = [get| userNode.node.groups[].node.name |] 309 | ``` 310 | -------------------------------------------------------------------------------- /src/Data/Aeson/Schema/TH/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE NamedFieldPuns #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | {-# LANGUAGE ViewPatterns #-} 8 | 9 | {-| 10 | Module : Data.Aeson.Schema.TH.Utils 11 | Maintainer : Brandon Chinn 12 | Stability : experimental 13 | Portability : portable 14 | -} 15 | module Data.Aeson.Schema.TH.Utils ( 16 | reifySchema, 17 | lookupSchema, 18 | loadSchema, 19 | resolveSchemaType, 20 | schemaVToTypeQ, 21 | schemaTypeVToTypeQ, 22 | ) where 23 | 24 | import Control.Applicative (empty) 25 | import Control.Monad (forM) 26 | import Data.Bifunctor (bimap) 27 | import Language.Haskell.TH 28 | 29 | import Data.Aeson.Schema.Internal (Object) 30 | import Data.Aeson.Schema.Key (SchemaKey' (..), SchemaKeyV) 31 | import Data.Aeson.Schema.Type ( 32 | Schema' (..), 33 | SchemaObjectMapV, 34 | SchemaType' (..), 35 | SchemaTypeV, 36 | SchemaV, 37 | fromSchemaV, 38 | toSchemaObjectV, 39 | ) 40 | import Data.Aeson.Schema.Utils.Invariant (unreachable) 41 | import Data.Aeson.Schema.Utils.NameLike (NameLike (..), resolveName) 42 | 43 | {- Loading schema from TH -} 44 | 45 | reifySchema :: String -> Q SchemaV 46 | reifySchema name = lookupSchema (NameRef name) >>= loadSchema 47 | 48 | data ReifiedSchema = ReifiedSchema 49 | { reifiedSchemaName :: Name 50 | , reifiedSchemaType :: TypeWithoutKinds 51 | } 52 | 53 | -- | Look up a schema with the given name. Errors if the name doesn't exist or if the name does 54 | -- not refer to a schema. 55 | lookupSchema :: NameLike -> Q ReifiedSchema 56 | lookupSchema nameLike = do 57 | name <- lookupSchemaName nameLike 58 | ReifiedSchema name <$> reifySchemaType name 59 | where 60 | lookupSchemaName = \case 61 | NameRef name -> lookupTypeName name >>= maybe (fail $ "Unknown schema: " ++ name) return 62 | NameTH name -> return name 63 | 64 | reifySchemaType :: Name -> Q TypeWithoutKinds 65 | reifySchemaType schemaName = 66 | reify schemaName >>= \case 67 | TyConI (TySynD _ _ (stripKinds -> ty)) 68 | -- `type MySchema = 'Schema '[ ... ]` 69 | | isPromotedSchema ty -> 70 | return ty 71 | -- `type MySchema = Object ('Schema '[ ... ])` 72 | | Just inner <- unwrapObject ty 73 | , isPromotedSchema inner -> 74 | return inner 75 | -- `type MySchema = Object OtherSchema` 76 | | Just (ConT schemaName') <- unwrapObject ty -> 77 | reifySchemaType schemaName' 78 | _ -> fail $ "'" ++ show schemaName ++ "' is not a Schema" 79 | 80 | -- If the given type is of the format `Object a`, return `a`. 81 | unwrapObject :: TypeWithoutKinds -> Maybe TypeWithoutKinds 82 | unwrapObject = \case 83 | AppT (ConT name) inner | name == ''Object -> Just inner 84 | _ -> Nothing 85 | 86 | -- Return True if the given type is of the format: 'Schema '[ ... ] 87 | isPromotedSchema :: TypeWithoutKinds -> Bool 88 | isPromotedSchema = \case 89 | AppT (PromotedT name) _ | name == 'Schema -> True 90 | _ -> False 91 | 92 | loadSchema :: ReifiedSchema -> Q SchemaV 93 | loadSchema ReifiedSchema{reifiedSchemaType} = 94 | maybe (fail $ "Could not parse schema: " ++ show reifiedSchemaType) return $ parseSchema reifiedSchemaType 95 | where 96 | -- should be the inverse of schemaVToTypeQ 97 | parseSchema :: TypeWithoutKinds -> Maybe SchemaV 98 | parseSchema ty = do 99 | schemaObjectType <- case ty of 100 | AppT (PromotedT name) schemaType | name == 'Schema -> return schemaType 101 | _ -> empty 102 | 103 | Schema <$> parseSchemaObjectMap schemaObjectType 104 | 105 | -- should be the inverse of schemaObjectMapVToTypeQ 106 | parseSchemaObjectMap :: TypeWithoutKinds -> Maybe SchemaObjectMapV 107 | parseSchemaObjectMap schemaObjectType = do 108 | schemaObjectListOfPairs <- mapM typeToPair =<< typeToList schemaObjectType 109 | forM schemaObjectListOfPairs $ \(schemaKeyType, schemaTypeType) -> do 110 | schemaKey <- parseSchemaKey schemaKeyType 111 | schemaType <- parseSchemaType schemaTypeType 112 | return (schemaKey, schemaType) 113 | 114 | -- should be the inverse of schemaKeyVToTypeQ 115 | parseSchemaKey :: TypeWithoutKinds -> Maybe SchemaKeyV 116 | parseSchemaKey = \case 117 | AppT (PromotedT ty) (LitT (StrTyLit key)) 118 | | ty == 'NormalKey -> return $ NormalKey key 119 | | ty == 'PhantomKey -> return $ PhantomKey key 120 | _ -> empty 121 | 122 | -- should be the inverse of schemaTypeVToTypeQ 123 | parseSchemaType :: TypeWithoutKinds -> Maybe SchemaTypeV 124 | parseSchemaType = \case 125 | AppT (PromotedT name) (ConT inner) 126 | | name == 'SchemaScalar -> return $ SchemaScalar $ NameTH inner 127 | AppT (PromotedT name) inner 128 | | name == 'SchemaMaybe -> SchemaMaybe <$> parseSchemaType inner 129 | | name == 'SchemaTry -> SchemaTry <$> parseSchemaType inner 130 | | name == 'SchemaList -> SchemaList <$> parseSchemaType inner 131 | | name == 'SchemaUnion -> do 132 | schemas <- typeToList inner 133 | SchemaUnion <$> mapM parseSchemaType schemas 134 | | name == 'SchemaObject -> SchemaObject <$> parseSchemaObjectMap inner 135 | AppT (PromotedT name) (AppT (PromotedT right) (ConT inner)) 136 | | name == 'SchemaInclude 137 | , right == 'Right -> 138 | return $ SchemaInclude $ Left $ NameTH inner 139 | _ -> empty 140 | 141 | -- | Resolve SchemaInclude, if present. (Not recursive) 142 | resolveSchemaType :: SchemaTypeV -> Q SchemaTypeV 143 | resolveSchemaType = \case 144 | SchemaInclude (Left name) -> fmap toSchemaObjectV . loadSchema =<< lookupSchema name 145 | SchemaInclude (Right _) -> unreachable "Found 'SchemaInclude Right' when resolving schema type" 146 | schemaType -> pure schemaType 147 | 148 | {- Splicing schema into TH -} 149 | 150 | schemaVToTypeQ :: SchemaV -> TypeQ 151 | schemaVToTypeQ = appT [t|'Schema|] . schemaObjectMapVToTypeQ . fromSchemaV 152 | 153 | schemaObjectMapVToTypeQ :: SchemaObjectMapV -> TypeQ 154 | schemaObjectMapVToTypeQ = promotedListT . map schemaObjectPairVToTypeQ 155 | where 156 | schemaObjectPairVToTypeQ :: (SchemaKeyV, SchemaTypeV) -> TypeQ 157 | schemaObjectPairVToTypeQ = promotedPairT . bimap schemaKeyVToTypeQ schemaTypeVToTypeQ 158 | 159 | schemaKeyVToTypeQ :: SchemaKeyV -> TypeQ 160 | schemaKeyVToTypeQ = \case 161 | NormalKey key -> [t|'NormalKey $(litT $ strTyLit key)|] 162 | PhantomKey key -> [t|'PhantomKey $(litT $ strTyLit key)|] 163 | 164 | schemaTypeVToTypeQ :: SchemaTypeV -> TypeQ 165 | schemaTypeVToTypeQ = \case 166 | SchemaScalar name -> [t|'SchemaScalar $(resolveName name >>= conT)|] 167 | SchemaMaybe inner -> [t|'SchemaMaybe $(schemaTypeVToTypeQ inner)|] 168 | SchemaTry inner -> [t|'SchemaTry $(schemaTypeVToTypeQ inner)|] 169 | SchemaList inner -> [t|'SchemaList $(schemaTypeVToTypeQ inner)|] 170 | SchemaUnion schemas -> [t|'SchemaUnion $(promotedListT $ map schemaTypeVToTypeQ schemas)|] 171 | SchemaObject pairs -> [t|'SchemaObject $(schemaObjectMapVToTypeQ pairs)|] 172 | SchemaInclude (Left name) -> [t|'SchemaInclude ('Right $(conT . reifiedSchemaName =<< lookupSchema name))|] 173 | SchemaInclude (Right _) -> unreachable "Found 'SchemaInclude Right' when converting to TypeQ" 174 | 175 | {- TH utilities -} 176 | 177 | -- | Same as 'Type' except without any kind signatures or applications at any depth. 178 | -- 179 | -- Provides no actual guarantees. The caller is responsible for making sure the value 180 | -- has been run through 'stripKinds' at one point. 181 | type TypeWithoutKinds = Type 182 | 183 | {- FOURMOLU_DISABLE -} 184 | 185 | -- | Recursively strip all kind signatures and applications. 186 | stripKinds :: Type -> TypeWithoutKinds 187 | stripKinds ty = 188 | case ty of 189 | -- cases that strip + recurse 190 | SigT ty1 _ -> stripKinds ty1 191 | AppKindT ty1 _ -> stripKinds ty1 192 | 193 | -- cases that recurse 194 | ForallT tyVars ctx ty1 -> ForallT tyVars ctx (stripKinds ty1) 195 | ForallVisT tyVars ty1 -> ForallVisT tyVars (stripKinds ty1) 196 | AppT ty1 ty2 -> AppT (stripKinds ty1) (stripKinds ty2) 197 | InfixT ty1 name ty2 -> InfixT (stripKinds ty1) name (stripKinds ty2) 198 | UInfixT ty1 name ty2 -> UInfixT (stripKinds ty1) name (stripKinds ty2) 199 | PromotedInfixT ty1 name ty2 -> PromotedInfixT (stripKinds ty1) name (stripKinds ty2) 200 | PromotedUInfixT ty1 name ty2 -> PromotedUInfixT (stripKinds ty1) name (stripKinds ty2) 201 | ParensT ty1 -> ParensT (stripKinds ty1) 202 | ImplicitParamT str ty1 -> ImplicitParamT str (stripKinds ty1) 203 | 204 | -- base cases 205 | VarT _ -> ty 206 | ConT _ -> ty 207 | PromotedT _ -> ty 208 | TupleT _ -> ty 209 | UnboxedTupleT _ -> ty 210 | UnboxedSumT _ -> ty 211 | ArrowT -> ty 212 | MulArrowT -> ty 213 | EqualityT -> ty 214 | ListT -> ty 215 | PromotedTupleT _ -> ty 216 | PromotedNilT -> ty 217 | PromotedConsT -> ty 218 | StarT -> ty 219 | ConstraintT -> ty 220 | LitT _ -> ty 221 | WildCardT -> ty 222 | 223 | {- FOURMOLU_ENABLE -} 224 | 225 | typeToList :: TypeWithoutKinds -> Maybe [TypeWithoutKinds] 226 | typeToList = \case 227 | PromotedNilT -> Just [] 228 | AppT (AppT PromotedConsT x) xs -> (x :) <$> typeToList xs 229 | _ -> Nothing 230 | 231 | typeToPair :: TypeWithoutKinds -> Maybe (TypeWithoutKinds, TypeWithoutKinds) 232 | typeToPair = \case 233 | AppT (AppT (PromotedTupleT 2) a) b -> Just (a, b) 234 | _ -> Nothing 235 | 236 | promotedListT :: [TypeQ] -> TypeQ 237 | promotedListT = foldr consT promotedNilT 238 | where 239 | -- nb. https://stackoverflow.com/a/34457936 240 | consT x xs = appT (appT promotedConsT x) xs 241 | 242 | promotedPairT :: (TypeQ, TypeQ) -> TypeQ 243 | promotedPairT (a, b) = [t|'($a, $b)|] 244 | -------------------------------------------------------------------------------- /src/Data/Aeson/Schema/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE DefaultSignatures #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE GADTs #-} 8 | {-# LANGUAGE LambdaCase #-} 9 | {-# LANGUAGE MultiParamTypeClasses #-} 10 | {-# LANGUAGE OverloadedStrings #-} 11 | {-# LANGUAGE PolyKinds #-} 12 | {-# LANGUAGE RankNTypes #-} 13 | {-# LANGUAGE ScopedTypeVariables #-} 14 | {-# LANGUAGE TypeApplications #-} 15 | {-# LANGUAGE TypeFamilyDependencies #-} 16 | {-# LANGUAGE TypeOperators #-} 17 | {-# LANGUAGE UndecidableInstances #-} 18 | 19 | {-| 20 | Module : Data.Aeson.Schema.Internal 21 | Maintainer : Brandon Chinn 22 | Stability : experimental 23 | Portability : portable 24 | 25 | Internal definitions for declaring JSON schemas. 26 | -} 27 | module Data.Aeson.Schema.Internal where 28 | 29 | import Control.Applicative (Alternative (..), optional) 30 | import Data.Aeson (FromJSON (..), ToJSON (..), Value (..)) 31 | import qualified Data.Aeson as Aeson 32 | import Data.Aeson.Types (Parser) 33 | import Data.Dynamic (Dynamic, fromDynamic, toDyn) 34 | import Data.List (intersperse) 35 | import Data.Maybe (fromMaybe) 36 | import Data.Proxy (Proxy (..)) 37 | import Data.String (fromString) 38 | import qualified Data.Text as Text 39 | import Data.Typeable (Typeable) 40 | import Fcf (type (<=<), type (=<<)) 41 | import qualified Fcf 42 | import GHC.Exts (toList) 43 | import GHC.TypeLits ( 44 | ErrorMessage (..), 45 | KnownSymbol, 46 | Symbol, 47 | TypeError, 48 | symbolVal, 49 | ) 50 | 51 | import Data.Aeson.Schema.Key ( 52 | IsSchemaKey (..), 53 | SchemaKey, 54 | SchemaKey' (..), 55 | fromSchemaKeyV, 56 | getContext, 57 | showSchemaKey, 58 | toContext, 59 | ) 60 | import Data.Aeson.Schema.Type ( 61 | FromSchema, 62 | IsSchemaObjectMap, 63 | IsSchemaType (..), 64 | Schema, 65 | Schema' (..), 66 | SchemaType, 67 | SchemaType' (..), 68 | ToSchemaObject, 69 | showSchemaTypeV, 70 | showSchemaV, 71 | toSchemaV, 72 | ) 73 | import Data.Aeson.Schema.Utils.All (All (..)) 74 | import Data.Aeson.Schema.Utils.Compat (Key, KeyMap) 75 | import qualified Data.Aeson.Schema.Utils.Compat as Compat 76 | import Data.Aeson.Schema.Utils.Invariant (unreachable) 77 | import Data.Aeson.Schema.Utils.Sum (SumType (..)) 78 | 79 | {- Schema-validated JSON object -} 80 | 81 | -- | The object containing JSON data and its schema. 82 | -- 83 | -- Has a 'FromJSON' instance, so you can use the usual @Data.Aeson@ decoding functions. 84 | -- 85 | -- > obj = decode "{\"a\": 1}" :: Maybe (Object [schema| { a: Int } |]) 86 | newtype Object (schema :: Schema) = UnsafeObject (KeyMap Dynamic) 87 | 88 | instance (IsSchema schema) => Show (Object schema) where 89 | showsPrec _ = showValue @(ToSchemaObject schema) 90 | 91 | instance (IsSchema schema) => Eq (Object schema) where 92 | a == b = toJSON a == toJSON b 93 | 94 | instance (IsSchema schema) => FromJSON (Object schema) where 95 | parseJSON = parseValue @(ToSchemaObject schema) [] 96 | 97 | instance (IsSchema schema) => ToJSON (Object schema) where 98 | toJSON = toValue @(ToSchemaObject schema) 99 | 100 | -- | Convert an 'Object' into a 'Aeson.Object', losing the type information in the schema. 101 | -- 102 | -- @since 1.3.0 103 | toMap :: (IsSchema ('Schema schema)) => Object ('Schema schema) -> Aeson.Object 104 | toMap = toValueMap 105 | 106 | {- Type-level schema definitions -} 107 | 108 | -- | The constraint for most operations involving @Object schema@. If you're writing functions 109 | -- on general Objects, you should use this constraint. e.g. 110 | -- 111 | -- > logObject :: (MonadLogger m, IsSchema schema) => Object schema -> m () 112 | -- > logObject = logInfoN . Text.pack . show 113 | -- 114 | -- @since 1.3.0 115 | type IsSchema (schema :: Schema) = 116 | ( HasSchemaResult (ToSchemaObject schema) 117 | , All HasSchemaResultPair (FromSchema schema) 118 | , IsSchemaObjectMap (FromSchema schema) 119 | , SchemaResult (ToSchemaObject schema) ~ Object schema 120 | ) 121 | 122 | -- | Show the given schema. 123 | -- 124 | -- Usage: 125 | -- 126 | -- > type MySchema = [schema| { a: Int } |] 127 | -- > showSchema @MySchema 128 | showSchema :: forall (schema :: Schema). (IsSchema schema) => String 129 | showSchema = "SchemaObject " ++ showSchemaV schema -- TODO: Remove "SchemaObject" prefix? Or rename to "Schema"? 130 | where 131 | schema = toSchemaV $ Proxy @schema 132 | 133 | showSchemaType :: forall (schemaType :: SchemaType). (HasSchemaResult schemaType) => String 134 | showSchemaType = showSchemaTypeV schemaType 135 | where 136 | schemaType = toSchemaTypeV $ Proxy @schemaType 137 | 138 | {- Conversions from schema types into Haskell types -} 139 | 140 | -- | A type family mapping SchemaType to the corresponding Haskell type. 141 | type family SchemaResult (schema :: SchemaType) where 142 | SchemaResult ('SchemaScalar inner) = inner 143 | SchemaResult ('SchemaMaybe inner) = Maybe (SchemaResult inner) 144 | SchemaResult ('SchemaTry inner) = Maybe (SchemaResult inner) 145 | SchemaResult ('SchemaList inner) = [SchemaResult inner] 146 | SchemaResult ('SchemaUnion schemas) = SumType (SchemaResultList schemas) 147 | SchemaResult ('SchemaObject inner) = Object ('Schema inner) 148 | SchemaResult ('SchemaInclude ('Right schema)) = SchemaResult (ToSchemaObject schema) 149 | 150 | type family SchemaResultList (xs :: [SchemaType]) where 151 | SchemaResultList '[] = '[] 152 | SchemaResultList (x ': xs) = SchemaResult x ': SchemaResultList xs 153 | 154 | -- | A type-class for types that can be parsed from JSON for an associated schema type. 155 | class (IsSchemaType schema) => HasSchemaResult (schema :: SchemaType) where 156 | parseValue :: [Key] -> Value -> Parser (SchemaResult schema) 157 | default parseValue :: (FromJSON (SchemaResult schema)) => [Key] -> Value -> Parser (SchemaResult schema) 158 | parseValue path value = parseJSON value <|> parseFail @schema path value 159 | 160 | toValue :: SchemaResult schema -> Value 161 | default toValue :: (ToJSON (SchemaResult schema)) => SchemaResult schema -> Value 162 | toValue = toJSON 163 | 164 | -- Note: Using ShowS here instead of just returning String to avoid quadratic performance when 165 | -- using (++) 166 | showValue :: SchemaResult schema -> ShowS 167 | default showValue :: (Show (SchemaResult schema)) => SchemaResult schema -> ShowS 168 | showValue = shows 169 | 170 | instance (Show inner, Typeable inner, FromJSON inner, ToJSON inner) => HasSchemaResult ('SchemaScalar inner) 171 | 172 | instance (HasSchemaResult inner, Show (SchemaResult inner), ToJSON (SchemaResult inner)) => HasSchemaResult ('SchemaMaybe inner) where 173 | parseValue path = \case 174 | Null -> return Nothing 175 | value -> (Just <$> parseValue @inner path value) 176 | 177 | instance (HasSchemaResult inner, Show (SchemaResult inner), ToJSON (SchemaResult inner)) => HasSchemaResult ('SchemaTry inner) where 178 | parseValue path = optional . parseValue @inner path 179 | 180 | instance (HasSchemaResult inner, Show (SchemaResult inner), ToJSON (SchemaResult inner)) => HasSchemaResult ('SchemaList inner) where 181 | parseValue path = \case 182 | Array a -> traverse (parseValue @inner path) (toList a) 183 | value -> parseFail @('SchemaList inner) path value 184 | 185 | instance 186 | ( All HasSchemaResult schemas 187 | , All IsSchemaType schemas 188 | , Show (SchemaResult ('SchemaUnion schemas)) 189 | , FromJSON (SchemaResult ('SchemaUnion schemas)) 190 | , ToJSON (SchemaResult ('SchemaUnion schemas)) 191 | , ParseSumType schemas 192 | ) => 193 | HasSchemaResult ('SchemaUnion (schemas :: [SchemaType])) 194 | where 195 | parseValue path value = parseSumType @schemas path value <|> parseFail @('SchemaUnion schemas) path value 196 | 197 | class ParseSumType xs where 198 | parseSumType :: [Key] -> Value -> Parser (SumType (SchemaResultList xs)) 199 | 200 | instance ParseSumType '[] where 201 | parseSumType _ _ = empty 202 | 203 | instance (HasSchemaResult schema, ParseSumType schemas) => ParseSumType (schema ': schemas) where 204 | parseSumType path value = parseHere <|> parseThere 205 | where 206 | parseHere = Here <$> parseValue @schema path value 207 | parseThere = There <$> parseSumType @schemas path value 208 | 209 | instance (All HasSchemaResultPair pairs, IsSchemaObjectMap pairs) => HasSchemaResult ('SchemaObject pairs) where 210 | parseValue path = \case 211 | Aeson.Object o -> UnsafeObject . Compat.fromList <$> parseValueMap o 212 | value -> parseFail @('SchemaObject pairs) path value 213 | where 214 | parseValueMap :: Aeson.Object -> Parser [(Key, Dynamic)] 215 | parseValueMap o = sequence $ mapAll @HasSchemaResultPair @pairs $ \proxy -> parseValuePair proxy path o 216 | 217 | toValue = Aeson.Object . toValueMap 218 | 219 | showValue o = showString "{ " . intercalateShowS ", " (map fromPair pairs) . showString " }" 220 | where 221 | fromPair (k, v) = showString k . showString ": " . v 222 | pairs = mapAll @HasSchemaResultPair @pairs $ \proxy -> showValuePair proxy o 223 | 224 | -- intercalate for ShowS 225 | intercalateShowS :: String -> [ShowS] -> ShowS 226 | intercalateShowS s = concatShowS . intersperse (showString s) 227 | 228 | concatShowS :: [ShowS] -> ShowS 229 | concatShowS = foldr (.) id 230 | 231 | toValueMap :: forall pairs. (All HasSchemaResultPair pairs) => Object ('Schema pairs) -> Aeson.Object 232 | toValueMap o = Compat.unions $ mapAll @HasSchemaResultPair @pairs (\proxy -> toValuePair proxy o) 233 | 234 | class HasSchemaResultPair (a :: (SchemaKey, SchemaType)) where 235 | parseValuePair :: Proxy a -> [Key] -> Aeson.Object -> Parser (Key, Dynamic) 236 | toValuePair :: Proxy a -> Object schema -> Aeson.Object 237 | showValuePair :: Proxy a -> Object schema -> (String, ShowS) 238 | 239 | instance 240 | ( IsSchemaKey key 241 | , HasSchemaResult inner 242 | , Typeable (SchemaResult inner) 243 | ) => 244 | HasSchemaResultPair '(key, inner) 245 | where 246 | parseValuePair _ path o = do 247 | inner <- parseValue @inner (key : path) $ getContext schemaKey o 248 | return (key, toDyn inner) 249 | where 250 | schemaKey = toSchemaKeyV $ Proxy @key 251 | key = fromString $ fromSchemaKeyV schemaKey 252 | 253 | toValuePair _ o = toContext schemaKey (toValue @inner val) 254 | where 255 | schemaKey = toSchemaKeyV $ Proxy @key 256 | val = unsafeGetKey @inner (Proxy @(FromSchemaKey key)) o 257 | 258 | showValuePair _ o = (showSchemaKey @key, showValue @inner val) 259 | where 260 | val = unsafeGetKey @inner (Proxy @(FromSchemaKey key)) o 261 | 262 | instance (IsSchema schema) => HasSchemaResult ('SchemaInclude ('Right schema)) where 263 | parseValue = parseValue @(ToSchemaObject schema) 264 | toValue = toValue @(ToSchemaObject schema) 265 | showValue = showValue @(ToSchemaObject schema) 266 | 267 | -- | A helper for creating fail messages when parsing a schema. 268 | parseFail :: forall (schema :: SchemaType) m a. (MonadFail m, HasSchemaResult schema) => [Key] -> Value -> m a 269 | parseFail path value = fail $ msg ++ ": " ++ ellipses 200 (show value) 270 | where 271 | msg = 272 | if null path 273 | then "Could not parse schema " ++ schema' 274 | else "Could not parse path '" ++ path' ++ "' with schema " ++ schema' 275 | path' = Text.unpack . Text.intercalate "." . map Compat.keyToText $ reverse path 276 | schema' = "`" ++ showSchemaType @schema ++ "`" 277 | ellipses n s = if length s > n then take n s ++ "..." else s 278 | 279 | {- Lookups within SchemaObject -} 280 | 281 | data UnSchemaKey :: SchemaKey -> Fcf.Exp Symbol 282 | type instance Fcf.Eval (UnSchemaKey ('NormalKey key)) = Fcf.Eval (Fcf.Pure key) 283 | type instance Fcf.Eval (UnSchemaKey ('PhantomKey key)) = Fcf.Eval (Fcf.Pure key) 284 | 285 | -- first-class-families-0.3.0.1 doesn't support partially applying Lookup 286 | type Lookup a = Fcf.Map Fcf.Snd <=< Fcf.Find (Fcf.TyEq a <=< Fcf.Fst) 287 | 288 | -- | The type-level function that return the schema of the given key in a 'SchemaObject'. 289 | type family LookupSchema (key :: Symbol) (schema :: Schema) :: SchemaType where 290 | LookupSchema key ('Schema schema) = 291 | Fcf.Eval 292 | ( Fcf.FromMaybe 293 | ( TypeError 294 | ( 'Text "Key '" 295 | ':<>: 'Text key 296 | ':<>: 'Text "' does not exist in the following schema:" 297 | ':$$: 'ShowType schema 298 | ) 299 | ) 300 | =<< Lookup key 301 | =<< Fcf.Map (Fcf.Bimap UnSchemaKey Fcf.Pure) schema 302 | ) 303 | 304 | -- | Get a key from the given 'Data.Aeson.Schema.Internal.Object', returned as the type encoded in 305 | -- its schema. 306 | -- 307 | -- > let o = .. :: Object 308 | -- > ( 'SchemaObject 309 | -- > '[ '("foo", 'SchemaInt) 310 | -- > , '("bar", 'SchemaObject 311 | -- > '[ '("name", 'SchemaText) 312 | -- > ] 313 | -- > , '("baz", 'SchemaMaybe 'SchemaBool) 314 | -- > ] 315 | -- > ) 316 | -- > 317 | -- > getKey (Proxy @"foo") o :: Bool 318 | -- > getKey (Proxy @"bar") o :: Object ('SchemaObject '[ '("name", 'SchemaText) ]) 319 | -- > getKey (Proxy @"name") $ getKey @"bar" o :: Text 320 | -- > getKey (Proxy @"baz") o :: Maybe Bool 321 | getKey :: 322 | forall (key :: Symbol) (schema :: Schema) (endSchema :: SchemaType) result. 323 | ( endSchema ~ LookupSchema key schema 324 | , result ~ SchemaResult endSchema 325 | , KnownSymbol key 326 | , Typeable result 327 | , Typeable endSchema 328 | ) => 329 | Proxy key 330 | -> Object schema 331 | -> result 332 | getKey = unsafeGetKey @endSchema 333 | 334 | unsafeGetKey :: 335 | forall (endSchema :: SchemaType) (key :: Symbol) (schema :: Schema). 336 | (KnownSymbol key, Typeable (SchemaResult endSchema)) => 337 | Proxy key 338 | -> Object schema 339 | -> SchemaResult endSchema 340 | unsafeGetKey keyProxy (UnsafeObject object) = 341 | fromMaybe (unreachable $ "Could not load key: " ++ key) $ 342 | fromDynamic =<< Compat.lookup (fromString key) object 343 | where 344 | key = symbolVal keyProxy 345 | -------------------------------------------------------------------------------- /test/TestUtils/Arbitrary.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DeriveLift #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE LambdaCase #-} 8 | {-# LANGUAGE PolyKinds #-} 9 | {-# LANGUAGE QuasiQuotes #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE StandaloneDeriving #-} 12 | {-# LANGUAGE TemplateHaskell #-} 13 | {-# LANGUAGE TupleSections #-} 14 | {-# LANGUAGE TypeApplications #-} 15 | {-# LANGUAGE TypeFamilies #-} 16 | {-# LANGUAGE TypeOperators #-} 17 | {-# LANGUAGE UndecidableInstances #-} 18 | {-# OPTIONS_GHC -Wno-orphans #-} 19 | 20 | module TestUtils.Arbitrary ( 21 | ArbitraryObject (..), 22 | forAllArbitraryObjects, 23 | ) where 24 | 25 | import Control.Monad (forM) 26 | import Data.Aeson (ToJSON (..), Value (..), encode) 27 | import qualified Data.Aeson as Aeson 28 | import Data.List (nub) 29 | import Data.Proxy (Proxy (..)) 30 | import Data.Text (Text) 31 | import qualified Data.Text as Text 32 | import Data.Typeable (Typeable) 33 | import GHC.Exts (fromList) 34 | import GHC.TypeLits (KnownSymbol) 35 | import Language.Haskell.TH (ExpQ, listE, runIO) 36 | import Language.Haskell.TH.Instances () 37 | import Language.Haskell.TH.Quote (QuasiQuoter (quoteType)) 38 | import Language.Haskell.TH.Syntax (Lift) 39 | import Test.QuickCheck 40 | 41 | import Data.Aeson.Schema (IsSchema, Object, schema) 42 | import Data.Aeson.Schema.Key ( 43 | IsSchemaKey (..), 44 | SchemaKey, 45 | SchemaKey' (..), 46 | SchemaKeyV, 47 | toContext, 48 | ) 49 | import Data.Aeson.Schema.Type ( 50 | Schema' (..), 51 | SchemaObjectMapV, 52 | SchemaType, 53 | SchemaType' (..), 54 | SchemaTypeV, 55 | SchemaV, 56 | showSchemaV, 57 | toSchemaObjectV, 58 | ) 59 | import Data.Aeson.Schema.Utils.All (All (..)) 60 | import qualified Data.Aeson.Schema.Utils.Compat as Compat 61 | import Data.Aeson.Schema.Utils.NameLike (NameLike (..), fromName) 62 | 63 | data ArbitraryObject where 64 | ArbitraryObject :: 65 | (IsSchema schema) => 66 | Proxy (Object schema) 67 | -> Value 68 | -> SchemaV 69 | -> ArbitraryObject 70 | 71 | -- Show the value and schema as something that could be copied/pasted into GHCi. 72 | instance Show ArbitraryObject where 73 | show (ArbitraryObject _ v schemaV) = 74 | unlines 75 | [ "ArbitraryObject:" 76 | , " " ++ show (encode v) 77 | , " [schema| " ++ showSchemaV schemaV ++ " |]" 78 | ] 79 | 80 | -- | A Template Haskell function to generate a splice for QuickCheck tests to generate arbitrary 81 | -- objects with arbitrary schemas. 82 | -- 83 | -- Note that for repeated runs of the test suite, the schemas will be the same, with the actual 84 | -- JSON values generated randomly. You need to recompile in order to generate different schemas. 85 | arbitraryObject :: ExpQ 86 | arbitraryObject = do 87 | arbitrarySchemas <- runIO $ genSchemaTypes 20 88 | 89 | [|oneof $(listE $ map mkSchemaGen arbitrarySchemas)|] 90 | where 91 | mkSchemaGen schemaV = 92 | let schemaType = quoteType schema $ showSchemaV schemaV 93 | in [|genSchema' (Proxy :: Proxy (Object $schemaType)) schemaV|] 94 | 95 | -- | 96 | -- Splices to a 'forAll' with 'arbitraryObject', outputting information about the object 97 | -- generated, to ensure we get good generation. 98 | -- 99 | -- >>> $(forAllArbitraryObjects) :: Testable prop => ArbitraryObject -> prop 100 | forAllArbitraryObjects :: ExpQ 101 | forAllArbitraryObjects = [|forAllArbitraryObjects' $arbitraryObject|] 102 | 103 | forAllArbitraryObjects' :: Gen ArbitraryObject -> (ArbitraryObject -> Property) -> Property 104 | forAllArbitraryObjects' genArbitraryObject runTest = 105 | forAll @_ @Property genArbitraryObject $ \o@(ArbitraryObject _ _ schemaType) -> 106 | tabulate "Key types" (map getKeyType $ getKeys schemaType) $ 107 | tabulate "Schema types" (getSchemaTypes schemaType) $ 108 | tabulate "Object sizes" (map show $ getObjectSizes schemaType) $ 109 | tabulate "Object depth" [show $ getObjectDepth schemaType] $ 110 | runTest o 111 | 112 | {- Run time helpers -} 113 | 114 | deriving instance Lift NameLike 115 | deriving instance Lift SchemaV 116 | deriving instance Lift SchemaTypeV 117 | 118 | genSchema' :: 119 | forall schema. 120 | ( ArbitrarySchema ('SchemaObject schema) 121 | , IsSchema ('Schema schema) 122 | ) => 123 | Proxy (Object ('Schema schema)) 124 | -> SchemaV 125 | -> Gen ArbitraryObject 126 | genSchema' proxy schemaV = do 127 | v <- genSchema @('SchemaObject schema) 128 | return $ ArbitraryObject proxy v schemaV 129 | 130 | getKeyType :: SchemaKeyV -> String 131 | getKeyType = \case 132 | NormalKey _ -> "Normal" 133 | PhantomKey _ -> "Phantom" 134 | 135 | getKeys :: SchemaV -> [SchemaKeyV] 136 | getKeys = getKeys' . toSchemaObjectV 137 | where 138 | getKeys' = \case 139 | SchemaMaybe inner -> getKeys' inner 140 | SchemaTry inner -> getKeys' inner 141 | SchemaList inner -> getKeys' inner 142 | SchemaUnion schemas -> concatMap getKeys' schemas 143 | SchemaObject pairs -> concatMap (\(key, inner) -> key : getKeys' inner) pairs 144 | _ -> [] 145 | 146 | getSchemaTypes :: SchemaV -> [String] 147 | getSchemaTypes = getSchemaTypes' . toSchemaObjectV 148 | where 149 | getSchemaTypes' = \case 150 | SchemaScalar name -> [fromName name] 151 | SchemaMaybe inner -> "SchemaMaybe" : getSchemaTypes' inner 152 | SchemaTry inner -> "SchemaTry" : getSchemaTypes' inner 153 | SchemaList inner -> "SchemaList" : getSchemaTypes' inner 154 | SchemaUnion schemas -> "SchemaUnion" : concatMap getSchemaTypes' schemas 155 | SchemaObject pairs -> "SchemaObject" : concatMap (getSchemaTypes' . snd) pairs 156 | SchemaInclude _ -> error "ArbitraryObject unexpectedly generated a schema that includes another schema" 157 | 158 | getObjectSizes :: SchemaV -> [Int] 159 | getObjectSizes = getObjectSizes' . toSchemaObjectV 160 | where 161 | getObjectSizes' = \case 162 | SchemaScalar _ -> [] 163 | SchemaMaybe inner -> getObjectSizes' inner 164 | SchemaTry inner -> getObjectSizes' inner 165 | SchemaList inner -> getObjectSizes' inner 166 | SchemaUnion schemas -> concatMap getObjectSizes' schemas 167 | SchemaObject pairs -> length pairs : concatMap (getObjectSizes' . snd) pairs 168 | SchemaInclude _ -> error "ArbitraryObject unexpectedly generated a schema that includes another schema" 169 | 170 | getObjectDepth :: SchemaV -> Int 171 | getObjectDepth = getObjectDepth' . toSchemaObjectV 172 | where 173 | getObjectDepth' = \case 174 | SchemaScalar _ -> 0 175 | SchemaMaybe inner -> getObjectDepth' inner 176 | SchemaTry inner -> getObjectDepth' inner 177 | SchemaList inner -> getObjectDepth' inner 178 | SchemaUnion schemas -> maximum $ map getObjectDepth' schemas 179 | SchemaObject pairs -> 1 + maximum (map (getObjectDepth' . snd) pairs) 180 | SchemaInclude _ -> error "ArbitraryObject unexpectedly generated a schema that includes another schema" 181 | 182 | {- Generating schemas -} 183 | 184 | class ArbitrarySchema (schema :: SchemaType) where 185 | genSchema :: Gen Value 186 | 187 | instance {-# OVERLAPS #-} ArbitrarySchema ('SchemaScalar Text) where 188 | genSchema = toJSON <$> arbitrary @String 189 | 190 | instance (Arbitrary inner, ToJSON inner, Typeable inner) => ArbitrarySchema ('SchemaScalar inner) where 191 | genSchema = toJSON <$> arbitrary @inner 192 | 193 | instance (ArbitrarySchema inner) => ArbitrarySchema ('SchemaMaybe inner) where 194 | genSchema = 195 | frequency 196 | [ (3, genSchema @inner) 197 | , (1, pure Null) 198 | ] 199 | 200 | instance (ArbitrarySchema inner) => ArbitrarySchema ('SchemaTry inner) where 201 | genSchema = 202 | frequency 203 | [ (3, genSchema @inner) 204 | , (1, genValue) 205 | ] 206 | where 207 | genValue = 208 | oneof 209 | [ pure Null 210 | , Number . realToFrac <$> arbitrary @Double 211 | , Bool <$> arbitrary 212 | , String . Text.pack <$> arbitrary 213 | ] 214 | 215 | instance (ArbitrarySchema inner) => ArbitrarySchema ('SchemaList inner) where 216 | genSchema = Array . fromList <$> listOf (genSchema @inner) 217 | 218 | instance (All ArbitrarySchema schemas) => ArbitrarySchema ('SchemaUnion schemas) where 219 | genSchema = oneof $ mapAll @ArbitrarySchema @schemas genSchemaElem 220 | where 221 | genSchemaElem :: forall schema. (ArbitrarySchema schema) => Proxy schema -> Gen Value 222 | genSchemaElem _ = genSchema @schema 223 | 224 | instance (All ArbitraryObjectPair pairs) => ArbitrarySchema ('SchemaObject (pairs :: [(SchemaKey, SchemaType)])) where 225 | genSchema = Object . Compat.unions <$> genSchemaPairs 226 | where 227 | genSchemaPairs :: Gen [Aeson.Object] 228 | genSchemaPairs = sequence $ mapAll @ArbitraryObjectPair @pairs genSchemaPair 229 | 230 | class (IsSchemaKey (Fst pair)) => ArbitraryObjectPair (pair :: (SchemaKey, SchemaType)) where 231 | genSchemaPair :: Proxy pair -> Gen Aeson.Object 232 | genSchemaPair _ = toContext schemaKey <$> genInnerSchema @pair 233 | where 234 | schemaKey = toSchemaKeyV $ Proxy @(Fst pair) 235 | 236 | genInnerSchema :: Gen Value 237 | 238 | instance (IsSchemaKey key, ArbitrarySchema schema) => ArbitraryObjectPair '(key, schema) where 239 | genInnerSchema = genSchema @schema 240 | 241 | -- For phantom keys, Maybe is only valid for Objects. Since phantom keys parse the schema with 242 | -- the current object as the context, we should guarantee that this only generates objects, and 243 | -- not Null. 244 | instance 245 | {-# OVERLAPS #-} 246 | (KnownSymbol key, inner ~ 'SchemaObject a, ArbitrarySchema inner) => 247 | ArbitraryObjectPair '( 'PhantomKey key, 'SchemaMaybe inner) 248 | where 249 | genInnerSchema = genSchema @inner 250 | 251 | -- For phantom keys, Try can be used on any schema, but for all non-object schemas, need to ensure 252 | -- we generate 'Null', because Try on a non-object schema will always be an invalid parse. 253 | instance 254 | {-# OVERLAPS #-} 255 | (KnownSymbol key, ArbitrarySchema ('SchemaTry inner)) => 256 | ArbitraryObjectPair '( 'PhantomKey key, 'SchemaTry inner) 257 | where 258 | genInnerSchema = castNull <$> genSchema @('SchemaTry inner) 259 | where 260 | castNull inner = 261 | case inner of 262 | Object _ -> inner 263 | _ -> Null 264 | 265 | -- For phantom keys, Union can be used on any schemas, as long as at least one is an object schema. 266 | instance 267 | {-# OVERLAPS #-} 268 | (KnownSymbol key, FilterObjectSchemas schemas ~ objectSchemas, ArbitrarySchema ('SchemaUnion objectSchemas)) => 269 | ArbitraryObjectPair '( 'PhantomKey key, 'SchemaUnion schemas) 270 | where 271 | genInnerSchema = genSchema @('SchemaUnion objectSchemas) 272 | 273 | {- Generating schema definitions -} 274 | 275 | genSchemaTypes :: Int -> IO [SchemaV] 276 | genSchemaTypes numSchemasToGenerate = 277 | generate $ 278 | sequence $ 279 | take 280 | numSchemasToGenerate 281 | [resize n arbitrary | n <- [0, 2 ..]] 282 | 283 | instance Arbitrary SchemaV where 284 | arbitrary = Schema <$> sized genSchemaObject 285 | 286 | -- | Generate an arbitrary schema. 287 | -- 288 | -- SchemaType is a recursive definition, so we want to make sure that generating a schema will 289 | -- terminate, and also not take too long. The ways we account for that are: 290 | -- * Providing an upper bound on the depth of any object schemas in the current object (n / 2) 291 | -- * Providing an upper bound on the number of keys in the current object (n / 3) 292 | -- * Providing an upper bound on the number of schemas in a union (n / 5) 293 | genSchemaObject :: Int -> Gen SchemaObjectMapV 294 | genSchemaObject n = do 295 | keys <- genUniqList1 (n `div` 3) genKey 296 | forM keys $ \key -> 297 | frequency 298 | [ (10, genSchemaObjectPairNormal key) 299 | , (1, genSchemaObjectPairPhantom key) 300 | ] 301 | where 302 | genSchemaObject' = do 303 | n' <- choose (0, n `div` 2) 304 | SchemaObject <$> genSchemaObject n' 305 | 306 | genSchemaObjectPairNormal key = do 307 | schemaType <- 308 | frequency $ 309 | if n == 0 310 | then scalarSchemaTypes 311 | else allSchemaTypes 312 | return (NormalKey key, schemaType) 313 | 314 | genSchemaObjectPairPhantom key = do 315 | schemaType <- 316 | frequency 317 | [ (2, SchemaMaybe <$> genSchemaObject') 318 | , (2, SchemaTry <$> frequency nonNullableSchemaTypes) 319 | , (4, genSchemaObject') 320 | , (1, genSchemaUnion genSchemaObject') 321 | ] 322 | return (PhantomKey key, schemaType) 323 | 324 | scalarSchemaTypes = 325 | [ (4, pure $ SchemaScalar $ NameRef "Bool") 326 | , (4, pure $ SchemaScalar $ NameRef "Int") 327 | , (4, pure $ SchemaScalar $ NameRef "Double") 328 | , (4, pure $ SchemaScalar $ NameRef "Text") 329 | ] 330 | 331 | nonNullableSchemaTypes = 332 | scalarSchemaTypes 333 | ++ [ (2, SchemaList <$> frequency allSchemaTypes) 334 | , (1, genSchemaUnion $ frequency allSchemaTypes) 335 | , (2, genSchemaObject') 336 | ] 337 | 338 | allSchemaTypes = 339 | nonNullableSchemaTypes 340 | ++ [ (2, SchemaMaybe <$> frequency nonNullableSchemaTypes) 341 | , (2, SchemaTry <$> frequency nonNullableSchemaTypes) 342 | ] 343 | 344 | -- avoid generating big unions by scaling list length 345 | genSchemaUnion gen = SchemaUnion <$> genUniqList1 (n `div` 5) gen 346 | 347 | -- | Generate a valid JSON key 348 | -- See Data.Aeson.Schema.TH.Parse.jsonKey' 349 | genKey :: Gen String 350 | genKey = listOf1 $ arbitraryPrintableChar `suchThat` (`notElem` " \"\\!?[](),.@:{}#") 351 | 352 | -- | Generate a non-empty and unique list of the given generator. 353 | -- 354 | -- Takes in the max size of the list. 355 | genUniqList1 :: (Eq a) => Int -> Gen a -> Gen [a] 356 | genUniqList1 n gen = do 357 | k <- choose (1, max 1 n) 358 | take k . nub <$> infiniteListOf gen 359 | 360 | {- Helper type families -} 361 | 362 | type family Fst x where 363 | Fst '(a, _) = a 364 | 365 | type family FilterObjectSchemas schemas where 366 | FilterObjectSchemas '[] = '[] 367 | FilterObjectSchemas ('SchemaObject inner ': xs) = 'SchemaObject inner : FilterObjectSchemas xs 368 | FilterObjectSchemas (_ ': xs) = FilterObjectSchemas xs 369 | --------------------------------------------------------------------------------