diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +# v1.4.0.1 + +* Add support for GHC 9.4 + # v1.4.0.0 * Drop support for GHC < 8.10 diff --git a/aeson-schemas.cabal b/aeson-schemas.cabal --- a/aeson-schemas.cabal +++ b/aeson-schemas.cabal @@ -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 diff --git a/bench/Benchmarks/Data/Objects.hs b/bench/Benchmarks/Data/Objects.hs --- a/bench/Benchmarks/Data/Objects.hs +++ b/bench/Benchmarks/Data/Objects.hs @@ -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 diff --git a/src/Data/Aeson/Schema/Internal.hs b/src/Data/Aeson/Schema/Internal.hs --- a/src/Data/Aeson/Schema/Internal.hs +++ b/src/Data/Aeson/Schema/Internal.hs @@ -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 diff --git a/src/Data/Aeson/Schema/Key.hs b/src/Data/Aeson/Schema/Key.hs --- a/src/Data/Aeson/Schema/Key.hs +++ b/src/Data/Aeson/Schema/Key.hs @@ -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 diff --git a/src/Data/Aeson/Schema/TH/Utils.hs b/src/Data/Aeson/Schema/TH/Utils.hs --- a/src/Data/Aeson/Schema/TH/Utils.hs +++ b/src/Data/Aeson/Schema/TH/Utils.hs @@ -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) diff --git a/src/Data/Aeson/Schema/Type.hs b/src/Data/Aeson/Schema/Type.hs --- a/src/Data/Aeson/Schema/Type.hs +++ b/src/Data/Aeson/Schema/Type.hs @@ -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 diff --git a/test/TestUtils.hs b/test/TestUtils.hs --- a/test/TestUtils.hs +++ b/test/TestUtils.hs @@ -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"] "" diff --git a/test/TestUtils/Arbitrary.hs b/test/TestUtils/Arbitrary.hs --- a/test/TestUtils/Arbitrary.hs +++ b/test/TestUtils/Arbitrary.hs @@ -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 diff --git a/test/Tests/GetQQ.hs b/test/Tests/GetQQ.hs --- a/test/Tests/GetQQ.hs +++ b/test/Tests/GetQQ.hs @@ -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 -} diff --git a/test/goldens/getqq_missing_key.golden b/test/goldens/getqq_missing_key.golden deleted file mode 100644 --- a/test/goldens/getqq_missing_key.golden +++ /dev/null @@ -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 ...) diff --git a/test/goldens/integration/ghc-8.10/getqq_missing_key.golden b/test/goldens/integration/ghc-8.10/getqq_missing_key.golden new file mode 100644 --- /dev/null +++ b/test/goldens/integration/ghc-8.10/getqq_missing_key.golden @@ -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 |] + | ^^^^^^^^^^^^^^^^^^^^^^^^^^^ diff --git a/test/goldens/integration/ghc-9.0/getqq_missing_key.golden b/test/goldens/integration/ghc-9.0/getqq_missing_key.golden new file mode 100644 --- /dev/null +++ b/test/goldens/integration/ghc-9.0/getqq_missing_key.golden @@ -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 |] + | ^^^^^^^^^^^^^^^^^^^^^^^^^^^ diff --git a/test/goldens/integration/ghc-9.2/getqq_missing_key.golden b/test/goldens/integration/ghc-9.2/getqq_missing_key.golden new file mode 100644 --- /dev/null +++ b/test/goldens/integration/ghc-9.2/getqq_missing_key.golden @@ -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 |] + | ^^^^^^^^^^^^^^^^^^^^^^^^^^^ diff --git a/test/goldens/integration/ghc-9.4/getqq_missing_key.golden b/test/goldens/integration/ghc-9.4/getqq_missing_key.golden new file mode 100644 --- /dev/null +++ b/test/goldens/integration/ghc-9.4/getqq_missing_key.golden @@ -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 |] + | ^^^^^^^^^^^^^ diff --git a/test/wont-compile/GetMissingKey.hs b/test/wont-compile/GetMissingKey.hs --- a/test/wont-compile/GetMissingKey.hs +++ b/test/wont-compile/GetMissingKey.hs @@ -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 ()