diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/aeson-schemas.cabal b/aeson-schemas.cabal --- a/aeson-schemas.cabal +++ b/aeson-schemas.cabal @@ -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 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 @@ -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 diff --git a/bench/Benchmarks/Data/Schemas.hs b/bench/Benchmarks/Data/Schemas.hs --- a/bench/Benchmarks/Data/Schemas.hs +++ b/bench/Benchmarks/Data/Schemas.hs @@ -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)) + |] + ] + ) diff --git a/bench/Benchmarks/Data/Schemas/TH.hs b/bench/Benchmarks/Data/Schemas/TH.hs --- a/bench/Benchmarks/Data/Schemas/TH.hs +++ b/bench/Benchmarks/Data/Schemas/TH.hs @@ -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 diff --git a/bench/Benchmarks/FromJSON.hs b/bench/Benchmarks/FromJSON.hs --- a/bench/Benchmarks/FromJSON.hs +++ b/bench/Benchmarks/FromJSON.hs @@ -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 -} diff --git a/bench/Benchmarks/SchemaQQ.hs b/bench/Benchmarks/SchemaQQ.hs --- a/bench/Benchmarks/SchemaQQ.hs +++ b/bench/Benchmarks/SchemaQQ.hs @@ -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 diff --git a/bench/Benchmarks/Show.hs b/bench/Benchmarks/Show.hs --- a/bench/Benchmarks/Show.hs +++ b/bench/Benchmarks/Show.hs @@ -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) + ] diff --git a/bench/Benchmarks/ToJSON.hs b/bench/Benchmarks/ToJSON.hs --- a/bench/Benchmarks/ToJSON.hs +++ b/bench/Benchmarks/ToJSON.hs @@ -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) + ] diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -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 + ] diff --git a/bench/Utils/DeepSeq.hs b/bench/Utils/DeepSeq.hs --- a/bench/Utils/DeepSeq.hs +++ b/bench/Utils/DeepSeq.hs @@ -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 diff --git a/src/Data/Aeson/Schema.hs b/src/Data/Aeson/Schema.hs --- a/src/Data/Aeson/Schema.hs +++ b/src/Data/Aeson/Schema.hs @@ -1,4 +1,4 @@ -{-| +{- | Module : Data.Aeson.Schema Maintainer : Brandon Chinn 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 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,11 +1,3 @@ -{-| -Module : Data.Aeson.Schema.Internal -Maintainer : Brandon Chinn -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 +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) 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,11 +1,3 @@ -{-| -Module : Data.Aeson.Schema.Key -Maintainer : Brandon Chinn -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 +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 diff --git a/src/Data/Aeson/Schema/TH.hs b/src/Data/Aeson/Schema/TH.hs --- a/src/Data/Aeson/Schema/TH.hs +++ b/src/Data/Aeson/Schema/TH.hs @@ -1,4 +1,4 @@ -{-| +{- | Module : Data.Aeson.Schema.TH Maintainer : Brandon Chinn 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 diff --git a/src/Data/Aeson/Schema/TH/Enum.hs b/src/Data/Aeson/Schema/TH/Enum.hs --- a/src/Data/Aeson/Schema/TH/Enum.hs +++ b/src/Data/Aeson/Schema/TH/Enum.hs @@ -1,4 +1,7 @@ -{-| +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TemplateHaskell #-} + +{- | Module : Data.Aeson.Schema.TH.Enum Maintainer : Brandon Chinn 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)|]) [] diff --git a/src/Data/Aeson/Schema/TH/Get.hs b/src/Data/Aeson/Schema/TH/Get.hs --- a/src/Data/Aeson/Schema/TH/Get.hs +++ b/src/Data/Aeson/Schema/TH/Get.hs @@ -1,4 +1,9 @@ -{-| +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +{- | Module : Data.Aeson.Schema.TH.Get Maintainer : Brandon Chinn 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 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 @@ -1,4 +1,7 @@ -{-| +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +{- | Module : Data.Aeson.Schema.TH.Getter Maintainer : Brandon Chinn 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) []] ] 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,8 @@ -{-| +{-# LANGUAGE CPP #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE RecordWildCards #-} + +{- | Module : Data.Aeson.Schema.TH.Parse Maintainer : Brandon Chinn 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 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 @@ -1,110 +1,118 @@ -{-| -Module : Data.Aeson.Schema.TH.Schema -Maintainer : Brandon Chinn -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 +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: \, ... }@ 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 \@ and @List \@ correspond to @Maybe@ and @[]@, containing values --- specified by the provided schema (no parentheses needed). --- --- * @Try \@ corresponds to @Maybe@, where the value will be @Just@ if the given schema --- successfully parses the value, or @Nothing@ otherwise. Different from @Maybe \@, --- 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: --- --- * @\ | \@ 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]: \ }@ 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: \, ... }@ 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 \@ and @List \@ correspond to @Maybe@ and @[]@, containing values + specified by the provided schema (no parentheses needed). + + * @Try \@ corresponds to @Maybe@, where the value will be @Just@ if the given schema + successfully parses the value, or @Nothing@ otherwise. Different from @Maybe \@, + 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: + + * @\ | \@ 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]: \ }@ 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) diff --git a/src/Data/Aeson/Schema/TH/Unwrap.hs b/src/Data/Aeson/Schema/TH/Unwrap.hs --- a/src/Data/Aeson/Schema/TH/Unwrap.hs +++ b/src/Data/Aeson/Schema/TH/Unwrap.hs @@ -1,4 +1,8 @@ -{-| +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +{- | Module : Data.Aeson.Schema.TH.Unwrap Maintainer : Brandon Chinn 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 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 @@ -1,9 +1,3 @@ -{-| -Module : Data.Aeson.Schema.TH.Utils -Maintainer : Brandon Chinn -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 +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)|] 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 @@ -1,11 +1,3 @@ -{-| -Module : Data.Aeson.Schema.Type -Maintainer : Brandon Chinn -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 +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 diff --git a/src/Data/Aeson/Schema/Utils/All.hs b/src/Data/Aeson/Schema/Utils/All.hs --- a/src/Data/Aeson/Schema/Utils/All.hs +++ b/src/Data/Aeson/Schema/Utils/All.hs @@ -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 diff --git a/src/Data/Aeson/Schema/Utils/Invariant.hs b/src/Data/Aeson/Schema/Utils/Invariant.hs --- a/src/Data/Aeson/Schema/Utils/Invariant.hs +++ b/src/Data/Aeson/Schema/Utils/Invariant.hs @@ -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/" + ] 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,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 diff --git a/src/Data/Aeson/Schema/Utils/Sum.hs b/src/Data/Aeson/Schema/Utils/Sum.hs --- a/src/Data/Aeson/Schema/Utils/Sum.hs +++ b/src/Data/Aeson/Schema/Utils/Sum.hs @@ -1,12 +1,3 @@ -{-| -Module : Data.Aeson.Schema.Utils.Sum -Maintainer : Brandon Chinn -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 +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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 + ] diff --git a/test/TestUtils.hs b/test/TestUtils.hs --- a/test/TestUtils.hs +++ b/test/TestUtils.hs @@ -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) diff --git a/test/TestUtils/Arbitrary.hs b/test/TestUtils/Arbitrary.hs --- a/test/TestUtils/Arbitrary.hs +++ b/test/TestUtils/Arbitrary.hs @@ -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 diff --git a/test/TestUtils/DeepSeq.hs b/test/TestUtils/DeepSeq.hs --- a/test/TestUtils/DeepSeq.hs +++ b/test/TestUtils/DeepSeq.hs @@ -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 diff --git a/test/Tests/EnumTH.hs b/test/Tests/EnumTH.hs --- a/test/Tests/EnumTH.hs +++ b/test/Tests/EnumTH.hs @@ -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 diff --git a/test/Tests/GetQQ.hs b/test/Tests/GetQQ.hs --- a/test/Tests/GetQQ.hs +++ b/test/Tests/GetQQ.hs @@ -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" diff --git a/test/Tests/GetQQ/TH.hs b/test/Tests/GetQQ/TH.hs --- a/test/Tests/GetQQ/TH.hs +++ b/test/Tests/GetQQ/TH.hs @@ -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)|] diff --git a/test/Tests/MkGetter.hs b/test/Tests/MkGetter.hs --- a/test/Tests/MkGetter.hs +++ b/test/Tests/MkGetter.hs @@ -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" }, diff --git a/test/Tests/Object.hs b/test/Tests/Object.hs --- a/test/Tests/Object.hs +++ b/test/Tests/Object.hs @@ -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) + ] + ] diff --git a/test/Tests/Object/Eq.hs b/test/Tests/Object/Eq.hs --- a/test/Tests/Object/Eq.hs +++ b/test/Tests/Object/Eq.hs @@ -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 + ] diff --git a/test/Tests/Object/FromJSON.hs b/test/Tests/Object/FromJSON.hs --- a/test/Tests/Object/FromJSON.hs +++ b/test/Tests/Object/FromJSON.hs @@ -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 diff --git a/test/Tests/Object/FromJSON/TH.hs b/test/Tests/Object/FromJSON/TH.hs --- a/test/Tests/Object/FromJSON/TH.hs +++ b/test/Tests/Object/FromJSON/TH.hs @@ -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|] diff --git a/test/Tests/Object/Show.hs b/test/Tests/Object/Show.hs --- a/test/Tests/Object/Show.hs +++ b/test/Tests/Object/Show.hs @@ -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} } }|] + ] diff --git a/test/Tests/Object/ToJSON.hs b/test/Tests/Object/ToJSON.hs --- a/test/Tests/Object/ToJSON.hs +++ b/test/Tests/Object/ToJSON.hs @@ -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 -} diff --git a/test/Tests/SchemaQQ.hs b/test/Tests/SchemaQQ.hs --- a/test/Tests/SchemaQQ.hs +++ b/test/Tests/SchemaQQ.hs @@ -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 -} diff --git a/test/Tests/SchemaQQ/TH.hs b/test/Tests/SchemaQQ/TH.hs --- a/test/Tests/SchemaQQ/TH.hs +++ b/test/Tests/SchemaQQ/TH.hs @@ -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)|] diff --git a/test/Tests/SumType.hs b/test/Tests/SumType.hs --- a/test/Tests/SumType.hs +++ b/test/Tests/SumType.hs @@ -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 diff --git a/test/Tests/UnwrapQQ.hs b/test/Tests/UnwrapQQ.hs --- a/test/Tests/UnwrapQQ.hs +++ b/test/Tests/UnwrapQQ.hs @@ -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 )" + ] diff --git a/test/Tests/UnwrapQQ/TH.hs b/test/Tests/UnwrapQQ/TH.hs --- a/test/Tests/UnwrapQQ/TH.hs +++ b/test/Tests/UnwrapQQ/TH.hs @@ -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)|]