git.iko.soy/schematic
on master help sign in
Merge pull request #14 from AnisimoffNikita/master
d117450Denis Redozubov
schematic.cabal+7
compare with master
unifiedsplit
@@ -15,6 +15,8 @@ cabal-version: >=1.10
15library
15library
16 exposed-modules: Data.Schematic
16 exposed-modules: Data.Schematic
17 , Data.Schematic.DSL
17 , Data.Schematic.DSL
18+ , Data.Schematic.Generator
19+ , Data.Schematic.Generator.Regex
18 , Data.Schematic.Instances
20 , Data.Schematic.Instances
19 , Data.Schematic.JsonSchema
21 , Data.Schematic.JsonSchema
20 , Data.Schematic.Helpers
22 , Data.Schematic.Helpers
@@ -23,6 +25,11 @@ library
23 , Data.Schematic.Path
25 , Data.Schematic.Path
24 , Data.Schematic.Schema
26 , Data.Schematic.Schema
25 , Data.Schematic.Validation
27 , 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
26 ghc-options: -Wall
33 ghc-options: -Wall
27 default-extensions: ConstraintKinds
34 default-extensions: ConstraintKinds
28 , DataKinds
35 , 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 @@
4module Data.Schematic.Instances where
4module Data.Schematic.Instances where
5
5
6import Data.Scientific
6import Data.Scientific
7+import Data.Text (Text, pack)
7import Data.Vector as V
8import Data.Vector as V
8import Data.Vinyl
9import Data.Vinyl
9import Test.SmallCheck.Series
10import Test.SmallCheck.Series
@@ -21,3 +22,6 @@ instance Serial m a => Serial m (V.Vector a) where
21
22
22instance Monad m => Serial m Scientific where
23instance Monad m => Serial m Scientific where
23 series = scientific <$> series <*> series
24 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 @@
1module Data.Schematic.Path where
1module Data.Schematic.Path where
2
2
3import Data.Foldable as F
3import Data.Foldable as F
4−import Data.Monoid
5import Data.Singletons.Prelude
4import Data.Singletons.Prelude
6import Data.Singletons.TypeLits
5import Data.Singletons.TypeLits
7import Data.Text as T
6import Data.Text as T
src/Data/Schematic/Schema.hs+45−41
@@ -13,6 +13,7 @@ import Data.HashMap.Strict as H
13import Data.Kind
13import Data.Kind
14import Data.Maybe
14import Data.Maybe
15import Data.Schematic.Instances ()
15import Data.Schematic.Instances ()
16+import Data.Schematic.Generator
16import Data.Scientific
17import Data.Scientific
17import Data.Singletons.Prelude.List hiding (All, Union)
18import Data.Singletons.Prelude.List hiding (All, Union)
18import Data.Singletons.TH
19import Data.Singletons.TH
@@ -24,7 +25,8 @@ import Data.Vinyl hiding (Dict)
24import qualified Data.Vinyl.TypeLevel as V
25import qualified Data.Vinyl.TypeLevel as V
25import GHC.Exts
26import GHC.Exts
26import GHC.Generics (Generic)
27import GHC.Generics (Generic)
28+import GHC.TypeLits
27−import GHC.TypeLits (SomeNat(..), SomeSymbol(..), someSymbolVal, someNatVal)
29+ (SomeNat(..), SomeSymbol(..), someNatVal, someSymbolVal)
28import Prelude as P
30import Prelude as P
29import Test.SmallCheck.Series
31import Test.SmallCheck.Series
30
32
@@ -56,25 +58,25 @@ instance SingKind TextConstraint where
56 STRegex s -> withKnownSymbol s (DTRegex $ T.pack $ symbolVal s)
58 STRegex s -> withKnownSymbol s (DTRegex $ T.pack $ symbolVal s)
57 STEnum s -> let
59 STEnum s -> let
58 d :: Sing (s :: [Symbol]) -> [Text]
60 d :: Sing (s :: [Symbol]) -> [Text]
59− d SNil = []
61+ d SNil = []
60 d (SCons ss@SSym fs) = T.pack (symbolVal ss) : d fs
62 d (SCons ss@SSym fs) = T.pack (symbolVal ss) : d fs
61 in DTEnum $ d s
63 in DTEnum $ d s
62 toSing = \case
64 toSing = \case
63 DTEq n -> case someNatVal n of
65 DTEq n -> case someNatVal n of
64 Just (SomeNat (_ :: Proxy n)) -> SomeSing (STEq (SNat :: Sing n))
66 Just (SomeNat (_ :: Proxy n)) -> SomeSing (STEq (SNat :: Sing n))
65− Nothing -> error "Negative singleton nat"
67+ Nothing -> error "Negative singleton nat"
66 DTLt n -> case someNatVal n of
68 DTLt n -> case someNatVal n of
67 Just (SomeNat (_ :: Proxy n)) -> SomeSing (STLt (SNat :: Sing n))
69 Just (SomeNat (_ :: Proxy n)) -> SomeSing (STLt (SNat :: Sing n))
68− Nothing -> error "Negative singleton nat"
70+ Nothing -> error "Negative singleton nat"
69 DTLe n -> case someNatVal n of
71 DTLe n -> case someNatVal n of
70 Just (SomeNat (_ :: Proxy n)) -> SomeSing (STLe (SNat :: Sing n))
72 Just (SomeNat (_ :: Proxy n)) -> SomeSing (STLe (SNat :: Sing n))
71− Nothing -> error "Negative singleton nat"
73+ Nothing -> error "Negative singleton nat"
72 DTGt n -> case someNatVal n of
74 DTGt n -> case someNatVal n of
73 Just (SomeNat (_ :: Proxy n)) -> SomeSing (STGt (SNat :: Sing n))
75 Just (SomeNat (_ :: Proxy n)) -> SomeSing (STGt (SNat :: Sing n))
74− Nothing -> error "Negative singleton nat"
76+ Nothing -> error "Negative singleton nat"
75 DTGe n -> case someNatVal n of
77 DTGe n -> case someNatVal n of
76 Just (SomeNat (_ :: Proxy n)) -> SomeSing (STGe (SNat :: Sing n))
78 Just (SomeNat (_ :: Proxy n)) -> SomeSing (STGe (SNat :: Sing n))
77− Nothing -> error "Negative singleton nat"
79+ Nothing -> error "Negative singleton nat"
78 DTRegex s -> case someSymbolVal (T.unpack s) of
80 DTRegex s -> case someSymbolVal (T.unpack s) of
79 SomeSymbol (_ :: Proxy n) -> SomeSing (STRegex (SSym :: Sing n))
81 SomeSymbol (_ :: Proxy n) -> SomeSing (STRegex (SSym :: Sing n))
80 DTEnum ss -> case toSing ss of
82 DTEnum ss -> case toSing ss of
@@ -88,7 +90,7 @@ data DemotedTextConstraint
88 | DTGe Integer
90 | DTGe Integer
89 | DTRegex Text
91 | DTRegex Text
90 | DTEnum [Text]
92 | DTEnum [Text]
91− deriving (Generic)
93+ deriving (Generic, Eq, Show)
92
94
93data instance Sing (tc :: TextConstraint) where
95data instance Sing (tc :: TextConstraint) where
94 STEq :: Sing n -> Sing ('TEq n)
96 STEq :: Sing n -> Sing ('TEq n)
@@ -129,7 +131,7 @@ data DemotedNumberConstraint
129 | DNGt Integer
131 | DNGt Integer
130 | DNGe Integer
132 | DNGe Integer
131 | DNEq Integer
133 | DNEq Integer
132− deriving (Generic)
134+ deriving (Generic, Eq, Show)
133
135
134data instance Sing (nc :: NumberConstraint) where
136data instance Sing (nc :: NumberConstraint) where
135 SNEq :: Sing n -> Sing ('NEq n)
137 SNEq :: Sing n -> Sing ('NEq n)
@@ -161,19 +163,19 @@ instance SingKind NumberConstraint where
161 toSing = \case
163 toSing = \case
162 DNEq n -> case someNatVal n of
164 DNEq n -> case someNatVal n of
163 Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNEq (SNat :: Sing n))
165 Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNEq (SNat :: Sing n))
164− Nothing -> error "Negative singleton nat"
166+ Nothing -> error "Negative singleton nat"
165 DNGt n -> case someNatVal n of
167 DNGt n -> case someNatVal n of
166 Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNGt (SNat :: Sing n))
168 Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNGt (SNat :: Sing n))
167− Nothing -> error "Negative singleton nat"
169+ Nothing -> error "Negative singleton nat"
168 DNGe n -> case someNatVal n of
170 DNGe n -> case someNatVal n of
169 Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNGe (SNat :: Sing n))
171 Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNGe (SNat :: Sing n))
170− Nothing -> error "Negative singleton nat"
172+ Nothing -> error "Negative singleton nat"
171 DNLt n -> case someNatVal n of
173 DNLt n -> case someNatVal n of
172 Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNLt (SNat :: Sing n))
174 Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNLt (SNat :: Sing n))
173− Nothing -> error "Negative singleton nat"
175+ Nothing -> error "Negative singleton nat"
174 DNLe n -> case someNatVal n of
176 DNLe n -> case someNatVal n of
175 Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNLe (SNat :: Sing n))
177 Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNLe (SNat :: Sing n))
176− Nothing -> error "Negative singleton nat"
178+ Nothing -> error "Negative singleton nat"
177
179
178data ArrayConstraint
180data ArrayConstraint
179 = AEq Nat
181 = AEq Nat
@@ -181,7 +183,7 @@ data ArrayConstraint
181
183
182data DemotedArrayConstraint
184data DemotedArrayConstraint
183 = DAEq Integer
185 = DAEq Integer
184− deriving (Generic)
186+ deriving (Generic, Eq, Show)
185
187
186data instance Sing (ac :: ArrayConstraint) where
188data instance Sing (ac :: ArrayConstraint) where
187 SAEq :: Sing n -> Sing ('AEq n)
189 SAEq :: Sing n -> Sing ('AEq n)
@@ -197,7 +199,7 @@ instance SingKind ArrayConstraint where
197 toSing = \case
199 toSing = \case
198 DAEq n -> case someNatVal n of
200 DAEq n -> case someNatVal n of
199 Just (SomeNat (_ :: Proxy n)) -> SomeSing (SAEq (SNat :: Sing n))
201 Just (SomeNat (_ :: Proxy n)) -> SomeSing (SAEq (SNat :: Sing n))
200− Nothing -> error "Negative singleton nat"
202+ Nothing -> error "Negative singleton nat"
201
203
202data Schema
204data Schema
203 = SchemaText [TextConstraint]
205 = SchemaText [TextConstraint]
@@ -219,7 +221,7 @@ data DemotedSchema
219 | DSchemaNull
221 | DSchemaNull
220 | DSchemaOptional DemotedSchema
222 | DSchemaOptional DemotedSchema
221 | DSchemaUnion [DemotedSchema]
223 | DSchemaUnion [DemotedSchema]
222− deriving (Generic)
224+ deriving (Generic, Eq, Show)
223
225
224data instance Sing (schema :: Schema) where
226data instance Sing (schema :: Schema) where
225 SSchemaText :: Sing tcs -> Sing ('SchemaText tcs)
227 SSchemaText :: Sing tcs -> Sing ('SchemaText tcs)
@@ -334,6 +336,31 @@ data JsonRepr :: Schema -> Type where
334 ReprOptional :: Maybe (JsonRepr s) -> JsonRepr ('SchemaOptional s)
336 ReprOptional :: Maybe (JsonRepr s) -> JsonRepr ('SchemaOptional s)
335 ReprUnion :: Union JsonRepr (h ': tl) -> JsonRepr ('SchemaUnion (h ': tl))
337 ReprUnion :: Union JsonRepr (h ': tl) -> JsonRepr ('SchemaUnion (h ': tl))
336
338
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+
337-- | Move to the union package
364-- | Move to the union package
338instance Show (JsonRepr ('SchemaText cs)) where
365instance Show (JsonRepr ('SchemaText cs)) where
339 show (ReprText t) = "ReprText " P.++ show t
366 show (ReprText t) = "ReprText " P.++ show t
@@ -352,29 +379,6 @@ instance V.RecAll FieldRepr fs Show => Show (JsonRepr ('SchemaObject fs)) where
352instance Show (JsonRepr s) => Show (JsonRepr ('SchemaOptional s)) where
379instance Show (JsonRepr s) => Show (JsonRepr ('SchemaOptional s)) where
353 show (ReprOptional s) = "ReprOptional " P.++ show s
380 show (ReprOptional s) = "ReprOptional " P.++ show s
354
381
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−
378instance Eq (Rec FieldRepr fs) => Eq (JsonRepr ('SchemaObject fs)) where
382instance Eq (Rec FieldRepr fs) => Eq (JsonRepr ('SchemaObject fs)) where
379 ReprObject a == ReprObject b = a == b
383 ReprObject a == ReprObject b = a == b
380
384
@@ -502,7 +506,7 @@ instance J.ToJSON (JsonRepr a) where
502 toJSON (ReprText t) = J.String t
506 toJSON (ReprText t) = J.String t
503 toJSON (ReprNumber n) = J.Number n
507 toJSON (ReprNumber n) = J.Number n
504 toJSON (ReprOptional s) = case s of
508 toJSON (ReprOptional s) = case s of
505− Just v -> toJSON v
509+ Just v -> toJSON v
506 Nothing -> J.Null
510 Nothing -> J.Null
507 toJSON (ReprArray v) = J.Array $ toJSON <$> v
511 toJSON (ReprArray v) = J.Array $ toJSON <$> v
508 toJSON (ReprObject r) = J.Object . H.fromList . fold $ r
512 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
64 STLt n -> do
64 STLt n -> do
65 let
65 let
66 nlen = withKnownNat n $ natVal n
66 nlen = withKnownNat n $ natVal n
67− predicate = nlen < (fromIntegral $ T.length t)
67+ predicate = nlen > (fromIntegral $ T.length t)
68 errMsg = "length of " <> path <> " should be < " <> T.pack (show nlen)
68 errMsg = "length of " <> path <> " should be < " <> T.pack (show nlen)
69 warn = vWarning $ mmSingleton path (pure errMsg)
69 warn = vWarning $ mmSingleton path (pure errMsg)
70 unless predicate warn
70 unless predicate warn
71 STLe n -> do
71 STLe n -> do
72 let
72 let
73 nlen = withKnownNat n $ natVal n
73 nlen = withKnownNat n $ natVal n
74− predicate = nlen <= (fromIntegral $ T.length t)
74+ predicate = nlen >= (fromIntegral $ T.length t)
75 errMsg = "length of " <> path <> " should be <= " <> T.pack (show nlen)
75 errMsg = "length of " <> path <> " should be <= " <> T.pack (show nlen)
76 warn = vWarning $ mmSingleton path (pure errMsg)
76 warn = vWarning $ mmSingleton path (pure errMsg)
77 unless predicate warn
77 unless predicate warn
78 STGt n -> do
78 STGt n -> do
79 let
79 let
80 nlen = withKnownNat n $ natVal n
80 nlen = withKnownNat n $ natVal n
81− predicate = nlen > (fromIntegral $ T.length t)
81+ predicate = nlen < (fromIntegral $ T.length t)
82 errMsg = "length of " <> path <> " should be > " <> T.pack (show nlen)
82 errMsg = "length of " <> path <> " should be > " <> T.pack (show nlen)
83 warn = vWarning $ mmSingleton path (pure errMsg)
83 warn = vWarning $ mmSingleton path (pure errMsg)
84 unless predicate warn
84 unless predicate warn
85 STGe n -> do
85 STGe n -> do
86 let
86 let
87 nlen = withKnownNat n $ natVal n
87 nlen = withKnownNat n $ natVal n
88− predicate = nlen >= (fromIntegral $ T.length t)
88+ predicate = nlen <= (fromIntegral $ T.length t)
89 errMsg = "length of " <> path <> " should be >= " <> T.pack (show nlen)
89 errMsg = "length of " <> path <> " should be >= " <> T.pack (show nlen)
90 warn = vWarning $ mmSingleton path (pure errMsg)
90 warn = vWarning $ mmSingleton path (pure errMsg)
91 unless predicate warn
91 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
17import Data.Functor.Identity
17import Data.Functor.Identity
18import Data.Proxy
18import Data.Proxy
19import Data.Schematic
19import Data.Schematic
20+import Data.Schematic.Generator
21+import Data.Singletons
20import Data.Tagged
22import Data.Tagged
21import Data.Vinyl
23import Data.Vinyl
22import Test.Hspec
24import 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
23
29
30+import Debug.Trace
24
31
25type SchemaExample = 'SchemaObject
32type SchemaExample = 'SchemaObject
26 '[ '("foo", 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10]))
33 '[ '("foo", 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10]))
27 , '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))]
34 , '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))]
28
35
36+type SchemaExample2 = 'SchemaObject
37+ '[ '("foo", 'SchemaArray '[ 'AEq 2] ('SchemaText '[ 'TGt 10]))
38+ , '("bar", 'SchemaOptional ('SchemaText '[ 'TRegex "[0-9]+"]))]
39+
29jsonExample :: JsonRepr SchemaExample
40jsonExample :: JsonRepr SchemaExample
30jsonExample = withRepr @SchemaExample
41jsonExample = withRepr @SchemaExample
31 $ field @"bar" (Just "bar")
42 $ field @"bar" (Just "bar")
@@ -69,6 +80,12 @@ schemaJson = "{\"foo\": [13], \"bar\": null}"
69schemaJson2 :: ByteString
80schemaJson2 :: ByteString
70schemaJson2 = "{\"foo\": [3], \"bar\": null}"
81schemaJson2 = "{\"foo\": [3], \"bar\": null}"
71
82
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+
72spec :: Spec
89spec :: Spec
73spec = do
90spec = do
74 -- it "show/read JsonRepr properly" $
91 -- it "show/read JsonRepr properly" $
@@ -93,6 +110,13 @@ spec = do
93 migrationList
110 migrationList
94 schemaJson
111 schemaJson
95 `shouldSatisfy` isValid
112 `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+
96
120
97main :: IO ()
121main :: IO ()
98main = hspec spec
122main = hspec spec