git.iko.soy/rel8
on master help sign in
Introduce ADT meta-Rel8able for sum types
commit4bc16d34513bd018c6ae69e202f14579390d5b53 authorShane O'Brien <shane.obrien@circuithub.com> dateSat 1 May 2021, 10:21 (6 years ago) parent23bb65b
12 files changed+422−105
compare with master
unifiedsplit
rel8.cabal+3 src/Rel8.hs+7 src/Rel8/Column/ADT.hs+94 src/Rel8/Generic/Rel8able.hs+86−58 src/Rel8/Generic/Rel8able/Test.hs+8 src/Rel8/Table/ADT.hs+46 src/Rel8/Table/Eq.hs−11 src/Rel8/Table/NonEmpty.hs−1 src/Rel8/Table/Ord.hs+1−13 src/Rel8/Table/Recontextualize.hs+8−11 src/Rel8/Table/Rel8able.hs+167 src/Rel8/Table/Serialize.hs+2−11
rel8.cabal+3
@@ -50,6 +50,7 @@ library
5050 Rel8.Aggregate
5151
5252 Rel8.Column
53+ Rel8.Column.ADT
5354 Rel8.Column.Either
5455 Rel8.Column.Field
5556 Rel8.Column.Lift
@@ -143,6 +144,7 @@ library
143144 Rel8.Statement.View
144145
145146 Rel8.Table
147+ Rel8.Table.ADT
146148 Rel8.Table.Aggregate
147149 Rel8.Table.Alternative
148150 Rel8.Table.Bool
@@ -158,6 +160,7 @@ library
158160 Rel8.Table.Ord
159161 Rel8.Table.Order
160162 Rel8.Table.Recontextualize
163+ Rel8.Table.Rel8able
161164 Rel8.Table.Serialize
162165 Rel8.Table.Tag
163166 Rel8.Table.These
src/Rel8.hs+7
@@ -33,6 +33,7 @@ module Rel8
3333 , Rel8able, KRel8able
3434 , Column, Field, Necessity( Required, Optional )
3535 , Default
36+ , HADT
3637 , HEither
3738 , HMaybe
3839 , HList
@@ -81,6 +82,9 @@ module Rel8
8182 , bindTheseTable
8283 , bitraverseTheseTable
8384
85+ -- ** @ADT@
86+ , ADT
87+
8488 -- ** @ListTable@
8589 , ListTable
8690 , many
@@ -251,6 +255,7 @@ import Prelude ()
251255-- rel8
252256import Rel8.Aggregate
253257import Rel8.Column
258+import Rel8.Column.ADT
254259import Rel8.Column.Either
255260import Rel8.Column.Field
256261import Rel8.Column.Lift
@@ -300,6 +305,7 @@ import Rel8.Statement.Select
300305import Rel8.Statement.Update
301306import Rel8.Statement.View
302307import Rel8.Table
308+import Rel8.Table.ADT
303309import Rel8.Table.Aggregate
304310import Rel8.Table.Alternative
305311import Rel8.Table.Bool
@@ -313,6 +319,7 @@ import Rel8.Table.Name
313319import Rel8.Table.NonEmpty
314320import Rel8.Table.Ord
315321import Rel8.Table.Order
322+import Rel8.Table.Rel8able ()
316323import Rel8.Table.Serialize
317324import Rel8.Table.These
318325import Rel8.Type
src/Rel8/Column/ADT.hsnew file+94
@@ -0,0 +1,94 @@
1+{-# language DataKinds #-}
2+{-# language LambdaCase #-}
3+{-# language MultiParamTypeClasses #-}
4+{-# language StandaloneKindSignatures #-}
5+{-# language TypeFamilies #-}
6+{-# language UndecidableInstances #-}
7+
8+module Rel8.Column.ADT
9+ ( HADT, AHADT(..)
10+ )
11+where
12+
13+-- base
14+import Data.Kind ( Type )
15+import Prelude
16+
17+-- rel8
18+import Rel8.Generic.Rel8able
19+ ( Rel8able
20+ , GColumnsADT, gfromColumnsADT, gtoColumnsADT
21+ , greify, gunreify
22+ )
23+import Rel8.Kind.Context ( SContext(..), Reifiable, contextSing )
24+import Rel8.Schema.Context ( Col )
25+import qualified Rel8.Schema.Kind as K
26+import Rel8.Schema.Reify ( Reify, hreify, hunreify )
27+import Rel8.Schema.Result ( Result )
28+import Rel8.Table
29+ ( Table, Columns, Context, fromColumns, toColumns
30+ , Unreify, reify, unreify
31+ )
32+import Rel8.Table.ADT ( ADT( ADT ) )
33+import Rel8.Table.Recontextualize ( Recontextualize )
34+
35+
36+type HADT :: K.Context -> K.Rel8able -> Type
37+type family HADT context t where
38+ HADT (Reify context) t = AHADT context t
39+ HADT Result t = t Result
40+ HADT context t = ADT t context
41+
42+
43+type AHADT :: K.Context -> K.Rel8able -> Type
44+newtype AHADT context t = AHADT (HADT context t)
45+
46+
47+instance (Rel8able t, Reifiable context) =>
48+ Table (Reify context) (AHADT context t)
49+ where
50+ type Context (AHADT context t) = Reify context
51+ type Columns (AHADT context t) = GColumnsADT t
52+ type Unreify (AHADT context t) = HADT context t
53+
54+ fromColumns = sfromColumnsADT contextSing
55+ toColumns = stoColumnsADT contextSing
56+ reify _ = AHADT
57+ unreify _ (AHADT a) = a
58+
59+
60+instance
61+ ( Reifiable context, Reifiable context'
62+ , Rel8able t, t ~ t'
63+ )
64+ => Recontextualize
65+ (Reify context)
66+ (Reify context')
67+ (AHADT context t)
68+ (AHADT context' t')
69+
70+
71+sfromColumnsADT :: Rel8able t
72+ => SContext context
73+ -> GColumnsADT t (Col (Reify context))
74+ -> AHADT context t
75+sfromColumnsADT = \case
76+ SAggregate -> AHADT . ADT . hunreify
77+ SExpr -> AHADT . ADT . hunreify
78+ SInsert -> AHADT . ADT . hunreify
79+ SName -> AHADT . ADT . hunreify
80+ SResult -> AHADT . gunreify . gfromColumnsADT
81+ SReify context -> AHADT . sfromColumnsADT context . hunreify
82+
83+
84+stoColumnsADT :: Rel8able t
85+ => SContext context
86+ -> AHADT context t
87+ -> GColumnsADT t (Col (Reify context))
88+stoColumnsADT = \case
89+ SAggregate -> hreify . (\(AHADT (ADT a)) -> a)
90+ SExpr -> hreify . (\(AHADT (ADT a)) -> a)
91+ SInsert -> hreify . (\(AHADT (ADT a)) -> a)
92+ SName -> hreify . (\(AHADT (ADT a)) -> a)
93+ SResult -> gtoColumnsADT . greify . (\(AHADT a) -> a)
94+ SReify context -> hreify . stoColumnsADT context . (\(AHADT a) -> a)
src/Rel8/Generic/Rel8able.hs+86−58
@@ -11,12 +11,13 @@
1111{-# language TypeFamilies #-}
1212{-# language UndecidableInstances #-}
1313
14−{-# options_ghc -fno-warn-orphans #-}
15−
1614module Rel8.Generic.Rel8able
1715 ( KRel8able, Rel8able
18− , GColumns, GContext, gfromColumns, gtoColumns, greify, gunreify
1916 , Algebra
17+ , GRep
18+ , GColumns, GContext, gfromColumns, gtoColumns
19+ , GColumnsADT, gfromColumnsADT, gtoColumnsADT
20+ , greify, gunreify
2021 )
2122where
2223
@@ -28,11 +29,7 @@ import GHC.Generics ( Generic, Rep, from, to )
2829import Prelude
2930
3031-- rel8
31−import Rel8.Kind.Context
32− ( SContext( SReify )
33− , Reifiable, contextSing
34− , sLabelable, sReifiable
35− )
32+import Rel8.Kind.Context ( Reifiable )
3633import Rel8.FCF ( Eval, Exp )
3734import Rel8.Generic.Map ( GMap, GMappable, gmap, gunmap )
3835import Rel8.Generic.Record ( Record(..) )
@@ -40,6 +37,7 @@ import Rel8.Generic.Table
4037 ( GGTable, GGColumns, GGContext, ggfromColumns, ggtoColumns
4138 , GAlgebra
4239 )
40+import qualified Rel8.Generic.Table.ADT as G
4341import Rel8.Kind.Algebra
4442 ( SAlgebra( SProduct, SSum )
4543 , KnownAlgebra, algebraSing
@@ -47,48 +45,17 @@ import Rel8.Kind.Algebra
4745import qualified Rel8.Kind.Algebra as K ( Algebra(..) )
4846import Rel8.Schema.Context ( Col )
4947import Rel8.Schema.Context.Label ( Labelable )
50−import Rel8.Schema.Dict ( Dict( Dict ) )
5148import Rel8.Schema.HTable ( HTable )
5249import qualified Rel8.Schema.Kind as K
5350import Rel8.Schema.Name ( Name )
54−import Rel8.Schema.Reify
55− ( Col( Reify ), Reify, hreify, hunreify
56− , UnwrapReify
57− )
51+import Rel8.Schema.Reify ( Col( Reify ), Reify, UnwrapReify )
5852import Rel8.Schema.Result ( Result )
5953import Rel8.Table
60− ( Table, Columns, Context, fromColumns, toColumns
61− , Unreify, reify, unreify
54+ ( fromColumns, toColumns, reify, unreify
6255 , TTable, TColumns, TContext, TUnreify
6356 )
6457
6558
66−instance
67− ( Rel8able t
68− , GContext t context ~ context
69− , Labelable context
70− , Reifiable context
71− )
72− => Table context (t context)
73− where
74− type Columns (t context) = GColumns t
75− type Context (t context) = context
76− type Unreify (t context) = t (UnwrapReify context)
77−
78− fromColumns = gunreify . gfromColumns . hreify
79− toColumns = hunreify . gtoColumns . greify
80−
81− reify Refl = case contextSing @context of
82− SReify context -> case sLabelable context of
83− Dict -> case sReifiable context of
84− Dict -> greify
85−
86− unreify Refl = case contextSing @context of
87− SReify context -> case sLabelable context of
88− Dict -> case sReifiable context of
89− Dict -> gunreify
90−
91−
9259type KRel8able :: Type
9360type KRel8able = K.Rel8able
9461
@@ -136,9 +103,19 @@ type KRel8able = K.Rel8able
136103-- deriving ( GHC.Generics.Generic, Rel8able )
137104-- @
138105type Rel8able :: K.Rel8able -> Constraint
139−class HTable (GColumns t) => Rel8able t where
106+class
107+ ( HTable (GColumns t)
108+ , HTable (GColumnsADT t)
109+ , GContext t Result ~ Result
110+ )
111+ => Rel8able t
112+ where
140113 type Algebra t :: K.Algebra
114+
115+ type GRep t (context :: K.Context) :: Type -> Type
116+
141117 type GColumns t :: K.HTable
118+
142119 type GContext t (context :: K.Context) :: K.Context
143120
144121 gfromColumns :: (Labelable context, Reifiable context, GContext t context ~ context)
@@ -147,21 +124,31 @@ class HTable (GColumns t) => Rel8able t where
147124 gtoColumns :: (Labelable context, Reifiable context, GContext t context ~ context)
148125 => t (Reify context) -> GColumns t (Col (Reify context))
149126
127+ gfromColumnsADT :: GColumnsADT t (Col (Reify Result)) -> t (Reify Result)
128+
129+ gtoColumnsADT :: t (Reify Result) -> GColumnsADT t (Col (Reify Result))
130+
150131 greify :: (Labelable context, Reifiable context)
151132 => t context -> t (Reify context)
152133
153134 gunreify :: (Labelable context, Reifiable context)
154135 => t (Reify context) -> t context
155136
156− type Algebra t = GAlgebra (Rep (Record (t (Reify Name))))
157− type GColumns t = Eval (GGColumns (Algebra t) TColumns (Rep (Record (t (Reify Name)))))
158− type GContext t context = Eval (GGContext (Algebra t) TUnreifyContext (Rep (Record (t (Reify context)))))
137+ type Algebra t = GAlgebra (GRep t (Reify Name))
138+
139+ type GRep t context = Rep (Record (t context))
140+
141+ type GColumns t = Eval (GGColumns (Algebra t) TColumns (GRep t (Reify Name)))
142+
143+ type GContext t context =
144+ Eval (GGContext (Algebra t) TUnreifyContext (GRep t (Reify context)))
159145
160146 default gfromColumns :: forall context.
161147 ( Generic (Record (t (Reify context)))
148+ , GRep t (Reify context) ~ Rep (Record (t (Reify context)))
162149 , KnownAlgebra (Algebra t)
163− , Eval (GGTable (Algebra t) (TTable (Reify context)) TColumns (Col (Reify context)) (Rep (Record (t (Reify context)))))
164− , Eval (GGColumns (Algebra t) TColumns (Rep (Record (t (Reify context))))) ~ GColumns t
150+ , Eval (GGTable (Algebra t) (TTable (Reify context)) TColumns (Col (Reify context)) (GRep t (Reify context)))
151+ , Eval (GGColumns (Algebra t) TColumns (GRep t (Reify context))) ~ GColumns t
165152 , Constraints t context
166153 )
167154 => GColumns t (Col (Reify context)) -> t (Reify context)
@@ -179,9 +166,10 @@ class HTable (GColumns t) => Rel8able t where
179166
180167 default gtoColumns :: forall context.
181168 ( Generic (Record (t (Reify context)))
169+ , GRep t (Reify context) ~ Rep (Record (t (Reify context)))
182170 , KnownAlgebra (Algebra t)
183− , Eval (GGTable (Algebra t) (TTable (Reify context)) TColumns (Col (Reify context)) (Rep (Record (t (Reify context)))))
184− , Eval (GGColumns (Algebra t) TColumns (Rep (Record (t (Reify context))))) ~ GColumns t
171+ , Eval (GGTable (Algebra t) (TTable (Reify context)) TColumns (Col (Reify context)) (GRep t (Reify context)))
172+ , Eval (GGColumns (Algebra t) TColumns (GRep t (Reify context))) ~ GColumns t
185173 , Constraints t context
186174 )
187175 => t (Reify context) -> GColumns t (Col (Reify context))
@@ -197,11 +185,47 @@ class HTable (GColumns t) => Rel8able t where
197185 from .
198186 Record
199187
188+ default gfromColumnsADT ::
189+ ( Generic (Record (t (Reify Result)))
190+ , GRep t (Reify Result) ~ Rep (Record (t (Reify Result)))
191+ , G.GTableADT (TTable (Reify Result)) TColumns (Col (Reify Result)) (GRep t (Reify Result))
192+ , G.GColumnsADT TColumns (GRep t (Reify Result)) ~ GColumnsADT t
193+ )
194+ => GColumnsADT t (Col (Reify Result)) -> t (Reify Result)
195+ gfromColumnsADT =
196+ unrecord .
197+ to .
198+ G.gfromColumnsADT
199+ @(TTable (Reify Result))
200+ @TColumns
201+ (\(Reify a) -> a)
202+ Reify
203+ fromColumns
204+
205+ default gtoColumnsADT ::
206+ ( Generic (Record (t (Reify Result)))
207+ , GRep t (Reify Result) ~ Rep (Record (t (Reify Result)))
208+ , G.GTableADT (TTable (Reify Result)) TColumns (Col (Reify Result)) (GRep t (Reify Result))
209+ , G.GColumnsADT TColumns (GRep t (Reify Result)) ~ GColumnsADT t
210+ )
211+ => t (Reify Result) -> GColumnsADT t (Col (Reify Result))
212+ gtoColumnsADT =
213+ G.gtoColumnsADT
214+ @(TTable (Reify Result))
215+ @TColumns
216+ (\(Reify a) -> a)
217+ Reify
218+ toColumns .
219+ from .
220+ Record
221+
200222 default greify :: forall context.
201223 ( Generic (Record (t context))
224+ , GRep t context ~ Rep (Record (t context))
202225 , Generic (Record (t (Reify context)))
203− , GMappable (TTable (Reify context)) (Rep (Record (t (Reify context))))
204− , Rep (Record (t context)) ~ GMap TUnreify (Rep (Record (t (Reify context))))
226+ , GRep t (Reify context) ~ Rep (Record (t (Reify context)))
227+ , GMappable (TTable (Reify context)) (GRep t (Reify context))
228+ , GRep t context ~ GMap TUnreify (GRep t (Reify context))
205229 )
206230 => t context -> t (Reify context)
207231 greify =
@@ -213,9 +237,11 @@ class HTable (GColumns t) => Rel8able t where
213237
214238 default gunreify :: forall context.
215239 ( Generic (Record (t context))
240+ , GRep t context ~ Rep (Record (t context))
216241 , Generic (Record (t (Reify context)))
217− , GMappable (TTable (Reify context)) (Rep (Record (t (Reify context))))
218− , Rep (Record (t context)) ~ GMap TUnreify (Rep (Record (t (Reify context))))
242+ , GRep t (Reify context) ~ Rep (Record (t (Reify context)))
243+ , GMappable (TTable (Reify context)) (GRep t (Reify context))
244+ , GRep t context ~ GMap TUnreify (GRep t (Reify context))
219245 )
220246 => t (Reify context) -> t context
221247 gunreify =
@@ -226,6 +252,9 @@ class HTable (GColumns t) => Rel8able t where
226252 Record
227253
228254
255+type GColumnsADT t = G.GColumnsADT TColumns (GRep t (Reify Name))
256+
257+
229258data TUnreifyContext :: Type -> Exp K.Context
230259type instance Eval (TUnreifyContext a) = UnwrapReify (Eval (TContext a))
231260
@@ -237,9 +266,8 @@ type Constraints t context = Constraints' (Algebra t) t context
237266type Constraints' :: K.Algebra -> K.Rel8able -> K.Context -> Constraint
238267type family Constraints' algebra t context where
239268 Constraints' 'K.Product t context =
240− ( Eval (GGContext 'K.Product TContext (Rep (Record (t (Reify context))))) ~
241− Reify context
242− )
269+ Eval (GGContext 'K.Product TContext (GRep t (Reify context))) ~
270+ Reify context
243271 Constraints' 'K.Sum _ context = context ~ Result
244272
245273
@@ -248,7 +276,7 @@ fromContext :: forall t context spec.
248276 , Constraints t context
249277 )
250278 => Col (Reify context) spec
251− -> Col (Eval (GGContext (Algebra t) TContext (Rep (Record (t (Reify context)))))) spec
279+ -> Col (Eval (GGContext (Algebra t) TContext (GRep t (Reify context)))) spec
252280fromContext = case algebraSing @(Algebra t) of
253281 SProduct -> id
254282 SSum -> \(Reify a) -> a
@@ -258,7 +286,7 @@ toContext :: forall t context spec.
258286 ( KnownAlgebra (Algebra t)
259287 , Constraints t context
260288 )
261− => Col (Eval (GGContext (Algebra t) TContext (Rep (Record (t (Reify context)))))) spec
289+ => Col (Eval (GGContext (Algebra t) TContext (GRep t (Reify context)))) spec
262290 -> Col (Reify context) spec
263291toContext = case algebraSing @(Algebra t) of
264292 SProduct -> id
src/Rel8/Generic/Rel8able/Test.hs+8
@@ -124,3 +124,11 @@ data TableSum f
124124 | TableSumC (Column f Text)
125125 deriving stock Generic
126126 deriving anyclass Rel8able
127+
128+
129+data TableProduct f = TableProduct
130+ { sum :: HADT f TableSum
131+ , list :: TableList f
132+ }
133+ deriving stock Generic
134+ deriving anyclass Rel8able
src/Rel8/Table/ADT.hsnew file+46
@@ -0,0 +1,46 @@
1+{-# language DataKinds #-}
2+{-# language StandaloneKindSignatures #-}
3+{-# language TypeFamilies #-}
4+{-# language UndecidableInstances #-}
5+
6+module Rel8.Table.ADT
7+ ( ADT( ADT )
8+ )
9+where
10+
11+-- base
12+import Prelude ()
13+
14+-- rel8
15+import Rel8.Generic.Rel8able
16+ ( Rel8able, Algebra
17+ , GRep, GColumns, GContext, gfromColumns, gtoColumns
18+ , GColumnsADT, gfromColumnsADT, gtoColumnsADT
19+ , greify, gunreify
20+ )
21+import qualified Rel8.Kind.Algebra as K
22+import Rel8.Schema.Context ( Col )
23+import qualified Rel8.Schema.Kind as K
24+import Rel8.Schema.Reify ( hreify, hunreify )
25+
26+
27+type ADT :: K.Rel8able -> K.Rel8able
28+newtype ADT t context = ADT (GColumnsADT t (Col context))
29+
30+
31+instance Rel8able t => Rel8able (ADT t) where
32+ type Algebra (ADT t) = 'K.Product
33+
34+ type GRep (ADT t) context = GRep t context
35+
36+ type GColumns (ADT t) = GColumnsADT t
37+ type GContext (ADT t) context = context
38+
39+ gfromColumns = ADT
40+ gtoColumns (ADT a) = a
41+
42+ gfromColumnsADT = ADT
43+ gtoColumnsADT (ADT a) = a
44+
45+ greify (ADT a) = ADT (hreify a)
46+ gunreify (ADT a) = ADT (hunreify a)
src/Rel8/Table/Eq.hs−11
@@ -44,7 +44,6 @@ import Rel8.Schema.HTable
4444 , htabulateA, hfield, hdicts
4545 )
4646import Rel8.Schema.HTable.Type ( HType(..) )
47−import Rel8.Schema.Kind ( Context )
4847import Rel8.Schema.Null ( Sql )
4948import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType, nullifier )
5049import Rel8.Table ( Table, Columns, toColumns, TColumns )
@@ -80,16 +79,6 @@ data TEqTable :: Type -> Exp Constraint
8079type instance Eval (TEqTable a) = EqTable a
8180
8281
83−instance
84− ( Table Expr (t (Expr :: Context))
85− , f ~ Expr
86− , HConstrainTable (Columns (t Expr)) (ConstrainDBType DBEq)
87− )
88− => EqTable (t f)
89− where
90− eqTable = hdicts @(Columns (t f)) @(ConstrainDBType DBEq)
91−
92−
9382instance
9483 ( HTable t
9584 , f ~ Col Expr
src/Rel8/Table/NonEmpty.hs−1
@@ -3,7 +3,6 @@
33{-# language FlexibleInstances #-}
44{-# language MultiParamTypeClasses #-}
55{-# language NamedFieldPuns #-}
6−{-# language QuantifiedConstraints #-}
76{-# language ScopedTypeVariables #-}
87{-# language StandaloneKindSignatures #-}
98{-# language TypeApplications #-}
src/Rel8/Table/Ord.hs+1−13
@@ -42,10 +42,9 @@ import Rel8.Schema.HTable
4242 , htabulateA, hfield, hdicts
4343 )
4444import Rel8.Schema.HTable.Type ( HType(..) )
45−import Rel8.Schema.Kind ( Context )
4645import Rel8.Schema.Null (Sql)
4746import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType, nullifier )
48−import Rel8.Table ( Table, Columns, toColumns, TColumns )
47+import Rel8.Table ( Columns, toColumns, TColumns )
4948import Rel8.Table.Bool ( bool )
5049import Rel8.Table.Eq ( EqTable )
5150import Rel8.Type.Eq ( DBEq )
@@ -81,17 +80,6 @@ data TOrdTable :: Type -> Exp Constraint
8180type instance Eval (TOrdTable a) = OrdTable a
8281
8382
84−instance
85− ( Table Expr (t (Expr :: Context))
86− , f ~ Expr
87− , HConstrainTable (Columns (t Expr)) (ConstrainDBType DBEq)
88− , HConstrainTable (Columns (t Expr)) (ConstrainDBType DBOrd)
89− )
90− => OrdTable (t f)
91− where
92− ordTable = hdicts @(Columns (t f)) @(ConstrainDBType DBOrd)
93−
94−
9583instance
9684 ( HTable t
9785 , f ~ Col Expr
src/Rel8/Table/Recontextualize.hs+8−11
@@ -48,19 +48,13 @@ instance Sql DBType a => Recontextualize Result Result (Identity a) (Identity a)
4848instance HTable t => Recontextualize from to (t (Col from)) (t (Col to))
4949
5050
51−instance
52− ( Table from (t from)
53− , Table to (t to)
54− , Congruent (t from) (t to)
55− ) => Recontextualize from to (t from) (t to)
56−
57−
5851instance
5952 ( Recontextualize from to a1 b1
6053 , Recontextualize from to a2 b2
6154 , Labelable from
6255 , Labelable to
63− ) => Recontextualize from to (a1, a2) (b1, b2)
56+ )
57+ => Recontextualize from to (a1, a2) (b1, b2)
6458
6559
6660instance
@@ -68,7 +62,8 @@ instance
6862 , Recontextualize from to a2 b2
6963 , Recontextualize from to a3 b3
7064 , Labelable from, Labelable to
71− ) => Recontextualize from to (a1, a2, a3) (b1, b2, b3)
65+ )
66+ => Recontextualize from to (a1, a2, a3) (b1, b2, b3)
7267
7368
7469instance
@@ -77,7 +72,8 @@ instance
7772 , Recontextualize from to a3 b3
7873 , Recontextualize from to a4 b4
7974 , Labelable from, Labelable to
80− ) => Recontextualize from to (a1, a2, a3, a4) (b1, b2, b3, b4)
75+ )
76+ => Recontextualize from to (a1, a2, a3, a4) (b1, b2, b3, b4)
8177
8278
8379instance
@@ -87,4 +83,5 @@ instance
8783 , Recontextualize from to a4 b4
8884 , Recontextualize from to a5 b5
8985 , Labelable from, Labelable to
90− ) => Recontextualize from to (a1, a2, a3, a4, a5) (b1, b2, b3, b4, b5)
86+ )
87+ => Recontextualize from to (a1, a2, a3, a4, a5) (b1, b2, b3, b4, b5)
src/Rel8/Table/Rel8able.hsnew file+167
@@ -0,0 +1,167 @@
1+{-# language DataKinds #-}
2+{-# language FlexibleInstances #-}
3+{-# language FunctionalDependencies #-}
4+{-# language ScopedTypeVariables #-}
5+{-# language StandaloneKindSignatures #-}
6+{-# language TypeApplications #-}
7+{-# language TypeFamilies #-}
8+{-# language UndecidableInstances #-}
9+
10+{-# options_ghc -fno-warn-orphans #-}
11+
12+module Rel8.Table.Rel8able
13+ (
14+ )
15+where
16+
17+-- base
18+import Data.Kind ( Constraint )
19+import Data.Type.Equality ( (:~:)( Refl ) )
20+import Prelude
21+
22+-- rel8
23+import Rel8.Expr ( Expr )
24+import qualified Rel8.Kind.Algebra as K
25+import Rel8.Kind.Context
26+ ( SContext( SReify )
27+ , Reifiable, contextSing
28+ , sLabelable, sReifiable
29+ )
30+import Rel8.Generic.Rel8able
31+ ( Rel8able, Algebra
32+ , GColumns, GContext, gfromColumns, gtoColumns
33+ , gfromColumnsADT, gtoColumnsADT
34+ , greify, gunreify
35+ )
36+import Rel8.Schema.Context ( Col )
37+import Rel8.Schema.Context.Label ( Labelable )
38+import Rel8.Schema.Dict ( Dict( Dict ) )
39+import qualified Rel8.Schema.Kind as K
40+import Rel8.Schema.HTable ( HConstrainTable, hdicts )
41+import Rel8.Schema.Reify ( hreify, hunreify, UnwrapReify )
42+import Rel8.Schema.Result ( Result )
43+import Rel8.Table
44+ ( Table, Columns, Context, Congruent, fromColumns, toColumns
45+ , Unreify, reify, unreify
46+ )
47+import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
48+import Rel8.Table.ADT ( ADT )
49+import Rel8.Table.Eq ( EqTable, eqTable )
50+import Rel8.Table.Ord ( OrdTable, ordTable )
51+import Rel8.Table.Recontextualize ( Recontextualize )
52+import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
53+import Rel8.Type.Eq ( DBEq )
54+import Rel8.Type.Ord ( DBOrd )
55+
56+
57+instance
58+ ( Rel8able t
59+ , GContext t context ~ context
60+ , Labelable context
61+ , Reifiable context
62+ )
63+ => Table context (t context)
64+ where
65+ type Columns (t context) = GColumns t
66+ type Context (t context) = context
67+ type Unreify (t context) = t (UnwrapReify context)
68+
69+ fromColumns = gunreify . gfromColumns . hreify
70+ toColumns = hunreify . gtoColumns . greify
71+
72+ reify Refl = case contextSing @context of
73+ SReify context -> case sLabelable context of
74+ Dict -> case sReifiable context of
75+ Dict -> greify
76+
77+ unreify Refl = case contextSing @context of
78+ SReify context -> case sLabelable context of
79+ Dict -> case sReifiable context of
80+ Dict -> gunreify
81+
82+
83+instance
84+ ( Rel8able t
85+ , Labelable from, Reifiable from, GContext t from ~ from
86+ , Labelable to, Reifiable to, GContext t to ~ to
87+ , Congruent (t from) (t to)
88+ )
89+ => Recontextualize from to (t from) (t to)
90+
91+
92+instance
93+ ( context ~ Expr
94+ , Rel8able t
95+ , GContext t context ~ context
96+ , HConstrainTable (Columns (t context)) (ConstrainDBType DBEq)
97+ )
98+ => EqTable (t context)
99+ where
100+ eqTable = hdicts @(Columns (t context)) @(ConstrainDBType DBEq)
101+
102+
103+instance
104+ ( context ~ Expr
105+ , Rel8able t
106+ , GContext t context ~ context
107+ , HConstrainTable (Columns (t context)) (ConstrainDBType DBEq)
108+ , HConstrainTable (Columns (t context)) (ConstrainDBType DBOrd)
109+ )
110+ => OrdTable (t context)
111+ where
112+ ordTable = hdicts @(Columns (t context)) @(ConstrainDBType DBOrd)
113+
114+
115+type instance FromExprs (t Expr) = FromExprs' t Result
116+
117+
118+instance
119+ ( x ~ t' Expr
120+ , result ~ Result
121+ , ToExprs' (Algebra t) t' t
122+ )
123+ => ToExprs x (t result)
124+ where
125+ fromResult = fromResult' @(Algebra t) @t'
126+ toResult = toResult' @(Algebra t) @t'
127+
128+
129+type FromExprs' :: K.Rel8able -> K.Rel8able
130+type family FromExprs' t where
131+ FromExprs' (ADT t) = t
132+ FromExprs' t = t
133+
134+
135+type ToExprs' :: K.Algebra -> K.Rel8able -> K.Rel8able -> Constraint
136+class
137+ ( algebra ~ Algebra t
138+ , Rel8able t'
139+ , GContext t' Expr ~ Expr
140+ )
141+ => ToExprs' algebra t' t | algebra t -> t'
142+ where
143+ fromResult' :: GColumns t' (Col Result) -> t Result
144+ toResult' :: t Result -> GColumns t' (Col Result)
145+
146+
147+instance
148+ ( Algebra t ~ 'K.Product
149+ , Rel8able t
150+ , GContext t Expr ~ Expr
151+ , t ~ t'
152+ )
153+ => ToExprs' 'K.Product t' t
154+ where
155+ fromResult' = fromColumns
156+ toResult' = toColumns
157+
158+
159+instance
160+ ( Algebra t ~ 'K.Sum
161+ , Rel8able t
162+ , t' ~ ADT t
163+ )
164+ => ToExprs' 'K.Sum t' t
165+ where
166+ fromResult' = gunreify . gfromColumnsADT . hreify
167+ toResult' = hunreify . gtoColumnsADT . greify
src/Rel8/Table/Serialize.hs+2−11
@@ -15,8 +15,8 @@
1515
1616module Rel8.Table.Serialize
1717 ( Serializable, lit, parse
18− , ToExprs(..)
19− , FromExprs
18+ , ToExprs(..), FromExprs
19+ , TToExprs
2020 )
2121where
2222
@@ -50,7 +50,6 @@ import Rel8.Table.Either ( EitherTable )
5050import Rel8.Table.List ( ListTable )
5151import Rel8.Table.Maybe ( MaybeTable )
5252import Rel8.Table.NonEmpty ( NonEmptyTable )
53−import Rel8.Table.Recontextualize ( Recontextualize )
5453import Rel8.Table.These ( TheseTable )
5554import Rel8.Type ( DBType )
5655
@@ -231,13 +230,6 @@ instance (HTable t, result ~ Col Result, x ~ t (Col Expr)) =>
231230 toResult = id
232231
233232
234−instance (Recontextualize Result Expr (t Result) (t Expr), result ~ Result, x ~ t Expr) =>
235− ToExprs x (t result)
236− where
237− fromResult = fromColumns
238− toResult = toColumns
239−
240−
241233instance (KnownSpec spec, x ~ Col Expr spec) =>
242234 ToExprs x (Col Result spec)
243235 where
@@ -268,7 +260,6 @@ type instance FromExprs (a, b, c, d, e, f, g) =
268260 ( FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e
269261 , FromExprs f, FromExprs g
270262 )
271−type instance FromExprs (t Expr) = t Result
272263type instance FromExprs (t (Col Expr)) = t (Col Result)
273264
274265