@@ -0,0 +1,186 @@
1+module ProjectM36 where
2+
3+import Prelude
4+import Prim.Row
5+import Prim.RowList
6+import Type.Prelude
7+
8+import Data.Newtype (class Newtype)
9+import Data.Set (Set)
10+import Data.Set as Set
11+import Foreign.Object (Object)
12+import Foreign.Object as Object
13+import Prim.Row as Row
14+import Prim.RowList as RowList
15+
16+data Expr
17+ = Join Expr Expr
18+ | Union Expr Expr
19+ | Project (Set Attribute) Expr
20+ | Rename (Object Attribute) Expr
21+ | Difference Expr Expr
22+ | Group (Set Attribute) Attribute Expr
23+ | Ungroup Attribute Expr
24+ | RelationVariable RelVarName
25+
26+type RelVarName = String
27+type Attribute = String
28+
29+class RelVar :: forall k. k -> Constraint
30+class RelVar rel where
31+ relVar :: String
32+
33+rel :: forall @rel fields. Newtype rel (Record fields) => RelVar rel => Rel fields
34+rel = Rel $ RelationVariable (relVar @rel)
35+
36+newtype Rel (fields :: Row Type) = Rel Expr
37+
38+union :: forall fields. Rel fields -> Rel fields -> Rel fields
39+union (Rel x) (Rel y) = Rel $ Union x y
40+
41+difference :: forall fields. Rel fields -> Rel fields -> Rel fields
42+difference (Rel x) (Rel y) = Rel $ Difference x y
43+
44+join
45+ :: forall lhs rhs res lhs' rhs' res'
46+ . Union lhs rhs res
47+ => RowToList lhs lhs'
48+ => RowToList rhs rhs'
49+ => AssertNoConflict lhs' res'
50+ => AssertNoConflict rhs' res'
51+ => Nub res res'
52+ => Rel lhs
53+ -> Rel rhs
54+ -> Rel res'
55+join (Rel lhs) (Rel rhs) = Rel $ Join lhs rhs
56+
57+class AssertNoConflict :: forall k. RowList k -> Row k -> Constraint
58+class AssertNoConflict xs ys
59+
60+instance AssertNoConflict Nil xs
61+instance (AssertNoConflict ys xs, Row.Cons l y xs' xs) => AssertNoConflict (RowList.Cons l y ys) xs
62+
63+rename
64+ :: forall @rename rename' fields fields'
65+ . RowList.RowToList rename rename'
66+ => RenameRel rename' fields fields'
67+ => ReifyRename rename'
68+ => Rel fields
69+ -> Rel fields'
70+rename (Rel x) = Rel $ Rename (reifyRename @rename') x
71+
72+class ReifyRename :: RowList Symbol -> Constraint
73+class ReifyRename rename where
74+ reifyRename :: Object Attribute
75+
76+instance ReifyRename RowList.Nil where
77+ reifyRename = Object.empty
78+
79+instance (ReifyRename rest, IsSymbol from, IsSymbol to) => ReifyRename (RowList.Cons from to rest) where
80+ reifyRename = Object.insert (reflectSymbol @from Proxy) (reflectSymbol @to Proxy) (reifyRename @rest)
81+
82+class RenameRel :: forall k. RowList Symbol -> Row k -> Row k -> Constraint
83+class RenameRel rename fields fields' | rename fields -> fields'
84+
85+instance RenameRel RowList.Nil fields fields
86+instance
87+ ( Row.Cons from t fields' fields
88+ , Row.Cons to t fields' fields''
89+ ) =>
90+ RenameRel (RowList.Cons from to rest) fields fields''
91+
92+project
93+ :: forall @projection projection' fields fields'
94+ . ProjectRel projection' fields fields'
95+ => RowList.RowToList projection projection'
96+ => ReifyFields projection'
97+ => Rel fields
98+ -> Rel fields'
99+project (Rel x) = Rel $ Project (reifyFields @projection') x
100+
101+class ProjectRel :: forall k l. RowList k -> Row l -> Row l -> Constraint
102+class ProjectRel projection fields fields' | projection fields -> fields'
103+
104+instance ProjectRel RowList.Nil fields ()
105+instance
106+ ( ProjectRel rest fields fields''
107+ , Row.Cons field value f fields
108+ , Row.Cons field value fields'' fields'
109+ ) =>
110+ ProjectRel (RowList.Cons field v rest) fields fields'
111+
112+class ReifyFields :: forall k. RowList k -> Constraint
113+class ReifyFields row where
114+ reifyFields :: Set Attribute
115+
116+instance ReifyFields RowList.Nil where
117+ reifyFields = Set.empty
118+
119+instance (IsSymbol field, ReifyFields rest) => ReifyFields (RowList.Cons field v rest) where
120+ reifyFields = Set.insert (reflectSymbol @field Proxy) (reifyFields @rest)
121+
122+group
123+ :: forall @group (@field :: Symbol) group' groupped fields fields' fields''
124+ . RowList.RowToList group group'
125+ => GroupRel group' fields groupped
126+ => Row.Cons field (Rel groupped) fields'' fields'
127+ => DropFields group' fields fields''
128+ => ReifyFields group'
129+ => IsSymbol field
130+ => Rel fields
131+ -> Rel fields'
132+group (Rel x) = Rel $ Group (reifyFields @group') (reflectSymbol @field Proxy) x
133+
134+class GroupRel :: forall k l. RowList l -> Row k -> Row k -> Constraint
135+class GroupRel group fields groupped | group fields -> groupped
136+
137+instance GroupRel RowList.Nil fields ()
138+
139+instance
140+ ( GroupRel rest fields fields''
141+ , Row.Cons field t f fields
142+ , Row.Cons field t fields'' fields'
143+ ) =>
144+ GroupRel (RowList.Cons field u rest) fields fields'
145+
146+class DropFields :: forall l k. RowList l -> Row k -> Row k -> Constraint
147+class DropFields drop fields fields' | drop fields -> fields'
148+
149+instance DropFields RowList.Nil fields fields
150+
151+instance (DropFields rest fields fields'', Row.Cons field t' fields' fields'') => DropFields (RowList.Cons field t rest) fields fields'
152+
153+ungroup
154+ :: forall (@field :: Symbol) fields fields' fields'' group group'
155+ . IsSymbol field
156+ => Row.Cons field (Rel group) fields'' fields
157+ => Row.Union group fields'' fields'
158+ => RowList.RowToList group group'
159+ => AssertNoDuplicates group' fields''
160+ => Rel fields
161+ -> Rel fields'
162+ungroup (Rel x) = Rel $ Ungroup (reflectSymbol @field Proxy) x
163+
164+class AssertNoDuplicates :: forall k. RowList k -> Row k -> Constraint
165+class AssertNoDuplicates xs ys
166+
167+instance AssertNoDuplicates RowList.Nil ys
168+instance (AssertNoDuplicates rest ys, Row.Lacks field ys) => AssertNoDuplicates (RowList.Cons field t rest) ys
169+
170+---------------------------------------------------------------------------------------------------
171+
172+newtype Foo = Foo { a :: Int, b :: String, x :: Rel (a :: Int, d :: Number) }
173+
174+derive instance Newtype Foo _
175+
176+instance RelVar Foo where
177+ relVar = "foo"
178+
179+newtype Bar = Bar { b :: String, c :: Boolean }
180+
181+derive instance Newtype Bar _
182+
183+instance RelVar Bar where
184+ relVar = "bar"
185+
186+baz = ungroup @"x" (rel @Foo)