@@ -1,14 +1,16 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
12module Data.Schematic.Generator where
23
3−import Data.Aeson (Value(..))
4−import qualified Data.HashMap.Lazy as H
5−import Data.Maybe
6−import Data.Schematic.Schema
7−import Data.Text (Text, pack)
4+import Data.Maybe
5+import Data.Schematic.Schema
6+import Data.Scientific
7+import Data.Singletons
8+import Data.Text (Text, pack)
89import qualified Data.Vector as V
9−import Data.Schematic.Generator.Regex
10−import Data.Schematic.Verifier
11−import Test.SmallCheck.Series
10+import Data.Vinyl
11+import Data.Schematic.Generator.Regex
12+import Data.Schematic.Verifier
13+import Test.SmallCheck.Series
1214
1315maxHigh :: Int
1416maxHigh = 30
@@ -30,14 +32,14 @@ textLengthSeries =
3032textEnumSeries :: Monad m => [Text] -> Series m Text
3133textEnumSeries enum = generate $ \depth -> take depth enum
3234
33−textSeries :: Monad m => [DemotedTextConstraint] -> Series m Value
35+textSeries :: Monad m => [DemotedTextConstraint] -> Series m Text
3436textSeries cs = do
3537 let mvcs = verifyTextConstraints cs
3638 case mvcs of
3739 Just vcs -> do
3840 n <- textSeries' vcs
39− pure $ String n
40− Nothing -> pure Null
41+ pure $ n
42+ Nothing -> pure "error"
4143
4244textSeries' :: Monad m => [VerifiedTextConstraint] -> Series m Text
4345textSeries' [] = pure "sample"
@@ -51,16 +53,16 @@ textSeries' vcs = do
5153 Just e -> regexSeries e
5254 Nothing -> textLengthSeries vcs
5355
54−numberSeries :: Monad m => [DemotedNumberConstraint] -> Series m Value
56+numberSeries :: Monad m => [DemotedNumberConstraint] -> Series m Scientific
5557numberSeries cs = do
5658 let mvcs = verifyNumberConstraints cs
5759 case mvcs of
5860 Just vcs -> do
5961 n <- numberSeries' vcs
60− pure $ Number $ fromIntegral n
61− Nothing -> pure Null
62+ pure $ n
63+ Nothing -> pure 0
6264
63−numberSeries' :: Monad m => VerifiedNumberConstraint -> Series m Integer
65+numberSeries' :: Monad m => VerifiedNumberConstraint -> Series m Scientific
6466numberSeries' =
6567 \case
6668 VNEq eq -> pure $ fromIntegral eq
@@ -70,31 +72,47 @@ numberSeries' =
7072 n <- generate $ \depth -> take depth [l .. h]
7173 pure $ fromIntegral n
7274
73−arraySeries ::
74− Monad m => [DemotedArrayConstraint] -> DemotedSchema -> Series m Value
75−arraySeries cs sch = do
75+arraySeries
76+ :: (Monad m, Serial m (JsonRepr s))
77+ => [DemotedArrayConstraint]
78+ -> Series m (V.Vector (JsonRepr s))
79+arraySeries cs = do
7680 let mvcs = verifyArrayConstraint cs
7781 case mvcs of
78− Just vcs -> arraySeries' vcs sch
79− Nothing -> pure Null
80−
81−arraySeries' ::
82− Monad m => Maybe VerifiedArrayConstraint -> DemotedSchema -> Series m Value
83−arraySeries' ml sch = do
84− objs <- V.replicateM (maybe minRepeat f ml) (valueSeries sch)
85− pure $ Array objs
82+ Just vcs -> arraySeries' vcs
83+ Nothing -> pure V.empty
84+
85+arraySeries'
86+ :: forall m s. (Monad m, Serial m (JsonRepr s))
87+ => Maybe VerifiedArrayConstraint
88+ -> Series m (V.Vector (JsonRepr s))
89+arraySeries' ml = do
90+ objs <- V.replicateM (maybe minRepeat f ml) (series :: Series m (JsonRepr s))
91+ pure $ objs
8692 where
8793 f (VAEq l) = fromIntegral l
8894
89−valueSeries :: Monad m => DemotedSchema -> Series m Value
90−valueSeries (DSchemaText cs) = textSeries cs
91−valueSeries (DSchemaNumber cs) = numberSeries cs
92−valueSeries DSchemaBoolean = Bool <$> pure True \/ pure False
93−valueSeries (DSchemaObject pairs') =
94− Object <$> (decDepth $ mapM valueSeries $ H.fromList pairs')
95−valueSeries (DSchemaArray cs sch) = arraySeries cs sch
96−valueSeries DSchemaNull = pure Null
97−valueSeries (DSchemaOptional sch) = pure Null \/ valueSeries sch
98−valueSeries (DSchemaUnion schs) = do
99− objs <- mapM valueSeries schs
100− pure $ Array $ V.fromList objs
95+instance (Monad m, Serial m Text, SingI cs)
96+ => Serial m (JsonRepr ('SchemaText cs)) where
97+ series = decDepth $ fmap ReprText $ textSeries $ fromSing (sing :: Sing cs)
98+
99+instance (Monad m, Serial m Scientific, SingI cs)
100+ => Serial m (JsonRepr ('SchemaNumber cs)) where
101+ series = decDepth $ fmap ReprNumber
102+ $ numberSeries $ fromSing (sing :: Sing cs)
103+
104+instance Monad m => Serial m (JsonRepr 'SchemaNull) where
105+ series = cons0 ReprNull
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)
111+
112+instance (Serial m (JsonRepr s))
113+ => Serial m (JsonRepr ('SchemaOptional s)) where
114+ series = cons1 ReprOptional
115+
116+instance (Monad m, Serial m (Rec FieldRepr fs))
117+ => Serial m (JsonRepr ('SchemaObject fs)) where
118+ series = cons1 ReprObject