@@ -1,14 +1,16 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
1module Data.Schematic.Generator where
2module Data.Schematic.Generator where
3−import Data.Aeson (Value(..))
4−import qualified Data.HashMap.Lazy as H
5−import Data.Maybe
4+import Data.Maybe
6−import Data.Schematic.Schema
5+import Data.Schematic.Schema
7−import Data.Text (Text, pack)
8+import Data.Text (Text, pack)
8import qualified Data.Vector as V
9import qualified Data.Vector as V
9−import Data.Schematic.Generator.Regex
11+import Data.Schematic.Generator.Regex
10−import Data.Schematic.Verifier
12+import Data.Schematic.Verifier
11−import Test.SmallCheck.Series
13+import Test.SmallCheck.Series
13maxHigh :: Int
15maxHigh :: Int
14maxHigh = 30
16maxHigh = 30
@@ -30,14 +32,14 @@ textLengthSeries =
30textEnumSeries :: Monad m => [Text] -> Series m Text
32textEnumSeries :: Monad m => [Text] -> Series m Text
31textEnumSeries enum = generate $ \depth -> take depth enum
33textEnumSeries enum = generate $ \depth -> take depth enum
33−textSeries :: Monad m => [DemotedTextConstraint] -> Series m Value
35+textSeries :: Monad m => [DemotedTextConstraint] -> Series m Text
34textSeries cs = do
36textSeries cs = do
35 let mvcs = verifyTextConstraints cs
37 let mvcs = verifyTextConstraints cs
36 case mvcs of
38 case mvcs of
37 Just vcs -> do
39 Just vcs -> do
38 n <- textSeries' vcs
40 n <- textSeries' vcs
39− pure $ String n
41+ pure $ n
40− Nothing -> pure Null
42+ Nothing -> pure "error"
42textSeries' :: Monad m => [VerifiedTextConstraint] -> Series m Text
44textSeries' :: Monad m => [VerifiedTextConstraint] -> Series m Text
43textSeries' [] = pure "sample"
45textSeries' [] = pure "sample"
@@ -51,16 +53,16 @@ textSeries' vcs = do
51 Just e -> regexSeries e
53 Just e -> regexSeries e
52 Nothing -> textLengthSeries vcs
54 Nothing -> textLengthSeries vcs
54−numberSeries :: Monad m => [DemotedNumberConstraint] -> Series m Value
56+numberSeries :: Monad m => [DemotedNumberConstraint] -> Series m Scientific
55numberSeries cs = do
57numberSeries cs = do
56 let mvcs = verifyNumberConstraints cs
58 let mvcs = verifyNumberConstraints cs
57 case mvcs of
59 case mvcs of
58 Just vcs -> do
60 Just vcs -> do
59 n <- numberSeries' vcs
61 n <- numberSeries' vcs
60− pure $ Number $ fromIntegral n
62+ pure $ n
61− Nothing -> pure Null
63+ Nothing -> pure 0
63−numberSeries' :: Monad m => VerifiedNumberConstraint -> Series m Integer
65+numberSeries' :: Monad m => VerifiedNumberConstraint -> Series m Scientific
64numberSeries' =
66numberSeries' =
66 VNEq eq -> pure $ fromIntegral eq
68 VNEq eq -> pure $ fromIntegral eq
@@ -70,31 +72,47 @@ numberSeries' =
70 n <- generate $ \depth -> take depth [l .. h]
72 n <- generate $ \depth -> take depth [l .. h]
71 pure $ fromIntegral n
73 pure $ fromIntegral n
73−arraySeries ::
75+arraySeries
76+ :: (Monad m, Serial m (JsonRepr s))
74− Monad m => [DemotedArrayConstraint] -> DemotedSchema -> Series m Value
77+ => [DemotedArrayConstraint]
78+ -> Series m (V.Vector (JsonRepr s))
75−arraySeries cs sch = do
79+arraySeries cs = do
76 let mvcs = verifyArrayConstraint cs
80 let mvcs = verifyArrayConstraint cs
77 case mvcs of
81 case mvcs of
78− Just vcs -> arraySeries' vcs sch
82+ Just vcs -> arraySeries' vcs
79− Nothing -> pure Null
83+ Nothing -> pure V.empty
81−arraySeries' ::
85+arraySeries'
86+ :: forall m s. (Monad m, Serial m (JsonRepr s))
82− Monad m => Maybe VerifiedArrayConstraint -> DemotedSchema -> Series m Value
87+ => Maybe VerifiedArrayConstraint
88+ -> Series m (V.Vector (JsonRepr s))
83−arraySeries' ml sch = do
89+arraySeries' ml = do
84− objs <- V.replicateM (maybe minRepeat f ml) (valueSeries sch)
90+ objs <- V.replicateM (maybe minRepeat f ml) (series :: Series m (JsonRepr s))
85− pure $ Array objs
91+ pure $ objs
87 f (VAEq l) = fromIntegral l
93 f (VAEq l) = fromIntegral l
89−valueSeries :: Monad m => DemotedSchema -> Series m Value
95+instance (Monad m, Serial m Text, SingI cs)
90−valueSeries (DSchemaText cs) = textSeries cs
96+ => Serial m (JsonRepr ('SchemaText cs)) where
91−valueSeries (DSchemaNumber cs) = numberSeries cs
97+ series = decDepth $ fmap ReprText $ textSeries $ fromSing (sing :: Sing cs)
92−valueSeries DSchemaBoolean = Bool <$> pure True \/ pure False
98+
93−valueSeries (DSchemaObject pairs') =
99+instance (Monad m, Serial m Scientific, SingI cs)
94− Object <$> (decDepth $ mapM valueSeries $ H.fromList pairs')
100+ => Serial m (JsonRepr ('SchemaNumber cs)) where
95−valueSeries (DSchemaArray cs sch) = arraySeries cs sch
101+ series = decDepth $ fmap ReprNumber
96−valueSeries DSchemaNull = pure Null
102+ $ numberSeries $ fromSing (sing :: Sing cs)
97−valueSeries (DSchemaOptional sch) = pure Null \/ valueSeries sch
103+
98−valueSeries (DSchemaUnion schs) = do
104+instance Monad m => Serial m (JsonRepr 'SchemaNull) where
99− objs <- mapM valueSeries schs
105+ series = cons0 ReprNull
100− pure $ Array $ V.fromList objs
106+
107+instance (Serial m (JsonRepr s), Serial m (V.Vector (JsonRepr s)), SingI cs)
108+ => Serial m (JsonRepr ('SchemaArray cs s)) where
109+ series = decDepth $ fmap ReprArray
110+ $ arraySeries $ fromSing (sing :: Sing cs)
112+instance (Serial m (JsonRepr s))
113+ => Serial m (JsonRepr ('SchemaOptional s)) where
114+ series = cons1 ReprOptional
116+instance (Monad m, Serial m (Rec FieldRepr fs))
117+ => Serial m (JsonRepr ('SchemaObject fs)) where
118+ series = cons1 ReprObject