@@ -1,6 +1,7 @@
11{-# LANGUAGE AllowAmbiguousTypes #-}
22{-# LANGUAGE InstanceSigs #-}
33{-# LANGUAGE UndecidableInstances #-}
4+{-# OPTIONS_GHC -fprint-explicit-kinds #-}
45
56module Data.Schematic.Schema where
67
@@ -14,22 +15,22 @@ import Data.Vinyl.Functor
1415import GHC.TypeLits (KnownNat, natVal, KnownSymbol, symbolVal, Symbol, Nat)
1516
1617singletons [d|
17− data Type
18+ data Type els
1819 = Text
1920 | Number
2021 | Array
21− | Object
22+ | Object els
2223 | Null
2324
2425 |]
2526
26−type family CRepr (ty :: k) :: Type
27+type family CRepr (ty :: k) :: Type els
2728
2829type family Repr (ty :: k1) :: k2 where
2930 Repr 'Text = String -- because of matchRegex
3031 Repr 'Number = Double
3132
32−class Constrained c ty | c -> ty where
33+class Constrained c ty where
3334 predicate :: Repr ty -> Bool
3435
3536data LengthEqNat nat
@@ -40,47 +41,44 @@ instance KnownNat nat => Constrained (LengthEqNat nat) Text where
4041type instance CRepr (LengthEqNat nat) = Number
4142
4243type family Verifiable (els :: k) (t :: z) :: Constraint where
43− Verifiable '[] ty = ()
44+ Verifiable '[] ty = ()
4445 Verifiable (e : els) ty = (Constrained e (CRepr e), Verifiable els ty)
4546
46−data Exists f 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
54− SchemaNumber :: Schema
55− SchemaObjCons :: KnownSymbol label
47+data Schema (ty :: Type k) where
48+ SchemaText :: Verifiable cs Text => Rec Sing cs -> Schema Text
49+ SchemaNumber :: Verifiable cs Number => Rec Sing cs -> Schema Number
50+ SchemaObjCons :: (KnownSymbol label, Verifiable cs t)
5651 => Proxy label
57− -> Schema -- new elem
58− -> Schema -- tail
59− -> Schema
60− SchemaObjNil :: Schema
52+ -> Rec Sing cs
53+ -> Schema t -- new elem
54+ -> Schema (Object tys) -- tail
55+ -> Schema (Object (t ': tys))
56+ SchemaObjNil :: Schema (Object '[])
6157
6258class Schematic ty where
63− rep :: Proxy ty -> Schema
64−
65−-- | Signals it's appropriate as a top-level json type
66−-- class Schematic ty => TopLevel ty
59+ type SchemaOf ty :: Type t
60+ rep :: Proxy ty -> Schema (SchemaOf ty)
6761
6862data c :% s
6963
7064instance Schematic s => Schematic (c :% s) where
65+ type SchemaOf (c :% s) = SchemaOf s
7166 rep _ = rep $ Proxy @s
7267
7368data NilObj
7469
7570instance Schematic NilObj where
71+ type SchemaOf NilObj = Object '[]
7672 rep _ = SchemaObjNil
7773
78−data (:**) (label :: Symbol) e (s :: Type)
74+data (:**) (label :: Symbol) e (s :: k)
7975
8076instance (KnownSymbol label, Schematic e, Schematic s)
8177 => Schematic (label :** e s) where
78+ type SchemaOf (label :** e s) = SchemaOf s
8279 rep _ = SchemaObjCons
8380 (Proxy @label)
81+ RNil
8482 (rep $ Proxy @e)
8583 (rep $ Proxy @s)
8684
@@ -89,6 +87,9 @@ data JText
8987instance Schematic JText where
9088 rep _ = SchemaText
9189
92−-- type TestStruct
93−-- = "carrier" (JString :% LengthEqNat 2 :% Regexp "[a-zA-Z]+")
94−-- :& "booking_classes" (JArray :% (LengthArrLe 5) (JString :% Regexp "[a-zA-Z]{2}"))
90+-- | Signals it's appropriate as a top-level json type
91+-- class Schematic ty => TopLevel ty
92+
93+-- -- type TestStruct
94+-- -- = "carrier" (JString :% LengthEqNat 2 :% Regexp "[a-zA-Z]+")
95+-- -- :& "booking_classes" (JArray :% (LengthArrLe 5) (JString :% Regexp "[a-zA-Z]{2}"))