git.iko.soy/rel8
on master help sign in
Add reify and unreify to Table class

Previously these were implemented with `unsafeCoerce`, which was mostly correct, but was incorrect for certain instances of `HList`. With this change, `deriving Rel8able` will now fail to type check in those instances.

commit1c73ec6814b7c10b806ce6e915352afc19692df3 authorShane O'Brien <shane.obrien@circuithub.com> dateTue 27 Apr 2021, 14:40 (6 years ago) parent1276beb
20 files changed+576−139
compare with master
unifiedsplit
rel8.cabal+3 src/Rel8/Aggregate.hs+8−1 src/Rel8/Expr.hs+6−1 src/Rel8/Generic/Table.hs+38−2 src/Rel8/Kind/Context.hs+89 src/Rel8/Schema/Field.hs+48−74 src/Rel8/Schema/Generic.hs+62−24 src/Rel8/Schema/Generic/Test.hs+6−3 src/Rel8/Schema/HKD.hs+20−5 src/Rel8/Schema/HTable/Nullify.hs+5−5 src/Rel8/Schema/Insert.hs+7−1 src/Rel8/Schema/Name.hs+6−1 src/Rel8/Schema/Reify.hs+75 src/Rel8/Table.hs+99−9 src/Rel8/Table/Either.hs+7−1 src/Rel8/Table/List.hs+18−4 src/Rel8/Table/Maybe.hs+8−2 src/Rel8/Table/NonEmpty.hs+20−4 src/Rel8/Table/These.hs+8−2 src/Rel8/Table/Unreify.hs+43
rel8.cabal+3
@@ -63,6 +63,7 @@ library
6363
6464 Rel8.FCF
6565
66+ Rel8.Kind.Context
6667 Rel8.Kind.Labels
6768 Rel8.Kind.Necessity
6869
@@ -115,6 +116,7 @@ library
115116 Rel8.Schema.Kind
116117 Rel8.Schema.Name
117118 Rel8.Schema.Null
119+ Rel8.Schema.Reify
118120 Rel8.Schema.Result
119121 Rel8.Schema.Spec
120122 Rel8.Schema.Spec.ConstrainDBType
@@ -148,6 +150,7 @@ library
148150 Rel8.Table.Tag
149151 Rel8.Table.These
150152 Rel8.Table.Undefined
153+ Rel8.Table.Unreify
151154
152155 Rel8.Type
153156 Rel8.Type.Array
src/Rel8/Aggregate.hs+8−1
@@ -37,9 +37,13 @@ import Rel8.Schema.Context.Label ( Labelable(..) )
3737import Rel8.Schema.HTable ( hfield, htabulate, htabulateA, hspecs )
3838import Rel8.Schema.Name ( Name )
3939import Rel8.Schema.Null ( Sql )
40+import Rel8.Schema.Reify ( notReify )
4041import Rel8.Schema.Result ( Result )
4142import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
42−import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
43+import Rel8.Table
44+ ( Table, Columns, Context, fromColumns, toColumns
45+ , reify, unreify
46+ )
4347import Rel8.Table.Recontextualize ( Recontextualize )
4448import Rel8.Type ( DBType )
4549
@@ -82,6 +86,9 @@ instance Table Expr a => Table Aggregate (Aggregate a) where
8286 case hfield as field of
8387 Aggregation a -> DB <$> a
8488
89+ reify = notReify
90+ unreify = notReify
91+
8592
8693instance Sql DBType a =>
8794 Recontextualize Aggregate Aggregate (Aggregate (Expr a)) (Aggregate (Expr a))
src/Rel8/Expr.hs+6−1
@@ -41,9 +41,12 @@ import Rel8.Schema.Context ( Interpretation, Col )
4141import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
4242import Rel8.Schema.HTable.Type ( HType( HType ) )
4343import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )
44+import Rel8.Schema.Reify ( notReify )
4445import Rel8.Schema.Result ( Result )
4546import Rel8.Schema.Spec ( Spec( Spec ) )
46−import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
47+import Rel8.Table
48+ ( Table, Columns, Context, fromColumns, toColumns, reify, unreify
49+ )
4750import Rel8.Table.Recontextualize ( Recontextualize )
4851import Rel8.Type ( DBType )
4952import Rel8.Type.Monoid ( DBMonoid, memptyExpr )
@@ -112,6 +115,8 @@ instance Sql DBType a => Table Expr (Expr a) where
112115
113116 toColumns a = HType (DB a)
114117 fromColumns (HType (DB a)) = a
118+ reify = notReify
119+ unreify = notReify
115120
116121
117122instance Sql DBType a => Recontextualize Expr Expr (Expr a) (Expr a)
src/Rel8/Generic/Table.hs+38−2
@@ -12,7 +12,8 @@
1212{-# language UndecidableInstances #-}
1313
1414module Rel8.Generic.Table
15− ( GTable, GColumns, GContext, fromGColumns, toGColumns, gtable
15+ ( GTable, GColumns, GContext, GUnreify
16+ , fromGColumns, toGColumns, gtable, greify, gunreify
1617 )
1718where
1819
@@ -53,6 +54,14 @@ type family GContext _Context rep where
5354 GContext _Context (K1 _ a) = Eval (_Context a)
5455
5556
57+type GUnreify :: (Type -> Exp a) -> (Type -> Type) -> Type -> Type
58+type family GUnreify _Unreify rep where
59+ GUnreify _Unreify (M1 i c rep) = M1 i c (GUnreify _Unreify rep)
60+ GUnreify _Unreify (rep1 :*: rep2) =
61+ GUnreify _Unreify rep1 :*: GUnreify _Unreify rep2
62+ GUnreify _Unreify (K1 i a) = K1 i (Eval (_Unreify a))
63+
64+
5665type GTable
5766 :: (Type -> Exp Constraint)
5867 -> (Type -> Exp K.HTable)
@@ -73,6 +82,18 @@ class GTable _Table _Columns context rep
7382 => (forall a. Eval (_Table a) => Proxy a -> Eval (_Columns a) context)
7483 -> GColumns _Columns rep context
7584
85+ greify :: ()
86+ => Proxy _Unreify
87+ -> (forall a. Eval (_Table a) => Eval (_Unreify a) -> a)
88+ -> GUnreify _Unreify rep x
89+ -> rep x
90+
91+ gunreify :: ()
92+ => Proxy _Unreify
93+ -> (forall a. Eval (_Table a) => a -> Eval (_Unreify a))
94+ -> rep x
95+ -> GUnreify _Unreify rep x
96+
7697
7798instance GTable _Table _Columns context rep =>
7899 GTable _Table _Columns context (M1 D c rep)
@@ -82,6 +103,10 @@ instance GTable _Table _Columns context rep =>
82103 toGColumns toColumns (M1 a) =
83104 toGColumns @_Table @_Columns @context @rep toColumns a
84105 gtable = gtable @_Table @_Columns @context @rep
106+ greify proxy reify (M1 a) =
107+ M1 (greify @_Table @_Columns @context @rep proxy reify a)
108+ gunreify proxy unreify (M1 a) =
109+ M1 (gunreify @_Table @_Columns @context @rep proxy unreify a)
85110
86111
87112instance GTable _Table _Columns context rep =>
@@ -92,6 +117,10 @@ instance GTable _Table _Columns context rep =>
92117 toGColumns toColumns (M1 a) =
93118 toGColumns @_Table @_Columns @context @rep toColumns a
94119 gtable = gtable @_Table @_Columns @context @rep
120+ greify proxy reify (M1 a) =
121+ M1 (greify @_Table @_Columns @context @rep proxy reify a)
122+ gunreify proxy unreify (M1 a) =
123+ M1 (gunreify @_Table @_Columns @context @rep proxy unreify a)
95124
96125
97126instance
@@ -109,6 +138,12 @@ instance
109138 gtable table = HProduct
110139 (gtable @_Table @_Columns @context @rep1 table)
111140 (gtable @_Table @_Columns @context @rep2 table)
141+ greify proxy reify (a :*: b) =
142+ greify @_Table @_Columns @context @rep1 proxy reify a :*:
143+ greify @_Table @_Columns @context @rep2 proxy reify b
144+ gunreify proxy unreify (a :*: b) =
145+ gunreify @_Table @_Columns @context @rep1 proxy unreify a :*:
146+ gunreify @_Table @_Columns @context @rep2 proxy unreify b
112147
113148
114149instance
@@ -116,7 +151,6 @@ instance
116151 , Eval (_Table a)
117152 , HLabelable context
118153 , KnownSymbol label
119− , GColumns _Columns (M1 S meta k1) ~ HLabel label (Eval (_Columns a))
120154 , meta ~ 'MetaSel ('Just label) _su _ss _ds
121155 , k1 ~ K1 i a
122156 )
@@ -125,3 +159,5 @@ instance
125159 fromGColumns fromColumns = M1 . K1 . fromColumns . hunlabel hunlabeler
126160 toGColumns toColumns (M1 (K1 a)) = hlabel hlabeler (toColumns a)
127161 gtable table = hlabel hlabeler (table (Proxy @a))
162+ greify _ reify (M1 (K1 a)) = M1 (K1 (reify a))
163+ gunreify _ unreify (M1 (K1 a)) = M1 (K1 (unreify a))
src/Rel8/Kind/Context.hsnew file+89
@@ -0,0 +1,89 @@
1+{-# language DataKinds #-}
2+{-# language GADTs #-}
3+{-# language LambdaCase #-}
4+{-# language StandaloneKindSignatures #-}
5+
6+module Rel8.Kind.Context
7+ ( Reifiable( contextSing )
8+ , SContext(..)
9+ , sReifiable
10+ , sLabelable
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.Schema.Dict ( Dict( Dict ) )
22+import Rel8.Schema.Context ( Interpretation )
23+import Rel8.Schema.Context.Label ( Labelable )
24+import Rel8.Schema.Insert ( Insert )
25+import Rel8.Schema.Kind ( Context )
26+import Rel8.Schema.Name ( Name )
27+import Rel8.Schema.Reify ( Reify )
28+import Rel8.Schema.Result ( Result )
29+
30+
31+type SContext :: Context -> Type
32+data SContext context where
33+ SAggregate :: SContext Aggregate
34+ SExpr :: SContext Expr
35+ SInsert :: SContext Insert
36+ SName :: SContext Name
37+ SResult :: SContext Result
38+ SReify :: SContext context -> SContext (Reify context)
39+
40+
41+type Reifiable :: Context -> Constraint
42+class Interpretation context => Reifiable context where
43+ contextSing :: SContext context
44+
45+
46+instance Reifiable Aggregate where
47+ contextSing = SAggregate
48+
49+
50+instance Reifiable Expr where
51+ contextSing = SExpr
52+
53+
54+instance Reifiable Result where
55+ contextSing = SResult
56+
57+
58+instance Reifiable Insert where
59+ contextSing = SInsert
60+
61+
62+instance Reifiable Name where
63+ contextSing = SName
64+
65+
66+instance Reifiable context => Reifiable (Reify context) where
67+ contextSing = SReify contextSing
68+
69+
70+sReifiable :: SContext context -> Dict Reifiable context
71+sReifiable = \case
72+ SAggregate -> Dict
73+ SExpr -> Dict
74+ SInsert -> Dict
75+ SName -> Dict
76+ SResult -> Dict
77+ SReify context -> case sReifiable context of
78+ Dict -> Dict
79+
80+
81+sLabelable :: SContext context -> Dict Labelable context
82+sLabelable = \case
83+ SAggregate -> Dict
84+ SExpr -> Dict
85+ SInsert -> Dict
86+ SName -> Dict
87+ SResult -> Dict
88+ SReify context -> case sLabelable context of
89+ Dict -> Dict
src/Rel8/Schema/Field.hs+48−74
@@ -10,31 +10,28 @@
1010module Rel8.Schema.Field
1111 ( Field
1212 , HEither, HList, HMaybe, HNonEmpty, HThese
13− , Reify, hreify, hunreify
14− , Reifiable(..)
1513 , AField(..)
1614 , AHEither(..), AHList(..), AHMaybe(..), AHNonEmpty(..), AHThese(..)
17− , SContext(..)
1815 )
1916where
2017
2118-- base
19+import Control.Applicative ( liftA2 )
2220import Data.Bifunctor ( Bifunctor, bimap )
23−import Data.Kind ( Constraint, Type )
21+import Data.Kind ( Type )
2422import Data.List.NonEmpty ( NonEmpty )
2523import Prelude
2624
2725-- rel8
2826import Rel8.Aggregate ( Aggregate, Col(..) )
2927import Rel8.Expr ( Expr, Col(..) )
28+import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )
3029import Rel8.Kind.Necessity
3130 ( Necessity( Required, Optional )
3231 , SNecessity( SRequired, SOptional )
3332 , KnownNecessity, necessitySing
3433 )
35−import Rel8.Schema.Context ( Interpretation, Col(..) )
36−import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
37−import Rel8.Schema.HTable ( HTable, hfield, htabulate )
34+import Rel8.Schema.Context ( Col(..) )
3835import Rel8.Schema.HTable.Either ( HEitherTable )
3936import Rel8.Schema.HTable.List ( HListTable )
4037import Rel8.Schema.HTable.Maybe ( HMaybeTable )
@@ -45,11 +42,12 @@ import Rel8.Schema.Insert ( Insert, Col(..) )
4542import qualified Rel8.Schema.Kind as K
4643import Rel8.Schema.Name ( Name(..), Col(..) )
4744import Rel8.Schema.Null ( Sql )
45+import Rel8.Schema.Reify ( Reify, Col(..), hreify, hunreify )
4846import Rel8.Schema.Result ( Result )
4947import Rel8.Schema.Spec ( Spec( Spec ) )
5048import Rel8.Table
51− ( Table, Columns, Context, fromColumns, toColumns
52− , Congruent
49+ ( Table, Columns, Congruent, Context, fromColumns, toColumns
50+ , Unreify, reify, unreify
5351 )
5452import Rel8.Table.Either ( EitherTable )
5553import Rel8.Table.List ( ListTable( ListTable ) )
@@ -57,6 +55,7 @@ import Rel8.Table.Maybe ( MaybeTable )
5755import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) )
5856import Rel8.Table.Recontextualize ( Recontextualize )
5957import Rel8.Table.These ( TheseTable )
58+import Rel8.Table.Unreify ( Unreifiable )
6059import Rel8.Type ( DBType )
6160
6261-- these
@@ -133,9 +132,12 @@ instance (Reifiable context, KnownNecessity necessity, Sql DBType a) =>
133132 where
134133 type Context (AField context necessity a) = Reify context
135134 type Columns (AField context necessity a) = HIdentity ('Spec '[""] necessity a)
135+ type Unreify (AField context necessity a) = Field context necessity a
136136
137137 fromColumns (HIdentity (Reify a)) = sfromColumn contextSing a
138138 toColumns = HIdentity . Reify . stoColumn contextSing necessitySing
139+ reify _ = AField
140+ unreify _ (AField a) = a
139141
140142
141143instance
@@ -166,9 +168,12 @@ instance (Reifiable context, Table (Reify context) a, Table (Reify context) b)
166168 where
167169 type Context (AHEither context a b) = Reify context
168170 type Columns (AHEither context a b) = HEitherTable (Columns a) (Columns b)
171+ type Unreify (AHEither context a b) = HEither context (Unreify a) (Unreify b)
169172
170173 fromColumns = sfromColumnsEither contextSing
171174 toColumns = stoColumnsEither contextSing
175+ reify proof = liftA2 bimap reify reify proof . AHEither
176+ unreify proof = (\(AHEither a) -> a) . liftA2 bimap unreify unreify proof
172177
173178
174179instance
@@ -187,18 +192,30 @@ type AHList :: K.Context -> Type -> Type
187192newtype AHList context a = AHList (HList context a)
188193
189194
190−instance (Reifiable context, Table (Reify context) a) =>
191− Table (Reify context) (AHList context a)
195+instance
196+ ( Reifiable context
197+ , Table (Reify context) a
198+ , Unreifiable (Reify context) a
199+ )
200+ => Table (Reify context) (AHList context a)
192201 where
193202 type Context (AHList context a) = Reify context
194203 type Columns (AHList context a) = HListTable (Columns a)
204+ type Unreify (AHList context a) = HList context (Unreify a)
195205
196206 fromColumns = sfromColumnsList contextSing
197207 toColumns = stoColumnsList contextSing
208+ reify proof =
209+ smapList contextSing (reify proof) hreify .
210+ AHList
211+ unreify proof =
212+ (\(AHList a) -> a) .
213+ smapList contextSing (unreify proof) hunreify
198214
199215
200216instance
201217 ( Reifiable context, Reifiable context'
218+ , Unreifiable (Reify context) a, Unreifiable (Reify context') a'
202219 , Recontextualize (Reify context) (Reify context') a a'
203220 ) =>
204221 Recontextualize
@@ -221,9 +238,12 @@ instance (Reifiable context, Table (Reify context) a) =>
221238 where
222239 type Context (AHMaybe context a) = Reify context
223240 type Columns (AHMaybe context a) = HMaybeTable (Columns a)
241+ type Unreify (AHMaybe context a) = HMaybe context (Unreify a)
224242
225243 fromColumns = sfromColumnsMaybe contextSing
226244 toColumns = stoColumnsMaybe contextSing
245+ reify proof = fmap fmap reify proof . AHMaybe
246+ unreify proof = (\(AHMaybe a) -> a) . fmap fmap unreify proof
227247
228248
229249instance
@@ -241,18 +261,30 @@ type AHNonEmpty :: K.Context -> Type -> Type
241261newtype AHNonEmpty context a = AHNonEmpty (HNonEmpty context a)
242262
243263
244−instance (Reifiable context, Table (Reify context) a) =>
245− Table (Reify context) (AHNonEmpty context a)
264+instance
265+ ( Reifiable context
266+ , Table (Reify context) a
267+ , Unreifiable (Reify context) a
268+ )
269+ => Table (Reify context) (AHNonEmpty context a)
246270 where
247271 type Context (AHNonEmpty context a) = Reify context
248272 type Columns (AHNonEmpty context a) = HNonEmptyTable (Columns a)
273+ type Unreify (AHNonEmpty context a) = HNonEmpty context (Unreify a)
249274
250275 fromColumns = sfromColumnsNonEmpty contextSing
251276 toColumns = stoColumnsNonEmpty contextSing
277+ reify proof =
278+ smapNonEmpty contextSing (reify proof) hreify .
279+ AHNonEmpty
280+ unreify proof =
281+ (\(AHNonEmpty a) -> a) .
282+ smapNonEmpty contextSing (unreify proof) hunreify
252283
253284
254285instance
255286 ( Reifiable context, Reifiable context'
287+ , Unreifiable (Reify context) a, Unreifiable (Reify context') a'
256288 , Recontextualize (Reify context) (Reify context') a a'
257289 ) =>
258290 Recontextualize
@@ -279,9 +311,12 @@ instance (Reifiable context, Table (Reify context) a, Table (Reify context) b)
279311 where
280312 type Context (AHThese context a b) = Reify context
281313 type Columns (AHThese context a b) = HTheseTable (Columns a) (Columns b)
314+ type Unreify (AHThese context a b) = HThese context (Unreify a) (Unreify b)
282315
283316 fromColumns = sfromColumnsThese contextSing
284317 toColumns = stoColumnsThese contextSing
318+ reify proof = liftA2 bimap reify reify proof . AHThese
319+ unreify proof = (\(AHThese a) -> a) . liftA2 bimap unreify unreify proof
285320
286321
287322instance
@@ -296,58 +331,6 @@ instance
296331 (AHThese context' a' b')
297332
298333
299−type SContext :: K.Context -> Type
300−data SContext context where
301− SAggregate :: SContext Aggregate
302− SExpr :: SContext Expr
303− SInsert :: SContext Insert
304− SName :: SContext Name
305− SResult :: SContext Result
306− SReify :: SContext context -> SContext (Reify context)
307−
308−
309−type Reifiable :: K.Context -> Constraint
310−class Interpretation context => Reifiable context where
311− contextSing :: SContext context
312−
313−
314−instance Reifiable Aggregate where
315− contextSing = SAggregate
316−
317−
318−instance Reifiable Expr where
319− contextSing = SExpr
320−
321−
322−instance Reifiable Result where
323− contextSing = SResult
324−
325−
326−instance Reifiable Insert where
327− contextSing = SInsert
328−
329−
330−instance Reifiable Name where
331− contextSing = SName
332−
333−
334−type Reify :: K.Context -> K.Context
335−data Reify context a
336−
337−
338−instance Interpretation (Reify context) where
339− newtype Col (Reify context) spec = Reify (Col context spec)
340−
341−
342−instance Labelable context => Labelable (Reify context) where
343− labeler (Reify a) = Reify (labeler a)
344− unlabeler (Reify a) = Reify (unlabeler a)
345−
346−
347−instance Reifiable context => Reifiable (Reify context) where
348− contextSing = SReify contextSing
349−
350−
351334sfromColumn :: ()
352335 => SContext context
353336 -> Col context ('Spec labels necessity a)
@@ -710,12 +693,3 @@ stoColumnsThese = \case
710693 stoColumnsThese context .
711694 sbimapThese context (hunreify . toColumns) (hunreify . toColumns) .
712695 (\(AHThese a) -> a)
713−
714−
715−hreify :: HTable t => t (Col context) -> t (Col (Reify context))
716−hreify a = htabulate $ \field -> Reify (hfield a field)
717−
718−
719−hunreify :: HTable t => t (Col (Reify context)) -> t (Col context)
720−hunreify a = htabulate $ \field -> case hfield a field of
721− Reify x -> x
src/Rel8/Schema/Generic.hs+62−24
@@ -19,38 +19,56 @@ where
1919
2020-- base
2121import Data.Kind ( Constraint, Type )
22+import Data.Proxy ( Proxy( Proxy ) )
23+import Data.Type.Equality ( (:~:)( Refl ) )
2224import GHC.Generics ( Generic, Rep, from, to )
2325import Prelude
24−import Unsafe.Coerce ( unsafeCoerce )
2526
2627-- rel8
28+import Rel8.Kind.Context
29+ ( SContext( SReify )
30+ , Reifiable, contextSing
31+ , sLabelable, sReifiable
32+ )
2733import Rel8.Generic.Record ( Record(..) )
2834import Rel8.Generic.Table
2935 ( GTable, GColumns, fromGColumns, toGColumns
36+ , GUnreify
3037 )
38+import qualified Rel8.Generic.Table as G
3139import Rel8.Schema.Context ( Col )
3240import Rel8.Schema.Context.Label ( Labelable )
33−import Rel8.Schema.Field ( Reify, Reifiable, hreify, hunreify )
41+import Rel8.Schema.Dict ( Dict( Dict ) )
3442import Rel8.Schema.HTable ( HTable )
3543import qualified Rel8.Schema.Kind as K
3644import Rel8.Schema.Name ( Name )
45+import Rel8.Schema.Reify ( Reify, UnwrapReify, hreify, hunreify )
3746import Rel8.Table
3847 ( Table, Columns, Context, fromColumns, toColumns
39− , TTable, TColumns
48+ , Unreify, reify, unreify
49+ , TTable, TColumns, TUnreify
4050 )
4151
4252
43−instance
44− ( Rel8able t
45− , Labelable context
46− , Reifiable context
47− ) => Table context (t context)
53+instance (Rel8able t, Labelable context, Reifiable context) =>
54+ Table context (t context)
4855 where
4956 type Columns (t context) = GRep t
5057 type Context (t context) = context
58+ type Unreify (t context) = t (UnwrapReify context)
59+
60+ fromColumns = gunreify . gfromColumns . hreify
61+ toColumns = hunreify . gtoColumns . greify
62+
63+ reify Refl = case contextSing @context of
64+ SReify context -> case sLabelable context of
65+ Dict -> case sReifiable context of
66+ Dict -> greify
5167
52− fromColumns = unreify . gfromColumns . hreify
53− toColumns = hunreify . gtoColumns . reify
68+ unreify Refl = case contextSing @context of
69+ SReify context -> case sLabelable context of
70+ Dict -> case sReifiable context of
71+ Dict -> gunreify
5472
5573
5674type KRel8able :: Type
@@ -109,6 +127,12 @@ class HTable (GRep t) => Rel8able t where
109127 gtoColumns :: (Labelable context, Reifiable context)
110128 => t (Reify context) -> GRep t (Col (Reify context))
111129
130+ greify :: (Labelable context, Reifiable context)
131+ => t context -> t (Reify context)
132+
133+ gunreify :: (Labelable context, Reifiable context)
134+ => t (Reify context) -> t context
135+
112136 type GRep t = GColumns TColumns (Rep (Record (t (Reify Name))))
113137
114138 default gfromColumns :: forall context.
@@ -133,18 +157,32 @@ class HTable (GRep t) => Rel8able t where
133157 from .
134158 Record
135159
160+ default greify :: forall context.
161+ ( Generic (Record (t context))
162+ , Generic (Record (t (Reify context)))
163+ , GTable (TTable (Reify context)) TColumns (Col (Reify context)) (Rep (Record (t (Reify context))))
164+ , Rep (Record (t context)) ~ GUnreify TUnreify (Rep (Record (t (Reify context))))
165+ )
166+ => t context -> t (Reify context)
167+ greify =
168+ unrecord .
169+ to .
170+ G.greify @(TTable (Reify context)) @TColumns @(Col (Reify context)) (Proxy @TUnreify)
171+ (reify Refl) .
172+ from .
173+ Record
136174
137−reify ::
138− (-- Rel8able t
139− --, forall necessity a. Coercible (Field context necessity a) (AField context necessity a) => Coercible (t context) (t (Reify context))
140− )
141− => t context -> t (Reify context)
142−reify = unsafeCoerce
143−
144−
145−unreify ::
146− (-- Rel8able t
147− --, forall necessity a. Coercible (AField context necessity a) (Field context necessity a) => Coercible (t (Reify context)) (t context)
148− )
149− => t (Reify context) -> t context
150−unreify = unsafeCoerce
175+ default gunreify :: forall context.
176+ ( Generic (Record (t context))
177+ , Generic (Record (t (Reify context)))
178+ , GTable (TTable (Reify context)) TColumns (Col (Reify context)) (Rep (Record (t (Reify context))))
179+ , Rep (Record (t context)) ~ GUnreify TUnreify (Rep (Record (t (Reify context))))
180+ )
181+ => t (Reify context) -> t context
182+ gunreify =
183+ unrecord .
184+ to .
185+ G.gunreify @(TTable (Reify context)) @TColumns @(Col (Reify context)) (Proxy @TUnreify)
186+ (unreify Refl) .
187+ from .
188+ Record
src/Rel8/Schema/Generic/Test.hs+6−3
@@ -8,6 +8,8 @@
88{-# language StandaloneDeriving #-}
99{-# language TypeFamilies #-}
1010
11+{-# options_ghc -O0 #-}
12+
1113module Rel8.Schema.Generic.Test
1214 ( module Rel8.Schema.Generic.Test
1315 )
@@ -77,7 +79,7 @@ data TableList f = TableList
7779
7880data TableNonEmpty f = TableNonEmpty
7981 { foo :: Column f Bool
80− , bars :: HNonEmpty f (TableList f, Default f Char)
82+ , bars :: HNonEmpty f (TableList f, TableMaybe f)
8183 }
8284 deriving stock Generic
8385 deriving anyclass Rel8able
@@ -86,14 +88,15 @@ data TableNonEmpty f = TableNonEmpty
8688data S3Object = S3Object
8789 { bucketName :: Text
8890 , objectKey :: Text
89− } deriving stock Generic
91+ }
92+ deriving stock Generic
9093
9194
9295deriving via HKDT S3Object
9396 instance x ~ HKD S3Object Expr => ToExprs x S3Object
9497
9598
96−data HKDTest f = HKDTest
99+newtype HKDTest f = HKDTest
97100 { s3Object :: Lift f S3Object
98101 }
99102 deriving stock Generic
src/Rel8/Schema/HKD.hs+20−5
@@ -37,17 +37,17 @@ import GHC.TypeLits ( KnownSymbol )
3737import Prelude
3838
3939-- higgledy
40−import Data.Generic.HKD ( Construct, HKD( HKD, runHKD ), GHKD_, construct, deconstruct )
40+import Data.Generic.HKD ( Construct, HKD(..), GHKD_, construct, deconstruct )
4141
4242-- rel8
4343import Rel8.Aggregate ( Col(..), Aggregate )
4444import Rel8.Expr ( Expr )
45+import Rel8.Kind.Context ( Reifiable(..), SContext(..) )
4546import Rel8.Schema.Context.Label
4647 ( Labelable
4748 , HLabelable, hlabeler, hunlabeler
4849 )
4950import Rel8.Schema.Dict ( Dict( Dict ) )
50−import Rel8.Schema.Field ( Reify, Reifiable(..), SContext(..), hunreify, hreify )
5151import Rel8.Schema.HTable ( HTable )
5252import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
5353import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )
@@ -56,8 +56,12 @@ import Rel8.Schema.Insert ( Insert, Col(..) )
5656import qualified Rel8.Schema.Kind as K
5757import Rel8.Schema.Name ( Name(..) )
5858import Rel8.Schema.Null ( Sql )
59+import Rel8.Schema.Reify ( Reify, hreify, hunreify, NotReify, notReify )
5960import Rel8.Schema.Result ( Result )
60−import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
61+import Rel8.Table
62+ ( Table, Columns, Context, fromColumns, toColumns
63+ , Unreify, reify, unreify
64+ )
6165import Rel8.Table.Recontextualize ( Recontextualize )
6266import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
6367import Rel8.Type ( DBType )
@@ -178,19 +182,27 @@ type family GColumns rep where
178182 GColumns (f :*: g) = HProduct (GColumns f) (GColumns g)
179183
180184
181−instance (GTable (Rep a), Column1 context f, Labelable context) =>
182− Table context (HKD a f)
185+instance
186+ ( GTable (Rep a)
187+ , Column1 context f
188+ , Labelable context
189+ , NotReify context
190+ )
191+ => Table context (HKD a f)
183192 where
184193 type Columns (HKD a f) = GRep a
185194 type Context (HKD a f) = Context1 f
186195
187196 toColumns = toGColumns toColumn1 . runHKD
188197 fromColumns = HKD . fromGColumns fromColumn1
198+ reify = notReify
199+ unreify = notReify
189200
190201
191202instance
192203 ( a ~ a'
193204 , GTable (Rep a)
205+ , NotReify context, NotReify context'
194206 , Recontextualize1 context context' f f'
195207 , Column1 context f, Labelable context
196208 , Column1 context' f', Labelable context'
@@ -227,9 +239,12 @@ instance
227239 where
228240 type Context (ALift context a) = Reify context
229241 type Columns (ALift context a) = GRep a
242+ type Unreify (ALift context a) = Lift context a
230243
231244 fromColumns = sfromColumnsLift contextSing
232245 toColumns = stoColumnsLift contextSing
246+ reify _ = ALift
247+ unreify _ (ALift a) = a
233248
234249
235250instance
src/Rel8/Schema/HTable/Nullify.hs+5−5
@@ -1,13 +1,13 @@
1−{-# LANGUAGE DeriveAnyClass #-}
2−{-# LANGUAGE DerivingStrategies #-}
3−{-# LANGUAGE DeriveGeneric #-}
4−{-# LANGUAGE NamedFieldPuns #-}
5−{-# LANGUAGE LambdaCase #-}
61{-# language ConstraintKinds #-}
72{-# language DataKinds #-}
3+{-# language DeriveAnyClass #-}
4+{-# language DerivingStrategies #-}
5+{-# language DeriveGeneric #-}
86{-# language FlexibleInstances #-}
97{-# language GADTs #-}
8+{-# language LambdaCase #-}
109{-# language MultiParamTypeClasses #-}
10+{-# language NamedFieldPuns #-}
1111{-# language QuantifiedConstraints #-}
1212{-# language RankNTypes #-}
1313{-# language ScopedTypeVariables #-}
src/Rel8/Schema/Insert.hs+7−1
@@ -39,11 +39,15 @@ import Rel8.Schema.Context.Nullify
3939import Rel8.Schema.HTable.Type ( HType( HType ) )
4040import Rel8.Schema.Name ( Name, Selects )
4141import Rel8.Schema.Null ( Sql )
42+import Rel8.Schema.Reify ( notReify )
4243import Rel8.Schema.Result ( Result )
4344import Rel8.Schema.Spec ( SSpec(SSpec, nullity), Spec(Spec) )
4445import Rel8.Schema.Table ( TableSchema )
4546import Rel8.Statement.Returning ( Returning )
46−import Rel8.Table ( Table(..) )
47+import Rel8.Table
48+ ( Table, Context, Columns, fromColumns, toColumns
49+ , reify, unreify
50+ )
4751import Rel8.Table.Recontextualize ( Recontextualize )
4852import Rel8.Table.Tag ( Tag(..), fromExpr )
4953import Rel8.Type ( DBType )
@@ -89,6 +93,8 @@ instance Sql DBType a => Table Insert (Insertion a) where
8993
9094 toColumns (Insertion a) = HType (RequiredInsert a)
9195 fromColumns (HType (RequiredInsert a)) = Insertion a
96+ reify = notReify
97+ unreify = notReify
9298
9399
94100instance Sql DBType a =>
src/Rel8/Schema/Name.hs+6−1
@@ -31,8 +31,11 @@ import Rel8.Schema.Context ( Interpretation, Col )
3131import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
3232import Rel8.Schema.HTable.Type ( HType( HType ) )
3333import Rel8.Schema.Null ( Sql )
34+import Rel8.Schema.Reify ( notReify )
3435import Rel8.Schema.Result ( Result )
35−import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
36+import Rel8.Table
37+ ( Table, Columns, Context, fromColumns, toColumns, reify, unreify
38+ )
3639import Rel8.Table.Recontextualize ( Recontextualize )
3740import Rel8.Type ( DBType )
3841
@@ -59,6 +62,8 @@ instance Sql DBType a => Table Name (Name a) where
5962
6063 toColumns (Name a) = HType (NameCol a)
6164 fromColumns (HType (NameCol a)) = Name a
65+ reify = notReify
66+ unreify = notReify
6267
6368
6469instance Sql DBType a => Recontextualize Expr Name (Expr a) (Name a)
src/Rel8/Schema/Reify.hsnew file+75
@@ -0,0 +1,75 @@
1+{-# language AllowAmbiguousTypes #-}
2+{-# language EmptyCase #-}
3+{-# language DataKinds #-}
4+{-# language FlexibleInstances #-}
5+{-# language ScopedTypeVariables #-}
6+{-# language StandaloneKindSignatures #-}
7+{-# language TypeApplications #-}
8+{-# language TypeFamilies #-}
9+{-# language TypeOperators #-}
10+{-# language UndecidableInstances #-}
11+
12+module Rel8.Schema.Reify
13+ ( Reify, Col( Reify ), hreify, hunreify
14+ , UnwrapReify
15+ , NotReify, notReify
16+ )
17+where
18+
19+-- base
20+import Data.Kind ( Constraint )
21+import Data.Type.Equality ( (:~:)( Refl ) )
22+import Prelude
23+
24+-- rel8
25+import Rel8.Schema.Context ( Interpretation, Col )
26+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
27+import Rel8.Schema.HTable ( HTable, hfield, htabulate )
28+import Rel8.Schema.Kind ( Context )
29+
30+
31+type Reify :: Context -> Context
32+data Reify context a
33+
34+
35+instance Interpretation (Reify context) where
36+ newtype Col (Reify context) spec = Reify (Col context spec)
37+
38+
39+instance Labelable context => Labelable (Reify context) where
40+ labeler (Reify a) = Reify (labeler a)
41+ unlabeler (Reify a) = Reify (unlabeler a)
42+
43+
44+hreify :: HTable t => t (Col context) -> t (Col (Reify context))
45+hreify a = htabulate $ \field -> Reify (hfield a field)
46+
47+
48+hunreify :: HTable t => t (Col (Reify context)) -> t (Col context)
49+hunreify a = htabulate $ \field -> case hfield a field of
50+ Reify x -> x
51+
52+
53+type UnwrapReify :: Context -> Context
54+type family UnwrapReify context where
55+ UnwrapReify (Reify context) = context
56+
57+
58+type IsReify :: Context -> Bool
59+type family IsReify context where
60+ IsReify (Reify _) = 'True
61+ IsReify _ = 'False
62+
63+
64+type NotReify :: Context -> Constraint
65+class IsReify context ~ 'False => NotReify context
66+instance IsReify context ~ 'False => NotReify context
67+
68+
69+notReify :: forall context ctx a. NotReify context => context :~: Reify ctx -> a
70+notReify refl = case lemma @context of
71+ Refl -> case refl of
72+
73+
74+lemma :: NotReify context => IsReify context :~: 'False
75+lemma = Refl
src/Rel8/Table.hs+99−9
@@ -1,3 +1,4 @@
1+{-# language AllowAmbiguousTypes #-}
12{-# language DataKinds #-}
23{-# language DefaultSignatures #-}
34{-# language DisambiguateRecordFields #-}
@@ -14,9 +15,9 @@
1415{-# language UndecidableInstances #-}
1516
1617module Rel8.Table
17− ( Table (Columns, Context, toColumns, fromColumns)
18+ ( Table (Columns, Context, Unreify, toColumns, fromColumns, reify, unreify)
1819 , Congruent
19− , TTable, TColumns, TContext
20+ , TTable, TColumns, TContext, TUnreify
2021 )
2122where
2223
@@ -25,13 +26,16 @@ import Data.Functor ( ($>) )
2526import Data.Functor.Identity ( Identity( Identity ) )
2627import Data.Kind ( Constraint, Type )
2728import Data.List.NonEmpty ( NonEmpty )
29+import Data.Proxy ( Proxy( Proxy ) )
30+import Data.Type.Equality ( (:~:)( Refl ) )
2831import GHC.Generics ( Generic, Rep, from, to )
2932import Prelude hiding ( null )
3033
3134-- rel8
3235import Rel8.FCF ( Eval, Exp )
3336import Rel8.Generic.Table
34− ( GTable, GColumns, GContext, fromGColumns, toGColumns
37+ ( GTable, GColumns, GContext, GUnreify
38+ , fromGColumns, toGColumns, greify, gunreify
3539 )
3640import Rel8.Generic.Record ( Record(..) )
3741import Rel8.Schema.Context ( Col(..) )
@@ -49,6 +53,11 @@ import Rel8.Schema.HTable.Type ( HType( HType ) )
4953import Rel8.Schema.HTable.Vectorize ( hvectorize, hunvectorize )
5054import qualified Rel8.Schema.Kind as K
5155import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql )
56+import Rel8.Schema.Reify
57+ ( Reify, Col( Reify ), hreify, hunreify
58+ , UnwrapReify
59+ , notReify
60+ )
5261import Rel8.Schema.Result ( Result )
5362import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..), KnownSpec )
5463import Rel8.Type ( DBType )
@@ -78,18 +87,24 @@ class (HTable (Columns a), context ~ Context a) => Table context a | a -> contex
7887 -- | The common context that all columns use as an interpretation.
7988 type Context a :: K.Context
8089
81− toColumns :: a -> Columns a (Col (Context a))
82− fromColumns :: Columns a (Col (Context a)) -> a
90+ type Unreify a :: Type
91+
92+ toColumns :: a -> Columns a (Col context)
93+ fromColumns :: Columns a (Col context) -> a
94+
95+ reify :: context :~: Reify ctx -> Unreify a -> a
96+ unreify :: context :~: Reify ctx -> a -> Unreify a
8397
8498 type Columns a = GColumns TColumns (Rep (Record a))
8599 type Context a = GContext TContext (Rep (Record a))
100+ type Unreify a = DefaultUnreify a
86101
87102 default toColumns ::
88103 ( Generic (Record a)
89− , GTable (TTable context) TColumns (Col (Context a)) (Rep (Record a))
104+ , GTable (TTable context) TColumns (Col context) (Rep (Record a))
90105 , Columns a ~ GColumns TColumns (Rep (Record a))
91106 )
92− => a -> Columns a (Col (Context a))
107+ => a -> Columns a (Col context)
93108 toColumns =
94109 toGColumns @(TTable context) @TColumns toColumns .
95110 from .
@@ -97,15 +112,45 @@ class (HTable (Columns a), context ~ Context a) => Table context a | a -> contex
97112
98113 default fromColumns ::
99114 ( Generic (Record a)
100− , GTable (TTable context) TColumns (Col (Context a)) (Rep (Record a))
115+ , GTable (TTable context) TColumns (Col context) (Rep (Record a))
101116 , Columns a ~ GColumns TColumns (Rep (Record a))
102117 )
103− => Columns a (Col (Context a)) -> a
118+ => Columns a (Col context) -> a
104119 fromColumns =
105120 unrecord .
106121 to .
107122 fromGColumns @(TTable context) @TColumns fromColumns
108123
124+ default reify ::
125+ ( Generic (Record a)
126+ , Generic (Record (Unreify a))
127+ , GTable (TTable context) TColumns (Col context) (Rep (Record a))
128+ , Rep (Record (Unreify a)) ~ GUnreify TUnreify (Rep (Record a))
129+ )
130+ => context :~: Reify ctx -> Unreify a -> a
131+ reify Refl =
132+ unrecord .
133+ to .
134+ greify @(TTable context) @TColumns @(Col context) (Proxy @TUnreify)
135+ (reify Refl) .
136+ from .
137+ Record
138+
139+ default unreify ::
140+ ( Generic (Record a)
141+ , Generic (Record (Unreify a))
142+ , GTable (TTable context) TColumns (Col context) (Rep (Record a))
143+ , Rep (Record (Unreify a)) ~ GUnreify TUnreify (Rep (Record a))
144+ )
145+ => context :~: Reify ctx -> a -> Unreify a
146+ unreify Refl =
147+ unrecord .
148+ to .
149+ gunreify @(TTable context) @TColumns @(Col context) (Proxy @TUnreify)
150+ (unreify Refl) .
151+ from .
152+ Record
153+
109154
110155data TTable :: K.Context -> Type -> Exp Constraint
111156type instance Eval (TTable context a) = Table context a
@@ -119,23 +164,50 @@ data TContext :: Type -> Exp K.Context
119164type instance Eval (TContext a) = Context a
120165
121166
167+data TUnreify :: Type -> Exp Type
168+type instance Eval (TUnreify a) = Unreify a
169+
170+
171+type DefaultUnreify :: Type -> Type
172+type family DefaultUnreify a where
173+ DefaultUnreify (t a b c d e f g) =
174+ t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e) (Unreify f) (Unreify g)
175+ DefaultUnreify (t a b c d e f) =
176+ t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e) (Unreify f)
177+ DefaultUnreify (t a b c d e) =
178+ t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e)
179+ DefaultUnreify (t a b c d) =
180+ t (Unreify a) (Unreify b) (Unreify c) (Unreify d)
181+ DefaultUnreify (t a b c) = t (Unreify a) (Unreify b) (Unreify c)
182+ DefaultUnreify (t a b) = t (Unreify a) (Unreify b)
183+ DefaultUnreify (t a) = t (Unreify a)
184+
185+
122186-- | Any 'HTable' is also a 'Table'.
123187instance HTable t => Table context (t (Col context)) where
124188 type Columns (t (Col context)) = t
125189 type Context (t (Col context)) = context
190+ type Unreify (t (Col context)) = t (Col (UnwrapReify context))
126191
127192 toColumns = id
128193 fromColumns = id
129194
195+ reify Refl = hreify
196+ unreify Refl = hunreify
197+
130198
131199-- | Any context is trivially a table.
132200instance KnownSpec spec => Table context (Col context spec) where
133201 type Columns (Col context spec) = HIdentity spec
134202 type Context (Col context spec) = context
203+ type Unreify (Col context spec) = Col (UnwrapReify context) spec
135204
136205 toColumns = HIdentity
137206 fromColumns = unHIdentity
138207
208+ reify Refl = Reify
209+ unreify Refl (Reify a) = a
210+
139211
140212instance Sql DBType a => Table Result (Identity a) where
141213 type Columns (Identity a) = HType a
@@ -144,6 +216,9 @@ instance Sql DBType a => Table Result (Identity a) where
144216 toColumns (Identity a) = HType (Result a)
145217 fromColumns (HType (Result a)) = Identity a
146218
219+ reify = notReify
220+ unreify = notReify
221+
147222
148223instance (Table Result a, Table Result b) => Table Result (Either a b) where
149224 type Columns (Either a b) = HEitherTable (Columns a) (Columns b)
@@ -168,6 +243,9 @@ instance (Table Result a, Table Result b) => Table Result (Either a b) where
168243 where
169244 err = error "Either.fromColumns: mismatch between tag and data"
170245
246+ reify = notReify
247+ unreify = notReify
248+
171249
172250instance Table Result a => Table Result [a] where
173251 type Columns [a] = HListTable (Columns a)
@@ -176,6 +254,9 @@ instance Table Result a => Table Result [a] where
176254 toColumns = hvectorize vectorizer . fmap toColumns
177255 fromColumns = fmap fromColumns . hunvectorize unvectorizer
178256
257+ reify = notReify
258+ unreify = notReify
259+
179260
180261instance Table Result a => Table Result (Maybe a) where
181262 type Columns (Maybe a) = HMaybeTable (Columns a)
@@ -197,6 +278,9 @@ instance Table Result a => Table Result (Maybe a) where
197278 Nothing -> error "Maybe.fromColumns: mismatch between tag and data"
198279 Just just -> fromColumns just
199280
281+ reify = notReify
282+ unreify = notReify
283+
200284
201285instance Table Result a => Table Result (NonEmpty a) where
202286 type Columns (NonEmpty a) = HNonEmptyTable (Columns a)
@@ -205,6 +289,9 @@ instance Table Result a => Table Result (NonEmpty a) where
205289 toColumns = hvectorize vectorizer . fmap toColumns
206290 fromColumns = fmap fromColumns . hunvectorize unvectorizer
207291
292+ reify = notReify
293+ unreify = notReify
294+
208295
209296instance (Table Result a, Table Result b) => Table Result (These a b) where
210297 type Columns (These a b) = HTheseTable (Columns a) (Columns b)
@@ -242,6 +329,9 @@ instance (Table Result a, Table Result b) => Table Result (These a b) where
242329 , hjust = hlabel labeler (hunlabel unlabeler hthere)
243330 }
244331
332+ reify = notReify
333+ unreify = notReify
334+
245335
246336instance (Table context a, Table context b, Labelable context)
247337 => Table context (a, b)
src/Rel8/Table/Either.hs+7−1
@@ -20,6 +20,7 @@ module Rel8.Table.Either
2020where
2121
2222-- base
23+import Control.Applicative ( liftA2 )
2324import Data.Bifunctor ( Bifunctor, bimap )
2425import Data.Functor.Identity ( runIdentity )
2526import Data.Kind ( Type )
@@ -46,7 +47,10 @@ import Rel8.Schema.HTable.Identity ( HIdentity(..) )
4647import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
4748import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
4849import Rel8.Schema.Name ( Name )
49−import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
50+import Rel8.Table
51+ ( Table, Columns, Context, fromColumns, toColumns
52+ , reify, unreify
53+ )
5054import Rel8.Table.Bool ( bool )
5155import Rel8.Table.Eq ( EqTable, eqTable )
5256import Rel8.Table.Ord ( OrdTable, ordTable )
@@ -108,6 +112,8 @@ instance
108112
109113 toColumns = toColumns2 toColumns toColumns
110114 fromColumns = fromColumns2 fromColumns fromColumns
115+ reify = liftA2 bimap reify reify
116+ unreify = liftA2 bimap unreify unreify
111117
112118
113119instance
src/Rel8/Table/List.hs+18−4
@@ -17,6 +17,7 @@ where
1717-- base
1818import Data.Functor.Identity ( Identity( Identity ) )
1919import Data.Kind ( Type )
20+import Data.Type.Equality ( (:~:)( Refl ) )
2021import Prelude
2122
2223-- rel8
@@ -28,7 +29,11 @@ import Rel8.Schema.HTable.Vectorize ( happend, hempty, hvectorize )
2829import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
2930import Rel8.Schema.Spec ( SSpec(..) )
3031import Rel8.Schema.Spec.ConstrainDBType ( dbTypeDict, dbTypeNullity )
31−import Rel8.Table ( Table, Context, Columns, fromColumns, toColumns )
32+import Rel8.Schema.Reify ( hreify, hunreify )
33+import Rel8.Table
34+ ( Table, Context, Columns, fromColumns, toColumns
35+ , reify, unreify
36+ )
3237import Rel8.Table.Alternative
3338 ( AltTable, (<|>:)
3439 , AlternativeTable, emptyTable
@@ -36,6 +41,7 @@ import Rel8.Table.Alternative
3641import Rel8.Table.Eq ( EqTable, eqTable )
3742import Rel8.Table.Ord ( OrdTable, ordTable )
3843import Rel8.Table.Recontextualize ( Recontextualize )
44+import Rel8.Table.Unreify ( Unreifiable )
3945
4046
4147-- | A @ListTable@ value contains zero or more instances of @a@. You construct
@@ -44,16 +50,24 @@ type ListTable :: Type -> Type
4450newtype ListTable a = ListTable (HListTable (Columns a) (Col (Context a)))
4551
4652
47−instance Table context a => Table context (ListTable a) where
53+instance (Table context a, Unreifiable context a) =>
54+ Table context (ListTable a)
55+ where
4856 type Columns (ListTable a) = HListTable (Columns a)
4957 type Context (ListTable a) = Context a
5058
5159 fromColumns = ListTable
5260 toColumns (ListTable a) = a
5361
62+ reify Refl (ListTable a) = ListTable (hreify a)
63+ unreify Refl (ListTable a) = ListTable (hunreify a)
64+
5465
55−instance Recontextualize from to a b =>
56− Recontextualize from to (ListTable a) (ListTable b)
66+instance
67+ ( Unreifiable from a, Unreifiable to b
68+ , Recontextualize from to a b
69+ )
70+ => Recontextualize from to (ListTable a) (ListTable b)
5771
5872
5973instance EqTable a => EqTable (ListTable a) where
src/Rel8/Table/Maybe.hs+8−2
@@ -48,7 +48,10 @@ import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
4848import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
4949import Rel8.Schema.Name ( Name )
5050import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql, nullable )
51−import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
51+import Rel8.Table
52+ ( Table, Columns, Context, fromColumns, toColumns
53+ , reify, unreify
54+ )
5255import Rel8.Table.Alternative
5356 ( AltTable, (<|>:)
5457 , AlternativeTable, emptyTable
@@ -139,13 +142,16 @@ instance
139142
140143 toColumns = toColumns1 toColumns
141144 fromColumns = fromColumns1 fromColumns
145+ reify = fmap fmap reify
146+ unreify = fmap fmap unreify
142147
143148
144149instance
145150 ( Labelable from, Nullifiable from, ConstrainTag from MaybeTag
146151 , Labelable to, Nullifiable to, ConstrainTag to MaybeTag
147152 , Recontextualize from to a b
148− ) => Recontextualize from to (MaybeTable a) (MaybeTable b)
153+ )
154+ => Recontextualize from to (MaybeTable a) (MaybeTable b)
149155
150156
151157instance EqTable a => EqTable (MaybeTable a) where
src/Rel8/Table/NonEmpty.hs+20−4
@@ -1,7 +1,9 @@
1+{-# language DataKinds #-}
12{-# language FlexibleContexts #-}
23{-# language FlexibleInstances #-}
34{-# language MultiParamTypeClasses #-}
45{-# language NamedFieldPuns #-}
6+{-# language QuantifiedConstraints #-}
57{-# language ScopedTypeVariables #-}
68{-# language StandaloneKindSignatures #-}
79{-# language TypeApplications #-}
@@ -19,6 +21,7 @@ where
1921import Data.Functor.Identity ( Identity( Identity ) )
2022import Data.Kind ( Type )
2123import Data.List.NonEmpty ( NonEmpty )
24+import Data.Type.Equality ( (:~:)( Refl ) )
2225import Prelude
2326
2427-- rel8
@@ -28,13 +31,18 @@ import Rel8.Schema.Dict ( Dict( Dict ) )
2831import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
2932import Rel8.Schema.HTable.Vectorize ( happend, hvectorize )
3033import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
34+import Rel8.Schema.Reify ( hreify, hunreify )
3135import Rel8.Schema.Spec ( SSpec(..) )
3236import Rel8.Schema.Spec.ConstrainDBType ( dbTypeDict, dbTypeNullity )
33−import Rel8.Table ( Table, Context, Columns, fromColumns, toColumns )
37+import Rel8.Table
38+ ( Table, Context, Columns, fromColumns, toColumns
39+ , reify, unreify
40+ )
3441import Rel8.Table.Alternative ( AltTable, (<|>:) )
3542import Rel8.Table.Eq ( EqTable, eqTable )
3643import Rel8.Table.Ord ( OrdTable, ordTable )
3744import Rel8.Table.Recontextualize ( Recontextualize )
45+import Rel8.Table.Unreify ( Unreifiable )
3846
3947
4048-- | A @NonEmptyTable@ value contains one or more instances of @a@. You
@@ -44,16 +52,24 @@ newtype NonEmptyTable a =
4452 NonEmptyTable (HNonEmptyTable (Columns a) (Col (Context a)))
4553
4654
47−instance Table context a => Table context (NonEmptyTable a) where
55+instance (Table context a, Unreifiable context a) =>
56+ Table context (NonEmptyTable a)
57+ where
4858 type Columns (NonEmptyTable a) = HNonEmptyTable (Columns a)
4959 type Context (NonEmptyTable a) = Context a
5060
5161 fromColumns = NonEmptyTable
5262 toColumns (NonEmptyTable a) = a
5363
64+ reify Refl (NonEmptyTable a) = NonEmptyTable (hreify a)
65+ unreify Refl (NonEmptyTable a) = NonEmptyTable (hunreify a)
66+
5467
55−instance Recontextualize from to a b =>
56− Recontextualize from to (NonEmptyTable a) (NonEmptyTable b)
68+instance
69+ ( Unreifiable from a, Unreifiable to b
70+ , Recontextualize from to a b
71+ )
72+ => Recontextualize from to (NonEmptyTable a) (NonEmptyTable b)
5773
5874
5975instance EqTable a => EqTable (NonEmptyTable a) where
src/Rel8/Table/These.hs+8−2
@@ -24,6 +24,7 @@ module Rel8.Table.These
2424where
2525
2626-- base
27+import Control.Applicative ( liftA2 )
2728import Data.Bifunctor ( Bifunctor, bimap )
2829import Data.Functor.Identity ( runIdentity )
2930import Data.Kind ( Type )
@@ -49,8 +50,11 @@ import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
4950import Rel8.Schema.HTable.Identity ( HIdentity(..) )
5051import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
5152import Rel8.Schema.HTable.These ( HTheseTable(..) )
52−import Rel8.Schema.Name ( Name )
53−import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
53+import Rel8.Schema.Name ( Name )
54+import Rel8.Table
55+ ( Table, Columns, Context, fromColumns, toColumns
56+ , reify, unreify
57+ )
5458import Rel8.Table.Eq ( EqTable, eqTable )
5559import Rel8.Table.Maybe
5660 ( MaybeTable(..)
@@ -128,6 +132,8 @@ instance
128132
129133 toColumns = toColumns2 toColumns toColumns
130134 fromColumns = fromColumns2 fromColumns fromColumns
135+ reify = liftA2 bimap reify reify
136+ unreify = liftA2 bimap unreify unreify
131137
132138
133139instance
src/Rel8/Table/Unreify.hsnew file+43
@@ -0,0 +1,43 @@
1+{-# language DataKinds #-}
2+{-# language StandaloneKindSignatures #-}
3+{-# language TypeFamilies #-}
4+{-# language UndecidableInstances #-}
5+
6+-- | This module implements some machinery for implementing methods of the
7+-- 'Table' class for a particular special (but important) class of polymorphic
8+-- @Table@ types.
9+--
10+-- This special case is characterised by a @newtype@ wrapper around a bare
11+-- 'HTable' which is constructed by applying a type family to the polymorphic
12+-- type variable.
13+--
14+-- Examples of this class of @Table@ include @ListTable@ and @NonEmptyTable@.
15+--
16+-- The tricky part about implementing @Table@ for these types is 'reify' and
17+-- 'unreify'. There is no guarantee in general that @'Unreify' a@ is itself
18+-- a @Table@, let alone a @Table@ with the same 'Columns' as @a@
19+-- (e.g., @Unreify (AColumn Result Bool) = Bool@, and @Bool@ is not a
20+-- @Table@)
21+
22+module Rel8.Table.Unreify
23+ ( Unreifiable
24+ )
25+where
26+
27+-- base
28+import Data.Kind ( Constraint, Type )
29+import Prelude ()
30+
31+-- rel8
32+import qualified Rel8.Schema.Kind as K
33+import Rel8.Schema.Reify ( Reify )
34+import Rel8.Table ( Table, Columns, Unreify )
35+
36+
37+type Unreifiable :: K.Context -> Type -> Constraint
38+type family Unreifiable context a where
39+ Unreifiable (Reify context) a =
40+ ( Table context (Unreify a)
41+ , Columns a ~ Columns (Unreify a)
42+ )
43+ Unreifiable _ _ = ()