@@ -0,0 +1,94 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE InstanceSigs #-}
3+{-# LANGUAGE UndecidableInstances #-}
4+
5+module Data.Schematic.Schema where
6+
7+import Data.Functor.Foldable
8+import Data.Singletons.TH
9+import Data.Kind hiding (Type)
10+import Data.Proxy
11+import Data.Type.Equality
12+import Data.Vinyl
13+import Data.Vinyl.Functor
14+import GHC.TypeLits (KnownNat, natVal, KnownSymbol, symbolVal, Symbol, Nat)
15+
16+singletons [d|
17+ data Type
18+ = Text
19+ | Number
20+ | Array
21+ | Object
22+ | Null
23+
24+ |]
25+
26+type family CRepr (ty :: k) :: Type
27+
28+type family Repr (ty :: k1) :: k2 where
29+ Repr 'Text = String -- because of matchRegex
30+ Repr 'Number = Double
31+
32+class Constrained c ty | c -> ty where
33+ predicate :: Repr ty -> Bool
34+
35+data LengthEqNat nat
36+
37+instance KnownNat nat => Constrained (LengthEqNat nat) Text where
38+ predicate n = natVal (Proxy @nat) == fromIntegral (length n)
39+
40+type instance CRepr (LengthEqNat nat) = Number
41+
42+type family Verifiable (els :: k) (t :: z) :: Constraint where
43+ Verifiable '[] ty = ()
44+ Verifiable (e : els) ty = (Constrained e (CRepr e), Verifiable els ty)
45+
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
56+ => Proxy label
57+ -> Schema -- new elem
58+ -> Schema -- tail
59+ -> Schema
60+ SchemaObjNil :: Schema
61+
62+class 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
67+
68+data c :% s
69+
70+instance Schematic s => Schematic (c :% s) where
71+ rep _ = rep $ Proxy @s
72+
73+data NilObj
74+
75+instance Schematic NilObj where
76+ rep _ = SchemaObjNil
77+
78+data (:**) (label :: Symbol) e (s :: Type)
79+
80+instance (KnownSymbol label, Schematic e, Schematic s)
81+ => Schematic (label :** e s) where
82+ rep _ = SchemaObjCons
83+ (Proxy @label)
84+ (rep $ Proxy @e)
85+ (rep $ Proxy @s)
86+
87+data JText
88+
89+instance Schematic JText where
90+ rep _ = SchemaText
91+
92+-- type TestStruct
93+-- = "carrier" (JString :% LengthEqNat 2 :% Regexp "[a-zA-Z]+")
94+-- :& "booking_classes" (JArray :% (LengthArrLe 5) (JString :% Regexp "[a-zA-Z]{2}"))