git.iko.soy/typeable/schematic
on master help sign in
reduce mess WIP
06e017bDenis Redozubov
src/Data/Schematic/Schema.hs+75−39
compare with master
unifiedsplit
@@ -15,7 +15,6 @@ import Data.Text (Text)
15import Data.Type.Equality
15import Data.Type.Equality
16import Data.Vinyl
16import Data.Vinyl
17import Data.Vinyl.Functor
17import Data.Vinyl.Functor
18−import GHC.Exts
19import GHC.TypeLits (KnownNat, natVal, KnownSymbol, symbolVal, Symbol, Nat)
18import GHC.TypeLits (KnownNat, natVal, KnownSymbol, symbolVal, Symbol, Nat)
20
19
21
20
@@ -27,6 +26,7 @@ data JType
27 | JObject
26 | JObject
28 | JNull
27 | JNull
29
28
29+
30type family Repr (ty :: JType) :: * where
30type family Repr (ty :: JType) :: * where
31 Repr 'JText = String -- because of matchRegex
31 Repr 'JText = String -- because of matchRegex
32 Repr 'JNumber = Double
32 Repr 'JNumber = Double
@@ -34,47 +34,53 @@ type family Repr (ty :: JType) :: * where
34class Constrained (ty :: JType) c where
34class Constrained (ty :: JType) c where
35 cRep :: Proxy ty -> Proxy c -> CRepr ty
35 cRep :: Proxy ty -> Proxy c -> CRepr ty
36
36
37+-- Validators
38+
37data LengthEqNat nat
39data LengthEqNat nat
38
40
39instance KnownNat nat => Constrained 'JText (LengthEqNat nat) where
41instance KnownNat nat => Constrained 'JText (LengthEqNat nat) where
40 cRep _ _ = LengthEq $ natVal (Proxy @nat)
42 cRep _ _ = LengthEq $ natVal (Proxy @nat)
41
43
42−data Field field jty schema
44+data Gt nat
45+
46+instance KnownNat nat => Constrained 'JNumber (Gt nat) where
47+ cRep _ _ = Gt $ natVal (Proxy @nat)
43
48
49+-- /Validators
50+
51+data Field field ty schema
52+
44−instance (Schematic jty, Verifiable (JT jty) cs, KnownSymbol field)
53+instance (SchemaConstructor (JT jty), Verifiable (JT jty) cs, KnownSymbol field)
45− => Constrained JObject (Field field jty cs) where
54+ => Constrained JObject (Field field ty cs) where
46 cRep _ _ =
55 cRep _ _ =
47− (symbolVal (Proxy @field), constructor (Proxy @jty) $ schema (Proxy @(JT jty)) (Proxy @cs))
56+ (symbolVal (Proxy @field), constructor (Proxy @(JT jty))
57+ $ schema (Proxy @(JT jty)) (Proxy @cs))
58+
59+data Empty
48
60
49class Verifiable ty cs where
61class Verifiable ty cs where
50 schema :: Proxy ty -> Proxy cs -> [CRepr ty]
62 schema :: Proxy ty -> Proxy cs -> [CRepr ty]
51
63
52−instance Verifiable JText '[] where
53− schema _ _ = []
54−
55instance
64instance
56− (Constrained JText c, Verifiable JText cs) => Verifiable JText (c ': cs) where
65+ (Constrained 'JText c, Verifiable 'JText cs) => Verifiable 'JText (c ': cs) where
57− schema _ _ = schema (Proxy @JText) (Proxy @cs) ++ schema (Proxy @JText) (Proxy @cs)
66+ schema _ _ = cRep (Proxy @'JText) (Proxy @c) : schema (Proxy @'JText) (Proxy @cs)
58−
59−instance Verifiable JNumber '[] where
60− schema _ _ = []
61
67
62instance
68instance
63− (Constrained JNumber c, Verifiable JNumber cs) => Verifiable JNumber (c ': cs) where
69+ (Constrained 'JNumber c, Verifiable 'JNumber cs) => Verifiable 'JNumber (c ': cs) where
64− schema _ _ = schema (Proxy @JNumber) (Proxy @cs) ++ schema (Proxy @JNumber) (Proxy @cs)
70+ schema _ _ = cRep (Proxy @'JNumber) (Proxy @c) : schema (Proxy @'JNumber) (Proxy @cs)
65
71
66−instance Verifiable JObject '[] where
72+instance Verifiable jty '[] where
67 schema _ _ = []
73 schema _ _ = []
68
74
69instance
75instance
70− (Constrained JObject c, Verifiable JObject cs, KnownSymbol field)
76+ (Constrained 'JObject c, Verifiable 'JObject cs, KnownSymbol field)
71− => Verifiable JObject ((Field field jty c) ': cs) where
77+ => Verifiable 'JObject ((Field field jty c) ': cs) where
72− schema _ _ = cRep (Proxy @JObject) (Proxy @c) : schema (Proxy @JObject) (Proxy @cs)
78+ schema _ _ = cRep (Proxy @'JObject) (Proxy @c) : schema (Proxy @'JObject) (Proxy @cs)
73
79
74−type family VerifiableFields (ty :: JType) (els :: [k]) :: Constraint where
80+-- type family VerifiableFields (ty :: JType) (els :: [k]) :: Constraint where
75− VerifiableFields ty '[] = ()
81+-- VerifiableFields ty '[] = ()
76− VerifiableFields ty ((Field f jty s) ': elss)
82+-- VerifiableFields ty ((Field f jty s) ': elss)
77− = (Constrained jty s, VerifiableFields ty elss)
83+-- = (Verifiable jty s, VerifiableFields ty elss)
78
84
79type family CRepr (jty :: JType) :: * where
85type family CRepr (jty :: JType) :: * where
80 CRepr JText = TextConstraint
86 CRepr JText = TextConstraint
@@ -85,54 +91,84 @@ data TextConstraint
85 = LengthEq Integer
91 = LengthEq Integer
86 | LengthLe Integer
92 | LengthLe Integer
87 | LengthGt Integer
93 | LengthGt Integer
94+ deriving (Show, Eq)
88
95
89data NumberConstraint
96data NumberConstraint
90 = Le Integer
97 = Le Integer
91 | Gt Integer
98 | Gt Integer
92 | Eq Integer
99 | Eq Integer
100+ deriving (Show, Eq)
93
101
94data Schema
102data Schema
95 = SchemaText [TextConstraint]
103 = SchemaText [TextConstraint]
96 | SchemaNumber [NumberConstraint]
104 | SchemaNumber [NumberConstraint]
97 | SchemaObject [(String, Schema)]
105 | SchemaObject [(String, Schema)]
98 | SchemaArray Schema
106 | SchemaArray Schema
107+ deriving (Show, Eq)
99
108
100-- | Apply constraint for each element of list
109-- | Apply constraint for each element of list
101type family AllSatisfy (c :: k -> Constraint) (s :: [k]) :: Constraint where
110type family AllSatisfy (c :: k -> Constraint) (s :: [k]) :: Constraint where
102 AllSatisfy c '[] = ()
111 AllSatisfy c '[] = ()
103 AllSatisfy c (a ': as) = (c a, AllSatisfy c as)
112 AllSatisfy c (a ': as) = (c a, AllSatisfy c as)
104
113
114+class SchemaConstructor jty where
115+ constructor :: Proxy jty -> [CRepr jty] -> Schema
116+
117+instance SchemaConstructor 'JText where
118+ constructor _ = SchemaText
119+
120+instance SchemaConstructor 'JNumber where
121+ constructor _ = SchemaNumber
122+
123+instance SchemaConstructor 'JObject where
124+ constructor _ = SchemaObject
125+
105−class Schematic ty where
126+class (SchemaConstructor (JT ty)) => Schematic ty where
106− type JT ty :: JType
127+ type JT (ty :: k) :: JType
107− constructor :: Proxy ty -> [CRepr (JT ty)] -> Schema
128+ build :: Proxy ty -> Schema
108
129
109data SText cs
130data SText cs
110
131
111−instance (Verifiable JText cs) => Schematic (SText cs) where
132+instance (Verifiable 'JText cs) => Schematic (SText cs) where
112− type JT (SText cs) = JText
133+ type JT (SText cs) = 'JText
113− constructor _ = SchemaText
134+ build _ = constructor (Proxy @(JT (SText cs))) $ schema (Proxy @JText) (Proxy @cs)
114
135
115-- example
136-- example
116type TextSchema = SText '[LengthEqNat 3]
137type TextSchema = SText '[LengthEqNat 3]
117
138
118data SNumber cs
139data SNumber cs
119
140
120−instance (Verifiable JNumber cs) => Schematic (SNumber cs) where
141+instance (Verifiable 'JNumber cs) => Schematic (SNumber cs) where
121− type JT (SNumber cs) = JNumber
142+ type JT (SNumber cs) = 'JNumber
122− constructor _ = SchemaNumber
143+ build _ = constructor (Proxy @(JT (SNumber cs))) $ schema (Proxy @'JNumber) (Proxy @cs)
144+
145+-- example
146+type NumberSchema = SNumber '[ Gt 3]
147+
148+instance (Verifiable (JT ty) cs, SchemaConstructor (JT ty)) => Schematic (Field field ty cs) where
149+ type JT (Field field ty cs) = JT ty
150+ build _ = constructor (Proxy @(JT (Field field ty cs)))
151+ $ schema (Proxy @(JT (Field field ty cs))) (Proxy @cs)
123
152
124data SObject els
153data SObject els
125
154
126−instance (els ~ '[k], AllSatisfy Schematic els) => Schematic (SObject els) where
155+instance (els ~ '[k], Verifiable 'JObject els, AllSatisfy Schematic els)
156+ => Schematic (SObject els) where
127− type JT (SObject els) = JObject
157+ type JT (SObject els) = 'JObject
128− constructor _ = SchemaObject
158+ build _ =
159+ constructor (Proxy @(JT (SObject els)))
160+ $ schema (Proxy @(JT (SObject els))) (Proxy @els)
129
161
130-- | Shows it's top-level definition according to the json-schema
162-- | Shows it's top-level definition according to the json-schema
131class TopLevel spec
163class TopLevel spec
132
164
133−instance Schematic (SObject spec) => TopLevel (SObject els)
165+instance Schematic (SObject els) => TopLevel (SObject els)
134
166
135−-- toSchema :: forall spec cs. (Schematic spec, VerifiableFields (JT spec), TopLevel spec) => Proxy spec -> Schema
167+-- | TODO: abstract over objects and arrays
168+-- toSchema
169+-- :: forall els (e :: [k]). (e ~ '[], Verifiable (JT (SObject els)) e, Schematic (SObject els))
170+-- => Proxy (SObject els)
171+-- -> Schema
136−-- toSchema pspec = constructor pspec $ schema (Proxy @(JT spec)) pspec
172+-- toSchema p = constructor p $ schema (Proxy @(JT (SObject els))) (Proxy @els)
137
173
138−type TestStruct = SObject '[ '("carrier", [SText '[LengthEqNat 3]]) ]
174+type TestStruct = SObject '[ Field "carrier" 'JText [SText '[LengthEqNat 3] ] ]