git.iko.soy/typeable/schematic
on master help sign in
typelevel json arrays
871411aDenis Redozubov
src/Data/Schematic/Schema.hs+42−9
compare with master
unifiedsplit
@@ -24,6 +24,12 @@ type family Repr (ty :: JType) :: * where
24 Repr 'JText = String -- because of matchRegex
24 Repr 'JText = String -- because of matchRegex
25 Repr 'JNumber = Double
25 Repr 'JNumber = Double
26
26
27+type family CRepr (jty :: JType) :: * where
28+ CRepr JText = TextConstraint
29+ CRepr JNumber = NumberConstraint
30+ CRepr JObject = (String, Schema)
31+ CRepr JArray = ArrayConstraint
32+
27class Constrained (ty :: JType) c where
33class Constrained (ty :: JType) c where
28 cRep :: Proxy ty -> Proxy c -> CRepr ty
34 cRep :: Proxy ty -> Proxy c -> CRepr ty
29
35
@@ -39,6 +45,9 @@ data Gt nat
39instance KnownNat nat => Constrained 'JNumber (Gt nat) where
45instance KnownNat nat => Constrained 'JNumber (Gt nat) where
40 cRep _ _ = Gt $ natVal (Proxy @nat)
46 cRep _ _ = Gt $ natVal (Proxy @nat)
41
47
48+instance KnownNat nat => Constrained 'JArray (LengthEqNat nat) where
49+ cRep _ _ = LengthArrEq $ natVal (Proxy @nat)
50+
42-- /Validators
51-- /Validators
43
52
44data Field field ty schema
53data Field field ty schema
@@ -65,6 +74,13 @@ instance
65instance Verifiable jty '[] where
74instance Verifiable jty '[] where
66 schema _ _ = []
75 schema _ _ = []
67
76
77+instance
78+ ( Constrained 'JArray c
79+ , Verifiable 'JArray cs )
80+ => Verifiable 'JArray (c ': cs) where
81+ schema _ _ = cRep (Proxy @'JArray) (Proxy @c)
82+ : schema (Proxy @'JArray) (Proxy @cs)
83+
68instance
84instance
69 ( SchemaConstructor jty
85 ( SchemaConstructor jty
70 , Verifiable 'JObject fs
86 , Verifiable 'JObject fs
@@ -76,11 +92,6 @@ instance
76 fieldName = symbolVal (Proxy @field)
92 fieldName = symbolVal (Proxy @field)
77 fieldSchema = constructor (Proxy @jty) $ schema (Proxy @jty) (Proxy @cs)
93 fieldSchema = constructor (Proxy @jty) $ schema (Proxy @jty) (Proxy @cs)
78
94
79−type family CRepr (jty :: JType) :: * where
80− CRepr JText = TextConstraint
81− CRepr JNumber = NumberConstraint
82− CRepr JObject = (String, Schema)
83−
84data TextConstraint
95data TextConstraint
85 = LengthEq Integer
96 = LengthEq Integer
86 | LengthLe Integer
97 | LengthLe Integer
@@ -93,11 +104,15 @@ data NumberConstraint
93 | Eq Integer
104 | Eq Integer
94 deriving (Show, Eq)
105 deriving (Show, Eq)
95
106
107+data ArrayConstraint
108+ = LengthArrEq Integer
109+ deriving (Show, Eq)
110+
96data Schema
111data Schema
97 = SchemaText [TextConstraint]
112 = SchemaText [TextConstraint]
98 | SchemaNumber [NumberConstraint]
113 | SchemaNumber [NumberConstraint]
99 | SchemaObject [(String, Schema)]
114 | SchemaObject [(String, Schema)]
100− | SchemaArray Schema
115+ | SchemaArray [ArrayConstraint] Schema
101 deriving (Show, Eq)
116 deriving (Show, Eq)
102
117
103-- | Apply constraint for each element of list
118-- | Apply constraint for each element of list
@@ -117,7 +132,7 @@ instance SchemaConstructor 'JNumber where
117instance SchemaConstructor 'JObject where
132instance SchemaConstructor 'JObject where
118 constructor _ = SchemaObject
133 constructor _ = SchemaObject
119
134
120−class (SchemaConstructor (JT ty)) => Schematic ty where
135+class Schematic ty where
121 type JT (ty :: k) :: JType
136 type JT (ty :: k) :: JType
122 build :: Proxy ty -> Schema
137 build :: Proxy ty -> Schema
123
138
@@ -131,9 +146,13 @@ data SNumber cs
131
146
132instance (Verifiable 'JNumber cs) => Schematic (SNumber cs) where
147instance (Verifiable 'JNumber cs) => Schematic (SNumber cs) where
133 type JT (SNumber cs) = 'JNumber
148 type JT (SNumber cs) = 'JNumber
134− build _ = constructor (Proxy @(JT (SNumber cs))) $ schema (Proxy @'JNumber) (Proxy @cs)
149+ build _ = constructor (Proxy @(JT (SNumber cs)))
150+ $ schema (Proxy @'JNumber) (Proxy @cs)
135
151
152+instance
153+ ( Verifiable (JT ty) cs
154+ , SchemaConstructor (JT ty) )
136−instance (Verifiable (JT ty) cs, SchemaConstructor (JT ty)) => Schematic (Field field ty cs) where
155+ => Schematic (Field field ty cs) where
137 type JT (Field field ty cs) = JT ty
156 type JT (Field field ty cs) = JT ty
138 build _ = constructor (Proxy @(JT (Field field ty cs)))
157 build _ = constructor (Proxy @(JT (Field field ty cs)))
139 $ schema (Proxy @(JT (Field field ty cs))) (Proxy @cs)
158 $ schema (Proxy @(JT (Field field ty cs))) (Proxy @cs)
@@ -146,11 +165,25 @@ instance (Verifiable 'JObject els) => Schematic (SObject els) where
146 constructor (Proxy @(JT (SObject els)))
165 constructor (Proxy @(JT (SObject els)))
147 $ schema (Proxy @(JT (SObject els))) (Proxy @els)
166 $ schema (Proxy @(JT (SObject els))) (Proxy @els)
148
167
168+data SArray cs s
169+
170+instance
171+ ( Schematic s
172+ , Verifiable 'JArray cs )
173+ => Schematic (SArray cs s) where
174+ type JT (SArray cs s) = 'JArray
175+ build _ =
176+ SchemaArray
177+ (schema (Proxy @'JArray) (Proxy @cs))
178+ (build (Proxy @s))
179+
149-- | Shows it's top-level definition according to the json-schema
180-- | Shows it's top-level definition according to the json-schema
150class TopLevel spec
181class TopLevel spec
151
182
152instance Schematic (SObject els) => TopLevel (SObject els)
183instance Schematic (SObject els) => TopLevel (SObject els)
153
184
185+instance Schematic (SArray cs s) => TopLevel (SArray cs s)
186+
154-- | TODO: abstract over objects and arrays
187-- | TODO: abstract over objects and arrays
155-- toSchema
188-- toSchema
156-- :: forall els (e :: [k]). (e ~ '[], Verifiable (JT (SObject els)) e, Schematic (SObject els))
189-- :: forall els (e :: [k]). (e ~ '[], Verifiable (JT (SObject els)) e, Schematic (SObject els))
test/SchemaSpec.hs+5
@@ -8,6 +8,8 @@ type TextSchema = SText '[LengthEqNat 2]
8
8
9type NumberSchema = SNumber '[ Gt 3]
9type NumberSchema = SNumber '[ Gt 3]
10
10
11+type ArraySchema = SArray '[ LengthEqNat 3 ] NumberSchema
12+
11type ObjectSchema
13type ObjectSchema
12 = SObject '[ Field "carrier" 'JText '[LengthEqNat 2], Field "number_gt_3" 'JNumber '[Gt 3] ]
14 = SObject '[ Field "carrier" 'JText '[LengthEqNat 2], Field "number_gt_3" 'JNumber '[Gt 3] ]
13
15
@@ -17,10 +19,13 @@ spec = do
17 let
19 let
18 textSchema = SchemaText [LengthEq 2]
20 textSchema = SchemaText [LengthEq 2]
19 numberSchema = SchemaNumber [Gt 3]
21 numberSchema = SchemaNumber [Gt 3]
22+ arraySchema = SchemaArray [LengthArrEq 3] $ SchemaNumber [Gt 3]
20 it "translate string schema"
23 it "translate string schema"
21 $ build (Proxy @TextSchema) `shouldBe` textSchema
24 $ build (Proxy @TextSchema) `shouldBe` textSchema
22 it "translates number schema"
25 it "translates number schema"
23 $ build (Proxy @NumberSchema) `shouldBe` numberSchema
26 $ build (Proxy @NumberSchema) `shouldBe` numberSchema
27+ it "translates array schema" $ do
28+ build (Proxy @ArraySchema) `shouldBe` arraySchema
24 it "translates object schema" $ do
29 it "translates object schema" $ do
25 build (Proxy @ObjectSchema) `shouldBe`
30 build (Proxy @ObjectSchema) `shouldBe`
26 SchemaObject [("carrier", textSchema), ("number_gt_3", numberSchema)]
31 SchemaObject [("carrier", textSchema), ("number_gt_3", numberSchema)]