git.iko.soy/schematic
on master help sign in
constraints problems
b6a94f1Denis Redozubov
schematic.cabal+1
compare with master
unifiedsplit
@@ -19,6 +19,7 @@ library
19 exposed-modules: Data.Aeson.Validation
19 exposed-modules: Data.Aeson.Validation
20 , Data.Schematic
20 , Data.Schematic
21 , Data.Schematic.Schema
21 , Data.Schematic.Schema
22+ , Data.Schematic.Utils
22 -- ghc-options:
23 -- ghc-options:
23 -- other-modules:
24 -- other-modules:
24 default-extensions: ConstraintKinds
25 default-extensions: ConstraintKinds
src/Data/Schematic.hs+2
@@ -1,5 +1,7 @@
1module Data.Schematic
1module Data.Schematic
2 ( module Data.Schematic.Schema
2 ( module Data.Schematic.Schema
3+ , module Data.Schematic.Utils
3 ) where
4 ) where
4
5
5import Data.Schematic.Schema
6import Data.Schematic.Schema
7+import Data.Schematic.Utils
src/Data/Schematic/Schema.hs+39−13
@@ -16,6 +16,7 @@ import Data.Functor.Classes
16import Data.HashMap.Strict as H
16import Data.HashMap.Strict as H
17import Data.Kind
17import Data.Kind
18import Data.Maybe
18import Data.Maybe
19+import Data.Schematic.Utils
19import Data.Scientific
20import Data.Scientific
20import Data.Singletons.Decide
21import Data.Singletons.Decide
21import Data.Singletons.Prelude.List
22import Data.Singletons.Prelude.List
@@ -40,13 +41,19 @@ data TextConstraint
40 = TEq Nat
41 = TEq Nat
41 | TLe Nat
42 | TLe Nat
42 | TGt Nat
43 | TGt Nat
43− | Regex Symbol
44+ | TRegex Symbol
44 deriving (Generic)
45 deriving (Generic)
45
46
46data instance Sing (tc :: TextConstraint) where
47data instance Sing (tc :: TextConstraint) where
47− STextLengthEq :: Sing n -> Sing (TEq n)
48+ STEq :: Sing n -> Sing (TEq n)
48− STextLengthLe :: Sing n -> Sing (TLe n)
49+ STLe :: Sing n -> Sing (TLe n)
49− STextLengthGt :: Sing n -> Sing (TGt n)
50+ STGt :: Sing n -> Sing (TGt n)
51+ STRegex :: Sing s -> Sing (TRegex s)
52+
53+instance Known (Sing n) => Known (Sing (TEq n)) where known = STEq known
54+instance Known (Sing n) => Known (Sing (TGt n)) where known = STGt known
55+instance Known (Sing n) => Known (Sing (TLe n)) where known = STLe known
56+instance Known (Sing s) => Known (Sing (TRegex s)) where known = STRegex known
50
57
51instance Eq (Sing (TEq n)) where a == b = True
58instance Eq (Sing (TEq n)) where a == b = True
52instance Eq (Sing (TLe n)) where a == b = True
59instance Eq (Sing (TLe n)) where a == b = True
@@ -59,9 +66,13 @@ data NumberConstraint
59 deriving (Generic)
66 deriving (Generic)
60
67
61data instance Sing (nc :: NumberConstraint) where
68data instance Sing (nc :: NumberConstraint) where
62− SNumberEq :: Sing n -> Sing (NEq n)
69+ SNEq :: Sing n -> Sing (NEq n)
63− SNumberGt :: Sing n -> Sing (NGt n)
70+ SNGt :: Sing n -> Sing (NGt n)
64− SNumberLe :: Sing n -> Sing (NLe n)
71+ SNLe :: Sing n -> Sing (NLe n)
72+
73+instance Known (Sing n) => Known (Sing (NEq n)) where known = SNEq known
74+instance Known (Sing n) => Known (Sing (NGt n)) where known = SNGt known
75+instance Known (Sing n) => Known (Sing (NLe n)) where known = SNLe known
65
76
66instance Eq (Sing (NEq n)) where a == b = True
77instance Eq (Sing (NEq n)) where a == b = True
67instance Eq (Sing (NLe n)) where a == b = True
78instance Eq (Sing (NLe n)) where a == b = True
@@ -72,7 +83,9 @@ data ArrayConstraint
72 deriving (Generic)
83 deriving (Generic)
73
84
74data instance Sing (ac :: ArrayConstraint) where
85data instance Sing (ac :: ArrayConstraint) where
75− SArrayEq :: Sing n -> Sing (AEq n)
86+ SAEq :: Sing n -> Sing (AEq n)
87+
88+instance Known (Sing n) => Known (Sing (AEq n)) where known = SAEq known
76
89
77instance Eq (Sing (AEq n)) where a == b = True
90instance Eq (Sing (AEq n)) where a == b = True
78
91
@@ -91,6 +104,17 @@ data instance Sing (schema :: Schema) where
91 SSchemaObject :: Sing fields -> Sing (SchemaObject fields)
104 SSchemaObject :: Sing fields -> Sing (SchemaObject fields)
92 SSchemaNull :: Sing SchemaNull
105 SSchemaNull :: Sing SchemaNull
93
106
107+instance Known (Sing sl) => Known (Sing (SchemaText sl)) where
108+ known = SSchemaText known
109+instance Known (Sing sl) => Known (Sing (SchemaNumber sl)) where
110+ known = SSchemaNumber known
111+instance Known (Sing SchemaNull) where
112+ known = SSchemaNull
113+instance (Known (Sing ac), Known (Sing s)) => Known (Sing (SchemaArray ac s)) where
114+ known = SSchemaArray known known
115+instance Known (Sing stl) => Known (Sing (SchemaObject stl)) where
116+ known = SSchemaObject known
117+
94instance Eq (Sing (SchemaText cs)) where a == b = True
118instance Eq (Sing (SchemaText cs)) where a == b = True
95instance Eq (Sing (SchemaNumber cs)) where a == b = True
119instance Eq (Sing (SchemaNumber cs)) where a == b = True
96instance Eq (Sing SchemaNull) where a == b = True
120instance Eq (Sing SchemaNull) where a == b = True
@@ -131,14 +155,16 @@ instance Eq (JsonRepr SchemaNull) where
131instance Eq (JsonRepr s) => Eq (JsonRepr (SchemaArray as s)) where
155instance Eq (JsonRepr s) => Eq (JsonRepr (SchemaArray as s)) where
132 ReprArray a == ReprArray b = a == b
156 ReprArray a == ReprArray b = a == b
133
157
134−instance (SingI schema) => J.FromJSON (JsonRepr schema) where
158+instance Known (Sing schema) => J.FromJSON (JsonRepr schema) where
135− parseJSON value = case sing :: Sing schema of
159+ parseJSON value = case known :: Sing schema of
136 SSchemaText _ -> withText "String" (pure . ReprText) value
160 SSchemaText _ -> withText "String" (pure . ReprText) value
137 SSchemaNumber _ -> withScientific "Number" (pure . ReprNumber) value
161 SSchemaNumber _ -> withScientific "Number" (pure . ReprNumber) value
138 SSchemaNull -> pure ReprNull
162 SSchemaNull -> pure ReprNull
139− SSchemaArray c s -> withArray "Array" f value
163+ SSchemaArray c s -> do
140− where
164+ let
165+ f :: Sing cs -> Sing s -> V.Vector J.Value -> Parser (JsonRepr (SchemaArray cs s))
141− f = fmap ReprArray . (withSingI s $ traverse parseJSON)
166+ f _ _ = fmap ReprArray . traverse parseJSON
167+ withArray "Array" (f c s) value
142 SSchemaObject fs -> ReprObject <$> withObject "Object" (demoteFields fs) value
168 SSchemaObject fs -> ReprObject <$> withObject "Object" (demoteFields fs) value
143
169
144demoteFields
170demoteFields
test/SchemaSpec.hs+10−4
@@ -12,9 +12,14 @@ import Test.Hspec.SmallCheck
12type SchemaExample
12type SchemaExample
13 = SchemaObject
13 = SchemaObject
14 '[ '("foo", SchemaArray '[AEq 3] (SchemaNumber '[NGt 10]))
14 '[ '("foo", SchemaArray '[AEq 3] (SchemaNumber '[NGt 10]))
15− , '("bar", SchemaText '[Regex "\\w+"])]
15+ , '("bar", SchemaText '[TRegex "\\w+"])]
16−
16+
17+schemaExample
18+ :: ( DemoteRep Schema ~ Sing SchemaExample
19+ , DemoteRep Schema ~ s
20+ , SingKind Schema
17−schemaExample :: (SingKind Schema, SingI SchemaExample) => DemoteRep Schema
21+ , SingI SchemaExample
22+ ) => s
18schemaExample = fromSing (sing :: Sing SchemaExample)
23schemaExample = fromSing (sing :: Sing SchemaExample)
19
24
20exampleTest :: JsonRepr (SchemaText '[TEq 3])
25exampleTest :: JsonRepr (SchemaText '[TEq 3])
@@ -39,7 +44,8 @@ example = ReprObject $
39spec :: Spec
44spec :: Spec
40spec = do
45spec = do
41 it "decode/encode JsonRepr properly" $ do
46 it "decode/encode JsonRepr properly" $ do
47+ withSingI schemaExample $ property
42− property $ \(a :: JsonRepr SchemaExample) -> decode (encode a) == Just a
48+ $ \(a :: JsonRepr SchemaExample) -> decode (encode a) == Just a
43
49
44main :: IO ()
50main :: IO ()
45main = hspec spec
51main = hspec spec