packages feed

aeson-schemas 1.4.0.0 → 1.4.0.1

raw patch · 16 files changed

+237/−111 lines, 16 filesdep +directorydep −hintdep ~aesondep ~basedep ~template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies added: directory

Dependencies removed: hint

Dependency ranges changed: aeson, base, template-haskell, text

API changes (from Hackage documentation)

Files

CHANGELOG.md view
@@ -1,3 +1,7 @@+# v1.4.0.1++* Add support for GHC 9.4+ # v1.4.0.0  * Drop support for GHC < 8.10
aeson-schemas.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           aeson-schemas-version:        1.4.0.0+version:        1.4.0.1 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@@ -36,10 +36,13 @@     test/goldens/fromjson_scalar_invalid.golden     test/goldens/fromjson_union_invalid.golden     test/goldens/getqq_empty_expression.golden-    test/goldens/getqq_missing_key.golden     test/goldens/getqq_no_operators.golden     test/goldens/getqq_ops_after_list.golden     test/goldens/getqq_ops_after_tuple.golden+    test/goldens/integration/ghc-8.10/getqq_missing_key.golden+    test/goldens/integration/ghc-9.0/getqq_missing_key.golden+    test/goldens/integration/ghc-9.2/getqq_missing_key.golden+    test/goldens/integration/ghc-9.4/getqq_missing_key.golden     test/goldens/README_Quickstart.golden     test/goldens/schemaqq_key_with_invalid_character.golden     test/goldens/schemaqq_key_with_trailing_escape.golden@@ -52,6 +55,10 @@   type: git   location: https://github.com/LeapYear/aeson-schemas +flag run-integration-tests+  manual: True+  default: False+ library   exposed-modules:       Data.Aeson.Schema@@ -81,8 +88,8 @@     , first-class-families >=0.3.0.0 && <0.9     , hashable >=1.2.7.0 && <1.5     , megaparsec >=7 && <10-    , template-haskell >=2.16 && <2.19-    , text >=1.2.2.2 && <1.3+    , template-haskell >=2.16 && <2.20+    , text >=1.2.2.2 && <2.1     , unordered-containers >=0.2.8.0 && <0.3   default-language: Haskell2010   if impl(ghc >= 8.0)@@ -120,34 +127,32 @@   ghc-options: -Wall   build-depends:       QuickCheck-    , aeson >=1.1.2.0 && <3+    , aeson     , aeson-qq     , aeson-schemas-    , base >=4.14 && <5+    , base     , deepseq+    , directory     , filepath-    , first-class-families >=0.3.0.0 && <0.9-    , hashable >=1.2.7.0 && <1.5-    , hint     , interpolate-    , megaparsec >=7 && <10     , process     , raw-strings-qq     , tasty     , tasty-golden     , tasty-hunit     , tasty-quickcheck-    , template-haskell >=2.16 && <2.19+    , template-haskell     , temporary-    , text >=1.2.2.2 && <1.3+    , text     , th-orphans     , th-test-utils-    , unordered-containers >=0.2.8.0 && <0.3   default-language: Haskell2010   if impl(ghc >= 8.0)     ghc-options: -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances   if impl(ghc < 8.8)     ghc-options: -Wnoncanonical-monadfail-instances+  if flag(run-integration-tests)+    cpp-options: -DRUN_INTEGRATION_TESTS  benchmark aeson-schemas-bench   type: exitcode-stdio-1.0@@ -166,18 +171,13 @@       bench   ghc-options: -Wall   build-depends:-      aeson >=1.1.2.0 && <3+      aeson     , aeson-schemas-    , base >=4.14 && <5+    , base     , criterion     , deepseq-    , first-class-families >=0.3.0.0 && <0.9-    , hashable >=1.2.7.0 && <1.5-    , megaparsec >=7 && <10-    , template-haskell >=2.16 && <2.19-    , text >=1.2.2.2 && <1.3+    , template-haskell     , th-test-utils-    , unordered-containers >=0.2.8.0 && <0.3   default-language: Haskell2010   if impl(ghc >= 8.0)     ghc-options: -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances
bench/Benchmarks/Data/Objects.hs view
@@ -41,7 +41,7 @@ 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@@ -49,7 +49,7 @@   , IsSchemaObjectMap pairs   , Typeable pairs   ) =>-  MockSchemaResult ( 'SchemaObject pairs)+  MockSchemaResult ('SchemaObject pairs)   where   schemaResult _ = UnsafeObject $ Compat.fromList $ mapAll @MockSchemaResultPair @pairs schemaResultPair
src/Data/Aeson/Schema/Internal.hs view
@@ -101,7 +101,7 @@   @since 1.3.0 -}-toMap :: IsSchema ( 'Schema schema) => Object ( 'Schema schema) -> Aeson.Object+toMap :: IsSchema ('Schema schema) => Object ('Schema schema) -> Aeson.Object toMap = toValueMap  {- Type-level schema definitions -}@@ -142,13 +142,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 '[] = '[]@@ -170,32 +170,32 @@   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 = optional . parseValue @inner path -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]))+  HasSchemaResult ('SchemaUnion (schemas :: [SchemaType]))   where-  parseValue path value = parseSumType @schemas path value <|> parseFail @( 'SchemaUnion schemas) path value+  parseValue path value = parseSumType @schemas path value <|> parseFail @('SchemaUnion schemas) path value  class ParseSumType xs where   parseSumType :: [Key] -> Value -> Parser (SumType (SchemaResultList xs))@@ -209,10 +209,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 . Compat.fromList <$> parseValueMap o-    value -> parseFail @( 'SchemaObject pairs) path value+    value -> parseFail @('SchemaObject pairs) path value     where       parseValueMap :: Aeson.Object -> Parser [(Key, Dynamic)]       parseValueMap o = sequence $ mapAll @HasSchemaResultPair @pairs $ \proxy -> parseValuePair proxy path o@@ -231,7 +231,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 = Compat.unions $ mapAll @HasSchemaResultPair @pairs (\proxy -> toValuePair proxy o)  class HasSchemaResultPair (a :: (SchemaKey, SchemaType)) where@@ -262,7 +262,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)@@ -282,15 +282,15 @@ {- 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) =+  LookupSchema key ('Schema schema) =     Fcf.Eval       ( Fcf.FromMaybe           ( TypeError
src/Data/Aeson/Schema/Key.hs view
@@ -93,12 +93,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/Utils.hs view
@@ -150,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@@ -160,18 +160,18 @@      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))|]+  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 -}@@ -199,6 +199,10 @@     AppT ty1 ty2 -> AppT (stripKinds ty1) (stripKinds ty2)     InfixT ty1 name ty2 -> InfixT (stripKinds ty1) name (stripKinds ty2)     UInfixT ty1 name ty2 -> UInfixT (stripKinds ty1) name (stripKinds ty2)+#if MIN_VERSION_template_haskell(2,19,0)+    PromotedInfixT ty1 name ty2 -> PromotedInfixT (stripKinds ty1) name (stripKinds ty2)+    PromotedUInfixT ty1 name ty2 -> PromotedUInfixT (stripKinds ty1) name (stripKinds ty2)+#endif     ParensT ty1 -> ParensT (stripKinds ty1)     ImplicitParamT str ty1 -> ImplicitParamT str (stripKinds ty1)
src/Data/Aeson/Schema/Type.hs view
@@ -136,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)@@ -150,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
test/TestUtils.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}@@ -19,6 +20,7 @@   testGolden,   testGoldenIO,   testParseError,+  testIntegration, ) where  import Data.Aeson (FromJSON (..), Value, eitherDecode)@@ -33,6 +35,10 @@ import Data.Typeable (Typeable, typeRep) import Language.Haskell.TH (ExpQ) import Language.Haskell.TH.Quote (QuasiQuoter (..))+import System.Directory (findExecutable)+import System.FilePath ((</>))+import System.IO.Unsafe (unsafePerformIO)+import System.Process (readProcess) import Test.Tasty (TestTree) import Test.Tasty.Golden (goldenVsString) import Test.Tasty.Golden.Advanced (goldenTest)@@ -104,3 +110,28 @@           then Nothing           else Just $ "Test output was different from '" ++ goldenFile ++ "'. It was:\n" ++ Text.unpack actual     update = Text.writeFile goldenFile++-- | A golden test for integration tests calling GHC.+testIntegration :: String -> FilePath -> (FilePath -> IO String) -> TestTree+testIntegration name fp runTest =+  testGoldenIO name ("integration" </> ("ghc-" ++ ghcVersionShort) </> fp) (runTest ghcExe)+  where+    ghcVersionShort =+      case map Text.unpack . Text.splitOn "." . Text.pack $ ghcVersion of+        [x, y, _] -> x ++ "." ++ y+        _ -> error $ "Could not parse GHC version: " ++ ghcVersion++{-# NOINLINE ghcExe #-}+ghcExe :: FilePath+ghcExe =+  unsafePerformIO $+    findExecutable "ghc" >>= \case+      Just fp -> pure fp+      Nothing -> error "Could not find GHC executable"++{-# NOINLINE ghcVersion #-}+ghcVersion :: String+ghcVersion =+  unsafePerformIO $+    Text.unpack . Text.strip . Text.pack+      <$> readProcess ghcExe ["--numeric-version"] ""
test/TestUtils/Arbitrary.hs view
@@ -118,14 +118,14 @@  genSchema' ::   forall schema.-  ( ArbitrarySchema ( 'SchemaObject schema)-  , IsSchema ( 'Schema schema)+  ( ArbitrarySchema ('SchemaObject schema)+  , IsSchema ('Schema schema)   ) =>-  Proxy (Object ( '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@@ -185,20 +185,20 @@ 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+instance ArbitrarySchema inner => ArbitrarySchema ('SchemaMaybe inner) where   genSchema =     frequency       [ (3, genSchema @inner)       , (1, pure Null)       ] -instance ArbitrarySchema inner => ArbitrarySchema ( 'SchemaTry inner) where+instance ArbitrarySchema inner => ArbitrarySchema ('SchemaTry inner) where   genSchema =     frequency       [ (3, genSchema @inner)@@ -213,16 +213,16 @@           , 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 . Compat.unions <$> genSchemaPairs     where       genSchemaPairs :: Gen [Aeson.Object]@@ -253,10 +253,10 @@ -- we generate 'Null', because Try on a non-object schema will always be an invalid parse. instance   {-# OVERLAPS #-}-  (KnownSymbol key, ArbitrarySchema ( 'SchemaTry inner)) =>+  (KnownSymbol key, ArbitrarySchema ('SchemaTry inner)) =>   ArbitraryObjectPair '( 'PhantomKey key, 'SchemaTry inner)   where-  genInnerSchema = castNull <$> genSchema @( 'SchemaTry inner)+  genInnerSchema = castNull <$> genSchema @('SchemaTry inner)     where       castNull inner =         case inner of@@ -266,10 +266,10 @@ -- 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)) =>+  (KnownSymbol key, FilterObjectSchemas schemas ~ objectSchemas, ArbitrarySchema ('SchemaUnion objectSchemas)) =>   ArbitraryObjectPair '( 'PhantomKey key, 'SchemaUnion schemas)   where-  genInnerSchema = genSchema @( 'SchemaUnion objectSchemas)+  genInnerSchema = genSchema @('SchemaUnion objectSchemas)  {- Generating schema definitions -} @@ -368,5 +368,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/Tests/GetQQ.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-}@@ -17,7 +18,6 @@ import Data.Aeson.QQ (aesonQQ) import Data.Text (Text) import qualified Data.Text as Text-import qualified Language.Haskell.Interpreter as Hint import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck@@ -25,7 +25,12 @@ import Data.Aeson.Schema (Object, schema) import Data.Aeson.Schema.TH (mkEnum) import Data.Aeson.Schema.Utils.Sum (SumType (..))-import TestUtils (parseObject, testGoldenIO, testParseError)+import System.Directory (copyFile, createDirectoryIfMissing, withCurrentDirectory)+import System.Exit (ExitCode (..))+import System.FilePath (takeDirectory, (</>))+import System.IO.Temp (withSystemTempDirectory)+import System.Process (readProcessWithExitCode)+import TestUtils (parseObject, testIntegration, testParseError) import Tests.GetQQ.TH  mkEnum "Greeting" ["HELLO", "GOODBYE"]@@ -390,18 +395,34 @@  testCompileTimeErrors :: TestTree testCompileTimeErrors =-  testGroup-    "Compile-time errors"-    [ testGoldenIO "Key not in schema" "getqq_missing_key.golden" $-        getCompileError "GetMissingKey"+  testGroup "Compile-time errors" . map mkIntegrationTest $+    [ testIntegration "Key not in schema" "getqq_missing_key.golden" $ \ghcExe ->+        getCompileError ghcExe "GetMissingKey.hs"     ]   where-    getCompileError name = do-      let fp = "test/wont-compile/" ++ name ++ ".hs"-      Hint.runInterpreter (Hint.loadModules [fp]) >>= \case-        Left (Hint.WontCompile errors) -> return $ unlines $ map Hint.errMsg errors-        Left e -> fail $ show e-        Right _ -> fail "Compilation unexpectedly succeeded"+    testDir = "test/wont-compile/"+    getCompileError ghcExe file =+      withSystemTempDirectory "aeson-schemas-integration-tests" $ \tmpdir -> do+        let fp = tmpdir </> testDir </> file+        createDirectoryIfMissing True (takeDirectory fp)+        copyFile (testDir </> file) fp+        withCurrentDirectory tmpdir $+          readProcessWithExitCode ghcExe [fp] "" >>= \case+            (ExitFailure{}, _, stderr) ->+              return . Text.unpack . Text.replace (Text.pack tmpdir) "" . Text.pack $ stderr+            (ExitSuccess, stdout, stderr) ->+              error . unlines $+                [ "Compilation unexpectedly succeeded"+                , stdout+                , stderr+                ]++mkIntegrationTest :: TestTree -> TestTree+#ifdef RUN_INTEGRATION_TESTS+mkIntegrationTest = id+#else+mkIntegrationTest _ = testGroup "integration test" []+#endif  {- Helpers -}
− test/goldens/getqq_missing_key.golden 
@@ -1,12 +0,0 @@-test/wont-compile/GetMissingKey.hs:16:1: error:-    • Key 'missing' does not exist in the following schema:-      '[ '( 'Data.Aeson.Schema.Key.NormalKey "foo",-            'Data.Aeson.Schema.Type.SchemaScalar Bool)]-    • When checking the inferred type-        result :: Data.Aeson.Schema.Internal.SchemaResult (TypeError ...)-test/wont-compile/GetMissingKey.hs:16:1: error:-    • Key 'missing' does not exist in the following schema:-      '[ '( 'Data.Aeson.Schema.Key.NormalKey "foo",-            'Data.Aeson.Schema.Type.SchemaScalar Bool)]-    • When checking the inferred type-        result :: Data.Aeson.Schema.Internal.SchemaResult (TypeError ...)
+ test/goldens/integration/ghc-8.10/getqq_missing_key.golden view
@@ -0,0 +1,10 @@++/test/wont-compile/GetMissingKey.hs:17:1: error:+    • Key 'missing' does not exist in the following schema:+      '[ '( 'Data.Aeson.Schema.Key.NormalKey "foo",+            'Data.Aeson.Schema.Type.SchemaScalar Bool)]+    • When checking the inferred type+        result :: Data.Aeson.Schema.Internal.SchemaResult (TypeError ...)+   |+17 | result = [get| o.missing |]+   | ^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ test/goldens/integration/ghc-9.0/getqq_missing_key.golden view
@@ -0,0 +1,10 @@++/test/wont-compile/GetMissingKey.hs:17:1: error:+    • Key 'missing' does not exist in the following schema:+      '[ '( 'Data.Aeson.Schema.Key.NormalKey "foo",+            'Data.Aeson.Schema.Type.SchemaScalar Bool)]+    • When checking the inferred type+        result :: Data.Aeson.Schema.Internal.SchemaResult (TypeError ...)+   |+17 | result = [get| o.missing |]+   | ^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ test/goldens/integration/ghc-9.2/getqq_missing_key.golden view
@@ -0,0 +1,10 @@++/test/wont-compile/GetMissingKey.hs:17:1: error:+    • Key 'missing' does not exist in the following schema:+      '[ '( 'Data.Aeson.Schema.Key.NormalKey "foo",+            'Data.Aeson.Schema.Type.SchemaScalar Bool)]+    • When checking the inferred type+        result :: Data.Aeson.Schema.Internal.SchemaResult (TypeError ...)+   |+17 | result = [get| o.missing |]+   | ^^^^^^^^^^^^^^^^^^^^^^^^^^^
+ test/goldens/integration/ghc-9.4/getqq_missing_key.golden view
@@ -0,0 +1,44 @@++/test/wont-compile/GetMissingKey.hs:17:15: error:+    • Key 'missing' does not exist in the following schema:+      '[ '( 'Data.Aeson.Schema.Key.NormalKey "foo",+            'Data.Aeson.Schema.Type.SchemaScalar Bool)]+    • In the second argument of ‘(.)’, namely+        ‘Data.Aeson.Schema.Internal.getKey+           (Data.Proxy.Proxy :: Data.Proxy.Proxy "missing")’+      In the expression:+        (id+           . Data.Aeson.Schema.Internal.getKey+               (Data.Proxy.Proxy :: Data.Proxy.Proxy "missing"))+          o+      In an equation for ‘result’:+          result+            = ((id+                  . Data.Aeson.Schema.Internal.getKey+                      (Data.Proxy.Proxy :: Data.Proxy.Proxy "missing"))+                 o)+   |+17 | result = [get| o.missing |]+   |               ^^^^^^^^^^^^^++/test/wont-compile/GetMissingKey.hs:17:15: error:+    • Key 'missing' does not exist in the following schema:+      '[ '( 'Data.Aeson.Schema.Key.NormalKey "foo",+            'Data.Aeson.Schema.Type.SchemaScalar Bool)]+    • In the second argument of ‘(.)’, namely+        ‘Data.Aeson.Schema.Internal.getKey+           (Data.Proxy.Proxy :: Data.Proxy.Proxy "missing")’+      In the expression:+        (id+           . Data.Aeson.Schema.Internal.getKey+               (Data.Proxy.Proxy :: Data.Proxy.Proxy "missing"))+          o+      In an equation for ‘result’:+          result+            = ((id+                  . Data.Aeson.Schema.Internal.getKey+                      (Data.Proxy.Proxy :: Data.Proxy.Proxy "missing"))+                 o)+   |+17 | result = [get| o.missing |]+   |               ^^^^^^^^^^^^^
test/wont-compile/GetMissingKey.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -14,3 +15,6 @@  result :: _ result = [get| o.missing |]++main :: IO ()+main = pure ()