diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/schematic.cabal b/schematic.cabal --- a/schematic.cabal +++ b/schematic.cabal @@ -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 diff --git a/src/Data/Schematic.hs b/src/Data/Schematic.hs --- a/src/Data/Schematic.hs +++ b/src/Data/Schematic.hs @@ -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))) diff --git a/src/Data/Schematic/DSL.hs b/src/Data/Schematic/DSL.hs --- a/src/Data/Schematic/DSL.hs +++ b/src/Data/Schematic/DSL.hs @@ -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 diff --git a/src/Data/Schematic/Generator.hs b/src/Data/Schematic/Generator.hs new file mode 100644 --- /dev/null +++ b/src/Data/Schematic/Generator.hs @@ -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 diff --git a/src/Data/Schematic/Generator/Regex.hs b/src/Data/Schematic/Generator/Regex.hs new file mode 100644 --- /dev/null +++ b/src/Data/Schematic/Generator/Regex.hs @@ -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'] diff --git a/src/Data/Schematic/Instances.hs b/src/Data/Schematic/Instances.hs --- a/src/Data/Schematic/Instances.hs +++ b/src/Data/Schematic/Instances.hs @@ -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 diff --git a/src/Data/Schematic/JsonSchema.hs b/src/Data/Schematic/JsonSchema.hs --- a/src/Data/Schematic/JsonSchema.hs +++ b/src/Data/Schematic/JsonSchema.hs @@ -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 diff --git a/src/Data/Schematic/Lens.hs b/src/Data/Schematic/Lens.hs --- a/src/Data/Schematic/Lens.hs +++ b/src/Data/Schematic/Lens.hs @@ -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 diff --git a/src/Data/Schematic/Migration.hs b/src/Data/Schematic/Migration.hs --- a/src/Data/Schematic/Migration.hs +++ b/src/Data/Schematic/Migration.hs @@ -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) diff --git a/src/Data/Schematic/Path.hs b/src/Data/Schematic/Path.hs --- a/src/Data/Schematic/Path.hs +++ b/src/Data/Schematic/Path.hs @@ -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 "" diff --git a/src/Data/Schematic/Schema.hs b/src/Data/Schematic/Schema.hs --- a/src/Data/Schematic/Schema.hs +++ b/src/Data/Schematic/Schema.hs @@ -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 diff --git a/src/Data/Schematic/Schema.hs-boot b/src/Data/Schematic/Schema.hs-boot new file mode 100644 --- /dev/null +++ b/src/Data/Schematic/Schema.hs-boot @@ -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)) diff --git a/src/Data/Schematic/Validation.hs b/src/Data/Schematic/Validation.hs --- a/src/Data/Schematic/Validation.hs +++ b/src/Data/Schematic/Validation.hs @@ -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 diff --git a/src/Data/Schematic/Verifier.hs b/src/Data/Schematic/Verifier.hs new file mode 100644 --- /dev/null +++ b/src/Data/Schematic/Verifier.hs @@ -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 diff --git a/src/Data/Schematic/Verifier/Array.hs b/src/Data/Schematic/Verifier/Array.hs new file mode 100644 --- /dev/null +++ b/src/Data/Schematic/Verifier/Array.hs @@ -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 diff --git a/src/Data/Schematic/Verifier/Common.hs b/src/Data/Schematic/Verifier/Common.hs new file mode 100644 --- /dev/null +++ b/src/Data/Schematic/Verifier/Common.hs @@ -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 diff --git a/src/Data/Schematic/Verifier/Number.hs b/src/Data/Schematic/Verifier/Number.hs new file mode 100644 --- /dev/null +++ b/src/Data/Schematic/Verifier/Number.hs @@ -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 diff --git a/src/Data/Schematic/Verifier/Text.hs b/src/Data/Schematic/Verifier/Text.hs new file mode 100644 --- /dev/null +++ b/src/Data/Schematic/Verifier/Text.hs @@ -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] diff --git a/test/SchemaSpec.hs b/test/SchemaSpec.hs --- a/test/SchemaSpec.hs +++ b/test/SchemaSpec.hs @@ -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