diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,34 +1,37 @@ -## Upcoming +# v1.4.0.0 -## 1.3.5.1 +* Drop support for GHC < 8.10 +* Drop support for megaparsec < 7 +# v1.3.5.1 + * Fix benchmarks for `aeson-2` -## 1.3.5 +# v1.3.5 * Support `aeson-2.0.0.0` -## 1.3.4 +# v1.3.4 * Support `template-haskell-2.17.0.0` for GHC 9 -## 1.3.3 +# v1.3.3 * Fix test failure in newer Stack snapshots -## 1.3.2 +# v1.3.2 Performance: * Optimized including other schemas in a schema, which previously caused a huge slowdown, and possibly even out-of-memory errors. -## 1.3.1 +# v1.3.1 Bug fixes: * Update extra-source-files with files needed for testing -## 1.3.0 +# v1.3.0 Breaking changes: @@ -66,33 +69,33 @@ * The `Show` instance for objects added some whitespace, from `{"foo": 0}` to `{ "foo": 0 }` -## 1.2.0 +# v1.2.0 New features: * Add support for phantom keys * Add support for `Try` schemas -## 1.1.0 +# v1.1.0 New features: * Added support for unions * Added `ToJSON` instance for enums generated with `mkEnum` -## 1.0.3 +# v1.0.3 Support GHC 8.8 -## 1.0.2 +# v1.0.2 Bundle test data files in release tarball -## 1.0.1 +# v1.0.1 Add support with `first-class-families-0.6.0.0` -## 1.0.0 +# v1.0.0 Initial release: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,8 +1,8 @@ # aeson-schemas -![CircleCI](https://img.shields.io/hackage/v/aeson-schemas) -![Hackage](https://img.shields.io/circleci/build/github/LeapYear/aeson-schemas) -[![codecov](https://codecov.io/gh/LeapYear/aeson-schemas/branch/master/graph/badge.svg)](https://codecov.io/gh/LeapYear/aeson-schemas) +[![GitHub Actions](https://img.shields.io/github/workflow/status/LeapYear/aeson-schemas/CI/main)](https://github.com/LeapYear/aeson-schemas/actions?query=branch%3Amain) +[![codecov](https://codecov.io/gh/LeapYear/aeson-schemas/branch/main/graph/badge.svg)](https://codecov.io/gh/LeapYear/aeson-schemas) +[![Hackage](https://img.shields.io/hackage/v/aeson-schemas)](https://hackage.haskell.org/package/aeson-schemas) A library that extracts information from JSON input using type-level schemas and quasiquoters, consuming JSON data in a type-safe manner. Better than diff --git a/aeson-schemas.cabal b/aeson-schemas.cabal --- a/aeson-schemas.cabal +++ b/aeson-schemas.cabal @@ -1,11 +1,11 @@ cabal-version: >= 1.10 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack name: aeson-schemas -version: 1.3.5.1 +version: 1.4.0.0 synopsis: Easily consume JSON data on-demand with type-safety description: Parse JSON data easily and safely without defining new data types. Useful for deeply nested JSON data, which is difficult to parse using the default @@ -21,6 +21,7 @@ extra-source-files: README.md CHANGELOG.md + examples/input.json test/goldens/fromjson_error_messages_truncate.golden test/goldens/fromjson_list_inner_invalid.golden test/goldens/fromjson_list_invalid.golden @@ -75,19 +76,19 @@ src ghc-options: -Wall build-depends: - aeson >=1.1.2.0 && <2.1 - , base >=4.9 && <5 + aeson >=1.1.2.0 && <3 + , base >=4.14 && <5 , first-class-families >=0.3.0.0 && <0.9 , hashable >=1.2.7.0 && <1.5 - , megaparsec >=6.0.0 && <10 - , template-haskell >=2.12.0.0 && <2.19 + , megaparsec >=7 && <10 + , template-haskell >=2.16 && <2.19 , text >=1.2.2.2 && <1.3 , 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 - default-language: Haskell2010 test-suite aeson-schemas-test type: exitcode-stdio-1.0 @@ -104,6 +105,7 @@ Tests.Object.Show Tests.Object.Show.TH Tests.Object.ToJSON + Tests.Quickstart Tests.SchemaQQ Tests.SchemaQQ.TH Tests.SumType @@ -118,31 +120,34 @@ ghc-options: -Wall build-depends: QuickCheck - , aeson >=1.1.2.0 && <2.1 + , aeson >=1.1.2.0 && <3 , aeson-qq , aeson-schemas - , base >=4.9 && <5 + , base >=4.14 && <5 , deepseq + , filepath , first-class-families >=0.3.0.0 && <0.9 , hashable >=1.2.7.0 && <1.5 , hint , interpolate - , megaparsec >=6.0.0 && <10 + , megaparsec >=7 && <10 + , process , raw-strings-qq , tasty , tasty-golden , tasty-hunit , tasty-quickcheck - , template-haskell >=2.12.0.0 && <2.19 + , template-haskell >=2.16 && <2.19 + , temporary , text >=1.2.2.2 && <1.3 , 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 - default-language: Haskell2010 benchmark aeson-schemas-bench type: exitcode-stdio-1.0 @@ -161,20 +166,20 @@ bench ghc-options: -Wall build-depends: - aeson >=1.1.2.0 && <2.1 + aeson >=1.1.2.0 && <3 , aeson-schemas - , base >=4.9 && <5 + , base >=4.14 && <5 , criterion , deepseq , first-class-families >=0.3.0.0 && <0.9 , hashable >=1.2.7.0 && <1.5 - , megaparsec >=6.0.0 && <10 - , template-haskell >=2.12.0.0 && <2.19 + , megaparsec >=7 && <10 + , template-haskell >=2.16 && <2.19 , text >=1.2.2.2 && <1.3 , 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 - default-language: Haskell2010 diff --git a/bench/Utils/DeepSeq.hs b/bench/Utils/DeepSeq.hs --- a/bench/Utils/DeepSeq.hs +++ b/bench/Utils/DeepSeq.hs @@ -3,12 +3,8 @@ module Utils.DeepSeq () where -import Control.DeepSeq (NFData (..)) - -#if MIN_VERSION_template_haskell(2,16,0) -import Control.DeepSeq (rwhnf) +import Control.DeepSeq (NFData (..), rwhnf) import GHC.ForeignPtr (ForeignPtr) -#endif import Language.Haskell.TH.Syntax instance NFData AnnTarget @@ -66,9 +62,7 @@ instance NFData TyVarBndr #endif -#if MIN_VERSION_template_haskell(2,16,0) instance NFData Bytes instance NFData (ForeignPtr a) where rnf = rwhnf -#endif diff --git a/examples/input.json b/examples/input.json new file mode 100644 --- /dev/null +++ b/examples/input.json @@ -0,0 +1,47 @@ +{ + "users": [ + { + "id": 1, + "name": "Alice", + "age": 30, + "enabled": true, + "groups": [ + { + "id": 1, + "name": "admin" + } + ] + }, + { + "id": 2, + "name": "Bob", + "age": null, + "enabled": false, + "groups": null + }, + { + "id": 3, + "name": "Charlie", + "age": 25, + "enabled": true, + "groups": [ + ] + }, + { + "id": 4, + "name": "Darlene", + "age": 40, + "enabled": true, + "groups": [ + { + "id": 2, + "name": "groupA" + }, + { + "id": 3, + "name": "groupB" + } + ] + } + ] +} 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 @@ -1,5 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} @@ -75,10 +74,6 @@ import qualified Data.Aeson.Schema.Utils.Compat as Compat import Data.Aeson.Schema.Utils.Invariant (unreachable) import Data.Aeson.Schema.Utils.Sum (SumType (..)) - -#if !MIN_VERSION_base(4,13,0) -import Control.Monad.Fail (MonadFail) -#endif {- Schema-validated JSON object -} 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 @@ -1,5 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveLift #-} diff --git a/src/Data/Aeson/Schema/TH/Getter.hs b/src/Data/Aeson/Schema/TH/Getter.hs --- a/src/Data/Aeson/Schema/TH/Getter.hs +++ b/src/Data/Aeson/Schema/TH/Getter.hs @@ -83,7 +83,8 @@ mkGetter unwrapName funcName startSchemaName ops = do getterExp@GetterExp{..} <- parseGetterExp ops unless (isNothing start) $ - fail $ "Getter expression should start with '.': " ++ ops + fail $ + "Getter expression should start with '.': " ++ ops startSchema <- lookupSchema (NameTH startSchemaName) >>= loadSchema diff --git a/src/Data/Aeson/Schema/TH/Parse.hs b/src/Data/Aeson/Schema/TH/Parse.hs --- a/src/Data/Aeson/Schema/TH/Parse.hs +++ b/src/Data/Aeson/Schema/TH/Parse.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE RecordWildCards #-} @@ -14,9 +13,6 @@ import Control.Monad (MonadPlus, void) -#if !MIN_VERSION_base(4,13,0) -import Control.Monad.Fail (MonadFail) -#endif import Data.Functor (($>)) import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty) @@ -29,11 +25,6 @@ type Parser = Parsec Void String -#if !MIN_VERSION_megaparsec(7,0,0) -errorBundlePretty :: (Ord t, ShowToken t, ShowErrorComponent e) => ParseError t e -> String -errorBundlePretty = parseErrorPretty -#endif - runParserFail :: MonadFail m => Parser a -> String -> m a runParserFail parser s = either (fail . errorBundlePretty) return $ runParser parser s s @@ -214,7 +205,7 @@ fmap NonEmpty.toList $ some $ choice - [ try $ char '\\' *> anySingle' + [ try $ char '\\' *> anySingle , noneOf $ [' ', '\\', '"'] ++ schemaChars ++ getChars ] where @@ -222,13 +213,6 @@ getChars = "!?[](),.@" -- characters that should not indicate the start of a key when parsing 'schema' definitions schemaChars = ":{}#" - -anySingle' :: Parser Char -#if MIN_VERSION_megaparsec(7,0,0) -anySingle' = anySingle -#else -anySingle' = anyChar -#endif {- Parsing utilities -} diff --git a/src/Data/Aeson/Schema/TH/Schema.hs b/src/Data/Aeson/Schema/TH/Schema.hs --- a/src/Data/Aeson/Schema/TH/Schema.hs +++ b/src/Data/Aeson/Schema/TH/Schema.hs @@ -140,7 +140,8 @@ case schemaKey of PhantomKey _ -> unless (isValidPhantomSchema schemaType) $ - fail $ "Invalid schema for '" ++ fromSchemaKeyV schemaKey ++ "': " ++ showSchemaTypeV schemaType + fail $ + "Invalid schema for '" ++ fromSchemaKeyV schemaKey ++ "': " ++ showSchemaTypeV schemaType _ -> return () return ([(schemaKey, schemaType)], Provided) 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 @@ -69,14 +69,14 @@ TyConI (TySynD _ _ (stripKinds -> ty)) -- `type MySchema = 'Schema '[ ... ]` | isPromotedSchema ty -> - return ty + return ty -- `type MySchema = Object ('Schema '[ ... ])` | Just inner <- unwrapObject ty - , isPromotedSchema inner -> - return inner + , isPromotedSchema inner -> + return inner -- `type MySchema = Object OtherSchema` | Just (ConT schemaName') <- unwrapObject ty -> - reifySchemaType schemaName' + reifySchemaType schemaName' _ -> fail $ "'" ++ show schemaName ++ "' is not a Schema" -- If the given type is of the format `Object a`, return `a`. @@ -131,13 +131,13 @@ | name == 'SchemaTry -> SchemaTry <$> parseSchemaType inner | name == 'SchemaList -> SchemaList <$> parseSchemaType inner | name == 'SchemaUnion -> do - schemas <- typeToList inner - SchemaUnion <$> mapM parseSchemaType schemas + 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) @@ -191,22 +191,16 @@ case ty of -- cases that strip + recurse SigT ty1 _ -> stripKinds ty1 -#if MIN_VERSION_template_haskell(2,15,0) AppKindT ty1 _ -> stripKinds ty1 -#endif -- cases that recurse ForallT tyVars ctx ty1 -> ForallT tyVars ctx (stripKinds ty1) -#if MIN_VERSION_template_haskell(2,16,0) ForallVisT tyVars ty1 -> ForallVisT tyVars (stripKinds ty1) -#endif AppT ty1 ty2 -> AppT (stripKinds ty1) (stripKinds ty2) InfixT ty1 name ty2 -> InfixT (stripKinds ty1) name (stripKinds ty2) UInfixT ty1 name ty2 -> UInfixT (stripKinds ty1) name (stripKinds ty2) ParensT ty1 -> ParensT (stripKinds ty1) -#if MIN_VERSION_template_haskell(2,15,0) ImplicitParamT str ty1 -> ImplicitParamT str (stripKinds ty1) -#endif -- base cases VarT _ -> ty diff --git a/src/Data/Aeson/Schema/Utils/NameLike.hs b/src/Data/Aeson/Schema/Utils/NameLike.hs --- a/src/Data/Aeson/Schema/Utils/NameLike.hs +++ b/src/Data/Aeson/Schema/Utils/NameLike.hs @@ -1,5 +1,5 @@ {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskellQuotes #-} module Data.Aeson.Schema.Utils.NameLike ( NameLike (..), diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -4,6 +4,7 @@ import qualified Tests.GetQQ import qualified Tests.MkGetter import qualified Tests.Object +import qualified Tests.Quickstart import qualified Tests.SchemaQQ import qualified Tests.SumType import qualified Tests.UnwrapQQ @@ -20,4 +21,5 @@ , Tests.MkGetter.test , Tests.EnumTH.test , Tests.SumType.test + , Tests.Quickstart.test ] diff --git a/test/TestUtils.hs b/test/TestUtils.hs --- a/test/TestUtils.hs +++ b/test/TestUtils.hs @@ -1,5 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -25,9 +24,6 @@ import Data.Aeson (FromJSON (..), Value, eitherDecode) import Data.Aeson.Types (parseEither) -#if !MIN_VERSION_megaparsec(7,0,0) -import Data.Char (isDigit, isSpace) -#endif import Data.Proxy (Proxy (..)) import Data.String (fromString) import qualified Data.Text as Text @@ -100,7 +96,7 @@ testParseError name fp s = goldenTest name getExpected getActual cmp update where goldenFile = "test/goldens/" ++ fp - getExpected = sanitize <$> Text.readFile goldenFile + getExpected = Text.readFile goldenFile getActual = return $ Text.pack s cmp expected actual = return $ @@ -108,24 +104,3 @@ then Nothing else Just $ "Test output was different from '" ++ goldenFile ++ "'. It was:\n" ++ Text.unpack actual update = Text.writeFile goldenFile - -#if MIN_VERSION_megaparsec(7,0,0) - sanitize = id -#else - -- megaparsec before version 7.0.0 doesn't display the offending lines, so we need to strip - -- out those lines from the golden before comparing them. - -- - -- e.g. - -- - -- { "a:b": Int } :1:6: - -- > | - -- > 1 | { "a:b": Int } - -- > | ^ - -- unexpected ':' - -- expecting '"' or '\' - sanitize = Text.unlines . filter (not . isOffendingLine) . Text.lines - - isOffendingLine line = case Text.splitOn "|" line of - [prefix, _] -> Text.all (\c -> isDigit c || isSpace c) prefix - _ -> False -#endif diff --git a/test/TestUtils/Arbitrary.hs b/test/TestUtils/Arbitrary.hs --- a/test/TestUtils/Arbitrary.hs +++ b/test/TestUtils/Arbitrary.hs @@ -1,5 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -105,10 +104,10 @@ 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] $ + tabulate "Key types" (map getKeyType $ getKeys schemaType) $ + tabulate "Schema types" (getSchemaTypes schemaType) $ + tabulate "Object sizes" (map show $ getObjectSizes schemaType) $ + tabulate "Object depth" [show $ getObjectDepth schemaType] $ runTest o {- Run time helpers -} @@ -180,14 +179,6 @@ SchemaUnion schemas -> maximum $ map getObjectDepth' schemas SchemaObject pairs -> 1 + maximum (map (getObjectDepth' . snd) pairs) 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 -tabulate' _ _ = id -#endif {- Generating schemas -} diff --git a/test/TestUtils/DeepSeq.hs b/test/TestUtils/DeepSeq.hs --- a/test/TestUtils/DeepSeq.hs +++ b/test/TestUtils/DeepSeq.hs @@ -3,12 +3,8 @@ module TestUtils.DeepSeq () where -import Control.DeepSeq (NFData (..)) - -#if MIN_VERSION_template_haskell(2,16,0) -import Control.DeepSeq (rwhnf) +import Control.DeepSeq (NFData (..), rwhnf) import GHC.ForeignPtr (ForeignPtr) -#endif import Language.Haskell.TH.Syntax instance NFData AnnTarget @@ -66,9 +62,7 @@ instance NFData TyVarBndr #endif -#if MIN_VERSION_template_haskell(2,16,0) instance NFData Bytes instance NFData (ForeignPtr a) where rnf = rwhnf -#endif diff --git a/test/Tests/GetQQ.hs b/test/Tests/GetQQ.hs --- a/test/Tests/GetQQ.hs +++ b/test/Tests/GetQQ.hs @@ -217,7 +217,8 @@ testGroup "fromJust errors" [ testCase "Plain fromJust" $ - assertError "Called 'fromJust' on null expression" $ [runGet| ! |] (Nothing :: Maybe Int) + assertError "Called 'fromJust' on null expression" $ + [runGet| ! |] (Nothing :: Maybe Int) , testCase "With start" $ do let o = $(parseObject "{ foo: Maybe Bool }") [aesonQQ| { "foo": null } |] assertError diff --git a/test/Tests/MkGetter.hs b/test/Tests/MkGetter.hs --- a/test/Tests/MkGetter.hs +++ b/test/Tests/MkGetter.hs @@ -31,8 +31,8 @@ test :: TestTree test = - runMkGetterQ - `deepseq` testGroup + runMkGetterQ `deepseq` + testGroup "`mkGetter` helper" [ testCase "Type synonym is generated" $ showSchemaResult @User @?= [r|Object (SchemaObject { "name": Text })|] diff --git a/test/Tests/Quickstart.hs b/test/Tests/Quickstart.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Quickstart.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Tests.Quickstart (test) where + +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import System.Process (readProcess) +import Test.Tasty (TestTree) + +import TestUtils (testGoldenIO) + +test :: TestTree +test = testGoldenIO "README Quickstart works" "README_Quickstart.golden" $ + withSystemTempDirectory "readme-quickstart" $ \tmpdir -> do + let testfile = tmpdir "readme_quickstart.hs" + readme <- Text.readFile "README.md" + Text.writeFile testfile (getQuickstartCode readme) + readProcess "runghc" [testfile] "" + +getQuickstartCode :: Text -> Text +getQuickstartCode = Text.unlines . getQuickstartLines . Text.lines + where + getQuickstartLines readmeLines = + fromMaybe (error "Could not find Quickstart in README") $ + between (== "## Quickstart") ("## " `Text.isPrefixOf`) readmeLines + >>= between (== "```haskell") (== "```") + + between start end xs = + case dropWhile (not . start) xs of + [] -> Nothing + _ : afterStart -> Just $ takeWhile (not . end) afterStart