git.iko.soy/purestack-dev/purescript-projectm36-client
on master help sign in
purestack-dev/purescript-projectm36-client/src/ProjectM36.purs
186 lines 5.7 kB history raw
1module ProjectM36 where
3import Prelude
4import Prim.Row
5import Prim.RowList
6import Type.Prelude
8import Data.Newtype (class Newtype)
9import Data.Set (Set)
10import Data.Set as Set
11import Foreign.Object (Object)
12import Foreign.Object as Object
13import Prim.Row as Row
14import Prim.RowList as RowList
16data 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
26type RelVarName = String
27type Attribute = String
29class RelVar :: forall k. k -> Constraint
30class RelVar rel where
31 relVar :: String
33rel :: forall @rel fields. Newtype rel (Record fields) => RelVar rel => Rel fields
34rel = Rel $ RelationVariable (relVar @rel)
36newtype Rel (fields :: Row Type) = Rel Expr
38union :: forall fields. Rel fields -> Rel fields -> Rel fields
39union (Rel x) (Rel y) = Rel $ Union x y
41difference :: forall fields. Rel fields -> Rel fields -> Rel fields
42difference (Rel x) (Rel y) = Rel $ Difference x y
44join
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'
55join (Rel lhs) (Rel rhs) = Rel $ Join lhs rhs
57class AssertNoConflict :: forall k. RowList k -> Row k -> Constraint
58class AssertNoConflict xs ys
60instance AssertNoConflict Nil xs
61instance (AssertNoConflict ys xs, Row.Cons l y xs' xs) => AssertNoConflict (RowList.Cons l y ys) xs
63rename
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'
70rename (Rel x) = Rel $ Rename (reifyRename @rename') x
72class ReifyRename :: RowList Symbol -> Constraint
73class ReifyRename rename where
74 reifyRename :: Object Attribute
76instance ReifyRename RowList.Nil where
77 reifyRename = Object.empty
79instance (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)
82class RenameRel :: forall k. RowList Symbol -> Row k -> Row k -> Constraint
83class RenameRel rename fields fields' | rename fields -> fields'
85instance RenameRel RowList.Nil fields fields
86instance
87 ( Row.Cons from t fields' fields
88 , Row.Cons to t fields' fields''
89 ) =>
90 RenameRel (RowList.Cons from to rest) fields fields''
92project
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'
99project (Rel x) = Rel $ Project (reifyFields @projection') x
101class ProjectRel :: forall k l. RowList k -> Row l -> Row l -> Constraint
102class ProjectRel projection fields fields' | projection fields -> fields'
104instance ProjectRel RowList.Nil fields ()
105instance
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'
112class ReifyFields :: forall k. RowList k -> Constraint
113class ReifyFields row where
114 reifyFields :: Set Attribute
116instance ReifyFields RowList.Nil where
117 reifyFields = Set.empty
119instance (IsSymbol field, ReifyFields rest) => ReifyFields (RowList.Cons field v rest) where
120 reifyFields = Set.insert (reflectSymbol @field Proxy) (reifyFields @rest)
122group
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'
132group (Rel x) = Rel $ Group (reifyFields @group') (reflectSymbol @field Proxy) x
134class GroupRel :: forall k l. RowList l -> Row k -> Row k -> Constraint
135class GroupRel group fields groupped | group fields -> groupped
137instance GroupRel RowList.Nil fields ()
139instance
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'
146class DropFields :: forall l k. RowList l -> Row k -> Row k -> Constraint
147class DropFields drop fields fields' | drop fields -> fields'
149instance DropFields RowList.Nil fields fields
151instance (DropFields rest fields fields'', Row.Cons field t' fields' fields'') => DropFields (RowList.Cons field t rest) fields fields'
153ungroup
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'
162ungroup (Rel x) = Rel $ Ungroup (reflectSymbol @field Proxy) x
164class AssertNoDuplicates :: forall k. RowList k -> Row k -> Constraint
165class AssertNoDuplicates xs ys
167instance AssertNoDuplicates RowList.Nil ys
168instance (AssertNoDuplicates rest ys, Row.Lacks field ys) => AssertNoDuplicates (RowList.Cons field t rest) ys
170---------------------------------------------------------------------------------------------------
172newtype Foo = Foo { a :: Int, b :: String, x :: Rel (a :: Int, d :: Number) }
174derive instance Newtype Foo _
176instance RelVar Foo where
177 relVar = "foo"
179newtype Bar = Bar { b :: String, c :: Boolean }
181derive instance Newtype Bar _
183instance RelVar Bar where
184 relVar = "bar"
186baz = ungroup @"x" (rel @Foo)