git.iko.soy/rel8
on master help sign in
Clean up ConstrainDBType (#100)
commit716d9f1e0433fead35d6be41233259ef27dc601a authorShane <shane.obrien@circuithub.com> dateFri 2 Jul 2021, 19:19 (5 years ago) parent4e1b3b7
14 files changed+226−390
compare with master
unifiedsplit
rel8.cabal+1−1 src/Rel8/Schema/Context/Nullify.hs+5−67 src/Rel8/Schema/Spec/Constrain.hs+32 src/Rel8/Schema/Spec/ConstrainDBType.hs−89 src/Rel8/Table/Aggregate.hs+3−2 src/Rel8/Table/Either.hs+44−58 src/Rel8/Table/Eq.hs+7−7 src/Rel8/Table/List.hs+6−9 src/Rel8/Table/Maybe.hs+31−46 src/Rel8/Table/NonEmpty.hs+6−9 src/Rel8/Table/Ord.hs+8−8 src/Rel8/Table/Order.hs+13−15 src/Rel8/Table/Rel8able.hs+7−6 src/Rel8/Table/These.hs+63−73
rel8.cabal+1−1
@@ -134,7 +134,7 @@ library
134134 Rel8.Schema.Reify
135135 Rel8.Schema.Result
136136 Rel8.Schema.Spec
137− Rel8.Schema.Spec.ConstrainDBType
137+ Rel8.Schema.Spec.Constrain
138138 Rel8.Schema.Table
139139
140140 Rel8.Statement.Delete
src/Rel8/Schema/Context/Nullify.hs+5−67
@@ -9,14 +9,13 @@
99{-# language TypeFamilies #-}
1010
1111module Rel8.Schema.Context.Nullify
12− ( Nullifiable( ConstrainTag, encodeTag, decodeTag, nullifier, unnullifier )
13− , HNullifiable( HConstrainTag, hencodeTag, hdecodeTag, hnullifier, hunnullifier )
12+ ( Nullifiable( encodeTag, decodeTag, nullifier, unnullifier )
1413 , runTag, unnull
1514 )
1615where
1716
1817-- base
19−import Data.Kind ( Constraint, Type )
18+import Data.Kind ( Constraint )
2019import GHC.TypeLits ( KnownSymbol )
2120import Prelude hiding ( null )
2221
@@ -36,31 +35,18 @@ import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
3635import Rel8.Schema.Context ( Interpretation )
3736import qualified Rel8.Schema.Kind as K
3837import Rel8.Schema.Name ( Name( Name ), Col( N ) )
39−import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql )
40−import Rel8.Schema.Dict ( Dict( Dict ) )
38+import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )
4139import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
42−import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
43−import qualified Rel8.Schema.Spec.ConstrainDBType as ConstrainDBType
4440import Rel8.Table.Tag ( Tag(..), Taggable, fromAggregate, fromExpr, fromName )
4541
4642
4743type Nullifiable :: K.Context -> Constraint
4844class Interpretation context => Nullifiable context where
49− type ConstrainTag context :: Type -> Constraint
50− type ConstrainTag _context = DefaultConstrainTag
51−
52− encodeTag ::
53− ( Sql (ConstrainTag context) a
54− , Taggable a
55− )
45+ encodeTag :: Taggable a
5646 => Tag label a
5747 -> Col context ('Spec a)
5848
59− decodeTag ::
60− ( Sql (ConstrainTag context) a
61− , KnownSymbol label
62− , Taggable a
63− )
49+ decodeTag :: (KnownSymbol label, Taggable a)
6450 => Col context ('Spec a)
6551 -> Tag label a
6652
@@ -137,51 +123,3 @@ unnull :: Nullity a -> Expr (Nullify a) -> Expr a
137123unnull nullity a = case nullity of
138124 Null -> a
139125 NotNull -> unsafeUnnullify a
140−
141−
142−type HNullifiable :: K.HContext -> Constraint
143−class HNullifiable context where
144− type HConstrainTag context :: Type -> Constraint
145− type HConstrainTag _context = DefaultConstrainTag
146−
147− hencodeTag :: (Sql (HConstrainTag context) a, KnownSymbol label, Taggable a)
148− => Tag label a
149− -> context ('Spec a)
150−
151− hdecodeTag :: (Sql (HConstrainTag context) a, KnownSymbol label, Taggable a)
152− => context ('Spec a)
153− -> Tag label a
154−
155− hnullifier :: ()
156− => Tag label a
157− -> (Expr a -> Expr Bool)
158− -> SSpec ('Spec x)
159− -> context ('Spec x)
160− -> context ('Spec (Nullify x))
161−
162− hunnullifier :: ()
163− => SSpec ('Spec x)
164− -> context ('Spec (Nullify x))
165− -> context ('Spec x)
166−
167−
168−instance Nullifiable context => HNullifiable (Col context) where
169− type HConstrainTag (Col context) = ConstrainTag context
170− hencodeTag = encodeTag
171− hdecodeTag = decodeTag
172− hnullifier = nullifier
173− hunnullifier = unnullifier
174−
175−
176−instance HNullifiable (Dict (ConstrainDBType constraint)) where
177− type HConstrainTag (Dict (ConstrainDBType constraint)) = constraint
178−
179− hencodeTag _ = Dict
180− hdecodeTag = mempty
181− hnullifier _ _ = ConstrainDBType.nullifier
182− hunnullifier = ConstrainDBType.unnullifier
183−
184−
185−type DefaultConstrainTag :: Type -> Constraint
186−class DefaultConstrainTag a
187−instance DefaultConstrainTag a
src/Rel8/Schema/Spec/Constrain.hsnew file+32
@@ -0,0 +1,32 @@
1+{-# language ConstraintKinds #-}
2+{-# language DataKinds #-}
3+{-# language FlexibleInstances #-}
4+{-# language MultiParamTypeClasses #-}
5+{-# language StandaloneKindSignatures #-}
6+{-# language TypeFamilies #-}
7+{-# language UndecidableInstances #-}
8+{-# language UndecidableSuperClasses #-}
9+
10+module Rel8.Schema.Spec.Constrain
11+ ( ConstrainSpec
12+ )
13+where
14+
15+-- base
16+import Data.Kind ( Constraint, Type )
17+import Prelude ()
18+
19+-- rel8
20+import Rel8.Schema.Spec ( Spec( Spec ) )
21+
22+
23+type Unspec :: Spec -> Type
24+type family Unspec spec where
25+ Unspec ('Spec a) = a
26+
27+
28+type ConstrainSpec :: (Type -> Constraint) -> Spec -> Constraint
29+class (spec ~ 'Spec (Unspec spec), constraint (Unspec spec)) =>
30+ ConstrainSpec constraint spec
31+instance (spec ~ 'Spec (Unspec spec), constraint (Unspec spec)) =>
32+ ConstrainSpec constraint spec
src/Rel8/Schema/Spec/ConstrainDBType.hsdeleted−89
@@ -1,89 +0,0 @@
1−{-# language ConstraintKinds #-}
2−{-# language DataKinds #-}
3−{-# language FlexibleInstances #-}
4−{-# language MultiParamTypeClasses #-}
5−{-# language NamedFieldPuns #-}
6−{-# language QuantifiedConstraints #-}
7−{-# language StandaloneKindSignatures #-}
8−{-# language TypeFamilies #-}
9−{-# language UndecidableInstances #-}
10−
11−module Rel8.Schema.Spec.ConstrainDBType
12− ( ConstrainDBType
13− , dbTypeNullity, dbTypeDict
14− , nullifier, unnullifier
15− )
16−where
17−
18−-- base
19−import Data.Kind ( Constraint, Type )
20−import Prelude
21−
22−-- rel8
23−import Rel8.Schema.Dict ( Dict( Dict ) )
24−import Rel8.Schema.Null
25− ( Nullify, Unnullify
26− , Nullity( Null, NotNull )
27− , Sql, nullable
28− )
29−import Rel8.Schema.Spec ( Spec( Spec ), SSpec( SSpec, nullity ) )
30−
31−
32−type ConstrainDBType :: (Type -> Constraint) -> Spec -> Constraint
33−class
34− ( forall c a. ()
35− => (spec ~ 'Spec a)
36− => (forall x. (constraint x => c x)) => Sql c a
37− )
38− => ConstrainDBType constraint spec
39−instance
40− ( spec ~ 'Spec a
41− , Sql constraint a
42− )
43− => ConstrainDBType constraint spec
44−
45−
46−dbTypeNullity :: Dict (ConstrainDBType c) ('Spec a) -> Nullity a
47−dbTypeNullity = step2 . step1
48− where
49− step1 :: Dict (ConstrainDBType c) ('Spec a) -> Dict (Sql c) a
50− step1 Dict = Dict
51−
52− step2 :: Dict (Sql c) a -> Nullity a
53− step2 Dict = nullable
54−
55−
56−dbTypeDict :: Dict (ConstrainDBType c) ('Spec a) -> Dict c (Unnullify a)
57−dbTypeDict = step2 . step1
58− where
59− step1 :: Dict (ConstrainDBType c) ('Spec a) -> Dict (Sql c) a
60− step1 Dict = Dict
61−
62− step2 :: Dict (Sql c) a -> Dict c (Unnullify a)
63− step2 Dict = Dict
64−
65−
66−fromNullityDict :: Nullity a -> Dict c (Unnullify a) -> Dict (ConstrainDBType c) ('Spec a)
67−fromNullityDict Null Dict = Dict
68−fromNullityDict NotNull Dict = Dict
69−
70−
71−nullifier :: ()
72− => SSpec ('Spec a)
73− -> Dict (ConstrainDBType c) ('Spec a)
74− -> Dict (ConstrainDBType c) ('Spec (Nullify a))
75−nullifier SSpec {} dict = case dbTypeDict dict of
76− Dict -> case dbTypeNullity dict of
77− Null -> Dict
78− NotNull -> Dict
79−
80−
81−unnullifier :: ()
82− => SSpec ('Spec a)
83− -> Dict (ConstrainDBType c) ('Spec (Nullify a))
84− -> Dict (ConstrainDBType c) ('Spec a)
85−unnullifier SSpec {nullity} dict = case dbTypeDict dict of
86− Dict -> case nullity of
87− Null -> Dict
88− NotNull -> case dbTypeNullity dict of
89− Null -> fromNullityDict nullity Dict
src/Rel8/Table/Aggregate.hs+3−2
@@ -26,8 +26,9 @@ import Rel8.Expr.Aggregate
2626import Rel8.Schema.Dict ( Dict( Dict ) )
2727import Rel8.Schema.HTable ( HTable, hfield, htabulate )
2828import Rel8.Schema.HTable.Vectorize ( hvectorize )
29+import Rel8.Schema.Null ( Sql )
2930import Rel8.Schema.Spec ( SSpec( SSpec, info ) )
30−import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
31+import Rel8.Schema.Spec.Constrain ( ConstrainSpec )
3132import Rel8.Table ( toColumns, fromColumns )
3233import Rel8.Table.Eq ( EqTable, eqTable )
3334import Rel8.Table.List ( ListTable )
@@ -43,7 +44,7 @@ groupBy = fromColumns . hgroupBy (eqTable @exprs) . toColumns
4344
4445
4546hgroupBy :: HTable t
46− => t (Dict (ConstrainDBType DBEq)) -> t (Col Expr) -> t (Col Aggregate)
47+ => t (Dict (ConstrainSpec (Sql DBEq))) -> t (Col Expr) -> t (Col Aggregate)
4748hgroupBy eqs exprs = fromColumns $ htabulate $ \field ->
4849 case hfield eqs field of
4950 Dict -> case hfield exprs field of
src/Rel8/Table/Either.hs+44−58
@@ -33,12 +33,11 @@ import Prelude hiding ( undefined )
3333import Rel8.Expr ( Expr )
3434import Rel8.Expr.Serialize ( litExpr )
3535import Rel8.Schema.Context.Nullify
36− ( Nullifiable, ConstrainTag
37− , HNullifiable, HConstrainTag
38− , hencodeTag, hdecodeTag
39− , hnullifier, hunnullifier
36+ ( Nullifiable
37+ , encodeTag, decodeTag
38+ , nullifier, unnullifier
4039 )
41−import Rel8.Schema.HTable ( HTable )
40+import Rel8.Schema.Dict ( Dict( Dict ) )
4241import Rel8.Schema.HTable.Either ( HEitherTable(..) )
4342import Rel8.Schema.HTable.Identity ( HIdentity(..) )
4443import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
@@ -107,22 +106,45 @@ instance (Table Expr a, Table Expr b) => Semigroup (EitherTable a b) where
107106
108107instance
109108 ( Table context a, Table context b
110− , Nullifiable context, ConstrainTag context EitherTag
111− ) =>
112− Table context (EitherTable a b)
109+ , Nullifiable context
110+ )
111+ => Table context (EitherTable a b)
113112 where
114113 type Columns (EitherTable a b) = HEitherTable (Columns a) (Columns b)
115114 type Context (EitherTable a b) = Context a
116115
117− toColumns = toColumns2 toColumns toColumns
118− fromColumns = fromColumns2 fromColumns fromColumns
116+ toColumns EitherTable {tag, left, right} = HEitherTable
117+ { htag
118+ , hleft = hlabel $ hnullify (nullifier tag isLeft) $ toColumns left
119+ , hright = hlabel $ hnullify (nullifier tag isRight) $ toColumns right
120+ }
121+ where
122+ htag = hlabel $ HType $ encodeTag tag
123+
124+ fromColumns HEitherTable {htag, hleft, hright} = EitherTable
125+ { tag
126+ , left =
127+ fromColumns $
128+ runIdentity $
129+ hunnullify (\a -> pure . unnullifier a) $
130+ hunlabel
131+ hleft
132+ , right =
133+ fromColumns $
134+ runIdentity $
135+ hunnullify (\a -> pure . unnullifier a) $
136+ hunlabel
137+ hright
138+ }
139+ where
140+ tag = decodeTag $ unHIdentity $ hunlabel htag
141+
119142 reify = liftA2 bimap reify reify
120143 unreify = liftA2 bimap unreify unreify
121144
122145
123146instance
124− ( Nullifiable from, ConstrainTag from EitherTag
125− , Nullifiable to, ConstrainTag to EitherTag
147+ ( Nullifiable from, Nullifiable to
126148 , Recontextualize from to a1 b1
127149 , Recontextualize from to a2 b2
128150 )
@@ -130,11 +152,19 @@ instance
130152
131153
132154instance (EqTable a, EqTable b) => EqTable (EitherTable a b) where
133− eqTable = toColumns2 id id (rightTableWith (eqTable @a) (eqTable @b))
155+ eqTable = HEitherTable
156+ { htag = hlabel (HType Dict)
157+ , hleft = hlabel (hnullify (\_ Dict -> Dict) (eqTable @a))
158+ , hright = hlabel (hnullify (\_ Dict -> Dict) (eqTable @b))
159+ }
134160
135161
136162instance (OrdTable a, OrdTable b) => OrdTable (EitherTable a b) where
137− ordTable = toColumns2 id id (rightTableWith (ordTable @a) (ordTable @b))
163+ ordTable = HEitherTable
164+ { htag = hlabel (HType Dict)
165+ , hleft = hlabel (hnullify (\_ Dict -> Dict) (ordTable @a))
166+ , hright = hlabel (hnullify (\_ Dict -> Dict) (ordTable @b))
167+ }
138168
139169
140170type instance FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)
@@ -196,47 +226,3 @@ nameEitherTable
196226 -- ^ Names of the columns in the @b@ table.
197227 -> EitherTable a b
198228nameEitherTable = EitherTable . fromName
199−
200−
201−toColumns2 ::
202− ( HTable t
203− , HTable u
204− , HConstrainTag context EitherTag
205− , HNullifiable context
206− )
207− => (a -> t context)
208− -> (b -> u context)
209− -> EitherTable a b
210− -> HEitherTable t u context
211−toColumns2 f g EitherTable {tag, left, right} = HEitherTable
212− { htag
213− , hleft = hlabel $ hnullify (hnullifier tag isLeft) $ f left
214− , hright = hlabel $ hnullify (hnullifier tag isRight) $ g right
215− }
216− where
217− htag = hlabel $ HType $ hencodeTag tag
218−
219−
220−fromColumns2 ::
221− ( HTable t
222− , HTable u
223− , HConstrainTag context EitherTag
224− , HNullifiable context
225− )
226− => (t context -> a)
227− -> (u context -> b)
228− -> HEitherTable t u context
229− -> EitherTable a b
230−fromColumns2 f g HEitherTable {htag, hleft, hright} = EitherTable
231− { tag
232− , left = f $ runIdentity $
233− hunnullify (\a -> pure . hunnullifier a) $
234− hunlabel
235− hleft
236− , right = g $ runIdentity $
237− hunnullify (\a -> pure . hunnullifier a) $
238− hunlabel
239− hright
240− }
241− where
242− tag = hdecodeTag $ unHIdentity $ hunlabel htag
src/Rel8/Table/Eq.hs+7−7
@@ -45,7 +45,7 @@ import Rel8.Schema.HTable
4545 )
4646import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )
4747import Rel8.Schema.Null ( Sql )
48−import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType, nullifier )
48+import Rel8.Schema.Spec.Constrain ( ConstrainSpec )
4949import Rel8.Table ( Table, Columns, toColumns, TColumns )
5050import Rel8.Type.Eq ( DBEq )
5151
@@ -55,14 +55,14 @@ import Rel8.Type.Eq ( DBEq )
5555-- means "all columns in a 'Table' have an instance of 'DBEq'".
5656type EqTable :: Type -> Constraint
5757class Table Expr a => EqTable a where
58− eqTable :: Columns a (Dict (ConstrainDBType DBEq))
58+ eqTable :: Columns a (Dict (ConstrainSpec (Sql DBEq)))
5959
6060 default eqTable ::
6161 ( KnownAlgebra (GAlgebra (Rep (Record a)))
62− , Eval (GGTable (GAlgebra (Rep (Record a))) TEqTable TColumns (Dict (ConstrainDBType DBEq)) (Rep (Record a)))
62+ , Eval (GGTable (GAlgebra (Rep (Record a))) TEqTable TColumns (Dict (ConstrainSpec (Sql DBEq))) (Rep (Record a)))
6363 , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))
6464 )
65− => Columns a (Dict (ConstrainDBType DBEq))
65+ => Columns a (Dict (ConstrainSpec (Sql DBEq)))
6666 eqTable =
6767 ggtable
6868 @(GAlgebra (Rep (Record a)))
@@ -70,7 +70,7 @@ class Table Expr a => EqTable a where
7070 @TColumns
7171 @(Rep (Record a))
7272 table
73− nullifier
73+ (\_ Dict -> Dict)
7474 where
7575 table (_ :: proxy x) = eqTable @x
7676
@@ -82,11 +82,11 @@ type instance Eval (TEqTable a) = EqTable a
8282instance
8383 ( HTable t
8484 , f ~ Col Expr
85− , HConstrainTable t (ConstrainDBType DBEq)
85+ , HConstrainTable t (ConstrainSpec (Sql DBEq))
8686 )
8787 => EqTable (t f)
8888 where
89− eqTable = hdicts @(Columns (t f)) @(ConstrainDBType DBEq)
89+ eqTable = hdicts @(Columns (t f)) @(ConstrainSpec (Sql DBEq))
9090
9191
9292instance Sql DBEq a => EqTable (Expr a) where
src/Rel8/Table/List.hs+6−9
@@ -29,7 +29,6 @@ import Rel8.Schema.HTable.Vectorize ( happend, hempty, hvectorize )
2929import Rel8.Schema.Name ( Col( N ), Name( Name ) )
3030import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
3131import Rel8.Schema.Spec ( SSpec(..) )
32−import Rel8.Schema.Spec.ConstrainDBType ( dbTypeDict, dbTypeNullity )
3332import Rel8.Schema.Reify ( hreify, hunreify )
3433import Rel8.Table
3534 ( Table, Context, Columns, fromColumns, toColumns
@@ -75,20 +74,18 @@ instance
7574instance EqTable a => EqTable (ListTable a) where
7675 eqTable =
7776 hvectorize
78− (\SSpec {} (Identity dict) -> case dbTypeDict dict of
79− Dict -> case dbTypeNullity dict of
80− Null -> Dict
81− NotNull -> Dict)
77+ (\SSpec {nullity} (Identity Dict) -> case nullity of
78+ Null -> Dict
79+ NotNull -> Dict)
8280 (Identity (eqTable @a))
8381
8482
8583instance OrdTable a => OrdTable (ListTable a) where
8684 ordTable =
8785 hvectorize
88− (\SSpec {} (Identity dict) -> case dbTypeDict dict of
89− Dict -> case dbTypeNullity dict of
90− Null -> Dict
91− NotNull -> Dict)
86+ (\SSpec {nullity} (Identity Dict) -> case nullity of
87+ Null -> Dict
88+ NotNull -> Dict)
9289 (Identity (ordTable @a))
9390
9491
src/Rel8/Table/Maybe.hs+31−46
@@ -31,12 +31,11 @@ import Rel8.Expr ( Expr )
3131import Rel8.Expr.Bool ( boolExpr )
3232import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )
3333import Rel8.Schema.Context.Nullify
34− ( Nullifiable, ConstrainTag
35− , HNullifiable, HConstrainTag
36− , hencodeTag, hdecodeTag
37− , hnullifier, hunnullifier
34+ ( Nullifiable
35+ , encodeTag, decodeTag
36+ , nullifier, unnullifier
3837 )
39−import Rel8.Schema.HTable ( HTable )
38+import Rel8.Schema.Dict ( Dict( Dict ) )
4039import Rel8.Schema.HTable.Identity ( HIdentity(..) )
4140import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
4241import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
@@ -129,32 +128,51 @@ instance (Table Expr a, Semigroup a) => Monoid (MaybeTable a) where
129128instance
130129 ( Table context a
131130 , Nullifiable context
132− , ConstrainTag context MaybeTag
133− ) => Table context (MaybeTable a)
131+ )
132+ => Table context (MaybeTable a)
134133 where
135134 type Columns (MaybeTable a) = HMaybeTable (Columns a)
136135 type Context (MaybeTable a) = Context a
137136
138− toColumns = toColumns1 toColumns
139− fromColumns = fromColumns1 fromColumns
137+ toColumns MaybeTable {tag, just} = HMaybeTable
138+ { htag
139+ , hjust = hlabel $ hnullify (nullifier tag isNonNull) $ toColumns just
140+ }
141+ where
142+ htag = hlabel (HType (encodeTag tag))
143+
144+ fromColumns HMaybeTable {htag, hjust} = MaybeTable
145+ { tag
146+ , just = fromColumns $ runIdentity $
147+ hunnullify (\a -> pure . unnullifier a) (hunlabel hjust)
148+ }
149+ where
150+ tag = decodeTag (unHIdentity (hunlabel htag))
151+
140152 reify = fmap fmap reify
141153 unreify = fmap fmap unreify
142154
143155
144156instance
145− ( Nullifiable from, ConstrainTag from MaybeTag
146− , Nullifiable to, ConstrainTag to MaybeTag
157+ ( Nullifiable from
158+ , Nullifiable to
147159 , Recontextualize from to a b
148160 )
149161 => Recontextualize from to (MaybeTable a) (MaybeTable b)
150162
151163
152164instance EqTable a => EqTable (MaybeTable a) where
153− eqTable = toColumns1 id (justTable (eqTable @a))
165+ eqTable = HMaybeTable
166+ { htag = hlabel (HType Dict)
167+ , hjust = hlabel (hnullify (\_ Dict -> Dict) (eqTable @a))
168+ }
154169
155170
156171instance OrdTable a => OrdTable (MaybeTable a) where
157− ordTable = toColumns1 id (justTable (ordTable @a))
172+ ordTable = HMaybeTable
173+ { htag = hlabel (HType Dict)
174+ , hjust = hlabel (hnullify (\_ Dict -> Dict) (ordTable @a))
175+ }
158176
159177
160178type instance FromExprs (MaybeTable a) = Maybe (FromExprs a)
@@ -214,36 +232,3 @@ nameMaybeTable
214232 -- ^ Names of the columns in @a@.
215233 -> MaybeTable a
216234nameMaybeTable = MaybeTable . fromName
217−
218−
219−toColumns1 ::
220− ( HTable t
221− , HConstrainTag context MaybeTag
222− , HNullifiable context
223− )
224− => (a -> t context)
225− -> MaybeTable a
226− -> HMaybeTable t context
227−toColumns1 f MaybeTable {tag, just} = HMaybeTable
228− { htag
229− , hjust = hlabel $ hnullify (hnullifier tag isNonNull) $ f just
230− }
231− where
232− htag = hlabel (HType (hencodeTag tag))
233−
234−
235−fromColumns1 ::
236− ( HTable t
237− , HConstrainTag context MaybeTag
238− , HNullifiable context
239− )
240− => (t context -> a)
241− -> HMaybeTable t context
242− -> MaybeTable a
243−fromColumns1 f HMaybeTable {htag, hjust} = MaybeTable
244− { tag
245− , just = f $ runIdentity $
246− hunnullify (\a -> pure . hunnullifier a) (hunlabel hjust)
247− }
248− where
249− tag = hdecodeTag (unHIdentity (hunlabel htag))
src/Rel8/Table/NonEmpty.hs+6−9
@@ -31,7 +31,6 @@ import Rel8.Schema.Name ( Col( N ), Name( Name ) )
3131import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
3232import Rel8.Schema.Reify ( hreify, hunreify )
3333import Rel8.Schema.Spec ( SSpec(..) )
34−import Rel8.Schema.Spec.ConstrainDBType ( dbTypeDict, dbTypeNullity )
3534import Rel8.Table
3635 ( Table, Context, Columns, fromColumns, toColumns
3736 , reify, unreify
@@ -74,20 +73,18 @@ instance
7473instance EqTable a => EqTable (NonEmptyTable a) where
7574 eqTable =
7675 hvectorize
77− (\SSpec {} (Identity dict) -> case dbTypeDict dict of
78− Dict -> case dbTypeNullity dict of
79− Null -> Dict
80− NotNull -> Dict)
76+ (\SSpec {nullity} (Identity Dict) -> case nullity of
77+ Null -> Dict
78+ NotNull -> Dict)
8179 (Identity (eqTable @a))
8280
8381
8482instance OrdTable a => OrdTable (NonEmptyTable a) where
8583 ordTable =
8684 hvectorize
87− (\SSpec {} (Identity dict) -> case dbTypeDict dict of
88− Dict -> case dbTypeNullity dict of
89− Null -> Dict
90− NotNull -> Dict)
85+ (\SSpec {nullity} (Identity Dict) -> case nullity of
86+ Null -> Dict
87+ NotNull -> Dict)
9188 (Identity (ordTable @a))
9289
9390
src/Rel8/Table/Ord.hs+8−8
@@ -43,7 +43,7 @@ import Rel8.Schema.HTable
4343 )
4444import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )
4545import Rel8.Schema.Null (Sql)
46−import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType, nullifier )
46+import Rel8.Schema.Spec.Constrain ( ConstrainSpec )
4747import Rel8.Table ( Columns, toColumns, TColumns )
4848import Rel8.Table.Bool ( bool )
4949import Rel8.Table.Eq ( EqTable )
@@ -56,14 +56,14 @@ import Rel8.Type.Ord ( DBOrd )
5656-- columns in a 'Table' have an instance of 'DBOrd'".
5757type OrdTable :: Type -> Constraint
5858class EqTable a => OrdTable a where
59− ordTable :: Columns a (Dict (ConstrainDBType DBOrd))
59+ ordTable :: Columns a (Dict (ConstrainSpec (Sql DBOrd)))
6060
6161 default ordTable ::
6262 ( KnownAlgebra (GAlgebra (Rep (Record a)))
63− , Eval (GGTable (GAlgebra (Rep (Record a))) TOrdTable TColumns (Dict (ConstrainDBType DBOrd)) (Rep (Record a)))
63+ , Eval (GGTable (GAlgebra (Rep (Record a))) TOrdTable TColumns (Dict (ConstrainSpec (Sql DBOrd))) (Rep (Record a)))
6464 , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))
6565 )
66− => Columns a (Dict (ConstrainDBType DBOrd))
66+ => Columns a (Dict (ConstrainSpec (Sql DBOrd)))
6767 ordTable =
6868 ggtable
6969 @(GAlgebra (Rep (Record a)))
@@ -71,7 +71,7 @@ class EqTable a => OrdTable a where
7171 @TColumns
7272 @(Rep (Record a))
7373 table
74− nullifier
74+ (\_ Dict -> Dict)
7575 where
7676 table (_ :: proxy x) = ordTable @x
7777
@@ -83,12 +83,12 @@ type instance Eval (TOrdTable a) = OrdTable a
8383instance
8484 ( HTable t
8585 , f ~ Col Expr
86− , HConstrainTable t (ConstrainDBType DBEq)
87− , HConstrainTable t (ConstrainDBType DBOrd)
86+ , HConstrainTable t (ConstrainSpec (Sql DBEq))
87+ , HConstrainTable t (ConstrainSpec (Sql DBOrd))
8888 )
8989 => OrdTable (t f)
9090 where
91− ordTable = hdicts @(Columns (t f)) @(ConstrainDBType DBOrd)
91+ ordTable = hdicts @(Columns (t f)) @(ConstrainSpec (Sql DBOrd))
9292
9393
9494instance Sql DBOrd a => OrdTable (Expr a) where
src/Rel8/Table/Order.hs+13−15
@@ -1,4 +1,5 @@
11{-# language DataKinds #-}
2+{-# language NamedFieldPuns #-}
23{-# language ScopedTypeVariables #-}
34{-# language TypeApplications #-}
45{-# language TypeFamilies #-}
@@ -21,10 +22,9 @@ import Rel8.Order ( Order )
2122import Rel8.Schema.Dict ( Dict( Dict ) )
2223import Rel8.Schema.HTable (htabulateA, hfield, hspecs)
2324import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
24−import Rel8.Schema.Spec ( SSpec( SSpec ) )
25−import Rel8.Schema.Spec.ConstrainDBType ( dbTypeDict, dbTypeNullity )
25+import Rel8.Schema.Spec ( SSpec( SSpec, nullity ) )
2626import Rel8.Table ( Columns, toColumns )
27−import Rel8.Table.Ord
27+import Rel8.Table.Ord ( OrdTable, ordTable )
2828
2929
3030-- | Construct an 'Order' for a 'Table' by sorting all columns into ascending
@@ -32,12 +32,11 @@ import Rel8.Table.Ord
3232ascTable :: forall a. OrdTable a => Order a
3333ascTable = contramap toColumns $ getConst $
3434 htabulateA @(Columns a) $ \field -> case hfield hspecs field of
35− SSpec {} -> case hfield (ordTable @a) field of
36− dict@Dict -> case dbTypeDict dict of
37− Dict -> Const $ unE . (`hfield` field) >$<
38− case dbTypeNullity dict of
39− Null -> nullsFirst asc
40− NotNull -> asc
35+ SSpec {nullity} -> case hfield (ordTable @a) field of
36+ Dict -> Const $ unE . (`hfield` field) >$<
37+ case nullity of
38+ Null -> nullsFirst asc
39+ NotNull -> asc
4140
4241
4342-- | Construct an 'Order' for a 'Table' by sorting all columns into descending
@@ -45,9 +44,8 @@ ascTable = contramap toColumns $ getConst $
4544descTable :: forall a. OrdTable a => Order a
4645descTable = contramap toColumns $ getConst $
4746 htabulateA @(Columns a) $ \field -> case hfield hspecs field of
48− SSpec {} -> case hfield (ordTable @a) field of
49− dict@Dict -> case dbTypeDict dict of
50− Dict -> Const $ unE . (`hfield` field) >$<
51− case dbTypeNullity dict of
52− Null -> nullsLast desc
53− NotNull -> desc
47+ SSpec {nullity} -> case hfield (ordTable @a) field of
48+ Dict -> Const $ unE . (`hfield` field) >$<
49+ case nullity of
50+ Null -> nullsLast desc
51+ NotNull -> desc
src/Rel8/Table/Rel8able.hs+7−6
@@ -36,13 +36,14 @@ import Rel8.Schema.Context ( Col )
3636import Rel8.Schema.Dict ( Dict( Dict ) )
3737import qualified Rel8.Schema.Kind as K
3838import Rel8.Schema.HTable ( HConstrainTable, hdicts )
39+import Rel8.Schema.Null ( Sql )
3940import Rel8.Schema.Reify ( hreify, hunreify, UnwrapReify )
4041import Rel8.Schema.Result ( Result )
4142import Rel8.Table
4243 ( Table, Columns, Context, Congruent, fromColumns, toColumns
4344 , Unreify, reify, unreify
4445 )
45−import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
46+import Rel8.Schema.Spec.Constrain ( ConstrainSpec )
4647import Rel8.Table.ADT ( ADT( ADT ), ADTable, fromADT, toADT )
4748import Rel8.Table.Eq ( EqTable, eqTable )
4849import Rel8.Table.HKD ( HKD )
@@ -84,22 +85,22 @@ instance
8485instance
8586 ( context ~ Expr
8687 , Rel8able t
87− , HConstrainTable (Columns (t context)) (ConstrainDBType DBEq)
88+ , HConstrainTable (Columns (t context)) (ConstrainSpec (Sql DBEq))
8889 )
8990 => EqTable (t context)
9091 where
91− eqTable = hdicts @(Columns (t context)) @(ConstrainDBType DBEq)
92+ eqTable = hdicts @(Columns (t context)) @(ConstrainSpec (Sql DBEq))
9293
9394
9495instance
9596 ( context ~ Expr
9697 , Rel8able t
97− , HConstrainTable (Columns (t context)) (ConstrainDBType DBEq)
98− , HConstrainTable (Columns (t context)) (ConstrainDBType DBOrd)
98+ , HConstrainTable (Columns (t context)) (ConstrainSpec (Sql DBEq))
99+ , HConstrainTable (Columns (t context)) (ConstrainSpec (Sql DBOrd))
99100 )
100101 => OrdTable (t context)
101102 where
102− ordTable = hdicts @(Columns (t context)) @(ConstrainDBType DBOrd)
103+ ordTable = hdicts @(Columns (t context)) @(ConstrainSpec (Sql DBOrd))
103104
104105
105106type instance FromExprs (t Expr) = FromExprs' t
src/Rel8/Table/These.hs+63−73
@@ -37,12 +37,11 @@ import Rel8.Expr ( Expr )
3737import Rel8.Expr.Bool ( (&&.), not_ )
3838import Rel8.Expr.Null ( isNonNull )
3939import Rel8.Schema.Context.Nullify
40− ( Nullifiable, ConstrainTag
41− , HNullifiable, HConstrainTag
42− , hencodeTag, hdecodeTag
43− , hnullifier, hunnullifier
40+ ( Nullifiable
41+ , encodeTag, decodeTag
42+ , nullifier, unnullifier
4443 )
45−import Rel8.Schema.HTable ( HTable )
44+import Rel8.Schema.Dict ( Dict( Dict ) )
4645import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
4746import Rel8.Schema.HTable.Identity ( HIdentity(..) )
4847import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
@@ -132,33 +131,82 @@ instance (Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>
132131
133132instance
134133 ( Table context a, Table context b
135− , Nullifiable context, ConstrainTag context MaybeTag
136− ) => Table context (TheseTable a b)
134+ , Nullifiable context
135+ )
136+ => Table context (TheseTable a b)
137137 where
138138 type Columns (TheseTable a b) = HTheseTable (Columns a) (Columns b)
139139 type Context (TheseTable a b) = Context a
140140
141− toColumns = toColumns2 toColumns toColumns
142− fromColumns = fromColumns2 fromColumns fromColumns
141+ toColumns TheseTable {here, there} = HTheseTable
142+ { hhereTag = hlabel $ HType $ encodeTag (toHereTag (tag here))
143+ , hhere =
144+ hlabel $ hnullify (nullifier (tag here) isNonNull) $ toColumns $
145+ just here
146+ , hthereTag = hlabel $ HType $ encodeTag (toThereTag (tag there))
147+ , hthere =
148+ hlabel $ hnullify (nullifier (tag there) isNonNull) $ toColumns $
149+ just there
150+ }
151+
152+ fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable
153+ { here =
154+ let
155+ tag = decodeTag $ unHIdentity $ hunlabel hhereTag
156+ in
157+ MaybeTable
158+ { tag
159+ , just =
160+ fromColumns $
161+ runIdentity $
162+ hunnullify (\a -> pure . unnullifier a) $
163+ hunlabel
164+ hhere
165+ }
166+ , there =
167+ let
168+ tag = decodeTag $ unHIdentity $ hunlabel hthereTag
169+ in
170+ MaybeTable
171+ { tag
172+ , just =
173+ fromColumns $
174+ runIdentity $
175+ hunnullify (\a -> pure . unnullifier a) $
176+ hunlabel
177+ hthere
178+ }
179+ }
180+
181+
143182 reify = liftA2 bimap reify reify
144183 unreify = liftA2 bimap unreify unreify
145184
146185
147186instance
148− ( Nullifiable from, ConstrainTag from MaybeTag
149− , Nullifiable to, ConstrainTag to MaybeTag
187+ ( Nullifiable from, Nullifiable to
150188 , Recontextualize from to a1 b1
151189 , Recontextualize from to a2 b2
152− ) =>
153− Recontextualize from to (TheseTable a1 a2) (TheseTable b1 b2)
190+ )
191+ => Recontextualize from to (TheseTable a1 a2) (TheseTable b1 b2)
154192
155193
156194instance (EqTable a, EqTable b) => EqTable (TheseTable a b) where
157− eqTable = toColumns2 id id (thoseTable (eqTable @a) (eqTable @b))
195+ eqTable = HTheseTable
196+ { hhereTag = hlabel (HType Dict)
197+ , hhere = hlabel (hnullify (\_ Dict -> Dict) (eqTable @a))
198+ , hthereTag = hlabel (HType Dict)
199+ , hthere = hlabel (hnullify (\_ Dict -> Dict) (eqTable @b))
200+ }
158201
159202
160203instance (OrdTable a, OrdTable b) => OrdTable (TheseTable a b) where
161− ordTable = toColumns2 id id (thoseTable (ordTable @a) (ordTable @b))
204+ ordTable = HTheseTable
205+ { hhereTag = hlabel (HType Dict)
206+ , hhere = hlabel (hnullify (\_ Dict -> Dict) (ordTable @a))
207+ , hthereTag = hlabel (HType Dict)
208+ , hthere = hlabel (hnullify (\_ Dict -> Dict) (ordTable @b))
209+ }
162210
163211
164212type instance FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)
@@ -275,61 +323,3 @@ nameTheseTable here there a b =
275323 { here = nameMaybeTable here a
276324 , there = nameMaybeTable there b
277325 }
278−
279−
280−toColumns2 ::
281− ( HTable t
282− , HTable u
283− , HConstrainTag context MaybeTag
284− , HNullifiable context
285− )
286− => (a -> t context)
287− -> (b -> u context)
288− -> TheseTable a b
289− -> HTheseTable t u context
290−toColumns2 f g TheseTable {here, there} = HTheseTable
291− { hhereTag = hlabel $ HType $ hencodeTag (toHereTag (tag here))
292− , hhere =
293− hlabel $ hnullify (hnullifier (tag here) isNonNull) $ f (just here)
294− , hthereTag = hlabel $ HType $ hencodeTag (toThereTag (tag there))
295− , hthere =
296− hlabel $ hnullify (hnullifier (tag there) isNonNull) $ g (just there)
297− }
298−
299−
300−fromColumns2 ::
301− ( HTable t
302− , HTable u
303− , HConstrainTag context MaybeTag
304− , HNullifiable context
305− )
306− => (t context -> a)
307− -> (u context -> b)
308− -> HTheseTable t u context
309− -> TheseTable a b
310−fromColumns2 f g HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable
311− { here =
312− let
313− tag = hdecodeTag $ unHIdentity $ hunlabel hhereTag
314− in
315− MaybeTable
316− { tag
317− , just = f $
318− runIdentity $
319− hunnullify (\a -> pure . hunnullifier a) $
320− hunlabel
321− hhere
322− }
323− , there =
324− let
325− tag = hdecodeTag $ unHIdentity $ hunlabel hthereTag
326− in
327− MaybeTable
328− { tag
329− , just = g $
330− runIdentity $
331− hunnullify (\a -> pure . hunnullifier a) $
332− hunlabel
333− hthere
334− }
335− }