git.iko.soy/rel8
on master help sign in
Allow the derivation of Rel8able on vanilla HKDs (#111)
119c825Shane
rel8.cabal−1
compare with master
unifiedsplit
@@ -115,7 +115,6 @@ library
115 Rel8.Query.Values
115 Rel8.Query.Values
116
116
117 Rel8.Schema.Context.Nullify
117 Rel8.Schema.Context.Nullify
118− Rel8.Schema.Context.Virtual
119 Rel8.Schema.Dict
118 Rel8.Schema.Dict
120 Rel8.Schema.HTable
119 Rel8.Schema.HTable
121 Rel8.Schema.HTable.Either
120 Rel8.Schema.HTable.Either
src/Rel8/Generic/Rel8able.hs+115−64
@@ -3,12 +3,14 @@
3{-# language DataKinds #-}
3{-# language DataKinds #-}
4{-# language DefaultSignatures #-}
4{-# language DefaultSignatures #-}
5{-# language FlexibleContexts #-}
5{-# language FlexibleContexts #-}
6+{-# language FlexibleInstances #-}
6{-# language LambdaCase #-}
7{-# language LambdaCase #-}
8+{-# language MultiParamTypeClasses #-}
7{-# language ScopedTypeVariables #-}
9{-# language ScopedTypeVariables #-}
8{-# language StandaloneKindSignatures #-}
10{-# language StandaloneKindSignatures #-}
9{-# language TypeApplications #-}
11{-# language TypeApplications #-}
10−{-# language TypeFamilies #-}
11{-# language TypeFamilyDependencies #-}
12{-# language TypeFamilyDependencies #-}
13+{-# language TypeOperators #-}
12{-# language UndecidableInstances #-}
14{-# language UndecidableInstances #-}
13
15
14module Rel8.Generic.Rel8able
16module Rel8.Generic.Rel8able
@@ -17,31 +19,36 @@ module Rel8.Generic.Rel8able
17 , GRep
19 , GRep
18 , GColumns, gfromColumns, gtoColumns
20 , GColumns, gfromColumns, gtoColumns
19 , GFromExprs, gfromResult, gtoResult
21 , GFromExprs, gfromResult, gtoResult
22+ , TSerialize, serialize, deserialize
20 )
23 )
21where
24where
22
25
23-- base
26-- base
24import Data.Kind ( Constraint, Type )
27import Data.Kind ( Constraint, Type )
28+import Data.Type.Equality ( type (==) )
25import GHC.Generics ( Generic, Rep, from, to )
29import GHC.Generics ( Generic, Rep, from, to )
26import Prelude
30import Prelude
27
31
28-- rel8
32-- rel8
29import Rel8.Aggregate ( Aggregate )
33import Rel8.Aggregate ( Aggregate )
30import Rel8.Expr ( Expr )
34import Rel8.Expr ( Expr )
31−import Rel8.Generic.Map ( GMap )
35+import Rel8.FCF ( Exp, Eval )
32import Rel8.Generic.Record ( Record(..) )
36import Rel8.Generic.Record ( Record(..) )
33import Rel8.Generic.Table ( GAlgebra )
37import Rel8.Generic.Table ( GAlgebra )
34import qualified Rel8.Generic.Table.Record as G
38import qualified Rel8.Generic.Table.Record as G
35import qualified Rel8.Kind.Algebra as K ( Algebra(..) )
39import qualified Rel8.Kind.Algebra as K ( Algebra(..) )
36−import Rel8.Schema.Context.Virtual ( Abstract(..) )
40+import Rel8.Kind.Context ( SContext(..) )
37import Rel8.Schema.HTable ( HTable )
41import Rel8.Schema.HTable ( HTable )
38import qualified Rel8.Schema.Kind as K
42import qualified Rel8.Schema.Kind as K
39import Rel8.Schema.Name ( Name )
43import Rel8.Schema.Name ( Name )
40import Rel8.Schema.Result ( Result )
44import Rel8.Schema.Result ( Result )
41import Rel8.Table
45import Rel8.Table
46+ ( Table, Columns, Context, fromColumns, toColumns
42− ( fromColumns, toColumns, fromResult, toResult
47+ , FromExprs, fromResult, toResult
48+ , Transpose
43− , TTable, TColumns, TFromExprs
49+ , TTable, TColumns
44 )
50 )
51+import Rel8.Table.Transpose ( Transposes )
45
52
46
53
47-- | The kind of 'Rel8able' types
54-- | The kind of 'Rel8able' types
@@ -49,6 +56,40 @@ type KRel8able :: Type
49type KRel8able = K.Rel8able
56type KRel8able = K.Rel8able
50
57
51
58
59+type Serialize :: Bool -> Type -> Type -> Constraint
60+class transposition ~ (a == Transpose Result expr) =>
61+ Serialize transposition expr a
62+ where
63+ serialize :: a -> Columns expr Result
64+ deserialize :: Columns expr Result -> a
65+
66+
67+instance
68+ ( (a == Transpose Result expr) ~ 'True
69+ , Transposes Expr Result expr a
70+ )
71+ => Serialize 'True expr a
72+ where
73+ serialize = toColumns
74+ deserialize = fromColumns
75+
76+
77+instance
78+ ( (a == Transpose Result expr) ~ 'False
79+ , Table (Context expr) expr
80+ , FromExprs expr ~ a
81+ )
82+ => Serialize 'False expr a
83+ where
84+ serialize = toResult @_ @expr
85+ deserialize = fromResult @_ @expr
86+
87+
88+data TSerialize :: Type -> Type -> Exp Constraint
89+type instance Eval (TSerialize expr a) =
90+ Serialize (a == Transpose Result expr) expr a
91+
92+
52-- | This type class allows you to define custom 'Table's using higher-kinded
93-- | This type class allows you to define custom 'Table's using higher-kinded
53-- data types. Higher-kinded data types are data types of the pattern:
94-- data types. Higher-kinded data types are data types of the pattern:
54--
95--
@@ -96,8 +137,8 @@ class HTable (GColumns t) => Rel8able t where
96 type GColumns t :: K.HTable
137 type GColumns t :: K.HTable
97 type GFromExprs t :: Type
138 type GFromExprs t :: Type
98
139
99− gfromColumns :: Abstract context -> GColumns t context -> t context
140+ gfromColumns :: SContext context -> GColumns t context -> t context
100− gtoColumns :: Abstract context -> t context -> GColumns t context
141+ gtoColumns :: SContext context -> t context -> GColumns t context
101
142
102 gfromResult :: GColumns t Result -> GFromExprs t
143 gfromResult :: GColumns t Result -> GFromExprs t
103 gtoResult :: GFromExprs t -> GColumns t Result
144 gtoResult :: GFromExprs t -> GColumns t Result
@@ -106,62 +147,38 @@ class HTable (GColumns t) => Rel8able t where
106 type GFromExprs t = t Result
147 type GFromExprs t = t Result
107
148
108 default gfromColumns :: forall context.
149 default gfromColumns :: forall context.
109− ( VRel8able t Aggregate
150+ ( SRel8able t Aggregate
110− , VRel8able t Expr
151+ , SRel8able t Expr
111− , VRel8able t Name
152+ , SRel8able t Name
153+ , SSerialize t
112 )
154 )
113− => Abstract context -> GColumns t context -> t context
155+ => SContext context -> GColumns t context -> t context
114 gfromColumns = \case
156 gfromColumns = \case
115− VAggregate -> vfromColumns
157+ SAggregate -> sfromColumns
116− VExpr -> vfromColumns
158+ SExpr -> sfromColumns
117− VName -> vfromColumns
159+ SName -> sfromColumns
160+ SResult -> sfromResult
118
161
119 default gtoColumns :: forall context.
162 default gtoColumns :: forall context.
120− ( VRel8able t Aggregate
163+ ( SRel8able t Aggregate
121− , VRel8able t Expr
164+ , SRel8able t Expr
122− , VRel8able t Name
165+ , SRel8able t Name
166+ , SSerialize t
123 )
167 )
124− => Abstract context -> t context -> GColumns t context
168+ => SContext context -> t context -> GColumns t context
125 gtoColumns = \case
169 gtoColumns = \case
126− VAggregate -> vtoColumns
170+ SAggregate -> stoColumns
127− VExpr -> vtoColumns
171+ SExpr -> stoColumns
128− VName -> vtoColumns
172+ SName -> stoColumns
129−
173+ SResult -> stoResult
174+
130− default gfromResult ::
175+ default gfromResult :: (SSerialize t, GFromExprs t ~ t Result)
131− ( Generic (Record (t Result))
132− , G.GTable (TTable Expr) TColumns TFromExprs (GRep t Expr)
133− , G.GColumns TColumns (GRep t Expr) ~ GColumns t
134− , Rep (Record (t Result)) ~ GMap TFromExprs (GRep t Expr)
135− , GFromExprs t ~ t Result
136− )
137 => GColumns t Result -> GFromExprs t
176 => GColumns t Result -> GFromExprs t
138− gfromResult =
177+ gfromResult = sfromResult
139− unrecord .
178+
140− to .
141− G.gfromResult
142− @(TTable Expr)
143− @TColumns
144− @TFromExprs
145− @(GRep t Expr)
146− (\(_ :: proxy x) -> fromResult @Expr @x)
147−
148− default gtoResult ::
149− ( Generic (Record (t Result))
150− , G.GTable (TTable Expr) TColumns TFromExprs (GRep t Expr)
151− , G.GColumns TColumns (GRep t Expr) ~ GColumns t
152− , Rep (Record (t Result)) ~ GMap TFromExprs (GRep t Expr)
153− , GFromExprs t ~ t Result
179+ default gtoResult :: (SSerialize t, GFromExprs t ~ t Result)
154− )
155 => GFromExprs t -> GColumns t Result
180 => GFromExprs t -> GColumns t Result
156− gtoResult =
181+ gtoResult = stoResult
157− G.gtoResult
158− @(TTable Expr)
159− @TColumns
160− @TFromExprs
161− @(GRep t Expr)
162− (\(_ :: proxy x) -> toResult @Expr @x) .
163− from .
164− Record
165
182
166
183
167type Algebra :: K.Rel8able -> K.Algebra
184type Algebra :: K.Rel8able -> K.Algebra
@@ -172,25 +189,59 @@ type GRep :: K.Rel8able -> K.Context -> Type -> Type
172type GRep t context = Rep (Record (t context))
189type GRep t context = Rep (Record (t context))
173
190
174
191
175−type VRel8able :: K.Rel8able -> K.Context -> Constraint
192+type SRel8able :: K.Rel8able -> K.Context -> Constraint
176−type VRel8able t context =
193+type SRel8able t context =
177 ( Generic (Record (t context))
194 ( Generic (Record (t context))
178− , G.GTable (TTable context) TColumns TFromExprs (GRep t context)
195+ , G.GTable (TTable context) TColumns (GRep t context)
179 , G.GColumns TColumns (GRep t context) ~ GColumns t
196 , G.GColumns TColumns (GRep t context) ~ GColumns t
180 )
197 )
181
198
182
199
200+type SSerialize :: K.Rel8able -> Constraint
201+type SSerialize t =
202+ ( Generic (Record (t Result))
203+ , G.GSerialize TSerialize TColumns (GRep t Expr) (GRep t Result)
204+ , G.GColumns TColumns (GRep t Expr) ~ GColumns t
205+ )
206+
207+
183−vfromColumns :: forall t context. VRel8able t context
208+sfromColumns :: forall t context. SRel8able t context
184 => GColumns t context -> t context
209 => GColumns t context -> t context
185−vfromColumns =
210+sfromColumns =
186 unrecord .
211 unrecord .
187 to .
212 to .
188− G.gfromColumns @(TTable context) @TColumns @TFromExprs fromColumns
213+ G.gfromColumns @(TTable context) @TColumns fromColumns
189
214
190
215
191−vtoColumns :: forall t context. VRel8able t context
216+stoColumns :: forall t context. SRel8able t context
192 => t context -> GColumns t context
217 => t context -> GColumns t context
193−vtoColumns =
218+stoColumns =
194− G.gtoColumns @(TTable context) @TColumns @TFromExprs toColumns .
219+ G.gtoColumns @(TTable context) @TColumns toColumns .
220+ from .
221+ Record
222+
223+
224+sfromResult :: forall t. SSerialize t
225+ => GColumns t Result -> t Result
226+sfromResult =
227+ unrecord .
228+ to .
229+ G.gfromResult
230+ @TSerialize
231+ @TColumns
232+ @(GRep t Expr)
233+ @(GRep t Result)
234+ (\(_ :: proxy x) -> deserialize @_ @x)
235+
236+
237+stoResult :: forall t. SSerialize t
238+ => t Result -> GColumns t Result
239+stoResult =
240+ G.gtoResult
241+ @TSerialize
242+ @TColumns
243+ @(GRep t Expr)
244+ @(GRep t Result)
245+ (\(_ :: proxy x) -> serialize @_ @x) .
195 from .
246 from .
196 Record
247 Record
src/Rel8/Generic/Table.hs+26−27
@@ -12,7 +12,7 @@
12{-# language UndecidableInstances #-}
12{-# language UndecidableInstances #-}
13
13
14module Rel8.Generic.Table
14module Rel8.Generic.Table
15− ( GGTable, GGColumns, ggfromResult, ggtoResult
15+ ( GGSerialize, GGColumns, ggfromResult, ggtoResult
16 , GAlgebra
16 , GAlgebra
17 )
17 )
18where
18where
@@ -24,11 +24,10 @@ import Prelude ()
24
24
25-- rel8
25-- rel8
26import Rel8.FCF ( Eval, Exp )
26import Rel8.FCF ( Eval, Exp )
27−import Rel8.Generic.Map ( GMap )
28import Rel8.Generic.Table.ADT
27import Rel8.Generic.Table.ADT
29− ( GTableADT, GColumnsADT, gtoResultADT, gfromResultADT
28+ ( GSerializeADT, GColumnsADT, gtoResultADT, gfromResultADT
30 )
29 )
31−import Rel8.Generic.Table.Record ( GTable, GColumns, gtoResult, gfromResult )
30+import Rel8.Generic.Table.Record ( GSerialize, GColumns, gtoResult, gfromResult )
32import Rel8.Kind.Algebra
31import Rel8.Kind.Algebra
33 ( Algebra( Product, Sum )
32 ( Algebra( Product, Sum )
34 , SAlgebra( SProduct, SSum )
33 , SAlgebra( SProduct, SSum )
@@ -38,21 +37,21 @@ import qualified Rel8.Schema.Kind as K
38import Rel8.Schema.Result ( Result )
37import Rel8.Schema.Result ( Result )
39
38
40
39
41−data GGTable
40+data GGSerialize
42 :: Algebra
41 :: Algebra
43− -> (Type -> Exp Constraint)
42+ -> (Type -> Type -> Exp Constraint)
44 -> (Type -> Exp K.HTable)
43 -> (Type -> Exp K.HTable)
45− -> (Type -> Exp Type)
44+ -> (Type -> Type)
46 -> (Type -> Type)
45 -> (Type -> Type)
47 -> Exp Constraint
46 -> Exp Constraint
48
47
49
48
50−type instance Eval (GGTable 'Product _Table _Columns _FromExprs rep) =
49+type instance Eval (GGSerialize 'Product _Serialize _Columns exprs rep) =
51− GTable _Table _Columns _FromExprs rep
50+ GSerialize _Serialize _Columns exprs rep
52
51
53
52
54−type instance Eval (GGTable 'Sum _Table _Columns _FromExprs rep) =
53+type instance Eval (GGSerialize 'Sum _Serialize _Columns exprs rep) =
55− GTableADT _Table _Columns _FromExprs rep
54+ GSerializeADT _Serialize _Columns exprs rep
56
55
57
56
58data GGColumns
57data GGColumns
@@ -78,27 +77,27 @@ type family GAlgebra rep where
78 GAlgebra (K1 _ _) = 'Product
77 GAlgebra (K1 _ _) = 'Product
79
78
80
79
81−ggfromResult :: forall algebra _Table _Columns _FromExprs rep x.
80+ggfromResult :: forall algebra _Serialize _Columns exprs rep x.
82 ( KnownAlgebra algebra
81 ( KnownAlgebra algebra
83− , Eval (GGTable algebra _Table _Columns _FromExprs rep)
82+ , Eval (GGSerialize algebra _Serialize _Columns exprs rep)
84 )
83 )
85− => (forall a proxy. Eval (_Table a)
84+ => (forall expr a proxy. Eval (_Serialize expr a)
86− => proxy a -> Eval (_Columns a) Result -> Eval (_FromExprs a))
85+ => proxy expr -> Eval (_Columns expr) Result -> a)
87− -> Eval (GGColumns algebra _Columns rep) Result
86+ -> Eval (GGColumns algebra _Columns exprs) Result
88− -> GMap _FromExprs rep x
87+ -> rep x
89ggfromResult f x = case algebraSing @algebra of
88ggfromResult f x = case algebraSing @algebra of
90− SProduct -> gfromResult @_Table @_Columns @_FromExprs @rep f x
89+ SProduct -> gfromResult @_Serialize @_Columns @exprs @rep f x
91− SSum -> gfromResultADT @_Table @_Columns @_FromExprs @rep f x
90+ SSum -> gfromResultADT @_Serialize @_Columns @exprs @rep f x
92
91
93
92
94−ggtoResult :: forall algebra _Table _Columns _FromExprs rep x.
93+ggtoResult :: forall algebra _Serialize _Columns exprs rep x.
95 ( KnownAlgebra algebra
94 ( KnownAlgebra algebra
96− , Eval (GGTable algebra _Table _Columns _FromExprs rep)
95+ , Eval (GGSerialize algebra _Serialize _Columns exprs rep)
97 )
96 )
98− => (forall a proxy. Eval (_Table a)
97+ => (forall expr a proxy. Eval (_Serialize expr a)
99− => proxy a -> Eval (_FromExprs a) -> Eval (_Columns a) Result)
98+ => proxy expr -> a -> Eval (_Columns expr) Result)
100− -> GMap _FromExprs rep x
99+ -> rep x
101− -> Eval (GGColumns algebra _Columns rep) Result
100+ -> Eval (GGColumns algebra _Columns exprs) Result
102ggtoResult f x = case algebraSing @algebra of
101ggtoResult f x = case algebraSing @algebra of
103− SProduct -> gtoResult @_Table @_Columns @_FromExprs @rep f x
102+ SProduct -> gtoResult @_Serialize @_Columns @exprs @rep f x
104− SSum -> gtoResultADT @_Table @_Columns @_FromExprs @rep f x
103+ SSum -> gtoResultADT @_Serialize @_Columns @exprs @rep f x
src/Rel8/Generic/Table/ADT.hs+56−59
@@ -12,8 +12,8 @@
12{-# language UndecidableInstances #-}
12{-# language UndecidableInstances #-}
13
13
14module Rel8.Generic.Table.ADT
14module Rel8.Generic.Table.ADT
15− ( GTableADT, GColumnsADT, gfromResultADT, gtoResultADT
15+ ( GSerializeADT, GColumnsADT, gfromResultADT, gtoResultADT
16− , GTableADT', GColumnsADT'
16+ , GSerializeADT', GColumnsADT'
17 )
17 )
18where
18where
19
19
@@ -31,8 +31,7 @@ import Prelude hiding ( null )
31
31
32-- rel8
32-- rel8
33import Rel8.FCF ( Eval, Exp )
33import Rel8.FCF ( Eval, Exp )
34−import Rel8.Generic.Map ( GMap )
35−import Rel8.Generic.Table.Record ( GTable, GColumns, gfromResult, gtoResult )
34+import Rel8.Generic.Table.Record ( GSerialize, GColumns, gfromResult, gtoResult )
36import Rel8.Schema.HTable ( HTable )
35import Rel8.Schema.HTable ( HTable )
37import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
36import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
38import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
37import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
@@ -65,120 +64,118 @@ type family GColumnsADT' _Columns htable rep where
65 HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))
64 HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))
66
65
67
66
68−type GTableADT
67+type GSerializeADT
69− :: (Type -> Exp Constraint)
68+ :: (Type -> Type -> Exp Constraint)
70 -> (Type -> Exp K.HTable)
69 -> (Type -> Exp K.HTable)
71− -> (Type -> Exp Type)
72− -> (Type -> Type) -> Constraint
70+ -> (Type -> Type) -> (Type -> Type) -> Constraint
73−class GTableADT _Table _Columns _FromExprs rep where
71+class GSerializeADT _Serialize _Columns exprs rep where
74 gfromResultADT :: ()
72 gfromResultADT :: ()
75− => (forall a proxy. Eval (_Table a)
73+ => (forall expr a proxy. Eval (_Serialize expr a)
76− => proxy a -> Eval (_Columns a) Result -> Eval (_FromExprs a))
74+ => proxy expr -> Eval (_Columns expr) Result -> a)
77− -> GColumnsADT _Columns rep Result
75+ -> GColumnsADT _Columns exprs Result
78− -> GMap _FromExprs rep x
76+ -> rep x
79
77
80 gtoResultADT :: ()
78 gtoResultADT :: ()
81− => (forall a proxy. Eval (_Table a)
79+ => (forall expr a proxy. Eval (_Serialize expr a)
82− => proxy a -> Eval (_FromExprs a) -> Eval (_Columns a) Result)
80+ => proxy expr -> a -> Eval (_Columns expr) Result)
83− -> GMap _FromExprs rep x
81+ -> rep x
84− -> GColumnsADT _Columns rep Result
82+ -> GColumnsADT _Columns exprs Result
85
83
86
84
87instance
85instance
88 ( htable ~ HLabel "tag" (HIdentity Tag)
86 ( htable ~ HLabel "tag" (HIdentity Tag)
89− , GTableADT' _Table _Columns _FromExprs htable rep
87+ , GSerializeADT' _Serialize _Columns htable exprs rep
90 )
88 )
91− => GTableADT _Table _Columns _FromExprs (M1 D meta rep)
89+ => GSerializeADT _Serialize _Columns (M1 D meta exprs) (M1 D meta rep)
92 where
90 where
93 gfromResultADT fromResult columns =
91 gfromResultADT fromResult columns =
94− case gfromResultADT' @_Table @_Columns @_FromExprs @htable @rep fromResult tag columns of
92+ case gfromResultADT' @_Serialize @_Columns @htable @exprs @rep fromResult tag columns of
95 Just rep -> M1 rep
93 Just rep -> M1 rep
96 _ -> error "ADT.fromColumns: mismatch between tag and data"
94 _ -> error "ADT.fromColumns: mismatch between tag and data"
97 where
95 where
98 tag = (\(HIdentity (Identity a)) -> a) . hunlabel @"tag"
96 tag = (\(HIdentity (Identity a)) -> a) . hunlabel @"tag"
99
97
100 gtoResultADT toResult (M1 rep) =
98 gtoResultADT toResult (M1 rep) =
101− gtoResultADT' @_Table @_Columns @_FromExprs @htable @rep toResult tag (Just rep)
99+ gtoResultADT' @_Serialize @_Columns @htable @exprs @rep toResult tag (Just rep)
102 where
100 where
103 tag = hlabel @"tag" . HIdentity . Identity
101 tag = hlabel @"tag" . HIdentity . Identity
104
102
105
103
106−type GTableADT'
104+type GSerializeADT'
107− :: (Type -> Exp Constraint)
105+ :: (Type -> Type -> Exp Constraint)
108 -> (Type -> Exp K.HTable)
106 -> (Type -> Exp K.HTable)
109− -> (Type -> Exp Type)
110− -> K.HTable -> (Type -> Type) -> Constraint
107+ -> K.HTable -> (Type -> Type) -> (Type -> Type) -> Constraint
111−class GTableADT' _Table _Columns _FromExprs htable rep where
108+class GSerializeADT' _Serialize _Columns htable exprs rep where
112 gfromResultADT' :: context ~ Result
109 gfromResultADT' :: context ~ Result
113− => (forall a proxy. Eval (_Table a)
110+ => (forall expr a proxy. Eval (_Serialize expr a)
114− => proxy a -> Eval (_Columns a) context -> Eval (_FromExprs a))
111+ => proxy expr -> Eval (_Columns expr) context -> a)
115 -> (htable Result -> Tag)
112 -> (htable Result -> Tag)
116− -> GColumnsADT' _Columns htable rep context
113+ -> GColumnsADT' _Columns htable exprs context
117− -> Maybe (GMap _FromExprs rep x)
114+ -> Maybe (rep x)
118
115
119 gtoResultADT' :: context ~ Result
116 gtoResultADT' :: context ~ Result
120− => (forall a proxy. Eval (_Table a)
117+ => (forall expr a proxy. Eval (_Serialize expr a)
121− => proxy a -> Eval (_FromExprs a) -> Eval (_Columns a) context)
118+ => proxy expr -> a -> Eval (_Columns expr) context)
122 -> (Tag -> htable Result)
119 -> (Tag -> htable Result)
123− -> Maybe (GMap _FromExprs rep x)
120+ -> Maybe (rep x)
124− -> GColumnsADT' _Columns htable rep context
121+ -> GColumnsADT' _Columns htable exprs context
125
122
126− extract :: GColumnsADT' _Columns htable rep context -> htable context
123+ extract :: GColumnsADT' _Columns htable exprs context -> htable context
127
124
128
125
129instance
126instance
130− ( htable' ~ GColumnsADT' _Columns htable a
127+ ( htable' ~ GColumnsADT' _Columns htable exprs1
131− , GTableADT' _Table _Columns _FromExprs htable a
128+ , GSerializeADT' _Serialize _Columns htable exprs1 a
132− , GTableADT' _Table _Columns _FromExprs htable' b
129+ , GSerializeADT' _Serialize _Columns htable' exprs2 b
133 )
130 )
134− => GTableADT' _Table _Columns _FromExprs htable (a :+: b)
131+ => GSerializeADT' _Serialize _Columns htable (exprs1 :+: exprs2) (a :+: b)
135 where
132 where
136 gfromResultADT' fromResult f columns =
133 gfromResultADT' fromResult f columns =
137 case ma of
134 case ma of
138 Just a -> Just (L1 a)
135 Just a -> Just (L1 a)
139 Nothing -> R1 <$>
136 Nothing -> R1 <$>
140− gfromResultADT' @_Table @_Columns @_FromExprs @_ @b
137+ gfromResultADT' @_Serialize @_Columns @_ @exprs2 @b
141 fromResult
138 fromResult
142− (f . extract @_Table @_Columns @_FromExprs @_ @a)
139+ (f . extract @_Serialize @_Columns @_ @exprs1 @a)
143 columns
140 columns
144 where
141 where
145 ma =
142 ma =
146− gfromResultADT' @_Table @_Columns @_FromExprs @_ @a
143+ gfromResultADT' @_Serialize @_Columns @_ @exprs1 @a
147 fromResult
144 fromResult
148 f
145 f
149− (extract @_Table @_Columns @_FromExprs @_ @b columns)
146+ (extract @_Serialize @_Columns @_ @exprs2 @b columns)
150
147
151 gtoResultADT' toResult tag = \case
148 gtoResultADT' toResult tag = \case
152 Just (L1 a) ->
149 Just (L1 a) ->
153− gtoResultADT' @_Table @_Columns @_FromExprs @_ @b
150+ gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b
154 toResult
151 toResult
155− (\_ -> gtoResultADT' @_Table @_Columns @_FromExprs @_ @a
152+ (\_ -> gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a
156 toResult
153 toResult
157 tag
154 tag
158 (Just a))
155 (Just a))
159 Nothing
156 Nothing
160 Just (R1 b) ->
157 Just (R1 b) ->
161− gtoResultADT' @_Table @_Columns @_FromExprs @_ @b
158+ gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b
162 toResult
159 toResult
163 (\tag' ->
160 (\tag' ->
164− gtoResultADT' @_Table @_Columns @_FromExprs @_ @a
161+ gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a
165 toResult
162 toResult
166 (\_ -> tag tag')
163 (\_ -> tag tag')
167 Nothing)
164 Nothing)
168 (Just b)
165 (Just b)
169 Nothing ->
166 Nothing ->
170− gtoResultADT' @_Table @_Columns @_FromExprs @_ @b
167+ gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b
171 toResult
168 toResult
172− (\_ -> gtoResultADT' @_Table @_Columns @_FromExprs @_ @a toResult tag Nothing)
169+ (\_ -> gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a toResult tag Nothing)
173 Nothing
170 Nothing
174
171
175 extract =
172 extract =
176− extract @_Table @_Columns @_FromExprs @_ @a .
173+ extract @_Serialize @_Columns @_ @exprs1 @a .
177− extract @_Table @_Columns @_FromExprs @_ @b
174+ extract @_Serialize @_Columns @_ @exprs2 @b
178
175
179
176
180instance (meta ~ 'MetaCons label _fixity _isRecord, KnownSymbol label) =>
177instance (meta ~ 'MetaCons label _fixity _isRecord, KnownSymbol label) =>
181− GTableADT' _Table _Columns _FromExprs htable (M1 C meta U1)
178+ GSerializeADT' _Serialize _Columns _htable (M1 C meta U1) (M1 C meta U1)
182 where
179 where
183 gfromResultADT' _ tag columns
180 gfromResultADT' _ tag columns
184 | tag columns == tag' = Just (M1 U1)
181 | tag columns == tag' = Just (M1 U1)
@@ -194,18 +191,18 @@ instance (meta ~ 'MetaCons label _fixity _isRecord, KnownSymbol label) =>
194
191
195
192
196instance {-# OVERLAPPABLE #-}
193instance {-# OVERLAPPABLE #-}
197− ( HTable (GColumns _Columns rep)
194+ ( HTable (GColumns _Columns exprs)
198− , GTable _Table _Columns _FromExprs rep
195+ , GSerialize _Serialize _Columns exprs rep
199 , meta ~ 'MetaCons label _fixity _isRecord
196 , meta ~ 'MetaCons label _fixity _isRecord
200 , KnownSymbol label
197 , KnownSymbol label
201− , GColumnsADT' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) rep) ~
198+ , GColumnsADT' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) exprs) ~
202− HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))
199+ HProduct htable (HLabel label (HNullify (GColumns _Columns exprs)))
203 )
200 )
204− => GTableADT' _Table _Columns _FromExprs htable (M1 C meta rep)
201+ => GSerializeADT' _Serialize _Columns htable (M1 C meta exprs) (M1 C meta rep)
205 where
202 where
206 gfromResultADT' fromResult tag (HProduct a b)
203 gfromResultADT' fromResult tag (HProduct a b)
207 | tag a == tag' =
204 | tag a == tag' =
208− M1 . gfromResult @_Table @_Columns @_FromExprs @rep fromResult <$>
205+ M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult <$>
209 hunnullify unnullifier (hunlabel b)
206 hunnullify unnullifier (hunlabel b)
210 | otherwise = Nothing
207 | otherwise = Nothing
211 where
208 where
@@ -216,7 +213,7 @@ instance {-# OVERLAPPABLE #-}
216 Just (M1 rep) -> HProduct (tag tag') $
213 Just (M1 rep) -> HProduct (tag tag') $
217 hlabel $
214 hlabel $
218 hnullify nullifier $
215 hnullify nullifier $
219− gtoResult @_Table @_Columns @_FromExprs @rep toResult rep
216+ gtoResult @_Serialize @_Columns @exprs @rep toResult rep
220 where
217 where
221 tag' = Tag $ pack $ symbolVal (Proxy @label)
218 tag' = Tag $ pack $ symbolVal (Proxy @label)
222
219
src/Rel8/Generic/Table/Record.hs+78−50
@@ -13,8 +13,8 @@
13{-# language UndecidableInstances #-}
13{-# language UndecidableInstances #-}
14
14
15module Rel8.Generic.Table.Record
15module Rel8.Generic.Table.Record
16− ( GTable, GColumns, GContext
16+ ( GTable, GColumns, GContext, gfromColumns, gtoColumns, gtable
17− , gfromColumns, gtoColumns, gfromResult, gtoResult, gtable
17+ , GSerialize, gfromResult, gtoResult
18 )
18 )
19where
19where
20
20
@@ -30,7 +30,6 @@ import Prelude hiding ( null )
30
30
31-- rel8
31-- rel8
32import Rel8.FCF ( Eval, Exp )
32import Rel8.FCF ( Eval, Exp )
33−import Rel8.Generic.Map ( GMap )
34import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
33import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
35import Rel8.Schema.HTable.Product ( HProduct(..) )
34import Rel8.Schema.HTable.Product ( HProduct(..) )
36import qualified Rel8.Schema.Kind as K
35import qualified Rel8.Schema.Kind as K
@@ -56,9 +55,8 @@ type family GContext _Context rep where
56type GTable
55type GTable
57 :: (Type -> Exp Constraint)
56 :: (Type -> Exp Constraint)
58 -> (Type -> Exp K.HTable)
57 -> (Type -> Exp K.HTable)
59− -> (Type -> Exp Type)
60 -> (Type -> Type) -> Constraint
58 -> (Type -> Type) -> Constraint
61−class GTable _Table _Columns _FromExprs rep
59+class GTable _Table _Columns rep
62 where
60 where
63 gfromColumns :: ()
61 gfromColumns :: ()
64 => (forall a. Eval (_Table a) => Eval (_Columns a) context -> a)
62 => (forall a. Eval (_Table a) => Eval (_Columns a) context -> a)
@@ -70,73 +68,93 @@ class GTable _Table _Columns _FromExprs rep
70 -> rep x
68 -> rep x
71 -> GColumns _Columns rep context
69 -> GColumns _Columns rep context
72
70
73− gfromResult :: ()
74− => (forall a proxy. Eval (_Table a)
75− => proxy a -> Eval (_Columns a) context -> Eval (_FromExprs a))
76− -> GColumns _Columns rep context
77− -> GMap _FromExprs rep x
78−
79− gtoResult :: ()
80− => (forall a proxy. Eval (_Table a)
81− => proxy a -> Eval (_FromExprs a) -> Eval (_Columns a) context)
82− -> GMap _FromExprs rep x
83− -> GColumns _Columns rep context
84−
85 gtable :: ()
71 gtable :: ()
86 => (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context)
72 => (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context)
87 -> GColumns _Columns rep context
73 -> GColumns _Columns rep context
88
74
89
75
76+type GSerialize
77+ :: (Type -> Type -> Exp Constraint)
78+ -> (Type -> Exp K.HTable)
79+ -> (Type -> Type) -> (Type -> Type) -> Constraint
80+class GSerialize _Serialize _Columns exprs rep
81+ where
82+ gfromResult :: ()
83+ => (forall expr a proxy. Eval (_Serialize expr a)
84+ => proxy expr -> Eval (_Columns expr) context -> a)
85+ -> GColumns _Columns exprs context
86+ -> rep x
87+
88+ gtoResult :: ()
89+ => (forall expr a proxy. Eval (_Serialize expr a)
90+ => proxy expr -> a -> Eval (_Columns expr) context)
91+ -> rep x
92+ -> GColumns _Columns exprs context
93+
94+
90−instance GTable _Table _Columns _FromExprs rep =>
95+instance GTable _Table _Columns rep => GTable _Table _Columns (M1 D c rep)
91− GTable _Table _Columns _FromExprs (M1 D c rep)
92 where
96 where
93 gfromColumns fromColumns =
97 gfromColumns fromColumns =
94− M1 . gfromColumns @_Table @_Columns @_FromExprs @rep fromColumns
98+ M1 . gfromColumns @_Table @_Columns @rep fromColumns
95 gtoColumns toColumns (M1 a) =
99 gtoColumns toColumns (M1 a) =
96− gtoColumns @_Table @_Columns @_FromExprs @rep toColumns a
100+ gtoColumns @_Table @_Columns @rep toColumns a
101+ gtable = gtable @_Table @_Columns @rep
102+
103+
104+instance GSerialize _Serialize _Columns exprs rep =>
105+ GSerialize _Serialize _Columns (M1 D c exprs) (M1 D c rep)
106+ where
97 gfromResult fromResult =
107 gfromResult fromResult =
98− M1 . gfromResult @_Table @_Columns @_FromExprs @rep fromResult
108+ M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult
99 gtoResult toResult (M1 a) =
109 gtoResult toResult (M1 a) =
100− gtoResult @_Table @_Columns @_FromExprs @rep toResult a
110+ gtoResult @_Serialize @_Columns @exprs @rep toResult a
101− gtable = gtable @_Table @_Columns @_FromExprs @rep
102
111
103
112
104−instance GTable _Table _Columns _FromExprs rep =>
113+instance GTable _Table _Columns rep => GTable _Table _Columns (M1 C c rep)
105− GTable _Table _Columns _FromExprs (M1 C c rep)
106 where
114 where
107 gfromColumns fromColumns =
115 gfromColumns fromColumns =
108− M1 . gfromColumns @_Table @_Columns @_FromExprs @rep fromColumns
116+ M1 . gfromColumns @_Table @_Columns @rep fromColumns
109 gtoColumns toColumns (M1 a) =
117 gtoColumns toColumns (M1 a) =
110− gtoColumns @_Table @_Columns @_FromExprs @rep toColumns a
118+ gtoColumns @_Table @_Columns @rep toColumns a
119+ gtable = gtable @_Table @_Columns @rep
120+
121+
122+instance GSerialize _Serialize _Columns exprs rep =>
123+ GSerialize _Serialize _Columns (M1 C c exprs) (M1 C c rep)
124+ where
111 gfromResult fromResult =
125 gfromResult fromResult =
112− M1 . gfromResult @_Table @_Columns @_FromExprs @rep fromResult
126+ M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult
113 gtoResult toResult (M1 a) =
127 gtoResult toResult (M1 a) =
114− gtoResult @_Table @_Columns @_FromExprs @rep toResult a
128+ gtoResult @_Serialize @_Columns @exprs @rep toResult a
115− gtable = gtable @_Table @_Columns @_FromExprs @rep
116
129
117
130
118−instance
119− ( GTable _Table _Columns _FromExprs rep1
131+instance (GTable _Table _Columns rep1, GTable _Table _Columns rep2) =>
120− , GTable _Table _Columns _FromExprs rep2
121− )
122− => GTable _Table _Columns _FromExprs (rep1 :*: rep2)
132+ GTable _Table _Columns (rep1 :*: rep2)
123 where
133 where
124 gfromColumns fromColumns (HProduct a b) =
134 gfromColumns fromColumns (HProduct a b) =
125− gfromColumns @_Table @_Columns @_FromExprs @rep1 fromColumns a :*:
135+ gfromColumns @_Table @_Columns @rep1 fromColumns a :*:
126− gfromColumns @_Table @_Columns @_FromExprs @rep2 fromColumns b
136+ gfromColumns @_Table @_Columns @rep2 fromColumns b
127 gtoColumns toColumns (a :*: b) = HProduct
137 gtoColumns toColumns (a :*: b) = HProduct
128− (gtoColumns @_Table @_Columns @_FromExprs @rep1 toColumns a)
138+ (gtoColumns @_Table @_Columns @rep1 toColumns a)
129− (gtoColumns @_Table @_Columns @_FromExprs @rep2 toColumns b)
139+ (gtoColumns @_Table @_Columns @rep2 toColumns b)
140+ gtable table = HProduct
141+ (gtable @_Table @_Columns @rep1 table)
142+ (gtable @_Table @_Columns @rep2 table)
143+
144+
145+instance
146+ ( GSerialize _Serialize _Columns expr1 rep1
147+ , GSerialize _Serialize _Columns expr2 rep2
148+ )
149+ => GSerialize _Serialize _Columns (expr1 :*: expr2) (rep1 :*: rep2)
150+ where
130 gfromResult fromResult (HProduct a b) =
151 gfromResult fromResult (HProduct a b) =
131− gfromResult @_Table @_Columns @_FromExprs @rep1 fromResult a :*:
152+ gfromResult @_Serialize @_Columns @expr1 @rep1 fromResult a :*:
132− gfromResult @_Table @_Columns @_FromExprs @rep2 fromResult b
153+ gfromResult @_Serialize @_Columns @expr2 @rep2 fromResult b
133 gtoResult toResult (a :*: b) =
154 gtoResult toResult (a :*: b) =
134 HProduct
155 HProduct
135− (gtoResult @_Table @_Columns @_FromExprs @rep1 toResult a)
156+ (gtoResult @_Serialize @_Columns @expr1 @rep1 toResult a)
136− (gtoResult @_Table @_Columns @_FromExprs @rep2 toResult b)
157+ (gtoResult @_Serialize @_Columns @expr2 @rep2 toResult b)
137− gtable table = HProduct
138− (gtable @_Table @_Columns @_FromExprs @rep1 table)
139− (gtable @_Table @_Columns @_FromExprs @rep2 table)
140
158
141
159
142instance
160instance
@@ -144,10 +162,20 @@ instance
144 , meta ~ 'MetaSel ('Just label) _su _ss _ds
162 , meta ~ 'MetaSel ('Just label) _su _ss _ds
145 , k1 ~ K1 i a
163 , k1 ~ K1 i a
146 )
164 )
147− => GTable _Table _Columns _FromExprs (M1 S meta k1)
165+ => GTable _Table _Columns (M1 S meta k1)
148 where
166 where
149 gfromColumns fromColumns = M1 . K1 . fromColumns . hunlabel
167 gfromColumns fromColumns = M1 . K1 . fromColumns . hunlabel
150 gtoColumns toColumns (M1 (K1 a)) = hlabel (toColumns a)
168 gtoColumns toColumns (M1 (K1 a)) = hlabel (toColumns a)
151− gfromResult fromResult = M1 . K1 . fromResult (Proxy @a) . hunlabel
152− gtoResult toResult (M1 (K1 a)) = hlabel (toResult (Proxy @a) a)
153 gtable table = hlabel (table (Proxy @a))
169 gtable table = hlabel (table (Proxy @a))
170+
171+
172+instance
173+ ( Eval (_Serialize expr a)
174+ , meta ~ 'MetaSel ('Just label) _su _ss _ds
175+ , k1 ~ K1 i expr
176+ , k1' ~ K1 i a
177+ )
178+ => GSerialize _Serialize _Columns (M1 S meta k1) (M1 S meta k1')
179+ where
180+ gfromResult fromResult = M1 . K1 . fromResult (Proxy @expr) . hunlabel
181+ gtoResult toResult (M1 (K1 a)) = hlabel (toResult (Proxy @expr) a)
src/Rel8/Schema/Context/Virtual.hsdeleted−70
@@ -1,70 +0,0 @@
1−{-# language EmptyCase #-}
2−{-# language DataKinds #-}
3−{-# language GADTs #-}
4−{-# language LambdaCase #-}
5−{-# language StandaloneKindSignatures #-}
6−{-# language TypeFamilies #-}
7−
8−module Rel8.Schema.Context.Virtual
9− ( Virtual, virtual
10− , Abstract(..), Concrete(..), abstractOrConcrete, absurd
11− )
12−where
13−
14−-- base
15−import Data.Kind ( Constraint, Type )
16−import Prelude
17−
18−-- rel8
19−import Rel8.Aggregate ( Aggregate )
20−import Rel8.Expr ( Expr )
21−import Rel8.Kind.Context ( SContext(..) )
22−import qualified Rel8.Schema.Kind as K
23−import Rel8.Schema.Name ( Name )
24−import Rel8.Schema.Result ( Result )
25−
26−
27−type Virtual :: K.Context -> Constraint
28−class Virtual context where
29− virtual :: Abstract context
30−
31−
32−instance Virtual Aggregate where
33− virtual = VAggregate
34−
35−
36−instance Virtual Expr where
37− virtual = VExpr
38−
39−
40−instance Virtual Name where
41− virtual = VName
42−
43−
44−type Abstract :: K.Context -> Type
45−data Abstract context where
46− VAggregate :: Abstract Aggregate
47− VExpr :: Abstract Expr
48− VName :: Abstract Name
49−
50−
51−type Concrete :: K.Context -> Type
52−data Concrete context where
53− VResult :: Concrete Result
54−
55−
56−abstractOrConcrete :: ()
57− => SContext context
58− -> Either (Concrete context) (Abstract context)
59−abstractOrConcrete = \case
60− SAggregate -> Right VAggregate
61− SExpr -> Right VExpr
62− SName -> Right VName
63− SResult -> Left VResult
64−
65−
66−absurd :: Abstract context -> Concrete context -> a
67−absurd = \case
68− VAggregate -> \case
69− VExpr -> \case
70− VName -> \case
src/Rel8/Table.hs+38−24
@@ -17,26 +17,31 @@ module Rel8.Table
17 , Transpose
17 , Transpose
18 )
18 )
19 , Congruent
19 , Congruent
20− , TTable, TColumns, TContext, TFromExprs
20+ , TTable, TColumns, TContext, TFromExprs, TTranspose
21+ , TSerialize
21 )
22 )
22where
23where
23
24
24-- base
25-- base
26+import Data.Functor.Identity ( Identity( Identity ) )
25import Data.Kind ( Constraint, Type )
27import Data.Kind ( Constraint, Type )
26import GHC.Generics ( Generic, Rep, from, to )
28import GHC.Generics ( Generic, Rep, from, to )
27import Prelude hiding ( null )
29import Prelude hiding ( null )
28
30
29-- rel8
31-- rel8
30import Rel8.FCF ( Eval, Exp )
32import Rel8.FCF ( Eval, Exp )
31−import Rel8.Generic.Map ( GMap, Map )
33+import Rel8.Generic.Map ( Map )
32import Rel8.Generic.Table.Record
34import Rel8.Generic.Table.Record
33− ( GTable, GColumns, GContext
35+ ( GTable, GColumns, GContext, gfromColumns, gtoColumns
34− , gfromColumns, gtoColumns, gfromResult, gtoResult
36+ , GSerialize, gfromResult, gtoResult
35 )
37 )
36import Rel8.Generic.Record ( Record(..) )
38import Rel8.Generic.Record ( Record(..) )
37import Rel8.Schema.HTable ( HTable )
39import Rel8.Schema.HTable ( HTable )
40+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
38import qualified Rel8.Schema.Kind as K
41import qualified Rel8.Schema.Kind as K
42+import Rel8.Schema.Null ( Sql )
39import Rel8.Schema.Result ( Result )
43import Rel8.Schema.Result ( Result )
44+import Rel8.Type ( DBType )
40
45
41
46
42-- | @Table@s are one of the foundational elements of Rel8, and describe data
47-- | @Table@s are one of the foundational elements of Rel8, and describe data
@@ -84,69 +89,71 @@ class
84
89
85 default toColumns ::
90 default toColumns ::
86 ( Generic (Record a)
91 ( Generic (Record a)
87− , GTable (TTable context) TColumns TFromExprs (Rep (Record a))
92+ , GTable (TTable context) TColumns (Rep (Record a))
88 , Columns a ~ GColumns TColumns (Rep (Record a))
93 , Columns a ~ GColumns TColumns (Rep (Record a))
89 )
94 )
90 => a -> Columns a context
95 => a -> Columns a context
91 toColumns =
96 toColumns =
92− gtoColumns
93− @(TTable context)
97+ gtoColumns @(TTable context) @TColumns toColumns .
94− @TColumns
95− @TFromExprs
96− toColumns .
97 from .
98 from .
98 Record
99 Record
99
100
100 default fromColumns ::
101 default fromColumns ::
101 ( Generic (Record a)
102 ( Generic (Record a)
102− , GTable (TTable context) TColumns TFromExprs (Rep (Record a))
103+ , GTable (TTable context) TColumns (Rep (Record a))
103 , Columns a ~ GColumns TColumns (Rep (Record a))
104 , Columns a ~ GColumns TColumns (Rep (Record a))
104 )
105 )
105 => Columns a context -> a
106 => Columns a context -> a
106 fromColumns =
107 fromColumns =
107 unrecord .
108 unrecord .
108 to .
109 to .
109− gfromColumns
110− @(TTable context)
110+ gfromColumns @(TTable context) @TColumns fromColumns
111− @TColumns
112− @TFromExprs
113− fromColumns
114
111
115 default toResult ::
112 default toResult ::
116 ( Generic (Record (FromExprs a))
113 ( Generic (Record (FromExprs a))
117− , GTable (TTable context) TColumns TFromExprs (Rep (Record a))
114+ , GSerialize TSerialize TColumns (Rep (Record a)) (Rep (Record (FromExprs a)))
118 , Columns a ~ GColumns TColumns (Rep (Record a))
115 , Columns a ~ GColumns TColumns (Rep (Record a))
119− , Rep (Record (FromExprs a)) ~ GMap TFromExprs (Rep (Record a))
120 )
116 )
121 => FromExprs a -> Columns a Result
117 => FromExprs a -> Columns a Result
122 toResult =
118 toResult =
123 gtoResult
119 gtoResult
124− @(TTable context)
120+ @TSerialize
125 @TColumns
121 @TColumns
126− @TFromExprs
127 @(Rep (Record a))
122 @(Rep (Record a))
123+ @(Rep (Record (FromExprs a)))
128 (\(_ :: proxy x) -> toResult @(Context x) @x) .
124 (\(_ :: proxy x) -> toResult @(Context x) @x) .
129 from .
125 from .
130 Record
126 Record
131
127
132 default fromResult ::
128 default fromResult ::
133 ( Generic (Record (FromExprs a))
129 ( Generic (Record (FromExprs a))
134− , GTable (TTable context) TColumns TFromExprs (Rep (Record a))
130+ , GSerialize TSerialize TColumns (Rep (Record a)) (Rep (Record (FromExprs a)))
135 , Columns a ~ GColumns TColumns (Rep (Record a))
131 , Columns a ~ GColumns TColumns (Rep (Record a))
136− , Rep (Record (FromExprs a)) ~ GMap TFromExprs (Rep (Record a))
137 )
132 )
138 => Columns a Result -> FromExprs a
133 => Columns a Result -> FromExprs a
139 fromResult =
134 fromResult =
140 unrecord .
135 unrecord .
141 to .
136 to .
142 gfromResult
137 gfromResult
143− @(TTable context)
138+ @TSerialize
144 @TColumns
139 @TColumns
145− @TFromExprs
146 @(Rep (Record a))
140 @(Rep (Record a))
141+ @(Rep (Record (FromExprs a)))
147 (\(_ :: proxy x) -> fromResult @(Context x) @x)
142 (\(_ :: proxy x) -> fromResult @(Context x) @x)
148
143
149
144
145+instance Sql DBType a => Table Result (Identity a) where
146+ type Columns (Identity a) = HIdentity a
147+ type Context (Identity a) = Result
148+ type FromExprs (Identity a) = a
149+ type Transpose to (Identity a) = to a
150+
151+ toColumns = HIdentity
152+ fromColumns (HIdentity a) = a
153+ toResult a = HIdentity (Identity a)
154+ fromResult (HIdentity (Identity a)) = a
155+
156+
150data TTable :: K.Context -> Type -> Exp Constraint
157data TTable :: K.Context -> Type -> Exp Constraint
151type instance Eval (TTable context a) = Table context a
158type instance Eval (TTable context a) = Table context a
152
159
@@ -167,6 +174,13 @@ data TTranspose :: K.Context -> Type -> Exp Type
167type instance Eval (TTranspose context a) = Transpose context a
174type instance Eval (TTranspose context a) = Transpose context a
168
175
169
176
177+data TSerialize :: Type -> Type -> Exp Constraint
178+type instance Eval (TSerialize expr a) =
179+ ( Table (Context expr) expr
180+ , a ~ FromExprs expr
181+ )
182+
183+
170instance (Table context a, Table context b) => Table context (a, b)
184instance (Table context a, Table context b) => Table context (a, b)
171
185
172
186
src/Rel8/Table/ADT.hs+13−25
@@ -7,7 +7,6 @@
7{-# language ScopedTypeVariables #-}
7{-# language ScopedTypeVariables #-}
8{-# language StandaloneKindSignatures #-}
8{-# language StandaloneKindSignatures #-}
9{-# language TypeApplications #-}
9{-# language TypeApplications #-}
10−{-# language TypeFamilies #-}
11{-# language TypeFamilyDependencies #-}
10{-# language TypeFamilyDependencies #-}
12{-# language UndecidableInstances #-}
11{-# language UndecidableInstances #-}
13{-# language UndecidableSuperClasses #-}
12{-# language UndecidableSuperClasses #-}
@@ -28,7 +27,7 @@ where
28
27
29-- base
28-- base
30import Data.Kind ( Constraint, Type )
29import Data.Kind ( Constraint, Type )
31−import GHC.Generics ( Generic, Rep, from, to )
30+import GHC.Generics ( Generic, from, to )
32import GHC.TypeLits ( Symbol )
31import GHC.TypeLits ( Symbol )
33import Prelude
32import Prelude
34
33
@@ -45,24 +44,20 @@ import Rel8.Generic.Construction
45 , GGName, ggname
44 , GGName, ggname
46 , GGAggregate, ggaggregate
45 , GGAggregate, ggaggregate
47 )
46 )
48−import Rel8.Generic.Map ( GMap )
49import Rel8.Generic.Record ( Record( Record ), unrecord )
47import Rel8.Generic.Record ( Record( Record ), unrecord )
50import Rel8.Generic.Rel8able
48import Rel8.Generic.Rel8able
51 ( Rel8able
49 ( Rel8able
52 , GRep, GColumns, gfromColumns, gtoColumns
50 , GRep, GColumns, gfromColumns, gtoColumns
53 , GFromExprs, gfromResult, gtoResult
51 , GFromExprs, gfromResult, gtoResult
52+ , TSerialize, deserialize, serialize
54 )
53 )
55import qualified Rel8.Generic.Table.ADT as G
54import qualified Rel8.Generic.Table.ADT as G
56import qualified Rel8.Kind.Algebra as K
55import qualified Rel8.Kind.Algebra as K
57−import Rel8.Schema.Context.Virtual
58import Rel8.Schema.HTable ( HTable )
56import Rel8.Schema.HTable ( HTable )
59import qualified Rel8.Schema.Kind as K
57import qualified Rel8.Schema.Kind as K
60import Rel8.Schema.Name ( Name )
58import Rel8.Schema.Name ( Name )
61import Rel8.Schema.Result ( Result )
59import Rel8.Schema.Result ( Result )
62−import Rel8.Table
60+import Rel8.Table ( Table, TColumns )
63− ( Table, fromResult, toResult
64− , TTable, TColumns, TFromExprs
65− )
66
61
67
62
68type ADT :: K.Rel8able -> K.Rel8able
63type ADT :: K.Rel8able -> K.Rel8able
@@ -73,31 +68,26 @@ instance ADTable t => Rel8able (ADT t) where
73 type GColumns (ADT t) = GColumnsADT t
68 type GColumns (ADT t) = GColumnsADT t
74 type GFromExprs (ADT t) = t Result
69 type GFromExprs (ADT t) = t Result
75
70
76− gfromColumns VAggregate = ADT
71+ gfromColumns _ = ADT
77− gfromColumns VExpr = ADT
78− gfromColumns VName = ADT
79−
80− gtoColumns VAggregate (ADT a) = a
81− gtoColumns VExpr (ADT a) = a
82− gtoColumns VName (ADT a) = a
72+ gtoColumns _ (ADT a) = a
83
73
84 gfromResult =
74 gfromResult =
85 unrecord .
75 unrecord .
86 to .
76 to .
87 G.gfromResultADT
77 G.gfromResultADT
88− @(TTable Expr)
78+ @TSerialize
89 @TColumns
79 @TColumns
90− @TFromExprs
91 @(Eval (ADTRep t Expr))
80 @(Eval (ADTRep t Expr))
81+ @(Eval (ADTRep t Result))
92− (\(_ :: proxy x) -> fromResult @_ @x)
82+ (\(_ :: proxy x) -> deserialize @_ @x)
93
83
94 gtoResult =
84 gtoResult =
95 G.gtoResultADT
85 G.gtoResultADT
96− @(TTable Expr)
86+ @TSerialize
97 @TColumns
87 @TColumns
98− @TFromExprs
99 @(Eval (ADTRep t Expr))
88 @(Eval (ADTRep t Expr))
89+ @(Eval (ADTRep t Result))
100− (\(_ :: proxy x) -> toResult @_ @x) .
90+ (\(_ :: proxy x) -> serialize @_ @x) .
101 from .
91 from .
102 Record
92 Record
103
93
@@ -106,15 +96,13 @@ type ADTable :: K.Rel8able -> Constraint
106class
96class
107 ( Generic (Record (t Result))
97 ( Generic (Record (t Result))
108 , HTable (GColumnsADT t)
98 , HTable (GColumnsADT t)
109− , G.GTableADT (TTable Expr) TColumns TFromExprs (Eval (ADTRep t Expr))
99+ , G.GSerializeADT TSerialize TColumns (Eval (ADTRep t Expr)) (Eval (ADTRep t Result))
110− , GMap TFromExprs (Rep (Record (t Expr))) ~ Rep (Record (t Result))
111 )
100 )
112 => ADTable t
101 => ADTable t
113instance
102instance
114 ( Generic (Record (t Result))
103 ( Generic (Record (t Result))
115 , HTable (GColumnsADT t)
104 , HTable (GColumnsADT t)
116− , G.GTableADT (TTable Expr) TColumns TFromExprs (Eval (ADTRep t Expr))
105+ , G.GSerializeADT TSerialize TColumns (Eval (ADTRep t Expr)) (Eval (ADTRep t Result))
117− , GMap TFromExprs (Rep (Record (t Expr))) ~ Rep (Record (t Result))
118 )
106 )
119 => ADTable t
107 => ADTable t
120
108
src/Rel8/Table/Eq.hs+3−9
@@ -37,7 +37,7 @@ import Rel8.Schema.Dict ( Dict( Dict ) )
37import Rel8.Schema.HTable ( htabulateA, hfield )
37import Rel8.Schema.HTable ( htabulateA, hfield )
38import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
38import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
39import Rel8.Schema.Null ( Sql )
39import Rel8.Schema.Null ( Sql )
40−import Rel8.Table ( Table, Columns, toColumns, TColumns, TFromExprs )
40+import Rel8.Table ( Table, Columns, toColumns, TColumns )
41import Rel8.Type.Eq ( DBEq )
41import Rel8.Type.Eq ( DBEq )
42
42
43
43
@@ -49,17 +49,11 @@ class Table Expr a => EqTable a where
49 eqTable :: Columns a (Dict (Sql DBEq))
49 eqTable :: Columns a (Dict (Sql DBEq))
50
50
51 default eqTable ::
51 default eqTable ::
52− ( GTable TEqTable TColumns TFromExprs (Rep (Record a))
52+ ( GTable TEqTable TColumns (Rep (Record a))
53 , Columns a ~ GColumns TColumns (Rep (Record a))
53 , Columns a ~ GColumns TColumns (Rep (Record a))
54 )
54 )
55 => Columns a (Dict (Sql DBEq))
55 => Columns a (Dict (Sql DBEq))
56− eqTable =
56+ eqTable = gtable @TEqTable @TColumns @(Rep (Record a)) table
57− gtable
58− @TEqTable
59− @TColumns
60− @TFromExprs
61− @(Rep (Record a))
62− table
63 where
57 where
64 table (_ :: proxy x) = eqTable @x
58 table (_ :: proxy x) = eqTable @x
65
59
src/Rel8/Table/HKD.hs+13−13
@@ -57,16 +57,18 @@ import Rel8.Generic.Rel8able
57 , GFromExprs, gfromResult, gtoResult
57 , GFromExprs, gfromResult, gtoResult
58 )
58 )
59import Rel8.Generic.Table
59import Rel8.Generic.Table
60− ( GGTable, GGColumns, GAlgebra, ggfromResult, ggtoResult
60+ ( GGSerialize, GGColumns, GAlgebra, ggfromResult, ggtoResult
61 )
61 )
62import Rel8.Generic.Table.Record ( GTable, GContext )
62import Rel8.Generic.Table.Record ( GTable, GContext )
63import qualified Rel8.Generic.Table.Record as G
63import qualified Rel8.Generic.Table.Record as G
64import qualified Rel8.Schema.Kind as K
64import qualified Rel8.Schema.Kind as K
65import Rel8.Schema.HTable ( HTable )
65import Rel8.Schema.HTable ( HTable )
66import Rel8.Schema.Name ( Name )
66import Rel8.Schema.Name ( Name )
67+import Rel8.Schema.Result ( Result )
67import Rel8.Table
68import Rel8.Table
68 ( Table, fromColumns, toColumns, fromResult, toResult
69 ( Table, fromColumns, toColumns, fromResult, toResult
69− , TTable, TColumns, TContext, TFromExprs
70+ , TTable, TColumns, TContext
71+ , TSerialize
70 )
72 )
71
73
72
74
@@ -91,26 +93,26 @@ instance HKDable a => Rel8able (HKD a) where
91 to .
93 to .
92 ggfromResult
94 ggfromResult
93 @(GAlgebra (Rep a))
95 @(GAlgebra (Rep a))
94− @(TTable Expr)
96+ @TSerialize
95 @TColumns
97 @TColumns
96− @TFromExprs
97 @(Eval (HKDRep a Expr))
98 @(Eval (HKDRep a Expr))
99+ @(Eval (HKDRep a Result))
98 (\(_ :: proxy x) -> fromResult @_ @x)
100 (\(_ :: proxy x) -> fromResult @_ @x)
99
101
100 gtoResult =
102 gtoResult =
101 ggtoResult
103 ggtoResult
102 @(GAlgebra (Rep a))
104 @(GAlgebra (Rep a))
103− @(TTable Expr)
105+ @TSerialize
104 @TColumns
106 @TColumns
105− @TFromExprs
106 @(Eval (HKDRep a Expr))
107 @(Eval (HKDRep a Expr))
108+ @(Eval (HKDRep a Result))
107 (\(_ :: proxy x) -> toResult @_ @x) .
109 (\(_ :: proxy x) -> toResult @_ @x) .
108 from .
110 from .
109 Record
111 Record
110
112
111
113
112instance
114instance
113− ( GTable (TTable f) TColumns TFromExprs (GRecord (GMap (TColumn f) (Rep a)))
115+ ( GTable (TTable f) TColumns (GRecord (GMap (TColumn f) (Rep a)))
114 , G.GColumns TColumns (GRecord (GMap (TColumn f) (Rep a))) ~ GColumnsHKD a
116 , G.GColumns TColumns (GRecord (GMap (TColumn f) (Rep a))) ~ GColumnsHKD a
115 , GContext TContext (GRecord (GMap (TColumn f) (Rep a))) ~ f
117 , GContext TContext (GRecord (GMap (TColumn f) (Rep a))) ~ f
116 , GRecordable (GMap (TColumn f) (Rep a))
118 , GRecordable (GMap (TColumn f) (Rep a))
@@ -124,7 +126,6 @@ instance
124 G.gfromColumns
126 G.gfromColumns
125 @(TTable f)
127 @(TTable f)
126 @TColumns
128 @TColumns
127− @TFromExprs
128 fromColumns .
129 fromColumns .
129 (\(HKD a) -> a)
130 (\(HKD a) -> a)
130
131
@@ -133,7 +134,6 @@ instance
133 G.gtoColumns
134 G.gtoColumns
134 @(TTable f)
135 @(TTable f)
135 @TColumns
136 @TColumns
136− @TFromExprs
137 toColumns .
137 toColumns .
138 grecord @(GMap (TColumn f) (Rep a))
138 grecord @(GMap (TColumn f) (Rep a))
139
139
@@ -143,16 +143,16 @@ class
143 ( Generic (Record a)
143 ( Generic (Record a)
144 , HTable (GColumns (HKD a))
144 , HTable (GColumns (HKD a))
145 , KnownAlgebra (GAlgebra (Rep a))
145 , KnownAlgebra (GAlgebra (Rep a))
146− , Eval (GGTable (GAlgebra (Rep a)) (TTable Expr) TColumns TFromExprs (Eval (HKDRep a Expr)))
146+ , Eval (GGSerialize (GAlgebra (Rep a)) TSerialize TColumns (Eval (HKDRep a Expr)) (Eval (HKDRep a Result)))
147− , GMap TFromExprs (GRecord (GMap (TColumn Expr) (Rep a))) ~ Rep (Record a)
147+ , GRecord (GMap (TColumn Result) (Rep a)) ~ Rep (Record a)
148 )
148 )
149 => HKDable a
149 => HKDable a
150instance
150instance
151 ( Generic (Record a)
151 ( Generic (Record a)
152 , HTable (GColumns (HKD a))
152 , HTable (GColumns (HKD a))
153 , KnownAlgebra (GAlgebra (Rep a))
153 , KnownAlgebra (GAlgebra (Rep a))
154− , Eval (GGTable (GAlgebra (Rep a)) (TTable Expr) TColumns TFromExprs (Eval (HKDRep a Expr)))
154+ , Eval (GGSerialize (GAlgebra (Rep a)) TSerialize TColumns (Eval (HKDRep a Expr)) (Eval (HKDRep a Result)))
155− , GMap TFromExprs (GRecord (GMap (TColumn Expr) (Rep a))) ~ Rep (Record a)
155+ , GRecord (GMap (TColumn Result) (Rep a)) ~ Rep (Record a)
156 )
156 )
157 => HKDable a
157 => HKDable a
158
158
src/Rel8/Table/Ord.hs+3−9
@@ -35,7 +35,7 @@ import Rel8.Schema.Dict ( Dict( Dict ) )
35import Rel8.Schema.HTable ( htabulateA, hfield )
35import Rel8.Schema.HTable ( htabulateA, hfield )
36import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
36import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
37import Rel8.Schema.Null (Sql)
37import Rel8.Schema.Null (Sql)
38−import Rel8.Table ( Columns, toColumns, TColumns, TFromExprs )
38+import Rel8.Table ( Columns, toColumns, TColumns )
39import Rel8.Table.Bool ( bool )
39import Rel8.Table.Bool ( bool )
40import Rel8.Table.Eq ( EqTable )
40import Rel8.Table.Eq ( EqTable )
41import Rel8.Type.Ord ( DBOrd )
41import Rel8.Type.Ord ( DBOrd )
@@ -49,17 +49,11 @@ class EqTable a => OrdTable a where
49 ordTable :: Columns a (Dict (Sql DBOrd))
49 ordTable :: Columns a (Dict (Sql DBOrd))
50
50
51 default ordTable ::
51 default ordTable ::
52− ( GTable TOrdTable TColumns TFromExprs (Rep (Record a))
52+ ( GTable TOrdTable TColumns (Rep (Record a))
53 , Columns a ~ GColumns TColumns (Rep (Record a))
53 , Columns a ~ GColumns TColumns (Rep (Record a))
54 )
54 )
55 => Columns a (Dict (Sql DBOrd))
55 => Columns a (Dict (Sql DBOrd))
56− ordTable =
56+ ordTable = gtable @TOrdTable @TColumns @(Rep (Record a)) table
57− gtable
58− @TOrdTable
59− @TColumns
60− @TFromExprs
61− @(Rep (Record a))
62− table
63 where
57 where
64 table (_ :: proxy x) = ordTable @x
58 table (_ :: proxy x) = ordTable @x
65
59
src/Rel8/Table/Rel8able.hs+4−4
@@ -20,12 +20,12 @@ import Prelude ()
20-- rel8
20-- rel8
21import Rel8.Expr ( Expr )
21import Rel8.Expr ( Expr )
22import qualified Rel8.Kind.Algebra as K
22import qualified Rel8.Kind.Algebra as K
23+import Rel8.Kind.Context ( Reifiable, contextSing )
23import Rel8.Generic.Rel8able
24import Rel8.Generic.Rel8able
24 ( Rel8able, Algebra
25 ( Rel8able, Algebra
25 , GColumns, gfromColumns, gtoColumns
26 , GColumns, gfromColumns, gtoColumns
26 , GFromExprs, gfromResult, gtoResult
27 , GFromExprs, gfromResult, gtoResult
27 )
28 )
28−import Rel8.Schema.Context.Virtual ( Virtual, virtual )
29import qualified Rel8.Schema.Kind as K
29import qualified Rel8.Schema.Kind as K
30import Rel8.Schema.HTable ( HConstrainTable, hdicts )
30import Rel8.Schema.HTable ( HConstrainTable, hdicts )
31import Rel8.Schema.Null ( Sql )
31import Rel8.Schema.Null ( Sql )
@@ -43,7 +43,7 @@ import Rel8.Type.Eq ( DBEq )
43import Rel8.Type.Ord ( DBOrd )
43import Rel8.Type.Ord ( DBOrd )
44
44
45
45
46−instance (Rel8able t, Virtual context, context ~ context') =>
46+instance (Rel8able t, Reifiable context, context ~ context') =>
47 Table context' (t context)
47 Table context' (t context)
48 where
48 where
49 type Columns (t context) = GColumns t
49 type Columns (t context) = GColumns t
@@ -51,8 +51,8 @@ instance (Rel8able t, Virtual context, context ~ context') =>
51 type FromExprs (t context) = GFromExprs t
51 type FromExprs (t context) = GFromExprs t
52 type Transpose to (t context) = t to
52 type Transpose to (t context) = t to
53
53
54− fromColumns = gfromColumns virtual
54+ fromColumns = gfromColumns contextSing
55− toColumns = gtoColumns virtual
55+ toColumns = gtoColumns contextSing
56 fromResult = gfromResult @t
56 fromResult = gfromResult @t
57 toResult = gtoResult @t
57 toResult = gtoResult @t
58
58
tests/Rel8/Generic/Rel8able/Test.hs+27−1
@@ -6,6 +6,7 @@
6{-# language FlexibleInstances #-}
6{-# language FlexibleInstances #-}
7{-# language MultiParamTypeClasses #-}
7{-# language MultiParamTypeClasses #-}
8{-# language TypeFamilies #-}
8{-# language TypeFamilies #-}
9+{-# language UndecidableInstances #-}
9
10
10{-# options_ghc -O0 #-}
11{-# options_ghc -O0 #-}
11
12
@@ -136,10 +137,35 @@ data TableSum f
136 deriving stock Generic
137 deriving stock Generic
137
138
138
139
140+data BarbieSum f
141+ = BarbieSumA (f Bool) (f Text)
142+ | BarbieSumB
143+ | BarbieSumC (f Text)
144+ deriving stock Generic
145+
146+
139data TableProduct f = TableProduct
147data TableProduct f = TableProduct
140− { sum :: HADT f TableSum
148+ { sum :: HADT f BarbieSum
141 , list :: TableList f
149 , list :: TableList f
142 , foos :: HList f (HADT f TableSum, Lift f HKDSum, HKDTest f)
150 , foos :: HList f (HADT f TableSum, Lift f HKDSum, HKDTest f)
143 }
151 }
144 deriving stock Generic
152 deriving stock Generic
145 deriving anyclass Rel8able
153 deriving anyclass Rel8able
154+
155+
156+data TableTestB f = TableTestB
157+ { foo :: f Bool
158+ , bar :: f (Maybe Bool)
159+ }
160+ deriving stock Generic
161+ deriving anyclass Rel8able
162+
163+
164+data NestedTableTestB f = NestedTableTestB
165+ { foo :: f Bool
166+ , bar :: f (Maybe Bool)
167+ , baz :: Column f Char
168+ , nest :: TableTestB f
169+ }
170+ deriving stock Generic
171+ deriving anyclass Rel8able