git.iko.soy/schematic
on master help sign in
TypeInType failg
ff78b8eDenis Redozubov
src/Data/Schematic/Schema.hs+28−27
compare with master
unifiedsplit
@@ -1,6 +1,7 @@
1{-# LANGUAGE AllowAmbiguousTypes #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE InstanceSigs #-}
2{-# LANGUAGE InstanceSigs #-}
3{-# LANGUAGE UndecidableInstances #-}
3{-# LANGUAGE UndecidableInstances #-}
4+{-# OPTIONS_GHC -fprint-explicit-kinds #-}
4
5
5module Data.Schematic.Schema where
6module Data.Schematic.Schema where
6
7
@@ -14,22 +15,22 @@ import Data.Vinyl.Functor
14import GHC.TypeLits (KnownNat, natVal, KnownSymbol, symbolVal, Symbol, Nat)
15import GHC.TypeLits (KnownNat, natVal, KnownSymbol, symbolVal, Symbol, Nat)
15
16
16singletons [d|
17singletons [d|
17− data Type
18+ data Type els
18 = Text
19 = Text
19 | Number
20 | Number
20 | Array
21 | Array
21− | Object
22+ | Object els
22 | Null
23 | Null
23
24
24 |]
25 |]
25
26
26−type family CRepr (ty :: k) :: Type
27+type family CRepr (ty :: k) :: Type els
27
28
28type family Repr (ty :: k1) :: k2 where
29type family Repr (ty :: k1) :: k2 where
29 Repr 'Text = String -- because of matchRegex
30 Repr 'Text = String -- because of matchRegex
30 Repr 'Number = Double
31 Repr 'Number = Double
31
32
32−class Constrained c ty | c -> ty where
33+class Constrained c ty where
33 predicate :: Repr ty -> Bool
34 predicate :: Repr ty -> Bool
34
35
35data LengthEqNat nat
36data LengthEqNat nat
@@ -40,47 +41,44 @@ instance KnownNat nat => Constrained (LengthEqNat nat) Text where
40type instance CRepr (LengthEqNat nat) = Number
41type instance CRepr (LengthEqNat nat) = Number
41
42
42type family Verifiable (els :: k) (t :: z) :: Constraint where
43type family Verifiable (els :: k) (t :: z) :: Constraint where
43− Verifiable '[] ty = ()
44+ Verifiable '[] ty = ()
44 Verifiable (e : els) ty = (Constrained e (CRepr e), Verifiable els ty)
45 Verifiable (e : els) ty = (Constrained e (CRepr e), Verifiable els ty)
45
46
46−data Exists f where
47+data Schema (ty :: Type k) where
47− Exists :: f a -> Exists f
48−
49−data C els =
50− forall els ty. Verifiable els ty => C (Rec Proxy els)
51−
52−data Schema where
53− SchemaText :: Schema
48+ SchemaText :: Verifiable cs Text => Rec Sing cs -> Schema Text
54− SchemaNumber :: Schema
49+ SchemaNumber :: Verifiable cs Number => Rec Sing cs -> Schema Number
55− SchemaObjCons :: KnownSymbol label
50+ SchemaObjCons :: (KnownSymbol label, Verifiable cs t)
56 => Proxy label
51 => Proxy label
52+ -> Rec Sing cs
57− -> Schema -- new elem
53+ -> Schema t -- new elem
58− -> Schema -- tail
54+ -> Schema (Object tys) -- tail
59− -> Schema
55+ -> Schema (Object (t ': tys))
60− SchemaObjNil :: Schema
56+ SchemaObjNil :: Schema (Object '[])
61
57
62class Schematic ty where
58class Schematic ty where
59+ type SchemaOf ty :: Type t
63− rep :: Proxy ty -> Schema
60+ rep :: Proxy ty -> Schema (SchemaOf ty)
64−
65−-- | Signals it's appropriate as a top-level json type
66−-- class Schematic ty => TopLevel ty
67
61
68data c :% s
62data c :% s
69
63
70instance Schematic s => Schematic (c :% s) where
64instance Schematic s => Schematic (c :% s) where
65+ type SchemaOf (c :% s) = SchemaOf s
71 rep _ = rep $ Proxy @s
66 rep _ = rep $ Proxy @s
72
67
73data NilObj
68data NilObj
74
69
75instance Schematic NilObj where
70instance Schematic NilObj where
71+ type SchemaOf NilObj = Object '[]
76 rep _ = SchemaObjNil
72 rep _ = SchemaObjNil
77
73
78−data (:**) (label :: Symbol) e (s :: Type)
74+data (:**) (label :: Symbol) e (s :: k)
79
75
80instance (KnownSymbol label, Schematic e, Schematic s)
76instance (KnownSymbol label, Schematic e, Schematic s)
81 => Schematic (label :** e s) where
77 => Schematic (label :** e s) where
78+ type SchemaOf (label :** e s) = SchemaOf s
82 rep _ = SchemaObjCons
79 rep _ = SchemaObjCons
83 (Proxy @label)
80 (Proxy @label)
81+ RNil
84 (rep $ Proxy @e)
82 (rep $ Proxy @e)
85 (rep $ Proxy @s)
83 (rep $ Proxy @s)
86
84
@@ -89,6 +87,9 @@ data JText
89instance Schematic JText where
87instance Schematic JText where
90 rep _ = SchemaText
88 rep _ = SchemaText
91
89
90+-- | Signals it's appropriate as a top-level json type
91+-- class Schematic ty => TopLevel ty
92+
92−-- type TestStruct
93+-- -- type TestStruct
93−-- = "carrier" (JString :% LengthEqNat 2 :% Regexp "[a-zA-Z]+")
94+-- -- = "carrier" (JString :% LengthEqNat 2 :% Regexp "[a-zA-Z]+")
94−-- :& "booking_classes" (JArray :% (LengthArrLe 5) (JString :% Regexp "[a-zA-Z]{2}"))
95+-- -- :& "booking_classes" (JArray :% (LengthArrLe 5) (JString :% Regexp "[a-zA-Z]{2}"))