Skip to content

Commit a8ac1ae

Browse files
AnisimoffNikitaAnisimoffNikita
committed
notes
1 parent 5dbdde3 commit a8ac1ae

File tree

8 files changed

+170
-85
lines changed

8 files changed

+170
-85
lines changed

‎src/Data/Schematic/Generator.hs‎

Lines changed: 12 additions & 39 deletions
Original file line numberDiff line numberDiff line change
@@ -1,15 +1,12 @@
1-
{-# OPTIONS_GHC -fno-warn-orphans #-}
21
module Data.Schematic.Generator where
32

43
import Data.Maybe
5-
import Data.Schematic.Schema
4+
import Data.Schematic.Generator.Regex
5+
import {-# SOURCE #-} Data.Schematic.Schema
6+
import Data.Schematic.Verifier
67
import Data.Scientific
7-
import Data.Singletons
88
import Data.Text (Text, pack)
99
import qualified Data.Vector as V
10-
import Data.Vinyl
11-
import Data.Schematic.Generator.Regex
12-
import Data.Schematic.Verifier
1310
import Test.SmallCheck.Series
1411

1512
maxHigh :: Int
@@ -21,13 +18,14 @@ minLow = 2
2118
textLengthSeries :: Monad m => [VerifiedTextConstraint] -> Series m Text
2219
textLengthSeries =
2320
\case
24-
[VTEq eq] -> pure $ pack $ take (fromIntegral eq) $ cycle "sample"
21+
[VTEq eq] -> pure $ pack $ take (fromIntegral eq) $ cycle "sample"
2522
[VTBounds ml mh] -> do
26-
let l = fromMaybe minLow (fromIntegral <$> ml) + 1
27-
h = fromMaybe maxHigh (fromIntegral <$> mh) - 1
23+
let
24+
l = fromMaybe minLow (fromIntegral <$> ml) + 1
25+
h = fromMaybe maxHigh (fromIntegral <$> mh) - 1
2826
n <- generate $ \depth -> take depth [l .. h]
2927
pure $ pack $ take (fromIntegral n) $ cycle "sample"
30-
_ -> pure "error"
28+
_ -> pure "error"
3129

3230
textEnumSeries :: Monad m => [Text] -> Series m Text
3331
textEnumSeries enum = generate $ \depth -> take depth enum
@@ -38,8 +36,8 @@ textSeries cs = do
3836
case mvcs of
3937
Just vcs -> do
4038
n <- textSeries' vcs
41-
pure $ n
42-
Nothing -> pure "error"
39+
pure n
40+
Nothing -> pure "error"
4341

4442
textSeries' :: Monad m => [VerifiedTextConstraint] -> Series m Text
4543
textSeries' [] = pure "sample"
@@ -50,7 +48,7 @@ textSeries' vcs = do
5048
Nothing -> do
5149
let regexps = listToMaybe [x | VTRegex x _ _ <- vcs]
5250
case regexps of
53-
Just e -> regexSeries e
51+
Just e -> regexSeries e
5452
Nothing -> textLengthSeries vcs
5553

5654
numberSeries :: Monad m => [DemotedNumberConstraint] -> Series m Scientific
@@ -80,7 +78,7 @@ arraySeries cs = do
8078
let mvcs = verifyArrayConstraint cs
8179
case mvcs of
8280
Just vcs -> arraySeries' vcs
83-
Nothing -> pure V.empty
81+
Nothing -> pure V.empty
8482

8583
arraySeries'
8684
:: forall m s. (Monad m, Serial m (JsonRepr s))
@@ -91,28 +89,3 @@ arraySeries' ml = do
9189
pure $ objs
9290
where
9391
f (VAEq l) = fromIntegral l
94-
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

‎src/Data/Schematic/Generator/Regex.hs‎

Lines changed: 10 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -1,15 +1,15 @@
11
module Data.Schematic.Generator.Regex where
22

3-
import Control.Monad
4-
import Data.List
5-
import Data.Maybe
3+
import Control.Monad
4+
import Data.List
5+
import Data.Maybe
66
import qualified Data.Set as S
7-
import Data.Text (Text, unpack)
8-
import Data.Text.Lazy (toStrict)
9-
import Data.Text.Lazy.Builder (Builder, singleton, toLazyText)
10-
import Test.SmallCheck.Series
11-
import Text.Regex.TDFA.Pattern
12-
import Text.Regex.TDFA.ReadRegex (parseRegex)
7+
import Data.Text (Text, unpack)
8+
import Data.Text.Lazy (toStrict)
9+
import Data.Text.Lazy.Builder (Builder, singleton, toLazyText)
10+
import Test.SmallCheck.Series
11+
import Text.Regex.TDFA.Pattern
12+
import Text.Regex.TDFA.ReadRegex (parseRegex)
1313

1414

1515
minRepeat :: Int
@@ -22,7 +22,7 @@ regexSeries :: (Monad m) => Text -> Series m Text
2222
regexSeries regexp =
2323
case parseRegex . unpack $ regexp of
2424
Right (p, _) -> toStrict . toLazyText <$> regexSeries' p
25-
Left _ -> pure ""
25+
Left _ -> pure ""
2626

2727
regexSeries' :: (Monad m) => Pattern -> Series m Builder
2828
regexSeries' pt =

‎src/Data/Schematic/Schema.hs‎

Lines changed: 41 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -13,6 +13,7 @@ import Data.HashMap.Strict as H
1313
import Data.Kind
1414
import Data.Maybe
1515
import Data.Schematic.Instances ()
16+
import Data.Schematic.Generator
1617
import Data.Scientific
1718
import Data.Singletons.Prelude.List hiding (All, Union)
1819
import Data.Singletons.TH
@@ -24,7 +25,8 @@ import Data.Vinyl hiding (Dict)
2425
import qualified Data.Vinyl.TypeLevel as V
2526
import GHC.Exts
2627
import GHC.Generics (Generic)
27-
import GHC.TypeLits (SomeNat(..), SomeSymbol(..), someSymbolVal, someNatVal)
28+
import GHC.TypeLits
29+
(SomeNat(..), SomeSymbol(..), someNatVal, someSymbolVal)
2830
import Prelude as P
2931
import Test.SmallCheck.Series
3032

@@ -56,25 +58,25 @@ instance SingKind TextConstraint where
5658
STRegex s -> withKnownSymbol s (DTRegex $ T.pack $ symbolVal s)
5759
STEnum s -> let
5860
d :: Sing (s :: [Symbol]) -> [Text]
59-
d SNil = []
61+
d SNil = []
6062
d (SCons ss@SSym fs) = T.pack (symbolVal ss) : d fs
6163
in DTEnum $ d s
6264
toSing = \case
6365
DTEq n -> case someNatVal n of
6466
Just (SomeNat (_ :: Proxy n)) -> SomeSing (STEq (SNat :: Sing n))
65-
Nothing -> error "Negative singleton nat"
67+
Nothing -> error "Negative singleton nat"
6668
DTLt n -> case someNatVal n of
6769
Just (SomeNat (_ :: Proxy n)) -> SomeSing (STLt (SNat :: Sing n))
68-
Nothing -> error "Negative singleton nat"
70+
Nothing -> error "Negative singleton nat"
6971
DTLe n -> case someNatVal n of
7072
Just (SomeNat (_ :: Proxy n)) -> SomeSing (STLe (SNat :: Sing n))
71-
Nothing -> error "Negative singleton nat"
73+
Nothing -> error "Negative singleton nat"
7274
DTGt n -> case someNatVal n of
7375
Just (SomeNat (_ :: Proxy n)) -> SomeSing (STGt (SNat :: Sing n))
74-
Nothing -> error "Negative singleton nat"
76+
Nothing -> error "Negative singleton nat"
7577
DTGe n -> case someNatVal n of
7678
Just (SomeNat (_ :: Proxy n)) -> SomeSing (STGe (SNat :: Sing n))
77-
Nothing -> error "Negative singleton nat"
79+
Nothing -> error "Negative singleton nat"
7880
DTRegex s -> case someSymbolVal (T.unpack s) of
7981
SomeSymbol (_ :: Proxy n) -> SomeSing (STRegex (SSym :: Sing n))
8082
DTEnum ss -> case toSing ss of
@@ -161,19 +163,19 @@ instance SingKind NumberConstraint where
161163
toSing = \case
162164
DNEq n -> case someNatVal n of
163165
Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNEq (SNat :: Sing n))
164-
Nothing -> error "Negative singleton nat"
166+
Nothing -> error "Negative singleton nat"
165167
DNGt n -> case someNatVal n of
166168
Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNGt (SNat :: Sing n))
167-
Nothing -> error "Negative singleton nat"
169+
Nothing -> error "Negative singleton nat"
168170
DNGe n -> case someNatVal n of
169171
Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNGe (SNat :: Sing n))
170-
Nothing -> error "Negative singleton nat"
172+
Nothing -> error "Negative singleton nat"
171173
DNLt n -> case someNatVal n of
172174
Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNLt (SNat :: Sing n))
173-
Nothing -> error "Negative singleton nat"
175+
Nothing -> error "Negative singleton nat"
174176
DNLe n -> case someNatVal n of
175177
Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNLe (SNat :: Sing n))
176-
Nothing -> error "Negative singleton nat"
178+
Nothing -> error "Negative singleton nat"
177179

178180
data ArrayConstraint
179181
= AEq Nat
@@ -197,7 +199,7 @@ instance SingKind ArrayConstraint where
197199
toSing = \case
198200
DAEq n -> case someNatVal n of
199201
Just (SomeNat (_ :: Proxy n)) -> SomeSing (SAEq (SNat :: Sing n))
200-
Nothing -> error "Negative singleton nat"
202+
Nothing -> error "Negative singleton nat"
201203

202204
data Schema
203205
= SchemaText [TextConstraint]
@@ -334,6 +336,31 @@ data JsonRepr :: Schema -> Type where
334336
ReprOptional :: Maybe (JsonRepr s) -> JsonRepr ('SchemaOptional s)
335337
ReprUnion :: Union JsonRepr (h ': tl) -> JsonRepr ('SchemaUnion (h ': tl))
336338

339+
instance (Monad m, Serial m Text, SingI cs)
340+
=> Serial m (JsonRepr ('SchemaText cs)) where
341+
series = decDepth $ fmap ReprText $ textSeries $ fromSing (sing :: Sing cs)
342+
343+
instance (Monad m, Serial m Scientific, SingI cs)
344+
=> Serial m (JsonRepr ('SchemaNumber cs)) where
345+
series = decDepth $ fmap ReprNumber
346+
$ numberSeries $ fromSing (sing :: Sing cs)
347+
348+
instance Monad m => Serial m (JsonRepr 'SchemaNull) where
349+
series = cons0 ReprNull
350+
351+
instance (Serial m (JsonRepr s), Serial m (V.Vector (JsonRepr s)), SingI cs)
352+
=> Serial m (JsonRepr ('SchemaArray cs s)) where
353+
series = decDepth $ fmap ReprArray
354+
$ arraySeries $ fromSing (sing :: Sing cs)
355+
356+
instance (Serial m (JsonRepr s))
357+
=> Serial m (JsonRepr ('SchemaOptional s)) where
358+
series = cons1 ReprOptional
359+
360+
instance (Monad m, Serial m (Rec FieldRepr fs))
361+
=> Serial m (JsonRepr ('SchemaObject fs)) where
362+
series = cons1 ReprObject
363+
337364
-- | Move to the union package
338365
instance Show (JsonRepr ('SchemaText cs)) where
339366
show (ReprText t) = "ReprText " P.++ show t
@@ -479,7 +506,7 @@ instance J.ToJSON (JsonRepr a) where
479506
toJSON (ReprText t) = J.String t
480507
toJSON (ReprNumber n) = J.Number n
481508
toJSON (ReprOptional s) = case s of
482-
Just v -> toJSON v
509+
Just v -> toJSON v
483510
Nothing -> J.Null
484511
toJSON (ReprArray v) = J.Array $ toJSON <$> v
485512
toJSON (ReprObject r) = J.Object . H.fromList . fold $ r

‎src/Data/Schematic/Schema.hs-boot‎

Lines changed: 87 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,87 @@
1+
module Data.Schematic.Schema where
2+
3+
import Data.Kind
4+
import Data.Maybe
5+
import Data.Schematic.Instances ()
6+
import Data.Scientific
7+
import Data.Singletons.TH
8+
import Data.Singletons.TypeLits
9+
import Data.Text as T
10+
import Data.Union
11+
import Data.Vector as V
12+
import Data.Vinyl hiding (Dict)
13+
import Prelude as P
14+
15+
data TextConstraint
16+
= TEq Nat
17+
| TLt Nat
18+
| TLe Nat
19+
| TGt Nat
20+
| TGe Nat
21+
| TRegex Symbol
22+
| TEnum [Symbol]
23+
24+
data DemotedTextConstraint
25+
= DTEq Integer
26+
| DTLt Integer
27+
| DTLe Integer
28+
| DTGt Integer
29+
| DTGe Integer
30+
| DTRegex Text
31+
| DTEnum [Text]
32+
33+
data NumberConstraint
34+
= NLe Nat
35+
| NLt Nat
36+
| NGt Nat
37+
| NGe Nat
38+
| NEq Nat
39+
40+
data DemotedNumberConstraint
41+
= DNLe Integer
42+
| DNLt Integer
43+
| DNGt Integer
44+
| DNGe Integer
45+
| DNEq Integer
46+
47+
data ArrayConstraint
48+
= AEq Nat
49+
50+
data DemotedArrayConstraint
51+
= DAEq Integer
52+
53+
data Schema
54+
= SchemaText [TextConstraint]
55+
| SchemaBoolean
56+
| SchemaNumber [NumberConstraint]
57+
| SchemaObject [(Symbol, Schema)]
58+
| SchemaArray [ArrayConstraint] Schema
59+
| SchemaNull
60+
| SchemaOptional Schema
61+
| SchemaUnion [Schema]
62+
63+
data DemotedSchema
64+
= DSchemaText [DemotedTextConstraint]
65+
| DSchemaNumber [DemotedNumberConstraint]
66+
| DSchemaBoolean
67+
| DSchemaObject [(Text, DemotedSchema)]
68+
| DSchemaArray [DemotedArrayConstraint] DemotedSchema
69+
| DSchemaNull
70+
| DSchemaOptional DemotedSchema
71+
| DSchemaUnion [DemotedSchema]
72+
73+
data FieldRepr :: (Symbol, Schema) -> Type where
74+
FieldRepr
75+
:: (SingI schema, KnownSymbol name)
76+
=> JsonRepr schema
77+
-> FieldRepr '(name, schema)
78+
79+
data JsonRepr :: Schema -> Type where
80+
ReprText :: Text -> JsonRepr ('SchemaText cs)
81+
ReprNumber :: Scientific -> JsonRepr ('SchemaNumber cs)
82+
ReprBoolean :: Bool -> JsonRepr 'SchemaBoolean
83+
ReprNull :: JsonRepr 'SchemaNull
84+
ReprArray :: V.Vector (JsonRepr s) -> JsonRepr ('SchemaArray cs s)
85+
ReprObject :: Rec FieldRepr fs -> JsonRepr ('SchemaObject fs)
86+
ReprOptional :: Maybe (JsonRepr s) -> JsonRepr ('SchemaOptional s)
87+
ReprUnion :: Union JsonRepr (h ': tl) -> JsonRepr ('SchemaUnion (h ': tl))

‎src/Data/Schematic/Verifier/Array.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
module Data.Schematic.Verifier.Array where
22

3-
import Data.Schematic
3+
import {-# SOURCE #-} Data.Schematic.Schema
44
import Data.Schematic.Verifier.Common
55

66
data VerifiedArrayConstraint =

‎src/Data/Schematic/Verifier/Common.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -6,7 +6,7 @@ simplifyNumberConstraint :: ([Integer] -> Integer) -> [Integer] -> Maybe Integer
66
simplifyNumberConstraint f =
77
\case
88
[] -> Nothing
9-
x -> Just $ f x
9+
x -> Just $ f x
1010

1111
simplifyDNLs :: [Integer] -> Maybe Integer
1212
simplifyDNLs = simplifyNumberConstraint minimum

‎src/Data/Schematic/Verifier/Number.hs‎

Lines changed: 5 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -1,23 +1,22 @@
11
module Data.Schematic.Verifier.Number where
22

3-
import Data.Schematic
3+
import {-# SOURCE #-} Data.Schematic.Schema
44
import Data.Schematic.Verifier.Common
55

66
toStrictNumber :: [DemotedNumberConstraint] -> [DemotedNumberConstraint]
77
toStrictNumber = map f
88
where
99
f (DNLe x) = DNLt (x + 1)
1010
f (DNGe x) = DNGt (x - 1)
11-
f x = x
11+
f x = x
1212

1313
data VerifiedNumberConstraint
1414
= VNEq Integer
15-
| VNBounds (Maybe Integer)
16-
(Maybe Integer)
15+
| VNBounds (Maybe Integer) (Maybe Integer)
1716
deriving (Show)
1817

19-
verifyNumberConstraints ::
20-
[DemotedNumberConstraint]
18+
verifyNumberConstraints
19+
:: [DemotedNumberConstraint]
2120
-> Maybe VerifiedNumberConstraint
2221
verifyNumberConstraints cs' = do
2322
let

0 commit comments

Comments
 (0)