git.iko.soy/typeable/schematic
on master help sign in
Merge pull request #14 from AnisimoffNikita/master

Schema generator

commitd117450b5394e9b2546b98cc14cc6f105f94351a authorDenis Redozubov <denis.redozubov@gmail.com> dateWed 20 Feb 2019, 11:38 (8 years ago) parent868dab9a8ac1ae
14 files changed+552−46
compare with master
unifiedsplit
schematic.cabal+7 src/Data/Schematic/Generator.hs+91 src/Data/Schematic/Generator/Regex.hs+76 src/Data/Schematic/Instances.hs+4 src/Data/Schematic/Path.hs−1 src/Data/Schematic/Schema.hs+45−41 src/Data/Schematic/Schema.hs-boot+87 src/Data/Schematic/Validation.hs+4−4 src/Data/Schematic/Verifier.hs+5 src/Data/Schematic/Verifier/Array.hs+14 src/Data/Schematic/Verifier/Common.hs+43 src/Data/Schematic/Verifier/Number.hs+31 src/Data/Schematic/Verifier/Text.hs+121 test/SchemaSpec.hs+24
schematic.cabal+7
@@ -15,6 +15,8 @@ cabal-version: >=1.10
1515library
1616 exposed-modules: Data.Schematic
1717 , Data.Schematic.DSL
18+ , Data.Schematic.Generator
19+ , Data.Schematic.Generator.Regex
1820 , Data.Schematic.Instances
1921 , Data.Schematic.JsonSchema
2022 , Data.Schematic.Helpers
@@ -23,6 +25,11 @@ library
2325 , Data.Schematic.Path
2426 , Data.Schematic.Schema
2527 , Data.Schematic.Validation
28+ , Data.Schematic.Verifier
29+ , Data.Schematic.Verifier.Array
30+ , Data.Schematic.Verifier.Common
31+ , Data.Schematic.Verifier.Number
32+ , Data.Schematic.Verifier.Text
2633 ghc-options: -Wall
2734 default-extensions: ConstraintKinds
2835 , DataKinds
src/Data/Schematic/Generator.hsnew file+91
@@ -0,0 +1,91 @@
1+module Data.Schematic.Generator where
2+
3+import Data.Maybe
4+import Data.Schematic.Generator.Regex
5+import {-# SOURCE #-} Data.Schematic.Schema
6+import Data.Schematic.Verifier
7+import Data.Scientific
8+import Data.Text (Text, pack)
9+import qualified Data.Vector as V
10+import Test.SmallCheck.Series
11+
12+maxHigh :: Int
13+maxHigh = 30
14+
15+minLow :: Int
16+minLow = 2
17+
18+textLengthSeries :: Monad m => [VerifiedTextConstraint] -> Series m Text
19+textLengthSeries =
20+ \case
21+ [VTEq eq] -> pure $ pack $ take (fromIntegral eq) $ cycle "sample"
22+ [VTBounds ml mh] -> do
23+ let
24+ l = fromMaybe minLow (fromIntegral <$> ml) + 1
25+ h = fromMaybe maxHigh (fromIntegral <$> mh) - 1
26+ n <- generate $ \depth -> take depth [l .. h]
27+ pure $ pack $ take (fromIntegral n) $ cycle "sample"
28+ _ -> pure "error"
29+
30+textEnumSeries :: Monad m => [Text] -> Series m Text
31+textEnumSeries enum = generate $ \depth -> take depth enum
32+
33+textSeries :: Monad m => [DemotedTextConstraint] -> Series m Text
34+textSeries cs = do
35+ let mvcs = verifyTextConstraints cs
36+ case mvcs of
37+ Just vcs -> do
38+ n <- textSeries' vcs
39+ pure n
40+ Nothing -> pure "error"
41+
42+textSeries' :: Monad m => [VerifiedTextConstraint] -> Series m Text
43+textSeries' [] = pure "sample"
44+textSeries' vcs = do
45+ let enums = listToMaybe [x | VTEnum x <- vcs]
46+ case enums of
47+ Just e -> textEnumSeries e
48+ Nothing -> do
49+ let regexps = listToMaybe [x | VTRegex x _ _ <- vcs]
50+ case regexps of
51+ Just e -> regexSeries e
52+ Nothing -> textLengthSeries vcs
53+
54+numberSeries :: Monad m => [DemotedNumberConstraint] -> Series m Scientific
55+numberSeries cs = do
56+ let mvcs = verifyNumberConstraints cs
57+ case mvcs of
58+ Just vcs -> do
59+ n <- numberSeries' vcs
60+ pure $ n
61+ Nothing -> pure 0
62+
63+numberSeries' :: Monad m => VerifiedNumberConstraint -> Series m Scientific
64+numberSeries' =
65+ \case
66+ VNEq eq -> pure $ fromIntegral eq
67+ VNBounds ml mh -> do
68+ let l = fromMaybe minLow (fromIntegral <$> ml) + 1
69+ h = fromMaybe maxHigh (fromIntegral <$> mh) - 1
70+ n <- generate $ \depth -> take depth [l .. h]
71+ pure $ fromIntegral n
72+
73+arraySeries
74+ :: (Monad m, Serial m (JsonRepr s))
75+ => [DemotedArrayConstraint]
76+ -> Series m (V.Vector (JsonRepr s))
77+arraySeries cs = do
78+ let mvcs = verifyArrayConstraint cs
79+ case mvcs of
80+ Just vcs -> arraySeries' vcs
81+ Nothing -> pure V.empty
82+
83+arraySeries'
84+ :: forall m s. (Monad m, Serial m (JsonRepr s))
85+ => Maybe VerifiedArrayConstraint
86+ -> Series m (V.Vector (JsonRepr s))
87+arraySeries' ml = do
88+ objs <- V.replicateM (maybe minRepeat f ml) (series :: Series m (JsonRepr s))
89+ pure $ objs
90+ where
91+ f (VAEq l) = fromIntegral l
src/Data/Schematic/Generator/Regex.hsnew file+76
@@ -0,0 +1,76 @@
1+module Data.Schematic.Generator.Regex where
2+
3+import Control.Monad
4+import Data.List
5+import Data.Maybe
6+import qualified Data.Set as S
7+import Data.Text (Text, unpack)
8+import Data.Text.Lazy (toStrict)
9+import Data.Text.Lazy.Builder (Builder, singleton, toLazyText)
10+import Test.SmallCheck.Series
11+import Text.Regex.TDFA.Pattern
12+import Text.Regex.TDFA.ReadRegex (parseRegex)
13+
14+
15+minRepeat :: Int
16+minRepeat = 2
17+
18+maxRepeat :: Int
19+maxRepeat = 10
20+
21+regexSeries :: (Monad m) => Text -> Series m Text
22+regexSeries regexp =
23+ case parseRegex . unpack $ regexp of
24+ Right (p, _) -> toStrict . toLazyText <$> regexSeries' p
25+ Left _ -> pure ""
26+
27+regexSeries' :: (Monad m) => Pattern -> Series m Builder
28+regexSeries' pt =
29+ case pt of
30+ PEmpty -> pure mempty
31+ PChar {..} -> pure $ singleton getPatternChar
32+ PAny {getPatternSet = PatternSet (Just cset) _ _ _} -> do
33+ x <- generate $ \depth -> take depth $ S.toList cset
34+ pure $ singleton x
35+ PAnyNot {getPatternSet = PatternSet (Just cset) _ _ _} -> do
36+ x <-
37+ generate $ \depth ->
38+ take depth $ notChars $ concatMap expandEscape $ S.toList cset
39+ pure $ singleton x
40+ PQuest p -> regexSeries' p \/ pure mempty
41+ PPlus p -> regexSeries' $ PBound 1 Nothing p
42+ PStar _ p -> regexSeries' $ PBound 0 Nothing p
43+ PBound low mhigh p -> do
44+ let high = fromMaybe (low + maxRepeat) mhigh
45+ n <- generate $ \depth -> take depth [low .. high]
46+ decDepth $ do
47+ ps <- replicateM n $ regexSeries' p
48+ pure $ mconcat ps
49+ PConcat ps -> mconcat <$> mapM regexSeries' ps
50+ POr xs -> regexSeries' =<< (generate $ \depth -> take depth xs)
51+ PDot _ -> do
52+ x <- generate $ \depth -> take depth $ notChars []
53+ pure $ singleton x
54+ PEscape {..} -> do
55+ x <- generate $ \depth -> take depth $ expandEscape getPatternChar
56+ pure $ singleton x
57+ PCarat _ -> pure mempty
58+ PDollar _ -> pure mempty
59+ _ -> pure mempty
60+ where
61+ notChars = ([' ' .. '~'] \\)
62+ expandEscape ch =
63+ case ch of
64+ 'n' -> "\n"
65+ 't' -> "\t"
66+ 'r' -> "\r"
67+ 'f' -> "\f"
68+ 'a' -> "\a"
69+ 'e' -> "\ESC"
70+ 'd' -> ['0' .. '9']
71+ 'w' -> ['0' .. '9'] ++ '_' : ['a' .. 'z'] ++ ['A' .. 'Z']
72+ 's' -> "\9\32"
73+ 'D' -> notChars $ ['0' .. '9']
74+ 'W' -> notChars $ ['0' .. '9'] ++ '_' : ['a' .. 'z'] ++ ['A' .. 'Z']
75+ 'S' -> notChars "\9\32"
76+ ch' -> [ch']
src/Data/Schematic/Instances.hs+4
@@ -4,6 +4,7 @@
44module Data.Schematic.Instances where
55
66import Data.Scientific
7+import Data.Text (Text, pack)
78import Data.Vector as V
89import Data.Vinyl
910import Test.SmallCheck.Series
@@ -21,3 +22,6 @@ instance Serial m a => Serial m (V.Vector a) where
2122
2223instance Monad m => Serial m Scientific where
2324 series = scientific <$> series <*> series
25+
26+instance Monad m => Serial m Text where
27+ series = pack <$> series
src/Data/Schematic/Path.hs−1
@@ -1,7 +1,6 @@
11module Data.Schematic.Path where
22
33import Data.Foldable as F
4−import Data.Monoid
54import Data.Singletons.Prelude
65import Data.Singletons.TypeLits
76import Data.Text as T
src/Data/Schematic/Schema.hs+45−41
@@ -13,6 +13,7 @@ import Data.HashMap.Strict as H
1313import Data.Kind
1414import Data.Maybe
1515import Data.Schematic.Instances ()
16+import Data.Schematic.Generator
1617import Data.Scientific
1718import Data.Singletons.Prelude.List hiding (All, Union)
1819import Data.Singletons.TH
@@ -24,7 +25,8 @@ import Data.Vinyl hiding (Dict)
2425import qualified Data.Vinyl.TypeLevel as V
2526import GHC.Exts
2627import GHC.Generics (Generic)
27−import GHC.TypeLits (SomeNat(..), SomeSymbol(..), someSymbolVal, someNatVal)
28+import GHC.TypeLits
29+ (SomeNat(..), SomeSymbol(..), someNatVal, someSymbolVal)
2830import Prelude as P
2931import Test.SmallCheck.Series
3032
@@ -56,25 +58,25 @@ instance SingKind TextConstraint where
5658 STRegex s -> withKnownSymbol s (DTRegex $ T.pack $ symbolVal s)
5759 STEnum s -> let
5860 d :: Sing (s :: [Symbol]) -> [Text]
59− d SNil = []
61+ d SNil = []
6062 d (SCons ss@SSym fs) = T.pack (symbolVal ss) : d fs
6163 in DTEnum $ d s
6264 toSing = \case
6365 DTEq n -> case someNatVal n of
6466 Just (SomeNat (_ :: Proxy n)) -> SomeSing (STEq (SNat :: Sing n))
65− Nothing -> error "Negative singleton nat"
67+ Nothing -> error "Negative singleton nat"
6668 DTLt n -> case someNatVal n of
6769 Just (SomeNat (_ :: Proxy n)) -> SomeSing (STLt (SNat :: Sing n))
68− Nothing -> error "Negative singleton nat"
70+ Nothing -> error "Negative singleton nat"
6971 DTLe n -> case someNatVal n of
7072 Just (SomeNat (_ :: Proxy n)) -> SomeSing (STLe (SNat :: Sing n))
71− Nothing -> error "Negative singleton nat"
73+ Nothing -> error "Negative singleton nat"
7274 DTGt n -> case someNatVal n of
7375 Just (SomeNat (_ :: Proxy n)) -> SomeSing (STGt (SNat :: Sing n))
74− Nothing -> error "Negative singleton nat"
76+ Nothing -> error "Negative singleton nat"
7577 DTGe n -> case someNatVal n of
7678 Just (SomeNat (_ :: Proxy n)) -> SomeSing (STGe (SNat :: Sing n))
77− Nothing -> error "Negative singleton nat"
79+ Nothing -> error "Negative singleton nat"
7880 DTRegex s -> case someSymbolVal (T.unpack s) of
7981 SomeSymbol (_ :: Proxy n) -> SomeSing (STRegex (SSym :: Sing n))
8082 DTEnum ss -> case toSing ss of
@@ -88,7 +90,7 @@ data DemotedTextConstraint
8890 | DTGe Integer
8991 | DTRegex Text
9092 | DTEnum [Text]
91− deriving (Generic)
93+ deriving (Generic, Eq, Show)
9294
9395data instance Sing (tc :: TextConstraint) where
9496 STEq :: Sing n -> Sing ('TEq n)
@@ -129,7 +131,7 @@ data DemotedNumberConstraint
129131 | DNGt Integer
130132 | DNGe Integer
131133 | DNEq Integer
132− deriving (Generic)
134+ deriving (Generic, Eq, Show)
133135
134136data instance Sing (nc :: NumberConstraint) where
135137 SNEq :: Sing n -> Sing ('NEq n)
@@ -161,19 +163,19 @@ instance SingKind NumberConstraint where
161163 toSing = \case
162164 DNEq n -> case someNatVal n of
163165 Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNEq (SNat :: Sing n))
164− Nothing -> error "Negative singleton nat"
166+ Nothing -> error "Negative singleton nat"
165167 DNGt n -> case someNatVal n of
166168 Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNGt (SNat :: Sing n))
167− Nothing -> error "Negative singleton nat"
169+ Nothing -> error "Negative singleton nat"
168170 DNGe n -> case someNatVal n of
169171 Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNGe (SNat :: Sing n))
170− Nothing -> error "Negative singleton nat"
172+ Nothing -> error "Negative singleton nat"
171173 DNLt n -> case someNatVal n of
172174 Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNLt (SNat :: Sing n))
173− Nothing -> error "Negative singleton nat"
175+ Nothing -> error "Negative singleton nat"
174176 DNLe n -> case someNatVal n of
175177 Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNLe (SNat :: Sing n))
176− Nothing -> error "Negative singleton nat"
178+ Nothing -> error "Negative singleton nat"
177179
178180data ArrayConstraint
179181 = AEq Nat
@@ -181,7 +183,7 @@ data ArrayConstraint
181183
182184data DemotedArrayConstraint
183185 = DAEq Integer
184− deriving (Generic)
186+ deriving (Generic, Eq, Show)
185187
186188data instance Sing (ac :: ArrayConstraint) where
187189 SAEq :: Sing n -> Sing ('AEq n)
@@ -197,7 +199,7 @@ instance SingKind ArrayConstraint where
197199 toSing = \case
198200 DAEq n -> case someNatVal n of
199201 Just (SomeNat (_ :: Proxy n)) -> SomeSing (SAEq (SNat :: Sing n))
200− Nothing -> error "Negative singleton nat"
202+ Nothing -> error "Negative singleton nat"
201203
202204data Schema
203205 = SchemaText [TextConstraint]
@@ -219,7 +221,7 @@ data DemotedSchema
219221 | DSchemaNull
220222 | DSchemaOptional DemotedSchema
221223 | DSchemaUnion [DemotedSchema]
222− deriving (Generic)
224+ deriving (Generic, Eq, Show)
223225
224226data instance Sing (schema :: Schema) where
225227 SSchemaText :: Sing tcs -> Sing ('SchemaText tcs)
@@ -334,6 +336,31 @@ data JsonRepr :: Schema -> Type where
334336 ReprOptional :: Maybe (JsonRepr s) -> JsonRepr ('SchemaOptional s)
335337 ReprUnion :: Union JsonRepr (h ': tl) -> JsonRepr ('SchemaUnion (h ': tl))
336338
339+instance (Monad m, Serial m Text, SingI cs)
340+ => Serial m (JsonRepr ('SchemaText cs)) where
341+ series = decDepth $ fmap ReprText $ textSeries $ fromSing (sing :: Sing cs)
342+
343+instance (Monad m, Serial m Scientific, SingI cs)
344+ => Serial m (JsonRepr ('SchemaNumber cs)) where
345+ series = decDepth $ fmap ReprNumber
346+ $ numberSeries $ fromSing (sing :: Sing cs)
347+
348+instance Monad m => Serial m (JsonRepr 'SchemaNull) where
349+ series = cons0 ReprNull
350+
351+instance (Serial m (JsonRepr s), Serial m (V.Vector (JsonRepr s)), SingI cs)
352+ => Serial m (JsonRepr ('SchemaArray cs s)) where
353+ series = decDepth $ fmap ReprArray
354+ $ arraySeries $ fromSing (sing :: Sing cs)
355+
356+instance (Serial m (JsonRepr s))
357+ => Serial m (JsonRepr ('SchemaOptional s)) where
358+ series = cons1 ReprOptional
359+
360+instance (Monad m, Serial m (Rec FieldRepr fs))
361+ => Serial m (JsonRepr ('SchemaObject fs)) where
362+ series = cons1 ReprObject
363+
337364-- | Move to the union package
338365instance Show (JsonRepr ('SchemaText cs)) where
339366 show (ReprText t) = "ReprText " P.++ show t
@@ -352,29 +379,6 @@ instance V.RecAll FieldRepr fs Show => Show (JsonRepr ('SchemaObject fs)) where
352379instance Show (JsonRepr s) => Show (JsonRepr ('SchemaOptional s)) where
353380 show (ReprOptional s) = "ReprOptional " P.++ show s
354381
355−instance (Monad m, Serial m Text)
356− => Serial m (JsonRepr ('SchemaText cs)) where
357− series = cons1 ReprText
358−
359−instance (Monad m, Serial m Scientific)
360− => Serial m (JsonRepr ('SchemaNumber cs)) where
361− series = cons1 ReprNumber
362−
363−instance Monad m => Serial m (JsonRepr 'SchemaNull) where
364− series = cons0 ReprNull
365−
366−instance (Serial m (V.Vector (JsonRepr s)))
367− => Serial m (JsonRepr ('SchemaArray cs s)) where
368− series = cons1 ReprArray
369−
370−instance (Serial m (JsonRepr s))
371− => Serial m (JsonRepr ('SchemaOptional s)) where
372− series = cons1 ReprOptional
373−
374−instance (Monad m, Serial m (Rec FieldRepr fs))
375− => Serial m (JsonRepr ('SchemaObject fs)) where
376− series = cons1 ReprObject
377−
378382instance Eq (Rec FieldRepr fs) => Eq (JsonRepr ('SchemaObject fs)) where
379383 ReprObject a == ReprObject b = a == b
380384
@@ -502,7 +506,7 @@ instance J.ToJSON (JsonRepr a) where
502506 toJSON (ReprText t) = J.String t
503507 toJSON (ReprNumber n) = J.Number n
504508 toJSON (ReprOptional s) = case s of
505− Just v -> toJSON v
509+ Just v -> toJSON v
506510 Nothing -> J.Null
507511 toJSON (ReprArray v) = J.Array $ toJSON <$> v
508512 toJSON (ReprObject r) = J.Object . H.fromList . fold $ r
src/Data/Schematic/Schema.hs-bootnew file+87
@@ -0,0 +1,87 @@
1+module Data.Schematic.Schema where
2+
3+import Data.Kind
4+import Data.Maybe
5+import Data.Schematic.Instances ()
6+import Data.Scientific
7+import Data.Singletons.TH
8+import Data.Singletons.TypeLits
9+import Data.Text as T
10+import Data.Union
11+import Data.Vector as V
12+import Data.Vinyl hiding (Dict)
13+import Prelude as P
14+
15+data TextConstraint
16+ = TEq Nat
17+ | TLt Nat
18+ | TLe Nat
19+ | TGt Nat
20+ | TGe Nat
21+ | TRegex Symbol
22+ | TEnum [Symbol]
23+
24+data DemotedTextConstraint
25+ = DTEq Integer
26+ | DTLt Integer
27+ | DTLe Integer
28+ | DTGt Integer
29+ | DTGe Integer
30+ | DTRegex Text
31+ | DTEnum [Text]
32+
33+data NumberConstraint
34+ = NLe Nat
35+ | NLt Nat
36+ | NGt Nat
37+ | NGe Nat
38+ | NEq Nat
39+
40+data DemotedNumberConstraint
41+ = DNLe Integer
42+ | DNLt Integer
43+ | DNGt Integer
44+ | DNGe Integer
45+ | DNEq Integer
46+
47+data ArrayConstraint
48+ = AEq Nat
49+
50+data DemotedArrayConstraint
51+ = DAEq Integer
52+
53+data Schema
54+ = SchemaText [TextConstraint]
55+ | SchemaBoolean
56+ | SchemaNumber [NumberConstraint]
57+ | SchemaObject [(Symbol, Schema)]
58+ | SchemaArray [ArrayConstraint] Schema
59+ | SchemaNull
60+ | SchemaOptional Schema
61+ | SchemaUnion [Schema]
62+
63+data DemotedSchema
64+ = DSchemaText [DemotedTextConstraint]
65+ | DSchemaNumber [DemotedNumberConstraint]
66+ | DSchemaBoolean
67+ | DSchemaObject [(Text, DemotedSchema)]
68+ | DSchemaArray [DemotedArrayConstraint] DemotedSchema
69+ | DSchemaNull
70+ | DSchemaOptional DemotedSchema
71+ | DSchemaUnion [DemotedSchema]
72+
73+data FieldRepr :: (Symbol, Schema) -> Type where
74+ FieldRepr
75+ :: (SingI schema, KnownSymbol name)
76+ => JsonRepr schema
77+ -> FieldRepr '(name, schema)
78+
79+data JsonRepr :: Schema -> Type where
80+ ReprText :: Text -> JsonRepr ('SchemaText cs)
81+ ReprNumber :: Scientific -> JsonRepr ('SchemaNumber cs)
82+ ReprBoolean :: Bool -> JsonRepr 'SchemaBoolean
83+ ReprNull :: JsonRepr 'SchemaNull
84+ ReprArray :: V.Vector (JsonRepr s) -> JsonRepr ('SchemaArray cs s)
85+ ReprObject :: Rec FieldRepr fs -> JsonRepr ('SchemaObject fs)
86+ ReprOptional :: Maybe (JsonRepr s) -> JsonRepr ('SchemaOptional s)
87+ ReprUnion :: Union JsonRepr (h ': tl) -> JsonRepr ('SchemaUnion (h ': tl))
src/Data/Schematic/Validation.hs+4−4
@@ -64,28 +64,28 @@ validateTextConstraint (JSONPath path) t = \case
6464 STLt n -> do
6565 let
6666 nlen = withKnownNat n $ natVal n
67− predicate = nlen < (fromIntegral $ T.length t)
67+ predicate = nlen > (fromIntegral $ T.length t)
6868 errMsg = "length of " <> path <> " should be < " <> T.pack (show nlen)
6969 warn = vWarning $ mmSingleton path (pure errMsg)
7070 unless predicate warn
7171 STLe n -> do
7272 let
7373 nlen = withKnownNat n $ natVal n
74− predicate = nlen <= (fromIntegral $ T.length t)
74+ predicate = nlen >= (fromIntegral $ T.length t)
7575 errMsg = "length of " <> path <> " should be <= " <> T.pack (show nlen)
7676 warn = vWarning $ mmSingleton path (pure errMsg)
7777 unless predicate warn
7878 STGt n -> do
7979 let
8080 nlen = withKnownNat n $ natVal n
81− predicate = nlen > (fromIntegral $ T.length t)
81+ predicate = nlen < (fromIntegral $ T.length t)
8282 errMsg = "length of " <> path <> " should be > " <> T.pack (show nlen)
8383 warn = vWarning $ mmSingleton path (pure errMsg)
8484 unless predicate warn
8585 STGe n -> do
8686 let
8787 nlen = withKnownNat n $ natVal n
88− predicate = nlen >= (fromIntegral $ T.length t)
88+ predicate = nlen <= (fromIntegral $ T.length t)
8989 errMsg = "length of " <> path <> " should be >= " <> T.pack (show nlen)
9090 warn = vWarning $ mmSingleton path (pure errMsg)
9191 unless predicate warn
src/Data/Schematic/Verifier.hsnew file+5
@@ -0,0 +1,5 @@
1+module Data.Schematic.Verifier (module X) where
2+
3+import Data.Schematic.Verifier.Array as X
4+import Data.Schematic.Verifier.Number as X
5+import Data.Schematic.Verifier.Text as X
src/Data/Schematic/Verifier/Array.hsnew file+14
@@ -0,0 +1,14 @@
1+module Data.Schematic.Verifier.Array where
2+
3+import {-# SOURCE #-} Data.Schematic.Schema
4+import Data.Schematic.Verifier.Common
5+
6+data VerifiedArrayConstraint =
7+ VAEq Integer
8+ deriving (Show)
9+
10+verifyArrayConstraint ::
11+ [DemotedArrayConstraint] -> Maybe (Maybe VerifiedArrayConstraint)
12+verifyArrayConstraint cs = do
13+ x <- verifyDNEq [x | DAEq x <- cs]
14+ pure $ VAEq <$> x
src/Data/Schematic/Verifier/Common.hsnew file+43
@@ -0,0 +1,43 @@
1+module Data.Schematic.Verifier.Common where
2+
3+import Data.List (nub)
4+
5+simplifyNumberConstraint :: ([Integer] -> Integer) -> [Integer] -> Maybe Integer
6+simplifyNumberConstraint f =
7+ \case
8+ [] -> Nothing
9+ x -> Just $ f x
10+
11+simplifyDNLs :: [Integer] -> Maybe Integer
12+simplifyDNLs = simplifyNumberConstraint minimum
13+
14+simplifyDNGs :: [Integer] -> Maybe Integer
15+simplifyDNGs = simplifyNumberConstraint maximum
16+
17+verifyDNEq :: [Integer] -> Maybe (Maybe Integer)
18+verifyDNEq x =
19+ case nub x of
20+ [] -> Just Nothing
21+ [y] -> Just $ Just y
22+ (_:_:_) -> Nothing
23+
24+verify3 :: Maybe Integer -> Maybe Integer -> Maybe Integer -> Maybe ()
25+verify3 (Just x) (Just y) (Just z) =
26+ if x < y && y < z
27+ then Just ()
28+ else Nothing
29+verify3 _ _ _ = Just ()
30+
31+verify2 :: Maybe Integer -> Maybe Integer -> Maybe ()
32+verify2 (Just x) (Just y) =
33+ if x < y
34+ then Just ()
35+ else Nothing
36+verify2 _ _ = Just ()
37+
38+verifyEquations :: Maybe Integer -> Maybe Integer -> Maybe Integer -> Maybe ()
39+verifyEquations mgt meq mlt = do
40+ verify3 mgt meq mlt
41+ verify2 mgt meq
42+ verify2 meq mlt
43+ verify2 mgt mlt
src/Data/Schematic/Verifier/Number.hsnew file+31
@@ -0,0 +1,31 @@
1+module Data.Schematic.Verifier.Number where
2+
3+import {-# SOURCE #-} Data.Schematic.Schema
4+import Data.Schematic.Verifier.Common
5+
6+toStrictNumber :: [DemotedNumberConstraint] -> [DemotedNumberConstraint]
7+toStrictNumber = map f
8+ where
9+ f (DNLe x) = DNLt (x + 1)
10+ f (DNGe x) = DNGt (x - 1)
11+ f x = x
12+
13+data VerifiedNumberConstraint
14+ = VNEq Integer
15+ | VNBounds (Maybe Integer) (Maybe Integer)
16+ deriving (Show)
17+
18+verifyNumberConstraints
19+ :: [DemotedNumberConstraint]
20+ -> Maybe VerifiedNumberConstraint
21+verifyNumberConstraints cs' = do
22+ let
23+ cs = toStrictNumber cs'
24+ mlt = simplifyDNLs [x | DNLt x <- cs]
25+ mgt = simplifyDNGs [x | DNGt x <- cs]
26+ meq <- verifyDNEq [x | DNEq x <- cs]
27+ verifyEquations mgt meq mlt
28+ Just $
29+ case meq of
30+ Just eq -> VNEq eq
31+ Nothing -> VNBounds mgt mlt
src/Data/Schematic/Verifier/Text.hsnew file+121
@@ -0,0 +1,121 @@
1+module Data.Schematic.Verifier.Text where
2+
3+import Control.Monad
4+import Data.Maybe
5+import {-# SOURCE #-} Data.Schematic.Schema
6+import Data.Schematic.Verifier.Common
7+import Data.Text (Text, unpack)
8+import Text.Regex.TDFA.Pattern
9+import Text.Regex.TDFA.ReadRegex (parseRegex)
10+
11+toStrictTextLength :: [DemotedTextConstraint] -> [DemotedTextConstraint]
12+toStrictTextLength = map f
13+ where
14+ f (DTLe x) = DTLt (x + 1)
15+ f (DTGe x) = DTGt (x - 1)
16+ f x = x
17+
18+data VerifiedTextConstraint
19+ = VTEq Integer
20+ | VTBounds (Maybe Integer) (Maybe Integer)
21+ | VTRegex Text Integer (Maybe Integer)
22+ | VTEnum [Text]
23+ deriving (Show)
24+
25+verifyTextLengthConstraints
26+ :: [DemotedTextConstraint]
27+ -> Maybe (Maybe VerifiedTextConstraint)
28+verifyTextLengthConstraints cs' = do
29+ let
30+ cs = toStrictTextLength cs'
31+ mlt = simplifyDNLs [x | DTLt x <- cs]
32+ mgt = simplifyDNGs [x | DTGt x <- cs]
33+ meq <- verifyDNEq [x | DTEq x <- cs]
34+ verifyEquations mgt meq mlt
35+ case all isNothing ([mgt, meq, mlt] :: [Maybe Integer]) of
36+ True -> Just Nothing
37+ _ ->
38+ Just $
39+ Just $
40+ case meq of
41+ Just eq -> VTEq eq
42+ Nothing -> VTBounds mgt mlt
43+
44+regexLength :: Text -> Maybe (Int, Maybe Int)
45+regexLength regexp =
46+ case parseRegex . unpack $ regexp of
47+ Right (p, _) -> Just (minRegexLength p, maxRegexLength p)
48+ Left _ -> Nothing
49+
50+minRegexLength :: Pattern -> Int
51+minRegexLength p =
52+ case p of
53+ PEmpty -> 0
54+ PChar {..} -> 1
55+ PAny {..} -> 1
56+ PAnyNot {..} -> 1
57+ PQuest _ -> 0
58+ PPlus sch -> minRegexLength $ PBound 1 Nothing sch
59+ PStar _ sch -> minRegexLength $ PBound 0 Nothing sch
60+ PBound low _ sch -> low * minRegexLength sch
61+ PConcat ps -> sum $ fmap minRegexLength ps
62+ POr xs -> minimum $ fmap minRegexLength xs
63+ PDot _ -> 1
64+ PEscape {..} -> 1
65+ PCarat _ -> 0
66+ PDollar _ -> 0
67+ _ -> 0
68+
69+maxRegexLength :: Pattern -> Maybe Int
70+maxRegexLength p =
71+ case p of
72+ PEmpty -> Just 0
73+ PChar _ _ -> Just 1
74+ PAny _ _ -> Just 1
75+ PAnyNot _ _ -> Just 1
76+ PQuest _ -> Just 0
77+ PPlus _ -> Nothing
78+ PStar _ _ -> Nothing
79+ PBound _ mhigh sch -> (*) <$> mhigh <*> maxRegexLength sch
80+ PConcat ps -> sum <$> mapM maxRegexLength ps
81+ POr xs -> maximum <$> mapM maxRegexLength xs
82+ PDot _ -> Just 1
83+ PEscape _ _ -> Just 1
84+ PCarat _ -> Just 0
85+ PDollar _ -> Just 0
86+ _ -> Just 0
87+
88+verifyTextRegexConstraint
89+ :: [DemotedTextConstraint]
90+ -> Maybe (Maybe VerifiedTextConstraint)
91+verifyTextRegexConstraint cs = do
92+ let regexps = [x | DTRegex x <- cs]
93+ case regexps of
94+ [] -> Just Nothing
95+ [x] -> do
96+ (l, mh) <- regexLength x
97+ Just $ Just $ VTRegex x (fromIntegral l) (fromIntegral <$> mh)
98+ _ -> Nothing
99+
100+verifyTextEnumConstraint
101+ :: [DemotedTextConstraint]
102+ -> Maybe (Maybe VerifiedTextConstraint)
103+verifyTextEnumConstraint cs = do
104+ let enums = concat [x | DTEnum x <- cs]
105+ case enums of
106+ [] -> Just Nothing
107+ x -> Just $ Just $ VTEnum x
108+
109+verifyTextConstraints
110+ :: [DemotedTextConstraint]
111+ -> Maybe [VerifiedTextConstraint]
112+verifyTextConstraints cs = do
113+ regexp <- verifyTextRegexConstraint cs
114+ void $
115+ case regexp of
116+ Just (VTRegex _ l mh) ->
117+ verifyTextLengthConstraints (DTGe l : cs ++ maybeToList (DTLe <$> mh))
118+ _ -> pure Nothing
119+ lengths <- verifyTextLengthConstraints cs
120+ enums <- verifyTextEnumConstraint cs
121+ return $ catMaybes [lengths, enums, regexp]
test/SchemaSpec.hs+24
@@ -17,15 +17,26 @@ import Data.ByteString.Lazy
1717import Data.Functor.Identity
1818import Data.Proxy
1919import Data.Schematic
20+import Data.Schematic.Generator
21+import Data.Singletons
2022import Data.Tagged
2123import Data.Vinyl
2224import Test.Hspec
25+import Test.Hspec.SmallCheck
26+import Test.SmallCheck as SC
27+import Test.SmallCheck.Drivers as SC
28+import Test.SmallCheck.Series as SC
2329
30+import Debug.Trace
2431
2532type SchemaExample = 'SchemaObject
2633 '[ '("foo", 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10]))
2734 , '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))]
2835
36+type SchemaExample2 = 'SchemaObject
37+ '[ '("foo", 'SchemaArray '[ 'AEq 2] ('SchemaText '[ 'TGt 10]))
38+ , '("bar", 'SchemaOptional ('SchemaText '[ 'TRegex "[0-9]+"]))]
39+
2940jsonExample :: JsonRepr SchemaExample
3041jsonExample = withRepr @SchemaExample
3142 $ field @"bar" (Just "bar")
@@ -69,6 +80,12 @@ schemaJson = "{\"foo\": [13], \"bar\": null}"
6980schemaJson2 :: ByteString
7081schemaJson2 = "{\"foo\": [3], \"bar\": null}"
7182
83+schemaJsonSeries :: Monad m => SC.Series m (JsonRepr SchemaExample)
84+schemaJsonSeries = series
85+
86+schemaJsonSeries2 :: Monad m => SC.Series m (JsonRepr SchemaExample2)
87+schemaJsonSeries2 = series
88+
7289spec :: Spec
7390spec = do
7491 -- it "show/read JsonRepr properly" $
@@ -93,6 +110,13 @@ spec = do
93110 migrationList
94111 schemaJson
95112 `shouldSatisfy` isValid
113+ it "validates json series" $ property $
114+ SC.over schemaJsonSeries $ \x ->
115+ isValid (parseAndValidateJson @SchemaExample (toJSON x))
116+ it "validates json series 2" $ property $
117+ SC.over schemaJsonSeries2 $ \x ->
118+ isValid (parseAndValidateJson @SchemaExample2 (toJSON x))
119+
96120
97121main :: IO ()
98122main = hspec spec