git.iko.soy/typeable/schematic
on master help sign in
wip
ad520f6Nikita
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+112
@@ -0,0 +1,112 @@
1+module Data.Schematic.Generator where
2+
3+import Control.Monad
4+import Data.Aeson (Object, Value(..))
5+import Data.HashMap.Lazy (HashMap)
6+import qualified Data.HashMap.Lazy as H
7+import Data.List
8+import Data.Maybe
9+import Data.Monoid
10+import Data.Schematic.Schema
11+import qualified Data.Set as S
12+import Data.Text (Text, pack, unpack)
13+import qualified Data.Text as T (replicate)
14+import Data.Text.Lazy (toStrict)
15+import Data.Text.Lazy.Builder (Builder, singleton, toLazyText)
16+import qualified Data.Vector as V
17+import Data.Schematic.Generator.Regex
18+import Data.Schematic.Verifier
19+import Test.SmallCheck
20+import Test.SmallCheck.Series
21+import Text.Regex.TDFA
22+import Text.Regex.TDFA.Pattern
23+import Text.Regex.TDFA.ReadRegex (parseRegex)
24+
25+maxHigh :: Int
26+maxHigh = 30
27+
28+minLow :: Int
29+minLow = 2
30+
31+textLengthSeries :: Monad m => [VerifiedTextConstraint] -> Series m Text
32+textLengthSeries =
33+ \case
34+ [VTEq eq] -> pure $ pack $ take (fromIntegral eq) $ cycle "sample"
35+ [VTBounds ml mh] -> do
36+ let l = fromMaybe minLow (fromIntegral <$> ml) + 1
37+ h = fromMaybe maxHigh (fromIntegral <$> mh) - 1
38+ n <- generate $ \depth -> take depth [l .. h]
39+ pure $ pack $ take (fromIntegral n) $ cycle "sample"
40+ _ -> pure "error"
41+
42+textEnumSeries :: Monad m => [Text] -> Series m Text
43+textEnumSeries enum = generate $ \depth -> take depth enum
44+
45+textSeries :: Monad m => [DemotedTextConstraint] -> Series m Value
46+textSeries cs = do
47+ let mvcs = verifyTextConstraints cs
48+ case mvcs of
49+ Just vcs -> do
50+ n <- textSeries' vcs
51+ pure $ String n
52+ Nothing -> pure Null
53+
54+textSeries' :: Monad m => [VerifiedTextConstraint] -> Series m Text
55+textSeries' [] = pure "sample"
56+textSeries' vcs = do
57+ let enums = listToMaybe [x | VTEnum x <- vcs]
58+ case enums of
59+ Just e -> textEnumSeries e
60+ Nothing -> do
61+ let regexps = listToMaybe [x | VTRegex x _ _ <- vcs]
62+ case regexps of
63+ Just e -> regexSeries e
64+ Nothing -> textLengthSeries vcs
65+
66+numberSeries :: Monad m => [DemotedNumberConstraint] -> Series m Value
67+numberSeries cs = do
68+ let mvcs = verifyNumberConstraints cs
69+ case mvcs of
70+ Just vcs -> do
71+ n <- numberSeries' vcs
72+ pure $ Number $ fromIntegral n
73+ Nothing -> pure Null
74+
75+numberSeries' :: Monad m => VerifiedNumberConstraint -> Series m Integer
76+numberSeries' =
77+ \case
78+ VNEq eq -> pure $ fromIntegral eq
79+ VNBounds ml mh -> do
80+ let l = fromMaybe minLow (fromIntegral <$> ml) + 1
81+ h = fromMaybe maxHigh (fromIntegral <$> mh) - 1
82+ n <- generate $ \depth -> take depth [l .. h]
83+ pure $ fromIntegral n
84+
85+arraySeries ::
86+ Monad m => [DemotedArrayConstraint] -> DemotedSchema -> Series m Value
87+arraySeries cs sch = do
88+ let mvcs = verifyArrayConstraint cs
89+ case mvcs of
90+ Just vcs -> arraySeries' vcs sch
91+ Nothing -> pure Null
92+
93+arraySeries' ::
94+ Monad m => Maybe VerifiedArrayConstraint -> DemotedSchema -> Series m Value
95+arraySeries' ml sch = do
96+ objs <- V.replicateM (maybe minRepeat f ml) (valueSeries sch)
97+ pure $ Array objs
98+ where
99+ f (VAEq l) = fromIntegral l
100+
101+valueSeries :: Monad m => DemotedSchema -> Series m Value
102+valueSeries (DSchemaText cs) = textSeries cs
103+valueSeries (DSchemaNumber cs) = numberSeries cs
104+valueSeries DSchemaBoolean = Bool <$> pure True \/ pure False
105+valueSeries (DSchemaObject pairs') =
106+ Object <$> (decDepth $ mapM valueSeries $ H.fromList pairs')
107+valueSeries (DSchemaArray cs sch) = arraySeries cs sch
108+valueSeries DSchemaNull = pure Null
109+valueSeries (DSchemaOptional sch) = pure Null \/ valueSeries sch
110+valueSeries (DSchemaUnion schs) = do
111+ objs <- mapM valueSeries schs
112+ pure $ Array $ V.fromList objs
src/Data/Schematic/Generator/Regex.hsnew file+85
@@ -0,0 +1,85 @@
1+module Data.Schematic.Generator.Regex where
2+
3+import Control.Monad
4+import Data.Aeson (Object, Value(..))
5+import Data.HashMap.Lazy (HashMap)
6+import qualified Data.HashMap.Lazy as H
7+import Data.List
8+import Data.Maybe
9+import Data.Monoid
10+import Data.Schematic.Schema
11+import qualified Data.Set as S
12+import Data.Text (Text, pack, unpack)
13+import Data.Text.Lazy (toStrict)
14+import Data.Text.Lazy.Builder (Builder, singleton, toLazyText)
15+import qualified Data.Vector as V
16+import Test.SmallCheck
17+import Test.SmallCheck.Series
18+import Text.Regex.TDFA
19+import Text.Regex.TDFA.Pattern
20+import Text.Regex.TDFA.ReadRegex (parseRegex)
21+import Data.Schematic.Verifier
22+
23+
24+minRepeat :: Int
25+minRepeat = 2
26+
27+maxRepeat :: Int
28+maxRepeat = 10
29+
30+regexSeries :: (Monad m) => Text -> Series m Text
31+regexSeries regexp =
32+ case parseRegex . unpack $ regexp of
33+ Right (p, _) -> toStrict . toLazyText <$> regexSeries' p
34+ Left _ -> pure ""
35+
36+regexSeries' :: (Monad m) => Pattern -> Series m Builder
37+regexSeries' p =
38+ case p of
39+ PEmpty -> pure mempty
40+ PChar {..} -> pure $ singleton getPatternChar
41+ PAny {getPatternSet = PatternSet (Just cset) _ _ _} -> do
42+ x <- generate $ \depth -> take depth $ S.toList cset
43+ pure $ singleton x
44+ PAnyNot {getPatternSet = PatternSet (Just cset) _ _ _} -> do
45+ x <-
46+ generate $ \depth ->
47+ take depth $ notChars $ concatMap expandEscape $ S.toList cset
48+ pure $ singleton x
49+ PQuest p -> regexSeries' p \/ pure mempty
50+ PPlus p -> regexSeries' $ PBound 1 Nothing p
51+ PStar _ p -> regexSeries' $ PBound 0 Nothing p
52+ PBound low mhigh p -> do
53+ let high = fromMaybe (low + maxRepeat) mhigh
54+ n <- generate $ \depth -> take depth [low .. high]
55+ decDepth $ do
56+ ps <- replicateM n $ regexSeries' p
57+ pure $ mconcat ps
58+ PConcat ps -> mconcat <$> mapM regexSeries' ps
59+ POr xs -> regexSeries' =<< (generate $ \depth -> take depth xs)
60+ PDot _ -> do
61+ x <- generate $ \depth -> take depth $ notChars []
62+ pure $ singleton x
63+ PEscape {..} -> do
64+ x <- generate $ \depth -> take depth $ expandEscape getPatternChar
65+ pure $ singleton x
66+ PCarat _ -> pure mempty
67+ PDollar _ -> pure mempty
68+ _ -> pure mempty
69+ where
70+ notChars = ([' ' .. '~'] \\)
71+ expandEscape ch =
72+ case ch of
73+ 'n' -> "\n"
74+ 't' -> "\t"
75+ 'r' -> "\r"
76+ 'f' -> "\f"
77+ 'a' -> "\a"
78+ 'e' -> "\ESC"
79+ 'd' -> ['0' .. '9']
80+ 'w' -> ['0' .. '9'] ++ '_' : ['a' .. 'z'] ++ ['A' .. 'Z']
81+ 's' -> "\9\32"
82+ 'D' -> notChars $ ['0' .. '9']
83+ 'W' -> notChars $ ['0' .. '9'] ++ '_' : ['a' .. 'z'] ++ ['A' .. 'Z']
84+ 'S' -> notChars "\9\32"
85+ 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/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+22
@@ -0,0 +1,22 @@
1+module Data.Schematic.Verifier.Array where
2+
3+import Data.List
4+import Data.Maybe
5+import Data.Schematic
6+import Data.Schematic.Verifier.Common
7+import Data.Singletons
8+import Data.Singletons.Prelude
9+import Data.Singletons.TypeLits
10+import Data.Text (Text)
11+import Data.Text.Array (Array)
12+import GHC.Generics
13+
14+data VerifiedArrayConstraint =
15+ VAEq Integer
16+ deriving (Show)
17+
18+verifyArrayConstraint ::
19+ [DemotedArrayConstraint] -> Maybe (Maybe VerifiedArrayConstraint)
20+verifyArrayConstraint cs = do
21+ x <- verifyDNEq [x | DAEq x <- cs]
22+ 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+ [x] -> Just $ Just x
22+ (x:y:_) -> 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+40
@@ -0,0 +1,40 @@
1+module Data.Schematic.Verifier.Number where
2+
3+import Data.List
4+import Data.Maybe
5+import Data.Schematic
6+import Data.Schematic.Schema
7+import Data.Schematic.Verifier.Common
8+import Data.Singletons
9+import Data.Singletons.Prelude
10+import Data.Singletons.TypeLits
11+import Data.Text (Text)
12+import Data.Text.Array (Array)
13+import GHC.Generics
14+
15+toStrictNumber :: [DemotedNumberConstraint] -> [DemotedNumberConstraint]
16+toStrictNumber = map f
17+ where
18+ f (DNLe x) = DNLt (x + 1)
19+ f (DNGe x) = DNGt (x - 1)
20+ f x = x
21+
22+data VerifiedNumberConstraint
23+ = VNEq Integer
24+ | VNBounds (Maybe Integer)
25+ (Maybe Integer)
26+ deriving (Show)
27+
28+verifyNumberConstraints ::
29+ [DemotedNumberConstraint]
30+ -> Maybe VerifiedNumberConstraint
31+verifyNumberConstraints cs' = do
32+ let cs = toStrictNumber cs'
33+ mlt = simplifyDNLs [x | DNLt x <- cs]
34+ mgt = simplifyDNGs [x | DNGt x <- cs]
35+ meq <- verifyDNEq [x | DNEq x <- cs]
36+ verifyEquations mgt meq mlt
37+ Just $
38+ case meq of
39+ Just eq -> VNEq eq
40+ Nothing -> VNBounds mgt mlt
src/Data/Schematic/Verifier/Text.hsnew file+127
@@ -0,0 +1,127 @@
1+module Data.Schematic.Verifier.Text where
2+
3+import Control.Monad
4+import Data.List
5+import Data.Maybe
6+import Data.Schematic
7+import Data.Schematic.Schema
8+import Data.Schematic.Verifier.Common
9+import Data.Singletons
10+import Data.Singletons.Prelude
11+import Data.Singletons.TypeLits
12+import Data.Text (unpack)
13+import Data.Text (Text)
14+import Data.Text.Array (Array)
15+import GHC.Generics
16+import Text.Regex.TDFA
17+import Text.Regex.TDFA.Pattern
18+import Text.Regex.TDFA.ReadRegex (parseRegex)
19+
20+toStrictTextLength :: [DemotedTextConstraint] -> [DemotedTextConstraint]
21+toStrictTextLength = map f
22+ where
23+ f (DTLe x) = DTLt (x + 1)
24+ f (DTGe x) = DTGt (x - 1)
25+ f x = x
26+
27+data VerifiedTextConstraint
28+ = VTEq Integer
29+ | VTBounds (Maybe Integer)
30+ (Maybe Integer)
31+ | VTRegex Text
32+ Integer
33+ (Maybe Integer)
34+ | VTEnum [Text]
35+ deriving (Show)
36+
37+verifyTextLengthConstraints ::
38+ [DemotedTextConstraint] -> Maybe (Maybe VerifiedTextConstraint)
39+verifyTextLengthConstraints cs' = do
40+ let cs = toStrictTextLength cs'
41+ mlt = simplifyDNLs [x | DTLt x <- cs]
42+ mgt = simplifyDNGs [x | DTGt x <- cs]
43+ meq <- verifyDNEq [x | DTEq x <- cs]
44+ verifyEquations mgt meq mlt
45+ case all isNothing ([mgt, meq, mlt] :: [Maybe Integer]) of
46+ True -> Just Nothing
47+ _ ->
48+ Just $
49+ Just $
50+ case meq of
51+ Just eq -> VTEq eq
52+ Nothing -> VTBounds mgt mlt
53+
54+regexLength :: Text -> Maybe (Int, Maybe Int)
55+regexLength regexp =
56+ case parseRegex . unpack $ regexp of
57+ Right (p, _) -> Just (minRegexLength p, maxRegexLength p)
58+ Left _ -> Nothing
59+
60+minRegexLength :: Pattern -> Int
61+minRegexLength p =
62+ case p of
63+ PEmpty -> 0
64+ PChar {..} -> 1
65+ PAny {getPatternSet = PatternSet (Just cset) _ _ _} -> 1
66+ PAnyNot {getPatternSet = PatternSet (Just cset) _ _ _} -> 1
67+ PQuest p -> 0
68+ PPlus p -> minRegexLength $ PBound 1 Nothing p
69+ PStar _ p -> minRegexLength $ PBound 0 Nothing p
70+ PBound low mhigh p -> low * minRegexLength p
71+ PConcat ps -> sum $ fmap minRegexLength ps
72+ POr xs -> minimum $ fmap minRegexLength xs
73+ PDot _ -> 1
74+ PEscape {..} -> 1
75+ PCarat _ -> 0
76+ PDollar _ -> 0
77+ _ -> 0
78+
79+maxRegexLength :: Pattern -> Maybe Int
80+maxRegexLength p =
81+ case p of
82+ PEmpty -> Just 0
83+ PChar _ _ -> Just 1
84+ PAny _ _ -> Just 1
85+ PAnyNot _ _ -> Just 1
86+ PQuest _ -> Just 0
87+ PPlus _ -> Nothing
88+ PStar _ _ -> Nothing
89+ PBound low mhigh p -> (*) <$> mhigh <*> maxRegexLength p
90+ PConcat ps -> sum <$> mapM maxRegexLength ps
91+ POr xs -> maximum <$> mapM maxRegexLength xs
92+ PDot _ -> Just 1
93+ PEscape _ _ -> Just 1
94+ PCarat _ -> Just 0
95+ PDollar _ -> Just 0
96+ _ -> Just 0
97+
98+verifyTextRegexConstraint ::
99+ [DemotedTextConstraint] -> Maybe (Maybe VerifiedTextConstraint)
100+verifyTextRegexConstraint cs = do
101+ let regexps = [x | DTRegex x <- cs]
102+ case regexps of
103+ [] -> Just Nothing
104+ [x] -> do
105+ (l, mh) <- regexLength x
106+ Just $ Just $ VTRegex x (fromIntegral l) (fromIntegral <$> mh)
107+ _ -> Nothing
108+
109+verifyTextEnumConstraint ::
110+ [DemotedTextConstraint] -> Maybe (Maybe VerifiedTextConstraint)
111+verifyTextEnumConstraint cs = do
112+ let enums = concat [x | DTEnum x <- cs]
113+ case enums of
114+ [] -> Just Nothing
115+ x -> Just $ Just $ VTEnum x
116+
117+verifyTextConstraints ::
118+ [DemotedTextConstraint] -> Maybe [VerifiedTextConstraint]
119+verifyTextConstraints cs = do
120+ regexp <- verifyTextRegexConstraint cs
121+ void $ case regexp of
122+ Just (VTRegex _ l mh) ->
123+ verifyTextLengthConstraints (DTGe l : cs ++ maybeToList (DTLe <$> mh))
124+ _ -> pure Nothing
125+ lengths <- verifyTextLengthConstraints cs
126+ enums <- verifyTextEnumConstraint cs
127+ return $ catMaybes [lengths, enums, regexp]
test/SchemaSpec.hs+14
@@ -17,10 +17,17 @@ 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]))
@@ -69,6 +76,9 @@ schemaJson = "{\"foo\": [13], \"bar\": null}"
69schemaJson2 :: ByteString
76schemaJson2 :: ByteString
70schemaJson2 = "{\"foo\": [3], \"bar\": null}"
77schemaJson2 = "{\"foo\": [3], \"bar\": null}"
71
78
79+schemaJsonSeries :: Monad m => SC.Series m Value
80+schemaJsonSeries = valueSeries $ fromSing (sing :: Sing SchemaExample)
81+
72spec :: Spec
82spec :: Spec
73spec = do
83spec = do
74 -- it "show/read JsonRepr properly" $
84 -- it "show/read JsonRepr properly" $
@@ -93,6 +103,10 @@ spec = do
93 migrationList
103 migrationList
94 schemaJson
104 schemaJson
95 `shouldSatisfy` isValid
105 `shouldSatisfy` isValid
106+ it "validate json series" $ property $
107+ SC.over schemaJsonSeries $ \x ->
108+ isValid (parseAndValidateJson @SchemaExample x)
109+
96
110
97main :: IO ()
111main :: IO ()
98main = hspec spec
112main = hspec spec