schematic 0.4.2.0 → 0.5.0.0
raw patch · 20 files changed
+673/−135 lines, 20 filesdep ~basedep ~singletonsdep ~validationt
Dependency ranges changed: base, singletons, validationt
Files
- ChangeLog.md +13/−0
- schematic.cabal +14/−6
- src/Data/Schematic.hs +0/−23
- src/Data/Schematic/DSL.hs +6/−6
- src/Data/Schematic/Generator.hs +91/−0
- src/Data/Schematic/Generator/Regex.hs +76/−0
- src/Data/Schematic/Instances.hs +4/−0
- src/Data/Schematic/JsonSchema.hs +8/−1
- src/Data/Schematic/Lens.hs +12/−24
- src/Data/Schematic/Migration.hs +4/−4
- src/Data/Schematic/Path.hs +4/−6
- src/Data/Schematic/Schema.hs +81/−59
- src/Data/Schematic/Schema.hs-boot +87/−0
- src/Data/Schematic/Validation.hs +35/−6
- src/Data/Schematic/Verifier.hs +5/−0
- src/Data/Schematic/Verifier/Array.hs +14/−0
- src/Data/Schematic/Verifier/Common.hs +43/−0
- src/Data/Schematic/Verifier/Number.hs +31/−0
- src/Data/Schematic/Verifier/Text.hs +121/−0
- test/SchemaSpec.hs +24/−0
ChangeLog.md view
@@ -1,5 +1,18 @@ # Revision history for schematic +## 0.5.0.0 -- 2019-02-20++GHC 8.6, json generation by schema definition, validation bug fixes, better+parsing error messages.++## 0.4.3.0 -- 2018-07-12++GHC 8.4 support, dropping support for older GHC versions++## 0.4.2.0++Support ghc-8.4 and drop support for older versions+ ## 0.4.1.0 -- 2017-11-05 Convenience isomorphisms: txt, num, opt, bln etc
schematic.cabal view
@@ -1,6 +1,7 @@ name: schematic-version: 0.4.2.0+version: 0.5.0.0 synopsis: JSON-biased spec and validation tool+description: JSON-biased spec and validation tool. Makes possible to have a schema as a haskell type and derive json instances, validation actions, JSON generation for property-test generically. Built-in lens support. license: BSD3 license-file: LICENSE author: Denis Redozubov@@ -15,6 +16,8 @@ library exposed-modules: Data.Schematic , Data.Schematic.DSL+ , Data.Schematic.Generator+ , Data.Schematic.Generator.Regex , Data.Schematic.Instances , Data.Schematic.JsonSchema , Data.Schematic.Helpers@@ -23,6 +26,11 @@ , Data.Schematic.Path , Data.Schematic.Schema , Data.Schematic.Validation+ , Data.Schematic.Verifier+ , Data.Schematic.Verifier.Array+ , Data.Schematic.Verifier.Common+ , Data.Schematic.Verifier.Number+ , Data.Schematic.Verifier.Text ghc-options: -Wall default-extensions: ConstraintKinds , DataKinds@@ -57,7 +65,7 @@ , TypeOperators , TypeSynonymInstances , UndecidableInstances- build-depends: base >=4.9 && <4.11+ build-depends: base >=4.11 && <4.12 , bytestring , aeson >= 1 , containers@@ -67,14 +75,14 @@ , regex-tdfa , regex-tdfa-text , scientific- , singletons >= 2.2+ , singletons >= 2.4 , smallcheck , tagged , template-haskell , text , union , unordered-containers- , validationt >= 0.1.0.1+ , validationt >= 0.2.1.0 , vector , vinyl hs-source-dirs: src@@ -87,7 +95,7 @@ default-language: Haskell2010 build-depends: HUnit , aeson >= 1- , base >=4.9 && <4.11+ , base >=4.11 && <4.12 , bytestring , containers , hjsonschema@@ -104,7 +112,7 @@ , tagged , text , unordered-containers- , validationt >= 0.1.0.1+ , validationt >= 0.2.1.0 , vinyl other-modules: SchemaSpec , HelpersSpec
src/Data/Schematic.hs view
@@ -39,29 +39,6 @@ import Data.Text as T -parseAndValidateJson- :: forall schema- . (J.FromJSON (JsonRepr schema), TopLevel schema, SingI schema)- => J.Value- -> ParseResult (JsonRepr schema)-parseAndValidateJson v =- case parseEither parseJSON v of- Left s -> DecodingError $ T.pack s- Right jsonRepr ->- let- validate = validateJsonRepr (sing :: Sing schema) [] jsonRepr- res = runIdentity . runValidationTEither $ validate- in case res of- Left em -> ValidationError em- Right () -> Valid jsonRepr--parseAndValidateJsonBy- :: (J.FromJSON (JsonRepr schema), TopLevel schema, SingI schema)- => proxy schema- -> J.Value- -> ParseResult (JsonRepr schema)-parseAndValidateJsonBy _ = parseAndValidateJson- parseAndValidateTopVersionJson :: forall proxy (v :: Versioned) . (SingI (TopVersion (AllVersions v)))
src/Data/Schematic/DSL.hs view
@@ -18,9 +18,9 @@ type Constructor a- = forall b. FSubset (FieldsOf a) b (FImage (FieldsOf a) b)- => Rec (Tagged (FieldsOf a) :. FieldRepr) b- -> JsonRepr ('SchemaObject (FieldsOf a))+ = forall fields b. (fields ~ FieldsOf a, FSubset fields b (FImage fields b))+ => Rec (Tagged fields :. FieldRepr) b+ -> JsonRepr ('SchemaObject fields) withRepr :: Constructor a withRepr = ReprObject . rmap (unTagged . getCompose) . fcast@@ -66,9 +66,9 @@ FieldsOf ('SchemaObject fs) = fs type FieldConstructor fn =- forall fs. (Representable (ByField fn fs (FIndex fn fs)))- => Repr (ByField fn fs (FIndex fn fs))- -> (Tagged fs :. FieldRepr) '(fn, (ByField fn fs (FIndex fn fs)))+ forall byField fs. (byField ~ ByField fn fs (FIndex fn fs), Representable byField)+ => Repr byField+ -> (Tagged fs :. FieldRepr) '(fn, byField) field :: forall fn. KnownSymbol fn => FieldConstructor fn field = Compose . Tagged . constructField (sing :: Sing fn) Proxy
+ src/Data/Schematic/Generator.hs view
@@ -0,0 +1,91 @@+module Data.Schematic.Generator where++import Data.Maybe+import Data.Schematic.Generator.Regex+import {-# SOURCE #-} Data.Schematic.Schema+import Data.Schematic.Verifier+import Data.Scientific+import Data.Text (Text, pack)+import qualified Data.Vector as V+import Test.SmallCheck.Series++maxHigh :: Int+maxHigh = 30++minLow :: Int+minLow = 2++textLengthSeries :: Monad m => [VerifiedTextConstraint] -> Series m Text+textLengthSeries =+ \case+ [VTEq eq] -> pure $ pack $ take (fromIntegral eq) $ cycle "sample"+ [VTBounds ml mh] -> do+ let+ l = fromMaybe minLow (fromIntegral <$> ml) + 1+ h = fromMaybe maxHigh (fromIntegral <$> mh) - 1+ n <- generate $ \depth -> take depth [l .. h]+ pure $ pack $ take (fromIntegral n) $ cycle "sample"+ _ -> pure "error"++textEnumSeries :: Monad m => [Text] -> Series m Text+textEnumSeries enum = generate $ \depth -> take depth enum++textSeries :: Monad m => [DemotedTextConstraint] -> Series m Text+textSeries cs = do+ let mvcs = verifyTextConstraints cs+ case mvcs of+ Just vcs -> do+ n <- textSeries' vcs+ pure n+ Nothing -> pure "error"++textSeries' :: Monad m => [VerifiedTextConstraint] -> Series m Text+textSeries' [] = pure "sample"+textSeries' vcs = do+ let enums = listToMaybe [x | VTEnum x <- vcs]+ case enums of+ Just e -> textEnumSeries e+ Nothing -> do+ let regexps = listToMaybe [x | VTRegex x _ _ <- vcs]+ case regexps of+ Just e -> regexSeries e+ Nothing -> textLengthSeries vcs++numberSeries :: Monad m => [DemotedNumberConstraint] -> Series m Scientific+numberSeries cs = do+ let mvcs = verifyNumberConstraints cs+ case mvcs of+ Just vcs -> do+ n <- numberSeries' vcs+ pure $ n+ Nothing -> pure 0++numberSeries' :: Monad m => VerifiedNumberConstraint -> Series m Scientific+numberSeries' =+ \case+ VNEq eq -> pure $ fromIntegral eq+ VNBounds ml mh -> do+ let l = fromMaybe minLow (fromIntegral <$> ml) + 1+ h = fromMaybe maxHigh (fromIntegral <$> mh) - 1+ n <- generate $ \depth -> take depth [l .. h]+ pure $ fromIntegral n++arraySeries+ :: (Monad m, Serial m (JsonRepr s))+ => [DemotedArrayConstraint]+ -> Series m (V.Vector (JsonRepr s))+arraySeries cs = do+ let mvcs = verifyArrayConstraint cs+ case mvcs of+ Just vcs -> arraySeries' vcs+ Nothing -> pure V.empty++arraySeries'+ :: forall m s. (Monad m, Serial m (JsonRepr s))+ => Maybe VerifiedArrayConstraint+ -> Series m (V.Vector (JsonRepr s))+arraySeries' ml = do+ objs <- V.replicateM (maybe minRepeat f ml) (series :: Series m (JsonRepr s))+ pure $ objs+ where+ f (VAEq l) = fromIntegral l
+ src/Data/Schematic/Generator/Regex.hs view
@@ -0,0 +1,76 @@+module Data.Schematic.Generator.Regex where++import Control.Monad+import Data.List+import Data.Maybe+import qualified Data.Set as S+import Data.Text (Text, unpack)+import Data.Text.Lazy (toStrict)+import Data.Text.Lazy.Builder (Builder, singleton, toLazyText)+import Test.SmallCheck.Series+import Text.Regex.TDFA.Pattern+import Text.Regex.TDFA.ReadRegex (parseRegex)+++minRepeat :: Int+minRepeat = 2++maxRepeat :: Int+maxRepeat = 10++regexSeries :: (Monad m) => Text -> Series m Text+regexSeries regexp =+ case parseRegex . unpack $ regexp of+ Right (p, _) -> toStrict . toLazyText <$> regexSeries' p+ Left _ -> pure ""++regexSeries' :: (Monad m) => Pattern -> Series m Builder+regexSeries' pt =+ case pt of+ PEmpty -> pure mempty+ PChar {..} -> pure $ singleton getPatternChar+ PAny {getPatternSet = PatternSet (Just cset) _ _ _} -> do+ x <- generate $ \depth -> take depth $ S.toList cset+ pure $ singleton x+ PAnyNot {getPatternSet = PatternSet (Just cset) _ _ _} -> do+ x <-+ generate $ \depth ->+ take depth $ notChars $ concatMap expandEscape $ S.toList cset+ pure $ singleton x+ PQuest p -> regexSeries' p \/ pure mempty+ PPlus p -> regexSeries' $ PBound 1 Nothing p+ PStar _ p -> regexSeries' $ PBound 0 Nothing p+ PBound low mhigh p -> do+ let high = fromMaybe (low + maxRepeat) mhigh+ n <- generate $ \depth -> take depth [low .. high]+ decDepth $ do+ ps <- replicateM n $ regexSeries' p+ pure $ mconcat ps+ PConcat ps -> mconcat <$> mapM regexSeries' ps+ POr xs -> regexSeries' =<< (generate $ \depth -> take depth xs)+ PDot _ -> do+ x <- generate $ \depth -> take depth $ notChars []+ pure $ singleton x+ PEscape {..} -> do+ x <- generate $ \depth -> take depth $ expandEscape getPatternChar+ pure $ singleton x+ PCarat _ -> pure mempty+ PDollar _ -> pure mempty+ _ -> pure mempty+ where+ notChars = ([' ' .. '~'] \\)+ expandEscape ch =+ case ch of+ 'n' -> "\n"+ 't' -> "\t"+ 'r' -> "\r"+ 'f' -> "\f"+ 'a' -> "\a"+ 'e' -> "\ESC"+ 'd' -> ['0' .. '9']+ 'w' -> ['0' .. '9'] ++ '_' : ['a' .. 'z'] ++ ['A' .. 'Z']+ 's' -> "\9\32"+ 'D' -> notChars $ ['0' .. '9']+ 'W' -> notChars $ ['0' .. '9'] ++ '_' : ['a' .. 'z'] ++ ['A' .. 'Z']+ 'S' -> notChars "\9\32"+ ch' -> [ch']
src/Data/Schematic/Instances.hs view
@@ -4,6 +4,7 @@ module Data.Schematic.Instances where import Data.Scientific+import Data.Text (Text, pack) import Data.Vector as V import Data.Vinyl import Test.SmallCheck.Series@@ -21,3 +22,6 @@ instance Monad m => Serial m Scientific where series = scientific <$> series <*> series++instance Monad m => Serial m Text where+ series = pack <$> series
src/Data/Schematic/JsonSchema.hs view
@@ -12,8 +12,10 @@ import Data.Aeson as J import Data.Foldable as F import Data.HashMap.Strict as H+import Data.List as L import Data.List.NonEmpty as NE import Data.Schematic.Schema as S+import Data.Set as Set import Data.Singletons import Data.Text import Data.Traversable@@ -84,14 +86,19 @@ res <- for objs $ \(n,s) -> do s' <- toJsonSchema' s pure (n, s')+ let+ nonOpt = \case+ (_, DSchemaOptional _) -> False+ _ -> True pure $ emptySchema { _schemaType = pure $ TypeValidatorString D4.SchemaObject+ , _schemaRequired = pure $ Set.fromList $ fst <$> L.filter nonOpt objs , _schemaProperties = pure $ H.fromList res } DSchemaArray acs sch -> do res <- toJsonSchema' sch pure $ execState (traverse_ arrayConstraint acs) $ emptySchema { _schemaType = pure $ TypeValidatorString D4.SchemaArray- , _schemaItems = pure $ ItemsArray [res] }+ , _schemaItems = pure $ ItemsObject res } DSchemaNull -> pure $ emptySchema { _schemaType = pure $ TypeValidatorString D4.SchemaNull } DSchemaOptional sch -> do
src/Data/Schematic/Lens.hs view
@@ -156,64 +156,52 @@ -- A bunch of @Iso@morphisms textRepr- :: (KnownSymbol fn, SingI fn, SingI cs)+ :: (KnownSymbol fn, SingI cs) => Iso' (FieldRepr '(fn, ('SchemaText cs))) Text textRepr = iso (\(FieldRepr (ReprText t)) -> t) (FieldRepr . ReprText) numberRepr- :: (KnownSymbol fn, SingI fn, SingI cs)+ :: (KnownSymbol fn, SingI cs) => Iso' (FieldRepr '(fn, ('SchemaNumber cs))) Scientific numberRepr = iso (\(FieldRepr (ReprNumber n)) -> n) (FieldRepr . ReprNumber) boolRepr- :: (KnownSymbol fn, SingI fn, SingI cs)+ :: (KnownSymbol fn) => Iso' (FieldRepr '(fn, 'SchemaBoolean)) Bool boolRepr = iso (\(FieldRepr (ReprBoolean b)) -> b) (FieldRepr . ReprBoolean) arrayRepr- :: (KnownSymbol fn, SingI fn, SingI cs, SingI schema)+ :: (KnownSymbol fn, SingI cs, SingI schema) => Iso' (FieldRepr '(fn, ('SchemaArray cs schema))) (V.Vector (JsonRepr schema)) arrayRepr = iso (\(FieldRepr (ReprArray a)) -> a) (FieldRepr . ReprArray) objectRepr- :: (KnownSymbol fn, SingI fn, SingI fields)+ :: (KnownSymbol fn, SingI fields) => Iso' (FieldRepr '(fn, ('SchemaObject fields))) (Rec FieldRepr fields) objectRepr = iso (\(FieldRepr (ReprObject o)) -> o) (FieldRepr . ReprObject) optionalRepr- :: (KnownSymbol fn, SingI fn, SingI schema)+ :: (KnownSymbol fn, SingI schema) => Iso' (FieldRepr '(fn, ('SchemaOptional schema))) (Maybe (JsonRepr schema)) optionalRepr = iso (\(FieldRepr (ReprOptional r)) -> r) (FieldRepr . ReprOptional) -obj- :: SingI fields- => Iso' (JsonRepr ('SchemaObject fields)) (Rec FieldRepr fields)+obj :: Iso' (JsonRepr ('SchemaObject fields)) (Rec FieldRepr fields) obj = iso (\(ReprObject r) -> r) ReprObject -arr- :: (SingI schema)- => Iso' (JsonRepr ('SchemaArray cs schema)) (V.Vector (JsonRepr schema))+arr :: Iso' (JsonRepr ('SchemaArray cs schema)) (V.Vector (JsonRepr schema)) arr = iso (\(ReprArray r) -> r) ReprArray -uni- :: SingI (h ': tl)- => Iso' (JsonRepr ('SchemaUnion (h ': tl))) (Union JsonRepr (h ': tl))+uni :: Iso' (JsonRepr ('SchemaUnion (h ': tl))) (Union JsonRepr (h ': tl)) uni = iso (\(ReprUnion u) -> u) ReprUnion -txt- :: SingI cs- => Iso' (JsonRepr ('SchemaText cs)) Text+txt :: Iso' (JsonRepr ('SchemaText cs)) Text txt = iso (\(ReprText t) -> t) ReprText -num- :: SingI cs- => Iso' (JsonRepr ('SchemaNumber cs)) Scientific+num :: Iso' (JsonRepr ('SchemaNumber cs)) Scientific num = iso (\(ReprNumber t) -> t) ReprNumber bln :: Iso' (JsonRepr 'SchemaBoolean) Bool bln = iso (\(ReprBoolean b) -> b) ReprBoolean -opt- :: SingI schema- => Iso' (JsonRepr ('SchemaOptional schema)) (Maybe (JsonRepr schema))+opt :: Iso' (JsonRepr ('SchemaOptional schema)) (Maybe (JsonRepr schema)) opt = iso (\(ReprOptional o) -> o) ReprOptional
src/Data/Schematic/Migration.hs view
@@ -7,10 +7,10 @@ import Data.Schematic.DSL import Data.Schematic.Lens import Data.Schematic.Path-import Data.Tagged import Data.Schematic.Schema import Data.Singletons.Prelude hiding (All, (:.)) import Data.Singletons.TypeLits+import Data.Tagged import Data.Vinyl import Data.Vinyl.Functor @@ -42,8 +42,8 @@ SchemaByKey ( '(a, s) ': tl) fn = SchemaByKey tl fn type family DeleteKey (acc :: [(Symbol, Schema)]) (fn :: Symbol) (fs :: [(Symbol, Schema)]) :: [(Symbol, Schema)] where- DeleteKey acc fn ('(fn, a) ': tl) = acc :++ tl- DeleteKey acc fn (fna ': tl) = acc :++ (fna ': tl)+ DeleteKey acc fn ('(fn, a) ': tl) = acc ++ tl+ DeleteKey acc fn (fna ': tl) = acc ++ (fna ': tl) type family UpdateKey (fn :: Symbol)@@ -146,7 +146,7 @@ type DataMigration s m h = Tagged s (JsonRepr h -> m (JsonRepr s)) -data MList :: (* -> *) -> [Schema] -> Type where+data MList :: (Type -> Type) -> [Schema] -> Type where MNil :: (Monad m, SingI s, TopLevel s) => MList m '[s] (:&&) :: (TopLevel s, SingI s)
src/Data/Schematic/Path.hs view
@@ -1,8 +1,6 @@ module Data.Schematic.Path where import Data.Foldable as F-import Data.Monoid-import Data.Singletons import Data.Singletons.Prelude import Data.Singletons.TypeLits import Data.Text as T@@ -26,10 +24,10 @@ where go :: [DemotedPathSegment] -> Sing (ps :: [PathSegment]) -> [DemotedPathSegment] go acc SNil = acc- go acc (SCons p ps) = go (acc ++ [demote p]) ps- demote :: Sing (ps :: PathSegment) -> DemotedPathSegment- demote (SKey s) = DKey $ T.pack $ withKnownSymbol s $ symbolVal s- demote (SIx n) = DIx $ withKnownNat n $ natVal n+ go acc (SCons p ps) = go (acc ++ [demotePathSeg p]) ps+ demotePathSeg :: Sing (ps :: PathSegment) -> DemotedPathSegment+ demotePathSeg (SKey s) = DKey $ T.pack $ withKnownSymbol s $ symbolVal s+ demotePathSeg (SIx n) = DIx $ withKnownNat n $ fromIntegral $ natVal n demotedPathToText :: [DemotedPathSegment] -> JSONPath demotedPathToText = JSONPath . F.foldl' renderPathSegment ""
src/Data/Schematic/Schema.hs view
@@ -13,6 +13,7 @@ import Data.Kind import Data.Maybe import Data.Schematic.Instances ()+import Data.Schematic.Generator import Data.Scientific import Data.Singletons.Prelude.List hiding (All, Union) import Data.Singletons.TH@@ -24,7 +25,8 @@ import qualified Data.Vinyl.TypeLevel as V import GHC.Exts import GHC.Generics (Generic)-import GHC.TypeLits (SomeNat(..), SomeSymbol(..), someSymbolVal, someNatVal)+import GHC.TypeLits+ (SomeNat(..), SomeSymbol(..), someNatVal, someSymbolVal) import Prelude as P import Test.SmallCheck.Series @@ -48,33 +50,33 @@ instance SingKind TextConstraint where type Demote TextConstraint = DemotedTextConstraint fromSing = \case- STEq n -> withKnownNat n (DTEq $ natVal n)- STLt n -> withKnownNat n (DTLt $ natVal n)- STLe n -> withKnownNat n (DTLe $ natVal n)- STGt n -> withKnownNat n (DTGt $ natVal n)- STGe n -> withKnownNat n (DTGe $ natVal n)+ STEq n -> withKnownNat n (DTEq . fromIntegral $ natVal n)+ STLt n -> withKnownNat n (DTLt . fromIntegral $ natVal n)+ STLe n -> withKnownNat n (DTLe . fromIntegral $ natVal n)+ STGt n -> withKnownNat n (DTGt . fromIntegral $ natVal n)+ STGe n -> withKnownNat n (DTGe . fromIntegral $ natVal n) STRegex s -> withKnownSymbol s (DTRegex $ T.pack $ symbolVal s) STEnum s -> let d :: Sing (s :: [Symbol]) -> [Text]- d SNil = []+ d SNil = [] d (SCons ss@SSym fs) = T.pack (symbolVal ss) : d fs in DTEnum $ d s toSing = \case DTEq n -> case someNatVal n of Just (SomeNat (_ :: Proxy n)) -> SomeSing (STEq (SNat :: Sing n))- Nothing -> error "Negative singleton nat"+ Nothing -> error "Negative singleton nat" DTLt n -> case someNatVal n of Just (SomeNat (_ :: Proxy n)) -> SomeSing (STLt (SNat :: Sing n))- Nothing -> error "Negative singleton nat"+ Nothing -> error "Negative singleton nat" DTLe n -> case someNatVal n of Just (SomeNat (_ :: Proxy n)) -> SomeSing (STLe (SNat :: Sing n))- Nothing -> error "Negative singleton nat"+ Nothing -> error "Negative singleton nat" DTGt n -> case someNatVal n of Just (SomeNat (_ :: Proxy n)) -> SomeSing (STGt (SNat :: Sing n))- Nothing -> error "Negative singleton nat"+ Nothing -> error "Negative singleton nat" DTGe n -> case someNatVal n of Just (SomeNat (_ :: Proxy n)) -> SomeSing (STGe (SNat :: Sing n))- Nothing -> error "Negative singleton nat"+ Nothing -> error "Negative singleton nat" DTRegex s -> case someSymbolVal (T.unpack s) of SomeSymbol (_ :: Proxy n) -> SomeSing (STRegex (SSym :: Sing n)) DTEnum ss -> case toSing ss of@@ -88,7 +90,7 @@ | DTGe Integer | DTRegex Text | DTEnum [Text]- deriving (Generic)+ deriving (Generic, Eq, Show) data instance Sing (tc :: TextConstraint) where STEq :: Sing n -> Sing ('TEq n)@@ -129,7 +131,7 @@ | DNGt Integer | DNGe Integer | DNEq Integer- deriving (Generic)+ deriving (Generic, Eq, Show) data instance Sing (nc :: NumberConstraint) where SNEq :: Sing n -> Sing ('NEq n)@@ -153,27 +155,27 @@ instance SingKind NumberConstraint where type Demote NumberConstraint = DemotedNumberConstraint fromSing = \case- SNEq n -> withKnownNat n (DNEq $ natVal n)- SNGt n -> withKnownNat n (DNGt $ natVal n)- SNGe n -> withKnownNat n (DNGe $ natVal n)- SNLt n -> withKnownNat n (DNLt $ natVal n)- SNLe n -> withKnownNat n (DNLe $ natVal n)+ SNEq n -> withKnownNat n (DNEq . fromIntegral $ natVal n)+ SNGt n -> withKnownNat n (DNGt . fromIntegral $ natVal n)+ SNGe n -> withKnownNat n (DNGe . fromIntegral $ natVal n)+ SNLt n -> withKnownNat n (DNLt . fromIntegral $ natVal n)+ SNLe n -> withKnownNat n (DNLe . fromIntegral $ natVal n) toSing = \case DNEq n -> case someNatVal n of Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNEq (SNat :: Sing n))- Nothing -> error "Negative singleton nat"+ Nothing -> error "Negative singleton nat" DNGt n -> case someNatVal n of Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNGt (SNat :: Sing n))- Nothing -> error "Negative singleton nat"+ Nothing -> error "Negative singleton nat" DNGe n -> case someNatVal n of Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNGe (SNat :: Sing n))- Nothing -> error "Negative singleton nat"+ Nothing -> error "Negative singleton nat" DNLt n -> case someNatVal n of Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNLt (SNat :: Sing n))- Nothing -> error "Negative singleton nat"+ Nothing -> error "Negative singleton nat" DNLe n -> case someNatVal n of Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNLe (SNat :: Sing n))- Nothing -> error "Negative singleton nat"+ Nothing -> error "Negative singleton nat" data ArrayConstraint = AEq Nat@@ -181,7 +183,7 @@ data DemotedArrayConstraint = DAEq Integer- deriving (Generic)+ deriving (Generic, Eq, Show) data instance Sing (ac :: ArrayConstraint) where SAEq :: Sing n -> Sing ('AEq n)@@ -193,11 +195,11 @@ instance SingKind ArrayConstraint where type Demote ArrayConstraint = DemotedArrayConstraint fromSing = \case- SAEq n -> withKnownNat n (DAEq $ natVal n)+ SAEq n -> withKnownNat n (DAEq . fromIntegral $ natVal n) toSing = \case DAEq n -> case someNatVal n of Just (SomeNat (_ :: Proxy n)) -> SomeSing (SAEq (SNat :: Sing n))- Nothing -> error "Negative singleton nat"+ Nothing -> error "Negative singleton nat" data Schema = SchemaText [TextConstraint]@@ -219,7 +221,7 @@ | DSchemaNull | DSchemaOptional DemotedSchema | DSchemaUnion [DemotedSchema]- deriving (Generic)+ deriving (Generic, Eq, Show) data instance Sing (schema :: Schema) where SSchemaText :: Sing tcs -> Sing ('SchemaText tcs)@@ -334,6 +336,31 @@ ReprOptional :: Maybe (JsonRepr s) -> JsonRepr ('SchemaOptional s) ReprUnion :: Union JsonRepr (h ': tl) -> JsonRepr ('SchemaUnion (h ': tl)) +instance (Monad m, Serial m Text, SingI cs)+ => Serial m (JsonRepr ('SchemaText cs)) where+ series = decDepth $ fmap ReprText $ textSeries $ fromSing (sing :: Sing cs)++instance (Monad m, Serial m Scientific, SingI cs)+ => Serial m (JsonRepr ('SchemaNumber cs)) where+ series = decDepth $ fmap ReprNumber+ $ numberSeries $ fromSing (sing :: Sing cs)++instance Monad m => Serial m (JsonRepr 'SchemaNull) where+ series = cons0 ReprNull++instance (Serial m (JsonRepr s), Serial m (V.Vector (JsonRepr s)), SingI cs)+ => Serial m (JsonRepr ('SchemaArray cs s)) where+ series = decDepth $ fmap ReprArray+ $ arraySeries $ fromSing (sing :: Sing cs)++instance (Serial m (JsonRepr s))+ => Serial m (JsonRepr ('SchemaOptional s)) where+ series = cons1 ReprOptional++instance (Monad m, Serial m (Rec FieldRepr fs))+ => Serial m (JsonRepr ('SchemaObject fs)) where+ series = cons1 ReprObject+ -- | Move to the union package instance Show (JsonRepr ('SchemaText cs)) where show (ReprText t) = "ReprText " P.++ show t@@ -352,29 +379,6 @@ instance Show (JsonRepr s) => Show (JsonRepr ('SchemaOptional s)) where show (ReprOptional s) = "ReprOptional " P.++ show s -instance (Monad m, Serial m Text)- => Serial m (JsonRepr ('SchemaText cs)) where- series = cons1 ReprText--instance (Monad m, Serial m Scientific)- => Serial m (JsonRepr ('SchemaNumber cs)) where- series = cons1 ReprNumber--instance Monad m => Serial m (JsonRepr 'SchemaNull) where- series = cons0 ReprNull--instance (Serial m (V.Vector (JsonRepr s)))- => Serial m (JsonRepr ('SchemaArray cs s)) where- series = cons1 ReprArray--instance (Serial m (JsonRepr s))- => Serial m (JsonRepr ('SchemaOptional s)) where- series = cons1 ReprOptional--instance (Monad m, Serial m (Rec FieldRepr fs))- => Serial m (JsonRepr ('SchemaObject fs)) where- series = cons1 ReprObject- instance Eq (Rec FieldRepr fs) => Eq (JsonRepr ('SchemaObject fs)) where ReprObject a == ReprObject b = a == b @@ -393,6 +397,24 @@ instance Eq (JsonRepr s) => Eq (JsonRepr ('SchemaOptional s)) where ReprOptional a == ReprOptional b = a == b +instance Ord (Rec FieldRepr fs) => Ord (JsonRepr ('SchemaObject fs)) where+ ReprObject a `compare` ReprObject b = a `compare` b++instance Ord (JsonRepr ('SchemaText cs)) where+ ReprText a `compare` ReprText b = a `compare` b++instance Ord (JsonRepr ('SchemaNumber cs)) where+ ReprNumber a `compare` ReprNumber b = a `compare` b++instance Ord (JsonRepr 'SchemaNull) where+ compare _ _ = EQ++instance Ord (JsonRepr s) => Ord (JsonRepr ('SchemaArray as s)) where+ ReprArray a `compare` ReprArray b = a `compare` b++instance Ord (JsonRepr s) => Ord (JsonRepr ('SchemaOptional s)) where+ ReprOptional a `compare` ReprOptional b = a `compare` b+ instance IsList (JsonRepr ('SchemaArray cs s)) where type Item (JsonRepr ('SchemaArray cs s)) = JsonRepr s fromList = ReprArray . GHC.Exts.fromList@@ -454,25 +476,25 @@ fieldRepr <- case s of SSchemaText so -> case H.lookup fieldName h of Just v -> withSingI so $ FieldRepr <$> parseJSON v- Nothing -> fail "schematext"+ Nothing -> fail $ "No text field: " P.++ show fieldName SSchemaNumber so -> case H.lookup fieldName h of Just v -> withSingI so $ FieldRepr <$> parseJSON v- Nothing -> fail "schemanumber"+ Nothing -> fail $ "No number field: " P.++ show fieldName SSchemaBoolean -> case H.lookup fieldName h of Just v -> FieldRepr <$> parseJSON v- Nothing -> fail "schemaboolean"+ Nothing -> fail $ "No boolean field: " P.++ show fieldName SSchemaNull -> case H.lookup fieldName h of Just v -> FieldRepr <$> parseJSON v- Nothing -> fail "schemanull"+ Nothing -> fail $ "No null field: " P.++ show fieldName SSchemaArray sa sb -> case H.lookup fieldName h of Just v -> withSingI sa $ withSingI sb $ FieldRepr <$> parseJSON v- Nothing -> fail "schemaarray"+ Nothing -> fail $ "No array field: " P.++ show fieldName SSchemaObject so -> case H.lookup fieldName h of Just v -> withSingI so $ FieldRepr <$> parseJSON v- Nothing -> fail "schemaobject"+ Nothing -> fail $ "No object field" P.++ show fieldName SSchemaOptional so -> case H.lookup fieldName h of Just v -> withSingI so $ FieldRepr <$> parseJSON v- Nothing -> fail "schemaoptional"+ Nothing -> withSingI so $ pure $ FieldRepr $ ReprOptional Nothing SSchemaUnion ss -> withSingI ss $ FieldRepr <$> parseUnion ss value (fieldRepr :&) <$> demoteFields tl h ReprObject <$> withObject "Object" (demoteFields fs) value@@ -484,7 +506,7 @@ toJSON (ReprText t) = J.String t toJSON (ReprNumber n) = J.Number n toJSON (ReprOptional s) = case s of- Just v -> toJSON v+ Just v -> toJSON v Nothing -> J.Null toJSON (ReprArray v) = J.Array $ toJSON <$> v toJSON (ReprObject r) = J.Object . H.fromList . fold $ r
+ src/Data/Schematic/Schema.hs-boot view
@@ -0,0 +1,87 @@+module Data.Schematic.Schema where++import Data.Kind+import Data.Maybe+import Data.Schematic.Instances ()+import Data.Scientific+import Data.Singletons.TH+import Data.Singletons.TypeLits+import Data.Text as T+import Data.Union+import Data.Vector as V+import Data.Vinyl hiding (Dict)+import Prelude as P++data TextConstraint+ = TEq Nat+ | TLt Nat+ | TLe Nat+ | TGt Nat+ | TGe Nat+ | TRegex Symbol+ | TEnum [Symbol]++data DemotedTextConstraint+ = DTEq Integer+ | DTLt Integer+ | DTLe Integer+ | DTGt Integer+ | DTGe Integer+ | DTRegex Text+ | DTEnum [Text]++data NumberConstraint+ = NLe Nat+ | NLt Nat+ | NGt Nat+ | NGe Nat+ | NEq Nat++data DemotedNumberConstraint+ = DNLe Integer+ | DNLt Integer+ | DNGt Integer+ | DNGe Integer+ | DNEq Integer++data ArrayConstraint+ = AEq Nat++data DemotedArrayConstraint+ = DAEq Integer++data Schema+ = SchemaText [TextConstraint]+ | SchemaBoolean+ | SchemaNumber [NumberConstraint]+ | SchemaObject [(Symbol, Schema)]+ | SchemaArray [ArrayConstraint] Schema+ | SchemaNull+ | SchemaOptional Schema+ | SchemaUnion [Schema]++data DemotedSchema+ = DSchemaText [DemotedTextConstraint]+ | DSchemaNumber [DemotedNumberConstraint]+ | DSchemaBoolean+ | DSchemaObject [(Text, DemotedSchema)]+ | DSchemaArray [DemotedArrayConstraint] DemotedSchema+ | DSchemaNull+ | DSchemaOptional DemotedSchema+ | DSchemaUnion [DemotedSchema]++data FieldRepr :: (Symbol, Schema) -> Type where+ FieldRepr+ :: (SingI schema, KnownSymbol name)+ => JsonRepr schema+ -> FieldRepr '(name, schema)++data JsonRepr :: Schema -> Type where+ ReprText :: Text -> JsonRepr ('SchemaText cs)+ ReprNumber :: Scientific -> JsonRepr ('SchemaNumber cs)+ ReprBoolean :: Bool -> JsonRepr 'SchemaBoolean+ ReprNull :: JsonRepr 'SchemaNull+ ReprArray :: V.Vector (JsonRepr s) -> JsonRepr ('SchemaArray cs s)+ ReprObject :: Rec FieldRepr fs -> JsonRepr ('SchemaObject fs)+ ReprOptional :: Maybe (JsonRepr s) -> JsonRepr ('SchemaOptional s)+ ReprUnion :: Union JsonRepr (h ': tl) -> JsonRepr ('SchemaUnion (h ': tl))
src/Data/Schematic/Validation.hs view
@@ -2,6 +2,8 @@ import Control.Monad import Control.Monad.Validation+import Data.Aeson+import Data.Aeson.Types import Data.Foldable import Data.Functor.Identity import Data.Monoid@@ -30,6 +32,10 @@ | ValidationError ErrorMap -- runtime deriving (Show, Eq, Functor, Foldable, Traversable) +instance (TopLevel a, SingI a, FromJSON (JsonRepr a))+ => FromJSON (ParseResult (JsonRepr a)) where+ parseJSON = pure . parseAndValidateJson @a+ isValid :: ParseResult a -> Bool isValid (Valid _) = True isValid _ = False@@ -58,28 +64,28 @@ STLt n -> do let nlen = withKnownNat n $ natVal n- predicate = nlen < (fromIntegral $ T.length t)+ predicate = nlen > (fromIntegral $ T.length t) errMsg = "length of " <> path <> " should be < " <> T.pack (show nlen) warn = vWarning $ mmSingleton path (pure errMsg) unless predicate warn STLe n -> do let nlen = withKnownNat n $ natVal n- predicate = nlen <= (fromIntegral $ T.length t)+ predicate = nlen >= (fromIntegral $ T.length t) errMsg = "length of " <> path <> " should be <= " <> T.pack (show nlen) warn = vWarning $ mmSingleton path (pure errMsg) unless predicate warn STGt n -> do let nlen = withKnownNat n $ natVal n- predicate = nlen > (fromIntegral $ T.length t)+ predicate = nlen < (fromIntegral $ T.length t) errMsg = "length of " <> path <> " should be > " <> T.pack (show nlen) warn = vWarning $ mmSingleton path (pure errMsg) unless predicate warn STGe n -> do let nlen = withKnownNat n $ natVal n- predicate = nlen >= (fromIntegral $ T.length t)+ predicate = nlen <= (fromIntegral $ T.length t) errMsg = "length of " <> path <> " should be >= " <> T.pack (show nlen) warn = vWarning $ mmSingleton path (pure errMsg) unless predicate warn@@ -129,14 +135,14 @@ SNLt n -> do let nlen = withKnownNat n $ natVal n- predicate = fromIntegral nlen < num+ predicate = num < fromIntegral nlen errMsg = path <> " should be < " <> T.pack (show nlen) warn = vWarning $ mmSingleton path (pure errMsg) unless predicate warn SNLe n -> do let nlen = withKnownNat n $ natVal n- predicate = fromIntegral nlen <= num+ predicate = num <= fromIntegral nlen errMsg = path <> " should be <= " <> T.pack (show nlen) warn = vWarning $ mmSingleton path (pure errMsg) unless predicate warn@@ -246,3 +252,26 @@ umatch' :: UElem a as i => Sing a -> Union f as -> Maybe (f a) umatch' _ u = umatch u++parseAndValidateJson+ :: forall schema+ . (FromJSON (JsonRepr schema), TopLevel schema, SingI schema)+ => Value+ -> ParseResult (JsonRepr schema)+parseAndValidateJson v =+ case parseEither parseJSON v of+ Left s -> DecodingError $ T.pack s+ Right jsonRepr ->+ let+ validate = validateJsonRepr (sing :: Sing schema) [] jsonRepr+ res = runIdentity . runValidationTEither $ validate+ in case res of+ Left em -> ValidationError em+ Right () -> Valid jsonRepr++parseAndValidateJsonBy+ :: (FromJSON (JsonRepr schema), TopLevel schema, SingI schema)+ => proxy schema+ -> Value+ -> ParseResult (JsonRepr schema)+parseAndValidateJsonBy _ = parseAndValidateJson
+ src/Data/Schematic/Verifier.hs view
@@ -0,0 +1,5 @@+module Data.Schematic.Verifier (module X) where++import Data.Schematic.Verifier.Array as X+import Data.Schematic.Verifier.Number as X+import Data.Schematic.Verifier.Text as X
+ src/Data/Schematic/Verifier/Array.hs view
@@ -0,0 +1,14 @@+module Data.Schematic.Verifier.Array where++import {-# SOURCE #-} Data.Schematic.Schema+import Data.Schematic.Verifier.Common++data VerifiedArrayConstraint =+ VAEq Integer+ deriving (Show)++verifyArrayConstraint ::+ [DemotedArrayConstraint] -> Maybe (Maybe VerifiedArrayConstraint)+verifyArrayConstraint cs = do+ x <- verifyDNEq [x | DAEq x <- cs]+ pure $ VAEq <$> x
+ src/Data/Schematic/Verifier/Common.hs view
@@ -0,0 +1,43 @@+module Data.Schematic.Verifier.Common where++import Data.List (nub)++simplifyNumberConstraint :: ([Integer] -> Integer) -> [Integer] -> Maybe Integer+simplifyNumberConstraint f =+ \case+ [] -> Nothing+ x -> Just $ f x++simplifyDNLs :: [Integer] -> Maybe Integer+simplifyDNLs = simplifyNumberConstraint minimum++simplifyDNGs :: [Integer] -> Maybe Integer+simplifyDNGs = simplifyNumberConstraint maximum++verifyDNEq :: [Integer] -> Maybe (Maybe Integer)+verifyDNEq x =+ case nub x of+ [] -> Just Nothing+ [y] -> Just $ Just y+ (_:_:_) -> Nothing++verify3 :: Maybe Integer -> Maybe Integer -> Maybe Integer -> Maybe ()+verify3 (Just x) (Just y) (Just z) =+ if x < y && y < z+ then Just ()+ else Nothing+verify3 _ _ _ = Just ()++verify2 :: Maybe Integer -> Maybe Integer -> Maybe ()+verify2 (Just x) (Just y) =+ if x < y+ then Just ()+ else Nothing+verify2 _ _ = Just ()++verifyEquations :: Maybe Integer -> Maybe Integer -> Maybe Integer -> Maybe ()+verifyEquations mgt meq mlt = do+ verify3 mgt meq mlt+ verify2 mgt meq+ verify2 meq mlt+ verify2 mgt mlt
+ src/Data/Schematic/Verifier/Number.hs view
@@ -0,0 +1,31 @@+module Data.Schematic.Verifier.Number where++import {-# SOURCE #-} Data.Schematic.Schema+import Data.Schematic.Verifier.Common++toStrictNumber :: [DemotedNumberConstraint] -> [DemotedNumberConstraint]+toStrictNumber = map f+ where+ f (DNLe x) = DNLt (x + 1)+ f (DNGe x) = DNGt (x - 1)+ f x = x++data VerifiedNumberConstraint+ = VNEq Integer+ | VNBounds (Maybe Integer) (Maybe Integer)+ deriving (Show)++verifyNumberConstraints+ :: [DemotedNumberConstraint]+ -> Maybe VerifiedNumberConstraint+verifyNumberConstraints cs' = do+ let+ cs = toStrictNumber cs'+ mlt = simplifyDNLs [x | DNLt x <- cs]+ mgt = simplifyDNGs [x | DNGt x <- cs]+ meq <- verifyDNEq [x | DNEq x <- cs]+ verifyEquations mgt meq mlt+ Just $+ case meq of+ Just eq -> VNEq eq+ Nothing -> VNBounds mgt mlt
+ src/Data/Schematic/Verifier/Text.hs view
@@ -0,0 +1,121 @@+module Data.Schematic.Verifier.Text where++import Control.Monad+import Data.Maybe+import {-# SOURCE #-} Data.Schematic.Schema+import Data.Schematic.Verifier.Common+import Data.Text (Text, unpack)+import Text.Regex.TDFA.Pattern+import Text.Regex.TDFA.ReadRegex (parseRegex)++toStrictTextLength :: [DemotedTextConstraint] -> [DemotedTextConstraint]+toStrictTextLength = map f+ where+ f (DTLe x) = DTLt (x + 1)+ f (DTGe x) = DTGt (x - 1)+ f x = x++data VerifiedTextConstraint+ = VTEq Integer+ | VTBounds (Maybe Integer) (Maybe Integer)+ | VTRegex Text Integer (Maybe Integer)+ | VTEnum [Text]+ deriving (Show)++verifyTextLengthConstraints+ :: [DemotedTextConstraint]+ -> Maybe (Maybe VerifiedTextConstraint)+verifyTextLengthConstraints cs' = do+ let+ cs = toStrictTextLength cs'+ mlt = simplifyDNLs [x | DTLt x <- cs]+ mgt = simplifyDNGs [x | DTGt x <- cs]+ meq <- verifyDNEq [x | DTEq x <- cs]+ verifyEquations mgt meq mlt+ case all isNothing ([mgt, meq, mlt] :: [Maybe Integer]) of+ True -> Just Nothing+ _ ->+ Just $+ Just $+ case meq of+ Just eq -> VTEq eq+ Nothing -> VTBounds mgt mlt++regexLength :: Text -> Maybe (Int, Maybe Int)+regexLength regexp =+ case parseRegex . unpack $ regexp of+ Right (p, _) -> Just (minRegexLength p, maxRegexLength p)+ Left _ -> Nothing++minRegexLength :: Pattern -> Int+minRegexLength p =+ case p of+ PEmpty -> 0+ PChar {..} -> 1+ PAny {..} -> 1+ PAnyNot {..} -> 1+ PQuest _ -> 0+ PPlus sch -> minRegexLength $ PBound 1 Nothing sch+ PStar _ sch -> minRegexLength $ PBound 0 Nothing sch+ PBound low _ sch -> low * minRegexLength sch+ PConcat ps -> sum $ fmap minRegexLength ps+ POr xs -> minimum $ fmap minRegexLength xs+ PDot _ -> 1+ PEscape {..} -> 1+ PCarat _ -> 0+ PDollar _ -> 0+ _ -> 0++maxRegexLength :: Pattern -> Maybe Int+maxRegexLength p =+ case p of+ PEmpty -> Just 0+ PChar _ _ -> Just 1+ PAny _ _ -> Just 1+ PAnyNot _ _ -> Just 1+ PQuest _ -> Just 0+ PPlus _ -> Nothing+ PStar _ _ -> Nothing+ PBound _ mhigh sch -> (*) <$> mhigh <*> maxRegexLength sch+ PConcat ps -> sum <$> mapM maxRegexLength ps+ POr xs -> maximum <$> mapM maxRegexLength xs+ PDot _ -> Just 1+ PEscape _ _ -> Just 1+ PCarat _ -> Just 0+ PDollar _ -> Just 0+ _ -> Just 0++verifyTextRegexConstraint+ :: [DemotedTextConstraint]+ -> Maybe (Maybe VerifiedTextConstraint)+verifyTextRegexConstraint cs = do+ let regexps = [x | DTRegex x <- cs]+ case regexps of+ [] -> Just Nothing+ [x] -> do+ (l, mh) <- regexLength x+ Just $ Just $ VTRegex x (fromIntegral l) (fromIntegral <$> mh)+ _ -> Nothing++verifyTextEnumConstraint+ :: [DemotedTextConstraint]+ -> Maybe (Maybe VerifiedTextConstraint)+verifyTextEnumConstraint cs = do+ let enums = concat [x | DTEnum x <- cs]+ case enums of+ [] -> Just Nothing+ x -> Just $ Just $ VTEnum x++verifyTextConstraints+ :: [DemotedTextConstraint]+ -> Maybe [VerifiedTextConstraint]+verifyTextConstraints cs = do+ regexp <- verifyTextRegexConstraint cs+ void $+ case regexp of+ Just (VTRegex _ l mh) ->+ verifyTextLengthConstraints (DTGe l : cs ++ maybeToList (DTLe <$> mh))+ _ -> pure Nothing+ lengths <- verifyTextLengthConstraints cs+ enums <- verifyTextEnumConstraint cs+ return $ catMaybes [lengths, enums, regexp]
test/SchemaSpec.hs view
@@ -17,15 +17,26 @@ import Data.Functor.Identity import Data.Proxy import Data.Schematic+import Data.Schematic.Generator+import Data.Singletons import Data.Tagged import Data.Vinyl import Test.Hspec+import Test.Hspec.SmallCheck+import Test.SmallCheck as SC+import Test.SmallCheck.Drivers as SC+import Test.SmallCheck.Series as SC +import Debug.Trace type SchemaExample = 'SchemaObject '[ '("foo", 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10])) , '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))] +type SchemaExample2 = 'SchemaObject+ '[ '("foo", 'SchemaArray '[ 'AEq 2] ('SchemaText '[ 'TGt 10]))+ , '("bar", 'SchemaOptional ('SchemaText '[ 'TRegex "[0-9]+"]))]+ jsonExample :: JsonRepr SchemaExample jsonExample = withRepr @SchemaExample $ field @"bar" (Just "bar")@@ -69,6 +80,12 @@ schemaJson2 :: ByteString schemaJson2 = "{\"foo\": [3], \"bar\": null}" +schemaJsonSeries :: Monad m => SC.Series m (JsonRepr SchemaExample)+schemaJsonSeries = series++schemaJsonSeries2 :: Monad m => SC.Series m (JsonRepr SchemaExample2)+schemaJsonSeries2 = series+ spec :: Spec spec = do -- it "show/read JsonRepr properly" $@@ -93,6 +110,13 @@ migrationList schemaJson `shouldSatisfy` isValid+ it "validates json series" $ property $+ SC.over schemaJsonSeries $ \x ->+ isValid (parseAndValidateJson @SchemaExample (toJSON x))+ it "validates json series 2" $ property $+ SC.over schemaJsonSeries2 $ \x ->+ isValid (parseAndValidateJson @SchemaExample2 (toJSON x))+ main :: IO () main = hspec spec