@@ -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