git.iko.soy/schematic
on 6cc400e help sign in
schematic/src/Data/Schematic/Generator.hs
118 lines 3.7 kB history raw
1{-# OPTIONS_GHC -fno-warn-orphans #-}
2module Data.Schematic.Generator where
4import Data.Maybe
5import Data.Schematic.Schema
6import Data.Scientific
7import Data.Singletons
8import Data.Text (Text, pack)
9import qualified Data.Vector as V
10import Data.Vinyl
11import Data.Schematic.Generator.Regex
12import Data.Schematic.Verifier
13import Test.SmallCheck.Series
15maxHigh :: Int
16maxHigh = 30
18minLow :: Int
19minLow = 2
21textLengthSeries :: Monad m => [VerifiedTextConstraint] -> Series m Text
22textLengthSeries =
23 \case
24 [VTEq eq] -> pure $ pack $ take (fromIntegral eq) $ cycle "sample"
25 [VTBounds ml mh] -> do
26 let l = fromMaybe minLow (fromIntegral <$> ml) + 1
27 h = fromMaybe maxHigh (fromIntegral <$> mh) - 1
28 n <- generate $ \depth -> take depth [l .. h]
29 pure $ pack $ take (fromIntegral n) $ cycle "sample"
30 _ -> pure "error"
32textEnumSeries :: Monad m => [Text] -> Series m Text
33textEnumSeries enum = generate $ \depth -> take depth enum
35textSeries :: Monad m => [DemotedTextConstraint] -> Series m Text
36textSeries cs = do
37 let mvcs = verifyTextConstraints cs
38 case mvcs of
39 Just vcs -> do
40 n <- textSeries' vcs
41 pure $ n
42 Nothing -> pure "error"
44textSeries' :: Monad m => [VerifiedTextConstraint] -> Series m Text
45textSeries' [] = pure "sample"
46textSeries' vcs = do
47 let enums = listToMaybe [x | VTEnum x <- vcs]
48 case enums of
49 Just e -> textEnumSeries e
50 Nothing -> do
51 let regexps = listToMaybe [x | VTRegex x _ _ <- vcs]
52 case regexps of
53 Just e -> regexSeries e
54 Nothing -> textLengthSeries vcs
56numberSeries :: Monad m => [DemotedNumberConstraint] -> Series m Scientific
57numberSeries cs = do
58 let mvcs = verifyNumberConstraints cs
59 case mvcs of
60 Just vcs -> do
61 n <- numberSeries' vcs
62 pure $ n
63 Nothing -> pure 0
65numberSeries' :: Monad m => VerifiedNumberConstraint -> Series m Scientific
66numberSeries' =
67 \case
68 VNEq eq -> pure $ fromIntegral eq
69 VNBounds ml mh -> do
70 let l = fromMaybe minLow (fromIntegral <$> ml) + 1
71 h = fromMaybe maxHigh (fromIntegral <$> mh) - 1
72 n <- generate $ \depth -> take depth [l .. h]
73 pure $ fromIntegral n
75arraySeries
76 :: (Monad m, Serial m (JsonRepr s))
77 => [DemotedArrayConstraint]
78 -> Series m (V.Vector (JsonRepr s))
79arraySeries cs = do
80 let mvcs = verifyArrayConstraint cs
81 case mvcs of
82 Just vcs -> arraySeries' vcs
83 Nothing -> pure V.empty
85arraySeries'
86 :: forall m s. (Monad m, Serial m (JsonRepr s))
87 => Maybe VerifiedArrayConstraint
88 -> Series m (V.Vector (JsonRepr s))
89arraySeries' ml = do
90 objs <- V.replicateM (maybe minRepeat f ml) (series :: Series m (JsonRepr s))
91 pure $ objs
92 where
93 f (VAEq l) = fromIntegral l
95instance (Monad m, Serial m Text, SingI cs)
96 => Serial m (JsonRepr ('SchemaText cs)) where
97 series = decDepth $ fmap ReprText $ textSeries $ fromSing (sing :: Sing cs)
99instance (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)
104instance Monad m => Serial m (JsonRepr 'SchemaNull) where
105 series = cons0 ReprNull
107instance (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)
112instance (Serial m (JsonRepr s))
113 => Serial m (JsonRepr ('SchemaOptional s)) where
114 series = cons1 ReprOptional
116instance (Monad m, Serial m (Rec FieldRepr fs))
117 => Serial m (JsonRepr ('SchemaObject fs)) where
118 series = cons1 ReprObject