git.iko.soy/typeable/schematic
on master help sign in
notes
commita8ac1ae86fbc080e19903dccdb4d9dc021c03756 authorNikita <anisimoff.nikita@gmail.com> dateFri 15 Feb 2019, 12:50 (8 years ago) parent5dbdde3
8 files changed+170−85
compare with master
unifiedsplit
src/Data/Schematic/Generator.hs+12−39 src/Data/Schematic/Generator/Regex.hs+10−10 src/Data/Schematic/Schema.hs+41−14 src/Data/Schematic/Schema.hs-boot+87 src/Data/Schematic/Verifier/Array.hs+1−1 src/Data/Schematic/Verifier/Common.hs+1−1 src/Data/Schematic/Verifier/Number.hs+5−6 src/Data/Schematic/Verifier/Text.hs+13−14
src/Data/Schematic/Generator.hs+12−39
@@ -1,15 +1,12 @@
1−{-# OPTIONS_GHC -fno-warn-orphans #-}
21module Data.Schematic.Generator where
32
43import Data.Maybe
5−import Data.Schematic.Schema
4+import Data.Schematic.Generator.Regex
5+import {-# SOURCE #-} Data.Schematic.Schema
6+import Data.Schematic.Verifier
67import Data.Scientific
7−import Data.Singletons
88import Data.Text (Text, pack)
99import qualified Data.Vector as V
10−import Data.Vinyl
11−import Data.Schematic.Generator.Regex
12−import Data.Schematic.Verifier
1310import Test.SmallCheck.Series
1411
1512maxHigh :: Int
@@ -21,13 +18,14 @@ minLow = 2
2118textLengthSeries :: Monad m => [VerifiedTextConstraint] -> Series m Text
2219textLengthSeries =
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
3230textEnumSeries :: Monad m => [Text] -> Series m Text
3331textEnumSeries 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
4442textSeries' :: Monad m => [VerifiedTextConstraint] -> Series m Text
4543textSeries' [] = 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
5654numberSeries :: 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
8583arraySeries'
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+10−10
@@ -1,15 +1,15 @@
11module 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
66import 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
1515minRepeat :: Int
@@ -22,7 +22,7 @@ regexSeries :: (Monad m) => Text -> Series m Text
2222regexSeries regexp =
2323 case parseRegex . unpack $ regexp of
2424 Right (p, _) -> toStrict . toLazyText <$> regexSeries' p
25− Left _ -> pure ""
25+ Left _ -> pure ""
2626
2727regexSeries' :: (Monad m) => Pattern -> Series m Builder
2828regexSeries' pt =
src/Data/Schematic/Schema.hs+41−14
@@ -13,6 +13,7 @@ import Data.HashMap.Strict as H
1313import Data.Kind
1414import Data.Maybe
1515import Data.Schematic.Instances ()
16+import Data.Schematic.Generator
1617import Data.Scientific
1718import Data.Singletons.Prelude.List hiding (All, Union)
1819import Data.Singletons.TH
@@ -24,7 +25,8 @@ import Data.Vinyl hiding (Dict)
2425import qualified Data.Vinyl.TypeLevel as V
2526import GHC.Exts
2627import GHC.Generics (Generic)
27−import GHC.TypeLits (SomeNat(..), SomeSymbol(..), someSymbolVal, someNatVal)
28+import GHC.TypeLits
29+ (SomeNat(..), SomeSymbol(..), someNatVal, someSymbolVal)
2830import Prelude as P
2931import 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
178180data 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
202204data 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
338365instance 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-bootnew file+87
@@ -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+1−1
@@ -1,6 +1,6 @@
11module Data.Schematic.Verifier.Array where
22
3−import Data.Schematic
3+import {-# SOURCE #-} Data.Schematic.Schema
44import Data.Schematic.Verifier.Common
55
66data VerifiedArrayConstraint =
src/Data/Schematic/Verifier/Common.hs+1−1
@@ -6,7 +6,7 @@ simplifyNumberConstraint :: ([Integer] -> Integer) -> [Integer] -> Maybe Integer
66simplifyNumberConstraint f =
77 \case
88 [] -> Nothing
9− x -> Just $ f x
9+ x -> Just $ f x
1010
1111simplifyDNLs :: [Integer] -> Maybe Integer
1212simplifyDNLs = simplifyNumberConstraint minimum
src/Data/Schematic/Verifier/Number.hs+5−6
@@ -1,6 +1,6 @@
11module Data.Schematic.Verifier.Number where
22
3−import Data.Schematic
3+import {-# SOURCE #-} Data.Schematic.Schema
44import Data.Schematic.Verifier.Common
55
66toStrictNumber :: [DemotedNumberConstraint] -> [DemotedNumberConstraint]
@@ -8,16 +8,15 @@ 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
1313data 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
2221verifyNumberConstraints cs' = do
2322 let
src/Data/Schematic/Verifier/Text.hs+13−14
@@ -2,7 +2,7 @@ module Data.Schematic.Verifier.Text where
22
33import Control.Monad
44import Data.Maybe
5−import Data.Schematic
5+import {-# SOURCE #-} Data.Schematic.Schema
66import Data.Schematic.Verifier.Common
77import Data.Text (Text, unpack)
88import Text.Regex.TDFA.Pattern
@@ -13,15 +13,12 @@ toStrictTextLength = map f
1313 where
1414 f (DTLe x) = DTLt (x + 1)
1515 f (DTGe x) = DTGt (x - 1)
16− f x = x
16+ f x = x
1717
1818data VerifiedTextConstraint
1919 = VTEq Integer
20− | VTBounds (Maybe Integer)
21− (Maybe Integer)
22− | VTRegex Text
23− Integer
24− (Maybe Integer)
20+ | VTBounds (Maybe Integer) (Maybe Integer)
21+ | VTRegex Text Integer (Maybe Integer)
2522 | VTEnum [Text]
2623 deriving (Show)
2724
@@ -29,9 +26,10 @@ verifyTextLengthConstraints
2926 :: [DemotedTextConstraint]
3027 -> Maybe (Maybe VerifiedTextConstraint)
3128verifyTextLengthConstraints cs' = do
32− let cs = toStrictTextLength cs'
33− mlt = simplifyDNLs [x | DTLt x <- cs]
34− mgt = simplifyDNGs [x | DTGt x <- cs]
29+ let
30+ cs = toStrictTextLength cs'
31+ mlt = simplifyDNLs [x | DTLt x <- cs]
32+ mgt = simplifyDNGs [x | DTGt x <- cs]
3533 meq <- verifyDNEq [x | DTEq x <- cs]
3634 verifyEquations mgt meq mlt
3735 case all isNothing ([mgt, meq, mlt] :: [Maybe Integer]) of
@@ -113,10 +111,11 @@ verifyTextConstraints
113111 -> Maybe [VerifiedTextConstraint]
114112verifyTextConstraints cs = do
115113 regexp <- verifyTextRegexConstraint cs
116− void $ case regexp of
117− Just (VTRegex _ l mh) ->
118− verifyTextLengthConstraints (DTGe l : cs ++ maybeToList (DTLe <$> mh))
119− _ -> pure Nothing
114+ void $
115+ case regexp of
116+ Just (VTRegex _ l mh) ->
117+ verifyTextLengthConstraints (DTGe l : cs ++ maybeToList (DTLe <$> mh))
118+ _ -> pure Nothing
120119 lengths <- verifyTextLengthConstraints cs
121120 enums <- verifyTextEnumConstraint cs
122121 return $ catMaybes [lengths, enums, regexp]