aeson-schemas 1.3.3 → 1.3.4
raw patch · 46 files changed
+2360/−2108 lines, 46 filesdep ~template-haskellPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: template-haskell
API changes (from Hackage documentation)
Files
- CHANGELOG.md +4/−0
- aeson-schemas.cabal +6/−6
- bench/Benchmarks/Data/Objects.hs +14/−8
- bench/Benchmarks/Data/Schemas.hs +59/−55
- bench/Benchmarks/Data/Schemas/TH.hs +15/−12
- bench/Benchmarks/FromJSON.hs +23/−17
- bench/Benchmarks/SchemaQQ.hs +34/−26
- bench/Benchmarks/Show.hs +22/−16
- bench/Benchmarks/ToJSON.hs +22/−16
- bench/Main.hs +7/−6
- bench/Utils/DeepSeq.hs +11/−1
- src/Data/Aeson/Schema.hs +16/−15
- src/Data/Aeson/Schema/Internal.hs +149/−130
- src/Data/Aeson/Schema/Key.hs +34/−32
- src/Data/Aeson/Schema/TH.hs +11/−10
- src/Data/Aeson/Schema/TH/Enum.hs +89/−83
- src/Data/Aeson/Schema/TH/Get.hs +96/−92
- src/Data/Aeson/Schema/TH/Getter.hs +65/−61
- src/Data/Aeson/Schema/TH/Parse.hs +75/−59
- src/Data/Aeson/Schema/TH/Schema.hs +130/−115
- src/Data/Aeson/Schema/TH/Unwrap.hs +75/−68
- src/Data/Aeson/Schema/TH/Utils.hs +86/−90
- src/Data/Aeson/Schema/Type.hs +58/−50
- src/Data/Aeson/Schema/Utils/All.hs +4/−4
- src/Data/Aeson/Schema/Utils/Invariant.hs +12/−9
- src/Data/Aeson/Schema/Utils/NameLike.hs +10/−11
- src/Data/Aeson/Schema/Utils/Sum.hs +82/−74
- test/Main.hs +12/−9
- test/TestUtils.hs +29/−25
- test/TestUtils/Arbitrary.hs +155/−121
- test/TestUtils/DeepSeq.hs +11/−1
- test/Tests/EnumTH.hs +58/−49
- test/Tests/GetQQ.hs +266/−254
- test/Tests/GetQQ/TH.hs +20/−13
- test/Tests/MkGetter.hs +31/−24
- test/Tests/Object.hs +17/−15
- test/Tests/Object/Eq.hs +9/−7
- test/Tests/Object/FromJSON.hs +89/−56
- test/Tests/Object/FromJSON/TH.hs +4/−4
- test/Tests/Object/Show.hs +44/−54
- test/Tests/Object/ToJSON.hs +10/−8
- test/Tests/SchemaQQ.hs +170/−199
- test/Tests/SchemaQQ/TH.hs +45/−33
- test/Tests/SumType.hs +61/−53
- test/Tests/UnwrapQQ.hs +73/−81
- test/Tests/UnwrapQQ/TH.hs +47/−36
CHANGELOG.md view
@@ -1,5 +1,9 @@ ## Upcoming +## 1.3.4++* Support `template-haskell-2.17.0.0` for GHC 9+ ## 1.3.3 * Fix test failure in newer Stack snapshots
aeson-schemas.cabal view
@@ -1,13 +1,13 @@ cabal-version: >= 1.10 --- This file has been generated from package.yaml by hpack version 0.33.0.+-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack ----- hash: 80faccce54f3481d8cd37abc188cd5c521e19f5f78f181e08be5c8acd2c0a432+-- hash: c3827569da0ed7cd2f7ccd6e6846b6f0607403409198a8340ccc23ec205390aa name: aeson-schemas-version: 1.3.3+version: 1.3.4 synopsis: Easily consume JSON data on-demand with type-safety description: Parse JSON data easily and safely without defining new data types. Useful for deeply nested JSON data, which is difficult to parse using the default@@ -81,7 +81,7 @@ , first-class-families >=0.3.0.0 && <0.9 , hashable >=1.2.7.0 && <1.4 , megaparsec >=6.0.0 && <10- , template-haskell >=2.12.0.0 && <2.17+ , template-haskell >=2.12.0.0 && <2.18 , text >=1.2.2.2 && <1.3 , unordered-containers >=0.2.8.0 && <0.3 if impl(ghc >= 8.0)@@ -134,7 +134,7 @@ , tasty-golden , tasty-hunit , tasty-quickcheck- , template-haskell >=2.12.0.0 && <2.17+ , template-haskell >=2.12.0.0 && <2.18 , text >=1.2.2.2 && <1.3 , th-orphans , th-test-utils@@ -170,7 +170,7 @@ , first-class-families >=0.3.0.0 && <0.9 , hashable >=1.2.7.0 && <1.4 , megaparsec >=6.0.0 && <10- , template-haskell >=2.12.0.0 && <2.17+ , template-haskell >=2.12.0.0 && <2.18 , text >=1.2.2.2 && <1.3 , th-test-utils , unordered-containers >=0.2.8.0 && <0.3
bench/Benchmarks/Data/Objects.hs view
@@ -10,18 +10,22 @@ module Benchmarks.Data.Objects where -import Data.Aeson (ToJSON(..), Value)+import Data.Aeson (ToJSON (..), Value) import Data.Dynamic (Dynamic, Typeable, toDyn) import qualified Data.HashMap.Strict as HashMap-import Data.Proxy (Proxy(..))+import Data.Proxy (Proxy (..)) import Data.Text (Text) import qualified Data.Text as Text -import Data.Aeson.Schema.Internal (Object(..), SchemaResult)+import Data.Aeson.Schema.Internal (Object (..), SchemaResult) import Data.Aeson.Schema.Key (IsSchemaKey, SchemaKey, fromSchemaKey)-import Data.Aeson.Schema.Type- (IsSchemaObjectMap, SchemaType, SchemaType'(..), ToSchemaObject)-import Data.Aeson.Schema.Utils.All (All(..))+import Data.Aeson.Schema.Type (+ IsSchemaObjectMap,+ SchemaType,+ SchemaType' (..),+ ToSchemaObject,+ )+import Data.Aeson.Schema.Utils.All (All (..)) type MockSchema schema = ( MockSchemaResult (ToSchemaObject schema)@@ -38,14 +42,16 @@ class Typeable (SchemaResult schema) => MockSchemaResult (schema :: SchemaType) where schemaResult :: Proxy schema -> SchemaResult schema -instance MockSchemaResult ('SchemaScalar Int) where+instance MockSchemaResult ( 'SchemaScalar Int) where schemaResult _ = 42 instance ( All MockSchemaResultPair pairs , IsSchemaObjectMap pairs , Typeable pairs- ) => MockSchemaResult ('SchemaObject pairs) where+ ) =>+ MockSchemaResult ( 'SchemaObject pairs)+ where schemaResult _ = UnsafeObject $ HashMap.fromList $ mapAll @MockSchemaResultPair @pairs schemaResultPair class MockSchemaResultPair (pair :: (SchemaKey, SchemaType)) where
bench/Benchmarks/Data/Schemas.hs view
@@ -1,10 +1,10 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TemplateHaskell #-} -module Benchmarks.Data.Schemas- ( module Benchmarks.Data.Schemas- , module Benchmarks.Data.Schemas.TH- ) where+module Benchmarks.Data.Schemas (+ module Benchmarks.Data.Schemas,+ module Benchmarks.Data.Schemas.TH,+) where import Control.Monad (forM) import Data.Char (chr, toUpper)@@ -20,24 +20,25 @@ -- type Schema5 = { a1: Int, a2: Int, ... a5: Int } -- type Schema10 = { a1: Int, a2: Int, ... a10: Int } -- type Schema100 = { a1: Int, a2: Int, ... a100: Int }-$(do- -- The sizes of schemas to generate- let schemaSizes = [1, 5, 10, 100]- allSchemas = flip map schemaSizes $ \n ->- let name = "Schema" ++ show n- in (n, name, mkName name)+$( do+ -- The sizes of schemas to generate+ let schemaSizes = [1, 5, 10, 100]+ allSchemas = flip map schemaSizes $ \n ->+ let name = "Schema" ++ show n+ in (n, name, mkName name) - concat <$> sequence- [ forM allSchemas $ \(n, _, name) -> genSchema name $ keysTo n- , [d|- sizedSchemas :: [(Int, String)]- sizedSchemas = $(lift $ flip map allSchemas $ \(n, name, _) -> (n, name))+ concat+ <$> sequence+ [ forM allSchemas $ \(n, _, name) -> genSchema name $ keysTo n+ , [d|+ sizedSchemas :: [(Int, String)]+ sizedSchemas = $(lift $ flip map allSchemas $ \(n, name, _) -> (n, name)) - sizedSchemasNames :: [(String, Name)]- sizedSchemasNames = $(lift $ flip map allSchemas $ \(_, name, thName) -> (name, thName))- |]- ]- )+ sizedSchemasNames :: [(String, Name)]+ sizedSchemasNames = $(lift $ flip map allSchemas $ \(_, name, thName) -> (name, thName))+ |]+ ]+ ) -- Generates: --@@ -45,25 +46,27 @@ -- type SchemaNest5 = { a1: { a2: { ... a5: Int } } -- type SchemaNest10 = { a1: { a2: { ... a10: Int } } -- type SchemaNest100 = { a1: { a2: { ... a100: Int } }-$(do- -- The depths of schemas to generate- let schemaSizes = [1, 5, 10, 100]- allSchemas = flip map schemaSizes $ \n ->- let name = "SchemaNest" ++ show n- in (n, name, mkName name)+$( do+ -- The depths of schemas to generate+ let schemaSizes = [1, 5, 10, 100]+ allSchemas = flip map schemaSizes $ \n ->+ let name = "SchemaNest" ++ show n+ in (n, name, mkName name) - concat <$> sequence- [ forM allSchemas $ \(n, _, name) -> genSchema' name $- foldr (\i inner -> genSchemaDef [Field (mkField i) inner]) "Int" [1..n]- , [d|- nestedSchemas :: [(Int, String)]- nestedSchemas = $(lift $ flip map allSchemas $ \(n, name, _) -> (n, name))+ concat+ <$> sequence+ [ forM allSchemas $ \(n, _, name) ->+ genSchema' name $+ foldr (\i inner -> genSchemaDef [Field (mkField i) inner]) "Int" [1 .. n]+ , [d|+ nestedSchemas :: [(Int, String)]+ nestedSchemas = $(lift $ flip map allSchemas $ \(n, name, _) -> (n, name)) - nestedSchemasNames :: [(String, Name)]- nestedSchemasNames = $(lift $ flip map allSchemas $ \(_, name, thName) -> (name, thName))- |]- ]- )+ nestedSchemasNames :: [(String, Name)]+ nestedSchemasNames = $(lift $ flip map allSchemas $ \(_, name, thName) -> (name, thName))+ |]+ ]+ ) -- Generates: --@@ -74,23 +77,24 @@ -- type SchemaA2 = { a2: Int } -- type SchemaB2 = { a2: Int } -- ...-$(do- let numSchemas = 100- allSchemas = flip map [1..numSchemas] $ \n ->- let (q, r) = n `divMod` 26- c = chr $ 97 + r -- a .. z- field = c : show q- name = "Schema" ++ map toUpper field- in (field, name, mkName name)+$( do+ let numSchemas = 100+ allSchemas = flip map [1 .. numSchemas] $ \n ->+ let (q, r) = n `divMod` 26+ c = chr $ 97 + r -- a .. z+ field = c : show q+ name = "Schema" ++ map toUpper field+ in (field, name, mkName name) - concat <$> sequence- [ forM allSchemas $ \(field, _, name) -> genSchema name [Field field "Int"]- , [d|- singleSchemas :: [String]- singleSchemas = $(lift $ flip map allSchemas $ \(_, name, _) -> name)+ concat+ <$> sequence+ [ forM allSchemas $ \(field, _, name) -> genSchema name [Field field "Int"]+ , [d|+ singleSchemas :: [String]+ singleSchemas = $(lift $ flip map allSchemas $ \(_, name, _) -> name) - singleSchemasNames :: [(String, Name)]- singleSchemasNames = $(lift $ flip map allSchemas $ \(_, name, thName) -> (name, thName))- |]- ]- )+ singleSchemasNames :: [(String, Name)]+ singleSchemasNames = $(lift $ flip map allSchemas $ \(_, name, thName) -> (name, thName))+ |]+ ]+ )
bench/Benchmarks/Data/Schemas/TH.hs view
@@ -1,13 +1,13 @@ {-# LANGUAGE LambdaCase #-} -module Benchmarks.Data.Schemas.TH- ( SchemaDef(..)- , genSchema- , genSchema'- , genSchemaDef- , keysTo- , mkField- ) where+module Benchmarks.Data.Schemas.TH (+ SchemaDef (..),+ genSchema,+ genSchema',+ genSchemaDef,+ keysTo,+ mkField,+) where import Data.List (intercalate) import Language.Haskell.TH@@ -16,9 +16,12 @@ import Data.Aeson.Schema (schema) data SchemaDef- = Field String String -- ^ { a: Int }- | Include String String -- ^ { a: #OtherSchema }- | Ref String -- ^ { #OtherSchema }+ = -- | { a: Int }+ Field String String+ | -- | { a: #OtherSchema }+ Include String String+ | -- | { #OtherSchema }+ Ref String genSchema :: Name -> [SchemaDef] -> DecQ genSchema name = genSchema' name . genSchemaDef@@ -35,7 +38,7 @@ Ref name -> "#" ++ name keysTo :: Int -> [SchemaDef]-keysTo n = map (\i -> Field (mkField i) "Int") [1..n]+keysTo n = map (\i -> Field (mkField i) "Int") [1 .. n] mkField :: Int -> String mkField i = "a" ++ show i
bench/Benchmarks/FromJSON.hs view
@@ -7,7 +7,7 @@ module Benchmarks.FromJSON where -import Control.DeepSeq (NFData(..))+import Control.DeepSeq (NFData (..)) import Criterion.Main import qualified Data.Aeson as Aeson @@ -17,24 +17,30 @@ import Benchmarks.Data.Schemas benchmarks :: Benchmark-benchmarks = bgroup "FromJSON instance"- [ byKeys- , byNestedKeys- ]+benchmarks =+ bgroup+ "FromJSON instance"+ [ byKeys+ , byNestedKeys+ ] where- byKeys = bgroup "# of keys"- [ bench "1" $ nf (Aeson.fromJSON @(Object Schema1)) (schemaValue @Schema1)- , bench "5" $ nf (Aeson.fromJSON @(Object Schema5)) (schemaValue @Schema5)- , bench "10" $ nf (Aeson.fromJSON @(Object Schema10)) (schemaValue @Schema10)- , bench "100" $ nf (Aeson.fromJSON @(Object Schema100)) (schemaValue @Schema100)- ]+ byKeys =+ bgroup+ "# of keys"+ [ bench "1" $ nf (Aeson.fromJSON @(Object Schema1)) (schemaValue @Schema1)+ , bench "5" $ nf (Aeson.fromJSON @(Object Schema5)) (schemaValue @Schema5)+ , bench "10" $ nf (Aeson.fromJSON @(Object Schema10)) (schemaValue @Schema10)+ , bench "100" $ nf (Aeson.fromJSON @(Object Schema100)) (schemaValue @Schema100)+ ] - byNestedKeys = bgroup "# of nested keys"- [ bench "1" $ nf (Aeson.fromJSON @(Object SchemaNest1)) (schemaValue @SchemaNest1)- , bench "5" $ nf (Aeson.fromJSON @(Object SchemaNest5)) (schemaValue @SchemaNest5)- , bench "10" $ nf (Aeson.fromJSON @(Object SchemaNest10)) (schemaValue @SchemaNest10)- , bench "100" $ nf (Aeson.fromJSON @(Object SchemaNest100)) (schemaValue @SchemaNest100)- ]+ byNestedKeys =+ bgroup+ "# of nested keys"+ [ bench "1" $ nf (Aeson.fromJSON @(Object SchemaNest1)) (schemaValue @SchemaNest1)+ , bench "5" $ nf (Aeson.fromJSON @(Object SchemaNest5)) (schemaValue @SchemaNest5)+ , bench "10" $ nf (Aeson.fromJSON @(Object SchemaNest10)) (schemaValue @SchemaNest10)+ , bench "100" $ nf (Aeson.fromJSON @(Object SchemaNest100)) (schemaValue @SchemaNest100)+ ] {- Orphans -}
bench/Benchmarks/SchemaQQ.hs view
@@ -3,9 +3,13 @@ module Benchmarks.SchemaQQ where import Criterion.Main-import Language.Haskell.TH.Quote (QuasiQuoter(quoteType))-import Language.Haskell.TH.TestUtils- (QMode(..), QState(..), loadNames, runTestQ)+import Language.Haskell.TH.Quote (QuasiQuoter (quoteType))+import Language.Haskell.TH.TestUtils (+ QMode (..),+ QState (..),+ loadNames,+ runTestQ,+ ) import qualified Data.Aeson.Schema @@ -13,57 +17,61 @@ import Utils.DeepSeq () benchmarks :: Benchmark-benchmarks = bgroup "schema quasiquoter"- [ byKeys- , byNestedKeys- , byNumOfIncluded- , byKeysInIncluded- , byNumOfExtended- , byKeysInExtended- ]+benchmarks =+ bgroup+ "schema quasiquoter"+ [ byKeys+ , byNestedKeys+ , byNumOfIncluded+ , byKeysInIncluded+ , byNumOfExtended+ , byKeysInExtended+ ] where byKeys = bgroup "# of keys" $ flip map [1, 5, 10, 100] $ \n -> let schemaDef = genSchemaDef $ keysTo n- in bench (show n) $ nf runSchema schemaDef+ in bench (show n) $ nf runSchema schemaDef byNestedKeys = bgroup "# of nested keys" $ flip map [1, 5, 10, 100] $ \n -> let schemaDef = iterateN n (\prev -> genSchemaDef [Field "a" prev]) "Int"- in bench (show n) $ nf runSchema schemaDef+ in bench (show n) $ nf runSchema schemaDef byNumOfIncluded = bgroup "Include given # of schemas" $ flip map [1, 5, 10, 100] $ \n -> let schemaDef = genSchemaDef $ map (\name -> Include name name) $ take n singleSchemas- in bench (show n) $ nf runSchema schemaDef+ in bench (show n) $ nf runSchema schemaDef byKeysInIncluded = bgroup "Include schema with given # of keys" $ flip map sizedSchemas $ \(n, schema) -> let schemaDef = genSchemaDef [Include "a" schema]- in bench (show n) $ nf runSchema schemaDef+ in bench (show n) $ nf runSchema schemaDef byNumOfExtended = bgroup "Extend given # of schemas" $ flip map [1, 5, 10, 100] $ \n -> let schemaDef = genSchemaDef $ map Ref $ take n singleSchemas- in bench (show n) $ nf runSchema schemaDef+ in bench (show n) $ nf runSchema schemaDef byKeysInExtended = bgroup "Extend schema with given # of keys" $ flip map sizedSchemas $ \(n, schema) -> let schemaDef = genSchemaDef [Field "a" "Int", Ref schema]- in bench (show n) $ nf runSchema schemaDef+ in bench (show n) $ nf runSchema schemaDef runSchema =- let qstate = QState- { mode = MockQ- , knownNames = sizedSchemasNames ++ singleSchemasNames- , reifyInfo = $(loadNames $ map snd $ sizedSchemasNames ++ singleSchemasNames)- }- in runTestQ qstate . quoteType Data.Aeson.Schema.schema+ let qstate =+ QState+ { mode = MockQ+ , knownNames = sizedSchemasNames ++ singleSchemasNames+ , reifyInfo = $(loadNames $ map snd $ sizedSchemasNames ++ singleSchemasNames)+ }+ in runTestQ qstate . quoteType Data.Aeson.Schema.schema {- Utilities -} --- | Apply the given functions the given number of times.------ The first parameter must be >= 0.+{- | Apply the given functions the given number of times.++ The first parameter must be >= 0.+-} iterateN :: Int -> (a -> a) -> a -> a iterateN n f x = iterate f x !! n
bench/Benchmarks/Show.hs view
@@ -9,21 +9,27 @@ import Benchmarks.Data.Schemas benchmarks :: Benchmark-benchmarks = bgroup "Show instance"- [ byKeys- , byNestedKeys- ]+benchmarks =+ bgroup+ "Show instance"+ [ byKeys+ , byNestedKeys+ ] where- byKeys = bgroup "# of keys"- [ bench "1" $ nf show (schemaObject @Schema1)- , bench "5" $ nf show (schemaObject @Schema5)- , bench "10" $ nf show (schemaObject @Schema10)- , bench "100" $ nf show (schemaObject @Schema100)- ]+ byKeys =+ bgroup+ "# of keys"+ [ bench "1" $ nf show (schemaObject @Schema1)+ , bench "5" $ nf show (schemaObject @Schema5)+ , bench "10" $ nf show (schemaObject @Schema10)+ , bench "100" $ nf show (schemaObject @Schema100)+ ] - byNestedKeys = bgroup "# of nested keys"- [ bench "1" $ nf show (schemaObject @SchemaNest1)- , bench "5" $ nf show (schemaObject @SchemaNest5)- , bench "10" $ nf show (schemaObject @SchemaNest10)- , bench "100" $ nf show (schemaObject @SchemaNest100)- ]+ byNestedKeys =+ bgroup+ "# of nested keys"+ [ bench "1" $ nf show (schemaObject @SchemaNest1)+ , bench "5" $ nf show (schemaObject @SchemaNest5)+ , bench "10" $ nf show (schemaObject @SchemaNest10)+ , bench "100" $ nf show (schemaObject @SchemaNest100)+ ]
bench/Benchmarks/ToJSON.hs view
@@ -10,21 +10,27 @@ import Benchmarks.Data.Schemas benchmarks :: Benchmark-benchmarks = bgroup "ToJSON instance"- [ byKeys- , byNestedKeys- ]+benchmarks =+ bgroup+ "ToJSON instance"+ [ byKeys+ , byNestedKeys+ ] where- byKeys = bgroup "# of keys"- [ bench "1" $ nf Aeson.toJSON (schemaObject @Schema1)- , bench "5" $ nf Aeson.toJSON (schemaObject @Schema5)- , bench "10" $ nf Aeson.toJSON (schemaObject @Schema10)- , bench "100" $ nf Aeson.toJSON (schemaObject @Schema100)- ]+ byKeys =+ bgroup+ "# of keys"+ [ bench "1" $ nf Aeson.toJSON (schemaObject @Schema1)+ , bench "5" $ nf Aeson.toJSON (schemaObject @Schema5)+ , bench "10" $ nf Aeson.toJSON (schemaObject @Schema10)+ , bench "100" $ nf Aeson.toJSON (schemaObject @Schema100)+ ] - byNestedKeys = bgroup "# of nested keys"- [ bench "1" $ nf Aeson.toJSON (schemaObject @SchemaNest1)- , bench "5" $ nf Aeson.toJSON (schemaObject @SchemaNest5)- , bench "10" $ nf Aeson.toJSON (schemaObject @SchemaNest10)- , bench "100" $ nf Aeson.toJSON (schemaObject @SchemaNest100)- ]+ byNestedKeys =+ bgroup+ "# of nested keys"+ [ bench "1" $ nf Aeson.toJSON (schemaObject @SchemaNest1)+ , bench "5" $ nf Aeson.toJSON (schemaObject @SchemaNest5)+ , bench "10" $ nf Aeson.toJSON (schemaObject @SchemaNest10)+ , bench "100" $ nf Aeson.toJSON (schemaObject @SchemaNest100)+ ]
bench/Main.hs view
@@ -6,9 +6,10 @@ import qualified Benchmarks.ToJSON main :: IO ()-main = defaultMain- [ Benchmarks.SchemaQQ.benchmarks- , Benchmarks.Show.benchmarks- , Benchmarks.FromJSON.benchmarks- , Benchmarks.ToJSON.benchmarks- ]+main =+ defaultMain+ [ Benchmarks.SchemaQQ.benchmarks+ , Benchmarks.Show.benchmarks+ , Benchmarks.FromJSON.benchmarks+ , Benchmarks.ToJSON.benchmarks+ ]
bench/Utils/DeepSeq.hs view
@@ -3,7 +3,8 @@ module Utils.DeepSeq () where -import Control.DeepSeq (NFData(..))+import Control.DeepSeq (NFData (..))+ #if MIN_VERSION_template_haskell(2,16,0) import Control.DeepSeq (rwhnf) import GHC.ForeignPtr (ForeignPtr)@@ -54,7 +55,16 @@ instance NFData TypeFamilyHead instance NFData TyLit instance NFData TySynEqn++#if MIN_VERSION_template_haskell(2,17,0)+instance NFData Specificity+#endif++#if MIN_VERSION_template_haskell(2,17,0)+instance NFData flag => NFData (TyVarBndr flag)+#else instance NFData TyVarBndr+#endif #if MIN_VERSION_template_haskell(2,16,0) instance NFData Bytes
src/Data/Aeson/Schema.hs view
@@ -1,4 +1,4 @@-{-|+{- | Module : Data.Aeson.Schema Maintainer : Brandon Chinn <brandon@leapyear.io> Stability : experimental@@ -8,21 +8,22 @@ extracting information using quasiquoters that will check if a given query path is valid at compile-time. -}+module Data.Aeson.Schema (+ -- * Object+ Object,+ toMap, -module Data.Aeson.Schema- ( -- * Object- Object- , toMap- -- * Schemas- , Schema- , IsSchema- , showSchema- -- * Quasiquoters for extracting or manipulating JSON data or schemas- , schema- , get- , unwrap- , mkGetter- ) where+ -- * Schemas+ Schema,+ IsSchema,+ showSchema,++ -- * Quasiquoters for extracting or manipulating JSON data or schemas+ schema,+ get,+ unwrap,+ mkGetter,+) where import Data.Aeson.Schema.Internal import Data.Aeson.Schema.TH
src/Data/Aeson/Schema/Internal.hs view
@@ -1,11 +1,3 @@-{-|-Module : Data.Aeson.Schema.Internal-Maintainer : Brandon Chinn <brandon@leapyear.io>-Stability : experimental-Portability : portable--Internal definitions for declaring JSON schemas.--} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-}@@ -24,13 +16,22 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{- |+Module : Data.Aeson.Schema.Internal+Maintainer : Brandon Chinn <brandon@leapyear.io>+Stability : experimental+Portability : portable++Internal definitions for declaring JSON schemas.+-} module Data.Aeson.Schema.Internal where -import Control.Applicative (Alternative(..))+import Control.Applicative (Alternative (..))+ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail (MonadFail) #endif-import Data.Aeson (FromJSON(..), ToJSON(..), Value(..))+import Data.Aeson (FromJSON (..), ToJSON (..), Value (..)) import qualified Data.Aeson as Aeson import Data.Aeson.Types (Parser) import Data.Dynamic (Dynamic, fromDynamic, toDyn)@@ -38,49 +39,55 @@ import qualified Data.HashMap.Strict as HashMap import Data.List (intersperse) import Data.Maybe (fromMaybe)-import Data.Proxy (Proxy(..))+import Data.Proxy (Proxy (..)) import Data.Text (Text) import qualified Data.Text as Text import Data.Typeable (Typeable) import Fcf (type (<=<), type (=<<)) import qualified Fcf import GHC.Exts (toList)-import GHC.TypeLits- (ErrorMessage(..), KnownSymbol, Symbol, TypeError, symbolVal)+import GHC.TypeLits (+ ErrorMessage (..),+ KnownSymbol,+ Symbol,+ TypeError,+ symbolVal,+ ) -import Data.Aeson.Schema.Key- ( IsSchemaKey(..)- , SchemaKey- , SchemaKey'(..)- , fromSchemaKeyV- , getContext- , showSchemaKey- , toContext- )-import Data.Aeson.Schema.Type- ( FromSchema- , IsSchemaObjectMap- , IsSchemaType(..)- , Schema- , Schema'(..)- , SchemaType- , SchemaType'(..)- , ToSchemaObject- , showSchemaTypeV- , showSchemaV- , toSchemaV- )-import Data.Aeson.Schema.Utils.All (All(..))+import Data.Aeson.Schema.Key (+ IsSchemaKey (..),+ SchemaKey,+ SchemaKey' (..),+ fromSchemaKeyV,+ getContext,+ showSchemaKey,+ toContext,+ )+import Data.Aeson.Schema.Type (+ FromSchema,+ IsSchemaObjectMap,+ IsSchemaType (..),+ Schema,+ Schema' (..),+ SchemaType,+ SchemaType' (..),+ ToSchemaObject,+ showSchemaTypeV,+ showSchemaV,+ toSchemaV,+ )+import Data.Aeson.Schema.Utils.All (All (..)) import Data.Aeson.Schema.Utils.Invariant (unreachable)-import Data.Aeson.Schema.Utils.Sum (SumType(..))+import Data.Aeson.Schema.Utils.Sum (SumType (..)) {- Schema-validated JSON object -} --- | The object containing JSON data and its schema.------ Has a 'FromJSON' instance, so you can use the usual @Data.Aeson@ decoding functions.------ > obj = decode "{\"a\": 1}" :: Maybe (Object [schema| { a: Int } |])+{- | The object containing JSON data and its schema.++ Has a 'FromJSON' instance, so you can use the usual @Data.Aeson@ decoding functions.++ > obj = decode "{\"a\": 1}" :: Maybe (Object [schema| { a: Int } |])+-} newtype Object (schema :: Schema) = UnsafeObject (HashMap Text Dynamic) instance IsSchema schema => Show (Object schema) where@@ -95,21 +102,23 @@ instance IsSchema schema => ToJSON (Object schema) where toJSON = toValue @(ToSchemaObject schema) --- | Convert an 'Object' into a 'HashMap', losing the type information in the schema.------ @since 1.3.0-toMap :: IsSchema ('Schema schema) => Object ('Schema schema) -> Aeson.Object+{- | Convert an 'Object' into a 'HashMap', losing the type information in the schema.++ @since 1.3.0+-}+toMap :: IsSchema ( 'Schema schema) => Object ( 'Schema schema) -> Aeson.Object toMap = toValueMap {- Type-level schema definitions -} --- | The constraint for most operations involving @Object schema@. If you're writing functions--- on general Objects, you should use this constraint. e.g.------ > logObject :: (MonadLogger m, IsSchema schema) => Object schema -> m ()--- > logObject = logInfoN . Text.pack . show------ @since 1.3.0+{- | The constraint for most operations involving @Object schema@. If you're writing functions+ on general Objects, you should use this constraint. e.g.++ > logObject :: (MonadLogger m, IsSchema schema) => Object schema -> m ()+ > logObject = logInfoN . Text.pack . show++ @since 1.3.0+-} type IsSchema (schema :: Schema) = ( HasSchemaResult (ToSchemaObject schema) , All HasSchemaResultPair (FromSchema schema)@@ -117,13 +126,13 @@ , SchemaResult (ToSchemaObject schema) ~ Object schema ) --- | Show the given schema.------ Usage:------ > type MySchema = [schema| { a: Int } |]--- > showSchema @MySchema---+{- | Show the given schema.++ Usage:++ > type MySchema = [schema| { a: Int } |]+ > showSchema @MySchema+-} showSchema :: forall (schema :: Schema). IsSchema schema => String showSchema = "SchemaObject " ++ showSchemaV schema -- TODO: Remove "SchemaObject" prefix? Or rename to "Schema"? where@@ -138,13 +147,13 @@ -- | A type family mapping SchemaType to the corresponding Haskell type. type family SchemaResult (schema :: SchemaType) where- SchemaResult ('SchemaScalar inner) = inner- SchemaResult ('SchemaMaybe inner) = Maybe (SchemaResult inner)- SchemaResult ('SchemaTry inner) = Maybe (SchemaResult inner)- SchemaResult ('SchemaList inner) = [SchemaResult inner]- SchemaResult ('SchemaUnion schemas) = SumType (SchemaResultList schemas)- SchemaResult ('SchemaObject inner) = Object ('Schema inner)- SchemaResult ('SchemaInclude ('Right schema)) = SchemaResult (ToSchemaObject schema)+ SchemaResult ( 'SchemaScalar inner) = inner+ SchemaResult ( 'SchemaMaybe inner) = Maybe (SchemaResult inner)+ SchemaResult ( 'SchemaTry inner) = Maybe (SchemaResult inner)+ SchemaResult ( 'SchemaList inner) = [SchemaResult inner]+ SchemaResult ( 'SchemaUnion schemas) = SumType (SchemaResultList schemas)+ SchemaResult ( 'SchemaObject inner) = Object ( 'Schema inner)+ SchemaResult ( 'SchemaInclude ( 'Right schema)) = SchemaResult (ToSchemaObject schema) type family SchemaResultList (xs :: [SchemaType]) where SchemaResultList '[] = '[]@@ -166,32 +175,34 @@ default showValue :: Show (SchemaResult schema) => SchemaResult schema -> ShowS showValue = shows -instance (Show inner, Typeable inner, FromJSON inner, ToJSON inner) => HasSchemaResult ('SchemaScalar inner)+instance (Show inner, Typeable inner, FromJSON inner, ToJSON inner) => HasSchemaResult ( 'SchemaScalar inner) -instance (HasSchemaResult inner, Show (SchemaResult inner), ToJSON (SchemaResult inner)) => HasSchemaResult ('SchemaMaybe inner) where+instance (HasSchemaResult inner, Show (SchemaResult inner), ToJSON (SchemaResult inner)) => HasSchemaResult ( 'SchemaMaybe inner) where parseValue path = \case Null -> return Nothing value -> (Just <$> parseValue @inner path value) -instance (HasSchemaResult inner, Show (SchemaResult inner), ToJSON (SchemaResult inner)) => HasSchemaResult ('SchemaTry inner) where+instance (HasSchemaResult inner, Show (SchemaResult inner), ToJSON (SchemaResult inner)) => HasSchemaResult ( 'SchemaTry inner) where parseValue path = wrapTry . parseValue @inner path where wrapTry parser = (Just <$> parser) <|> pure Nothing -instance (HasSchemaResult inner, Show (SchemaResult inner), ToJSON (SchemaResult inner)) => HasSchemaResult ('SchemaList inner) where+instance (HasSchemaResult inner, Show (SchemaResult inner), ToJSON (SchemaResult inner)) => HasSchemaResult ( 'SchemaList inner) where parseValue path = \case Array a -> traverse (parseValue @inner path) (toList a)- value -> parseFail @('SchemaList inner) path value+ value -> parseFail @( 'SchemaList inner) path value instance ( All HasSchemaResult schemas , All IsSchemaType schemas- , Show (SchemaResult ('SchemaUnion schemas))- , FromJSON (SchemaResult ('SchemaUnion schemas))- , ToJSON (SchemaResult ('SchemaUnion schemas))+ , Show (SchemaResult ( 'SchemaUnion schemas))+ , FromJSON (SchemaResult ( 'SchemaUnion schemas))+ , ToJSON (SchemaResult ( 'SchemaUnion schemas)) , ParseSumType schemas- ) => HasSchemaResult ('SchemaUnion (schemas :: [SchemaType])) where- parseValue path value = parseSumType @schemas path value <|> parseFail @('SchemaUnion schemas) path value+ ) =>+ HasSchemaResult ( 'SchemaUnion (schemas :: [SchemaType]))+ where+ parseValue path value = parseSumType @schemas path value <|> parseFail @( 'SchemaUnion schemas) path value class ParseSumType xs where parseSumType :: [Text] -> Value -> Parser (SumType (SchemaResultList xs))@@ -205,10 +216,10 @@ parseHere = Here <$> parseValue @schema path value parseThere = There <$> parseSumType @schemas path value -instance (All HasSchemaResultPair pairs, IsSchemaObjectMap pairs) => HasSchemaResult ('SchemaObject pairs) where+instance (All HasSchemaResultPair pairs, IsSchemaObjectMap pairs) => HasSchemaResult ( 'SchemaObject pairs) where parseValue path = \case Aeson.Object o -> UnsafeObject . HashMap.fromList <$> parseValueMap o- value -> parseFail @('SchemaObject pairs) path value+ value -> parseFail @( 'SchemaObject pairs) path value where parseValueMap :: Aeson.Object -> Parser [(Text, Dynamic)] parseValueMap o = sequence $ mapAll @HasSchemaResultPair @pairs $ \proxy -> parseValuePair proxy path o@@ -227,7 +238,7 @@ concatShowS :: [ShowS] -> ShowS concatShowS = foldr (.) id -toValueMap :: forall pairs. All HasSchemaResultPair pairs => Object ('Schema pairs) -> Aeson.Object+toValueMap :: forall pairs. All HasSchemaResultPair pairs => Object ( 'Schema pairs) -> Aeson.Object toValueMap o = HashMap.unions $ mapAll @HasSchemaResultPair @pairs (\proxy -> toValuePair proxy o) class HasSchemaResultPair (a :: (SchemaKey, SchemaType)) where@@ -239,9 +250,11 @@ ( IsSchemaKey key , HasSchemaResult inner , Typeable (SchemaResult inner)- ) => HasSchemaResultPair '(key, inner) where+ ) =>+ HasSchemaResultPair '(key, inner)+ where parseValuePair _ path o = do- inner <- parseValue @inner (key:path) $ getContext schemaKey o+ inner <- parseValue @inner (key : path) $ getContext schemaKey o return (key, toDyn inner) where schemaKey = toSchemaKeyV $ Proxy @key@@ -256,7 +269,7 @@ where val = unsafeGetKey @inner (Proxy @(FromSchemaKey key)) o -instance IsSchema schema => HasSchemaResult ('SchemaInclude ('Right schema)) where+instance IsSchema schema => HasSchemaResult ( 'SchemaInclude ( 'Right schema)) where parseValue = parseValue @(ToSchemaObject schema) toValue = toValue @(ToSchemaObject schema) showValue = showValue @(ToSchemaObject schema)@@ -265,9 +278,10 @@ parseFail :: forall (schema :: SchemaType) m a. (MonadFail m, HasSchemaResult schema) => [Text] -> Value -> m a parseFail path value = fail $ msg ++ ": " ++ ellipses 200 (show value) where- msg = if null path- then "Could not parse schema " ++ schema'- else "Could not parse path '" ++ path' ++ "' with schema " ++ schema'+ msg =+ if null path+ then "Could not parse schema " ++ schema'+ else "Could not parse path '" ++ path' ++ "' with schema " ++ schema' path' = Text.unpack . Text.intercalate "." $ reverse path schema' = "`" ++ showSchemaType @schema ++ "`" ellipses n s = if length s > n then take n s ++ "..." else s@@ -275,60 +289,65 @@ {- Lookups within SchemaObject -} data UnSchemaKey :: SchemaKey -> Fcf.Exp Symbol-type instance Fcf.Eval (UnSchemaKey ('NormalKey key)) = Fcf.Eval (Fcf.Pure key)-type instance Fcf.Eval (UnSchemaKey ('PhantomKey key)) = Fcf.Eval (Fcf.Pure key)+type instance Fcf.Eval (UnSchemaKey ( 'NormalKey key)) = Fcf.Eval (Fcf.Pure key)+type instance Fcf.Eval (UnSchemaKey ( 'PhantomKey key)) = Fcf.Eval (Fcf.Pure key) -- first-class-families-0.3.0.1 doesn't support partially applying Lookup type Lookup a = Fcf.Map Fcf.Snd <=< Fcf.Find (Fcf.TyEq a <=< Fcf.Fst) -- | The type-level function that return the schema of the given key in a 'SchemaObject'. type family LookupSchema (key :: Symbol) (schema :: Schema) :: SchemaType where- LookupSchema key ('Schema schema) = Fcf.Eval- ( Fcf.FromMaybe (TypeError- ( 'Text "Key '"- ':<>: 'Text key- ':<>: 'Text "' does not exist in the following schema:"- ':$$: 'ShowType schema- )+ LookupSchema key ( 'Schema schema) =+ Fcf.Eval+ ( Fcf.FromMaybe+ ( TypeError+ ( 'Text "Key '"+ ':<>: 'Text key+ ':<>: 'Text "' does not exist in the following schema:"+ ':$$: 'ShowType schema+ )+ )+ =<< Lookup key+ =<< Fcf.Map (Fcf.Bimap UnSchemaKey Fcf.Pure) schema )- =<< Lookup key =<< Fcf.Map (Fcf.Bimap UnSchemaKey Fcf.Pure) schema- ) --- | Get a key from the given 'Data.Aeson.Schema.Internal.Object', returned as the type encoded in--- its schema.------ > let o = .. :: Object--- > ( 'SchemaObject--- > '[ '("foo", 'SchemaInt)--- > , '("bar", 'SchemaObject--- > '[ '("name", 'SchemaText)--- > ]--- > , '("baz", 'SchemaMaybe 'SchemaBool)--- > ]--- > )--- >--- > getKey (Proxy @"foo") o :: Bool--- > getKey (Proxy @"bar") o :: Object ('SchemaObject '[ '("name", 'SchemaText) ])--- > getKey (Proxy @"name") $ getKey @"bar" o :: Text--- > getKey (Proxy @"baz") o :: Maybe Bool----getKey- :: forall (key :: Symbol) (schema :: Schema) (endSchema :: SchemaType) result.- ( endSchema ~ LookupSchema key schema- , result ~ SchemaResult endSchema- , KnownSymbol key- , Typeable result- , Typeable endSchema- )- => Proxy key- -> Object schema- -> result+{- | Get a key from the given 'Data.Aeson.Schema.Internal.Object', returned as the type encoded in+ its schema.++ > let o = .. :: Object+ > ( 'SchemaObject+ > '[ '("foo", 'SchemaInt)+ > , '("bar", 'SchemaObject+ > '[ '("name", 'SchemaText)+ > ]+ > , '("baz", 'SchemaMaybe 'SchemaBool)+ > ]+ > )+ >+ > getKey (Proxy @"foo") o :: Bool+ > getKey (Proxy @"bar") o :: Object ('SchemaObject '[ '("name", 'SchemaText) ])+ > getKey (Proxy @"name") $ getKey @"bar" o :: Text+ > getKey (Proxy @"baz") o :: Maybe Bool+-}+getKey ::+ forall (key :: Symbol) (schema :: Schema) (endSchema :: SchemaType) result.+ ( endSchema ~ LookupSchema key schema+ , result ~ SchemaResult endSchema+ , KnownSymbol key+ , Typeable result+ , Typeable endSchema+ ) =>+ Proxy key ->+ Object schema ->+ result getKey = unsafeGetKey @endSchema -unsafeGetKey- :: forall (endSchema :: SchemaType) (key :: Symbol) (schema :: Schema)- . (KnownSymbol key, Typeable (SchemaResult endSchema))- => Proxy key -> Object schema -> SchemaResult endSchema+unsafeGetKey ::+ forall (endSchema :: SchemaType) (key :: Symbol) (schema :: Schema).+ (KnownSymbol key, Typeable (SchemaResult endSchema)) =>+ Proxy key ->+ Object schema ->+ SchemaResult endSchema unsafeGetKey keyProxy (UnsafeObject object) = fromMaybe (unreachable $ "Could not load key: " ++ key) $ fromDynamic (object ! Text.pack key)
src/Data/Aeson/Schema/Key.hs view
@@ -1,11 +1,3 @@-{-|-Module : Data.Aeson.Schema.Key-Maintainer : Brandon Chinn <brandon@leapyear.io>-Stability : experimental-Portability : portable--Defines a SchemaKey.--} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-}@@ -17,23 +9,31 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeInType #-} -module Data.Aeson.Schema.Key- ( SchemaKey'(..)- , SchemaKeyV- , fromSchemaKeyV- , showSchemaKeyV- , getContext- , toContext- , SchemaKey- , IsSchemaKey(..)- , fromSchemaKey- , showSchemaKey- ) where+{- |+Module : Data.Aeson.Schema.Key+Maintainer : Brandon Chinn <brandon@leapyear.io>+Stability : experimental+Portability : portable +Defines a SchemaKey.+-}+module Data.Aeson.Schema.Key (+ SchemaKey' (..),+ SchemaKeyV,+ fromSchemaKeyV,+ showSchemaKeyV,+ getContext,+ toContext,+ SchemaKey,+ IsSchemaKey (..),+ fromSchemaKey,+ showSchemaKey,+) where+ import qualified Data.Aeson as Aeson-import Data.Hashable (Hashable) import qualified Data.HashMap.Strict as HashMap-import Data.Proxy (Proxy(..))+import Data.Hashable (Hashable)+import Data.Proxy (Proxy (..)) import qualified Data.Text as Text import GHC.Generics (Generic) import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)@@ -44,9 +44,9 @@ -- | A key in a JSON object schema. data SchemaKey' s = NormalKey s- | PhantomKey s- -- ^ A key that doesn't actually exist in the object, but whose content should be parsed from+ | -- | A key that doesn't actually exist in the object, but whose content should be parsed from -- the current object.+ PhantomKey s deriving (Show, Eq, Generic, Hashable, Lift) -- | A value-level SchemaKey@@ -60,8 +60,9 @@ showSchemaKeyV (NormalKey key) = show key showSchemaKeyV (PhantomKey key) = "[" ++ key ++ "]" --- | Given schema `{ key: innerSchema }` for JSON data `{ key: val1 }`, get the JSON--- Value that `innerSchema` should parse.+{- | Given schema `{ key: innerSchema }` for JSON data `{ key: val1 }`, get the JSON+ Value that `innerSchema` should parse.+-} getContext :: SchemaKeyV -> Aeson.Object -> Aeson.Value getContext = \case -- `innerSchema` should parse `val1`@@ -69,8 +70,9 @@ -- `innerSchema` should parse the same object that `key` is in PhantomKey _ -> Aeson.Object --- | Given JSON data `val` adhering to `innerSchema`, get the JSON object that should be--- merged with the outer JSON object.+{- | Given JSON data `val` adhering to `innerSchema`, get the JSON object that should be+ merged with the outer JSON object.+-} toContext :: SchemaKeyV -> Aeson.Value -> Aeson.Object toContext = \case -- `val` should be inserted with key `key`@@ -90,12 +92,12 @@ type FromSchemaKey key :: Symbol toSchemaKeyV :: Proxy key -> SchemaKeyV -instance KnownSymbol key => IsSchemaKey ('NormalKey key) where- type FromSchemaKey ('NormalKey key) = key+instance KnownSymbol key => IsSchemaKey ( 'NormalKey key) where+ type FromSchemaKey ( 'NormalKey key) = key toSchemaKeyV _ = NormalKey $ symbolVal $ Proxy @key -instance KnownSymbol key => IsSchemaKey ('PhantomKey key) where- type FromSchemaKey ('PhantomKey key) = key+instance KnownSymbol key => IsSchemaKey ( 'PhantomKey key) where+ type FromSchemaKey ( 'PhantomKey key) = key toSchemaKeyV _ = PhantomKey $ symbolVal $ Proxy @key fromSchemaKey :: forall key. IsSchemaKey key => String
src/Data/Aeson/Schema/TH.hs view
@@ -1,4 +1,4 @@-{-|+{- | Module : Data.Aeson.Schema.TH Maintainer : Brandon Chinn <brandon@leapyear.io> Stability : experimental@@ -20,18 +20,19 @@ * FlexibleContexts * TypeFamilies -}+module Data.Aeson.Schema.TH (+ schema,+ get,+ unwrap, -module Data.Aeson.Schema.TH- ( schema- , get- , unwrap -- * Utilities- , mkGetter+ mkGetter,+ -- * Helpers for Enum types- , mkEnum- , genFromJSONEnum- , genToJSONEnum- ) where+ mkEnum,+ genFromJSONEnum,+ genToJSONEnum,+) where import Data.Aeson.Schema.TH.Enum import Data.Aeson.Schema.TH.Get
src/Data/Aeson/Schema/TH/Enum.hs view
@@ -1,4 +1,7 @@-{-|+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TemplateHaskell #-}++{- | Module : Data.Aeson.Schema.TH.Enum Maintainer : Brandon Chinn <brandon@leapyear.io> Stability : experimental@@ -6,103 +9,105 @@ Template Haskell functions for Enum types. -}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE TemplateHaskell #-}--module Data.Aeson.Schema.TH.Enum- ( genFromJSONEnum- , genToJSONEnum- , mkEnum- ) where+module Data.Aeson.Schema.TH.Enum (+ genFromJSONEnum,+ genToJSONEnum,+ mkEnum,+) where import Control.Monad (forM, unless)-import Data.Aeson (FromJSON(..), ToJSON(..), Value(..))+import Data.Aeson (FromJSON (..), ToJSON (..), Value (..)) import Data.Char (toLower) import Data.Maybe (mapMaybe) import qualified Data.Text as Text import Language.Haskell.TH import Language.Haskell.TH.Syntax (lift) --- | Make an enum type with the given constructors, that can be parsed from JSON.------ The 'FromJSON' instance will match to a string value matching the constructor name,--- case-insensitive.------ @--- mkEnum \"State" [\"OPEN", \"CLOSED"]------ -- generates equivalent of:--- -- data State = OPEN | CLOSED deriving (...)--- -- genFromJSONEnum ''State--- -- genToJSONEnum ''State--- @+{- | Make an enum type with the given constructors, that can be parsed from JSON.++ The 'FromJSON' instance will match to a string value matching the constructor name,+ case-insensitive.++ @+ mkEnum \"State" [\"OPEN", \"CLOSED"]++ -- generates equivalent of:+ -- data State = OPEN | CLOSED deriving (...)+ -- genFromJSONEnum ''State+ -- genToJSONEnum ''State+ @+-} mkEnum :: String -> [String] -> Q [Dec]-mkEnum name vals = concat <$> sequence- [ (:[]) <$> dataDec- , mkFromJSON name' vals'- , mkToJSON name' vals'- ]+mkEnum name vals =+ concat+ <$> sequence+ [ (: []) <$> dataDec+ , mkFromJSON name' vals'+ , mkToJSON name' vals'+ ] where name' = mkName name vals' = map mkName vals dataDec = dataD (pure []) name' [] Nothing (map toCon vals') [derivClause Nothing deriveClasses] deriveClasses =- [ [t| Eq |]- , [t| Ord |]- , [t| Show |]- , [t| Enum |]+ [ [t|Eq|]+ , [t|Ord|]+ , [t|Show|]+ , [t|Enum|] ] toCon val = normalC val [] --- | Generate an instance of 'FromJSON' for the given data type.------ Prefer using 'mkEnum'; this function is useful for data types in which you want greater control--- over the actual data type.------ The 'FromJSON' instance will match to a string value matching the constructor name,--- case-insensitive.------ @--- data State = Open | CLOSED deriving (Show,Enum)--- genFromJSONEnum ''State------ -- outputs:--- -- Just Open--- -- Just Open--- -- Just CLOSED--- -- Just CLOSED--- main = mapM_ print--- [ decodeState \"open"--- , decodeState \"OPEN"--- , decodeState \"closed"--- , decodeState \"CLOSED"--- ]--- where--- decodeState :: String -> Maybe State--- decodeState = decode . show--- @+{- | Generate an instance of 'FromJSON' for the given data type.++ Prefer using 'mkEnum'; this function is useful for data types in which you want greater control+ over the actual data type.++ The 'FromJSON' instance will match to a string value matching the constructor name,+ case-insensitive.++ @+ data State = Open | CLOSED deriving (Show,Enum)+ genFromJSONEnum ''State++ -- outputs:+ -- Just Open+ -- Just Open+ -- Just CLOSED+ -- Just CLOSED+ main = mapM_ print+ [ decodeState \"open"+ , decodeState \"OPEN"+ , decodeState \"closed"+ , decodeState \"CLOSED"+ ]+ where+ decodeState :: String -> Maybe State+ decodeState = decode . show+ @+-} genFromJSONEnum :: Name -> Q [Dec] genFromJSONEnum name = getEnumConstructors name >>= mkFromJSON name --- | Generate an instance of 'ToJSON' for the given data type.------ Prefer using 'mkEnum'; this function is useful for data types in which you want greater control--- over the actual data type.------ The 'ToJSON' instance will encode the enum as a string matching the constructor name.------ @--- data State = Open | CLOSED deriving (Show,Enum)--- genToJSONEnum ''State------ -- outputs:--- -- \"Open"--- -- \"CLOSED"--- main = mapM_ print--- [ encode Open--- , encode CLOSED--- ]--- @+{- | Generate an instance of 'ToJSON' for the given data type.++ Prefer using 'mkEnum'; this function is useful for data types in which you want greater control+ over the actual data type.++ The 'ToJSON' instance will encode the enum as a string matching the constructor name.++ @+ data State = Open | CLOSED deriving (Show,Enum)+ genToJSONEnum ''State++ -- outputs:+ -- \"Open"+ -- \"CLOSED"+ main = mapM_ print+ [ encode Open+ , encode CLOSED+ ]+ @+-} genToJSONEnum :: Name -> Q [Dec] genToJSONEnum name = getEnumConstructors name >>= mkToJSON name @@ -127,11 +132,12 @@ mkFromJSON :: Name -> [Name] -> Q [Dec] mkFromJSON name cons = do let toPattern = litP . stringL . map toLower . nameBase- toMatch con = match (toPattern con) (normalB [| pure $(conE con) |]) []+ toMatch con = match (toPattern con) (normalB [|pure $(conE con)|]) [] t <- newName "t"- let parseEnum = caseE [| Text.unpack $ Text.toLower $(varE t) |] $- map toMatch cons ++ [match wildP (normalB $ appE badParse $ varE t) []]+ let parseEnum =+ caseE [|Text.unpack $ Text.toLower $(varE t)|] $+ map toMatch cons ++ [match wildP (normalB $ appE badParse $ varE t) []] [d| instance FromJSON $(conT name) where@@ -141,7 +147,7 @@ where badParse = let prefix = litE $ stringL $ "Bad " ++ nameBase name ++ ": "- in [| fail . ($prefix ++) . show |]+ in [|fail . ($prefix ++) . show|] mkToJSON :: Name -> [Name] -> Q [Dec] mkToJSON name cons =@@ -150,4 +156,4 @@ toJSON = $(lamCaseE $ map encodeConstructor cons) |] where- encodeConstructor con = match (conP con []) (normalB [| String $ Text.pack $(lift $ nameBase con) |]) []+ encodeConstructor con = match (conP con []) (normalB [|String $ Text.pack $(lift $ nameBase con)|]) []
src/Data/Aeson/Schema/TH/Get.hs view
@@ -1,4 +1,9 @@-{-|+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++{- | Module : Data.Aeson.Schema.TH.Get Maintainer : Brandon Chinn <brandon@leapyear.io> Stability : experimental@@ -6,11 +11,6 @@ The 'get' quasiquoter. -}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-}- module Data.Aeson.Schema.TH.Get where import Control.Monad ((>=>))@@ -18,75 +18,81 @@ import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Maybe as Maybe-import Data.Proxy (Proxy(..))+import Data.Proxy (Proxy (..)) import GHC.Stack (HasCallStack) import Language.Haskell.TH-import Language.Haskell.TH.Quote (QuasiQuoter(..))+import Language.Haskell.TH.Quote (QuasiQuoter (..)) import Data.Aeson.Schema.Internal (getKey)-import Data.Aeson.Schema.TH.Parse- (GetterExp(..), GetterOperation(..), GetterOps, parseGetterExp)+import Data.Aeson.Schema.TH.Parse (+ GetterExp (..),+ GetterOperation (..),+ GetterOps,+ parseGetterExp,+ ) import Data.Aeson.Schema.Utils.Sum (fromSumType) --- | Defines a QuasiQuoter for extracting JSON data.------ Example:------ > let Just result = decode ... :: Maybe (Object MySchema)--- >--- > [get| result.foo.a |] :: Int--- > [get| result.foo.nodes |] :: [Object (..)]--- > [get| result.foo.nodes[] |] :: [Object (..)]--- > [get| result.foo.nodes[].b |] :: [Maybe Bool]--- > [get| result.foo.nodes[].b! |] :: [Bool] -- runtime error if any values are Nothing--- > [get| result.foo.c |] :: Text--- > [get| result.foo.(a,c) |] :: (Int, Text)--- > [get| result.foo.[c,d] |] :: [Text]--- >--- > let nodes = [get| result.foo.nodes |]--- > flip map nodes $ \node -> fromMaybe ([get| node.num |] == 0) [get| node.b |]--- > map [get| .num |] nodes------ Syntax:------ * @x.y@ is only valid if @x@ is an 'Data.Aeson.Schema.Object'. Returns the value of the key @y@.------ * @.y@ returns a function that takes in an 'Data.Aeson.Schema.Object' and returns the value of--- the key @y@.------ * @x.[y,z.a]@ is only valid if @x@ is an 'Data.Aeson.Schema.Object', and if @y@ and @z.a@ have--- the same type. Returns the value of the operations @y@ and @z.a@ as a list.--- MUST be the last operation.------ * @x.(y,z.a)@ is only valid if @x@ is an 'Data.Aeson.Schema.Object'. Returns the value of the--- operations @y@ and @z.a@ as a tuple.--- MUST be the last operation.------ * @x!@ is only valid if @x@ is a 'Maybe'. Unwraps the value of @x@ from a 'Just' value and--- errors (at runtime!) if @x@ is 'Nothing'.------ * @x[]@ is only valid if @x@ is a list. Applies the remaining rules as an 'fmap' over the--- values in the list, e.g.------ * @x[]@ without anything after is equivalent to @x@--- * @x[].y@ gets the key @y@ in all the Objects in @x@--- * @x[]!@ unwraps all 'Just' values in @x@ (and errors if any 'Nothing' values exist in @x@)------ * @x?@ follows the same rules as @x[]@ except it's only valid if @x@ is a 'Maybe'.------ * @x\@#@ is only valid if @x@ is a 'SumType'. If the sum type contains a value at the given--- branch (e.g. @x\@0@ for @Here v@), return 'Just' that value, otherwise 'Nothing'. (added in--- v1.1.0)------ e.g. with the schema @{ a: Int | Bool }@, calling @[get| .a\@0 |]@ will return @Maybe Int@ if--- the sum type contains an 'Int'.+{- | Defines a QuasiQuoter for extracting JSON data.++ Example:++ > let Just result = decode ... :: Maybe (Object MySchema)+ >+ > [get| result.foo.a |] :: Int+ > [get| result.foo.nodes |] :: [Object (..)]+ > [get| result.foo.nodes[] |] :: [Object (..)]+ > [get| result.foo.nodes[].b |] :: [Maybe Bool]+ > [get| result.foo.nodes[].b! |] :: [Bool] -- runtime error if any values are Nothing+ > [get| result.foo.c |] :: Text+ > [get| result.foo.(a,c) |] :: (Int, Text)+ > [get| result.foo.[c,d] |] :: [Text]+ >+ > let nodes = [get| result.foo.nodes |]+ > flip map nodes $ \node -> fromMaybe ([get| node.num |] == 0) [get| node.b |]+ > map [get| .num |] nodes++ Syntax:++ * @x.y@ is only valid if @x@ is an 'Data.Aeson.Schema.Object'. Returns the value of the key @y@.++ * @.y@ returns a function that takes in an 'Data.Aeson.Schema.Object' and returns the value of+ the key @y@.++ * @x.[y,z.a]@ is only valid if @x@ is an 'Data.Aeson.Schema.Object', and if @y@ and @z.a@ have+ the same type. Returns the value of the operations @y@ and @z.a@ as a list.+ MUST be the last operation.++ * @x.(y,z.a)@ is only valid if @x@ is an 'Data.Aeson.Schema.Object'. Returns the value of the+ operations @y@ and @z.a@ as a tuple.+ MUST be the last operation.++ * @x!@ is only valid if @x@ is a 'Maybe'. Unwraps the value of @x@ from a 'Just' value and+ errors (at runtime!) if @x@ is 'Nothing'.++ * @x[]@ is only valid if @x@ is a list. Applies the remaining rules as an 'fmap' over the+ values in the list, e.g.++ * @x[]@ without anything after is equivalent to @x@+ * @x[].y@ gets the key @y@ in all the Objects in @x@+ * @x[]!@ unwraps all 'Just' values in @x@ (and errors if any 'Nothing' values exist in @x@)++ * @x?@ follows the same rules as @x[]@ except it's only valid if @x@ is a 'Maybe'.++ * @x\@#@ is only valid if @x@ is a 'SumType'. If the sum type contains a value at the given+ branch (e.g. @x\@0@ for @Here v@), return 'Just' that value, otherwise 'Nothing'. (added in+ v1.1.0)++ e.g. with the schema @{ a: Int | Bool }@, calling @[get| .a\@0 |]@ will return @Maybe Int@ if+ the sum type contains an 'Int'.+-} get :: QuasiQuoter-get = QuasiQuoter- { quoteExp = parseGetterExp >=> generateGetterExp- , quoteDec = error "Cannot use `get` for Dec"- , quoteType = error "Cannot use `get` for Type"- , quotePat = error "Cannot use `get` for Pat"- }+get =+ QuasiQuoter+ { quoteExp = parseGetterExp >=> generateGetterExp+ , quoteDec = error "Cannot use `get` for Dec"+ , quoteType = error "Cannot use `get` for Type"+ , quotePat = error "Cannot use `get` for Pat"+ } generateGetterExp :: GetterExp -> ExpQ generateGetterExp GetterExp{..} = applyStart $ resolveGetterOpExps $ mkGetterOpExps [] getterOps@@ -104,25 +110,19 @@ mkGetterOpExp history = \case GetterKey key -> let keyType = litT $ strTyLit key- in ApplyOp [| getKey (Proxy :: Proxy $keyType) |]-+ in ApplyOp [|getKey (Proxy :: Proxy $keyType)|] GetterBang -> let expr = startDisplay ++ showGetterOps history- in ApplyOp [| fromJust expr |]-+ in ApplyOp [|fromJust expr|] GetterMapMaybe ->- ApplyOpInfix [| (<$?>) |]-+ ApplyOpInfix [|(<$?>)|] GetterMapList ->- ApplyOpInfix [| (<$:>) |]-+ ApplyOpInfix [|(<$:>)|] GetterBranch branch -> let branchType = litT $ numTyLit $ fromIntegral branch- in ApplyOp [| fromSumType (Proxy :: Proxy $branchType) |]-+ in ApplyOp [|fromSumType (Proxy :: Proxy $branchType)|] GetterList elemOps -> ApplyOpsIntoList $ mkGetterOpExps history <$> elemOps- GetterTuple elemOps -> ApplyOpsIntoTuple $ mkGetterOpExps history <$> elemOps @@ -145,24 +145,27 @@ {- Code generation helpers -} data GetterOpExp- = ApplyOp ExpQ -- ^ next . f- | ApplyOpInfix ExpQ -- ^ (next `f`)- | ApplyOpsIntoList (NonEmpty GetterOpExps) -- ^ \v -> [f1 v, f2 v, ...]- | ApplyOpsIntoTuple (NonEmpty GetterOpExps) -- ^ \v -> (f1 v, f2 v, ...)+ = -- | next . f+ ApplyOp ExpQ+ | -- | (next `f`)+ ApplyOpInfix ExpQ+ | -- | \v -> [f1 v, f2 v, ...]+ ApplyOpsIntoList (NonEmpty GetterOpExps)+ | -- | \v -> (f1 v, f2 v, ...)+ ApplyOpsIntoTuple (NonEmpty GetterOpExps) type GetterOpExps = NonEmpty GetterOpExp resolveGetterOpExps :: GetterOpExps -> ExpQ resolveGetterOpExps (op NonEmpty.:| ops) = case op of- ApplyOp f -> [| $next . $f |]+ ApplyOp f -> [|$next . $f|] ApplyOpInfix f -> infixE (Just next) f Nothing- -- suffixes; ops should be empty ApplyOpsIntoList elemOps -> resolveEach listE elemOps ApplyOpsIntoTuple elemOps -> resolveEach tupE elemOps where- next = maybe [| id |] resolveGetterOpExps $ NonEmpty.nonEmpty ops+ next = maybe [|id|] resolveGetterOpExps $ NonEmpty.nonEmpty ops resolveEach fromElems elemOps = do val <- newName "v"@@ -173,7 +176,7 @@ showGetterOps = concatMap showGetterOp where showGetterOp = \case- GetterKey key -> '.':key+ GetterKey key -> '.' : key GetterBang -> "!" GetterMapList -> "[]" GetterMapMaybe -> "?"@@ -185,10 +188,11 @@ {- Utilities -} --- | Run the given function for each element in the list, providing all elements seen so far.------ e.g. for a list [1,2,3], this will return the result of------ [f [] 1, f [1] 2, f [1,2] 3]+{- | Run the given function for each element in the list, providing all elements seen so far.++ e.g. for a list [1,2,3], this will return the result of++ [f [] 1, f [1] 2, f [1,2] 3]+-} mapWithHistory :: ([a] -> a -> b) -> NonEmpty a -> NonEmpty b mapWithHistory f xs = NonEmpty.zipWith f (NonEmpty.inits xs) xs
src/Data/Aeson/Schema/TH/Getter.hs view
@@ -1,4 +1,7 @@-{-|+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++{- | Module : Data.Aeson.Schema.TH.Getter Maintainer : Brandon Chinn <brandon@leapyear.io> Stability : experimental@@ -6,9 +9,6 @@ Template Haskell functions for getter functions. -}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-}- module Data.Aeson.Schema.TH.Getter where import Control.Monad (unless)@@ -17,64 +17,68 @@ import Language.Haskell.TH import Data.Aeson.Schema.TH.Get (generateGetterExp)-import Data.Aeson.Schema.TH.Parse (GetterExp(..), parseGetterExp)-import Data.Aeson.Schema.TH.Unwrap- (FunctorHandler(..), unwrapSchema, unwrapSchemaUsing)+import Data.Aeson.Schema.TH.Parse (GetterExp (..), parseGetterExp)+import Data.Aeson.Schema.TH.Unwrap (+ FunctorHandler (..),+ unwrapSchema,+ unwrapSchemaUsing,+ ) import Data.Aeson.Schema.TH.Utils (loadSchema, lookupSchema, schemaVToTypeQ)-import Data.Aeson.Schema.Utils.NameLike (NameLike(..))+import Data.Aeson.Schema.Utils.NameLike (NameLike (..)) --- | A helper that generates a 'Data.Aeson.Schema.TH.get' expression and a type alias for the result--- of the expression.------ > mkGetter "Node" "getNodes" ''MySchema ".nodes[]"--- >--- > {- is equivalent to -}--- >--- > -- | Node ~ { b: Maybe Bool }--- > type Node = [unwrap| MySchema.nodes[] |]--- >--- > getNodes :: Object MySchema -> [Node]--- > getNodes = [get| .nodes[] |]------ 'mkGetter' takes four arguments:------ [@unwrapName@] The name of the type synonym to store the unwrapped schema as------ [@funcName@] The name of the getter function------ [@startSchema@] The schema to extract/unwrap from------ [@ops@] The operation to pass to the 'Data.Aeson.Schema.TH.get' and--- 'Data.Aeson.Schema.TH.unwrap' quasiquoters------ There is one subtlety that occurs from the use of the same @ops@ string for both the--- 'Data.Aeson.Schema.TH.unwrap' and 'Data.Aeson.Schema.TH.get' quasiquoters:--- 'Data.Aeson.Schema.TH.unwrap' strips out intermediate functors, while 'Data.Aeson.Schema.TH.get'--- applies within the functor. So in the above example, @".nodes[]"@ strips out the list when--- saving the schema to @Node@, while in the below example, @".nodes"@ doesn't strip out the list--- when saving the schema to @Nodes@.------ > mkGetter "Nodes" "getNodes" ''MySchema ".nodes"--- >--- > {- is equivalent to -}--- >--- > -- | Nodes ~ List { b: Maybe Bool }--- > type Nodes = [unwrap| MySchema.nodes |]--- >--- > getNodes :: Object MySchema -> Nodes--- > getNodes = [get| .nodes |]------ As another example,------ > mkGetter "MyName" "getMyName" ''MySchema ".f?[].name"--- >--- > {- is equivalent to -}--- >--- > -- | MyName ~ Text--- > type MyName = [unwrap| MySchema.f?[].name |]--- >--- > getMyBool :: Object MySchema -> Maybe [MyName]--- > getMyBool = [get| .f?[].name |]+{- | A helper that generates a 'Data.Aeson.Schema.TH.get' expression and a type alias for the result+ of the expression.++ > mkGetter "Node" "getNodes" ''MySchema ".nodes[]"+ >+ > {\- is equivalent to -\}+ >+ > -- | Node ~ { b: Maybe Bool }+ > type Node = [unwrap| MySchema.nodes[] |]+ >+ > getNodes :: Object MySchema -> [Node]+ > getNodes = [get| .nodes[] |]++ 'mkGetter' takes four arguments:++ [@unwrapName@] The name of the type synonym to store the unwrapped schema as++ [@funcName@] The name of the getter function++ [@startSchema@] The schema to extract/unwrap from++ [@ops@] The operation to pass to the 'Data.Aeson.Schema.TH.get' and+ 'Data.Aeson.Schema.TH.unwrap' quasiquoters++ There is one subtlety that occurs from the use of the same @ops@ string for both the+ 'Data.Aeson.Schema.TH.unwrap' and 'Data.Aeson.Schema.TH.get' quasiquoters:+ 'Data.Aeson.Schema.TH.unwrap' strips out intermediate functors, while 'Data.Aeson.Schema.TH.get'+ applies within the functor. So in the above example, @".nodes[]"@ strips out the list when+ saving the schema to @Node@, while in the below example, @".nodes"@ doesn't strip out the list+ when saving the schema to @Nodes@.++ > mkGetter "Nodes" "getNodes" ''MySchema ".nodes"+ >+ > {\- is equivalent to -\}+ >+ > -- | Nodes ~ List { b: Maybe Bool }+ > type Nodes = [unwrap| MySchema.nodes |]+ >+ > getNodes :: Object MySchema -> Nodes+ > getNodes = [get| .nodes |]++ As another example,++ > mkGetter "MyName" "getMyName" ''MySchema ".f?[].name"+ >+ > {\- is equivalent to -\}+ >+ > -- | MyName ~ Text+ > type MyName = [unwrap| MySchema.f?[].name |]+ >+ > getMyBool :: Object MySchema -> Maybe [MyName]+ > getMyBool = [get| .f?[].name |]+-} mkGetter :: String -> String -> Name -> String -> DecsQ mkGetter unwrapName funcName startSchemaName ops = do getterExp@GetterExp{..} <- parseGetterExp ops@@ -91,6 +95,6 @@ sequence [ tySynD unwrapName' [] unwrapResult- , sigD funcName' [t| Object $(schemaVToTypeQ startSchema) -> $funcResult |]+ , sigD funcName' [t|Object $(schemaVToTypeQ startSchema) -> $funcResult|] , funD funcName' [clause [] (normalB getterFunc) []] ]
src/Data/Aeson/Schema/TH/Parse.hs view
@@ -1,4 +1,8 @@-{-|+{-# LANGUAGE CPP #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE RecordWildCards #-}++{- | Module : Data.Aeson.Schema.TH.Parse Maintainer : Brandon Chinn <brandon@leapyear.io> Stability : experimental@@ -6,13 +10,10 @@ Definitions for parsing input text in QuasiQuoters. -}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE RecordWildCards #-}- module Data.Aeson.Schema.TH.Parse where import Control.Monad (MonadPlus, void)+ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail (MonadFail) #endif@@ -70,28 +71,32 @@ let parseSchemaUnion schemaDefs | length schemaDefs == 1 = NonEmpty.head schemaDefs | otherwise = SchemaDefUnion schemaDefs- in fmap parseSchemaUnion $ parseSchemaDefWithoutUnions `sepBy1` lexeme "|"-- parseSchemaDefWithoutUnions = choice- [ between (lexeme "{") (lexeme "}") $ SchemaDefObj <$> parseSchemaDefObjItems- , between (lexeme "(") (lexeme ")") parseSchemaDefWithUnions- , lexeme "Maybe" *> (SchemaDefMaybe <$> parseSchemaDefWithoutUnions)- , lexeme "Try" *> (SchemaDefTry <$> parseSchemaDefWithoutUnions)- , lexeme "List" *> (SchemaDefList <$> parseSchemaDefWithoutUnions)- , SchemaDefType <$> identifier upperChar- , SchemaDefInclude <$> parseSchemaReference- ] <* space -- allow any trailing spaces+ in fmap parseSchemaUnion $ parseSchemaDefWithoutUnions `sepBy1` lexeme "|" + parseSchemaDefWithoutUnions =+ choice+ [ between (lexeme "{") (lexeme "}") $ SchemaDefObj <$> parseSchemaDefObjItems+ , between (lexeme "(") (lexeme ")") parseSchemaDefWithUnions+ , lexeme "Maybe" *> (SchemaDefMaybe <$> parseSchemaDefWithoutUnions)+ , lexeme "Try" *> (SchemaDefTry <$> parseSchemaDefWithoutUnions)+ , lexeme "List" *> (SchemaDefList <$> parseSchemaDefWithoutUnions)+ , SchemaDefType <$> identifier upperChar+ , SchemaDefInclude <$> parseSchemaReference+ ]+ <* space -- allow any trailing spaces parseSchemaDefObjItems = parseSchemaDefObjItem `sepEndBy1` lexeme ","- parseSchemaDefObjItem = choice- [ SchemaDefObjPair <$> parseSchemaDefPair- , SchemaDefObjExtend <$> parseSchemaReference- ] <* space -- allow any trailing spaces- parseSchemaDefPair = do- key <- choice- [ SchemaDefObjKeyNormal <$> jsonKey- , SchemaDefObjKeyPhantom <$> between (lexeme' "[") (lexeme' "]") jsonKey'+ parseSchemaDefObjItem =+ choice+ [ SchemaDefObjPair <$> parseSchemaDefPair+ , SchemaDefObjExtend <$> parseSchemaReference ]+ <* space -- allow any trailing spaces+ parseSchemaDefPair = do+ key <-+ choice+ [ SchemaDefObjKeyNormal <$> jsonKey+ , SchemaDefObjKeyPhantom <$> between (lexeme' "[") (lexeme' "]") jsonKey'+ ] lexeme ":" value <- parseSchemaDefWithUnions return (key, value)@@ -100,9 +105,10 @@ {- GetterExp -} data GetterExp = GetterExp- { start :: Maybe String+ { start :: Maybe String , getterOps :: GetterOps- } deriving (Show)+ }+ deriving (Show) parseGetterExp :: MonadFail m => String -> m GetterExp parseGetterExp = runParserFail $ do@@ -117,8 +123,9 @@ data UnwrapSchema = UnwrapSchema { startSchema :: String- , getterOps :: GetterOps- } deriving (Show)+ , getterOps :: GetterOps+ }+ deriving (Show) parseUnwrapSchema :: MonadFail m => String -> m UnwrapSchema parseUnwrapSchema = runParserFail $ do@@ -131,9 +138,10 @@ {- GetterOps -} --- | A non-empty list of GetterOperations.------ Invariant: Any GetterList/GetterTuple operations MUST be last.+{- | A non-empty list of GetterOperations.++ Invariant: Any GetterList/GetterTuple operations MUST be last.+-} type GetterOps = NonEmpty GetterOperation parseGetterOps :: Parser GetterOps@@ -145,25 +153,28 @@ | GetterMapList | GetterMapMaybe | GetterBranch Int- -- suffixes- | GetterList (NonEmpty GetterOps)+ | -- suffixes+ GetterList (NonEmpty GetterOps) | GetterTuple (NonEmpty GetterOps) deriving (Show) parseGetterOp :: Parser GetterOperation-parseGetterOp = choice- [ lexeme "!" $> GetterBang- , lexeme "[]" $> GetterMapList- , lexeme "?" $> GetterMapMaybe- , lexeme "@" *> (GetterBranch . read . NonEmpty.toList <$> some digitChar)- , optional (lexeme ".") *> (GetterKey <$> jsonKey)- ]+parseGetterOp =+ choice+ [ lexeme "!" $> GetterBang+ , lexeme "[]" $> GetterMapList+ , lexeme "?" $> GetterMapMaybe+ , lexeme "@" *> (GetterBranch . read . NonEmpty.toList <$> some digitChar)+ , optional (lexeme ".") *> (GetterKey <$> jsonKey)+ ] parseGetterOpSuffix :: Parser GetterOperation-parseGetterOpSuffix = optional (lexeme ".") *> choice- [ fmap GetterList $ between (lexeme "[") (lexeme "]") $ parseGetterOps `sepBy1` lexeme ","- , fmap GetterTuple $ between (lexeme "(") (lexeme ")") $ parseGetterOps `sepBy1` lexeme ","- ]+parseGetterOpSuffix =+ optional (lexeme ".")+ *> choice+ [ fmap GetterList $ between (lexeme "[") (lexeme "]") $ parseGetterOps `sepBy1` lexeme ","+ , fmap GetterTuple $ between (lexeme "(") (lexeme ")") $ parseGetterOps `sepBy1` lexeme ","+ ] {- Parser primitives -} @@ -187,10 +198,11 @@ where ident = identifier start namespaced = intercalate "." <$> manyAndEnd (identifier upperChar <* lexeme ".") ident- manyAndEnd p end = choice- [ try $ p >>= \x -> (x:) <$> manyAndEnd p end- , (:[]) <$> end- ]+ manyAndEnd p end =+ choice+ [ try $ p >>= \x -> (x :) <$> manyAndEnd p end+ , (: []) <$> end+ ] -- | An optionally quoted JSON key. jsonKey :: Parser String@@ -198,10 +210,13 @@ -- | A string that can be used as a JSON key. jsonKey' :: Parser String-jsonKey' = fmap NonEmpty.toList $ some $ choice- [ try $ char '\\' *> anySingle'- , noneOf $ [' ', '\\', '"'] ++ schemaChars ++ getChars- ]+jsonKey' =+ fmap NonEmpty.toList $+ some $+ choice+ [ try $ char '\\' *> anySingle'+ , noneOf $ [' ', '\\', '"'] ++ schemaChars ++ getChars+ ] where #if MIN_VERSION_megaparsec(7,0,0) anySingle' = anySingle@@ -228,13 +243,14 @@ sepEndBy1 :: MonadPlus f => f a -> f sep -> f (NonEmpty a) sepEndBy1 p sep = NonEmpty.fromList <$> Megaparsec.sepEndBy1 p sep --- | Return a non-empty list containing elements from the given parsers in order.------ i.e. for `someWith [p1, p2, p3]`, elements parsed with `p1` will come before--- elements parsed with `p2` and `p3`, etc.------ An individual parser in the list may not parse anything, but at least one parser must return--- something.+{- | Return a non-empty list containing elements from the given parsers in order.++ i.e. for `someWith [p1, p2, p3]`, elements parsed with `p1` will come before+ elements parsed with `p2` and `p3`, etc.++ An individual parser in the list may not parse anything, but at least one parser must return+ something.+-} someWith :: MonadParsec e s m => [m a] -> m (NonEmpty a) someWith ps = do as <- concatMapM (many . try) ps
src/Data/Aeson/Schema/TH/Schema.hs view
@@ -1,110 +1,118 @@-{-|-Module : Data.Aeson.Schema.TH.Schema-Maintainer : Brandon Chinn <brandon@leapyear.io>-Stability : experimental-Portability : portable--The 'schema' quasiquoter.--} {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} +{- |+Module : Data.Aeson.Schema.TH.Schema+Maintainer : Brandon Chinn <brandon@leapyear.io>+Stability : experimental+Portability : portable++The 'schema' quasiquoter.+-} module Data.Aeson.Schema.TH.Schema (schema) where import Control.Monad (unless, (>=>)) import Data.Function (on)-import Data.Hashable (Hashable) import qualified Data.HashMap.Strict as HashMap+import Data.Hashable (Hashable) import Data.List (nubBy) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty import Language.Haskell.TH-import Language.Haskell.TH.Quote (QuasiQuoter(..))+import Language.Haskell.TH.Quote (QuasiQuoter (..)) -import Data.Aeson.Schema.Key (SchemaKey'(..), SchemaKeyV, fromSchemaKeyV)-import Data.Aeson.Schema.TH.Parse- (SchemaDef(..), SchemaDefObjItem(..), SchemaDefObjKey(..), parseSchemaDef)+import Data.Aeson.Schema.Key (SchemaKey' (..), SchemaKeyV, fromSchemaKeyV)+import Data.Aeson.Schema.TH.Parse (+ SchemaDef (..),+ SchemaDefObjItem (..),+ SchemaDefObjKey (..),+ parseSchemaDef,+ ) import Data.Aeson.Schema.TH.Utils (reifySchema, schemaVToTypeQ)-import Data.Aeson.Schema.Type- ( Schema'(..)- , SchemaObjectMapV- , SchemaType'(..)- , SchemaTypeV- , fromSchemaV- , showSchemaTypeV- )+import Data.Aeson.Schema.Type (+ Schema' (..),+ SchemaObjectMapV,+ SchemaType' (..),+ SchemaTypeV,+ fromSchemaV,+ showSchemaTypeV,+ ) import Data.Aeson.Schema.Utils.Invariant (unreachable)-import Data.Aeson.Schema.Utils.NameLike (NameLike(..))+import Data.Aeson.Schema.Utils.NameLike (NameLike (..)) --- | Defines a QuasiQuoter for writing schemas.------ Example:------ > import Data.Aeson.Schema (schema)--- >--- > type MySchema = [schema|--- > {--- > foo: {--- > a: Int,--- > // you can add comments like this--- > nodes: List {--- > b: Maybe Bool,--- > },--- > c: Text,--- > d: Text,--- > e: MyType,--- > f: Maybe List {--- > name: Text,--- > },--- > },--- > }--- > |]------ Syntax:------ * @{ key: \<schema\>, ... }@ corresponds to a JSON 'Data.Aeson.Schema.Object' with the given key--- mapping to the given schema.------ * @Bool@, @Int@, @Double@, and @Text@ correspond to the usual Haskell values.------ * @Maybe \<schema\>@ and @List \<schema\>@ correspond to @Maybe@ and @[]@, containing values--- specified by the provided schema (no parentheses needed).------ * @Try \<schema\>@ corresponds to @Maybe@, where the value will be @Just@ if the given schema--- successfully parses the value, or @Nothing@ otherwise. Different from @Maybe \<schema\>@,--- where parsing @{ "foo": true }@ with @{ foo: Try Int }@ returns @Nothing@, whereas it would--- be a parse error with @{ foo: Maybe Int }@ (added in v1.2.0)------ * Any other uppercase identifier corresponds to the respective type in scope -- requires a--- FromJSON instance.------ Advanced syntax:------ * @\<schema1\> | \<schema2\>@ corresponds to a JSON value that matches one of the given schemas.--- When extracted from an 'Data.Aeson.Schema.Object', it deserializes into a--- 'Data.Aeson.Schema.Utils.Sum.JSONSum' object. (added in v1.1.0)------ * @{ [key]: \<schema\> }@ uses the current object to resolve the keys in the given schema. Only--- object schemas are allowed here. (added in v1.2.0)------ * @{ key: #Other, ... }@ maps the given key to the @Other@ schema. The @Other@ schema needs to--- be defined in another module.------ * @{ #Other, ... }@ extends this schema with the @Other@ schema. The @Other@ schema needs to--- be defined in another module.+{- | Defines a QuasiQuoter for writing schemas.++ Example:++ > import Data.Aeson.Schema (schema)+ >+ > type MySchema = [schema|+ > {+ > foo: {+ > a: Int,+ > // you can add comments like this+ > nodes: List {+ > b: Maybe Bool,+ > },+ > c: Text,+ > d: Text,+ > e: MyType,+ > f: Maybe List {+ > name: Text,+ > },+ > },+ > }+ > |]++ Syntax:++ * @{ key: \<schema\>, ... }@ corresponds to a JSON 'Data.Aeson.Schema.Object' with the given key+ mapping to the given schema.++ * @Bool@, @Int@, @Double@, and @Text@ correspond to the usual Haskell values.++ * @Maybe \<schema\>@ and @List \<schema\>@ correspond to @Maybe@ and @[]@, containing values+ specified by the provided schema (no parentheses needed).++ * @Try \<schema\>@ corresponds to @Maybe@, where the value will be @Just@ if the given schema+ successfully parses the value, or @Nothing@ otherwise. Different from @Maybe \<schema\>@,+ where parsing @{ "foo": true }@ with @{ foo: Try Int }@ returns @Nothing@, whereas it would+ be a parse error with @{ foo: Maybe Int }@ (added in v1.2.0)++ * Any other uppercase identifier corresponds to the respective type in scope -- requires a+ FromJSON instance.++ Advanced syntax:++ * @\<schema1\> | \<schema2\>@ corresponds to a JSON value that matches one of the given schemas.+ When extracted from an 'Data.Aeson.Schema.Object', it deserializes into a+ 'Data.Aeson.Schema.Utils.Sum.JSONSum' object. (added in v1.1.0)++ * @{ [key]: \<schema\> }@ uses the current object to resolve the keys in the given schema. Only+ object schemas are allowed here. (added in v1.2.0)++ * @{ key: #Other, ... }@ maps the given key to the @Other@ schema. The @Other@ schema needs to+ be defined in another module.++ * @{ #Other, ... }@ extends this schema with the @Other@ schema. The @Other@ schema needs to+ be defined in another module.+-} schema :: QuasiQuoter-schema = QuasiQuoter- { quoteExp = error "Cannot use `schema` for Exp"- , quoteDec = error "Cannot use `schema` for Dec"- , quoteType = parseSchemaDef >=> \case- SchemaDefObj items -> generateSchemaObject items- _ -> fail "`schema` definition must be an object"- , quotePat = error "Cannot use `schema` for Pat"- }+schema =+ QuasiQuoter+ { quoteExp = error "Cannot use `schema` for Exp"+ , quoteDec = error "Cannot use `schema` for Dec"+ , quoteType =+ parseSchemaDef >=> \case+ SchemaDefObj items -> generateSchemaObject items+ _ -> fail "`schema` definition must be an object"+ , quotePat = error "Cannot use `schema` for Pat"+ } where generateSchemaObject items = schemaVToTypeQ . Schema =<< generateSchemaObjectV items @@ -120,8 +128,9 @@ either fail return $ resolveKeys schemaObjectMaps --- | Get the SchemaObjectMapV for the given SchemaDefObjItem, along with where the SchemaObjectMapV--- came from.+{- | Get the SchemaObjectMapV for the given SchemaDefObjItem, along with where the SchemaObjectMapV+ came from.+-} getSchemaObjectMap :: SchemaDefObjItem -> Q (SchemaObjectMapV, KeySource) getSchemaObjectMap = \case SchemaDefObjPair (schemaDefKey, schemaDefType) -> do@@ -135,7 +144,6 @@ _ -> return () return ([(schemaKey, schemaType)], Provided)- SchemaDefObjExtend other -> do schemaV <- reifySchema other return (fromSchemaV schemaV, Imported)@@ -149,24 +157,25 @@ SchemaInclude _ -> True _ -> False --- | Resolve the given keys with the following rules:------ 1. Any explicitly provided keys shadow/overwrite imported keys--- 2. Fail if duplicate keys are both explicitly provided--- 3. Fail if duplicate keys are both imported-resolveKeys :: Show a => LookupMap SchemaKeyV (KeySource, a) -> Either String (LookupMap SchemaKeyV a)+{- | Resolve the given keys with the following rules:++ 1. Any explicitly provided keys shadow/overwrite imported keys+ 2. Fail if duplicate keys are both explicitly provided+ 3. Fail if duplicate keys are both imported+-}+resolveKeys :: forall a. Show a => LookupMap SchemaKeyV (KeySource, a) -> Either String (LookupMap SchemaKeyV a) resolveKeys = mapM (uncurry resolveKey) . groupByKeyWith fromSchemaKeyV where+ resolveKey :: SchemaKeyV -> [(KeySource, a)] -> Either String (SchemaKeyV, a) resolveKey key sourcesAndVals =- let filterSource source = map snd $ filter ((== source) . fst) sourcesAndVals- numProvided = length $ filterSource Provided- numImported = length $ filterSource Imported- in if- | numProvided > 1 -> Left $ "Key '" ++ fromSchemaKeyV key ++ "' specified multiple times"- | [val] <- filterSource Provided -> Right (key, val)- | numImported > 1 -> Left $ "Key '" ++ fromSchemaKeyV key ++ "' declared in multiple imported schemas"- | [val] <- filterSource Imported -> Right (key, val)- | otherwise -> unreachable $ "resolveKey received: " ++ show (key, sourcesAndVals)+ let provided = lookupAll Provided sourcesAndVals+ imported = lookupAll Imported sourcesAndVals+ in if+ | length provided > 1 -> Left $ "Key '" ++ fromSchemaKeyV key ++ "' specified multiple times"+ | [val] <- provided -> Right (key, val)+ | length imported > 1 -> Left $ "Key '" ++ fromSchemaKeyV key ++ "' declared in multiple imported schemas"+ | [val] <- imported -> Right (key, val)+ | otherwise -> unreachable $ "resolveKey received: " ++ show (key, sourcesAndVals) {- SchemaDef conversions -} @@ -177,13 +186,13 @@ fromSchemaDefType :: SchemaDef -> Q SchemaTypeV fromSchemaDefType = \case- SchemaDefType name -> return $ SchemaScalar $ NameRef name- SchemaDefMaybe inner -> SchemaMaybe <$> fromSchemaDefType inner- SchemaDefTry inner -> SchemaTry <$> fromSchemaDefType inner- SchemaDefList inner -> SchemaList <$> fromSchemaDefType inner+ SchemaDefType name -> return $ SchemaScalar $ NameRef name+ SchemaDefMaybe inner -> SchemaMaybe <$> fromSchemaDefType inner+ SchemaDefTry inner -> SchemaTry <$> fromSchemaDefType inner+ SchemaDefList inner -> SchemaList <$> fromSchemaDefType inner SchemaDefInclude other -> return $ SchemaInclude $ Left $ NameRef other SchemaDefUnion schemas -> SchemaUnion . NonEmpty.toList <$> mapM fromSchemaDefType schemas- SchemaDefObj items -> SchemaObject <$> generateSchemaObjectV items+ SchemaDefObj items -> SchemaObject <$> generateSchemaObjectV items {- LookupMap utilities -} @@ -193,12 +202,13 @@ distribute :: LookupMap k v -> a -> LookupMap k (a, v) distribute lookupMap a = map (fmap (a,)) lookupMap --- | Find all values with the same key (according to the given function) and group them.------ Invariants:--- * [v] has length > 0--- * If the first occurence of k1 is before the first occurence of k2, k1 is before k2--- in the result+{- | Find all values with the same key (according to the given function) and group them.++ Invariants:+ * [v] has length > 0+ * If the first occurence of k1 is before the first occurence of k2, k1 is before k2+ in the result+-} groupByKeyWith :: (Eq a, Hashable a) => (k -> a) -> LookupMap k v -> LookupMap k [v] groupByKeyWith f pairs = map (\key -> (key, groups HashMap.! f key)) distinctKeys where@@ -206,3 +216,8 @@ distinctKeys = nubBy ((==) `on` f) $ map fst pairs groups = HashMap.fromListWith (flip (++)) $ map (\(k, v) -> (f k, [v])) pairs++{- Utilities -}++lookupAll :: Eq a => a -> [(a, b)] -> [b]+lookupAll a = map snd . filter ((== a) . fst)
src/Data/Aeson/Schema/TH/Unwrap.hs view
@@ -1,4 +1,8 @@-{-|+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++{- | Module : Data.Aeson.Schema.TH.Unwrap Maintainer : Brandon Chinn <brandon@leapyear.io> Stability : experimental@@ -6,71 +10,77 @@ The 'unwrap' quasiquoter. -}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-}- module Data.Aeson.Schema.TH.Unwrap where import Control.Monad ((<=<), (>=>)) import Data.Bifunctor (first) import qualified Data.List.NonEmpty as NonEmpty import Language.Haskell.TH-import Language.Haskell.TH.Quote (QuasiQuoter(..))+import Language.Haskell.TH.Quote (QuasiQuoter (..)) import Data.Aeson.Schema.Internal (Object, SchemaResult) import Data.Aeson.Schema.Key (fromSchemaKeyV)-import Data.Aeson.Schema.TH.Parse- (GetterOperation(..), GetterOps, UnwrapSchema(..), parseUnwrapSchema)-import Data.Aeson.Schema.TH.Utils- (reifySchema, resolveSchemaType, schemaTypeVToTypeQ, schemaVToTypeQ)-import Data.Aeson.Schema.Type- ( Schema'(..)- , SchemaType'(..)- , SchemaTypeV- , SchemaV- , showSchemaTypeV- , toSchemaObjectV- )+import Data.Aeson.Schema.TH.Parse (+ GetterOperation (..),+ GetterOps,+ UnwrapSchema (..),+ parseUnwrapSchema,+ )+import Data.Aeson.Schema.TH.Utils (+ reifySchema,+ resolveSchemaType,+ schemaTypeVToTypeQ,+ schemaVToTypeQ,+ )+import Data.Aeson.Schema.Type (+ Schema' (..),+ SchemaType' (..),+ SchemaTypeV,+ SchemaV,+ showSchemaTypeV,+ toSchemaObjectV,+ ) --- | Defines a QuasiQuoter to extract a schema within the given schema.------ The base schema needs to be defined in a separate module.------ For example:------ > -- | MyFoo ~ Object [schema| { b: Maybe Bool } |]--- > type MyFoo = [unwrap| MySchema.foo.nodes[] |]------ If the schema is imported qualified, you can use parentheses to distinguish it from the--- expression:------ > type MyFoo = [unwrap| (MyModule.Schema).foo.nodes[] |]------ You can then use the type alias as usual:------ > parseBar :: MyFoo -> String--- > parseBar = maybe "null" show . [get| .b |]--- >--- > foo = map parseBar [get| result.foo.nodes[] |]------ The syntax is mostly the same as 'Data.Aeson.Schema.TH.get', except the operations run on the--- type itself, instead of the values. Differences from 'Data.Aeson.Schema.TH.get':------ * @x!@ is only valid if @x@ is a @Maybe a@ type. Returns @a@, the type wrapped in the 'Maybe'.------ * @x?@ is the same as @x!@.------ * @x[]@ is only valid if @x@ is a @[a]@ type. Returns @a@, the type contained in the list.------ * @x\@#@ is only valid if @x@ is a @SumType@. Returns the type at that branch in the sum type.+{- | Defines a QuasiQuoter to extract a schema within the given schema.++ The base schema needs to be defined in a separate module.++ For example:++ > -- | MyFoo ~ Object [schema| { b: Maybe Bool } |]+ > type MyFoo = [unwrap| MySchema.foo.nodes[] |]++ If the schema is imported qualified, you can use parentheses to distinguish it from the+ expression:++ > type MyFoo = [unwrap| (MyModule.Schema).foo.nodes[] |]++ You can then use the type alias as usual:++ > parseBar :: MyFoo -> String+ > parseBar = maybe "null" show . [get| .b |]+ >+ > foo = map parseBar [get| result.foo.nodes[] |]++ The syntax is mostly the same as 'Data.Aeson.Schema.TH.get', except the operations run on the+ type itself, instead of the values. Differences from 'Data.Aeson.Schema.TH.get':++ * @x!@ is only valid if @x@ is a @Maybe a@ type. Returns @a@, the type wrapped in the 'Maybe'.++ * @x?@ is the same as @x!@.++ * @x[]@ is only valid if @x@ is a @[a]@ type. Returns @a@, the type contained in the list.++ * @x\@#@ is only valid if @x@ is a @SumType@. Returns the type at that branch in the sum type.+-} unwrap :: QuasiQuoter-unwrap = QuasiQuoter- { quoteExp = error "Cannot use `unwrap` for Exp"- , quoteDec = error "Cannot use `unwrap` for Dec"- , quoteType = parseUnwrapSchema >=> generateUnwrapSchema- , quotePat = error "Cannot use `unwrap` for Pat"- }+unwrap =+ QuasiQuoter+ { quoteExp = error "Cannot use `unwrap` for Exp"+ , quoteDec = error "Cannot use `unwrap` for Dec"+ , quoteType = parseUnwrapSchema >=> generateUnwrapSchema+ , quotePat = error "Cannot use `unwrap` for Pat"+ } generateUnwrapSchema :: UnwrapSchema -> TypeQ generateUnwrapSchema UnwrapSchema{..} = reifySchema startSchema >>= unwrapSchema getterOps@@ -86,8 +96,8 @@ toResultTypeQ :: UnwrapSchemaResult -> TypeQ toResultTypeQ = \case -- special case SchemaObject to make it further inspectable- SchemaResult (SchemaObject pairs) -> [t| Object $(schemaVToTypeQ (Schema pairs)) |]- SchemaResult schemaType -> [t| SchemaResult $(schemaTypeVToTypeQ schemaType) |]+ SchemaResult (SchemaObject pairs) -> [t|Object $(schemaVToTypeQ (Schema pairs))|]+ SchemaResult schemaType -> [t|SchemaResult $(schemaTypeVToTypeQ schemaType)|] SchemaResultList schemaResult -> appT listT (toResultTypeQ schemaResult) SchemaResultTuple schemaResults -> foldl appT (tupleT $ length schemaResults) $ map toResultTypeQ schemaResults SchemaResultWrapped functorTy schemaResult ->@@ -95,11 +105,11 @@ case functorHandler of ApplyFunctors -> AppT functorTy ty StripFunctors -> ty- in handleFunctor <$> toResultTypeQ schemaResult+ in handleFunctor <$> toResultTypeQ schemaResult go :: SchemaTypeV -> [GetterOperation] -> Q UnwrapSchemaResult go schemaType [] = pure $ SchemaResult schemaType- go schemaType' (op:ops) = do+ go schemaType' (op : ops) = do schemaType <- resolveSchemaType schemaType' let invalid message = fail $ message ++ ": " ++ showSchemaTypeV schemaType@@ -114,24 +124,20 @@ Just inner -> go inner ops Nothing -> invalid $ "Key '" ++ key ++ "' does not exist in schema" _ -> invalid $ "Cannot get key '" ++ key ++ "' in schema"- GetterBang -> case schemaType of SchemaMaybe inner -> go inner ops SchemaTry inner -> go inner ops _ -> invalid "Cannot use `!` operator on schema"- GetterMapMaybe -> case schemaType of SchemaMaybe inner -> wrapMaybe <$> go inner ops SchemaTry inner -> wrapMaybe <$> go inner ops _ -> invalid "Cannot use `?` operator on schema"- GetterMapList -> case schemaType of SchemaList inner -> wrapList <$> go inner ops _ -> invalid "Cannot use `[]` operator on schema"- GetterBranch branch -> case schemaType of SchemaUnion schemas ->@@ -139,7 +145,6 @@ then go (schemas !! branch) ops else invalid "Branch out of bounds for schema" _ -> invalid "Cannot use `@` operator on schema"- -- suffixes; ops should be empty GetterList elemOps ->@@ -151,7 +156,6 @@ then pure $ SchemaResultList elemSchema else invalid "List contains different types in schema" _ -> invalid "Cannot get keys in schema"- GetterTuple elemOps -> case schemaType of SchemaObject _ -> SchemaResultTuple <$> mapM (go schemaType . NonEmpty.toList) (NonEmpty.toList elemOps)@@ -161,10 +165,13 @@ = SchemaResult SchemaTypeV | SchemaResultList UnwrapSchemaResult | SchemaResultTuple [UnwrapSchemaResult]- | SchemaResultWrapped Type UnwrapSchemaResult -- ^ Type should be of kind `* -> *`+ | -- | Type should be of kind `* -> *`+ SchemaResultWrapped Type UnwrapSchemaResult deriving (Eq) -- | A data type that indicates how to handle functors when unwrapping a schema. data FunctorHandler- = ApplyFunctors -- ^ handleFunctor Maybe Int ==> Maybe Int- | StripFunctors -- ^ handleFunctor Maybe Int ==> Int+ = -- | handleFunctor Maybe Int ==> Maybe Int+ ApplyFunctors+ | -- | handleFunctor Maybe Int ==> Int+ StripFunctors
src/Data/Aeson/Schema/TH/Utils.hs view
@@ -1,9 +1,3 @@-{-|-Module : Data.Aeson.Schema.TH.Utils-Maintainer : Brandon Chinn <brandon@leapyear.io>-Stability : experimental-Portability : portable--} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}@@ -13,14 +7,20 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} -module Data.Aeson.Schema.TH.Utils- ( reifySchema- , lookupSchema- , loadSchema- , resolveSchemaType- , schemaVToTypeQ- , schemaTypeVToTypeQ- ) where+{- |+Module : Data.Aeson.Schema.TH.Utils+Maintainer : Brandon Chinn <brandon@leapyear.io>+Stability : experimental+Portability : portable+-}+module Data.Aeson.Schema.TH.Utils (+ reifySchema,+ lookupSchema,+ loadSchema,+ resolveSchemaType,+ schemaVToTypeQ,+ schemaTypeVToTypeQ,+) where import Control.Applicative (empty) import Control.Monad (forM)@@ -28,18 +28,18 @@ import Language.Haskell.TH import Data.Aeson.Schema.Internal (Object)-import Data.Aeson.Schema.Key (SchemaKey'(..), SchemaKeyV)-import Data.Aeson.Schema.Type- ( Schema'(..)- , SchemaObjectMapV- , SchemaType'(..)- , SchemaTypeV- , SchemaV- , fromSchemaV- , toSchemaObjectV- )+import Data.Aeson.Schema.Key (SchemaKey' (..), SchemaKeyV)+import Data.Aeson.Schema.Type (+ Schema' (..),+ SchemaObjectMapV,+ SchemaType' (..),+ SchemaTypeV,+ SchemaV,+ fromSchemaV,+ toSchemaObjectV,+ ) import Data.Aeson.Schema.Utils.Invariant (unreachable)-import Data.Aeson.Schema.Utils.NameLike (NameLike(..), resolveName)+import Data.Aeson.Schema.Utils.NameLike (NameLike (..), resolveName) {- Loading schema from TH -} @@ -51,8 +51,9 @@ , reifiedSchemaType :: TypeWithoutKinds } --- | Look up a schema with the given name. Errors if the name doesn't exist or if the name does--- not refer to a schema.+{- | Look up a schema with the given name. Errors if the name doesn't exist or if the name does+ not refer to a schema.+-} lookupSchema :: NameLike -> Q ReifiedSchema lookupSchema nameLike = do name <- lookupSchemaName nameLike@@ -63,22 +64,20 @@ NameTH name -> return name reifySchemaType :: Name -> Q TypeWithoutKinds- reifySchemaType schemaName = reify schemaName >>= \case- TyConI (TySynD _ _ (stripKinds -> ty))- -- `type MySchema = 'Schema '[ ... ]`- | isPromotedSchema ty- -> return ty-- -- `type MySchema = Object ('Schema '[ ... ])`- | Just inner <- unwrapObject ty- , isPromotedSchema inner- -> return inner-- -- `type MySchema = Object OtherSchema`- | Just (ConT schemaName') <- unwrapObject ty- -> reifySchemaType schemaName'-- _ -> fail $ "'" ++ show schemaName ++ "' is not a Schema"+ reifySchemaType schemaName =+ reify schemaName >>= \case+ TyConI (TySynD _ _ (stripKinds -> ty))+ -- `type MySchema = 'Schema '[ ... ]`+ | isPromotedSchema ty ->+ return ty+ -- `type MySchema = Object ('Schema '[ ... ])`+ | Just inner <- unwrapObject ty+ , isPromotedSchema inner ->+ return inner+ -- `type MySchema = Object OtherSchema`+ | Just (ConT schemaName') <- unwrapObject ty ->+ reifySchemaType schemaName'+ _ -> fail $ "'" ++ show schemaName ++ "' is not a Schema" -- If the given type is of the format `Object a`, return `a`. unwrapObject :: TypeWithoutKinds -> Maybe TypeWithoutKinds@@ -127,25 +126,18 @@ parseSchemaType = \case AppT (PromotedT name) (ConT inner) | name == 'SchemaScalar -> return $ SchemaScalar $ NameTH inner- AppT (PromotedT name) inner- | name == 'SchemaMaybe -> SchemaMaybe <$> parseSchemaType inner-- | name == 'SchemaTry -> SchemaTry <$> parseSchemaType inner-- | name == 'SchemaList -> SchemaList <$> parseSchemaType inner-- | name == 'SchemaUnion -> do- schemas <- typeToList inner- SchemaUnion <$> mapM parseSchemaType schemas-+ | name == 'SchemaMaybe -> SchemaMaybe <$> parseSchemaType inner+ | name == 'SchemaTry -> SchemaTry <$> parseSchemaType inner+ | name == 'SchemaList -> SchemaList <$> parseSchemaType inner+ | name == 'SchemaUnion -> do+ schemas <- typeToList inner+ SchemaUnion <$> mapM parseSchemaType schemas | name == 'SchemaObject -> SchemaObject <$> parseSchemaObjectMap inner- AppT (PromotedT name) (AppT (PromotedT right) (ConT inner)) | name == 'SchemaInclude- , right == 'Right- -> return $ SchemaInclude $ Left $ NameTH inner-+ , right == 'Right ->+ return $ SchemaInclude $ Left $ NameTH inner _ -> empty -- | Resolve SchemaInclude, if present. (Not recursive)@@ -158,7 +150,7 @@ {- Splicing schema into TH -} schemaVToTypeQ :: SchemaV -> TypeQ-schemaVToTypeQ = appT [t| 'Schema |] . schemaObjectMapVToTypeQ . fromSchemaV+schemaVToTypeQ = appT [t| 'Schema|] . schemaObjectMapVToTypeQ . fromSchemaV schemaObjectMapVToTypeQ :: SchemaObjectMapV -> TypeQ schemaObjectMapVToTypeQ = promotedListT . map schemaObjectPairVToTypeQ@@ -168,26 +160,27 @@ schemaKeyVToTypeQ :: SchemaKeyV -> TypeQ schemaKeyVToTypeQ = \case- NormalKey key -> [t| 'NormalKey $(litT $ strTyLit key) |]- PhantomKey key -> [t| 'PhantomKey $(litT $ strTyLit key) |]+ NormalKey key -> [t| 'NormalKey $(litT $ strTyLit key)|]+ PhantomKey key -> [t| 'PhantomKey $(litT $ strTyLit key)|] schemaTypeVToTypeQ :: SchemaTypeV -> TypeQ schemaTypeVToTypeQ = \case- SchemaScalar name -> [t| 'SchemaScalar $(resolveName name >>= conT) |]- SchemaMaybe inner -> [t| 'SchemaMaybe $(schemaTypeVToTypeQ inner) |]- SchemaTry inner -> [t| 'SchemaTry $(schemaTypeVToTypeQ inner) |]- SchemaList inner -> [t| 'SchemaList $(schemaTypeVToTypeQ inner) |]- SchemaUnion schemas -> [t| 'SchemaUnion $(promotedListT $ map schemaTypeVToTypeQ schemas) |]- SchemaObject pairs -> [t| 'SchemaObject $(schemaObjectMapVToTypeQ pairs) |]- SchemaInclude (Left name) -> [t| 'SchemaInclude ('Right $(conT . reifiedSchemaName =<< lookupSchema name)) |]- SchemaInclude (Right _) -> unreachable "Found 'SchemaInclude Right' when converting to TypeQ"+ SchemaScalar name -> [t| 'SchemaScalar $(resolveName name >>= conT)|]+ SchemaMaybe inner -> [t| 'SchemaMaybe $(schemaTypeVToTypeQ inner)|]+ SchemaTry inner -> [t| 'SchemaTry $(schemaTypeVToTypeQ inner)|]+ SchemaList inner -> [t| 'SchemaList $(schemaTypeVToTypeQ inner)|]+ SchemaUnion schemas -> [t| 'SchemaUnion $(promotedListT $ map schemaTypeVToTypeQ schemas)|]+ SchemaObject pairs -> [t| 'SchemaObject $(schemaObjectMapVToTypeQ pairs)|]+ SchemaInclude (Left name) -> [t| 'SchemaInclude ( 'Right $(conT . reifiedSchemaName =<< lookupSchema name))|]+ SchemaInclude (Right _) -> unreachable "Found 'SchemaInclude Right' when converting to TypeQ" {- TH utilities -} --- | Same as 'Type' except without any kind signatures or applications at any depth.------ Provides no actual guarantees. The caller is responsible for making sure the value--- has been run through 'stripKinds' at one point.+{- | Same as 'Type' except without any kind signatures or applications at any depth.++ Provides no actual guarantees. The caller is responsible for making sure the value+ has been run through 'stripKinds' at one point.+-} type TypeWithoutKinds = Type -- | Recursively strip all kind signatures and applications.@@ -214,27 +207,30 @@ #endif -- base cases- VarT _ -> ty- ConT _ -> ty- PromotedT _ -> ty- TupleT _ -> ty- UnboxedTupleT _ -> ty- UnboxedSumT _ -> ty- ArrowT -> ty- EqualityT -> ty- ListT -> ty+ VarT _ -> ty+ ConT _ -> ty+ PromotedT _ -> ty+ TupleT _ -> ty+ UnboxedTupleT _ -> ty+ UnboxedSumT _ -> ty+ ArrowT -> ty+#if MIN_VERSION_template_haskell(2,17,0)+ MulArrowT -> ty+#endif+ EqualityT -> ty+ ListT -> ty PromotedTupleT _ -> ty- PromotedNilT -> ty- PromotedConsT -> ty- StarT -> ty- ConstraintT -> ty- LitT _ -> ty- WildCardT -> ty+ PromotedNilT -> ty+ PromotedConsT -> ty+ StarT -> ty+ ConstraintT -> ty+ LitT _ -> ty+ WildCardT -> ty typeToList :: TypeWithoutKinds -> Maybe [TypeWithoutKinds] typeToList = \case PromotedNilT -> Just []- AppT (AppT PromotedConsT x) xs -> (x:) <$> typeToList xs+ AppT (AppT PromotedConsT x) xs -> (x :) <$> typeToList xs _ -> Nothing typeToPair :: TypeWithoutKinds -> Maybe (TypeWithoutKinds, TypeWithoutKinds)@@ -249,4 +245,4 @@ consT x xs = appT (appT promotedConsT x) xs promotedPairT :: (TypeQ, TypeQ) -> TypeQ-promotedPairT (a, b) = [t| '( $a, $b ) |]+promotedPairT (a, b) = [t|'($a, $b)|]
src/Data/Aeson/Schema/Type.hs view
@@ -1,11 +1,3 @@-{-|-Module : Data.Aeson.Schema.Type-Maintainer : Brandon Chinn <brandon@leapyear.io>-Stability : experimental-Portability : portable--Defines SchemaType, the AST that defines a JSON schema.--} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -16,36 +8,49 @@ {-# LANGUAGE TypeInType #-} {-# LANGUAGE UndecidableInstances #-} -module Data.Aeson.Schema.Type- ( Schema'(..)- , SchemaType'(..)- , SchemaV- , SchemaTypeV- , SchemaObjectMapV- , toSchemaObjectV- , fromSchemaV- , showSchemaV- , showSchemaTypeV- , Schema- , SchemaType- , ToSchemaObject- , FromSchema- , IsSchemaType(..)- , IsSchemaObjectMap- , toSchemaV- ) where+{- |+Module : Data.Aeson.Schema.Type+Maintainer : Brandon Chinn <brandon@leapyear.io>+Stability : experimental+Portability : portable +Defines SchemaType, the AST that defines a JSON schema.+-}+module Data.Aeson.Schema.Type (+ Schema' (..),+ SchemaType' (..),+ SchemaV,+ SchemaTypeV,+ SchemaObjectMapV,+ toSchemaObjectV,+ fromSchemaV,+ showSchemaV,+ showSchemaTypeV,+ Schema,+ SchemaType,+ ToSchemaObject,+ FromSchema,+ IsSchemaType (..),+ IsSchemaObjectMap,+ toSchemaV,+) where+ import Data.Kind (Type) import Data.List (intercalate)-import Data.Proxy (Proxy(..))+import Data.Proxy (Proxy (..)) import Data.Typeable (Typeable, tyConName, typeRep, typeRepTyCon) import GHC.TypeLits (Symbol) -import Data.Aeson.Schema.Key- (IsSchemaKey(..), SchemaKey, SchemaKey', SchemaKeyV, showSchemaKeyV)-import Data.Aeson.Schema.Utils.All (All(..))+import Data.Aeson.Schema.Key (+ IsSchemaKey (..),+ SchemaKey,+ SchemaKey',+ SchemaKeyV,+ showSchemaKeyV,+ )+import Data.Aeson.Schema.Utils.All (All (..)) import Data.Aeson.Schema.Utils.Invariant (unreachable)-import Data.Aeson.Schema.Utils.NameLike (NameLike(..), fromName)+import Data.Aeson.Schema.Utils.NameLike (NameLike (..), fromName) -- | The schema definition for a JSON object. data Schema' s ty = Schema (SchemaObjectMap' s ty)@@ -55,18 +60,20 @@ data SchemaType' s ty = SchemaScalar ty | SchemaMaybe (SchemaType' s ty)- | SchemaTry (SchemaType' s ty) -- ^ @since v1.2.0+ | -- | @since v1.2.0+ SchemaTry (SchemaType' s ty) | SchemaList (SchemaType' s ty)- | SchemaUnion [SchemaType' s ty] -- ^ @since v1.1.0+ | -- | @since v1.1.0+ SchemaUnion [SchemaType' s ty] | SchemaObject (SchemaObjectMap' s ty)- | SchemaInclude (Either ty (Schema' s ty))- -- ^ An optimization for including schemas.+ | -- | An optimization for including schemas. -- -- Will always be 'Left' when used in a value-level schema and 'Right' when used in -- a type-level schema. We can't use a type parameter for this because type synonyms -- can't be recursive (e.g. `type Schema = Schema' Symbol Type Schema`). -- -- @since v1.3.2+ SchemaInclude (Either ty (Schema' s ty)) deriving (Show, Eq) type SchemaObjectMap' s ty = [(SchemaKey' s, SchemaType' s ty)]@@ -115,12 +122,13 @@ {- Type-level schema types -} --- | The kind of schemas that may be used with Object; e.g.------ > data Payload (schema :: Schema) = Payload--- > { getPayload :: Object schema--- > , timestamp :: UTCTime--- > }+{- | The kind of schemas that may be used with Object; e.g.++ > data Payload (schema :: Schema) = Payload+ > { getPayload :: Object schema+ > , timestamp :: UTCTime+ > }+-} type Schema = Schema' Symbol Type type SchemaType = SchemaType' Symbol Type@@ -128,10 +136,10 @@ type SchemaObjectMap = SchemaObjectMap' Symbol Type type family ToSchemaObject (schema :: Schema) :: SchemaType where- ToSchemaObject ('Schema schema) = 'SchemaObject schema+ ToSchemaObject ( 'Schema schema) = 'SchemaObject schema type family FromSchema (schema :: Schema) :: SchemaObjectMap where- FromSchema ('Schema schema) = schema+ FromSchema ( 'Schema schema) = schema toSchemaV :: forall schema. IsSchemaObjectMap (FromSchema schema) => Proxy schema -> SchemaV toSchemaV _ = Schema $ toSchemaTypeMapV $ Proxy @(FromSchema schema)@@ -142,25 +150,25 @@ class IsSchemaType (schemaType :: SchemaType) where toSchemaTypeV :: Proxy schemaType -> SchemaTypeV -instance Typeable inner => IsSchemaType ('SchemaScalar inner) where+instance Typeable inner => IsSchemaType ( 'SchemaScalar inner) where toSchemaTypeV _ = SchemaScalar (NameRef $ tyConName $ typeRepTyCon $ typeRep $ Proxy @inner) -instance IsSchemaType inner => IsSchemaType ('SchemaMaybe inner) where+instance IsSchemaType inner => IsSchemaType ( 'SchemaMaybe inner) where toSchemaTypeV _ = SchemaMaybe (toSchemaTypeV $ Proxy @inner) -instance IsSchemaType inner => IsSchemaType ('SchemaTry inner) where+instance IsSchemaType inner => IsSchemaType ( 'SchemaTry inner) where toSchemaTypeV _ = SchemaTry (toSchemaTypeV $ Proxy @inner) -instance IsSchemaType inner => IsSchemaType ('SchemaList inner) where+instance IsSchemaType inner => IsSchemaType ( 'SchemaList inner) where toSchemaTypeV _ = SchemaList (toSchemaTypeV $ Proxy @inner) -instance All IsSchemaType schemas => IsSchemaType ('SchemaUnion schemas) where+instance All IsSchemaType schemas => IsSchemaType ( 'SchemaUnion schemas) where toSchemaTypeV _ = SchemaUnion (mapAll @IsSchemaType @schemas toSchemaTypeV) -instance IsSchemaObjectMap pairs => IsSchemaType ('SchemaObject pairs) where+instance IsSchemaObjectMap pairs => IsSchemaType ( 'SchemaObject pairs) where toSchemaTypeV _ = SchemaObject (toSchemaTypeMapV $ Proxy @pairs) -instance IsSchemaObjectMap (FromSchema schema) => IsSchemaType ('SchemaInclude ('Right schema)) where+instance IsSchemaObjectMap (FromSchema schema) => IsSchemaType ( 'SchemaInclude ( 'Right schema)) where toSchemaTypeV _ = toSchemaObjectV $ toSchemaV $ Proxy @schema type IsSchemaObjectMap (pairs :: SchemaObjectMap) = All IsSchemaObjectPair pairs
src/Data/Aeson/Schema/Utils/All.hs view
@@ -9,11 +9,11 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} -module Data.Aeson.Schema.Utils.All- ( All(..)- ) where+module Data.Aeson.Schema.Utils.All (+ All (..),+) where -import Data.Proxy (Proxy(..))+import Data.Proxy (Proxy (..)) -- | A type family for traversing a type-level list. class All f xs where
src/Data/Aeson/Schema/Utils/Invariant.hs view
@@ -1,11 +1,14 @@-module Data.Aeson.Schema.Utils.Invariant- ( unreachable- ) where+module Data.Aeson.Schema.Utils.Invariant (+ unreachable,+) where --- | An error function to indicate that a branch is unreachable. Provides a useful error message--- if it ends up happening, pointing users to write a bug report.+{- | An error function to indicate that a branch is unreachable. Provides a useful error message+ if it ends up happening, pointing users to write a bug report.+-} unreachable :: String -> a-unreachable msg = error $ unlines- [ "`aeson-schemas` internal error: " ++ msg- , "Please file a bug report at https://github.com/LeapYear/aeson-schemas/issues/"- ]+unreachable msg =+ error $+ unlines+ [ "`aeson-schemas` internal error: " ++ msg+ , "Please file a bug report at https://github.com/LeapYear/aeson-schemas/issues/"+ ]
src/Data/Aeson/Schema/Utils/NameLike.hs view
@@ -1,11 +1,11 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TemplateHaskell #-} -module Data.Aeson.Schema.Utils.NameLike- ( NameLike(..)- , fromName- , resolveName- ) where+module Data.Aeson.Schema.Utils.NameLike (+ NameLike (..),+ fromName,+ resolveName,+) where import Data.Text (Text) import Language.Haskell.TH.Syntax (Name, Q, lookupTypeName, nameBase)@@ -26,11 +26,10 @@ resolveName :: NameLike -> Q Name resolveName = \case -- some hardcoded cases- NameRef "Bool" -> pure ''Bool- NameRef "Int" -> pure ''Int+ NameRef "Bool" -> pure ''Bool+ NameRef "Int" -> pure ''Int NameRef "Double" -> pure ''Double- NameRef "Text" -> pure ''Text-+ NameRef "Text" -> pure ''Text -- general cases- NameRef name -> lookupTypeName name >>= maybe (fail $ "Unknown type: " ++ name) pure- NameTH name -> pure name+ NameRef name -> lookupTypeName name >>= maybe (fail $ "Unknown type: " ++ name) pure+ NameTH name -> pure name
src/Data/Aeson/Schema/Utils/Sum.hs view
@@ -1,12 +1,3 @@-{-|-Module : Data.Aeson.Schema.Utils.Sum-Maintainer : Brandon Chinn <brandon@leapyear.io>-Stability : experimental-Portability : portable--The 'SumType' data type that represents a sum type consisting of types-specified in a type-level list.--} {-# LANGUAGE DataKinds #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-}@@ -22,47 +13,57 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -module Data.Aeson.Schema.Utils.Sum- ( SumType(..)- , fromSumType- ) where+{- |+Module : Data.Aeson.Schema.Utils.Sum+Maintainer : Brandon Chinn <brandon@leapyear.io>+Stability : experimental+Portability : portable +The 'SumType' data type that represents a sum type consisting of types+specified in a type-level list.+-}+module Data.Aeson.Schema.Utils.Sum (+ SumType (..),+ fromSumType,+) where+ import Control.Applicative ((<|>))-import Data.Aeson (FromJSON(..), ToJSON(..))+import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.Kind (Constraint, Type)-import Data.Proxy (Proxy(..))-import GHC.TypeLits (type (-), ErrorMessage(..), Nat, TypeError)+import Data.Proxy (Proxy (..))+import GHC.TypeLits (ErrorMessage (..), Nat, TypeError, type (-)) --- | Represents a sum type.------ Loads the first type that successfully parses the JSON value.------ Example:------ @--- data Owl = Owl--- data Cat = Cat--- data Toad = Toad--- type Animal = SumType '[Owl, Cat, Toad]------ Here Owl :: Animal--- There (Here Cat) :: Animal--- There (There (Here Toad)) :: Animal------ {- Fails at compile-time--- Here True :: Animal--- Here Cat :: Animal--- There (Here Owl) :: Animal--- There (There (There (Here Owl))) :: Animal--- -}--- @+{- | Represents a sum type.++ Loads the first type that successfully parses the JSON value.++ Example:++ @+ data Owl = Owl+ data Cat = Cat+ data Toad = Toad+ type Animal = SumType '[Owl, Cat, Toad]++ Here Owl :: Animal+ There (Here Cat) :: Animal+ There (There (Here Toad)) :: Animal++ {\- Fails at compile-time+ Here True :: Animal+ Here Cat :: Animal+ There (Here Owl) :: Animal+ There (There (There (Here Owl))) :: Animal+ -\}+ @+-} data SumType (types :: [Type]) where- Here :: forall x xs. x -> SumType (x ': xs)+ Here :: forall x xs. x -> SumType (x ': xs) There :: forall x xs. SumType xs -> SumType (x ': xs) deriving instance (Show x, Show (SumType xs)) => Show (SumType (x ': xs)) instance Show (SumType '[]) where- show = \case {}+ show = \case deriving instance (Eq x, Eq (SumType xs)) => Eq (SumType (x ': xs)) instance Eq (SumType '[]) where@@ -84,7 +85,7 @@ There xs -> toJSON xs instance ToJSON (SumType '[]) where- toJSON = \case {}+ toJSON = \case {- Extracting sum type branches -} @@ -96,50 +97,57 @@ Here x -> Just x There _ -> Nothing -instance {-# OVERLAPPABLE #-}+instance+ {-# OVERLAPPABLE #-} ( FromSumType (n - 1) xs x , 'Just x ~ GetIndex (n - 1) xs- ) => FromSumType n (_x ': xs) x where+ ) =>+ FromSumType n (_x ': xs) x+ where fromSumType' _ = \case Here _ -> Nothing There xs -> fromSumType' (Proxy @(n - 1)) xs --- | Extract a value from a 'SumType'------ Example:------ @--- type Animal = SumType '[Owl, Cat, Toad]--- let someAnimal = ... :: Animal------ fromSumType (Proxy :: Proxy 0) someAnimal :: Maybe Owl--- fromSumType (Proxy :: Proxy 1) someAnimal :: Maybe Cat--- fromSumType (Proxy :: Proxy 2) someAnimal :: Maybe Toad------ -- Compile-time error--- -- fromSumType (Proxy :: Proxy 3) someAnimal--- @-fromSumType- :: ( IsInRange n types- , 'Just result ~ GetIndex n types- , FromSumType n types result- )- => proxy n -> SumType types -> Maybe result+{- | Extract a value from a 'SumType'++ Example:++ @+ type Animal = SumType '[Owl, Cat, Toad]+ let someAnimal = ... :: Animal++ fromSumType (Proxy :: Proxy 0) someAnimal :: Maybe Owl+ fromSumType (Proxy :: Proxy 1) someAnimal :: Maybe Cat+ fromSumType (Proxy :: Proxy 2) someAnimal :: Maybe Toad++ -- Compile-time error+ -- fromSumType (Proxy :: Proxy 3) someAnimal+ @+-}+fromSumType ::+ ( IsInRange n types+ , 'Just result ~ GetIndex n types+ , FromSumType n types result+ ) =>+ proxy n ->+ SumType types ->+ Maybe result fromSumType = fromSumType' {- Helpers -} type family IsInRange (n :: Nat) (xs :: [Type]) :: Constraint where- IsInRange n xs = IsInRange'- ( TypeError- ( 'Text "Index "- ':<>: 'ShowType n- ':<>: 'Text " does not exist in list: "- ':<>: 'ShowType xs+ IsInRange n xs =+ IsInRange'+ ( TypeError+ ( 'Text "Index "+ ':<>: 'ShowType n+ ':<>: 'Text " does not exist in list: "+ ':<>: 'ShowType xs+ ) )- )- n- xs+ n+ xs type family IsInRange' typeErr (n :: Nat) (xs :: [Type]) :: Constraint where IsInRange' typeErr _ '[] = typeErr
test/Main.hs view
@@ -9,12 +9,15 @@ import qualified Tests.UnwrapQQ main :: IO ()-main = defaultMain $ testGroup "aeson-schemas"- [ Tests.Object.test- , Tests.GetQQ.test- , Tests.UnwrapQQ.test- , Tests.SchemaQQ.test- , Tests.MkGetter.test- , Tests.EnumTH.test- , Tests.SumType.test- ]+main =+ defaultMain $+ testGroup+ "aeson-schemas"+ [ Tests.Object.test+ , Tests.GetQQ.test+ , Tests.UnwrapQQ.test+ , Tests.SchemaQQ.test+ , Tests.MkGetter.test+ , Tests.EnumTH.test+ , Tests.SumType.test+ ]
test/TestUtils.hs view
@@ -10,24 +10,25 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -module TestUtils- ( ShowSchemaResult(..)- , json- , parseValue- , parseObject- , parseProxy- , mkExpQQ- , testGolden- , testGoldenIO- , testParseError- ) where+module TestUtils (+ ShowSchemaResult (..),+ json,+ parseValue,+ parseObject,+ parseProxy,+ mkExpQQ,+ testGolden,+ testGoldenIO,+ testParseError,+) where -import Data.Aeson (FromJSON(..), Value, eitherDecode)+import Data.Aeson (FromJSON (..), Value, eitherDecode) import Data.Aeson.Types (parseEither)+ #if !MIN_VERSION_megaparsec(7,0,0) import Data.Char (isDigit, isSpace) #endif-import Data.Proxy (Proxy(..))+import Data.Proxy (Proxy (..)) import Data.String (fromString) import qualified Data.Text as Text import qualified Data.Text.IO as Text@@ -35,7 +36,7 @@ import qualified Data.Text.Lazy.Encoding as TextL import Data.Typeable (Typeable, typeRep) import Language.Haskell.TH (ExpQ)-import Language.Haskell.TH.Quote (QuasiQuoter(..))+import Language.Haskell.TH.Quote (QuasiQuoter (..)) import Test.Tasty (TestTree) import Test.Tasty.Golden (goldenVsString) import Test.Tasty.Golden.Advanced (goldenTest)@@ -60,7 +61,7 @@ {- Loading JSON data -} json :: QuasiQuoter-json = mkExpQQ $ \s -> [| (either error id . eitherDecode . fromString) s |]+json = mkExpQQ $ \s -> [|(either error id . eitherDecode . fromString) s|] parseValue :: FromJSON a => Value -> a parseValue = either error id . parseEither parseJSON@@ -69,19 +70,20 @@ parseProxy _ = parseEither parseJSON parseObject :: String -> ExpQ-parseObject schemaString = [| parseValue :: Value -> Object $schemaType |]+parseObject schemaString = [|parseValue :: Value -> Object $schemaType|] where schemaType = quoteType schema schemaString {- QuasiQuotation -} mkExpQQ :: (String -> ExpQ) -> QuasiQuoter-mkExpQQ f = QuasiQuoter- { quoteExp = f- , quotePat = error "Cannot use this QuasiQuoter for patterns"- , quoteType = error "Cannot use this QuasiQuoter for types"- , quoteDec = error "Cannot use this QuasiQuoter for declarations"- }+mkExpQQ f =+ QuasiQuoter+ { quoteExp = f+ , quotePat = error "Cannot use this QuasiQuoter for patterns"+ , quoteType = error "Cannot use this QuasiQuoter for types"+ , quoteDec = error "Cannot use this QuasiQuoter for declarations"+ } {- Tasty test trees -} @@ -100,9 +102,11 @@ goldenFile = "test/goldens/" ++ fp getExpected = sanitize <$> Text.readFile goldenFile getActual = return $ Text.pack s- cmp expected actual = return $ if expected == actual- then Nothing- else Just $ "Test output was different from '" ++ goldenFile ++ "'. It was:\n" ++ Text.unpack actual+ cmp expected actual =+ return $+ if expected == actual+ then Nothing+ else Just $ "Test output was different from '" ++ goldenFile ++ "'. It was:\n" ++ Text.unpack actual update = Text.writeFile goldenFile #if MIN_VERSION_megaparsec(7,0,0)
test/TestUtils/Arbitrary.hs view
@@ -17,17 +17,17 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} -module TestUtils.Arbitrary- ( ArbitraryObject(..)- , forAllArbitraryObjects- ) where+module TestUtils.Arbitrary (+ ArbitraryObject (..),+ forAllArbitraryObjects,+) where import Control.Monad (forM)-import Data.Aeson (ToJSON(..), Value(..), encode)+import Data.Aeson (ToJSON (..), Value (..), encode) import qualified Data.Aeson as Aeson import qualified Data.HashMap.Strict as HashMap import Data.List (nub)-import Data.Proxy (Proxy(..))+import Data.Proxy (Proxy (..)) import Data.Text (Text) import qualified Data.Text as Text import Data.Typeable (Typeable)@@ -35,72 +35,81 @@ import GHC.TypeLits (KnownSymbol) import Language.Haskell.TH (ExpQ, listE, runIO) import Language.Haskell.TH.Instances ()-import Language.Haskell.TH.Quote (QuasiQuoter(quoteType))+import Language.Haskell.TH.Quote (QuasiQuoter (quoteType)) import Language.Haskell.TH.Syntax (Lift) import Test.QuickCheck import Data.Aeson.Schema (IsSchema, Object, schema)-import Data.Aeson.Schema.Key- (IsSchemaKey(..), SchemaKey, SchemaKey'(..), SchemaKeyV, toContext)-import Data.Aeson.Schema.Type- ( Schema'(..)- , SchemaObjectMapV- , SchemaType- , SchemaType'(..)- , SchemaTypeV- , SchemaV- , showSchemaV- , toSchemaObjectV- )-import Data.Aeson.Schema.Utils.All (All(..))-import Data.Aeson.Schema.Utils.NameLike (NameLike(..), fromName)+import Data.Aeson.Schema.Key (+ IsSchemaKey (..),+ SchemaKey,+ SchemaKey' (..),+ SchemaKeyV,+ toContext,+ )+import Data.Aeson.Schema.Type (+ Schema' (..),+ SchemaObjectMapV,+ SchemaType,+ SchemaType' (..),+ SchemaTypeV,+ SchemaV,+ showSchemaV,+ toSchemaObjectV,+ )+import Data.Aeson.Schema.Utils.All (All (..))+import Data.Aeson.Schema.Utils.NameLike (NameLike (..), fromName) data ArbitraryObject where- ArbitraryObject- :: IsSchema schema- => Proxy (Object schema)- -> Value- -> SchemaV- -> ArbitraryObject+ ArbitraryObject ::+ IsSchema schema =>+ Proxy (Object schema) ->+ Value ->+ SchemaV ->+ ArbitraryObject -- Show the value and schema as something that could be copied/pasted into GHCi. instance Show ArbitraryObject where- show (ArbitraryObject _ v schemaV) = unlines- [ "ArbitraryObject:"- , " " ++ show (encode v)- , " [schema| " ++ showSchemaV schemaV ++ " |]"- ]+ show (ArbitraryObject _ v schemaV) =+ unlines+ [ "ArbitraryObject:"+ , " " ++ show (encode v)+ , " [schema| " ++ showSchemaV schemaV ++ " |]"+ ] --- | A Template Haskell function to generate a splice for QuickCheck tests to generate arbitrary--- objects with arbitrary schemas.------ Note that for repeated runs of the test suite, the schemas will be the same, with the actual--- JSON values generated randomly. You need to recompile in order to generate different schemas.+{- | A Template Haskell function to generate a splice for QuickCheck tests to generate arbitrary+ objects with arbitrary schemas.++ Note that for repeated runs of the test suite, the schemas will be the same, with the actual+ JSON values generated randomly. You need to recompile in order to generate different schemas.+-} arbitraryObject :: ExpQ arbitraryObject = do arbitrarySchemas <- runIO $ genSchemaTypes 20 - [| oneof $(listE $ map mkSchemaGen arbitrarySchemas) |]+ [|oneof $(listE $ map mkSchemaGen arbitrarySchemas)|] where mkSchemaGen schemaV = let schemaType = quoteType schema $ showSchemaV schemaV- in [| genSchema' (Proxy :: Proxy (Object $schemaType)) schemaV |]+ in [|genSchema' (Proxy :: Proxy (Object $schemaType)) schemaV|] --- | Splices to a 'forAll' with 'arbitraryObject', outputting information about the object--- generated, to ensure we get good generation.------ $(forAllArbitraryObjects) :: Testable prop => ArbitraryObject -> prop+{- |+Splices to a 'forAll' with 'arbitraryObject', outputting information about the object+generated, to ensure we get good generation.++>>> $(forAllArbitraryObjects) :: Testable prop => ArbitraryObject -> prop+-} forAllArbitraryObjects :: ExpQ-forAllArbitraryObjects = [| forAllArbitraryObjects' $arbitraryObject |]+forAllArbitraryObjects = [|forAllArbitraryObjects' $arbitraryObject|] forAllArbitraryObjects' :: Gen ArbitraryObject -> (ArbitraryObject -> Property) -> Property forAllArbitraryObjects' genArbitraryObject runTest = forAll @_ @Property genArbitraryObject $ \o@(ArbitraryObject _ _ schemaType) -> tabulate' "Key types" (map getKeyType $ getKeys schemaType) $- tabulate' "Schema types" (getSchemaTypes schemaType) $- tabulate' "Object sizes" (map show $ getObjectSizes schemaType) $- tabulate' "Object depth" [show $ getObjectDepth schemaType] $- runTest o+ tabulate' "Schema types" (getSchemaTypes schemaType) $+ tabulate' "Object sizes" (map show $ getObjectSizes schemaType) $+ tabulate' "Object depth" [show $ getObjectDepth schemaType] $+ runTest o {- Run time helpers -} @@ -108,13 +117,16 @@ deriving instance Lift SchemaV deriving instance Lift SchemaTypeV -genSchema' :: forall schema.- ( ArbitrarySchema ('SchemaObject schema)- , IsSchema ('Schema schema)- )- => Proxy (Object ('Schema schema)) -> SchemaV -> Gen ArbitraryObject+genSchema' ::+ forall schema.+ ( ArbitrarySchema ( 'SchemaObject schema)+ , IsSchema ( 'Schema schema)+ ) =>+ Proxy (Object ( 'Schema schema)) ->+ SchemaV ->+ Gen ArbitraryObject genSchema' proxy schemaV = do- v <- genSchema @('SchemaObject schema)+ v <- genSchema @( 'SchemaObject schema) return $ ArbitraryObject proxy v schemaV getKeyType :: SchemaKeyV -> String@@ -170,6 +182,7 @@ SchemaInclude _ -> error "ArbitraryObject unexpectedly generated a schema that includes another schema" tabulate' :: String -> [String] -> Property -> Property+ #if MIN_VERSION_QuickCheck(2,12,0) tabulate' = tabulate #else@@ -181,41 +194,44 @@ class ArbitrarySchema (schema :: SchemaType) where genSchema :: Gen Value -instance {-# OVERLAPS #-} ArbitrarySchema ('SchemaScalar Text) where+instance {-# OVERLAPS #-} ArbitrarySchema ( 'SchemaScalar Text) where genSchema = toJSON <$> arbitrary @String -instance (Arbitrary inner, ToJSON inner, Typeable inner) => ArbitrarySchema ('SchemaScalar inner) where+instance (Arbitrary inner, ToJSON inner, Typeable inner) => ArbitrarySchema ( 'SchemaScalar inner) where genSchema = toJSON <$> arbitrary @inner -instance ArbitrarySchema inner => ArbitrarySchema ('SchemaMaybe inner) where- genSchema = frequency- [ (3, genSchema @inner)- , (1, pure Null)- ]+instance ArbitrarySchema inner => ArbitrarySchema ( 'SchemaMaybe inner) where+ genSchema =+ frequency+ [ (3, genSchema @inner)+ , (1, pure Null)+ ] -instance ArbitrarySchema inner => ArbitrarySchema ('SchemaTry inner) where- genSchema = frequency- [ (3, genSchema @inner)- , (1, genValue)- ]+instance ArbitrarySchema inner => ArbitrarySchema ( 'SchemaTry inner) where+ genSchema =+ frequency+ [ (3, genSchema @inner)+ , (1, genValue)+ ] where- genValue = oneof- [ pure Null- , Number . realToFrac <$> arbitrary @Double- , Bool <$> arbitrary- , String . Text.pack <$> arbitrary- ]+ genValue =+ oneof+ [ pure Null+ , Number . realToFrac <$> arbitrary @Double+ , Bool <$> arbitrary+ , String . Text.pack <$> arbitrary+ ] -instance ArbitrarySchema inner => ArbitrarySchema ('SchemaList inner) where+instance ArbitrarySchema inner => ArbitrarySchema ( 'SchemaList inner) where genSchema = Array . fromList <$> listOf (genSchema @inner) -instance All ArbitrarySchema schemas => ArbitrarySchema ('SchemaUnion schemas) where+instance All ArbitrarySchema schemas => ArbitrarySchema ( 'SchemaUnion schemas) where genSchema = oneof $ mapAll @ArbitrarySchema @schemas genSchemaElem where genSchemaElem :: forall schema. ArbitrarySchema schema => Proxy schema -> Gen Value genSchemaElem _ = genSchema @schema -instance All ArbitraryObjectPair pairs => ArbitrarySchema ('SchemaObject (pairs :: [(SchemaKey, SchemaType)])) where+instance All ArbitraryObjectPair pairs => ArbitrarySchema ( 'SchemaObject (pairs :: [(SchemaKey, SchemaType)])) where genSchema = Object . HashMap.unions <$> genSchemaPairs where genSchemaPairs :: Gen [Aeson.Object]@@ -235,15 +251,21 @@ -- For phantom keys, Maybe is only valid for Objects. Since phantom keys parse the schema with -- the current object as the context, we should guarantee that this only generates objects, and -- not Null.-instance {-# OVERLAPS #-} (KnownSymbol key, inner ~ 'SchemaObject a, ArbitrarySchema inner)- => ArbitraryObjectPair '( 'PhantomKey key, 'SchemaMaybe inner ) where+instance+ {-# OVERLAPS #-}+ (KnownSymbol key, inner ~ 'SchemaObject a, ArbitrarySchema inner) =>+ ArbitraryObjectPair '( 'PhantomKey key, 'SchemaMaybe inner)+ where genInnerSchema = genSchema @inner -- For phantom keys, Try can be used on any schema, but for all non-object schemas, need to ensure -- we generate 'Null', because Try on a non-object schema will always be an invalid parse.-instance {-# OVERLAPS #-} (KnownSymbol key, ArbitrarySchema ('SchemaTry inner))- => ArbitraryObjectPair '( 'PhantomKey key, 'SchemaTry inner ) where- genInnerSchema = castNull <$> genSchema @('SchemaTry inner)+instance+ {-# OVERLAPS #-}+ (KnownSymbol key, ArbitrarySchema ( 'SchemaTry inner)) =>+ ArbitraryObjectPair '( 'PhantomKey key, 'SchemaTry inner)+ where+ genInnerSchema = castNull <$> genSchema @( 'SchemaTry inner) where castNull inner = case inner of@@ -251,52 +273,63 @@ _ -> Null -- For phantom keys, Union can be used on any schemas, as long as at least one is an object schema.-instance {-# OVERLAPS #-} (KnownSymbol key, FilterObjectSchemas schemas ~ objectSchemas, ArbitrarySchema ('SchemaUnion objectSchemas))- => ArbitraryObjectPair '( 'PhantomKey key, 'SchemaUnion schemas ) where- genInnerSchema = genSchema @('SchemaUnion objectSchemas)+instance+ {-# OVERLAPS #-}+ (KnownSymbol key, FilterObjectSchemas schemas ~ objectSchemas, ArbitrarySchema ( 'SchemaUnion objectSchemas)) =>+ ArbitraryObjectPair '( 'PhantomKey key, 'SchemaUnion schemas)+ where+ genInnerSchema = genSchema @( 'SchemaUnion objectSchemas) {- Generating schema definitions -} genSchemaTypes :: Int -> IO [SchemaV] genSchemaTypes numSchemasToGenerate =- generate $ sequence $ take numSchemasToGenerate- [ resize n arbitrary | n <- [0,2..] ]+ generate $+ sequence $+ take+ numSchemasToGenerate+ [resize n arbitrary | n <- [0, 2 ..]] instance Arbitrary SchemaV where arbitrary = Schema <$> sized genSchemaObject --- | Generate an arbitrary schema.------ SchemaType is a recursive definition, so we want to make sure that generating a schema will--- terminate, and also not take too long. The ways we account for that are:--- * Providing an upper bound on the depth of any object schemas in the current object (n / 2)--- * Providing an upper bound on the number of keys in the current object (n / 3)--- * Providing an upper bound on the number of schemas in a union (n / 5)+{- | Generate an arbitrary schema.++ SchemaType is a recursive definition, so we want to make sure that generating a schema will+ terminate, and also not take too long. The ways we account for that are:+ * Providing an upper bound on the depth of any object schemas in the current object (n / 2)+ * Providing an upper bound on the number of keys in the current object (n / 3)+ * Providing an upper bound on the number of schemas in a union (n / 5)+-} genSchemaObject :: Int -> Gen SchemaObjectMapV genSchemaObject n = do keys <- genUniqList1 (n `div` 3) genKey- forM keys $ \key -> frequency- [ (10, genSchemaObjectPairNormal key)- , (1, genSchemaObjectPairPhantom key)- ]+ forM keys $ \key ->+ frequency+ [ (10, genSchemaObjectPairNormal key)+ , (1, genSchemaObjectPairPhantom key)+ ] where genSchemaObject' = do n' <- choose (0, n `div` 2) SchemaObject <$> genSchemaObject n' genSchemaObjectPairNormal key = do- schemaType <- frequency $ if n == 0- then scalarSchemaTypes- else allSchemaTypes+ schemaType <-+ frequency $+ if n == 0+ then scalarSchemaTypes+ else allSchemaTypes return (NormalKey key, schemaType) genSchemaObjectPairPhantom key = do- schemaType <- frequency- [ (2, SchemaMaybe <$> genSchemaObject')- , (2, SchemaTry <$> frequency nonNullableSchemaTypes)- , (4, genSchemaObject')- , (1, genSchemaUnion genSchemaObject')- ]+ schemaType <-+ frequency+ [ (2, SchemaMaybe <$> genSchemaObject')+ , (2, SchemaTry <$> frequency nonNullableSchemaTypes)+ , (4, genSchemaObject')+ , (1, genSchemaUnion genSchemaObject')+ ] return (PhantomKey key, schemaType) scalarSchemaTypes =@@ -307,30 +340,31 @@ ] nonNullableSchemaTypes =- scalarSchemaTypes ++- [ (2, SchemaList <$> frequency allSchemaTypes)- , (1, genSchemaUnion $ frequency allSchemaTypes)- , (2, genSchemaObject')- ]+ scalarSchemaTypes+ ++ [ (2, SchemaList <$> frequency allSchemaTypes)+ , (1, genSchemaUnion $ frequency allSchemaTypes)+ , (2, genSchemaObject')+ ] allSchemaTypes =- nonNullableSchemaTypes ++- [ (2, SchemaMaybe <$> frequency nonNullableSchemaTypes)- , (2, SchemaTry <$> frequency nonNullableSchemaTypes)- ]+ nonNullableSchemaTypes+ ++ [ (2, SchemaMaybe <$> frequency nonNullableSchemaTypes)+ , (2, SchemaTry <$> frequency nonNullableSchemaTypes)+ ] -- avoid generating big unions by scaling list length genSchemaUnion gen = SchemaUnion <$> genUniqList1 (n `div` 5) gen ---- | Generate a valid JSON key--- See Data.Aeson.Schema.TH.Parse.jsonKey'+{- | Generate a valid JSON key+ See Data.Aeson.Schema.TH.Parse.jsonKey'+-} genKey :: Gen String genKey = listOf1 $ arbitraryPrintableChar `suchThat` (`notElem` " \"\\!?[](),.@:{}#") --- | Generate a non-empty and unique list of the given generator.------ Takes in the max size of the list.+{- | Generate a non-empty and unique list of the given generator.++ Takes in the max size of the list.+-} genUniqList1 :: Eq a => Int -> Gen a -> Gen [a] genUniqList1 n gen = do k <- choose (1, max 1 n)@@ -343,5 +377,5 @@ type family FilterObjectSchemas schemas where FilterObjectSchemas '[] = '[]- FilterObjectSchemas ('SchemaObject inner ': xs) = 'SchemaObject inner : FilterObjectSchemas xs+ FilterObjectSchemas ( 'SchemaObject inner ': xs) = 'SchemaObject inner : FilterObjectSchemas xs FilterObjectSchemas (_ ': xs) = FilterObjectSchemas xs
test/TestUtils/DeepSeq.hs view
@@ -3,7 +3,8 @@ module TestUtils.DeepSeq () where -import Control.DeepSeq (NFData(..))+import Control.DeepSeq (NFData (..))+ #if MIN_VERSION_template_haskell(2,16,0) import Control.DeepSeq (rwhnf) import GHC.ForeignPtr (ForeignPtr)@@ -54,7 +55,16 @@ instance NFData TypeFamilyHead instance NFData TyLit instance NFData TySynEqn++#if MIN_VERSION_template_haskell(2,17,0)+instance NFData Specificity+#endif++#if MIN_VERSION_template_haskell(2,17,0)+instance NFData flag => NFData (TyVarBndr flag)+#else instance NFData TyVarBndr+#endif #if MIN_VERSION_template_haskell(2,16,0) instance NFData Bytes
test/Tests/EnumTH.hs view
@@ -22,59 +22,68 @@ {- Tests -} test :: TestTree-test = testGroup "Enum TH helpers"- [ testMkEnum- , testGenJSONEnum- ]+test =+ testGroup+ "Enum TH helpers"+ [ testMkEnum+ , testGenJSONEnum+ ] testMkEnum :: TestTree-testMkEnum = testGroup "mkEnum"- [ testProperty "mkEnum decode is case insensitive" $ do- (val, enumVal) <- elements- [ ("OPEN", OPEN)- , ("CLOSED", CLOSED)- ]- casedVal <- randomlyCased val- return $ decode (encode casedVal) === Just enumVal- , testCase "mkEnum encode keeps case of constructor" $ do- encode OPEN @?= "\"OPEN\""- encode CLOSED @?= "\"CLOSED\""- , testProperty "mkEnum: (fromJust . decode . encode) === id" $ do- enumVal <- elements [OPEN, CLOSED]- return $ (decode . encode) enumVal === Just enumVal- ]+testMkEnum =+ testGroup+ "mkEnum"+ [ testProperty "mkEnum decode is case insensitive" $ do+ (val, enumVal) <-+ elements+ [ ("OPEN", OPEN)+ , ("CLOSED", CLOSED)+ ]+ casedVal <- randomlyCased val+ return $ decode (encode casedVal) === Just enumVal+ , testCase "mkEnum encode keeps case of constructor" $ do+ encode OPEN @?= "\"OPEN\""+ encode CLOSED @?= "\"CLOSED\""+ , testProperty "mkEnum: (fromJust . decode . encode) === id" $ do+ enumVal <- elements [OPEN, CLOSED]+ return $ (decode . encode) enumVal === Just enumVal+ ] testGenJSONEnum :: TestTree-testGenJSONEnum = testGroup "gen{To,From}JSONEnum"- [ testProperty "genFromJSONEnum decode is case insensitive" $ do- (val, enumVal) <- elements- [ ("Red", Red)- , ("LightBlue", LightBlue)- , ("Yellow", Yellow)- , ("DarkGreen", DarkGreen)- , ("Black", Black)- , ("JustABitOffWhite", JustABitOffWhite)- ]- casedVal <- randomlyCased val- return $ decode (encode casedVal) === Just enumVal- , testCase "genToJSONEnum encode keeps case of constructor" $ do- encode Red @?= "\"Red\""- encode LightBlue @?= "\"LightBlue\""- encode Yellow @?= "\"Yellow\""- encode DarkGreen @?= "\"DarkGreen\""- encode Black @?= "\"Black\""- encode JustABitOffWhite @?= "\"JustABitOffWhite\""- , testProperty "genFromJSONEnum + genToJSONEnum: (fromJust . decode . encode) === id" $ do- enumVal <- elements- [ Red- , LightBlue- , Yellow- , DarkGreen- , Black- , JustABitOffWhite- ]- return $ (decode . encode) enumVal === Just enumVal- ]+testGenJSONEnum =+ testGroup+ "gen{To,From}JSONEnum"+ [ testProperty "genFromJSONEnum decode is case insensitive" $ do+ (val, enumVal) <-+ elements+ [ ("Red", Red)+ , ("LightBlue", LightBlue)+ , ("Yellow", Yellow)+ , ("DarkGreen", DarkGreen)+ , ("Black", Black)+ , ("JustABitOffWhite", JustABitOffWhite)+ ]+ casedVal <- randomlyCased val+ return $ decode (encode casedVal) === Just enumVal+ , testCase "genToJSONEnum encode keeps case of constructor" $ do+ encode Red @?= "\"Red\""+ encode LightBlue @?= "\"LightBlue\""+ encode Yellow @?= "\"Yellow\""+ encode DarkGreen @?= "\"DarkGreen\""+ encode Black @?= "\"Black\""+ encode JustABitOffWhite @?= "\"JustABitOffWhite\""+ , testProperty "genFromJSONEnum + genToJSONEnum: (fromJust . decode . encode) === id" $ do+ enumVal <-+ elements+ [ Red+ , LightBlue+ , Yellow+ , DarkGreen+ , Black+ , JustABitOffWhite+ ]+ return $ (decode . encode) enumVal === Just enumVal+ ] randomlyCased :: String -> Gen String randomlyCased s = do
test/Tests/GetQQ.hs view
@@ -13,7 +13,7 @@ import Control.DeepSeq (deepseq) import Control.Exception (SomeException, try)-import Data.Aeson (FromJSON(..), ToJSON(..), withText)+import Data.Aeson (FromJSON (..), ToJSON (..), withText) import Data.Aeson.QQ (aesonQQ) import Data.Text (Text) import qualified Data.Text as Text@@ -24,14 +24,14 @@ import Data.Aeson.Schema (Object, schema) import Data.Aeson.Schema.TH (mkEnum)-import Data.Aeson.Schema.Utils.Sum (SumType(..))-import Tests.GetQQ.TH+import Data.Aeson.Schema.Utils.Sum (SumType (..)) import TestUtils (parseObject, testGoldenIO, testParseError)+import Tests.GetQQ.TH mkEnum "Greeting" ["HELLO", "GOODBYE"] newtype Coordinate = Coordinate (Int, Int)- deriving (Show,Eq)+ deriving (Show, Eq) instance ToJSON Coordinate where toJSON (Coordinate (x, y)) = toJSON $ show x ++ "," ++ show y@@ -45,105 +45,108 @@ {- Tests -} test :: TestTree-test = testGroup "`get` quasiquoter"- [ testValidExpressions- , testInvalidExpressions- , testCompileTimeErrors- ]+test =+ testGroup+ "`get` quasiquoter"+ [ testValidExpressions+ , testInvalidExpressions+ , testCompileTimeErrors+ ] testValidExpressions :: TestTree-testValidExpressions = testGroup "Valid get expressions"- [ testScalarExpressions- , testBasicExpressions- , testNullableExpressions- , testListExpressions- , testUnionExpressions- , testPhantomExpressions- , testNestedExpressions- ]+testValidExpressions =+ testGroup+ "Valid get expressions"+ [ testScalarExpressions+ , testBasicExpressions+ , testNullableExpressions+ , testListExpressions+ , testUnionExpressions+ , testPhantomExpressions+ , testNestedExpressions+ ] testScalarExpressions :: TestTree-testScalarExpressions = testGroup "Scalar expressions"- [ testProperty "Get Bool key from object" $ \b ->- let o = $(parseObject "{ foo: Bool }") [aesonQQ| { "foo": #{b} } |]- in [runGet| o.foo |] === b-- , testProperty "Get Int key from object" $ \x ->- let o = $(parseObject "{ foo: Int }") [aesonQQ| { "foo": #{x} } |]- in [runGet| o.foo |] === x-- , testProperty "Get Double key from object" $ \x ->- let o = $(parseObject "{ foo: Double }") [aesonQQ| { "foo": #{x} } |]- in [runGet| o.foo |] === x-- , testProperty "Get Text key from object" $ \(UnicodeText s) ->- let o = $(parseObject "{ foo: Text }") [aesonQQ| { "foo": #{s} } |]- in [runGet| o.foo |] === s-- , testProperty "Get Custom key from object" $ \coordinate ->- let o = $(parseObject "{ foo: Coordinate }") [aesonQQ| { "foo": #{coordinate} } |]- in [runGet| o.foo |] === coordinate-- , testProperty "Get Enum key from object" $ \greeting ->- let o = $(parseObject "{ foo: Greeting }") [aesonQQ| { "foo": #{greeting} } |]- in [runGet| o.foo |] === greeting- ]+testScalarExpressions =+ testGroup+ "Scalar expressions"+ [ testProperty "Get Bool key from object" $ \b ->+ let o = $(parseObject "{ foo: Bool }") [aesonQQ| { "foo": #{b} } |]+ in [runGet| o.foo |] === b+ , testProperty "Get Int key from object" $ \x ->+ let o = $(parseObject "{ foo: Int }") [aesonQQ| { "foo": #{x} } |]+ in [runGet| o.foo |] === x+ , testProperty "Get Double key from object" $ \x ->+ let o = $(parseObject "{ foo: Double }") [aesonQQ| { "foo": #{x} } |]+ in [runGet| o.foo |] === x+ , testProperty "Get Text key from object" $ \(UnicodeText s) ->+ let o = $(parseObject "{ foo: Text }") [aesonQQ| { "foo": #{s} } |]+ in [runGet| o.foo |] === s+ , testProperty "Get Custom key from object" $ \coordinate ->+ let o = $(parseObject "{ foo: Coordinate }") [aesonQQ| { "foo": #{coordinate} } |]+ in [runGet| o.foo |] === coordinate+ , testProperty "Get Enum key from object" $ \greeting ->+ let o = $(parseObject "{ foo: Greeting }") [aesonQQ| { "foo": #{greeting} } |]+ in [runGet| o.foo |] === greeting+ ] testBasicExpressions :: TestTree-testBasicExpressions = testGroup "Basic expressions"- [ testCase "Can query fields on namespaced object" $- [runGet| (Tests.GetQQ.TH.testData).foo |] @?= [runGet| testData.foo |]-- , testProperty "Can query quoted keys" $ \x ->- let o = $(parseObject "{ foo: Int }") [aesonQQ| { "foo": #{x :: Int} } |]- in [runGet| o."foo" |] === [runGet| o.foo |]-- , testProperty "Can query nested fields" $ \x ->- let o = $(parseObject "{ foo: { bar: Int } }") [aesonQQ| { "foo": { "bar": #{x} } } |]- in [runGet| o.foo.bar |] === x-- , testProperty "Can generate a lambda expression" $ \x ->- let o = $(parseObject "{ foo: Int }") [aesonQQ| { "foo": #{x} } |]- in [runGet| .foo |] o === x-- , testProperty "Can extract a list of elements" $ \x y bar ->- let o = $(parseObject "{ x: Int, y: Int, foo: { bar: Int } }") [aesonQQ|+testBasicExpressions =+ testGroup+ "Basic expressions"+ [ testCase "Can query fields on namespaced object" $+ [runGet| (Tests.GetQQ.TH.testData).foo |] @?= [runGet| testData.foo |]+ , testProperty "Can query quoted keys" $ \x ->+ let o = $(parseObject "{ foo: Int }") [aesonQQ| { "foo": #{x :: Int} } |]+ in [runGet| o."foo" |] === [runGet| o.foo |]+ , testProperty "Can query nested fields" $ \x ->+ let o = $(parseObject "{ foo: { bar: Int } }") [aesonQQ| { "foo": { "bar": #{x} } } |]+ in [runGet| o.foo.bar |] === x+ , testProperty "Can generate a lambda expression" $ \x ->+ let o = $(parseObject "{ foo: Int }") [aesonQQ| { "foo": #{x} } |]+ in [runGet| .foo |] o === x+ , testProperty "Can extract a list of elements" $ \x y bar ->+ let o =+ $(parseObject "{ x: Int, y: Int, foo: { bar: Int } }")+ [aesonQQ| { "x": #{x}, "y": #{y}, "foo": { "bar": #{bar} } } |]- in [runGet| o.[x, y, x, foo.bar] |] === [x, y, x, bar]-- , testProperty "Can extract a tuple of elements" $ \x b bar ->- let o = $(parseObject "{ x: Int, b: Bool, foo: { bar: Int } }") [aesonQQ|+ in [runGet| o.[x, y, x, foo.bar] |] === [x, y, x, bar]+ , testProperty "Can extract a tuple of elements" $ \x b bar ->+ let o =+ $(parseObject "{ x: Int, b: Bool, foo: { bar: Int } }")+ [aesonQQ| { "x": #{x}, "b": #{b}, "foo": { "bar": #{bar} } } |]- in [runGet| o.(x,b,x,foo.bar) |] === (x, b, x, bar)- ]+ in [runGet| o.(x,b,x,foo.bar) |] === (x, b, x, bar)+ ] testNullableExpressions :: TestTree-testNullableExpressions = testGroup "Nullable expressions"- [ testCase "Get Maybe key from object with value" $ do- let o = $(parseObject "{ foo: Maybe Bool }") [aesonQQ| { "foo": true } |]- [runGet| o.foo |] @?= Just True- [runGet| o.foo! |] @?= True-- , testCase "Get Maybe key from object with null value" $- let o = $(parseObject "{ foo: Maybe Bool }") [aesonQQ| { "foo": null } |]- in [runGet| o.foo |] @?= Nothing-- , testCase "Get Maybe key from object without value" $- let o = $(parseObject "{ foo: Maybe Bool }") [aesonQQ| {} |]- in [runGet| o.foo |] @?= Nothing-- , testCase "Can run operations within existing Maybe value" $- let o = $(parseObject "{ foo: Maybe List { bar: Bool } }") [aesonQQ|+testNullableExpressions =+ testGroup+ "Nullable expressions"+ [ testCase "Get Maybe key from object with value" $ do+ let o = $(parseObject "{ foo: Maybe Bool }") [aesonQQ| { "foo": true } |]+ [runGet| o.foo |] @?= Just True+ [runGet| o.foo! |] @?= True+ , testCase "Get Maybe key from object with null value" $+ let o = $(parseObject "{ foo: Maybe Bool }") [aesonQQ| { "foo": null } |]+ in [runGet| o.foo |] @?= Nothing+ , testCase "Get Maybe key from object without value" $+ let o = $(parseObject "{ foo: Maybe Bool }") [aesonQQ| {} |]+ in [runGet| o.foo |] @?= Nothing+ , testCase "Can run operations within existing Maybe value" $+ let o =+ $(parseObject "{ foo: Maybe List { bar: Bool } }")+ [aesonQQ| { "foo": [ { "bar": true },@@ -152,14 +155,14 @@ ] } |]- in [runGet| o.foo?[].bar |] @?= Just [True, True, False]-- , testCase "Can run operations within nonexisting Maybe value" $- let o = $(parseObject "{ foo: Maybe List { bar: Bool } }") [aesonQQ| { "foo": null } |]- in [runGet| o.foo?[].bar |] @?= Nothing-- , testCase "Can run operations after unwrapping Maybe value" $- let o = $(parseObject "{ foo: Maybe List { bar: Bool } }") [aesonQQ|+ in [runGet| o.foo?[].bar |] @?= Just [True, True, False]+ , testCase "Can run operations within nonexisting Maybe value" $+ let o = $(parseObject "{ foo: Maybe List { bar: Bool } }") [aesonQQ| { "foo": null } |]+ in [runGet| o.foo?[].bar |] @?= Nothing+ , testCase "Can run operations after unwrapping Maybe value" $+ let o =+ $(parseObject "{ foo: Maybe List { bar: Bool } }")+ [aesonQQ| { "foo": [ { "bar": true },@@ -168,19 +171,18 @@ ] } |]- in [runGet| o.foo![].bar |] @?= [True, True, False]-- , testCase "Get Try key from object with parsed value" $ do- let o = $(parseObject "{ foo: Try Bool }") [aesonQQ| { "foo": true } |]- [runGet| o.foo |] @?= Just True- [runGet| o.foo! |] @?= True-- , testCase "Get Try key from object with invalid value" $- let o = $(parseObject "{ foo: Try Bool }") [aesonQQ| { "foo": 1 } |]- in [runGet| o.foo |] @?= Nothing-- , testCase "Can run operations within parsed Try value" $- let o = $(parseObject "{ foo: Try List { bar: Bool } }") [aesonQQ|+ in [runGet| o.foo![].bar |] @?= [True, True, False]+ , testCase "Get Try key from object with parsed value" $ do+ let o = $(parseObject "{ foo: Try Bool }") [aesonQQ| { "foo": true } |]+ [runGet| o.foo |] @?= Just True+ [runGet| o.foo! |] @?= True+ , testCase "Get Try key from object with invalid value" $+ let o = $(parseObject "{ foo: Try Bool }") [aesonQQ| { "foo": 1 } |]+ in [runGet| o.foo |] @?= Nothing+ , testCase "Can run operations within parsed Try value" $+ let o =+ $(parseObject "{ foo: Try List { bar: Bool } }")+ [aesonQQ| { "foo": [ { "bar": true },@@ -189,14 +191,14 @@ ] } |]- in [runGet| o.foo?[].bar |] @?= Just [True, True, False]-- , testCase "Can run operations within invalid Try value" $- let o = $(parseObject "{ foo: Try List { bar: Bool } }") [aesonQQ| { "foo": [{ "baz": 1 }] } |]- in [runGet| o.foo?[].bar |] @?= Nothing-- , testCase "Can run operations after unwrapping Try value" $- let o = $(parseObject "{ foo: Try List { bar: Bool } }") [aesonQQ|+ in [runGet| o.foo?[].bar |] @?= Just [True, True, False]+ , testCase "Can run operations within invalid Try value" $+ let o = $(parseObject "{ foo: Try List { bar: Bool } }") [aesonQQ| { "foo": [{ "baz": 1 }] } |]+ in [runGet| o.foo?[].bar |] @?= Nothing+ , testCase "Can run operations after unwrapping Try value" $+ let o =+ $(parseObject "{ foo: Try List { bar: Bool } }")+ [aesonQQ| { "foo": [ { "bar": true },@@ -205,71 +207,68 @@ ] } |]- in [runGet| o.foo![].bar |] @?= [True, True, False]-- , testFromJustErrors- ]+ in [runGet| o.foo![].bar |] @?= [True, True, False]+ , testFromJustErrors+ ] -- test error message for bang operator, to get some coverage on startDisplay + showGetterOps testFromJustErrors :: TestTree-testFromJustErrors = testGroup "fromJust errors"- [ testCase "Plain fromJust" $- assertError "Called 'fromJust' on null expression" $ [runGet| ! |] (Nothing :: Maybe Int)-- , testCase "With start" $ do- let o = $(parseObject "{ foo: Maybe Bool }") [aesonQQ| { "foo": null } |]- assertError "Called 'fromJust' on null expression: o.foo"- [runGet| o.foo! |]-- , testCase "With qualified start" $- assertError "Called 'fromJust' on null expression: (Tests.GetQQ.TH.testData).foo"- [runGet| (Tests.GetQQ.TH.testData).foo! |]-- , testCase "With lambda" $ do- let o = $(parseObject "{ foo: Maybe Bool }") [aesonQQ| { "foo": null } |]- assertError "Called 'fromJust' on null expression: .foo" $ [runGet| .foo! |] o-- , testCase "Within nested list of keys" $ do- let o = $(parseObject "{ foo: { a: Bool, b: Maybe Bool } }") [aesonQQ| { "foo": { "a": true, "b": null } } |]- assertError "Called 'fromJust' on null expression: o.foo.b" [runGet| o.foo.[a, b!] |]-- , testCase "Within list of keys" $ do- let o = $(parseObject "{ foo: Bool, bar: Maybe Bool }") [aesonQQ| { "foo": true, "bar": null } |]- assertError "Called 'fromJust' on null expression: o.bar" [runGet| o.[foo, bar!] |]-- , testCase "Within nested tuple of keys" $ do- let o = $(parseObject "{ foo: { a: Int, b: Maybe Bool } }") [aesonQQ| { "foo": { "a": 1, "b": null } } |]- assertError "Called 'fromJust' on null expression: o.foo.b" [runGet| o.foo.(a, b!) |]-- , testCase "Within tuple of keys" $ do- let o = $(parseObject "{ foo: Int, bar: Maybe Bool }") [aesonQQ| { "foo": 1, "bar": null } |]- assertError "Called 'fromJust' on null expression: o.bar" [runGet| o.(foo, bar!) |]-- , testCase "Within list" $ do- let o = $(parseObject "{ foo: List Maybe Bool }") [aesonQQ| { "foo": [null] } |]- assertError "Called 'fromJust' on null expression: o.foo[]" [runGet| o.foo[]! |]-- , testCase "On incorrect branch selector" $ do- let o = $(parseObject "{ foo: Bool | Int }") [aesonQQ| { "foo": 1 } |]- assertError "Called 'fromJust' on null expression: o.foo@0" [runGet| o.foo@0! |]- ]+testFromJustErrors =+ testGroup+ "fromJust errors"+ [ testCase "Plain fromJust" $+ assertError "Called 'fromJust' on null expression" $ [runGet| ! |] (Nothing :: Maybe Int)+ , testCase "With start" $ do+ let o = $(parseObject "{ foo: Maybe Bool }") [aesonQQ| { "foo": null } |]+ assertError+ "Called 'fromJust' on null expression: o.foo"+ [runGet| o.foo! |]+ , testCase "With qualified start" $+ assertError+ "Called 'fromJust' on null expression: (Tests.GetQQ.TH.testData).foo"+ [runGet| (Tests.GetQQ.TH.testData).foo! |]+ , testCase "With lambda" $ do+ let o = $(parseObject "{ foo: Maybe Bool }") [aesonQQ| { "foo": null } |]+ assertError "Called 'fromJust' on null expression: .foo" $ [runGet| .foo! |] o+ , testCase "Within nested list of keys" $ do+ let o = $(parseObject "{ foo: { a: Bool, b: Maybe Bool } }") [aesonQQ| { "foo": { "a": true, "b": null } } |]+ assertError "Called 'fromJust' on null expression: o.foo.b" [runGet| o.foo.[a, b!] |]+ , testCase "Within list of keys" $ do+ let o = $(parseObject "{ foo: Bool, bar: Maybe Bool }") [aesonQQ| { "foo": true, "bar": null } |]+ assertError "Called 'fromJust' on null expression: o.bar" [runGet| o.[foo, bar!] |]+ , testCase "Within nested tuple of keys" $ do+ let o = $(parseObject "{ foo: { a: Int, b: Maybe Bool } }") [aesonQQ| { "foo": { "a": 1, "b": null } } |]+ assertError "Called 'fromJust' on null expression: o.foo.b" [runGet| o.foo.(a, b!) |]+ , testCase "Within tuple of keys" $ do+ let o = $(parseObject "{ foo: Int, bar: Maybe Bool }") [aesonQQ| { "foo": 1, "bar": null } |]+ assertError "Called 'fromJust' on null expression: o.bar" [runGet| o.(foo, bar!) |]+ , testCase "Within list" $ do+ let o = $(parseObject "{ foo: List Maybe Bool }") [aesonQQ| { "foo": [null] } |]+ assertError "Called 'fromJust' on null expression: o.foo[]" [runGet| o.foo[]! |]+ , testCase "On incorrect branch selector" $ do+ let o = $(parseObject "{ foo: Bool | Int }") [aesonQQ| { "foo": 1 } |]+ assertError "Called 'fromJust' on null expression: o.foo@0" [runGet| o.foo@0! |]+ ] where- assertError msg x = try @SomeException (x `deepseq` pure ()) >>= \case- Right _ -> error "Unexpectedly succeeded"- Left e -> (head . lines . show) e @?= msg+ assertError msg x =+ try @SomeException (x `deepseq` pure ()) >>= \case+ Right _ -> error "Unexpectedly succeeded"+ Left e -> (head . lines . show) e @?= msg testListExpressions :: TestTree-testListExpressions = testGroup "List expressions"- [ testCase "Get List key from object" $- let o = $(parseObject "{ foo: List Int }") [aesonQQ| { "foo": [1,2,3] } |]- in [runGet| o.foo |] @?= [1,2,3]-- , testProperty "Ending with a `[]` operator is a noop" $ \(xs :: [Int]) ->- let o = $(parseObject "{ foo: List Int }") [aesonQQ| { "foo": #{xs} } |]- in [runGet| o.foo |] === [runGet| o.foo[] |]-- , testCase "Can run operations within list" $- let o = $(parseObject "{ foo: List Maybe { bar: Int } }") [aesonQQ|+testListExpressions =+ testGroup+ "List expressions"+ [ testCase "Get List key from object" $+ let o = $(parseObject "{ foo: List Int }") [aesonQQ| { "foo": [1,2,3] } |]+ in [runGet| o.foo |] @?= [1, 2, 3]+ , testProperty "Ending with a `[]` operator is a noop" $ \(xs :: [Int]) ->+ let o = $(parseObject "{ foo: List Int }") [aesonQQ| { "foo": #{xs} } |]+ in [runGet| o.foo |] === [runGet| o.foo[] |]+ , testCase "Can run operations within list" $+ let o =+ $(parseObject "{ foo: List Maybe { bar: Int } }")+ [aesonQQ| { "foo": [ { "bar": 1 },@@ -279,109 +278,122 @@ ] } |]- in [runGet| o.foo[]?.bar |] @?= [Just 1, Just 2, Nothing, Just 3]- ]+ in [runGet| o.foo[]?.bar |] @?= [Just 1, Just 2, Nothing, Just 3]+ ] testUnionExpressions :: TestTree-testUnionExpressions = testGroup "Union expressions"- [ testCase "Get Union key from object" $ do- let o = $(parseObject "{ foo: Bool | Int }") [aesonQQ| { "foo": 1 } |]- [runGet| o.foo |] @?= There (Here 1)- [runGet| o.foo@0 |] @?= Nothing- [runGet| o.foo@1 |] @?= Just 1-- , testCase "Can run operations after extracting branch" $ do- let o = $(parseObject "{ foo: { bar: Bool } | { baz: Int } }") [aesonQQ| { "foo": { "bar": true } } |]- [runGet| o.foo@0?.bar |] @?= Just True- [runGet| o.foo@0!.bar |] @?= True- [runGet| o.foo@1?.baz |] @?= Nothing- ]+testUnionExpressions =+ testGroup+ "Union expressions"+ [ testCase "Get Union key from object" $ do+ let o = $(parseObject "{ foo: Bool | Int }") [aesonQQ| { "foo": 1 } |]+ [runGet| o.foo |] @?= There (Here 1)+ [runGet| o.foo@0 |] @?= Nothing+ [runGet| o.foo@1 |] @?= Just 1+ , testCase "Can run operations after extracting branch" $ do+ let o = $(parseObject "{ foo: { bar: Bool } | { baz: Int } }") [aesonQQ| { "foo": { "bar": true } } |]+ [runGet| o.foo@0?.bar |] @?= Just True+ [runGet| o.foo@0!.bar |] @?= True+ [runGet| o.foo@1?.baz |] @?= Nothing+ ] testPhantomExpressions :: TestTree-testPhantomExpressions = testGroup "Phantom expressions"- [ testProperty "Get Phantom object key from object" $ \x ->- let o = $(parseObject "{ [foo]: { bar: Int } }") [aesonQQ| { "bar": #{x} } |]- in [runGet| o.foo.bar |] === x-- , testProperty "Get Phantom object Try key from object" $ \x ->- let o = $(parseObject "{ [foo]: Try { bar: Int } }") [aesonQQ| { "bar": #{x} } |]- in [runGet| o.foo?.bar |] === Just x-- , testProperty "Get Phantom non-object Try key from object" $ \(x :: Int) ->- let o = $(parseObject "{ [foo]: Try Int }") [aesonQQ| { "foo": #{x} } |]- in [runGet| o.foo |] === Nothing- ]+testPhantomExpressions =+ testGroup+ "Phantom expressions"+ [ testProperty "Get Phantom object key from object" $ \x ->+ let o = $(parseObject "{ [foo]: { bar: Int } }") [aesonQQ| { "bar": #{x} } |]+ in [runGet| o.foo.bar |] === x+ , testProperty "Get Phantom object Try key from object" $ \x ->+ let o = $(parseObject "{ [foo]: Try { bar: Int } }") [aesonQQ| { "bar": #{x} } |]+ in [runGet| o.foo?.bar |] === Just x+ , testProperty "Get Phantom non-object Try key from object" $ \(x :: Int) ->+ let o = $(parseObject "{ [foo]: Try Int }") [aesonQQ| { "foo": #{x} } |]+ in [runGet| o.foo |] === Nothing+ ] testNestedExpressions :: TestTree-testNestedExpressions = testGroup "Nested expressions"- [ testProperty "Extracted object from Object can be queried further" $ \x ->- let o = $(parseObject "{ foo: { bar: Int } }") [aesonQQ| { "foo": { "bar": #{x} } } |]- foo = [runGet| o.foo |]- in [runGet| foo.bar |] === x-- , testProperty "Extracted object from Maybe can be queried further" $ \x ->- let o = $(parseObject "{ foo: Maybe { bar: Int } }") [aesonQQ| { "foo": { "bar": #{x} } } |]- foo = [runGet| o.foo! |]- in [runGet| foo.bar |] === x-- , testProperty "Extracted object from Try can be queried further" $ \x ->- let o = $(parseObject "{ foo: Try { bar: Int } }") [aesonQQ| { "foo": { "bar": #{x} } } |]- foo = [runGet| o.foo! |]- in [runGet| foo.bar |] === x-- , testProperty "Extracted object from List can be queried further" $ \xs ->- classify (length xs > 1) "non-trivial" $- let bars = map (\x -> [aesonQQ| { "bar": #{x} } |]) xs- o = $(parseObject "{ foo: List { bar: Int } }") [aesonQQ| { "foo": #{bars} } |]- getBar :: Object [schema| { bar: Int } |] -> Int- getBar foo = [runGet| foo.bar |]- in map getBar [runGet| o.foo |] === xs-- , testProperty "Extracted objects from list of keys can be queried further" $ \fooId barId ->- let o = $(parseObject "{ foo: { id: Int }, bar: { id: Int } }") [aesonQQ|+testNestedExpressions =+ testGroup+ "Nested expressions"+ [ testProperty "Extracted object from Object can be queried further" $ \x ->+ let o = $(parseObject "{ foo: { bar: Int } }") [aesonQQ| { "foo": { "bar": #{x} } } |]+ foo = [runGet| o.foo |]+ in [runGet| foo.bar |] === x+ , testProperty "Extracted object from Maybe can be queried further" $ \x ->+ let o = $(parseObject "{ foo: Maybe { bar: Int } }") [aesonQQ| { "foo": { "bar": #{x} } } |]+ foo = [runGet| o.foo! |]+ in [runGet| foo.bar |] === x+ , testProperty "Extracted object from Try can be queried further" $ \x ->+ let o = $(parseObject "{ foo: Try { bar: Int } }") [aesonQQ| { "foo": { "bar": #{x} } } |]+ foo = [runGet| o.foo! |]+ in [runGet| foo.bar |] === x+ , testProperty "Extracted object from List can be queried further" $ \xs ->+ classify (length xs > 1) "non-trivial" $+ let bars = map (\x -> [aesonQQ| { "bar": #{x} } |]) xs+ o = $(parseObject "{ foo: List { bar: Int } }") [aesonQQ| { "foo": #{bars} } |]+ getBar :: Object [schema| { bar: Int } |] -> Int+ getBar foo = [runGet| foo.bar |]+ in map getBar [runGet| o.foo |] === xs+ , testProperty "Extracted objects from list of keys can be queried further" $ \fooId barId ->+ let o =+ $(parseObject "{ foo: { id: Int }, bar: { id: Int } }")+ [aesonQQ| { "foo": { "id": #{fooId} }, "bar": { "id": #{barId} } } |]- getId :: Object [schema| { id: Int } |] -> Int- getId inner = [runGet| inner.id |]- in map getId [runGet| o.[foo, bar] |] === [fooId, barId]-- , testProperty "Extracted objects from tuple of keys can be queried further" $ \a b ->- let o = $(parseObject "{ foo: { a: Int }, bar: { b: Bool } }") [aesonQQ|+ getId :: Object [schema| { id: Int } |] -> Int+ getId inner = [runGet| inner.id |]+ in map getId [runGet| o.[foo, bar] |] === [fooId, barId]+ , testProperty "Extracted objects from tuple of keys can be queried further" $ \a b ->+ let o =+ $(parseObject "{ foo: { a: Int }, bar: { b: Bool } }")+ [aesonQQ| { "foo": { "a": #{a} }, "bar": { "b": #{b} } } |]- (foo, bar) = [runGet| o.(foo, bar) |]- in [runGet| foo.a |] === a .&&. [runGet| bar.b |] === b-- , testProperty "Extracted objects from union can be queried further" $ \x ->- let o = $(parseObject "{ foo: { x: Bool } | { x: Int } }") [aesonQQ| { "foo": { "x": #{x} } } |]- in case [runGet| o.foo |] of- There (Here foo) -> [runGet| foo.x |] === x- foo -> error $ "Unexpected failure: o.foo = " ++ show foo ++ ", x = " ++ show x- ]+ (foo, bar) = [runGet| o.(foo, bar) |]+ in [runGet| foo.a |] === a .&&. [runGet| bar.b |] === b+ , testProperty "Extracted objects from union can be queried further" $ \x ->+ let o = $(parseObject "{ foo: { x: Bool } | { x: Int } }") [aesonQQ| { "foo": { "x": #{x} } } |]+ in case [runGet| o.foo |] of+ There (Here foo) -> [runGet| foo.x |] === x+ foo -> error $ "Unexpected failure: o.foo = " ++ show foo ++ ", x = " ++ show x+ ] testInvalidExpressions :: TestTree-testInvalidExpressions = testGroup "Invalid expressions"- [ testParseError "Empty expression" "getqq_empty_expression.golden"- [getErr| |]- , testParseError "No operators" "getqq_no_operators.golden"- [getErr| o |]- , testParseError "Operators after tuple of keys" "getqq_ops_after_tuple.golden"- [getErr| o.(a,b).foo |]- , testParseError "Operators after list of keys" "getqq_ops_after_list.golden"- [getErr| o.[a,b].foo |]- ]+testInvalidExpressions =+ testGroup+ "Invalid expressions"+ [ testParseError+ "Empty expression"+ "getqq_empty_expression.golden"+ [getErr| |]+ , testParseError+ "No operators"+ "getqq_no_operators.golden"+ [getErr| o |]+ , testParseError+ "Operators after tuple of keys"+ "getqq_ops_after_tuple.golden"+ [getErr| o.(a,b).foo |]+ , testParseError+ "Operators after list of keys"+ "getqq_ops_after_list.golden"+ [getErr| o.[a,b].foo |]+ ] testCompileTimeErrors :: TestTree-testCompileTimeErrors = testGroup "Compile-time errors"- [ testGoldenIO "Key not in schema" "getqq_missing_key.golden" $- getCompileError "GetMissingKey"- ]+testCompileTimeErrors =+ testGroup+ "Compile-time errors"+ [ testGoldenIO "Key not in schema" "getqq_missing_key.golden" $+ getCompileError "GetMissingKey"+ ] where getCompileError name = do let fp = "test/wont-compile/" ++ name ++ ".hs"
test/Tests/GetQQ/TH.hs view
@@ -6,9 +6,14 @@ import Control.DeepSeq (deepseq) import Data.Aeson.QQ (aesonQQ)-import Language.Haskell.TH.Quote (QuasiQuoter(..))-import Language.Haskell.TH.TestUtils- (MockedMode(..), QMode(..), QState(..), runTestQ, runTestQErr)+import Language.Haskell.TH.Quote (QuasiQuoter (..))+import Language.Haskell.TH.TestUtils (+ MockedMode (..),+ QMode (..),+ QState (..),+ runTestQ,+ runTestQErr,+ ) import Data.Aeson.Schema (Object, get, schema) import TestUtils (mkExpQQ, parseValue)@@ -19,17 +24,19 @@ testData = parseValue [aesonQQ| { "foo": null } |] qState :: QState 'FullyMocked-qState = QState- { mode = MockQ- , knownNames = []- , reifyInfo = []- }+qState =+ QState+ { mode = MockQ+ , knownNames = []+ , reifyInfo = []+ } --- | Run the `get` quasiquoter at both runtime and compile-time, to get coverage.------ The `get` Quasiquoter doesn't reify anything, so this should work.+{- | Run the `get` quasiquoter at both runtime and compile-time, to get coverage.++ The `get` Quasiquoter doesn't reify anything, so this should work.+-} runGet :: QuasiQuoter-runGet = mkExpQQ $ \s -> [| runTestQ qState (quoteExp get s) `deepseq` $(quoteExp get s) |]+runGet = mkExpQQ $ \s -> [|runTestQ qState (quoteExp get s) `deepseq` $(quoteExp get s)|] getErr :: QuasiQuoter-getErr = mkExpQQ $ \s -> [| runTestQErr qState (quoteExp get s) |]+getErr = mkExpQQ $ \s -> [|runTestQErr qState (quoteExp get s)|]
test/Tests/MkGetter.hs view
@@ -10,8 +10,13 @@ import Control.DeepSeq (deepseq) import Data.Text (Text)-import Language.Haskell.TH.TestUtils- (QMode(..), QState(..), loadNames, runTestQ, runTestQErr)+import Language.Haskell.TH.TestUtils (+ QMode (..),+ QState (..),+ loadNames,+ runTestQ,+ runTestQErr,+ ) import Test.Tasty import Test.Tasty.HUnit import Text.RawString.QQ (r)@@ -25,35 +30,37 @@ mkGetter "User" "getUsers" ''MySchema ".users[]" test :: TestTree-test = runMkGetterQ `deepseq` testGroup "`mkGetter` helper"- [ testCase "Type synonym is generated" $- showSchemaResult @User @?= [r|Object (SchemaObject { "name": Text })|]-- , testCase "Getter function is generated" $- let users :: [User]- users = getUsers testData-- getName :: User -> Text- getName = [get| .name |]-- in map getName users @?= ["Alice", "Bob", "Claire"]+test =+ runMkGetterQ+ `deepseq` testGroup+ "`mkGetter` helper"+ [ testCase "Type synonym is generated" $+ showSchemaResult @User @?= [r|Object (SchemaObject { "name": Text })|]+ , testCase "Getter function is generated" $+ let users :: [User]+ users = getUsers testData - , testCase "mkGetter expression should be a lambda expression" $- let msg = runTestQErr qState $ mkGetter "User" "getUsers" ''MySchema "foo.users[]"- in msg @?= "Getter expression should start with '.': foo.users[]"- ]+ getName :: User -> Text+ getName = [get| .name |]+ in map getName users @?= ["Alice", "Bob", "Claire"]+ , testCase "mkGetter expression should be a lambda expression" $+ let msg = runTestQErr qState $ mkGetter "User" "getUsers" ''MySchema "foo.users[]"+ in msg @?= "Getter expression should start with '.': foo.users[]"+ ] where- qState = QState- { mode = MockQ- , knownNames = []- , reifyInfo = $(loadNames [''MySchema])- }+ qState =+ QState+ { mode = MockQ+ , knownNames = []+ , reifyInfo = $(loadNames [''MySchema])+ } -- run same mkGetter expression that was spliced, for coverage runMkGetterQ = runTestQ qState $ mkGetter "User" "getUsers" ''MySchema ".users[]" testData :: Object MySchema-testData = [json|+testData =+ [json| { "users": [ { "name": "Alice" },
test/Tests/Object.hs view
@@ -4,30 +4,32 @@ module Tests.Object where -import Data.Aeson (Value(..))+import Data.Aeson (Value (..)) import Data.Aeson.QQ (aesonQQ) import qualified Data.HashMap.Lazy as HashMap import Test.Tasty import Test.Tasty.HUnit import Data.Aeson.Schema (Object, schema, toMap)+import TestUtils (parseValue) import qualified Tests.Object.Eq import qualified Tests.Object.FromJSON import qualified Tests.Object.Show import qualified Tests.Object.ToJSON-import TestUtils (parseValue) test :: TestTree-test = testGroup "Object"- [ Tests.Object.Show.test- , Tests.Object.Eq.test- , Tests.Object.FromJSON.test- , Tests.Object.ToJSON.test-- , testCase "toMap smoketest" $- let o :: Object [schema| { a: Bool } |]- o = parseValue [aesonQQ| { "a": true } |]- in toMap o @?= HashMap.fromList- [ ("a", Bool True)- ]- ]+test =+ testGroup+ "Object"+ [ Tests.Object.Show.test+ , Tests.Object.Eq.test+ , Tests.Object.FromJSON.test+ , Tests.Object.ToJSON.test+ , testCase "toMap smoketest" $+ let o :: Object [schema| { a: Bool } |]+ o = parseValue [aesonQQ| { "a": true } |]+ in toMap o+ @?= HashMap.fromList+ [ ("a", Bool True)+ ]+ ]
test/Tests/Object/Eq.hs view
@@ -7,12 +7,14 @@ import Test.Tasty.QuickCheck import TestUtils (parseProxy)-import TestUtils.Arbitrary (ArbitraryObject(..), forAllArbitraryObjects)+import TestUtils.Arbitrary (ArbitraryObject (..), forAllArbitraryObjects) test :: TestTree-test = testGroup "Eq instance"- [ testProperty "o === o" $- $(forAllArbitraryObjects) $ \(ArbitraryObject proxy v _) ->- let o = either error id $ parseProxy proxy v- in o === o- ]+test =+ testGroup+ "Eq instance"+ [ testProperty "o === o" $+ $(forAllArbitraryObjects) $ \(ArbitraryObject proxy v _) ->+ let o = either error id $ parseProxy proxy v+ in o === o+ ]
test/Tests/Object/FromJSON.hs view
@@ -10,7 +10,7 @@ module Tests.Object.FromJSON where -import Data.Aeson (FromJSON(..), Value)+import Data.Aeson (FromJSON (..), Value) import Data.Aeson.QQ (aesonQQ) import Data.Aeson.Types (parseEither) import Data.Proxy (Proxy)@@ -18,94 +18,122 @@ import Test.Tasty.QuickCheck import Data.Aeson.Schema (Object)-import Tests.Object.FromJSON.TH import TestUtils (parseProxy, testGolden)-import TestUtils.Arbitrary (ArbitraryObject(..), forAllArbitraryObjects)+import TestUtils.Arbitrary (ArbitraryObject (..), forAllArbitraryObjects)+import Tests.Object.FromJSON.TH test :: TestTree-test = testGroup "FromJSON instance" $- map runTestCase testCases ++- [ testProperty "QuickCheck arbitrary Schema" $- $(forAllArbitraryObjects) $ \(ArbitraryObject proxy v _) ->- case parseProxy proxy v of- Right _ -> property ()- Left e -> error $ "Could not parse: " ++ e- ]+test =+ testGroup "FromJSON instance" $+ map runTestCase testCases+ ++ [ testProperty "QuickCheck arbitrary Schema" $+ $(forAllArbitraryObjects) $ \(ArbitraryObject proxy v _) ->+ case parseProxy proxy v of+ Right _ -> property ()+ Left e -> error $ "Could not parse: " ++ e+ ] testCases :: [FromJSONTestCase] testCases =- [ CheckValid "Scalar valid"+ [ CheckValid+ "Scalar valid" [schemaProxy| { foo: Text } |] $ \(s :: String) -> [aesonQQ| { "foo": #{s} } |]- , CheckError "Scalar invalid" "fromjson_scalar_invalid.golden"+ , CheckError+ "Scalar invalid"+ "fromjson_scalar_invalid.golden" [schemaProxy| { foo: Text } |] [aesonQQ| { "foo": 1 } |]-- , CheckValid "Maybe valid"+ , CheckValid+ "Maybe valid" [schemaProxy| { foo: Maybe Int } |] $ \(x :: Maybe Int) -> [aesonQQ| { "foo": #{x} } |]- , CheckError "Maybe invalid" "fromjson_maybe_invalid.golden"+ , CheckError+ "Maybe invalid"+ "fromjson_maybe_invalid.golden" [schemaProxy| { foo: Maybe Int } |] [aesonQQ| { "foo": true } |]-- , CheckValid "Try valid with valid parse"+ , CheckValid+ "Try valid with valid parse" [schemaProxy| { foo: Try Bool } |] $ \(x :: Bool) -> [aesonQQ| { "foo": #{x} } |]- , CheckValid "Try valid with invalid parse"+ , CheckValid+ "Try valid with invalid parse" [schemaProxy| { foo: Try Bool } |] $ \(s :: String) -> [aesonQQ| { "foo": #{s} } |]-- , CheckValid "List valid"+ , CheckValid+ "List valid" [schemaProxy| { foo: List Double } |] $ \(xs :: [Double]) -> [aesonQQ| { "foo": #{xs} } |]- , CheckError "List invalid" "fromjson_list_invalid.golden"+ , CheckError+ "List invalid"+ "fromjson_list_invalid.golden" [schemaProxy| { foo: List Double } |] [aesonQQ| { "foo": true } |]- , CheckError "List invalid inner" "fromjson_list_inner_invalid.golden"+ , CheckError+ "List invalid inner"+ "fromjson_list_inner_invalid.golden" [schemaProxy| { foo: List Double } |] [aesonQQ| { "foo": [true] } |]-- , CheckError "Object invalid" "fromjson_object_invalid.golden"+ , CheckError+ "Object invalid"+ "fromjson_object_invalid.golden" [schemaProxy| { foo: Int } |] [aesonQQ| 1 |]- , CheckError "Object invalid in later keys" "fromjson_object_later_keys_invalid.golden"+ , CheckError+ "Object invalid in later keys"+ "fromjson_object_later_keys_invalid.golden" [schemaProxy| { foo: Int, bar: Int } |] [aesonQQ| { "foo": 1, "bar": true } |]-- , CheckValid "Nested object valid"+ , CheckValid+ "Nested object valid" [schemaProxy| { foo: { bar: Int } } |] $ \(x :: Int) -> [aesonQQ| { "foo": { "bar": #{x} } } |]- , CheckError "Nested object invalid" "fromjson_nested_invalid.golden"+ , CheckError+ "Nested object invalid"+ "fromjson_nested_invalid.golden" [schemaProxy| { foo: { bar: Int } } |] [aesonQQ| { "foo": true } |]- , CheckError "Nested object invalid inner" "fromjson_nested_inner_invalid.golden"+ , CheckError+ "Nested object invalid inner"+ "fromjson_nested_inner_invalid.golden" [schemaProxy| { foo: { bar: Int } } |] [aesonQQ| { "foo": { "bar": true } } |]-- , CheckValid "Union object valid"+ , CheckValid+ "Union object valid" [schemaProxy| { foo: Int | Text } |] $ \(x :: Int) -> [aesonQQ| { "foo": #{x} } |]- , CheckError "Union object invalid" "fromjson_union_invalid.golden"+ , CheckError+ "Union object invalid"+ "fromjson_union_invalid.golden" [schemaProxy| { foo: Int | Text } |] [aesonQQ| { "foo": true } |]-- , CheckValid "Phantom key valid object"+ , CheckValid+ "Phantom key valid object" [schemaProxy| { [foo]: { bar: Int } } |] $ \(x :: Int) -> [aesonQQ| { "bar": #{x} } |]- , CheckValid "Phantom key valid non-object try"+ , CheckValid+ "Phantom key valid non-object try" [schemaProxy| { [foo]: Try Bool } |] $ \(b :: Bool) -> [aesonQQ| { "bar": #{b} } |]- , CheckError "Phantom key invalid" "fromjson_phantom_invalid.golden"+ , CheckError+ "Phantom key invalid"+ "fromjson_phantom_invalid.golden" [schemaProxy| { [foo]: { bar: Int } } |] [aesonQQ| 1 |]- , CheckError "Phantom key missing inner" "fromjson_phantom_inner_missing.golden"+ , CheckError+ "Phantom key missing inner"+ "fromjson_phantom_inner_missing.golden" [schemaProxy| { [foo]: { bar: Int } } |] [aesonQQ| { "foo": true } |]- , CheckError "Phantom key invalid inner" "fromjson_phantom_inner_invalid.golden"+ , CheckError+ "Phantom key invalid inner"+ "fromjson_phantom_inner_invalid.golden" [schemaProxy| { [foo]: { bar: Int } } |] [aesonQQ| { "bar": true } |]-- , CheckError "Decode failure messages are truncated" "fromjson_error_messages_truncate.golden"+ , CheckError+ "Decode failure messages are truncated"+ "fromjson_error_messages_truncate.golden" [schemaProxy| { foo: Int } |] [aesonQQ| {@@ -127,20 +155,26 @@ {- Helpers -} data FromJSONTestCase where- CheckValid- :: (Arbitrary a, Show a, FromJSON (Object schema))- => TestName -- ^ Name of test case- -> Proxy (Object schema) -- ^ The schema to parse with- -> (a -> Value) -- ^ A function that builds a Value that should satisfy the schema- -> FromJSONTestCase-- CheckError- :: (FromJSON (Object schema), Show (Object schema))- => TestName -- ^ Name of test case- -> String -- ^ Name of golden file- -> Proxy (Object schema) -- ^ The schema to parse with- -> Value -- ^ The value that should fail parsing the given schema- -> FromJSONTestCase+ CheckValid ::+ (Arbitrary a, Show a, FromJSON (Object schema)) =>+ -- | Name of test case+ TestName ->+ -- | The schema to parse with+ Proxy (Object schema) ->+ -- | A function that builds a Value that should satisfy the schema+ (a -> Value) ->+ FromJSONTestCase+ CheckError ::+ (FromJSON (Object schema), Show (Object schema)) =>+ -- | Name of test case+ TestName ->+ -- | Name of golden file+ String ->+ -- | The schema to parse with+ Proxy (Object schema) ->+ -- | The value that should fail parsing the given schema+ Value ->+ FromJSONTestCase runTestCase :: FromJSONTestCase -> TestTree runTestCase = \case@@ -149,7 +183,6 @@ case parse schema (valueGen a) of Right _ -> () Left e -> error $ "Unexpected failure: " ++ e- CheckError name fp schema value -> testGolden name fp $ case parse schema value of
test/Tests/Object/FromJSON/TH.hs view
@@ -2,13 +2,13 @@ module Tests.Object.FromJSON.TH where -import Data.Proxy (Proxy(..))-import Language.Haskell.TH.Quote (QuasiQuoter(quoteType))+import Data.Proxy (Proxy (..))+import Language.Haskell.TH.Quote (QuasiQuoter (quoteType)) import Data.Aeson.Schema (Object, schema) import TestUtils (mkExpQQ) schemaProxy :: QuasiQuoter schemaProxy = mkExpQQ $ \s ->- let schemaType = [t| Object $(quoteType schema s) |]- in [| Proxy :: Proxy $schemaType |]+ let schemaType = [t|Object $(quoteType schema s)|]+ in [|Proxy :: Proxy $schemaType|]
test/Tests/Object/Show.hs view
@@ -11,60 +11,50 @@ import Test.Tasty.HUnit import Test.Tasty.QuickCheck -import Tests.Object.Show.TH import TestUtils (parseObject)+import Tests.Object.Show.TH test :: TestTree-test = testGroup "Show instance"- [ testProperty "Scalar key" $ \(s :: String) ->- let o = $(parseObject "{ foo: Text }") [aesonQQ| { "foo": #{s} } |]- in show o === [i|{ "foo": #{show s} }|]-- , testProperty "Object with multiple keys" $ \(b :: Double, x :: Int) ->- let o = $(parseObject "{ foo: Double, bar: Int }") [aesonQQ| { "foo": #{b}, "bar": #{x} } |]- in show o === [i|{ "foo": #{show b}, "bar": #{show x} }|]-- , testProperty "Nested object" $ \(x :: Int) ->- let o = $(parseObject "{ foo: { bar: Int } }") [aesonQQ| { "foo": { "bar": #{x} } } |]- in show o === [i|{ "foo": { "bar": #{show x} } }|]-- , testProperty "Object with existing Maybe key" $ \(x :: Bool) ->- let o = $(parseObject "{ foo: Maybe Bool }") [aesonQQ| { "foo": #{x} } |]- in show o === [i|{ "foo": Just #{show x} }|]-- , testCase "Object with non-existing Maybe key" $- let o = $(parseObject "{ foo: Maybe Double }") [aesonQQ| { "foo": null } |]- in show o @?= [i|{ "foo": Nothing }|]-- , testProperty "Object with valid Try key" $ \(b :: Bool) ->- let o = $(parseObject "{ foo: Try Bool }") [aesonQQ| { "foo": #{b} } |]- in show o === [i|{ "foo": Just #{show b} }|]-- , testProperty "Object with invalid Try key" $ \(x :: Int) ->- let o = $(parseObject "{ foo: Try Bool }") [aesonQQ| { "foo": #{x} } |]- in show o === [i|{ "foo": Nothing }|]-- , testProperty "Object with List key" $ \(x :: [Int]) ->- let o = $(parseObject "{ foo: List Int }") [aesonQQ| { "foo": #{x} } |]- in show o === [i|{ "foo": #{show x} }|]-- , testProperty "Object with Union key branch 0" $ \(Positive (x :: Int)) ->- let o = $(parseObject "{ foo: Int | Text }") [aesonQQ| { "foo": #{x} } |]- in show o === [i|{ "foo": Here #{show x} }|]-- , testProperty "Object with Union key branch 1" $ \(s :: String) ->- let o = $(parseObject "{ foo: Int | Text }") [aesonQQ| { "foo": #{s} } |]- in show o === [i|{ "foo": There (Here #{show s}) }|]-- , testProperty "Object with referenced Object" $ \(name :: String) ->- let o = $(parseObject "{ user: #UserSchema }") [aesonQQ| { "user": { "name": #{name} } } |]- in show o === [i|{ "user": { "name": #{show name} } }|]-- , testProperty "Object with extended Object" $ \(name :: String, age :: Int) ->- let o = $(parseObject "{ #UserSchema, age: Int }") [aesonQQ| { "name": #{name}, "age": #{age} } |]- in show o === [i|{ "name": #{show name}, "age": #{show age} }|]-- , testProperty "Object with Phantom key" $ \(x :: Int) ->- let o = $(parseObject "{ [foo]: { bar: Int } }") [aesonQQ| { "bar": #{x} } |]- in show o === [i|{ [foo]: { "bar": #{show x} } }|]- ]+test =+ testGroup+ "Show instance"+ [ testProperty "Scalar key" $ \(s :: String) ->+ let o = $(parseObject "{ foo: Text }") [aesonQQ| { "foo": #{s} } |]+ in show o === [i|{ "foo": #{show s} }|]+ , testProperty "Object with multiple keys" $ \(b :: Double, x :: Int) ->+ let o = $(parseObject "{ foo: Double, bar: Int }") [aesonQQ| { "foo": #{b}, "bar": #{x} } |]+ in show o === [i|{ "foo": #{show b}, "bar": #{show x} }|]+ , testProperty "Nested object" $ \(x :: Int) ->+ let o = $(parseObject "{ foo: { bar: Int } }") [aesonQQ| { "foo": { "bar": #{x} } } |]+ in show o === [i|{ "foo": { "bar": #{show x} } }|]+ , testProperty "Object with existing Maybe key" $ \(x :: Bool) ->+ let o = $(parseObject "{ foo: Maybe Bool }") [aesonQQ| { "foo": #{x} } |]+ in show o === [i|{ "foo": Just #{show x} }|]+ , testCase "Object with non-existing Maybe key" $+ let o = $(parseObject "{ foo: Maybe Double }") [aesonQQ| { "foo": null } |]+ in show o @?= [i|{ "foo": Nothing }|]+ , testProperty "Object with valid Try key" $ \(b :: Bool) ->+ let o = $(parseObject "{ foo: Try Bool }") [aesonQQ| { "foo": #{b} } |]+ in show o === [i|{ "foo": Just #{show b} }|]+ , testProperty "Object with invalid Try key" $ \(x :: Int) ->+ let o = $(parseObject "{ foo: Try Bool }") [aesonQQ| { "foo": #{x} } |]+ in show o === [i|{ "foo": Nothing }|]+ , testProperty "Object with List key" $ \(x :: [Int]) ->+ let o = $(parseObject "{ foo: List Int }") [aesonQQ| { "foo": #{x} } |]+ in show o === [i|{ "foo": #{show x} }|]+ , testProperty "Object with Union key branch 0" $ \(Positive (x :: Int)) ->+ let o = $(parseObject "{ foo: Int | Text }") [aesonQQ| { "foo": #{x} } |]+ in show o === [i|{ "foo": Here #{show x} }|]+ , testProperty "Object with Union key branch 1" $ \(s :: String) ->+ let o = $(parseObject "{ foo: Int | Text }") [aesonQQ| { "foo": #{s} } |]+ in show o === [i|{ "foo": There (Here #{show s}) }|]+ , testProperty "Object with referenced Object" $ \(name :: String) ->+ let o = $(parseObject "{ user: #UserSchema }") [aesonQQ| { "user": { "name": #{name} } } |]+ in show o === [i|{ "user": { "name": #{show name} } }|]+ , testProperty "Object with extended Object" $ \(name :: String, age :: Int) ->+ let o = $(parseObject "{ #UserSchema, age: Int }") [aesonQQ| { "name": #{name}, "age": #{age} } |]+ in show o === [i|{ "name": #{show name}, "age": #{show age} }|]+ , testProperty "Object with Phantom key" $ \(x :: Int) ->+ let o = $(parseObject "{ [foo]: { bar: Int } }") [aesonQQ| { "bar": #{x} } |]+ in show o === [i|{ [foo]: { "bar": #{show x} } }|]+ ]
test/Tests/Object/ToJSON.hs view
@@ -5,21 +5,23 @@ module Tests.Object.ToJSON where -import Data.Aeson (FromJSON(..), ToJSON(..))+import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson.Types as Aeson import Test.Tasty import Test.Tasty.QuickCheck import TestUtils (parseProxy)-import TestUtils.Arbitrary (ArbitraryObject(..), forAllArbitraryObjects)+import TestUtils.Arbitrary (ArbitraryObject (..), forAllArbitraryObjects) test :: TestTree-test = testGroup "ToJSON instance"- [ testProperty "parseJSON . toJSON === pure" $- $(forAllArbitraryObjects) $ \(ArbitraryObject proxy v _) ->- let o = either error id $ parseProxy proxy v- in (parseJSON . toJSON) o === pure o- ]+test =+ testGroup+ "ToJSON instance"+ [ testProperty "parseJSON . toJSON === pure" $+ $(forAllArbitraryObjects) $ \(ArbitraryObject proxy v _) ->+ let o = either error id $ parseProxy proxy v+ in (parseJSON . toJSON) o === pure o+ ] {- Realizing Aeson.Parser -}
test/Tests/SchemaQQ.hs view
@@ -9,214 +9,185 @@ import Test.Tasty.HUnit import Text.RawString.QQ (r) -import Tests.SchemaQQ.TH import TestUtils (testParseError)+import Tests.SchemaQQ.TH test :: TestTree-test = testGroup "`schema` quasiquoter"- [ testValidSchemas- , testInvalidSchemas- , testKeys- ]+test =+ testGroup+ "`schema` quasiquoter"+ [ testValidSchemas+ , testInvalidSchemas+ , testKeys+ ] testValidSchemas :: TestTree-testValidSchemas = testGroup "Valid schemas"- [ testCase "Object with Bool field" $- assertMatches- [schemaRep| { a: Bool } |]- [r| SchemaObject { "a": Bool } |]-- , testCase "Object with Int field" $- assertMatches- [schemaRep| { a: Int } |]- [r| SchemaObject { "a": Int } |]-- , testCase "Object with Double field" $- assertMatches- [schemaRep| { foo123: Double } |]- [r| SchemaObject { "foo123": Double } |]-- , testCase "Object with Text field" $- assertMatches- [schemaRep| { some_text: Text } |]- [r| SchemaObject { "some_text": Text } |]-- , testCase "Object with a field with a custom type" $- assertMatches- [schemaRep| { status: Status } |]- [r| SchemaObject { "status": Status } |]-- , testCase "Object with a field with a Maybe type" $- assertMatches- [schemaRep| { a: Maybe Bool } |]- [r| SchemaObject { "a": Maybe Bool } |]-- , testCase "Object with a field with a Try type" $- assertMatches- [schemaRep| { a: Try Bool } |]- [r| SchemaObject { "a": Try Bool } |]-- , testCase "Object with a nested object" $- assertMatches- [schemaRep| { a: { b: Int } } |]- [r| SchemaObject { "a": { "b": Int } } |]-- , testCase "Object with a nullable nested object" $- assertMatches- [schemaRep| { a: Maybe { b: Int } } |]- [r| SchemaObject { "a": Maybe { "b": Int } } |]-- , testCase "Object with a list of nested objects" $- assertMatches- [schemaRep| { a: List { b: Int } } |]- [r| SchemaObject { "a": List { "b": Int } } |]-- , testCase "Object with an imported schema" $- assertMatches- [schemaRep| { user: #UserSchema } |]- [r| SchemaObject { "user": { "name": Text } } |]-- , testCase "Object with a qualified imported schema" $- assertMatches- [schemaRep| { user: #(Tests.SchemaQQ.TH.UserSchema) } |]- [r| SchemaObject { "user": { "name": Text } } |]-- , testCase "Object with an imported schema that uses a non-imported type" $- assertMatches- [schemaRep| { a: #SchemaWithHiddenImport } |]- [r| SchemaObject { "a": { "a": CBool } } |]-- , testCase "Object with an imported schema that itself imports a schema" $- assertMatches- [schemaRep| { a: #WithUser } |]- [r| SchemaObject { "a": { "user": { "name": Text } } } |]-- , testCase "Object with an extended schema" $- assertMatches- [schemaRep| { a: Int, #ExtraSchema } |]- [r| SchemaObject { "a": Int, "extra": Text } |]-- , testCase "Object with a qualified extended schema" $- assertMatches- [schemaRep| { a: Int, #(Tests.SchemaQQ.TH.ExtraSchema) } |]- [r| SchemaObject { "a": Int, "extra": Text } |]-- , testCase "Object with an extended schema that uses a non-imported type" $- assertMatches- [schemaRep| { #SchemaWithHiddenImport } |]- [r| SchemaObject { "a": CBool } |]-- , testCase "Object with an extended schema with a shadowed key" $- assertMatches- [schemaRep| { extra: Bool, #ExtraSchema } |]- [r| SchemaObject { "extra": Bool } |]-- , testCase "Object with a qualified extended schema with a shadowed key" $- assertMatches- [schemaRep| { extra: Bool, #(Tests.SchemaQQ.TH.ExtraSchema) } |]- [r| SchemaObject { "extra": Bool } |]-- , testCase "Object with a union field" $- assertMatches- [schemaRep| { a: List Int | Text } |]- [r| SchemaObject { "a": ( List Int | Text ) } |]-- , testCase "Object with a union field with a group" $- assertMatches- [schemaRep| { a: List (Int | Text) } |]- [r| SchemaObject { "a": List ( Int | Text ) } |]-- , testCase "Object with a phantom key for an object" $- assertMatches- [schemaRep| { [a]: { b: Int } } |]- [r| SchemaObject { [a]: { "b": Int } } |]-- , testCase "Object with a phantom key for a Maybe" $- assertMatches- [schemaRep| { [a]: Maybe { b: Int } } |]- [r| SchemaObject { [a]: Maybe { "b": Int } } |]-- , testCase "Object with a phantom key for a Try" $- assertMatches- [schemaRep| { [a]: Try { b: Int } } |]- [r| SchemaObject { [a]: Try { "b": Int } } |]-- , testCase "Object with a phantom key for a non-object Try" $- assertMatches- [schemaRep| { [a]: Try Bool } |]- [r| SchemaObject { [a]: Try Bool } |]-- , testCase "Object with a phantom key for a union of valid schemas" $- assertMatches- [schemaRep| { [a]: { b: Int } | Int } |]- [r| SchemaObject { [a]: ( { "b": Int } | Int ) } |]- ]+testValidSchemas =+ testGroup+ "Valid schemas"+ [ testCase "Object with Bool field" $+ assertMatches+ [schemaRep| { a: Bool } |]+ [r| SchemaObject { "a": Bool } |]+ , testCase "Object with Int field" $+ assertMatches+ [schemaRep| { a: Int } |]+ [r| SchemaObject { "a": Int } |]+ , testCase "Object with Double field" $+ assertMatches+ [schemaRep| { foo123: Double } |]+ [r| SchemaObject { "foo123": Double } |]+ , testCase "Object with Text field" $+ assertMatches+ [schemaRep| { some_text: Text } |]+ [r| SchemaObject { "some_text": Text } |]+ , testCase "Object with a field with a custom type" $+ assertMatches+ [schemaRep| { status: Status } |]+ [r| SchemaObject { "status": Status } |]+ , testCase "Object with a field with a Maybe type" $+ assertMatches+ [schemaRep| { a: Maybe Bool } |]+ [r| SchemaObject { "a": Maybe Bool } |]+ , testCase "Object with a field with a Try type" $+ assertMatches+ [schemaRep| { a: Try Bool } |]+ [r| SchemaObject { "a": Try Bool } |]+ , testCase "Object with a nested object" $+ assertMatches+ [schemaRep| { a: { b: Int } } |]+ [r| SchemaObject { "a": { "b": Int } } |]+ , testCase "Object with a nullable nested object" $+ assertMatches+ [schemaRep| { a: Maybe { b: Int } } |]+ [r| SchemaObject { "a": Maybe { "b": Int } } |]+ , testCase "Object with a list of nested objects" $+ assertMatches+ [schemaRep| { a: List { b: Int } } |]+ [r| SchemaObject { "a": List { "b": Int } } |]+ , testCase "Object with an imported schema" $+ assertMatches+ [schemaRep| { user: #UserSchema } |]+ [r| SchemaObject { "user": { "name": Text } } |]+ , testCase "Object with a qualified imported schema" $+ assertMatches+ [schemaRep| { user: #(Tests.SchemaQQ.TH.UserSchema) } |]+ [r| SchemaObject { "user": { "name": Text } } |]+ , testCase "Object with an imported schema that uses a non-imported type" $+ assertMatches+ [schemaRep| { a: #SchemaWithHiddenImport } |]+ [r| SchemaObject { "a": { "a": CBool } } |]+ , testCase "Object with an imported schema that itself imports a schema" $+ assertMatches+ [schemaRep| { a: #WithUser } |]+ [r| SchemaObject { "a": { "user": { "name": Text } } } |]+ , testCase "Object with an extended schema" $+ assertMatches+ [schemaRep| { a: Int, #ExtraSchema } |]+ [r| SchemaObject { "a": Int, "extra": Text } |]+ , testCase "Object with a qualified extended schema" $+ assertMatches+ [schemaRep| { a: Int, #(Tests.SchemaQQ.TH.ExtraSchema) } |]+ [r| SchemaObject { "a": Int, "extra": Text } |]+ , testCase "Object with an extended schema that uses a non-imported type" $+ assertMatches+ [schemaRep| { #SchemaWithHiddenImport } |]+ [r| SchemaObject { "a": CBool } |]+ , testCase "Object with an extended schema with a shadowed key" $+ assertMatches+ [schemaRep| { extra: Bool, #ExtraSchema } |]+ [r| SchemaObject { "extra": Bool } |]+ , testCase "Object with a qualified extended schema with a shadowed key" $+ assertMatches+ [schemaRep| { extra: Bool, #(Tests.SchemaQQ.TH.ExtraSchema) } |]+ [r| SchemaObject { "extra": Bool } |]+ , testCase "Object with a union field" $+ assertMatches+ [schemaRep| { a: List Int | Text } |]+ [r| SchemaObject { "a": ( List Int | Text ) } |]+ , testCase "Object with a union field with a group" $+ assertMatches+ [schemaRep| { a: List (Int | Text) } |]+ [r| SchemaObject { "a": List ( Int | Text ) } |]+ , testCase "Object with a phantom key for an object" $+ assertMatches+ [schemaRep| { [a]: { b: Int } } |]+ [r| SchemaObject { [a]: { "b": Int } } |]+ , testCase "Object with a phantom key for a Maybe" $+ assertMatches+ [schemaRep| { [a]: Maybe { b: Int } } |]+ [r| SchemaObject { [a]: Maybe { "b": Int } } |]+ , testCase "Object with a phantom key for a Try" $+ assertMatches+ [schemaRep| { [a]: Try { b: Int } } |]+ [r| SchemaObject { [a]: Try { "b": Int } } |]+ , testCase "Object with a phantom key for a non-object Try" $+ assertMatches+ [schemaRep| { [a]: Try Bool } |]+ [r| SchemaObject { [a]: Try Bool } |]+ , testCase "Object with a phantom key for a union of valid schemas" $+ assertMatches+ [schemaRep| { [a]: { b: Int } | Int } |]+ [r| SchemaObject { [a]: ( { "b": Int } | Int ) } |]+ ] testInvalidSchemas :: TestTree-testInvalidSchemas = testGroup "Invalid schemas"- [ testCase "Object with a duplicate key" $- [schemaErr| { a: Int, a: Bool } |] @?= "Key 'a' specified multiple times"-- , testCase "Object with a duplicate phantom key" $- [schemaErr| { a: Int, [a]: { b: Bool } } |] @?= "Key 'a' specified multiple times"-- , testCase "Object with a duplicate key from extending" $- [schemaErr| { #ExtraSchema, #ExtraSchema2 } |] @?= "Key 'extra' declared in multiple imported schemas"-- , testCase "Quasiquoter defining a non-object" $- [schemaErr| List { a: Int } |] @?= "`schema` definition must be an object"-- , testCase "Object with a field with an unknown type" $- [schemaErr| { a: HelloWorld } |] @?= "Unknown type: HelloWorld"-- , testCase "Object extending a non-schema" $- [schemaErr| { #Int } |] @?= "'GHC.Types.Int' is not a Schema"-- , testCase "Object importing an unknown schema" $- [schemaErr| { foo: #FooSchema } |] @?= "Unknown schema: FooSchema"-- , testCase "Object extending an unknown schema" $- [schemaErr| { #FooSchema } |] @?= "Unknown schema: FooSchema"-- , testCase "Object with a phantom key for a scalar" $- [schemaErr| { [a]: Int } |] @?= "Invalid schema for 'a': SchemaScalar Int"-- , testCase "Object with a phantom key for a list" $- [schemaErr| { [a]: List Int } |] @?= "Invalid schema for 'a': SchemaList Int"-- , testCase "Object with a phantom key for a non-object Maybe" $- [schemaErr| { [a]: Maybe Int } |] @?= "Invalid schema for 'a': SchemaMaybe Int"-- , testCase "Object with a phantom key for an invalid union" $- [schemaErr| { [a]: Bool | Int } |] @?= "Invalid schema for 'a': SchemaUnion ( Bool | Int )"- ]+testInvalidSchemas =+ testGroup+ "Invalid schemas"+ [ testCase "Object with a duplicate key" $+ [schemaErr| { a: Int, a: Bool } |] @?= "Key 'a' specified multiple times"+ , testCase "Object with a duplicate phantom key" $+ [schemaErr| { a: Int, [a]: { b: Bool } } |] @?= "Key 'a' specified multiple times"+ , testCase "Object with a duplicate key from extending" $+ [schemaErr| { #ExtraSchema, #ExtraSchema2 } |] @?= "Key 'extra' declared in multiple imported schemas"+ , testCase "Quasiquoter defining a non-object" $+ [schemaErr| List { a: Int } |] @?= "`schema` definition must be an object"+ , testCase "Object with a field with an unknown type" $+ [schemaErr| { a: HelloWorld } |] @?= "Unknown type: HelloWorld"+ , testCase "Object extending a non-schema" $+ [schemaErr| { #Int } |] @?= "'GHC.Types.Int' is not a Schema"+ , testCase "Object importing an unknown schema" $+ [schemaErr| { foo: #FooSchema } |] @?= "Unknown schema: FooSchema"+ , testCase "Object extending an unknown schema" $+ [schemaErr| { #FooSchema } |] @?= "Unknown schema: FooSchema"+ , testCase "Object with a phantom key for a scalar" $+ [schemaErr| { [a]: Int } |] @?= "Invalid schema for 'a': SchemaScalar Int"+ , testCase "Object with a phantom key for a list" $+ [schemaErr| { [a]: List Int } |] @?= "Invalid schema for 'a': SchemaList Int"+ , testCase "Object with a phantom key for a non-object Maybe" $+ [schemaErr| { [a]: Maybe Int } |] @?= "Invalid schema for 'a': SchemaMaybe Int"+ , testCase "Object with a phantom key for an invalid union" $+ [schemaErr| { [a]: Bool | Int } |] @?= "Invalid schema for 'a': SchemaUnion ( Bool | Int )"+ ] testKeys :: TestTree-testKeys = testGroup "Keys in schemas"- [ testCase "Quoted key same as plain key" $- [schemaRep| { a: Int } |] @?= [schemaRep| { "a": Int } |]-- , testParseError "Key with invalid character" "schemaqq_key_with_invalid_character.golden"- [schemaErr| { "a:b": Int } |]-- , testCase "Key with escaped invalid character" $- assertMatches- [schemaRep| { "a\:b": Int } |]- [r| SchemaObject { "a:b": Int } |]-- , testParseError "Key with trailing escape" "schemaqq_key_with_trailing_escape.golden"- [schemaErr| { "a\": Int } |]-- , testCase "Quoted key that starts with '//'" $- assertMatches- [schemaRep| { "//a": { b: Int } } |]- [r| SchemaObject { "//a": { "b": Int } } |]-- , testCase "Phantom key that starts with '//'" $- assertMatches- [schemaRep| { [//a]: { b: Int } } |]- [r| SchemaObject { [//a]: { "b": Int } } |]- ]+testKeys =+ testGroup+ "Keys in schemas"+ [ testCase "Quoted key same as plain key" $+ [schemaRep| { a: Int } |] @?= [schemaRep| { "a": Int } |]+ , testParseError+ "Key with invalid character"+ "schemaqq_key_with_invalid_character.golden"+ [schemaErr| { "a:b": Int } |]+ , testCase "Key with escaped invalid character" $+ assertMatches+ [schemaRep| { "a\:b": Int } |]+ [r| SchemaObject { "a:b": Int } |]+ , testParseError+ "Key with trailing escape"+ "schemaqq_key_with_trailing_escape.golden"+ [schemaErr| { "a\": Int } |]+ , testCase "Quoted key that starts with '//'" $+ assertMatches+ [schemaRep| { "//a": { b: Int } } |]+ [r| SchemaObject { "//a": { "b": Int } } |]+ , testCase "Phantom key that starts with '//'" $+ assertMatches+ [schemaRep| { [//a]: { b: Int } } |]+ [r| SchemaObject { [//a]: { "b": Int } } |]+ ] {- Helpers -}
test/Tests/SchemaQQ/TH.hs view
@@ -10,10 +10,17 @@ import Control.DeepSeq (deepseq) import Data.Aeson (FromJSON, ToJSON)-import Foreign.C (CBool(..))-import Language.Haskell.TH.Quote (QuasiQuoter(..))-import Language.Haskell.TH.TestUtils- (MockedMode(..), QMode(..), QState(..), loadNames, runTestQ, runTestQErr)+import Foreign.C (CBool (..))+import Language.Haskell.TH (appTypeE)+import Language.Haskell.TH.Quote (QuasiQuoter (..))+import Language.Haskell.TH.TestUtils (+ MockedMode (..),+ QMode (..),+ QState (..),+ loadNames,+ runTestQ,+ runTestQErr,+ ) import Data.Aeson.Schema (schema, showSchema) import TestUtils (mkExpQQ)@@ -24,10 +31,11 @@ type ExtraSchema2 = [schema| { extra: Maybe Text } |] newtype Status = Status Int- deriving (Show,FromJSON,ToJSON)+ deriving (Show, FromJSON, ToJSON) -- | The type referenced here should not be imported in SchemaQQ.hs nor included in 'knownNames'. type SchemaWithHiddenImport = [schema| { a: CBool } |]+ deriving instance ToJSON CBool deriving instance FromJSON CBool @@ -40,37 +48,41 @@ $(return []) qState :: QState 'FullyMocked-qState = QState- { mode = MockQ- , knownNames =- [ ("Status", ''Status)- , ("UserSchema", ''UserSchema)- , ("ExtraSchema", ''ExtraSchema)- , ("ExtraSchema2", ''ExtraSchema2)- , ("Tests.SchemaQQ.TH.UserSchema", ''UserSchema)- , ("Tests.SchemaQQ.TH.ExtraSchema", ''ExtraSchema)- , ("SchemaWithHiddenImport", ''SchemaWithHiddenImport)- , ("WithUser", ''WithUser)- , ("Int", ''Int)- ]- , reifyInfo = $(loadNames- [ ''UserSchema- , ''ExtraSchema- , ''ExtraSchema2- , ''SchemaWithHiddenImport- , ''WithUser- , ''Int- ]- )- }+qState =+ QState+ { mode = MockQ+ , knownNames =+ [ ("Status", ''Status)+ , ("UserSchema", ''UserSchema)+ , ("ExtraSchema", ''ExtraSchema)+ , ("ExtraSchema2", ''ExtraSchema2)+ , ("Tests.SchemaQQ.TH.UserSchema", ''UserSchema)+ , ("Tests.SchemaQQ.TH.ExtraSchema", ''ExtraSchema)+ , ("SchemaWithHiddenImport", ''SchemaWithHiddenImport)+ , ("WithUser", ''WithUser)+ , ("Int", ''Int)+ ]+ , reifyInfo =+ $( loadNames+ [ ''UserSchema+ , ''ExtraSchema+ , ''ExtraSchema2+ , ''SchemaWithHiddenImport+ , ''WithUser+ , ''Int+ ]+ )+ } --- | A quasiquoter for generating the string representation of a schema.------ Also runs the `schema` quasiquoter at runtime, to get coverage information.+{- | A quasiquoter for generating the string representation of a schema.++ Also runs the `schema` quasiquoter at runtime, to get coverage information.+-} schemaRep :: QuasiQuoter schemaRep = mkExpQQ $ \s -> let schemaType = quoteType schema s- in [| runTestQ qState (quoteType schema s) `deepseq` showSchema @ $schemaType |]+ showSchemaQ = appTypeE [|showSchema|] schemaType+ in [|runTestQ qState (quoteType schema s) `deepseq` $showSchemaQ|] schemaErr :: QuasiQuoter-schemaErr = mkExpQQ $ \s -> [| runTestQErr qState (quoteType schema s) |]+schemaErr = mkExpQQ $ \s -> [|runTestQErr qState (quoteType schema s)|]
test/Tests/SumType.hs view
@@ -6,14 +6,14 @@ module Tests.SumType where import Data.Aeson (ToJSON, eitherDecode, encode)-import Data.Proxy (Proxy(..))+import Data.Proxy (Proxy (..)) import Data.String (fromString) import Test.Tasty import Test.Tasty.Golden import Test.Tasty.HUnit import Test.Tasty.QuickCheck -import Data.Aeson.Schema.Utils.Sum (SumType(..), fromSumType)+import Data.Aeson.Schema.Utils.Sum (SumType (..), fromSumType) type SpecialJSON = SumType '[Bool, Int, [String]] @@ -26,64 +26,72 @@ {- Tests -} test :: TestTree-test = testGroup "SumType"- [ testCase "Sanity checks" $- -- this should compile- let values =- [ Here True- , Here False- , There (Here 1)- , There (Here 10)- , There (There (Here []))- , There (There (Here ["a"]))- ] :: [SpecialJSON]- in values @?= values- , testDecode- , testFromSumType- ]+test =+ testGroup+ "SumType"+ [ testCase "Sanity checks" $+ -- this should compile+ let values =+ [ Here True+ , Here False+ , There (Here 1)+ , There (Here 10)+ , There (There (Here []))+ , There (There (Here ["a"]))+ ] ::+ [SpecialJSON]+ in values @?= values+ , testDecode+ , testFromSumType+ ] testDecode :: TestTree-testDecode = testGroup "Decode SumType"- [ testProperty "branch 1" $ \(b :: Bool) ->- toSpecialJSON' b === Right (Here b)- , testProperty "branch 2" $ \(x :: Int) ->- toSpecialJSON' x === Right (There (Here x))- , testProperty "branch 3" $ \(l :: [String]) ->- toSpecialJSON' l === Right (There (There (Here l)))- , goldenVsString "invalid SumType" "test/goldens/sumtype_decode_invalid.golden" $- case toSpecialJSON' [True] of- Right v -> error $ "Unexpectedly decoded value: " ++ show v- Left e -> pure $ fromString e- ]+testDecode =+ testGroup+ "Decode SumType"+ [ testProperty "branch 1" $ \(b :: Bool) ->+ toSpecialJSON' b === Right (Here b)+ , testProperty "branch 2" $ \(x :: Int) ->+ toSpecialJSON' x === Right (There (Here x))+ , testProperty "branch 3" $ \(l :: [String]) ->+ toSpecialJSON' l === Right (There (There (Here l)))+ , goldenVsString "invalid SumType" "test/goldens/sumtype_decode_invalid.golden" $+ case toSpecialJSON' [True] of+ Right v -> error $ "Unexpectedly decoded value: " ++ show v+ Left e -> pure $ fromString e+ ] testFromSumType :: TestTree-testFromSumType = testGroup "fromSumType"- [ testProperty "branch 0 valid" $ \b ->- fromSumType (Proxy @0) (toSpecialJSON b) === Just b- , testProperty "branch 0 invalid" $- forAll (specialJSONExcept 0) $ \(branch, value) ->- labelBranch branch $ fromSumType (Proxy @0) value === Nothing-- , testProperty "branch 1 valid" $ \x ->- fromSumType (Proxy @1) (toSpecialJSON x) === Just x- , testProperty "branch 1 invalid" $- forAll (specialJSONExcept 1) $ \(branch, value) ->- labelBranch branch $ fromSumType (Proxy @1) value === Nothing-- , testProperty "branch 2 valid" $ \l ->- fromSumType (Proxy @2) (toSpecialJSON l) === Just l- , testProperty "branch 2 invalid" $- forAll (specialJSONExcept 2) $ \(branch, value) ->- labelBranch branch $ fromSumType (Proxy @2) value === Nothing- ]+testFromSumType =+ testGroup+ "fromSumType"+ [ testProperty "branch 0 valid" $ \b ->+ fromSumType (Proxy @0) (toSpecialJSON b) === Just b+ , testProperty "branch 0 invalid" $+ forAll (specialJSONExcept 0) $ \(branch, value) ->+ labelBranch branch $ fromSumType (Proxy @0) value === Nothing+ , testProperty "branch 1 valid" $ \x ->+ fromSumType (Proxy @1) (toSpecialJSON x) === Just x+ , testProperty "branch 1 invalid" $+ forAll (specialJSONExcept 1) $ \(branch, value) ->+ labelBranch branch $ fromSumType (Proxy @1) value === Nothing+ , testProperty "branch 2 valid" $ \l ->+ fromSumType (Proxy @2) (toSpecialJSON l) === Just l+ , testProperty "branch 2 invalid" $+ forAll (specialJSONExcept 2) $ \(branch, value) ->+ labelBranch branch $ fromSumType (Proxy @2) value === Nothing+ ] where specialJSONExcept :: Int -> Gen (Int, SpecialJSON) specialJSONExcept validBranch = let fmapFst (a, gen) = (a,) <$> gen- in oneof $ map fmapFst $ filter ((/= validBranch) . fst)- [ (0, toSpecialJSON <$> arbitrary @Bool)- , (1, toSpecialJSON <$> arbitrary @Int)- , (2, toSpecialJSON <$> arbitrary @[String])- ]+ in oneof $+ map fmapFst $+ filter+ ((/= validBranch) . fst)+ [ (0, toSpecialJSON <$> arbitrary @Bool)+ , (1, toSpecialJSON <$> arbitrary @Int)+ , (2, toSpecialJSON <$> arbitrary @[String])+ ] labelBranch branch = label $ "branch " ++ show branch
test/Tests/UnwrapQQ.hs view
@@ -10,45 +10,43 @@ import Text.RawString.QQ (r) import Data.Aeson.Schema (Object, get)-import Tests.UnwrapQQ.TH import TestUtils (json, testParseError)+import Tests.UnwrapQQ.TH test :: TestTree-test = testGroup "`unwrap` quasiquoter"- [ testValidUnwrapDefs- , testInvalidUnwrapDefs- ]+test =+ testGroup+ "`unwrap` quasiquoter"+ [ testValidUnwrapDefs+ , testInvalidUnwrapDefs+ ] testValidUnwrapDefs :: TestTree-testValidUnwrapDefs = testGroup "Valid unwrap definitions"- [ testCase "Can unwrap a list" $ do- [unwrapRep| ListSchema.ids |] @?= "[Int]"- [unwrapRep| ListSchema.ids[] |] @?= "Int"-- , testCase "Can unwrap a list of keys" $- [unwrapRep| ABCSchema.[a, b] |] @?= "[Bool]"-- , testCase "Can unwrap a tuple of keys" $- [unwrapRep| ABCSchema.(a, b, c) |] @?= "(Bool,Bool,Double)"-- , testCase "Can unwrap a maybe" $ do- [unwrapRep| MaybeSchema.class |] @?= "Maybe Text"- [unwrapRep| MaybeSchema.class! |] @?= "Text"- [unwrapRep| MaybeSchema.class? |] @?= "Text"-- , testCase "Can unwrap a sum type" $ do- [unwrapRep| SumSchema.verbosity@0 |] @?= "Int"- [unwrapRep| SumSchema.verbosity@1 |] @?= "Bool"-- , testCase "Can unwrap an included schema" $- [unwrapRep| ListSchema2.list.ids |] @?= "[Int]"-- , testCase "Can unwrap an Object twice" $- [unwrapRep| UnwrappedNestedSchema.b |] @?= "Object (SchemaObject { \"c\": Bool })"-- , testCase "Can use unwrapped type" $ do- let result :: Object MySchema- result = [json|+testValidUnwrapDefs =+ testGroup+ "Valid unwrap definitions"+ [ testCase "Can unwrap a list" $ do+ [unwrapRep| ListSchema.ids |] @?= "[Int]"+ [unwrapRep| ListSchema.ids[] |] @?= "Int"+ , testCase "Can unwrap a list of keys" $+ [unwrapRep| ABCSchema.[a, b] |] @?= "[Bool]"+ , testCase "Can unwrap a tuple of keys" $+ [unwrapRep| ABCSchema.(a, b, c) |] @?= "(Bool,Bool,Double)"+ , testCase "Can unwrap a maybe" $ do+ [unwrapRep| MaybeSchema.class |] @?= "Maybe Text"+ [unwrapRep| MaybeSchema.class! |] @?= "Text"+ [unwrapRep| MaybeSchema.class? |] @?= "Text"+ , testCase "Can unwrap a sum type" $ do+ [unwrapRep| SumSchema.verbosity@0 |] @?= "Int"+ [unwrapRep| SumSchema.verbosity@1 |] @?= "Bool"+ , testCase "Can unwrap an included schema" $+ [unwrapRep| ListSchema2.list.ids |] @?= "[Int]"+ , testCase "Can unwrap an Object twice" $+ [unwrapRep| UnwrappedNestedSchema.b |] @?= "Object (SchemaObject { \"c\": Bool })"+ , testCase "Can use unwrapped type" $ do+ let result :: Object MySchema+ result =+ [json| { "users": [ { "name": "Alice" },@@ -58,54 +56,48 @@ } |] - users :: [User]- users = [get| result.users |]+ users :: [User]+ users = [get| result.users |] - getName :: User -> String- getName = Text.unpack . [get| .name |]+ getName :: User -> String+ getName = Text.unpack . [get| .name |] - map getName users @?= ["Alice", "Bob", "Claire"]- ]+ map getName users @?= ["Alice", "Bob", "Claire"]+ ] testInvalidUnwrapDefs :: TestTree-testInvalidUnwrapDefs = testGroup "Invalid unwrap definitions"- [ testCase "Unwrap unknown schema" $- [unwrapErr| FooSchema.asdf |] @?= "Unknown schema: FooSchema"-- , testCase "Unwrap non-schema" $- [unwrapErr| NotASchema.foo |] @?= "'Tests.UnwrapQQ.TH.NotASchema' is not a Schema"-- , testCase "Unwrap key on non-object" $- [unwrapErr| ListSchema.ids.foo |] @?= "Cannot get key 'foo' in schema: SchemaList Int"-- , testCase "Unwrap maybe on non-maybe" $ do- [unwrapErr| ListSchema.ids! |] @?= "Cannot use `!` operator on schema: SchemaList Int"- [unwrapErr| ListSchema.ids? |] @?= "Cannot use `?` operator on schema: SchemaList Int"-- , testCase "Unwrap list on non-list" $- [unwrapErr| MaybeSchema.class[] |] @?= "Cannot use `[]` operator on schema: SchemaMaybe Text"-- , testCase "Unwrap nonexistent key" $- [unwrapErr| ListSchema.foo |] @?= [r|Key 'foo' does not exist in schema: SchemaObject { "ids": List Int }|]-- , testCase "Unwrap list of keys with different types" $- [unwrapErr| ABCSchema.[a,b,c] |] @?= [r|List contains different types in schema: SchemaObject { "a": Bool, "b": Bool, "c": Double }|]-- , testCase "Unwrap list of keys on non-object schema" $- [unwrapErr| ListSchema.ids.[a,b] |] @?= "Cannot get keys in schema: SchemaList Int"-- , testParseError "Unwrap beyond list of keys" "unwrapqq_unwrap_past_list.golden"- [unwrapErr| ABCSchema.[a,b].foo |]-- , testCase "Unwrap tuple of keys on non-object schema" $- [unwrapErr| ListSchema.ids.(a,b) |] @?= "Cannot get keys in schema: SchemaList Int"-- , testParseError "Unwrap beyond tuple of keys" "unwrapqq_unwrap_past_tuple.golden"- [unwrapErr| ABCSchema.(a,b).foo |]-- , testCase "Unwrap branch on non-branch" $- [unwrapErr| MaybeSchema.class@0 |] @?= "Cannot use `@` operator on schema: SchemaMaybe Text"-- , testCase "Unwrap out of bounds branch" $- [unwrapErr| SumSchema.verbosity@10 |] @?= "Branch out of bounds for schema: SchemaUnion ( Int | Bool )"- ]+testInvalidUnwrapDefs =+ testGroup+ "Invalid unwrap definitions"+ [ testCase "Unwrap unknown schema" $+ [unwrapErr| FooSchema.asdf |] @?= "Unknown schema: FooSchema"+ , testCase "Unwrap non-schema" $+ [unwrapErr| NotASchema.foo |] @?= "'Tests.UnwrapQQ.TH.NotASchema' is not a Schema"+ , testCase "Unwrap key on non-object" $+ [unwrapErr| ListSchema.ids.foo |] @?= "Cannot get key 'foo' in schema: SchemaList Int"+ , testCase "Unwrap maybe on non-maybe" $ do+ [unwrapErr| ListSchema.ids! |] @?= "Cannot use `!` operator on schema: SchemaList Int"+ [unwrapErr| ListSchema.ids? |] @?= "Cannot use `?` operator on schema: SchemaList Int"+ , testCase "Unwrap list on non-list" $+ [unwrapErr| MaybeSchema.class[] |] @?= "Cannot use `[]` operator on schema: SchemaMaybe Text"+ , testCase "Unwrap nonexistent key" $+ [unwrapErr| ListSchema.foo |] @?= [r|Key 'foo' does not exist in schema: SchemaObject { "ids": List Int }|]+ , testCase "Unwrap list of keys with different types" $+ [unwrapErr| ABCSchema.[a,b,c] |] @?= [r|List contains different types in schema: SchemaObject { "a": Bool, "b": Bool, "c": Double }|]+ , testCase "Unwrap list of keys on non-object schema" $+ [unwrapErr| ListSchema.ids.[a,b] |] @?= "Cannot get keys in schema: SchemaList Int"+ , testParseError+ "Unwrap beyond list of keys"+ "unwrapqq_unwrap_past_list.golden"+ [unwrapErr| ABCSchema.[a,b].foo |]+ , testCase "Unwrap tuple of keys on non-object schema" $+ [unwrapErr| ListSchema.ids.(a,b) |] @?= "Cannot get keys in schema: SchemaList Int"+ , testParseError+ "Unwrap beyond tuple of keys"+ "unwrapqq_unwrap_past_tuple.golden"+ [unwrapErr| ABCSchema.(a,b).foo |]+ , testCase "Unwrap branch on non-branch" $+ [unwrapErr| MaybeSchema.class@0 |] @?= "Cannot use `@` operator on schema: SchemaMaybe Text"+ , testCase "Unwrap out of bounds branch" $+ [unwrapErr| SumSchema.verbosity@10 |] @?= "Branch out of bounds for schema: SchemaUnion ( Int | Bool )"+ ]
test/Tests/UnwrapQQ/TH.hs view
@@ -6,18 +6,25 @@ import Control.DeepSeq (deepseq) import Language.Haskell.TH (appTypeE)-import Language.Haskell.TH.Quote (QuasiQuoter(..))-import Language.Haskell.TH.TestUtils- (MockedMode(..), QMode(..), QState(..), loadNames, runTestQ, runTestQErr)+import Language.Haskell.TH.Quote (QuasiQuoter (..))+import Language.Haskell.TH.TestUtils (+ MockedMode (..),+ QMode (..),+ QState (..),+ loadNames,+ runTestQ,+ runTestQErr,+ ) import Data.Aeson.Schema (schema, unwrap)-import TestUtils (ShowSchemaResult(..), mkExpQQ)+import TestUtils (ShowSchemaResult (..), mkExpQQ) import TestUtils.DeepSeq () type ListSchema = [schema| { ids: List Int } |] type MaybeSchema = [schema| { class: Maybe Text } |] type SumSchema = [schema| { verbosity: Int | Bool } |]-type ABCSchema = [schema|+type ABCSchema =+ [schema| { a: Bool, b: Bool,@@ -25,7 +32,8 @@ } |] -type NestedSchema = [schema|+type NestedSchema =+ [schema| { a: { b: {@@ -35,7 +43,8 @@ } |] -type MySchema = [schema|+type MySchema =+ [schema| { users: List { name: Text,@@ -56,38 +65,40 @@ $(return []) qState :: QState 'FullyMocked-qState = QState- { mode = MockQ- , knownNames =- [ ("ListSchema", ''ListSchema)- , ("ListSchema2", ''ListSchema2)- , ("MaybeSchema", ''MaybeSchema)- , ("SumSchema", ''SumSchema)- , ("ABCSchema", ''ABCSchema)- , ("NotASchema", ''NotASchema)- , ("UnwrappedNestedSchema", ''UnwrappedNestedSchema)- ]- , reifyInfo = $(- loadNames- [ ''ListSchema- , ''ListSchema2- , ''MaybeSchema- , ''SumSchema- , ''ABCSchema- , ''NotASchema- , ''MySchema- , ''UnwrappedNestedSchema+qState =+ QState+ { mode = MockQ+ , knownNames =+ [ ("ListSchema", ''ListSchema)+ , ("ListSchema2", ''ListSchema2)+ , ("MaybeSchema", ''MaybeSchema)+ , ("SumSchema", ''SumSchema)+ , ("ABCSchema", ''ABCSchema)+ , ("NotASchema", ''NotASchema)+ , ("UnwrappedNestedSchema", ''UnwrappedNestedSchema) ]- )- }+ , reifyInfo =+ $( loadNames+ [ ''ListSchema+ , ''ListSchema2+ , ''MaybeSchema+ , ''SumSchema+ , ''ABCSchema+ , ''NotASchema+ , ''MySchema+ , ''UnwrappedNestedSchema+ ]+ )+ } --- | A quasiquoter for generating the string representation of an unwrapped schema.------ Also runs the `unwrap` quasiquoter at runtime, to get coverage information.+{- | A quasiquoter for generating the string representation of an unwrapped schema.++ Also runs the `unwrap` quasiquoter at runtime, to get coverage information.+-} unwrapRep :: QuasiQuoter unwrapRep = mkExpQQ $ \s ->- let showSchemaResultQ = appTypeE [| showSchemaResult |] (quoteType unwrap s)- in [| runTestQ qState (quoteType unwrap s) `deepseq` $showSchemaResultQ |]+ let showSchemaResultQ = appTypeE [|showSchemaResult|] (quoteType unwrap s)+ in [|runTestQ qState (quoteType unwrap s) `deepseq` $showSchemaResultQ|] unwrapErr :: QuasiQuoter-unwrapErr = mkExpQQ $ \s -> [| runTestQErr qState (quoteType unwrap s) |]+unwrapErr = mkExpQQ $ \s -> [|runTestQErr qState (quoteType unwrap s)|]