git.iko.soy/rel8
on master help sign in
Complete overhaul of Rel8.Schema.Generic
commit5e4df5096ccc6f0bd76c87eff88df91f6075864f authorShane O'Brien <shane.obrien@circuithub.com> dateTue 13 Apr 2021, 19:54 (6 years ago) parent09e449b
23 files changed+1191−1628
compare with master
unifiedsplit
rel8.cabal+1−4 src/Rel8.hs+2−4 src/Rel8/Expr/Eq.hs+1−1 src/Rel8/Schema/Column.hs+3−103 src/Rel8/Schema/Context/Identity.hs−196 src/Rel8/Schema/Field.hs+709−18 src/Rel8/Schema/Generic.hs+75−932 src/Rel8/Schema/Generic/Test.hs+4−5 src/Rel8/Schema/HTable/Either.hs+3−13 src/Rel8/Schema/HTable/MapTable.hs+8−4 src/Rel8/Schema/HTable/Maybe.hs+3−13 src/Rel8/Schema/HTable/These.hs+3−2 src/Rel8/Schema/HTable/Vectorize.hs−8 src/Rel8/Schema/Insert.hs+2−2 src/Rel8/Schema/Structure.hs+3−40 src/Rel8/Table.hs+163−3 src/Rel8/Table/Either.hs+59−49 src/Rel8/Table/Lifted.hs−81 src/Rel8/Table/Maybe.hs+48−35 src/Rel8/Table/Serialize.hs+30−49 src/Rel8/Table/These.hs+72−65 src/Rel8/Type/Array.hs+1 src/Rel8/Type/Tag.hs+1−1
rel8.cabal+1−4
@@ -87,7 +87,6 @@ library
8787
8888 Rel8.Schema.Column
8989 Rel8.Schema.Context
90− Rel8.Schema.Context.Identity
9190 Rel8.Schema.Context.Label
9291 Rel8.Schema.Context.Nullify
9392 Rel8.Schema.Dict
@@ -117,6 +116,7 @@ library
117116 Rel8.Schema.Spec
118117 Rel8.Schema.Spec.ConstrainDBType
119118 Rel8.Schema.Spec.ConstrainType
119+ Rel8.Schema.Structure
120120 Rel8.Schema.Table
121121
122122 Rel8.Statement.Delete
@@ -133,7 +133,6 @@ library
133133 Rel8.Table.Either
134134 Rel8.Table.Eq
135135 Rel8.Table.Insert
136− Rel8.Table.Lifted
137136 Rel8.Table.List
138137 Rel8.Table.Maybe
139138 Rel8.Table.Name
@@ -163,8 +162,6 @@ library
163162 Rel8.Type.Sum
164163 Rel8.Type.Tag
165164
166− Rel8.Schema.Structure
167−
168165test-suite tests
169166 type: exitcode-stdio-1.0
170167 build-depends:
src/Rel8.hs+2−4
@@ -28,7 +28,7 @@ module Rel8
2828 -- * Tables and higher-kinded tables
2929 , Rel8able
3030 , Column, Field, Necessity( Required, Optional )
31− , Default, Label
31+ , Default
3232 , HMaybe
3333 , HList
3434 , HNonEmpty
@@ -268,7 +268,7 @@ import Rel8.Query.These
268268import Rel8.Query.Values
269269import Rel8.Schema.Column
270270import Rel8.Schema.Context.Label
271−import Rel8.Schema.Field (Field)
271+import Rel8.Schema.Field
272272import Rel8.Schema.Generic
273273import Rel8.Schema.HTable
274274import Rel8.Schema.Name
@@ -307,5 +307,3 @@ import Rel8.Type.ReadShow
307307import Rel8.Type.Semigroup
308308import Rel8.Type.String
309309import Rel8.Type.Sum
310−
311−
src/Rel8/Expr/Eq.hs+1−1
@@ -22,7 +22,7 @@ import Prelude
2222import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
2323
2424-- rel8
25−import Rel8.Expr ( Expr )
25+import {-# SOURCE #-} Rel8.Expr ( Expr )
2626import Rel8.Expr.Bool ( (&&.), (||.), false, or_, coalesce )
2727import Rel8.Expr.Null ( isNull, unsafeLiftOpNull )
2828import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr, zipPrimExprsWith )
src/Rel8/Schema/Column.hs+3−103
@@ -3,67 +3,24 @@
33{-# language StandaloneKindSignatures #-}
44
55module Rel8.Schema.Column
6− ( Column, Default, Label
7− , HEither
8− , HList
9− , HMaybe
10− , HNonEmpty
11− , HThese
6+ ( Column, Default
127 )
138where
149
1510-- base
16−import Data.Functor.Identity ( Identity )
1711import Data.Kind ( Type )
18−import Data.List.NonEmpty ( NonEmpty )
19−import GHC.TypeLits ( Symbol )
20−import Prelude
12+import Prelude ()
2113
2214-- rel8
23−import Rel8.Aggregate ( Aggregate )
24−import Rel8.Expr ( Expr )
25−import Rel8.Kind.Labels ( Labels )
2615import Rel8.Kind.Necessity ( Necessity( Required, Optional ) )
2716import Rel8.Schema.Field ( Field )
28−import Rel8.Schema.Insert ( Insert )
2917import qualified Rel8.Schema.Kind as K
30−import Rel8.Schema.Name ( Name )
31−import Rel8.Schema.Structure
32− ( Structure
33− , Shape( Either, List, Maybe, NonEmpty, These )
34− , Shape1
35− , Shape2
36− )
37−import Rel8.Table.Either ( EitherTable )
38−import Rel8.Table.List ( ListTable )
39−import Rel8.Table.Maybe ( MaybeTable )
40−import Rel8.Table.NonEmpty ( NonEmptyTable )
41−import Rel8.Table.These ( TheseTable )
42−
43−-- these
44−import Data.These ( These )
45−
46−
47−type Label :: Symbol -> Type -> Type
48−data Label label a
4918
5019
5120type Default :: Type -> Type
5221data Default a
5322
5423
55−type GetLabel :: Type -> Labels
56−type family GetLabel a where
57− GetLabel (Label label _) = '[label]
58− GetLabel _ = '[]
59−
60−
61−type UnwrapLabel :: Type -> Type
62−type family UnwrapLabel a where
63− UnwrapLabel (Label _ a) = a
64− UnwrapLabel a = a
65−
66−
6724type GetNecessity :: Type -> Necessity
6825type family GetNecessity a where
6926 GetNecessity (Default _) = 'Optional
@@ -82,61 +39,4 @@ type family UnwrapDefault a where
8239-- both query data and rows decoded to Haskell.
8340type Column :: K.Context -> Type -> Type
8441type Column context a =
85− Field context (GetLabel a)
86− (GetNecessity (UnwrapLabel a))
87− (UnwrapDefault (UnwrapLabel a))
88−
89−
90−type HEither :: K.Context -> Type -> Type -> Type
91−type family HEither context where
92− HEither Structure = Shape2 'Either
93− HEither Aggregate = EitherTable
94− HEither Expr = EitherTable
95− HEither Identity = Either
96− HEither Insert = EitherTable
97− HEither Name = EitherTable
98− HEither _ = Either
99−
100−
101−type HList :: K.Context -> Type -> Type
102−type family HList context where
103− HList Structure = Shape1 'List
104− HList Aggregate = ListTable
105− HList Expr = ListTable
106− HList Identity = []
107− HList Insert = ListTable
108− HList Name = ListTable
109− HList _ = []
110−
111−
112−type HMaybe :: K.Context -> Type -> Type
113−type family HMaybe context where
114− HMaybe Structure = Shape1 'Maybe
115− HMaybe Aggregate = MaybeTable
116− HMaybe Expr = MaybeTable
117− HMaybe Identity = Maybe
118− HMaybe Insert = MaybeTable
119− HMaybe Name = MaybeTable
120− HMaybe _ = Maybe
121−
122−
123−type HNonEmpty :: K.Context -> Type -> Type
124−type family HNonEmpty context where
125− HNonEmpty Structure = Shape1 'NonEmpty
126− HNonEmpty Aggregate = NonEmptyTable
127− HNonEmpty Expr = NonEmptyTable
128− HNonEmpty Identity = NonEmpty
129− HNonEmpty Insert = NonEmptyTable
130− HNonEmpty Name = NonEmptyTable
131− HNonEmpty _ = NonEmpty
132−
133−
134−type HThese :: K.Context -> Type -> Type -> Type
135−type family HThese context where
136− HThese Structure = Shape2 'These
137− HThese Aggregate = TheseTable
138− HThese Expr = TheseTable
139− HThese Identity = These
140− HThese Insert = TheseTable
141− HThese Name = TheseTable
142− HThese _ = These
42+ Field context (GetNecessity a) (UnwrapDefault a)
src/Rel8/Schema/Context/Identity.hsdeleted−196
@@ -1,196 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language DisambiguateRecordFields #-}
3−{-# language NamedFieldPuns #-}
4−{-# language TypeFamilies #-}
5−
6−module Rel8.Schema.Context.Identity
7− ( fromHEitherTable, toHEitherTable
8− , fromHListTable, toHListTable
9− , fromHMaybeTable, toHMaybeTable
10− , fromHNonEmptyTable, toHNonEmptyTable
11− , fromHTheseTable, toHTheseTable
12− )
13−where
14−
15−-- base
16−import Data.Functor ( ($>) )
17−import Data.Functor.Identity ( Identity )
18−import Data.List.NonEmpty ( NonEmpty )
19−import Prelude hiding ( null )
20−
21−-- rel8
22−import Rel8.Schema.Context ( Col( Result ) )
23−import Rel8.Schema.HTable ( HTable )
24−import Rel8.Schema.HTable.Either ( HEitherTable(..) )
25−import Rel8.Schema.HTable.Identity ( HIdentity(..) )
26−import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
27−import Rel8.Schema.HTable.List ( HListTable )
28−import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
29−import Rel8.Schema.HTable.Nullify ( hnulls, hnullify, hunnullify )
30−import Rel8.Schema.HTable.These ( HTheseTable(..) )
31−import Rel8.Schema.HTable.Vectorize ( hvectorize, hunvectorize )
32−import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )
33−import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
34−import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), MaybeTag( IsJust ) )
35−
36−-- these
37−import Data.These ( These( This, That, These ) )
38−import Data.These.Combinators ( justHere, justThere )
39−
40−
41−toHEitherTable :: (HTable t, HTable u)
42− => Either (t (Col Identity)) (u (Col Identity))
43− -> HEitherTable t u (Col Identity)
44−toHEitherTable = either hleft hright
45− where
46− hleft table = HEitherTable
47− { htag = HIdentity (Result IsLeft)
48− , hleft = hnullify nullifier table
49− , hright = hnulls null
50− }
51− hright table = HEitherTable
52− { htag = HIdentity (Result IsRight)
53− , hleft = hnulls null
54− , hright = hnullify nullifier table
55− }
56−{-# INLINABLE toHEitherTable #-}
57−
58−
59−fromHEitherTable :: (HTable t, HTable u)
60− => HEitherTable t u (Col Identity)
61− -> Either (t (Col Identity)) (u (Col Identity))
62−fromHEitherTable HEitherTable {htag, hleft, hright} = case htag of
63− HIdentity (Result tag) -> case tag of
64− IsLeft -> maybe err Left $ hunnullify unnullifier hleft
65− IsRight -> maybe err Right $ hunnullify unnullifier hright
66− where
67− err = error "fromHEitherTable: mismatch between tag and data"
68−{-# INLINABLE fromHEitherTable #-}
69−
70−
71−toHListTable :: HTable t => [t (Col Identity)] -> HListTable t (Col Identity)
72−toHListTable = hvectorize vectorizer
73−{-# INLINABLE toHListTable #-}
74−
75−
76−fromHListTable :: HTable t => HListTable t (Col Identity) -> [t (Col Identity)]
77−fromHListTable = hunvectorize unvectorizer
78−{-# INLINABLE fromHListTable #-}
79−
80−
81−toHMaybeTable :: HTable t => Maybe (t (Col Identity)) -> HMaybeTable t (Col Identity)
82−toHMaybeTable = maybe hnothing hjust
83− where
84− hnothing = HMaybeTable
85− { htag = HIdentity (Result Nothing)
86− , hjust = hnulls null
87− }
88− hjust table = HMaybeTable
89− { htag = HIdentity (Result (Just IsJust))
90− , hjust = hnullify nullifier table
91− }
92−{-# INLINABLE toHMaybeTable #-}
93−
94−
95−fromHMaybeTable :: HTable t => HMaybeTable t (Col Identity) -> Maybe (t (Col Identity))
96−fromHMaybeTable HMaybeTable {htag, hjust} = case htag of
97− HIdentity (Result tag) -> tag $>
98− case hunnullify unnullifier hjust of
99− Nothing -> error "fromHMaybeTable: mismatch between tag and data"
100− Just just -> just
101−{-# INLINABLE fromHMaybeTable #-}
102−
103−
104−toHNonEmptyTable :: HTable t => NonEmpty (t (Col Identity)) -> HNonEmptyTable t (Col Identity)
105−toHNonEmptyTable = hvectorize vectorizer
106−{-# INLINABLE toHNonEmptyTable #-}
107−
108−
109−fromHNonEmptyTable :: HTable t => HNonEmptyTable t (Col Identity) -> NonEmpty (t (Col Identity))
110−fromHNonEmptyTable = hunvectorize unvectorizer
111−{-# INLINABLE fromHNonEmptyTable #-}
112−
113−
114−toHTheseTable :: (HTable t, HTable u)
115− => These (t (Col Identity)) (u (Col Identity))
116− -> HTheseTable t u (Col Identity)
117−toHTheseTable tables = HTheseTable
118− { hhereTag = relabel hhereTag
119− , hhere
120− , hthereTag = relabel hthereTag
121− , hthere
122− }
123− where
124− HMaybeTable
125− { htag = hhereTag
126− , hjust = hhere
127− } = toHMaybeTable (justHere tables)
128− HMaybeTable
129− { htag = hthereTag
130− , hjust = hthere
131− } = toHMaybeTable (justThere tables)
132−{-# INLINABLE toHTheseTable #-}
133−
134−
135−fromHTheseTable :: (HTable t, HTable u)
136− => HTheseTable t u (Col Identity)
137− -> These (t (Col Identity)) (u (Col Identity))
138−fromHTheseTable HTheseTable {hhereTag, hhere, hthereTag, hthere} =
139− case (fromHMaybeTable mhere, fromHMaybeTable mthere) of
140− (Just a, Nothing) -> This a
141− (Nothing, Just b) -> That b
142− (Just a, Just b) -> These a b
143− _ -> error "fromHTheseTable: mismatch between tags and data"
144− where
145− mhere = HMaybeTable
146− { htag = relabel hhereTag
147− , hjust = hhere
148− }
149− mthere = HMaybeTable
150− { htag = relabel hthereTag
151− , hjust = hthere
152− }
153−{-# INLINABLE fromHTheseTable #-}
154−
155−
156−null :: Col Identity ('Spec labels necessity (Maybe a))
157−null = Result Nothing
158−
159−
160−nullifier :: ()
161− => SSpec ('Spec labels necessity a)
162− -> Col Identity ('Spec labels necessity a)
163− -> Col Identity ('Spec labels necessity (Nullify a))
164−nullifier SSpec {nullity} (Result a) = Result $ case nullity of
165− Null -> a
166− NotNull -> Just a
167−
168−
169−unnullifier :: ()
170− => SSpec ('Spec labels necessity a)
171− -> Col Identity ('Spec labels necessity (Nullify a))
172− -> Maybe (Col Identity ('Spec labels necessity a))
173−unnullifier SSpec {nullity} (Result a) =
174− case nullity of
175− Null -> pure $ Result a
176− NotNull -> Result <$> a
177−
178−
179−vectorizer :: Functor f
180− => SSpec ('Spec labels necessity a)
181− -> f (Col Identity ('Spec labels necessity a))
182− -> Col Identity ('Spec labels necessity (f a))
183−vectorizer _ = Result . fmap (\(Result a) -> a)
184−
185−
186−unvectorizer :: Functor f
187− => SSpec ('Spec labels necessity a)
188− -> Col Identity ('Spec labels necessity (f a))
189− -> f (Col Identity ('Spec labels necessity a))
190−unvectorizer _ (Result results) = Result <$> results
191−
192−
193−relabel :: ()
194− => HIdentity ('Spec labels necessity a) (Col Identity)
195− -> HIdentity ('Spec relabels necessity a) (Col Identity)
196−relabel (HIdentity (Result a)) = HIdentity (Result a)
src/Rel8/Schema/Field.hs+709−18
@@ -1,34 +1,725 @@
11{-# language DataKinds #-}
2+{-# language FlexibleContexts #-}
3+{-# language GADTs #-}
4+{-# language LambdaCase #-}
5+{-# language MultiParamTypeClasses #-}
26{-# language StandaloneKindSignatures #-}
37{-# language TypeFamilies #-}
8+{-# language UndecidableInstances #-}
49
510module Rel8.Schema.Field
611 ( Field
12+ , HEither, HList, HMaybe, HNonEmpty, HThese
13+ , Reify, hreify, hunreify
14+ , Reifiable
15+ , AField(..)
16+ , AHEither(..), AHList(..), AHMaybe(..), AHNonEmpty(..), AHThese(..)
717 )
818where
919
1020-- base
21+import Data.Bifunctor ( Bifunctor, bimap )
1122import Data.Functor.Identity ( Identity )
12−import Data.Kind ( Type )
23+import Data.Kind ( Constraint, Type )
24+import Data.List.NonEmpty ( NonEmpty )
1325import Prelude
1426
1527-- rel8
16−import Rel8.Aggregate ( Aggregate )
17−import Rel8.Expr ( Expr )
18−import Rel8.Kind.Labels ( Labels )
19−import Rel8.Kind.Necessity ( Necessity( Required, Optional ) )
20−import Rel8.Schema.Insert ( Insert )
28+import Rel8.Aggregate ( Aggregate, Col(..) )
29+import Rel8.Expr ( Expr, Col(..) )
30+import Rel8.Kind.Necessity
31+ ( Necessity( Required, Optional )
32+ , SNecessity( SRequired, SOptional )
33+ , KnownNecessity, necessitySing
34+ )
35+import Rel8.Schema.Context ( Interpretation, Col(..) )
36+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
37+import Rel8.Schema.HTable ( HTable, hfield, htabulate )
38+import Rel8.Schema.HTable.Either ( HEitherTable )
39+import Rel8.Schema.HTable.List ( HListTable )
40+import Rel8.Schema.HTable.Maybe ( HMaybeTable )
41+import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
42+import Rel8.Schema.HTable.These ( HTheseTable )
43+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
44+import Rel8.Schema.Insert ( Insert, Col(..) )
2145import qualified Rel8.Schema.Kind as K
46+import Rel8.Schema.Name ( Name(..), Col(..) )
47+import Rel8.Schema.Null ( Sql )
2248import Rel8.Schema.Spec ( Spec( Spec ) )
23−import Rel8.Schema.Structure ( Structure, Shape( Column ), Shape1 )
24−
25−
26−type Field :: K.Context -> Labels -> Necessity -> Type -> Type
27−type family Field labels context necessity a where
28− Field Identity _labels _necessity a = a
29− Field Expr _labels _necessity a = Expr a
30− Field Insert _labels 'Required a = Expr a
31− Field Insert _labels 'Optional a = Maybe (Expr a)
32− Field Aggregate _labels _necessity a = Aggregate (Expr a)
33− Field Structure labels necessity a = Shape1 'Column ('Spec labels necessity a)
34− Field context _labels _necessity a = context a
49+import Rel8.Table
50+ ( Table, Columns, Context, fromColumns, toColumns
51+ , Congruent
52+ )
53+import Rel8.Table.Either ( EitherTable )
54+import Rel8.Table.List ( ListTable( ListTable ) )
55+import Rel8.Table.Maybe ( MaybeTable )
56+import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) )
57+import Rel8.Table.Recontextualize ( Recontextualize )
58+import Rel8.Table.These ( TheseTable )
59+import Rel8.Type ( DBType )
60+
61+-- these
62+import Data.These ( These )
63+
64+
65+type Field :: K.Context -> Necessity -> Type -> Type
66+type family Field context necessity a where
67+ Field (Reify context) necessity a = AField context necessity a
68+ Field Identity _necessity a = a
69+ Field Expr _necessity a = Expr a
70+ Field Insert 'Required a = Expr a
71+ Field Insert 'Optional a = Maybe (Expr a)
72+ Field Aggregate _necessity a = Aggregate (Expr a)
73+ Field context _necessity a = context a
74+
75+
76+type HEither :: K.Context -> Type -> Type -> Type
77+type family HEither context where
78+ HEither (Reify context) = AHEither context
79+ HEither Aggregate = EitherTable
80+ HEither Expr = EitherTable
81+ HEither Identity = Either
82+ HEither Insert = EitherTable
83+ HEither Name = EitherTable
84+ HEither _ = Either
85+
86+
87+type HList :: K.Context -> Type -> Type
88+type family HList context where
89+ HList (Reify context) = AHList context
90+ HList Aggregate = ListTable
91+ HList Expr = ListTable
92+ HList Identity = []
93+ HList Insert = ListTable
94+ HList Name = ListTable
95+ HList _ = []
96+
97+
98+type HMaybe :: K.Context -> Type -> Type
99+type family HMaybe context where
100+ HMaybe (Reify context) = AHMaybe context
101+ HMaybe Aggregate = MaybeTable
102+ HMaybe Expr = MaybeTable
103+ HMaybe Identity = Maybe
104+ HMaybe Insert = MaybeTable
105+ HMaybe Name = MaybeTable
106+ HMaybe _ = Maybe
107+
108+
109+type HNonEmpty :: K.Context -> Type -> Type
110+type family HNonEmpty context where
111+ HNonEmpty (Reify context) = AHNonEmpty context
112+ HNonEmpty Aggregate = NonEmptyTable
113+ HNonEmpty Expr = NonEmptyTable
114+ HNonEmpty Identity = NonEmpty
115+ HNonEmpty Insert = NonEmptyTable
116+ HNonEmpty Name = NonEmptyTable
117+ HNonEmpty _ = NonEmpty
118+
119+
120+type HThese :: K.Context -> Type -> Type -> Type
121+type family HThese context where
122+ HThese (Reify context) = AHThese context
123+ HThese Aggregate = TheseTable
124+ HThese Expr = TheseTable
125+ HThese Identity = These
126+ HThese Insert = TheseTable
127+ HThese Name = TheseTable
128+ HThese _ = These
129+
130+
131+type AField :: K.Context -> Necessity -> Type -> Type
132+newtype AField context necessity a = AField (Field context necessity a)
133+
134+
135+instance (Reifiable context, KnownNecessity necessity, Sql DBType a) =>
136+ Table (Reify context) (AField context necessity a)
137+ where
138+ type Context (AField context necessity a) = Reify context
139+ type Columns (AField context necessity a) = HIdentity ('Spec '[""] necessity a)
140+
141+ fromColumns (HIdentity (Reify a)) = sfromColumn contextSing a
142+ toColumns = HIdentity . Reify . stoColumn contextSing necessitySing
143+
144+
145+instance
146+ ( Reifiable context, Reifiable context'
147+ , KnownNecessity necessity, Sql DBType a
148+ ) =>
149+ Recontextualize
150+ (Reify context)
151+ (Reify context')
152+ (AField context necessity a)
153+ (AField context' necessity a)
154+
155+
156+type AHEither :: K.Context -> Type -> Type -> Type
157+newtype AHEither context a b = AHEither (HEither context a b)
158+
159+
160+instance Reifiable context => Bifunctor (AHEither context) where
161+ bimap = sbimapEither contextSing
162+
163+
164+instance Reifiable context => Functor (AHEither context a) where
165+ fmap = bimap id
166+
167+
168+instance (Reifiable context, Table (Reify context) a, Table (Reify context) b)
169+ => Table (Reify context) (AHEither context a b)
170+ where
171+ type Context (AHEither context a b) = Reify context
172+ type Columns (AHEither context a b) = HEitherTable (Columns a) (Columns b)
173+
174+ fromColumns = sfromColumnsEither contextSing
175+ toColumns = stoColumnsEither contextSing
176+
177+
178+instance
179+ ( Reifiable context, Reifiable context'
180+ , Recontextualize (Reify context) (Reify context') a a'
181+ , Recontextualize (Reify context) (Reify context') b b'
182+ ) =>
183+ Recontextualize
184+ (Reify context)
185+ (Reify context')
186+ (AHEither context a b)
187+ (AHEither context' a' b')
188+
189+
190+type AHList :: K.Context -> Type -> Type
191+newtype AHList context a = AHList (HList context a)
192+
193+
194+instance (Reifiable context, Table (Reify context) a) =>
195+ Table (Reify context) (AHList context a)
196+ where
197+ type Context (AHList context a) = Reify context
198+ type Columns (AHList context a) = HListTable (Columns a)
199+
200+ fromColumns = sfromColumnsList contextSing
201+ toColumns = stoColumnsList contextSing
202+
203+
204+instance
205+ ( Reifiable context, Reifiable context'
206+ , Recontextualize (Reify context) (Reify context') a a'
207+ ) =>
208+ Recontextualize
209+ (Reify context)
210+ (Reify context')
211+ (AHList context a)
212+ (AHList context' a')
213+
214+
215+type AHMaybe :: K.Context -> Type -> Type
216+newtype AHMaybe context a = AHMaybe (HMaybe context a)
217+
218+
219+instance Reifiable context => Functor (AHMaybe context) where
220+ fmap = smapMaybe contextSing
221+
222+
223+instance (Reifiable context, Table (Reify context) a) =>
224+ Table (Reify context) (AHMaybe context a)
225+ where
226+ type Context (AHMaybe context a) = Reify context
227+ type Columns (AHMaybe context a) = HMaybeTable (Columns a)
228+
229+ fromColumns = sfromColumnsMaybe contextSing
230+ toColumns = stoColumnsMaybe contextSing
231+
232+
233+instance
234+ ( Reifiable context, Reifiable context'
235+ , Recontextualize (Reify context) (Reify context') a a'
236+ ) =>
237+ Recontextualize
238+ (Reify context)
239+ (Reify context')
240+ (AHMaybe context a)
241+ (AHMaybe context' a')
242+
243+
244+type AHNonEmpty :: K.Context -> Type -> Type
245+newtype AHNonEmpty context a = AHNonEmpty (HNonEmpty context a)
246+
247+
248+instance (Reifiable context, Table (Reify context) a) =>
249+ Table (Reify context) (AHNonEmpty context a)
250+ where
251+ type Context (AHNonEmpty context a) = Reify context
252+ type Columns (AHNonEmpty context a) = HNonEmptyTable (Columns a)
253+
254+ fromColumns = sfromColumnsNonEmpty contextSing
255+ toColumns = stoColumnsNonEmpty contextSing
256+
257+
258+instance
259+ ( Reifiable context, Reifiable context'
260+ , Recontextualize (Reify context) (Reify context') a a'
261+ ) =>
262+ Recontextualize
263+ (Reify context)
264+ (Reify context')
265+ (AHNonEmpty context a)
266+ (AHNonEmpty context' a')
267+
268+
269+type AHThese :: K.Context -> Type -> Type -> Type
270+newtype AHThese context a b = AHThese (HThese context a b)
271+
272+
273+instance Reifiable context => Bifunctor (AHThese context) where
274+ bimap = sbimapThese contextSing
275+
276+
277+instance Reifiable context => Functor (AHThese context a) where
278+ fmap = bimap id
279+
280+
281+instance (Reifiable context, Table (Reify context) a, Table (Reify context) b)
282+ => Table (Reify context) (AHThese context a b)
283+ where
284+ type Context (AHThese context a b) = Reify context
285+ type Columns (AHThese context a b) = HTheseTable (Columns a) (Columns b)
286+
287+ fromColumns = sfromColumnsThese contextSing
288+ toColumns = stoColumnsThese contextSing
289+
290+
291+instance
292+ ( Reifiable context, Reifiable context'
293+ , Recontextualize (Reify context) (Reify context') a a'
294+ , Recontextualize (Reify context) (Reify context') b b'
295+ ) =>
296+ Recontextualize
297+ (Reify context)
298+ (Reify context')
299+ (AHThese context a b)
300+ (AHThese context' a' b')
301+
302+
303+type SContext :: K.Context -> Type
304+data SContext context where
305+ SAggregate :: SContext Aggregate
306+ SExpr :: SContext Expr
307+ SIdentity :: SContext Identity
308+ SInsert :: SContext Insert
309+ SName :: SContext Name
310+ SReify :: SContext context -> SContext (Reify context)
311+
312+
313+type Reifiable :: K.Context -> Constraint
314+class Interpretation context => Reifiable context where
315+ contextSing :: SContext context
316+
317+
318+instance Reifiable Aggregate where
319+ contextSing = SAggregate
320+
321+
322+instance Reifiable Expr where
323+ contextSing = SExpr
324+
325+
326+instance Reifiable Identity where
327+ contextSing = SIdentity
328+
329+
330+instance Reifiable Insert where
331+ contextSing = SInsert
332+
333+
334+instance Reifiable Name where
335+ contextSing = SName
336+
337+
338+type Reify :: K.Context -> K.Context
339+data Reify context a
340+
341+
342+instance Interpretation (Reify context) where
343+ newtype Col (Reify context) spec = Reify (Col context spec)
344+
345+
346+instance Labelable context => Labelable (Reify context) where
347+ labeler (Reify a) = Reify (labeler a)
348+ unlabeler (Reify a) = Reify (unlabeler a)
349+
350+
351+instance Reifiable context => Reifiable (Reify context) where
352+ contextSing = SReify contextSing
353+
354+
355+sfromColumn :: ()
356+ => SContext context
357+ -> Col context ('Spec labels necessity a)
358+ -> AField context necessity a
359+sfromColumn = \case
360+ SAggregate -> \(Aggregation a) -> AField a
361+ SExpr -> \(DB a) -> AField a
362+ SIdentity -> \(Result a) -> AField a
363+ SInsert -> \case
364+ RequiredInsert a -> AField a
365+ OptionalInsert a -> AField a
366+ SName -> \(NameCol a) -> AField (Name a)
367+ SReify context -> \(Reify a) -> AField (sfromColumn context a)
368+
369+
370+stoColumn :: ()
371+ => SContext context
372+ -> SNecessity necessity
373+ -> AField context necessity a
374+ -> Col context ('Spec labels necessity a)
375+stoColumn = \case
376+ SAggregate -> \_ (AField a) -> Aggregation a
377+ SExpr -> \_ (AField a) -> DB a
378+ SIdentity -> \_ (AField a) -> Result a
379+ SInsert -> \case
380+ SRequired -> \(AField a) -> RequiredInsert a
381+ SOptional -> \(AField a) -> OptionalInsert a
382+ SName -> \_ (AField (Name a)) -> NameCol a
383+ SReify context ->
384+ \necessity (AField a) -> Reify (stoColumn context necessity a)
385+
386+
387+sbimapEither :: ()
388+ => SContext context
389+ -> (a -> c)
390+ -> (b -> d)
391+ -> AHEither context a b
392+ -> AHEither context c d
393+sbimapEither = \case
394+ SAggregate -> \f g (AHEither a) -> AHEither (bimap f g a)
395+ SExpr -> \f g (AHEither a) -> AHEither (bimap f g a)
396+ SIdentity -> \f g (AHEither a) -> AHEither (bimap f g a)
397+ SInsert -> \f g (AHEither a) -> AHEither (bimap f g a)
398+ SName -> \f g (AHEither a) -> AHEither (bimap f g a)
399+ SReify context -> \f g (AHEither a) -> AHEither (sbimapEither context f g a)
400+
401+
402+sfromColumnsEither :: (Table (Reify context) a, Table (Reify context) b)
403+ => SContext context
404+ -> HEitherTable (Columns a) (Columns b) (Col (Reify context))
405+ -> AHEither context a b
406+sfromColumnsEither = \case
407+ SAggregate ->
408+ AHEither .
409+ bimap (fromColumns . hreify) (fromColumns . hreify) .
410+ fromColumns .
411+ hunreify
412+ SExpr ->
413+ AHEither .
414+ bimap (fromColumns . hreify) (fromColumns . hreify) .
415+ fromColumns .
416+ hunreify
417+ SIdentity ->
418+ AHEither .
419+ bimap (fromColumns . hreify) (fromColumns . hreify) .
420+ fromColumns .
421+ hunreify
422+ SInsert ->
423+ AHEither .
424+ bimap (fromColumns . hreify) (fromColumns . hreify) .
425+ fromColumns .
426+ hunreify
427+ SName ->
428+ AHEither .
429+ bimap (fromColumns . hreify) (fromColumns . hreify) .
430+ fromColumns .
431+ hunreify
432+ SReify context ->
433+ AHEither .
434+ sbimapEither context (fromColumns . hreify) (fromColumns . hreify) .
435+ sfromColumnsEither context .
436+ hunreify
437+
438+
439+stoColumnsEither :: (Table (Reify context) a, Table (Reify context) b)
440+ => SContext context
441+ -> AHEither context a b
442+ -> HEitherTable (Columns a) (Columns b) (Col (Reify context))
443+stoColumnsEither = \case
444+ SAggregate ->
445+ hreify .
446+ toColumns .
447+ bimap (hunreify . toColumns) (hunreify . toColumns) .
448+ (\(AHEither a) -> a)
449+ SExpr ->
450+ hreify .
451+ toColumns .
452+ bimap (hunreify . toColumns) (hunreify . toColumns) .
453+ (\(AHEither a) -> a)
454+ SIdentity ->
455+ hreify .
456+ toColumns .
457+ bimap (hunreify . toColumns) (hunreify . toColumns) .
458+ (\(AHEither a) -> a)
459+ SInsert ->
460+ hreify .
461+ toColumns .
462+ bimap (hunreify . toColumns) (hunreify . toColumns) .
463+ (\(AHEither a) -> a)
464+ SName ->
465+ hreify .
466+ toColumns .
467+ bimap (hunreify . toColumns) (hunreify . toColumns) .
468+ (\(AHEither a) -> a)
469+ SReify context ->
470+ hreify .
471+ stoColumnsEither context .
472+ sbimapEither context (hunreify . toColumns) (hunreify . toColumns) .
473+ (\(AHEither a) -> a)
474+
475+
476+smapList :: Congruent a b
477+ => SContext context
478+ -> (a -> b)
479+ -> (HListTable (Columns a) (Col (Context a)) -> HListTable (Columns b) (Col (Context b)))
480+ -> AHList context a
481+ -> AHList context b
482+smapList = \case
483+ SAggregate -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))
484+ SExpr -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))
485+ SIdentity -> \f _ (AHList as) -> AHList (fmap f as)
486+ SInsert -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))
487+ SName -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))
488+ SReify context -> \f g (AHList as) -> AHList (smapList context f g as)
489+
490+
491+sfromColumnsList :: Table (Reify context) a
492+ => SContext context
493+ -> HListTable (Columns a) (Col (Reify context))
494+ -> AHList context a
495+sfromColumnsList = \case
496+ SAggregate -> AHList . ListTable
497+ SExpr -> AHList . ListTable
498+ SIdentity -> AHList . fmap (fromColumns . hreify) . fromColumns . hunreify
499+ SInsert -> AHList . ListTable
500+ SName -> AHList . ListTable
501+ SReify context ->
502+ AHList .
503+ smapList context (fromColumns . hreify) hreify .
504+ sfromColumnsList context .
505+ hunreify
506+
507+
508+stoColumnsList :: Table (Reify context) a
509+ => SContext context
510+ -> AHList context a
511+ -> HListTable (Columns a) (Col (Reify context))
512+stoColumnsList = \case
513+ SAggregate -> \(AHList (ListTable a)) -> a
514+ SExpr -> \(AHList (ListTable a)) -> a
515+ SIdentity ->
516+ hreify . toColumns . fmap (hunreify . toColumns) . (\(AHList a) -> a)
517+ SInsert -> \(AHList (ListTable a)) -> a
518+ SName -> \(AHList (ListTable a)) -> a
519+ SReify context ->
520+ hreify .
521+ stoColumnsList context .
522+ smapList context (hunreify . toColumns) hunreify .
523+ (\(AHList a) -> a)
524+
525+
526+smapMaybe :: ()
527+ => SContext context
528+ -> (a -> b)
529+ -> AHMaybe context a
530+ -> AHMaybe context b
531+smapMaybe = \case
532+ SAggregate -> \f (AHMaybe a) -> AHMaybe (fmap f a)
533+ SExpr -> \f (AHMaybe a) -> AHMaybe (fmap f a)
534+ SIdentity -> \f (AHMaybe a) -> AHMaybe (fmap f a)
535+ SInsert -> \f (AHMaybe a) -> AHMaybe (fmap f a)
536+ SName -> \f (AHMaybe a) -> AHMaybe (fmap f a)
537+ SReify context -> \f (AHMaybe a) -> AHMaybe (smapMaybe context f a)
538+
539+
540+sfromColumnsMaybe :: Table (Reify context) a
541+ => SContext context
542+ -> HMaybeTable (Columns a) (Col (Reify context))
543+ -> AHMaybe context a
544+sfromColumnsMaybe = \case
545+ SAggregate -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
546+ SExpr -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
547+ SIdentity -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
548+ SInsert -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
549+ SName -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
550+ SReify context ->
551+ AHMaybe .
552+ smapMaybe context (fromColumns . hreify) .
553+ sfromColumnsMaybe context .
554+ hunreify
555+
556+
557+stoColumnsMaybe :: Table (Reify context) a
558+ => SContext context
559+ -> AHMaybe context a
560+ -> HMaybeTable (Columns a) (Col (Reify context))
561+stoColumnsMaybe = \case
562+ SAggregate ->
563+ hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)
564+ SExpr ->
565+ hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)
566+ SIdentity ->
567+ hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)
568+ SInsert ->
569+ hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)
570+ SName ->
571+ hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)
572+ SReify context ->
573+ hreify .
574+ stoColumnsMaybe context .
575+ smapMaybe context (hunreify . toColumns) .
576+ (\(AHMaybe a) -> a)
577+
578+
579+smapNonEmpty :: Congruent a b
580+ => SContext context
581+ -> (a -> b)
582+ -> (HNonEmptyTable (Columns a) (Col (Context a)) -> HNonEmptyTable (Columns b) (Col (Context b)))
583+ -> AHNonEmpty context a
584+ -> AHNonEmpty context b
585+smapNonEmpty = \case
586+ SAggregate -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))
587+ SExpr -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))
588+ SIdentity -> \f _ (AHNonEmpty as) -> AHNonEmpty (fmap f as)
589+ SInsert -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))
590+ SName -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))
591+ SReify context -> \f g (AHNonEmpty as) -> AHNonEmpty (smapNonEmpty context f g as)
592+
593+
594+sfromColumnsNonEmpty :: Table (Reify context) a
595+ => SContext context
596+ -> HNonEmptyTable (Columns a) (Col (Reify context))
597+ -> AHNonEmpty context a
598+sfromColumnsNonEmpty = \case
599+ SAggregate -> AHNonEmpty . NonEmptyTable
600+ SExpr -> AHNonEmpty . NonEmptyTable
601+ SIdentity ->
602+ AHNonEmpty . fmap (fromColumns . hreify) . fromColumns . hunreify
603+ SInsert -> AHNonEmpty . NonEmptyTable
604+ SName -> AHNonEmpty . NonEmptyTable
605+ SReify context ->
606+ AHNonEmpty .
607+ smapNonEmpty context (fromColumns . hreify) hreify .
608+ sfromColumnsNonEmpty context .
609+ hunreify
610+
611+
612+stoColumnsNonEmpty :: Table (Reify context) a
613+ => SContext context
614+ -> AHNonEmpty context a
615+ -> HNonEmptyTable (Columns a) (Col (Reify context))
616+stoColumnsNonEmpty = \case
617+ SAggregate -> \(AHNonEmpty (NonEmptyTable a)) -> a
618+ SExpr -> \(AHNonEmpty (NonEmptyTable a)) -> a
619+ SIdentity ->
620+ hreify . toColumns . fmap (hunreify . toColumns) . (\(AHNonEmpty a) -> a)
621+ SInsert -> \(AHNonEmpty (NonEmptyTable a)) -> a
622+ SName -> \(AHNonEmpty (NonEmptyTable a)) -> a
623+ SReify context ->
624+ hreify .
625+ stoColumnsNonEmpty context .
626+ smapNonEmpty context (hunreify . toColumns) hunreify .
627+ (\(AHNonEmpty a) -> a)
628+
629+
630+sbimapThese :: ()
631+ => SContext context
632+ -> (a -> c)
633+ -> (b -> d)
634+ -> AHThese context a b
635+ -> AHThese context c d
636+sbimapThese = \case
637+ SAggregate -> \f g (AHThese a) -> AHThese (bimap f g a)
638+ SExpr -> \f g (AHThese a) -> AHThese (bimap f g a)
639+ SIdentity -> \f g (AHThese a) -> AHThese (bimap f g a)
640+ SInsert -> \f g (AHThese a) -> AHThese (bimap f g a)
641+ SName -> \f g (AHThese a) -> AHThese (bimap f g a)
642+ SReify context -> \f g (AHThese a) -> AHThese (sbimapThese context f g a)
643+
644+
645+sfromColumnsThese :: (Table (Reify context) a, Table (Reify context) b)
646+ => SContext context
647+ -> HTheseTable (Columns a) (Columns b) (Col (Reify context))
648+ -> AHThese context a b
649+sfromColumnsThese = \case
650+ SAggregate ->
651+ AHThese .
652+ bimap (fromColumns . hreify) (fromColumns . hreify) .
653+ fromColumns .
654+ hunreify
655+ SExpr ->
656+ AHThese .
657+ bimap (fromColumns . hreify) (fromColumns . hreify) .
658+ fromColumns .
659+ hunreify
660+ SIdentity ->
661+ AHThese .
662+ bimap (fromColumns . hreify) (fromColumns . hreify) .
663+ fromColumns .
664+ hunreify
665+ SInsert ->
666+ AHThese .
667+ bimap (fromColumns . hreify) (fromColumns . hreify) .
668+ fromColumns .
669+ hunreify
670+ SName ->
671+ AHThese .
672+ bimap (fromColumns . hreify) (fromColumns . hreify) .
673+ fromColumns .
674+ hunreify
675+ SReify context ->
676+ AHThese .
677+ sbimapThese context (fromColumns . hreify) (fromColumns . hreify) .
678+ sfromColumnsThese context .
679+ hunreify
680+
681+
682+stoColumnsThese :: (Table (Reify context) a, Table (Reify context) b)
683+ => SContext context
684+ -> AHThese context a b
685+ -> HTheseTable (Columns a) (Columns b) (Col (Reify context))
686+stoColumnsThese = \case
687+ SAggregate ->
688+ hreify .
689+ toColumns .
690+ bimap (hunreify . toColumns) (hunreify . toColumns) .
691+ (\(AHThese a) -> a)
692+ SExpr ->
693+ hreify .
694+ toColumns .
695+ bimap (hunreify . toColumns) (hunreify . toColumns) .
696+ (\(AHThese a) -> a)
697+ SIdentity ->
698+ hreify .
699+ toColumns .
700+ bimap (hunreify . toColumns) (hunreify . toColumns) .
701+ (\(AHThese a) -> a)
702+ SInsert ->
703+ hreify .
704+ toColumns .
705+ bimap (hunreify . toColumns) (hunreify . toColumns) .
706+ (\(AHThese a) -> a)
707+ SName ->
708+ hreify .
709+ toColumns .
710+ bimap (hunreify . toColumns) (hunreify . toColumns) .
711+ (\(AHThese a) -> a)
712+ SReify context ->
713+ hreify .
714+ stoColumnsThese context .
715+ sbimapThese context (hunreify . toColumns) (hunreify . toColumns) .
716+ (\(AHThese a) -> a)
717+
718+
719+hreify :: HTable t => t (Col context) -> t (Col (Reify context))
720+hreify a = htabulate $ \field -> Reify (hfield a field)
721+
722+
723+hunreify :: HTable t => t (Col (Reify context)) -> t (Col context)
724+hunreify a = htabulate $ \field -> case hfield a field of
725+ Reify x -> x
src/Rel8/Schema/Generic.hs+75−932
@@ -6,13 +6,13 @@
66{-# language FlexibleInstances #-}
77{-# language GADTs #-}
88{-# language MultiParamTypeClasses #-}
9+{-# language QuantifiedConstraints #-}
910{-# language ScopedTypeVariables #-}
1011{-# language StandaloneKindSignatures #-}
1112{-# language TypeApplications #-}
1213{-# language TypeFamilies #-}
1314{-# language TypeOperators #-}
1415{-# language UndecidableInstances #-}
15−{-# language ViewPatterns #-}
1616
1717{-# options_ghc -fno-warn-orphans #-}
1818
@@ -22,113 +22,44 @@ module Rel8.Schema.Generic
2222where
2323
2424-- base
25−import Data.Bifunctor ( bimap )
26−import Data.Functor.Identity ( Identity )
2725import Data.Kind ( Constraint, Type )
28−import Data.List.NonEmpty ( NonEmpty )
2926import GHC.Generics
3027 ( Generic, Rep, from, to
3128 , (:*:)( (:*:) ), K1( K1 ), M1( M1 )
32− , D, C, S
29+ , D, S
3330 , Meta( MetaSel )
3431 )
35−import GHC.TypeLits ( Symbol, KnownSymbol )
32+import qualified GHC.Generics as G ( C )
33+import GHC.TypeLits ( KnownSymbol )
3634import Prelude
35+import Unsafe.Coerce ( unsafeCoerce )
3736
3837-- rel8
39−import Rel8.Aggregate ( Aggregate, Col(..) )
40−import Rel8.Expr ( Expr, Col(..) )
41−import Rel8.Kind.Necessity
42− ( SNecessity( SRequired, SOptional )
43− , KnownNecessity, necessitySing
44− )
45−import Rel8.Schema.Context ( Col(..) )
46−import Rel8.Schema.Context.Identity
47− ( fromHEitherTable, toHEitherTable
48− , fromHListTable, toHListTable
49− , fromHMaybeTable, toHMaybeTable
50− , fromHNonEmptyTable, toHNonEmptyTable
51− , fromHTheseTable, toHTheseTable
52− )
53−import Rel8.Schema.Context.Label
54− ( Labelable, labeler, unlabeler
55− , hlabeler, hunlabeler
56− )
57−import Rel8.Schema.Field ( Field )
38+import Rel8.Schema.Context ( Col )
39+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
40+import Rel8.Schema.Field ( Reify, Reifiable, hreify, hunreify )
5841import Rel8.Schema.HTable ( HTable )
59−import Rel8.Schema.HTable.Either ( HEitherTable )
60−import Rel8.Schema.HTable.Identity ( HIdentity(..) )
6142import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
62−import Rel8.Schema.HTable.List ( HListTable )
63−import Rel8.Schema.HTable.Maybe ( HMaybeTable )
64−import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
6543import Rel8.Schema.HTable.Pair ( HPair(..) )
66−import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
67−import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
68−import Rel8.Schema.HTable.These ( HTheseTable )
69−import Rel8.Schema.HTable.Trio ( HTrio(..) )
70−import Rel8.Schema.HTable.Vectorize ( hrelabel )
71−import Rel8.Schema.Insert ( Insert, Col(..) )
7244import qualified Rel8.Schema.Kind as K
73−import Rel8.Schema.Name ( Name( Name ), Col(..) )
74−import Rel8.Schema.Spec ( Spec( Spec ), KTable )
75−import Rel8.Schema.Structure
76− ( IsStructure, Shape(..), Shape1, Shape2
77− , Structure
78− )
45+import Rel8.Schema.Spec ( KTable )
7946import Rel8.Table
8047 ( Table, Columns, Context, fromColumns, toColumns
8148 )
82−import Rel8.Table.Either ( EitherTable )
83−import Rel8.Table.Lifted
84− ( fromColumns1, toColumns1
85− , fromColumns2, toColumns2
86− )
87−import Rel8.Table.List ( ListTable )
88−import Rel8.Table.Maybe ( MaybeTable(..) )
89−import Rel8.Table.NonEmpty ( NonEmptyTable )
90−import Rel8.Table.These ( TheseTable )
91−
92−-- these
93−import Data.These ( These )
9449
9550
96−instance (Rel8able t, TableHelper context) => Table context (t context) where
97− type Columns (t context) = GRep t
51+instance
52+ ( Rel8able t
53+ , Labelable context
54+ , Reifiable context
55+ , HTable (GRep context t)
56+ ) => Table context (t context)
57+ where
58+ type Columns (t context) = GRep context t
9859 type Context (t context) = context
99− fromColumns = gfromColumns
100− toColumns = gtoColumns
101−
102−
103−type TableHelper :: K.Context -> Constraint
104−class TableHelper context where
105− gfromColumns :: Rel8able t => GRep t (Col context) -> t context
106− gtoColumns :: Rel8able t => t context -> GRep t (Col context)
107−
108−
109−instance TableHelper Aggregate where
110− gfromColumns = fromAggregateColumns
111− gtoColumns = toAggregateColumns
112−
113−
114−instance TableHelper Expr where
115− gfromColumns = fromExprColumns
116− gtoColumns = toExprColumns
11760
118−
119−instance TableHelper Insert where
120− gfromColumns = fromInsertColumns
121− gtoColumns = toInsertColumns
122−
123−
124−instance TableHelper Identity where
125− gfromColumns = fromIdentityColumns
126− gtoColumns = toIdentityColumns
127−
128−
129−instance TableHelper Name where
130− gfromColumns = fromNameColumns
131− gtoColumns = toNameColumns
61+ fromColumns = unreify . gfromColumns . hreify
62+ toColumns = hunreify . gtoColumns . reify
13263
13364
13465-- | This type class allows you to define custom 'Table's using higher-kinded
@@ -174,876 +105,88 @@ instance TableHelper Name where
174105-- deriving ( GHC.Generics.Generic, Rel8able )
175106-- @
176107type Rel8able :: KTable -> Constraint
177−class HTable (GRep t) => Rel8able t where
178− type GRep t :: K.HTable
179−
180− fromAggregateColumns :: GRep t (Col Aggregate) -> t Aggregate
181− toAggregateColumns :: t Aggregate -> GRep t (Col Aggregate)
182−
183− fromExprColumns :: GRep t (Col Expr) -> t Expr
184− toExprColumns :: t Expr -> GRep t (Col Expr)
185−
186− fromInsertColumns :: GRep t (Col Insert) -> t Insert
187− toInsertColumns :: t Insert -> GRep t (Col Insert)
188−
189− fromIdentityColumns :: GRep t (Col Identity) -> t Identity
190− toIdentityColumns :: t Identity -> GRep t (Col Identity)
191−
192− fromNameColumns :: GRep t (Col Name) -> t Name
193− toNameColumns :: t Name -> GRep t (Col Name)
194−
195− type GRep t = GColumns (Rep (t Structure))
196−
197− default fromAggregateColumns ::
198− ( Generic (t Aggregate)
199− , GColumns (Rep (t Structure)) ~ GRep t
200− , GRel8able Aggregate (Rep (t Structure)) (Rep (t Aggregate))
201− ) => GRep t (Col Aggregate) -> t Aggregate
202− fromAggregateColumns = to . fromGColumns @_ @(Rep (t Structure))
203−
204− default toAggregateColumns ::
205− ( Generic (t Aggregate)
206− , GColumns (Rep (t Structure)) ~ GRep t
207− , GRel8able Aggregate (Rep (t Structure)) (Rep (t Aggregate))
208− ) => t Aggregate -> GRep t (Col Aggregate)
209− toAggregateColumns = toGColumns @_ @(Rep (t Structure)) . from
210−
211− default fromExprColumns ::
212− ( Generic (t Expr)
213− , GColumns (Rep (t Structure)) ~ GRep t
214− , GRel8able Expr (Rep (t Structure)) (Rep (t Expr))
215− ) => GRep t (Col Expr) -> t Expr
216− fromExprColumns = to . fromGColumns @_ @(Rep (t Structure))
108+class Rel8able t where
109+ gfromColumns :: (Labelable context, Reifiable context)
110+ => GRep context t (Col (Reify context)) -> t (Reify context)
217111
218− default toExprColumns ::
219− ( Generic (t Expr)
220− , GColumns (Rep (t Structure)) ~ GRep t
221− , GRel8able Expr (Rep (t Structure)) (Rep (t Expr))
222− ) => t Expr -> GRep t (Col Expr)
223− toExprColumns = toGColumns @_ @(Rep (t Structure)) . from
112+ gtoColumns :: (Labelable context, Reifiable context)
113+ => t (Reify context) -> GRep context t (Col (Reify context))
224114
225− default fromInsertColumns ::
226− ( Generic (t Insert)
227− , GColumns (Rep (t Structure)) ~ GRep t
228− , GRel8able Insert (Rep (t Structure)) (Rep (t Insert))
229− ) => GRep t (Col Insert) -> t Insert
230− fromInsertColumns = to . fromGColumns @_ @(Rep (t Structure))
115+ default gfromColumns :: forall context.
116+ ( Generic (t (Reify context))
117+ , GRel8able context (Rep (t (Reify context)))
118+ ) => GRep context t (Col (Reify context)) -> t (Reify context)
119+ gfromColumns = to . fromGColumns @_ @(Rep (t (Reify context)))
231120
232− default toInsertColumns ::
233− ( Generic (t Insert)
234− , GColumns (Rep (t Structure)) ~ GRep t
235− , GRel8able Insert (Rep (t Structure)) (Rep (t Insert))
236− ) => t Insert -> GRep t (Col Insert)
237− toInsertColumns = toGColumns @_ @(Rep (t Structure)) . from
121+ default gtoColumns :: forall context.
122+ ( Generic (t (Reify context))
123+ , GRel8able context (Rep (t (Reify context)))
124+ ) => t (Reify context) -> GRep context t (Col (Reify context))
125+ gtoColumns = toGColumns @_ @(Rep (t (Reify context))) . from
238126
239− default fromIdentityColumns ::
240− ( Generic (t Identity)
241− , GColumns (Rep (t Structure)) ~ GRep t
242− , GRel8able Identity (Rep (t Structure)) (Rep (t Identity))
243− ) => GRep t (Col Identity) -> t Identity
244− fromIdentityColumns = to . fromGColumns @_ @(Rep (t Structure))
245127
246− default toIdentityColumns ::
247− ( Generic (t Identity)
248− , GColumns (Rep (t Structure)) ~ GRep t
249− , GRel8able Identity (Rep (t Structure)) (Rep (t Identity))
250− ) => t Identity -> GRep t (Col Identity)
251− toIdentityColumns = toGColumns @_ @(Rep (t Structure)) . from
252−
253− default fromNameColumns ::
254− ( Generic (t Name)
255− , GColumns (Rep (t Structure)) ~ GRep t
256− , GRel8able Name (Rep (t Structure)) (Rep (t Name))
257− ) => GRep t (Col Name) -> t Name
258− fromNameColumns = to . fromGColumns @_ @(Rep (t Structure))
259−
260− default toNameColumns ::
261− ( Generic (t Name)
262− , GColumns (Rep (t Structure)) ~ GRep t
263− , GRel8able Name (Rep (t Structure)) (Rep (t Name))
264− ) => t Name -> GRep t (Col Name)
265− toNameColumns = toGColumns @_ @(Rep (t Structure)) . from
128+type GRep :: K.Context -> K.Table -> K.HTable
129+type GRep context t = GColumns (Rep (t (Reify context)))
266130
267131
268132type GColumns :: (Type -> Type) -> K.HTable
269−type family GColumns structure where
270− GColumns (M1 D _ structure) = GColumns structure
271− GColumns (M1 C _ structure) = GColumns structure
272− GColumns (a :*: b) = HPair (GColumns a) (GColumns b)
273− GColumns (M1 S ('MetaSel ('Just label) _ _ _) (K1 _ structure)) =
274− K1Columns label structure
133+type family GColumns rep where
134+ GColumns (M1 D _ rep) = GColumns rep
135+ GColumns (M1 G.C _ rep) = GColumns rep
136+ GColumns (rep1 :*: rep2) = HPair (GColumns rep1) (GColumns rep2)
137+ GColumns (M1 S ('MetaSel ('Just label) _ _ _) (K1 _ a)) =
138+ HLabel label (Columns a)
275139
276140
277−type GRel8able :: K.Context -> (Type -> Type) -> (Type -> Type) -> Constraint
278−class GRel8able context structure rep where
279− fromGColumns :: GColumns structure (Col context) -> rep x
280− toGColumns :: rep x -> GColumns structure (Col context)
141+type GRel8able :: K.Context -> (Type -> Type) -> Constraint
142+class GRel8able context rep where
143+ fromGColumns :: GColumns rep (Col (Reify context)) -> rep x
144+ toGColumns :: rep x -> GColumns rep (Col (Reify context))
281145
282146
283−instance GRel8able context structure rep => GRel8able context (M1 D c structure) (M1 D c rep) where
284− fromGColumns = M1 . fromGColumns @context @structure @rep
285− toGColumns (M1 a) = toGColumns @context @structure @rep a
147+instance GRel8able context rep => GRel8able context (M1 D c rep) where
148+ fromGColumns = M1 . fromGColumns @context @rep
149+ toGColumns (M1 a) = toGColumns @context @rep a
286150
287151
288−instance GRel8able context structure rep => GRel8able context (M1 C c structure) (M1 C c rep) where
289− fromGColumns = M1 . fromGColumns @context @structure @rep
290− toGColumns (M1 a) = toGColumns @context @structure @rep a
152+instance GRel8able context rep => GRel8able context (M1 G.C c rep) where
153+ fromGColumns = M1 . fromGColumns @context @rep
154+ toGColumns (M1 a) = toGColumns @context @rep a
291155
292156
293−instance (GRel8able context structure1 rep1, GRel8able context structure2 rep2) =>
294− GRel8able context (structure1 :*: structure2) (rep1 :*: rep2)
157+instance (GRel8able context rep1, GRel8able context rep2) =>
158+ GRel8able context (rep1 :*: rep2)
295159 where
296160 fromGColumns (HPair a b) =
297− fromGColumns @context @structure1 @rep1 a :*:
298− fromGColumns @context @structure2 @rep2 b
161+ fromGColumns @context @rep1 a :*: fromGColumns @context @rep2 b
299162 toGColumns (a :*: b) =
300− HPair
301− (toGColumns @context @structure1 @rep1 a)
302− (toGColumns @context @structure2 @rep2 b)
303−
304−
305−instance
306− ( K1Table label context isStructure structure a
307− , meta ~ 'MetaSel ('Just label) _su _ss _ds
308− , structureK1 ~ K1 i structure
309− , k1 ~ K1 i a
310− ) => GRel8able context (M1 S meta structureK1) (M1 S meta k1)
311− where
312− fromGColumns = M1 . K1 . fromK1Columns @label @_ @_ @structure
313− toGColumns (M1 (K1 a)) = toK1Columns @label @_ @_ @structure a
314−
315−
316−type K1Columns :: Symbol -> Type -> K.HTable
317−type family K1Columns label structure where
318− K1Columns label (Shape1 'Column ('Spec '[] necessity a)) =
319− HIdentity ('Spec '[label] necessity a)
320− K1Columns _label (Shape1 'Column ('Spec (label ': labels) necessity a)) =
321− HIdentity ('Spec (label ': labels) necessity a)
322− K1Columns label (Shape2 'Either a b) =
323− HLabel label (HEitherTable (K1Columns "Left" a) (K1Columns "Right" b))
324− K1Columns label (Shape1 'List a) = HListTable (K1Columns label a)
325− K1Columns label (Shape1 'Maybe a) = HLabel label (HMaybeTable (K1Columns "Just" a))
326− K1Columns label (Shape1 'NonEmpty a) = HNonEmptyTable (K1Columns label a)
327− K1Columns label (Shape2 'These a b) =
328− HLabel label (HTheseTable (K1Columns "Here" a) (K1Columns "There" b))
329− K1Columns label (a, b) =
330− HLabel label
331− (HPair
332− (K1Columns "fst" a)
333− (K1Columns "snd" b))
334− K1Columns label (a, b, c) =
335− HLabel label
336− (HTrio
337− (K1Columns "fst" a)
338− (K1Columns "snd" b)
339− (K1Columns "trd" c))
340− K1Columns label (a, b, c, d) =
341− HLabel label
342− (HQuartet
343− (K1Columns "fst" a)
344− (K1Columns "snd" b)
345− (K1Columns "trd" c)
346− (K1Columns "frt" d))
347− K1Columns label (a, b, c, d, e) =
348− HLabel label
349− (HQuintet
350− (K1Columns "fst" a)
351− (K1Columns "snd" b)
352− (K1Columns "trd" c)
353− (K1Columns "frt" d)
354− (K1Columns "fft" e))
355− K1Columns label a = HLabel label (Columns a)
356−
357−
358−type K1Table :: Symbol -> K.Context -> Bool -> Type -> Type -> Constraint
359−class isStructure ~ IsStructure structure =>
360− K1Table label context isStructure structure a
361− where
362− fromK1Columns :: K1Columns label structure (Col context) -> a
363− toK1Columns :: a -> K1Columns label structure (Col context)
364−
365−
366−instance
367− ( x ~ Field Aggregate '[] necessity a
368− ) => K1Table label Aggregate 'True (Shape1 'Column ('Spec '[] necessity a)) x
369− where
370− fromK1Columns (HIdentity (Aggregation a)) = a
371− toK1Columns = HIdentity . Aggregation
372− {-# INLINABLE fromK1Columns #-}
373− {-# INLINABLE toK1Columns #-}
374−
375−
376−instance
377− ( x ~ Field Aggregate (label ': labels) necessity a
378− ) => K1Table _label Aggregate 'True (Shape1 'Column ('Spec (label ': labels) necessity a)) x
379− where
380− fromK1Columns (HIdentity (Aggregation a)) = a
381− toK1Columns = HIdentity . Aggregation
382− {-# INLINABLE fromK1Columns #-}
383− {-# INLINABLE toK1Columns #-}
384−
385−
386−instance
387− ( x ~ Field Expr '[] necessity a
388− ) => K1Table label Expr 'True (Shape1 'Column ('Spec '[] necessity a)) x
389− where
390− fromK1Columns (HIdentity (DB a)) = a
391− toK1Columns = HIdentity . DB
392− {-# INLINABLE fromK1Columns #-}
393− {-# INLINABLE toK1Columns #-}
394−
395−
396−instance
397− ( x ~ Field Expr (label ': labels) necessity a
398− ) => K1Table _label Expr 'True (Shape1 'Column ('Spec (label ': labels) necessity a)) x
399− where
400− fromK1Columns (HIdentity (DB a)) = a
401− toK1Columns = HIdentity . DB
402− {-# INLINABLE fromK1Columns #-}
403− {-# INLINABLE toK1Columns #-}
163+ HPair (toGColumns @context @rep1 a) (toGColumns @context @rep2 b)
404164
405165
406166instance
407− ( x ~ Field Insert '[] necessity a
408− , KnownNecessity necessity
409− ) => K1Table label Insert 'True (Shape1 'Column ('Spec '[] necessity a)) x
410− where
411− fromK1Columns (HIdentity insert) = case insert of
412− RequiredInsert a -> a
413− OptionalInsert ma -> ma
414− toK1Columns a = HIdentity $ case necessitySing @necessity of
415− SRequired -> RequiredInsert a
416− SOptional -> OptionalInsert a
417− {-# INLINABLE fromK1Columns #-}
418− {-# INLINABLE toK1Columns #-}
419−
420−
421−instance
422− ( x ~ Field Insert (label ': labels) necessity a
423− , KnownNecessity necessity
424− ) => K1Table _label Insert 'True (Shape1 'Column ('Spec (label ': labels) necessity a)) x
425− where
426− fromK1Columns (HIdentity insert) = case insert of
427− RequiredInsert a -> a
428− OptionalInsert ma -> ma
429− toK1Columns a = HIdentity $ case necessitySing @necessity of
430− SRequired -> RequiredInsert a
431− SOptional -> OptionalInsert a
432− {-# INLINABLE fromK1Columns #-}
433− {-# INLINABLE toK1Columns #-}
434−
435−
436−instance
437− ( x ~ Field Identity '[] necessity a
438− ) => K1Table label Identity 'True (Shape1 'Column ('Spec '[] necessity a)) x
439− where
440− fromK1Columns (HIdentity (Result a)) = a
441− toK1Columns = HIdentity . Result
442− {-# INLINABLE fromK1Columns #-}
443− {-# INLINABLE toK1Columns #-}
444−
445−
446−instance
447− ( x ~ Field Identity (label ': labels) necessity a
448− ) => K1Table _label Identity 'True (Shape1 'Column ('Spec (label ': labels) necessity a)) x
449− where
450− fromK1Columns (HIdentity (Result a)) = a
451− toK1Columns = HIdentity . Result
452− {-# INLINABLE fromK1Columns #-}
453− {-# INLINABLE toK1Columns #-}
454−
455−
456−instance
457− ( x ~ Field Name '[] necessity a
458− ) => K1Table _label Name 'True (Shape1 'Column ('Spec (label ': labels) necessity a)) x
459− where
460− fromK1Columns (HIdentity (NameCol a)) = Name a
461− toK1Columns (Name a) = HIdentity (NameCol a)
462− {-# INLINABLE fromK1Columns #-}
463− {-# INLINABLE toK1Columns #-}
464−
465−
466−instance
467− ( x ~ Field Name (label ': labels) necessity a
468− ) => K1Table label Name 'True (Shape1 'Column ('Spec '[] necessity a)) x
469− where
470− fromK1Columns = Name . (\(NameCol a) -> a) . unlabeler . unHIdentity
471− toK1Columns = HIdentity . labeler . NameCol . (\(Name a) -> a)
472− {-# INLINABLE fromK1Columns #-}
473− {-# INLINABLE toK1Columns #-}
474−
475−
476−instance
477− ( HTable (K1Columns "Left" structure1)
478− , HTable (K1Columns "Right" structure2)
479− , K1Table "Left" Aggregate (IsStructure structure1) structure1 a
480− , K1Table "Right" Aggregate (IsStructure structure2) structure2 b
481− , e ~ EitherTable a b
482− , KnownSymbol label
483− ) => K1Table label Aggregate 'True (Shape2 'Either structure1 structure2) e
484− where
485− fromK1Columns =
486− fromColumns2
487− (fromK1Columns @"Left" @_ @_ @structure1)
488− (fromK1Columns @"Right" @_ @_ @structure2) .
489− hunlabel unlabeler
490− toK1Columns =
491− hlabel labeler .
492− toColumns2
493− (toK1Columns @"Left" @_ @_ @structure1)
494− (toK1Columns @"Right" @_ @_ @structure2)
495− {-# INLINABLE fromK1Columns #-}
496− {-# INLINABLE toK1Columns #-}
497−
498−
499−instance
500− ( HTable (K1Columns "Left" structure1)
501− , HTable (K1Columns "Right" structure2)
502− , K1Table "Left" Expr (IsStructure structure1) structure1 a
503− , K1Table "Right" Expr (IsStructure structure2) structure2 b
504− , e ~ EitherTable a b
505− , KnownSymbol label
506− ) => K1Table label Expr 'True (Shape2 'Either structure1 structure2) e
507− where
508− fromK1Columns =
509− fromColumns2
510− (fromK1Columns @"Left" @_ @_ @structure1)
511− (fromK1Columns @"Right" @_ @_ @structure2) .
512− hunlabel unlabeler
513− toK1Columns =
514− hlabel labeler .
515− toColumns2
516− (toK1Columns @"Left" @_ @_ @structure1)
517− (toK1Columns @"Right" @_ @_ @structure2)
518− {-# INLINABLE fromK1Columns #-}
519− {-# INLINABLE toK1Columns #-}
520−
521−
522−instance
523− ( HTable (K1Columns "Left" structure1)
524− , HTable (K1Columns "Right" structure2)
525− , K1Table "Left" Insert (IsStructure structure1) structure1 a
526− , K1Table "Right" Insert (IsStructure structure2) structure2 b
527− , e ~ EitherTable a b
528− , KnownSymbol label
529− ) => K1Table label Insert 'True (Shape2 'Either structure1 structure2) e
530− where
531− fromK1Columns =
532− fromColumns2
533− (fromK1Columns @"Left" @_ @_ @structure1)
534− (fromK1Columns @"Right" @_ @_ @structure2) .
535− hunlabel unlabeler
536− toK1Columns =
537− hlabel labeler .
538− toColumns2
539− (toK1Columns @"Left" @_ @_ @structure1)
540− (toK1Columns @"Right" @_ @_ @structure2)
541− {-# INLINABLE fromK1Columns #-}
542− {-# INLINABLE toK1Columns #-}
543−
544−
545−instance
546− ( HTable (K1Columns "Left" structure1)
547− , HTable (K1Columns "Right" structure2)
548− , K1Table "Left" Identity (IsStructure structure1) structure1 a
549− , K1Table "Right" Identity (IsStructure structure2) structure2 b
550− , e ~ Either a b
551− , KnownSymbol label
552− ) => K1Table label Identity 'True (Shape2 'Either structure1 structure2) e
553− where
554− fromK1Columns
555− = bimap
556− (fromK1Columns @"Left" @_ @_ @structure1)
557− (fromK1Columns @"Right" @_ @_ @structure2)
558− . fromHEitherTable
559− . hunlabel unlabeler
560− toK1Columns
561− = hlabel labeler
562− . toHEitherTable
563− . bimap
564− (toK1Columns @"Left" @_ @_ @structure1)
565− (toK1Columns @"Right" @_ @_ @structure2)
566− {-# INLINABLE fromK1Columns #-}
567− {-# INLINABLE toK1Columns #-}
568−
569−
570−instance
571− ( HTable (K1Columns "Left" structure1)
572− , HTable (K1Columns "Right" structure2)
573− , K1Table "Left" Name (IsStructure structure1) structure1 a
574− , K1Table "Right" Name (IsStructure structure2) structure2 b
575− , e ~ EitherTable a b
576− , KnownSymbol label
577− ) => K1Table label Name 'True (Shape2 'Either structure1 structure2) e
578− where
579− fromK1Columns =
580− fromColumns2
581− (fromK1Columns @"Left" @_ @_ @structure1)
582− (fromK1Columns @"Right" @_ @_ @structure2) .
583− hunlabel unlabeler
584− toK1Columns =
585− hlabel labeler .
586− toColumns2
587− (toK1Columns @"Left" @_ @_ @structure1)
588− (toK1Columns @"Right" @_ @_ @structure2)
589− {-# INLINABLE fromK1Columns #-}
590− {-# INLINABLE toK1Columns #-}
591−
592−
593−instance
594− ( Table Aggregate a
595− , K1Columns label structure ~ HLabel label (Columns a)
596− , as ~ ListTable a
597− , KnownSymbol label
598− ) => K1Table label Aggregate 'True (Shape1 'List structure) as
599− where
600− fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
601− toK1Columns = hrelabel (hlabel hlabeler) . toColumns
602− {-# INLINABLE fromK1Columns #-}
603− {-# INLINABLE toK1Columns #-}
604−
605−
606−instance
607− ( Table Expr a
608− , K1Columns label structure ~ HLabel label (Columns a)
609− , as ~ ListTable a
610− , KnownSymbol label
611− ) => K1Table label Expr 'True (Shape1 'List structure) as
612− where
613− fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
614− toK1Columns = hrelabel (hlabel hlabeler) . toColumns
615− {-# INLINABLE fromK1Columns #-}
616− {-# INLINABLE toK1Columns #-}
617−
618−
619−instance
620− ( Table Insert a
621− , K1Columns label structure ~ HLabel label (Columns a)
622− , as ~ ListTable a
623− , KnownSymbol label
624− ) => K1Table label Insert 'True (Shape1 'List structure) as
625− where
626− fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
627− toK1Columns = hrelabel (hlabel hlabeler) . toColumns
628− {-# INLINABLE fromK1Columns #-}
629− {-# INLINABLE toK1Columns #-}
630−
631−
632−instance
633− ( K1Table label Identity (IsStructure structure) structure a
634− , HTable (K1Columns label structure)
635− , as ~ [a]
636− ) => K1Table label Identity 'True (Shape1 'List structure) as
637− where
638− fromK1Columns = fmap (fromK1Columns @label @_ @_ @structure) . fromHListTable
639− toK1Columns = toHListTable . fmap (toK1Columns @label @_ @_ @structure)
640− {-# INLINABLE fromK1Columns #-}
641− {-# INLINABLE toK1Columns #-}
642−
643−
644−instance
645− ( Table Name a
646− , K1Columns label structure ~ HLabel label (Columns a)
647− , as ~ ListTable a
648− , KnownSymbol label
649− ) => K1Table label Name 'True (Shape1 'List structure) as
650− where
651− fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
652− toK1Columns = hrelabel (hlabel hlabeler) . toColumns
653− {-# INLINABLE fromK1Columns #-}
654− {-# INLINABLE toK1Columns #-}
655−
656−
657−instance
658− ( HTable (K1Columns "Just" structure)
659− , K1Table "Just" Aggregate (IsStructure structure) structure a
660− , ma ~ MaybeTable a
661− , KnownSymbol label
662− ) => K1Table label Aggregate 'True (Shape1 'Maybe structure) ma
663− where
664− fromK1Columns =
665− fromColumns1 (fromK1Columns @"Just" @_ @_ @structure) .
666− hunlabel unlabeler
667− toK1Columns =
668− hlabel labeler .
669− toColumns1 (toK1Columns @"Just" @_ @_ @structure)
670− {-# INLINABLE fromK1Columns #-}
671− {-# INLINABLE toK1Columns #-}
672−
673−
674−instance
675− ( HTable (K1Columns "Just" structure)
676− , K1Table "Just" Expr (IsStructure structure) structure a
677− , ma ~ MaybeTable a
678− , KnownSymbol label
679− ) => K1Table label Expr 'True (Shape1 'Maybe structure) ma
680− where
681− fromK1Columns =
682− fromColumns1 (fromK1Columns @"Just" @_ @_ @structure) .
683− hunlabel unlabeler
684− toK1Columns =
685− hlabel labeler .
686− toColumns1 (toK1Columns @"Just" @_ @_ @structure)
687− {-# INLINABLE fromK1Columns #-}
688− {-# INLINABLE toK1Columns #-}
689−
690−
691−instance
692− ( HTable (K1Columns "Just" structure)
693− , K1Table "Just" Insert (IsStructure structure) structure a
694− , ma ~ MaybeTable a
695− , KnownSymbol label
696− ) => K1Table label Insert 'True (Shape1 'Maybe structure) ma
697− where
698− fromK1Columns =
699− fromColumns1 (fromK1Columns @"Just" @_ @_ @structure) .
700− hunlabel unlabeler
701− toK1Columns =
702− hlabel labeler .
703− toColumns1 (toK1Columns @"Just" @_ @_ @structure)
704− {-# INLINABLE fromK1Columns #-}
705− {-# INLINABLE toK1Columns #-}
706−
707−
708−instance
709− ( HTable (K1Columns "Just" structure)
710− , K1Table "Just" Identity (IsStructure structure) structure a
711− , ma ~ Maybe a
712− , KnownSymbol label
713− ) => K1Table label Identity 'True (Shape1 'Maybe structure) ma
714− where
715− fromK1Columns
716− = fmap (fromK1Columns @"Just" @_ @_ @structure)
717− . fromHMaybeTable
718− . hunlabel unlabeler
719− toK1Columns
720− = hlabel labeler
721− . toHMaybeTable
722− . fmap (toK1Columns @"Just" @_ @_ @structure)
723− {-# INLINABLE fromK1Columns #-}
724− {-# INLINABLE toK1Columns #-}
725−
726−
727−instance
728− ( HTable (K1Columns "Just" structure)
729− , K1Table "Just" Name (IsStructure structure) structure a
730− , ma ~ MaybeTable a
731− , KnownSymbol label
732− ) => K1Table label Name 'True (Shape1 'Maybe structure) ma
733− where
734− fromK1Columns =
735− fromColumns1 (fromK1Columns @"Just" @_ @_ @structure) .
736− hunlabel unlabeler
737− toK1Columns =
738− hlabel labeler .
739− toColumns1 (toK1Columns @"Just" @_ @_ @structure)
740− {-# INLINABLE fromK1Columns #-}
741− {-# INLINABLE toK1Columns #-}
742−
743−
744−instance
745− ( Table Aggregate a
746− , K1Columns label structure ~ HLabel label (Columns a)
747− , as ~ NonEmptyTable a
748− , KnownSymbol label
749− ) => K1Table label Aggregate 'True (Shape1 'NonEmpty structure) as
750− where
751− fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
752− toK1Columns = hrelabel (hlabel hlabeler) . toColumns
753− {-# INLINABLE fromK1Columns #-}
754− {-# INLINABLE toK1Columns #-}
755−
756−
757−instance
758− ( Table Expr a
759− , K1Columns label structure ~ HLabel label (Columns a)
760− , as ~ NonEmptyTable a
761− , KnownSymbol label
762− ) => K1Table label Expr 'True (Shape1 'NonEmpty structure) as
763− where
764− fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
765− toK1Columns = hrelabel (hlabel hlabeler) . toColumns
766− {-# INLINABLE fromK1Columns #-}
767− {-# INLINABLE toK1Columns #-}
768−
769−
770−instance
771− ( Table Insert a
772− , K1Columns label structure ~ HLabel label (Columns a)
773− , as ~ NonEmptyTable a
774− , KnownSymbol label
775− ) => K1Table label Insert 'True (Shape1 'NonEmpty structure) as
776− where
777− fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
778− toK1Columns = hrelabel (hlabel hlabeler) . toColumns
779− {-# INLINABLE fromK1Columns #-}
780− {-# INLINABLE toK1Columns #-}
781−
782−
783−instance
784− ( K1Table label Identity (IsStructure structure) structure a
785− , HTable (K1Columns label structure)
786− , as ~ NonEmpty a
787− ) => K1Table label Identity 'True (Shape1 'NonEmpty structure) as
788− where
789− fromK1Columns = fmap (fromK1Columns @label @_ @_ @structure) . fromHNonEmptyTable
790− toK1Columns = toHNonEmptyTable . fmap (toK1Columns @label @_ @_ @structure)
791− {-# INLINABLE fromK1Columns #-}
792− {-# INLINABLE toK1Columns #-}
793−
794−
795−instance
796− ( Table Name a
797− , K1Columns label structure ~ HLabel label (Columns a)
798− , as ~ NonEmptyTable a
799− , KnownSymbol label
800− ) => K1Table label Name 'True (Shape1 'NonEmpty structure) as
801− where
802− fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
803− toK1Columns = hrelabel (hlabel hlabeler) . toColumns
804− {-# INLINABLE fromK1Columns #-}
805− {-# INLINABLE toK1Columns #-}
806−
807−
808−instance
809− ( HTable (K1Columns "Here" structure1)
810− , HTable (K1Columns "There" structure2)
811− , K1Table "Here" Aggregate (IsStructure structure1) structure1 a
812− , K1Table "There" Aggregate (IsStructure structure2) structure2 b
813− , e ~ TheseTable a b
814− , KnownSymbol label
815− ) => K1Table label Aggregate 'True (Shape2 'These structure1 structure2) e
816− where
817− fromK1Columns =
818− fromColumns2
819− (fromK1Columns @"Here" @_ @_ @structure1)
820− (fromK1Columns @"There" @_ @_ @structure2) .
821− hunlabel unlabeler
822− toK1Columns =
823− hlabel labeler .
824− toColumns2
825− (toK1Columns @"Here" @_ @_ @structure1)
826− (toK1Columns @"There" @_ @_ @structure2)
827− {-# INLINABLE fromK1Columns #-}
828− {-# INLINABLE toK1Columns #-}
829−
830−
831−instance
832− ( HTable (K1Columns "Here" structure1)
833− , HTable (K1Columns "There" structure2)
834− , K1Table "Here" Expr (IsStructure structure1) structure1 a
835− , K1Table "There" Expr (IsStructure structure2) structure2 b
836− , e ~ TheseTable a b
837− , KnownSymbol label
838− ) => K1Table label Expr 'True (Shape2 'These structure1 structure2) e
839− where
840− fromK1Columns =
841− fromColumns2
842− (fromK1Columns @"Here" @_ @_ @structure1)
843− (fromK1Columns @"There" @_ @_ @structure2) .
844− hunlabel unlabeler
845− toK1Columns =
846− hlabel labeler .
847− toColumns2
848− (toK1Columns @"Here" @_ @_ @structure1)
849− (toK1Columns @"There" @_ @_ @structure2)
850− {-# INLINABLE fromK1Columns #-}
851− {-# INLINABLE toK1Columns #-}
852−
853−
854−instance
855− ( HTable (K1Columns "Here" structure1)
856− , HTable (K1Columns "There" structure2)
857− , K1Table "Here" Insert (IsStructure structure1) structure1 a
858− , K1Table "There" Insert (IsStructure structure2) structure2 b
859− , e ~ TheseTable a b
860− , KnownSymbol label
861− ) => K1Table label Insert 'True (Shape2 'These structure1 structure2) e
862− where
863− fromK1Columns =
864− fromColumns2
865− (fromK1Columns @"Here" @_ @_ @structure1)
866− (fromK1Columns @"There" @_ @_ @structure2) .
867− hunlabel unlabeler
868− toK1Columns =
869− hlabel labeler .
870− toColumns2
871− (toK1Columns @"Here" @_ @_ @structure1)
872− (toK1Columns @"There" @_ @_ @structure2)
873− {-# INLINABLE fromK1Columns #-}
874− {-# INLINABLE toK1Columns #-}
875−
876−
877−instance
878− ( HTable (K1Columns "Here" structure1)
879− , HTable (K1Columns "There" structure2)
880− , K1Table "Here" Identity (IsStructure structure1) structure1 a
881− , K1Table "There" Identity (IsStructure structure2) structure2 b
882− , e ~ These a b
883− , KnownSymbol label
884− ) => K1Table label Identity 'True (Shape2 'These structure1 structure2) e
885− where
886− fromK1Columns
887− = bimap
888− (fromK1Columns @"Here" @_ @_ @structure1)
889− (fromK1Columns @"There" @_ @_ @structure2)
890− . fromHTheseTable
891− . hunlabel unlabeler
892− toK1Columns
893− = hlabel labeler
894− . toHTheseTable
895− . bimap
896− (toK1Columns @"Here" @_ @_ @structure1)
897− (toK1Columns @"There" @_ @_ @structure2)
898− {-# INLINABLE fromK1Columns #-}
899− {-# INLINABLE toK1Columns #-}
900−
901−
902−instance
903− ( HTable (K1Columns "Here" structure1)
904− , HTable (K1Columns "There" structure2)
905− , K1Table "Here" Name (IsStructure structure1) structure1 a
906− , K1Table "There" Name (IsStructure structure2) structure2 b
907− , e ~ TheseTable a b
908− , KnownSymbol label
909− ) => K1Table label Name 'True (Shape2 'These structure1 structure2) e
910− where
911− fromK1Columns =
912− fromColumns2
913− (fromK1Columns @"Here" @_ @_ @structure1)
914− (fromK1Columns @"There" @_ @_ @structure2) .
915− hunlabel unlabeler
916− toK1Columns =
917− hlabel labeler .
918− toColumns2
919− (toK1Columns @"Here" @_ @_ @structure1)
920− (toK1Columns @"There" @_ @_ @structure2)
921− {-# INLINABLE fromK1Columns #-}
922− {-# INLINABLE toK1Columns #-}
923−
924−
925−instance
926− ( K1Table "fst" context (IsStructure structure1) structure1 a1
927− , K1Table "snd" context (IsStructure structure2) structure2 a2
928− , HTable (K1Columns "fst" structure1)
929− , HTable (K1Columns "snd" structure2)
930− , Labelable context
931− , a ~ (a1, a2)
932− , KnownSymbol label
933− ) => K1Table label context 'True (structure1, structure2) a
934− where
935− fromK1Columns (hunlabel unlabeler -> (HPair a b)) =
936− ( fromK1Columns @"fst" @_ @_ @structure1 a
937− , fromK1Columns @"snd" @_ @_ @structure2 b
938− )
939− toK1Columns (a, b) = hlabel labeler $ HPair
940− { hfst = toK1Columns @"fst" @_ @_ @structure1 a
941− , hsnd = toK1Columns @"snd" @_ @_ @structure2 b
942− }
943− {-# INLINABLE fromK1Columns #-}
944− {-# INLINABLE toK1Columns #-}
945−
946−
947−instance
948− ( K1Table "fst" context (IsStructure structure1) structure1 a1
949− , K1Table "snd" context (IsStructure structure2) structure2 a2
950− , K1Table "trd" context (IsStructure structure3) structure3 a3
951− , HTable (K1Columns "fst" structure1)
952− , HTable (K1Columns "snd" structure2)
953− , HTable (K1Columns "trd" structure3)
954− , Labelable context
955− , a ~ (a1, a2, a3)
956− , KnownSymbol label
957− ) => K1Table label context 'True (structure1, structure2, structure3) a
958− where
959− fromK1Columns (hunlabel unlabeler -> (HTrio a b c)) =
960− ( fromK1Columns @"fst" @_ @_ @structure1 a
961− , fromK1Columns @"snd" @_ @_ @structure2 b
962− , fromK1Columns @"trd" @_ @_ @structure3 c
963− )
964− toK1Columns (a, b, c) = hlabel labeler $ HTrio
965− { hfst = toK1Columns @"fst" @_ @_ @structure1 a
966− , hsnd = toK1Columns @"snd" @_ @_ @structure2 b
967− , htrd = toK1Columns @"trd" @_ @_ @structure3 c
968− }
969− {-# INLINABLE fromK1Columns #-}
970− {-# INLINABLE toK1Columns #-}
971−
972−
973−instance
974− ( K1Table "fst" context (IsStructure structure1) structure1 a1
975− , K1Table "snd" context (IsStructure structure2) structure2 a2
976− , K1Table "trd" context (IsStructure structure3) structure3 a3
977− , K1Table "frt" context (IsStructure structure3) structure4 a4
978− , HTable (K1Columns "fst" structure1)
979− , HTable (K1Columns "snd" structure2)
980− , HTable (K1Columns "trd" structure3)
981− , HTable (K1Columns "frt" structure4)
167+ ( Table (Reify context) a
982168 , Labelable context
983− , a ~ (a1, a2, a3, a4)
984169 , KnownSymbol label
985− ) => K1Table label context 'True (structure1, structure2, structure3, structure4) a
170+ , GColumns (M1 S meta k1) ~ HLabel label (Columns a)
171+ , meta ~ 'MetaSel ('Just label) _su _ss _ds
172+ , k1 ~ K1 i a
173+ ) => GRel8able context (M1 S meta k1)
986174 where
987− fromK1Columns (hunlabel unlabeler -> (HQuartet a b c d)) =
988− ( fromK1Columns @"fst" @_ @_ @structure1 a
989− , fromK1Columns @"snd" @_ @_ @structure2 b
990− , fromK1Columns @"trd" @_ @_ @structure3 c
991− , fromK1Columns @"frt" @_ @_ @structure4 d
992− )
993− toK1Columns (a, b, c, d) = hlabel labeler $ HQuartet
994− { hfst = toK1Columns @"fst" @_ @_ @structure1 a
995− , hsnd = toK1Columns @"snd" @_ @_ @structure2 b
996− , htrd = toK1Columns @"trd" @_ @_ @structure3 c
997− , hfrt = toK1Columns @"frt" @_ @_ @structure4 d
998− }
999− {-# INLINABLE fromK1Columns #-}
1000− {-# INLINABLE toK1Columns #-}
175+ fromGColumns = M1 . K1 . fromColumns . hunlabel unlabeler
176+ toGColumns (M1 (K1 a)) = hlabel labeler (toColumns a)
1001177
1002178
1003−instance
1004− ( K1Table "fst" context (IsStructure structure1) structure1 a1
1005− , K1Table "snd" context (IsStructure structure2) structure2 a2
1006− , K1Table "trd" context (IsStructure structure3) structure3 a3
1007− , K1Table "frt" context (IsStructure structure3) structure4 a4
1008− , K1Table "fft" context (IsStructure structure3) structure5 a5
1009− , HTable (K1Columns "fst" structure1)
1010− , HTable (K1Columns "snd" structure2)
1011− , HTable (K1Columns "trd" structure3)
1012− , HTable (K1Columns "frt" structure4)
1013− , HTable (K1Columns "fft" structure5)
1014− , Labelable context
1015− , a ~ (a1, a2, a3, a4, a5)
1016− , KnownSymbol label
1017− ) => K1Table label context 'True (structure1, structure2, structure3, structure4, structure5) a
1018− where
1019− fromK1Columns (hunlabel unlabeler -> (HQuintet a b c d e)) =
1020− ( fromK1Columns @"fst" @_ @_ @structure1 a
1021− , fromK1Columns @"snd" @_ @_ @structure2 b
1022− , fromK1Columns @"trd" @_ @_ @structure3 c
1023− , fromK1Columns @"frt" @_ @_ @structure4 d
1024− , fromK1Columns @"fft" @_ @_ @structure5 e
1025− )
1026− toK1Columns (a, b, c, d, e) = hlabel labeler $ HQuintet
1027− { hfst = toK1Columns @"fst" @_ @_ @structure1 a
1028− , hsnd = toK1Columns @"snd" @_ @_ @structure2 b
1029− , htrd = toK1Columns @"trd" @_ @_ @structure3 c
1030− , hfrt = toK1Columns @"frt" @_ @_ @structure4 d
1031− , hfft = toK1Columns @"fft" @_ @_ @structure5 e
1032− }
1033− {-# INLINABLE fromK1Columns #-}
1034− {-# INLINABLE toK1Columns #-}
179+reify ::
180+ (-- Rel8able t
181+ --, forall necessity a. Coercible (Field context necessity a) (AField context necessity a) => Coercible (t context) (t (Reify context))
182+ )
183+ => t context -> t (Reify context)
184+reify = unsafeCoerce
1035185
1036186
1037−instance
1038− ( IsStructure structure ~ 'False
1039− , K1Columns label structure ~ HLabel label (Columns structure)
1040− , Columns structure ~ Columns a
1041− , Labelable context
1042− , Table context a
1043− , KnownSymbol label
1044− ) => K1Table label context 'False structure a
1045− where
1046− fromK1Columns = fromColumns . hunlabel unlabeler
1047− toK1Columns = hlabel labeler . toColumns
1048− {-# INLINABLE fromK1Columns #-}
1049− {-# INLINABLE toK1Columns #-}
187+unreify ::
188+ (-- Rel8able t
189+ --, forall necessity a. Coercible (AField context necessity a) (Field context necessity a) => Coercible (t (Reify context)) (t context)
190+ )
191+ => t (Reify context) -> t context
192+unreify = unsafeCoerce
src/Rel8/Schema/Generic/Test.hs+4−5
@@ -4,8 +4,6 @@
44{-# language DerivingStrategies #-}
55{-# language DuplicateRecordFields #-}
66
7−{-# options_ghc -O0 #-}
8−
97module Rel8.Schema.Generic.Test
108 ( module Rel8.Schema.Generic.Test
119 )
@@ -17,6 +15,7 @@ import Prelude
1715
1816-- rel8
1917import Rel8.Schema.Column
18+import Rel8.Schema.Field
2019import Rel8.Schema.Generic
2120
2221-- text
@@ -24,7 +23,7 @@ import Data.Text ( Text )
2423
2524
2625data Table f = Table
27− { foo :: Column f (Label "blah" Bool)
26+ { foo :: Column f Bool
2827 , bar :: Column f (Maybe Bool)
2928 }
3029 deriving stock Generic
@@ -40,7 +39,7 @@ data TablePair f = TablePair
4039
4140
4241data TableMaybe f = TableMaybe
43− { foo :: Column f (Label "ABC" [Maybe Bool])
42+ { foo :: Column f [Maybe Bool]
4443 , bars :: HMaybe f (TablePair f, TablePair f)
4544 }
4645 deriving stock Generic
@@ -49,7 +48,7 @@ data TableMaybe f = TableMaybe
4948
5049data TableEither f = TableEither
5150 { foo :: Column f Bool
52− , bars :: HEither f (HMaybe f (TablePair f, TablePair f)) (Column f (Label "XYZ" Char))
51+ , bars :: HEither f (HMaybe f (TablePair f, TablePair f)) (Column f Char)
5352 }
5453 deriving stock Generic
5554 deriving anyclass Rel8able
src/Rel8/Schema/HTable/Either.hs+3−13
@@ -2,27 +2,22 @@
22{-# language DeriveAnyClass #-}
33{-# language DeriveGeneric #-}
44{-# language DerivingStrategies #-}
5−{-# language FlexibleInstances #-}
65{-# language StandaloneKindSignatures #-}
7−{-# language UndecidableInstances #-}
8−{-# language UndecidableSuperClasses #-}
96
107module Rel8.Schema.HTable.Either
118 ( HEitherTable(..)
12− , HEitherNullifiable
139 )
1410where
1511
1612-- base
17−import Data.Kind ( Constraint )
1813import GHC.Generics ( Generic )
1914import Prelude ()
2015
2116-- rel8
2217import Rel8.Kind.Necessity ( Necessity( Required ) )
23−import Rel8.Schema.Context.Nullify ( HNullifiable, HConstrainTag )
2418import Rel8.Schema.HTable ( HTable )
2519import Rel8.Schema.HTable.Identity ( HIdentity(..) )
20+import Rel8.Schema.HTable.Label ( HLabel )
2621import Rel8.Schema.HTable.Nullify ( HNullify )
2722import qualified Rel8.Schema.Kind as K
2823import Rel8.Schema.Spec ( Spec( Spec ) )
@@ -32,13 +27,8 @@ import Rel8.Type.Tag ( EitherTag )
3227type HEitherTable :: K.HTable -> K.HTable -> K.HTable
3328data HEitherTable left right context = HEitherTable
3429 { htag :: HIdentity ('Spec '["isRight"] 'Required EitherTag) context
35− , hleft :: HNullify left context
36− , hright :: HNullify right context
30+ , hleft :: HLabel "Left" (HNullify left) context
31+ , hright :: HLabel "Right" (HNullify right) context
3732 }
3833 deriving stock Generic
3934 deriving anyclass HTable
40−
41−
42−type HEitherNullifiable :: K.HContext -> Constraint
43−class (HNullifiable context, HConstrainTag context EitherTag) => HEitherNullifiable context
44−instance (HNullifiable context, HConstrainTag context EitherTag) => HEitherNullifiable context
src/Rel8/Schema/HTable/MapTable.hs+8−4
@@ -35,13 +35,15 @@ import Rel8.Schema.Dict ( Dict( Dict ) )
3535
3636
3737type HMapTable :: (a -> Exp b) -> ((a -> Type) -> Type) -> (b -> Type) -> Type
38−data HMapTable f t g where
39− HMapTable :: { unHMapTable :: t (Precompose f g) } -> HMapTable f t g
38+newtype HMapTable f t g = HMapTable
39+ { unHMapTable :: t (Precompose f g)
40+ }
4041
4142
4243type Precompose :: (a -> Exp b) -> (b -> Type) -> a -> Type
43−newtype Precompose f g x where
44− Precompose :: { precomposed :: g (Eval (f x)) } -> Precompose f g x
44+newtype Precompose f g x = Precompose
45+ { precomposed :: g (Eval (f x))
46+ }
4547
4648
4749type HMapTableField :: (Spec -> Exp a) -> K.HTable -> a -> Type
@@ -64,6 +66,7 @@ instance (HTable t, MapSpec f) => HTable (HMapTable f t) where
6466
6567 htraverse f (HMapTable x) =
6668 HMapTable <$> htraverse (fmap Precompose . f . precomposed) x
69+ {-# INLINABLE htraverse #-}
6770
6871 hdicts :: forall c. HConstrainTable (HMapTable f t) c => HMapTable f t (Dict c)
6972 hdicts =
@@ -73,6 +76,7 @@ instance (HTable t, MapSpec f) => HTable (HMapTable f t) where
7376
7477 hspecs =
7578 HMapTable $ htabulate $ Precompose . mapInfo @f . hfield hspecs
79+ {-# INLINABLE hspecs #-}
7680
7781
7882type MapSpec :: (Spec -> Exp Spec) -> Constraint
src/Rel8/Schema/HTable/Maybe.hs+3−13
@@ -2,42 +2,32 @@
22{-# language DeriveAnyClass #-}
33{-# language DeriveGeneric #-}
44{-# language DerivingStrategies #-}
5−{-# language FlexibleInstances #-}
65{-# language StandaloneKindSignatures #-}
7−{-# language UndecidableInstances #-}
8−{-# language UndecidableSuperClasses #-}
96
107module Rel8.Schema.HTable.Maybe
118 ( HMaybeTable(..)
12− , HMaybeNullifiable
139 )
1410where
1511
1612-- base
17−import Data.Kind ( Constraint )
1813import GHC.Generics ( Generic )
1914import Prelude
2015
2116-- rel8
2217import Rel8.Kind.Necessity ( Necessity( Required ) )
23−import Rel8.Schema.Context.Nullify ( HConstrainTag, HNullifiable )
2418import Rel8.Schema.HTable ( HTable )
2519import Rel8.Schema.HTable.Identity ( HIdentity(..) )
20+import Rel8.Schema.HTable.Label ( HLabel )
21+import Rel8.Schema.HTable.Nullify ( HNullify )
2622import qualified Rel8.Schema.Kind as K
2723import Rel8.Schema.Spec ( Spec( Spec ) )
2824import Rel8.Type.Tag ( MaybeTag )
29−import Rel8.Schema.HTable.Nullify ( HNullify )
3025
3126
3227type HMaybeTable :: K.HTable -> K.HTable
3328data HMaybeTable table context = HMaybeTable
3429 { htag :: HIdentity ('Spec '["isJust"] 'Required (Maybe MaybeTag)) context
35− , hjust :: HNullify table context
30+ , hjust :: HLabel "Just" (HNullify table) context
3631 }
3732 deriving stock Generic
3833 deriving anyclass HTable
39−
40−
41−type HMaybeNullifiable :: K.HContext -> Constraint
42−class (HNullifiable context, HConstrainTag context MaybeTag) => HMaybeNullifiable context
43−instance (HNullifiable context, HConstrainTag context MaybeTag) => HMaybeNullifiable context
src/Rel8/Schema/HTable/These.hs+3−2
@@ -17,6 +17,7 @@ import Prelude
1717import Rel8.Kind.Necessity ( Necessity( Required ) )
1818import Rel8.Schema.HTable ( HTable )
1919import Rel8.Schema.HTable.Identity ( HIdentity )
20+import Rel8.Schema.HTable.Label ( HLabel )
2021import Rel8.Schema.HTable.Nullify ( HNullify )
2122import qualified Rel8.Schema.Kind as K
2223import Rel8.Schema.Spec ( Spec( Spec ) )
@@ -26,9 +27,9 @@ import Rel8.Type.Tag ( MaybeTag )
2627type HTheseTable :: K.HTable -> K.HTable -> K.HTable
2728data HTheseTable here there context = HTheseTable
2829 { hhereTag :: HIdentity ('Spec '["hasHere"] 'Required (Maybe MaybeTag)) context
29− , hhere :: HNullify here context
30+ , hhere :: HLabel "Here" (HNullify here) context
3031 , hthereTag :: HIdentity ('Spec '["hasThere"] 'Required (Maybe MaybeTag)) context
31− , hthere :: HNullify there context
32+ , hthere :: HLabel "There" (HNullify there) context
3233 }
3334 deriving stock Generic
3435 deriving anyclass HTable
src/Rel8/Schema/HTable/Vectorize.hs−8
@@ -23,7 +23,6 @@ module Rel8.Schema.HTable.Vectorize
2323 ( HVectorize
2424 , hvectorize, hunvectorize
2525 , happend, hempty
26− , hrelabel
2726 )
2827where
2928
@@ -150,10 +149,3 @@ hempty empty = HVectorize $ htabulate $ \(HMapTableField field) -> case hfield h
150149instance HLabelable g => HLabelable (Precompose (Vectorize list) g) where
151150 hlabeler = Precompose . hlabeler . precomposed
152151 hunlabeler = Precompose . hunlabeler . precomposed
153−
154−
155−hrelabel :: HLabelable context
156− => (forall ctx. HLabelable ctx => t ctx -> u ctx)
157− -> HVectorize list t context
158− -> HVectorize list u context
159−hrelabel f (HVectorize (HMapTable table)) = HVectorize (HMapTable (f table))
src/Rel8/Schema/Insert.hs+2−2
@@ -15,8 +15,8 @@ module Rel8.Schema.Insert
1515 ( Insert(..)
1616 , OnConflict(..)
1717 , Col( RequiredInsert, OptionalInsert )
18− , Insertion(..)
1918 , Inserts
19+ , Insertion(..)
2020 )
2121where
2222
@@ -35,7 +35,7 @@ import Rel8.Schema.Context.Nullify
3535 ( Nullifiable, encodeTag, decodeTag, nullifier, unnullifier
3636 , runTag, unnull
3737 )
38−import Rel8.Schema.HTable.Type ( HType(HType) )
38+import Rel8.Schema.HTable.Type ( HType( HType ) )
3939import qualified Rel8.Schema.Kind as K
4040import Rel8.Schema.Name ( Name, Selects )
4141import Rel8.Schema.Null ( Sql )
src/Rel8/Schema/Structure.hs+3−40
@@ -1,54 +1,17 @@
11{-# language DataKinds #-}
22{-# language StandaloneKindSignatures #-}
3−{-# language PolyKinds #-}
4−{-# language TypeFamilies #-}
53
64module Rel8.Schema.Structure
75 ( Structure
8− , Shape( Column, Either, List, Maybe, NonEmpty, These )
9− , Shape1
10− , Shape2
11− , IsStructure
126 )
137where
148
159-- base
16−import Data.Kind ( Type )
17−import Prelude
10+import Prelude ()
1811
1912-- rel8
20−import qualified Rel8.Schema.Kind as K
21−import Rel8.Schema.Spec ( Spec )
13+import Rel8.Schema.Kind ( Context )
2214
2315
24−type Structure :: K.Context
16+type Structure :: Context
2517data Structure a
26−
27−
28−type Shape :: Type
29−data Shape
30− = Column Spec
31− | Either Type Type
32− | List Type
33− | Maybe Type
34− | NonEmpty Type
35− | These Type Type
36−
37−
38−type Shape1 :: (a -> Shape) -> a -> Type
39−data Shape1 shape a
40−
41−
42−type Shape2 :: (a -> b -> Shape) -> a -> b -> Type
43−data Shape2 shape a b
44−
45−
46−type IsStructure :: Type -> Bool
47−type family IsStructure a where
48− IsStructure (Shape1 _ _) = 'True
49− IsStructure (Shape2 _ _ _) = 'True
50− IsStructure (_, _) = 'True
51− IsStructure (_, _, _) = 'True
52− IsStructure (_, _, _, _) = 'True
53− IsStructure (_, _, _, _, _) = 'True
54− IsStructure _ = 'False
src/Rel8/Table.hs+163−3
@@ -3,8 +3,11 @@
33{-# language FlexibleContexts #-}
44{-# language FlexibleInstances #-}
55{-# language FunctionalDependencies #-}
6+{-# language LambdaCase #-}
7+{-# language NamedFieldPuns #-}
68{-# language StandaloneKindSignatures #-}
79{-# language TypeFamilies #-}
10+{-# language TypeOperators #-}
811{-# language UndecidableInstances #-}
912
1013module Rel8.Table
@@ -15,25 +18,39 @@ module Rel8.Table
1518where
1619
1720-- base
21+import Data.Functor ( ($>) )
1822import Data.Functor.Identity ( Identity( Identity ) )
1923import Data.Kind ( Constraint, Type )
20−import Prelude
24+import Data.List.NonEmpty ( NonEmpty )
25+import Prelude hiding ( null )
2126
2227-- rel8
2328import Rel8.Schema.Context ( Col(..) )
2429import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
2530import Rel8.Schema.HTable ( HTable )
31+import Rel8.Schema.HTable.Either ( HEitherTable(..) )
2632import Rel8.Schema.HTable.Identity ( HIdentity(..) )
2733import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
34+import Rel8.Schema.HTable.List ( HListTable )
35+import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
36+import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
37+import Rel8.Schema.HTable.Nullify ( hnulls, hnullify, hunnullify )
2838import Rel8.Schema.HTable.Pair ( HPair(..) )
2939import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
3040import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
41+import Rel8.Schema.HTable.These ( HTheseTable(..) )
3142import Rel8.Schema.HTable.Trio ( HTrio(..) )
3243import Rel8.Schema.HTable.Type ( HType( HType ) )
44+import Rel8.Schema.HTable.Vectorize ( hvectorize, hunvectorize )
3345import qualified Rel8.Schema.Kind as K
34−import Rel8.Schema.Null ( Sql )
35−import Rel8.Schema.Spec ( KnownSpec )
46+import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql )
47+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..), KnownSpec )
3648import Rel8.Type ( DBType )
49+import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), MaybeTag( IsJust ) )
50+
51+-- these
52+import Data.These ( These( This, That, These ) )
53+import Data.These.Combinators ( justHere, justThere )
3754
3855
3956-- | @Table@s are one of the foundational elements of Rel8, and describe data
@@ -85,6 +102,106 @@ instance Sql DBType a => Table Identity (Identity a) where
85102 fromColumns (HType (Result a)) = Identity a
86103
87104
105+instance (Table Identity a, Table Identity b) => Table Identity (Either a b)
106+ where
107+ type Columns (Either a b) = HEitherTable (Columns a) (Columns b)
108+ type Context (Either a b) = Identity
109+
110+ toColumns = \case
111+ Left table -> HEitherTable
112+ { htag = HIdentity (Result IsLeft)
113+ , hleft = hlabel labeler (hnullify nullifier (toColumns table))
114+ , hright = hlabel labeler (hnulls null)
115+ }
116+ Right table -> HEitherTable
117+ { htag = HIdentity (Result IsRight)
118+ , hleft = hlabel labeler (hnulls null)
119+ , hright = hlabel labeler (hnullify nullifier (toColumns table))
120+ }
121+
122+ fromColumns HEitherTable {htag, hleft, hright} = case htag of
123+ HIdentity (Result tag) -> case tag of
124+ IsLeft -> maybe err (Left . fromColumns) $ hunnullify unnullifier (hunlabel unlabeler hleft)
125+ IsRight -> maybe err (Right . fromColumns) $ hunnullify unnullifier (hunlabel unlabeler hright)
126+ where
127+ err = error "Either.fromColumns: mismatch between tag and data"
128+
129+
130+instance Table Identity a => Table Identity [a] where
131+ type Columns [a] = HListTable (Columns a)
132+ type Context [a] = Identity
133+
134+ toColumns = hvectorize vectorizer . fmap toColumns
135+ fromColumns = fmap fromColumns . hunvectorize unvectorizer
136+
137+
138+instance Table Identity a => Table Identity (Maybe a) where
139+ type Columns (Maybe a) = HMaybeTable (Columns a)
140+ type Context (Maybe a) = Identity
141+
142+ toColumns = \case
143+ Nothing -> HMaybeTable
144+ { htag = HIdentity (Result Nothing)
145+ , hjust = hlabel labeler (hnulls null)
146+ }
147+ Just table -> HMaybeTable
148+ { htag = HIdentity (Result (Just IsJust))
149+ , hjust = hlabel labeler (hnullify nullifier (toColumns table))
150+ }
151+
152+ fromColumns HMaybeTable {htag, hjust} = case htag of
153+ HIdentity (Result tag) -> tag $>
154+ case hunnullify unnullifier (hunlabel unlabeler hjust) of
155+ Nothing -> error "Maybe.fromColumns: mismatch between tag and data"
156+ Just just -> fromColumns just
157+
158+
159+instance Table Identity a => Table Identity (NonEmpty a) where
160+ type Columns (NonEmpty a) = HNonEmptyTable (Columns a)
161+ type Context (NonEmpty a) = Identity
162+
163+ toColumns = hvectorize vectorizer . fmap toColumns
164+ fromColumns = fmap fromColumns . hunvectorize unvectorizer
165+
166+
167+instance (Table Identity a, Table Identity b) => Table Identity (These a b)
168+ where
169+ type Columns (These a b) = HTheseTable (Columns a) (Columns b)
170+ type Context (These a b) = Identity
171+
172+ toColumns tables = HTheseTable
173+ { hhereTag = relabel hhereTag
174+ , hhere = hlabel labeler (hunlabel unlabeler (toColumns hhere))
175+ , hthereTag = relabel hthereTag
176+ , hthere = hlabel labeler (hunlabel unlabeler (toColumns hthere))
177+ }
178+ where
179+ HMaybeTable
180+ { htag = hhereTag
181+ , hjust = hhere
182+ } = toColumns (justHere tables)
183+ HMaybeTable
184+ { htag = hthereTag
185+ , hjust = hthere
186+ } = toColumns (justThere tables)
187+
188+ fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} =
189+ case (fromColumns mhere, fromColumns mthere) of
190+ (Just a, Nothing) -> This (fromColumns a)
191+ (Nothing, Just b) -> That (fromColumns b)
192+ (Just a, Just b) -> These (fromColumns a) (fromColumns b)
193+ _ -> error "These.fromColumns: mismatch between tags and data"
194+ where
195+ mhere = HMaybeTable
196+ { htag = relabel hhereTag
197+ , hjust = hlabel labeler (hunlabel unlabeler hhere)
198+ }
199+ mthere = HMaybeTable
200+ { htag = relabel hthereTag
201+ , hjust = hlabel labeler (hunlabel unlabeler hthere)
202+ }
203+
204+
88205instance
89206 ( Table context a, Table context b
90207 , Labelable context
@@ -192,3 +309,46 @@ instance
192309type Congruent :: Type -> Type -> Constraint
193310class Columns a ~ Columns b => Congruent a b
194311instance Columns a ~ Columns b => Congruent a b
312+
313+
314+null :: Col Identity ('Spec labels necessity (Maybe a))
315+null = Result Nothing
316+
317+
318+nullifier :: ()
319+ => SSpec ('Spec labels necessity a)
320+ -> Col Identity ('Spec labels necessity a)
321+ -> Col Identity ('Spec labels necessity (Nullify a))
322+nullifier SSpec {nullity} (Result a) = Result $ case nullity of
323+ Null -> a
324+ NotNull -> Just a
325+
326+
327+unnullifier :: ()
328+ => SSpec ('Spec labels necessity a)
329+ -> Col Identity ('Spec labels necessity (Nullify a))
330+ -> Maybe (Col Identity ('Spec labels necessity a))
331+unnullifier SSpec {nullity} (Result a) =
332+ case nullity of
333+ Null -> pure $ Result a
334+ NotNull -> Result <$> a
335+
336+
337+vectorizer :: Functor f
338+ => SSpec ('Spec labels necessity a)
339+ -> f (Col Identity ('Spec labels necessity a))
340+ -> Col Identity ('Spec labels necessity (f a))
341+vectorizer _ = Result . fmap (\(Result a) -> a)
342+
343+
344+unvectorizer :: Functor f
345+ => SSpec ('Spec labels necessity a)
346+ -> Col Identity ('Spec labels necessity (f a))
347+ -> f (Col Identity ('Spec labels necessity a))
348+unvectorizer _ (Result results) = Result <$> results
349+
350+
351+relabel :: ()
352+ => HIdentity ('Spec labels necessity a) (Col Identity)
353+ -> HIdentity ('Spec relabels necessity a) (Col Identity)
354+relabel (HIdentity (Result a)) = HIdentity (Result a)
src/Rel8/Table/Either.hs+59−49
@@ -30,23 +30,25 @@ import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )
3030import Rel8.Expr ( Expr )
3131import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
3232import Rel8.Expr.Serialize ( litExpr )
33−import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler, hlabeler )
33+import Rel8.Schema.Context.Label
34+ ( Labelable
35+ , HLabelable, hlabeler, hunlabeler
36+ )
3437import Rel8.Schema.Context.Nullify
3538 ( Nullifiable, ConstrainTag
39+ , HNullifiable, HConstrainTag
3640 , hencodeTag, hdecodeTag
3741 , hnullifier, hunnullifier
3842 )
39−import Rel8.Schema.HTable.Either ( HEitherTable(..), HEitherNullifiable )
43+import Rel8.Schema.HTable ( HTable )
44+import Rel8.Schema.HTable.Either ( HEitherTable(..) )
4045import Rel8.Schema.HTable.Identity ( HIdentity(..) )
41−import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
46+import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
4247import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
4348import Rel8.Schema.Name ( Name )
4449import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
4550import Rel8.Table.Bool ( bool )
4651import Rel8.Table.Eq ( EqTable, eqTable )
47−import Rel8.Table.Lifted
48− ( Table2, Columns2, ConstrainHContext2, fromColumns2, toColumns2
49− )
5052import Rel8.Table.Ord ( OrdTable, ordTable )
5153import Rel8.Table.Recontextualize ( Recontextualize )
5254import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )
@@ -95,51 +97,17 @@ instance (Table Expr a, Table Expr b) => Semigroup (EitherTable a b) where
9597 a <> b = bool a b (isRightTable a)
9698
9799
98−instance Table2 EitherTable where
99− type Columns2 EitherTable = HEitherTable
100− type ConstrainHContext2 EitherTable = HEitherNullifiable
101−
102− toColumns2 f g EitherTable {tag, left, right} = HEitherTable
103− { htag
104− , hleft = hnullify (hnullifier tag isLeft) $ f left
105− , hright = hnullify (hnullifier tag isRight) $ g right
106− }
107− where
108− htag = HIdentity (hencodeTag tag)
109−
110− fromColumns2 f g HEitherTable {htag = htag, hleft, hright} =
111− EitherTable
112− { tag
113− , left = f $ runIdentity $
114− hunnullify (\a -> pure . hunnullifier a) hleft
115− , right = g $ runIdentity $
116− hunnullify (\a -> pure . hunnullifier a) hright
117− }
118− where
119− tag = hdecodeTag $ unHIdentity htag
120−
121− {-# INLINABLE fromColumns2 #-}
122− {-# INLINABLE toColumns2 #-}
123−
124−
125100instance
126101 ( Table context a, Table context b
127102 , Labelable context, Nullifiable context, ConstrainTag context EitherTag
128103 ) =>
129104 Table context (EitherTable a b)
130105 where
131− type Columns (EitherTable a b) =
132− HEitherTable (HLabel "Left" (Columns a)) (HLabel "Right" (Columns b))
106+ type Columns (EitherTable a b) = HEitherTable (Columns a) (Columns b)
133107 type Context (EitherTable a b) = Context a
134108
135− toColumns =
136− toColumns2
137− (hlabel labeler . toColumns)
138− (hlabel labeler . toColumns)
139− fromColumns =
140− fromColumns2
141− (fromColumns . hunlabel unlabeler)
142− (fromColumns . hunlabel unlabeler)
109+ toColumns = toColumns2 toColumns toColumns
110+ fromColumns = fromColumns2 fromColumns fromColumns
143111
144112
145113instance
@@ -152,15 +120,11 @@ instance
152120
153121
154122instance (EqTable a, EqTable b) => EqTable (EitherTable a b) where
155− eqTable =
156− toColumns2 (hlabel hlabeler) (hlabel hlabeler)
157− (rightTableWith (eqTable @a) (eqTable @b))
123+ eqTable = toColumns2 id id (rightTableWith (eqTable @a) (eqTable @b))
158124
159125
160126instance (OrdTable a, OrdTable b) => OrdTable (EitherTable a b) where
161− ordTable =
162− toColumns2 (hlabel hlabeler) (hlabel hlabeler)
163− (rightTableWith (ordTable @a) (ordTable @b))
127+ ordTable = toColumns2 id id (rightTableWith (ordTable @a) (ordTable @b))
164128
165129
166130isLeftTable :: EitherTable a b -> Expr Bool
@@ -203,3 +167,49 @@ aggregateEitherTable f g EitherTable {tag, left, right} =
203167
204168nameEitherTable :: Name EitherTag -> a -> b -> EitherTable a b
205169nameEitherTable = EitherTable . fromName
170+
171+
172+toColumns2 ::
173+ ( HTable t
174+ , HTable u
175+ , HConstrainTag context EitherTag
176+ , HLabelable context
177+ , HNullifiable context
178+ )
179+ => (a -> t context)
180+ -> (b -> u context)
181+ -> EitherTable a b
182+ -> HEitherTable t u context
183+toColumns2 f g EitherTable {tag, left, right} = HEitherTable
184+ { htag
185+ , hleft = hlabel hlabeler $ hnullify (hnullifier tag isLeft) $ f left
186+ , hright = hlabel hlabeler $ hnullify (hnullifier tag isRight) $ g right
187+ }
188+ where
189+ htag = HIdentity (hencodeTag tag)
190+
191+
192+fromColumns2 ::
193+ ( HTable t
194+ , HTable u
195+ , HConstrainTag context EitherTag
196+ , HLabelable context
197+ , HNullifiable context
198+ )
199+ => (t context -> a)
200+ -> (u context -> b)
201+ -> HEitherTable t u context
202+ -> EitherTable a b
203+fromColumns2 f g HEitherTable {htag, hleft, hright} = EitherTable
204+ { tag
205+ , left = f $ runIdentity $
206+ hunnullify (\a -> pure . hunnullifier a) $
207+ hunlabel hunlabeler
208+ hleft
209+ , right = g $ runIdentity $
210+ hunnullify (\a -> pure . hunnullifier a) $
211+ hunlabel hunlabeler
212+ hright
213+ }
214+ where
215+ tag = hdecodeTag $ unHIdentity htag
src/Rel8/Table/Lifted.hsdeleted−81
@@ -1,81 +0,0 @@
1−{-# language ConstraintKinds #-}
2−{-# language DataKinds #-}
3−{-# language FlexibleContexts #-}
4−{-# language FlexibleInstances #-}
5−{-# language MultiParamTypeClasses #-}
6−{-# language QuantifiedConstraints #-}
7−{-# language StandaloneKindSignatures #-}
8−{-# language TypeFamilies #-}
9−{-# language UndecidableInstances #-}
10−
11−module Rel8.Table.Lifted
12− ( Table1( Columns1, ConstrainHContext1, toColumns1, fromColumns1 )
13− , Table2( Columns2, ConstrainHContext2, toColumns2, fromColumns2 )
14− , ConstrainContext
15− )
16−where
17−
18−-- base
19−import Data.Kind ( Constraint, Type )
20−import Prelude ()
21−
22−-- rel8
23−import Rel8.Schema.Context ( Col )
24−import Rel8.Schema.HTable ( HTable )
25−import Rel8.Schema.HTable.Pair
26−import qualified Rel8.Schema.Kind as K
27−
28−
29−type Table1 :: (Type -> Type) -> Constraint
30−class Table1 f where
31− type Columns1 f :: K.HTable -> K.HTable
32− type ConstrainHContext1 f :: K.HContext -> Constraint
33− type ConstrainHContext1 _ = DefaultConstrainContext
34−
35− toColumns1 :: (ConstrainHContext1 f context, HTable t)
36− => (a -> t context)
37− -> f a
38− -> Columns1 f t context
39−
40− fromColumns1 :: (ConstrainHContext1 f context, HTable t)
41− => (t context -> a)
42− -> Columns1 f t context
43− -> f a
44−
45−
46−type Table2 :: (Type -> Type -> Type) -> Constraint
47−class Table2 p where
48− type Columns2 p :: K.HTable -> K.HTable -> K.HTable
49− type ConstrainHContext2 p :: K.HContext -> Constraint
50− type ConstrainHContext2 _ = DefaultConstrainContext
51−
52− toColumns2 :: (ConstrainHContext2 p context, HTable t, HTable u)
53− => (a -> t context)
54− -> (b -> u context)
55− -> p a b
56− -> Columns2 p t u context
57−
58− fromColumns2 :: (ConstrainHContext2 p context, HTable t, HTable u)
59− => (t context -> a)
60− -> (u context -> b)
61− -> Columns2 p t u context
62− -> p a b
63−
64−
65−instance Table2 (,) where
66− type Columns2 (,) = HPair
67−
68− toColumns2 f g (a, b) = HPair (f a) (g b)
69− fromColumns2 f g (HPair a b) = (f a, g b)
70−
71−
72−type DefaultConstrainContext :: K.HContext -> Constraint
73−class DefaultConstrainContext context
74−instance DefaultConstrainContext context
75−
76−
77−type ConstrainContext :: (K.Context -> Constraint) -> K.HContext -> Constraint
78−class (forall context. hcontext ~ Col context => constraint context)
79− => ConstrainContext constraint hcontext
80−instance (hcontext ~ Col context, constraint context) =>
81− ConstrainContext constraint hcontext
src/Rel8/Table/Maybe.hs+48−35
@@ -24,7 +24,7 @@ where
2424-- base
2525import Data.Functor.Identity ( runIdentity )
2626import Data.Kind ( Type )
27−import Prelude hiding ( null, repeat, undefined, zipWith )
27+import Prelude hiding ( null, undefined )
2828
2929-- rel8
3030import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )
@@ -32,15 +32,19 @@ import Rel8.Expr ( Expr )
3232import Rel8.Expr.Bool ( boolExpr )
3333import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )
3434import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
35−import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler, hlabeler )
35+import Rel8.Schema.Context.Label
36+ ( Labelable, HLabelable, hlabeler, hunlabeler
37+ )
3638import Rel8.Schema.Context.Nullify
3739 ( Nullifiable, ConstrainTag
40+ , HNullifiable, HConstrainTag
3841 , hencodeTag, hdecodeTag
3942 , hnullifier, hunnullifier
4043 )
44+import Rel8.Schema.HTable ( HTable )
4145import Rel8.Schema.HTable.Identity ( HIdentity(..) )
42−import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
43−import Rel8.Schema.HTable.Maybe ( HMaybeTable(..), HMaybeNullifiable )
46+import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
47+import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
4448import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
4549import Rel8.Schema.Name ( Name )
4650import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql, nullable )
@@ -51,9 +55,6 @@ import Rel8.Table.Alternative
5155 )
5256import Rel8.Table.Bool ( bool )
5357import Rel8.Table.Eq ( EqTable, eqTable )
54−import Rel8.Table.Lifted
55− ( Table1, Columns1, ConstrainHContext1, fromColumns1, toColumns1
56− )
5758import Rel8.Table.Ord ( OrdTable, ordTable )
5859import Rel8.Table.Recontextualize ( Recontextualize )
5960import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )
@@ -127,40 +128,17 @@ instance (Table Expr a, Semigroup a) => Monoid (MaybeTable a) where
127128 mempty = nothingTable
128129
129130
130−instance Table1 MaybeTable where
131− type Columns1 MaybeTable = HMaybeTable
132− type ConstrainHContext1 MaybeTable = HMaybeNullifiable
133−
134− toColumns1 f MaybeTable {tag, just} = HMaybeTable
135− { htag
136− , hjust = hnullify (hnullifier tag isNonNull) $ f just
137− }
138− where
139− htag = HIdentity (hencodeTag tag)
140−
141− fromColumns1 f HMaybeTable {htag = HIdentity htag, hjust} = MaybeTable
142− { tag
143− , just = f $ runIdentity $
144− hunnullify (\a -> pure . hunnullifier a) hjust
145− }
146− where
147− tag = hdecodeTag htag
148−
149− {-# INLINABLE fromColumns1 #-}
150− {-# INLINABLE toColumns1 #-}
151−
152−
153131instance
154132 ( Table context a
155133 , Labelable context, Nullifiable context
156134 , ConstrainTag context MaybeTag
157135 ) => Table context (MaybeTable a)
158136 where
159− type Columns (MaybeTable a) = HMaybeTable (HLabel "Just" (Columns a))
137+ type Columns (MaybeTable a) = HMaybeTable (Columns a)
160138 type Context (MaybeTable a) = Context a
161139
162− toColumns = toColumns1 (hlabel labeler . toColumns)
163− fromColumns = fromColumns1 (fromColumns . hunlabel unlabeler)
140+ toColumns = toColumns1 toColumns
141+ fromColumns = fromColumns1 fromColumns
164142
165143
166144instance
@@ -171,11 +149,11 @@ instance
171149
172150
173151instance EqTable a => EqTable (MaybeTable a) where
174− eqTable = toColumns1 (hlabel hlabeler) (justTable (eqTable @a))
152+ eqTable = toColumns1 id (justTable (eqTable @a))
175153
176154
177155instance OrdTable a => OrdTable (MaybeTable a) where
178− ordTable = toColumns1 (hlabel hlabeler) (justTable (ordTable @a))
156+ ordTable = toColumns1 id (justTable (ordTable @a))
179157
180158
181159-- | Check if a @MaybeTable@ is absent of any row. Like 'Data.Maybe.isNothing'.
@@ -226,3 +204,38 @@ aggregateMaybeTable f MaybeTable {tag = tag@Tag {aggregator, expr}, just} =
226204
227205nameMaybeTable :: Name (Maybe MaybeTag) -> a -> MaybeTable a
228206nameMaybeTable = MaybeTable . fromName
207+
208+
209+toColumns1 ::
210+ ( HTable t
211+ , HConstrainTag context MaybeTag
212+ , HLabelable context
213+ , HNullifiable context
214+ )
215+ => (a -> t context)
216+ -> MaybeTable a
217+ -> HMaybeTable t context
218+toColumns1 f MaybeTable {tag, just} = HMaybeTable
219+ { htag
220+ , hjust = hlabel hlabeler $ hnullify (hnullifier tag isNonNull) $ f just
221+ }
222+ where
223+ htag = HIdentity (hencodeTag tag)
224+
225+
226+fromColumns1 ::
227+ ( HTable t
228+ , HConstrainTag context MaybeTag
229+ , HLabelable context
230+ , HNullifiable context
231+ )
232+ => (t context -> a)
233+ -> HMaybeTable t context
234+ -> MaybeTable a
235+fromColumns1 f HMaybeTable {htag = HIdentity htag, hjust} = MaybeTable
236+ { tag
237+ , just = f $ runIdentity $
238+ hunnullify (\a -> pure . hunnullifier a) (hunlabel hunlabeler hjust)
239+ }
240+ where
241+ tag = hdecodeTag htag
src/Rel8/Table/Serialize.hs+30−49
@@ -31,13 +31,6 @@ import qualified Hasql.Decoders as Hasql
3131import Rel8.Expr ( Expr, Col(..) )
3232import Rel8.Expr.Serialize ( slitExpr, sparseValue )
3333import Rel8.Schema.Context ( Col(..) )
34−import Rel8.Schema.Context.Identity
35− ( fromHEitherTable, toHEitherTable
36− , fromHListTable, toHListTable
37− , fromHMaybeTable, toHMaybeTable
38− , fromHNonEmptyTable, toHNonEmptyTable
39− , fromHTheseTable, toHTheseTable
40− )
4134import Rel8.Schema.Context.Label ( labeler, unlabeler )
4235import Rel8.Schema.HTable ( HTable, htabulate, htabulateA, hfield, hspecs )
4336import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
@@ -104,50 +97,38 @@ instance (ToExprs a exprs1, ToExprs b exprs2, x ~ EitherTable exprs1 exprs2) =>
10497 ToExprs (Either a b) x
10598 where
10699 fromIdentity =
107− bimap
108− (fromIdentity' @exprs1 . hunlabel unlabeler)
109− (fromIdentity' @exprs2 . hunlabel unlabeler) .
110− fromHEitherTable
100+ bimap (fromIdentity' @exprs1) (fromIdentity' @exprs2) .
101+ fromColumns
111102 toIdentity =
112− toHEitherTable .
113− bimap
114− (hlabel labeler . toIdentity' @exprs1)
115− (hlabel labeler . toIdentity' @exprs2)
103+ toColumns .
104+ bimap (toIdentity' @exprs1) (toIdentity' @exprs2)
116105
117106
118107instance ToExprs a exprs => ToExprs [a] (ListTable exprs) where
119− fromIdentity = fmap (fromIdentity' @exprs) . fromHListTable
120− toIdentity = toHListTable . fmap (toIdentity' @exprs)
108+ fromIdentity = fmap (fromIdentity' @exprs) . fromColumns
109+ toIdentity = toColumns . fmap (toIdentity' @exprs)
121110
122111
123112instance ToExprs a exprs => ToExprs (Maybe a) (MaybeTable exprs) where
124− fromIdentity =
125− fmap (fromIdentity' @exprs . hunlabel unlabeler) .
126− fromHMaybeTable
127− toIdentity =
128− toHMaybeTable .
129− fmap (hlabel labeler . toIdentity' @exprs)
113+ fromIdentity = fmap (fromIdentity' @exprs) . fromColumns
114+ toIdentity = toColumns . fmap (toIdentity' @exprs)
130115
131116
132117instance ToExprs a exprs => ToExprs (NonEmpty a) (NonEmptyTable exprs)
133118 where
134− fromIdentity = fmap (fromIdentity' @exprs) . fromHNonEmptyTable
135− toIdentity = toHNonEmptyTable . fmap (toIdentity' @exprs)
119+ fromIdentity = fmap (fromIdentity' @exprs) . fromColumns
120+ toIdentity = toColumns . fmap (toIdentity' @exprs)
136121
137122
138123instance (ToExprs a exprs1, ToExprs b exprs2, x ~ TheseTable exprs1 exprs2) =>
139124 ToExprs (These a b) x
140125 where
141126 fromIdentity =
142− bimap
143− (fromIdentity' @exprs1 . hunlabel unlabeler)
144− (fromIdentity' @exprs2 . hunlabel unlabeler) .
145− fromHTheseTable
127+ bimap (fromIdentity' @exprs1) (fromIdentity' @exprs2) .
128+ fromColumns
146129 toIdentity =
147− toHTheseTable .
148− bimap
149− (hlabel labeler . toIdentity' @exprs1)
150− (hlabel labeler . toIdentity' @exprs2)
130+ toColumns .
131+ bimap (toIdentity' @exprs1) (toIdentity' @exprs2)
151132
152133
153134instance (ToExprs a exprs1, ToExprs b exprs2, x ~ (exprs1, exprs2)) =>
@@ -251,22 +232,22 @@ instance (KnownSpec spec, x ~ Col Expr spec) =>
251232
252233
253234type FromExprs :: Type -> Type
254−type family FromExprs a where
255− FromExprs (Expr a) = a
256− FromExprs (Col Expr spec) = Col Identity spec
257− FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)
258− FromExprs (ListTable a) = [FromExprs a]
259− FromExprs (MaybeTable a) = Maybe (FromExprs a)
260− FromExprs (NonEmptyTable a) = NonEmpty (FromExprs a)
261− FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)
262− FromExprs (a, b) = (FromExprs a, FromExprs b)
263− FromExprs (a, b, c) = (FromExprs a, FromExprs b, FromExprs c)
264− FromExprs (a, b, c, d) =
265− (FromExprs a, FromExprs b, FromExprs c, FromExprs d)
266− FromExprs (a, b, c, d, e) =
267− (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)
268− FromExprs (t Expr) = t Identity
269− FromExprs (t (Col Expr)) = t (Col Identity)
235+type family FromExprs a
236+type instance FromExprs (Expr a) = a
237+type instance FromExprs (Col Expr spec) = Col Identity spec
238+type instance FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)
239+type instance FromExprs (ListTable a) = [FromExprs a]
240+type instance FromExprs (MaybeTable a) = Maybe (FromExprs a)
241+type instance FromExprs (NonEmptyTable a) = NonEmpty (FromExprs a)
242+type instance FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)
243+type instance FromExprs (a, b) = (FromExprs a, FromExprs b)
244+type instance FromExprs (a, b, c) = (FromExprs a, FromExprs b, FromExprs c)
245+type instance FromExprs (a, b, c, d) =
246+ (FromExprs a, FromExprs b, FromExprs c, FromExprs d)
247+type instance FromExprs (a, b, c, d, e) =
248+ (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)
249+type instance FromExprs (t Expr) = t Identity
250+type instance FromExprs (t (Col Expr)) = t (Col Identity)
270251
271252
272253-- | @Serializable@ witnesses the one-to-one correspondence between the type
src/Rel8/Table/These.hs+72−65
@@ -34,23 +34,24 @@ import Rel8.Aggregate ( Aggregate )
3434import Rel8.Expr ( Expr )
3535import Rel8.Expr.Bool ( (&&.), not_ )
3636import Rel8.Expr.Null ( isNonNull )
37−import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler, hlabeler )
37+import Rel8.Schema.Context.Label
38+ ( Labelable
39+ , HLabelable, hlabeler, hunlabeler
40+ )
3841import Rel8.Schema.Context.Nullify
3942 ( Nullifiable, ConstrainTag
43+ , HNullifiable, HConstrainTag
4044 , hencodeTag, hdecodeTag
4145 , hnullifier, hunnullifier
4246 )
43−import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
47+import Rel8.Schema.HTable ( HTable )
48+import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
4449import Rel8.Schema.HTable.Identity ( HIdentity(..) )
45−import Rel8.Schema.HTable.Maybe ( HMaybeNullifiable )
4650import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
4751import Rel8.Schema.HTable.These ( HTheseTable(..) )
4852import Rel8.Schema.Name ( Name )
4953import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
5054import Rel8.Table.Eq ( EqTable, eqTable )
51−import Rel8.Table.Lifted
52− ( Table2, Columns2, ConstrainHContext2, fromColumns2, toColumns2
53− )
5455import Rel8.Table.Maybe
5556 ( MaybeTable(..)
5657 , maybeTable, justTable, nothingTable
@@ -117,66 +118,16 @@ instance (Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>
117118 }
118119
119120
120−instance Table2 TheseTable where
121− type Columns2 TheseTable = HTheseTable
122− type ConstrainHContext2 TheseTable = HMaybeNullifiable
123−
124− toColumns2 f g TheseTable {here, there} = HTheseTable
125− { hhereTag = HIdentity $ hencodeTag (toHereTag (tag here))
126− , hhere =
127− hnullify (hnullifier (tag here) isNonNull) $ f (just here)
128− , hthereTag = HIdentity $ hencodeTag (toThereTag (tag there))
129− , hthere =
130− hnullify (hnullifier (tag there) isNonNull) $ g (just there)
131− }
132−
133− fromColumns2 f g HTheseTable {hhereTag, hhere, hthereTag, hthere} =
134− TheseTable
135− { here =
136− let
137− tag = hdecodeTag $ unHIdentity hhereTag
138− in
139− MaybeTable
140− { tag
141− , just = f $
142− runIdentity $
143− hunnullify (\a -> pure . hunnullifier a)
144− hhere
145− }
146− , there =
147− let
148− tag = hdecodeTag $ unHIdentity hthereTag
149− in
150− MaybeTable
151− { tag
152− , just = g $
153− runIdentity $
154− hunnullify (\a -> pure . hunnullifier a)
155− hthere
156− }
157− }
158−
159− {-# INLINABLE fromColumns2 #-}
160− {-# INLINABLE toColumns2 #-}
161−
162−
163121instance
164122 ( Table context a, Table context b
165123 , Labelable context, Nullifiable context, ConstrainTag context MaybeTag
166124 ) => Table context (TheseTable a b)
167125 where
168− type Columns (TheseTable a b) =
169− HTheseTable (HLabel "Here" (Columns a)) (HLabel "There" (Columns b))
126+ type Columns (TheseTable a b) = HTheseTable (Columns a) (Columns b)
170127 type Context (TheseTable a b) = Context a
171128
172− toColumns =
173− toColumns2
174− (hlabel labeler . toColumns)
175− (hlabel labeler . toColumns)
176− fromColumns =
177− fromColumns2
178− (fromColumns . hunlabel unlabeler)
179− (fromColumns . hunlabel unlabeler)
129+ toColumns = toColumns2 toColumns toColumns
130+ fromColumns = fromColumns2 fromColumns fromColumns
180131
181132
182133instance
@@ -189,15 +140,11 @@ instance
189140
190141
191142instance (EqTable a, EqTable b) => EqTable (TheseTable a b) where
192− eqTable =
193− toColumns2 (hlabel hlabeler) (hlabel hlabeler)
194− (thoseTable (eqTable @a) (eqTable @b))
143+ eqTable = toColumns2 id id (thoseTable (eqTable @a) (eqTable @b))
195144
196145
197146instance (OrdTable a, OrdTable b) => OrdTable (TheseTable a b) where
198− ordTable =
199− toColumns2 (hlabel hlabeler) (hlabel hlabeler)
200− (thoseTable (ordTable @a) (ordTable @b))
147+ ordTable = toColumns2 id id (thoseTable (ordTable @a) (ordTable @b))
201148
202149
203150toHereTag :: Tag "isJust" a -> Tag "hasHere" a
@@ -277,3 +224,63 @@ nameTheseTable here there a b =
277224 { here = nameMaybeTable here a
278225 , there = nameMaybeTable there b
279226 }
227+
228+
229+toColumns2 ::
230+ ( HTable t
231+ , HTable u
232+ , HConstrainTag context MaybeTag
233+ , HLabelable context
234+ , HNullifiable context
235+ )
236+ => (a -> t context)
237+ -> (b -> u context)
238+ -> TheseTable a b
239+ -> HTheseTable t u context
240+toColumns2 f g TheseTable {here, there} = HTheseTable
241+ { hhereTag = HIdentity $ hencodeTag (toHereTag (tag here))
242+ , hhere =
243+ hlabel hlabeler $ hnullify (hnullifier (tag here) isNonNull) $ f (just here)
244+ , hthereTag = HIdentity $ hencodeTag (toThereTag (tag there))
245+ , hthere =
246+ hlabel hlabeler $ hnullify (hnullifier (tag there) isNonNull) $ g (just there)
247+ }
248+
249+
250+fromColumns2 ::
251+ ( HTable t
252+ , HTable u
253+ , HConstrainTag context MaybeTag
254+ , HLabelable context
255+ , HNullifiable context
256+ )
257+ => (t context -> a)
258+ -> (u context -> b)
259+ -> HTheseTable t u context
260+ -> TheseTable a b
261+fromColumns2 f g HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable
262+ { here =
263+ let
264+ tag = hdecodeTag $ unHIdentity hhereTag
265+ in
266+ MaybeTable
267+ { tag
268+ , just = f $
269+ runIdentity $
270+ hunnullify (\a -> pure . hunnullifier a) $
271+ hunlabel hunlabeler
272+ hhere
273+ }
274+ , there =
275+ let
276+ tag = hdecodeTag $ unHIdentity hthereTag
277+ in
278+ MaybeTable
279+ { tag
280+ , just = g $
281+ runIdentity $
282+ hunnullify (\a -> pure . hunnullifier a) $
283+ hunlabel hunlabeler
284+ hthere
285+ }
286+ }
src/Rel8/Type/Array.hs+1
@@ -32,6 +32,7 @@ array TypeInformation {typeName} =
3232 fromPrimArray .
3333 Opaleye.CastExpr (typeName <> "[]") .
3434 Opaleye.ArrayExpr . toList
35+{-# INLINABLE array #-}
3536
3637
3738listTypeInformation :: ()
src/Rel8/Type/Tag.hs+1−1
@@ -19,7 +19,7 @@ import Prelude
1919import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
2020
2121-- rel8
22−import Rel8.Expr ( Expr )
22+import {-# SOURCE #-} Rel8.Expr ( Expr )
2323import Rel8.Expr.Eq ( (==.) )
2424import Rel8.Expr.Opaleye ( zipPrimExprsWith )
2525import Rel8.Expr.Serialize ( litExpr )