@@ -15,7 +15,6 @@ import Data.Text (Text)
1515import Data.Type.Equality
1616import Data.Vinyl
1717import Data.Vinyl.Functor
18−import GHC.Exts
1918import GHC.TypeLits (KnownNat, natVal, KnownSymbol, symbolVal, Symbol, Nat)
2019
2120
@@ -27,6 +26,7 @@ data JType
2726 | JObject
2827 | JNull
2928
29+
3030type family Repr (ty :: JType) :: * where
3131 Repr 'JText = String -- because of matchRegex
3232 Repr 'JNumber = Double
@@ -34,47 +34,53 @@ type family Repr (ty :: JType) :: * where
3434class Constrained (ty :: JType) c where
3535 cRep :: Proxy ty -> Proxy c -> CRepr ty
3636
37+-- Validators
38+
3739data LengthEqNat nat
3840
3941instance KnownNat nat => Constrained 'JText (LengthEqNat nat) where
4042 cRep _ _ = LengthEq $ natVal (Proxy @nat)
4143
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)
4348
44−instance (Schematic jty, Verifiable (JT jty) cs, KnownSymbol field)
45− => Constrained JObject (Field field jty cs) where
49+-- /Validators
50+
51+data Field field ty schema
52+
53+instance (SchemaConstructor (JT jty), Verifiable (JT jty) cs, KnownSymbol field)
54+ => Constrained JObject (Field field ty cs) where
4655 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
4860
4961class Verifiable ty cs where
5062 schema :: Proxy ty -> Proxy cs -> [CRepr ty]
5163
52−instance Verifiable JText '[] where
53− schema _ _ = []
54−
5564instance
56− (Constrained JText c, Verifiable JText cs) => Verifiable JText (c ': cs) where
57− schema _ _ = schema (Proxy @JText) (Proxy @cs) ++ schema (Proxy @JText) (Proxy @cs)
58−
59−instance Verifiable JNumber '[] where
60− schema _ _ = []
65+ (Constrained 'JText c, Verifiable 'JText cs) => Verifiable 'JText (c ': cs) where
66+ schema _ _ = cRep (Proxy @'JText) (Proxy @c) : schema (Proxy @'JText) (Proxy @cs)
6167
6268instance
63− (Constrained JNumber c, Verifiable JNumber cs) => Verifiable JNumber (c ': cs) where
64− schema _ _ = schema (Proxy @JNumber) (Proxy @cs) ++ schema (Proxy @JNumber) (Proxy @cs)
69+ (Constrained 'JNumber c, Verifiable 'JNumber cs) => Verifiable 'JNumber (c ': cs) where
70+ schema _ _ = cRep (Proxy @'JNumber) (Proxy @c) : schema (Proxy @'JNumber) (Proxy @cs)
6571
66−instance Verifiable JObject '[] where
72+instance Verifiable jty '[] where
6773 schema _ _ = []
6874
6975instance
70− (Constrained JObject c, Verifiable JObject cs, KnownSymbol field)
71− => Verifiable JObject ((Field field jty c) ': cs) where
72− schema _ _ = cRep (Proxy @JObject) (Proxy @c) : schema (Proxy @JObject) (Proxy @cs)
76+ (Constrained 'JObject c, Verifiable 'JObject cs, KnownSymbol field)
77+ => Verifiable 'JObject ((Field field jty c) ': cs) where
78+ schema _ _ = cRep (Proxy @'JObject) (Proxy @c) : schema (Proxy @'JObject) (Proxy @cs)
7379
74−type family VerifiableFields (ty :: JType) (els :: [k]) :: Constraint where
75− VerifiableFields ty '[] = ()
76− VerifiableFields ty ((Field f jty s) ': elss)
77− = (Constrained jty s, VerifiableFields ty elss)
80+-- type family VerifiableFields (ty :: JType) (els :: [k]) :: Constraint where
81+-- VerifiableFields ty '[] = ()
82+-- VerifiableFields ty ((Field f jty s) ': elss)
83+-- = (Verifiable jty s, VerifiableFields ty elss)
7884
7985type family CRepr (jty :: JType) :: * where
8086 CRepr JText = TextConstraint
@@ -85,54 +91,84 @@ data TextConstraint
8591 = LengthEq Integer
8692 | LengthLe Integer
8793 | LengthGt Integer
94+ deriving (Show, Eq)
8895
8996data NumberConstraint
9097 = Le Integer
9198 | Gt Integer
9299 | Eq Integer
100+ deriving (Show, Eq)
93101
94102data Schema
95103 = SchemaText [TextConstraint]
96104 | SchemaNumber [NumberConstraint]
97105 | SchemaObject [(String, Schema)]
98106 | SchemaArray Schema
107+ deriving (Show, Eq)
99108
100109-- | Apply constraint for each element of list
101110type family AllSatisfy (c :: k -> Constraint) (s :: [k]) :: Constraint where
102111 AllSatisfy c '[] = ()
103112 AllSatisfy c (a ': as) = (c a, AllSatisfy c as)
104113
105−class Schematic ty where
106− type JT ty :: JType
107− constructor :: Proxy ty -> [CRepr (JT ty)] -> Schema
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+
126+class (SchemaConstructor (JT ty)) => Schematic ty where
127+ type JT (ty :: k) :: JType
128+ build :: Proxy ty -> Schema
108129
109130data SText cs
110131
111−instance (Verifiable JText cs) => Schematic (SText cs) where
112− type JT (SText cs) = JText
113− constructor _ = SchemaText
132+instance (Verifiable 'JText cs) => Schematic (SText cs) where
133+ type JT (SText cs) = 'JText
134+ build _ = constructor (Proxy @(JT (SText cs))) $ schema (Proxy @JText) (Proxy @cs)
114135
115136-- example
116137type TextSchema = SText '[LengthEqNat 3]
117138
118139data SNumber cs
119140
120−instance (Verifiable JNumber cs) => Schematic (SNumber cs) where
121− type JT (SNumber cs) = JNumber
122− constructor _ = SchemaNumber
141+instance (Verifiable 'JNumber cs) => Schematic (SNumber cs) where
142+ type JT (SNumber cs) = 'JNumber
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)
123152
124153data SObject els
125154
126−instance (els ~ '[k], AllSatisfy Schematic els) => Schematic (SObject els) where
127− type JT (SObject els) = JObject
128− constructor _ = SchemaObject
155+instance (els ~ '[k], Verifiable 'JObject els, AllSatisfy Schematic els)
156+ => Schematic (SObject els) where
157+ type JT (SObject els) = 'JObject
158+ build _ =
159+ constructor (Proxy @(JT (SObject els)))
160+ $ schema (Proxy @(JT (SObject els))) (Proxy @els)
129161
130162-- | Shows it's top-level definition according to the json-schema
131163class TopLevel spec
132164
133−instance Schematic (SObject spec) => TopLevel (SObject els)
165+instance Schematic (SObject els) => TopLevel (SObject els)
134166
135−-- toSchema :: forall spec cs. (Schematic spec, VerifiableFields (JT spec), TopLevel spec) => Proxy spec -> Schema
136−-- toSchema pspec = constructor pspec $ schema (Proxy @(JT spec)) pspec
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
172+-- toSchema p = constructor p $ schema (Proxy @(JT (SObject els))) (Proxy @els)
137173
138−type TestStruct = SObject '[ '("carrier", [SText '[LengthEqNat 3]]) ]
174+type TestStruct = SObject '[ Field "carrier" 'JText [SText '[LengthEqNat 3] ] ]