git.iko.soy/rel8
on master help sign in
Fill in missing EqTable and OrdTable instances
commit24f0521920a3b532cf71776725bca10652a632c4 authorShane O'Brien <shane.obrien@circuithub.com> dateFri 26 Mar 2021, 20:37 (6 years ago) parent8127f14
19 files changed+639−265
compare with master
unifiedsplit
rel8.cabal+1 src/Rel8/Schema/Context/Label.hs+8 src/Rel8/Schema/Context/Nullify.hs+84−13 src/Rel8/Schema/HTable.hs−4 src/Rel8/Schema/HTable/Either.hs+11 src/Rel8/Schema/HTable/MapTable.hs+7−1 src/Rel8/Schema/HTable/Maybe.hs+11−4 src/Rel8/Schema/Nullability.hs+6−102 src/Rel8/Schema/Nullability/Internal.hs+123 src/Rel8/Schema/Spec/ConstrainDBType.hs+37−2 src/Rel8/Table/Either.hs+37−26 src/Rel8/Table/Eq.hs+66−13 src/Rel8/Table/Lifted.hs+46−21 src/Rel8/Table/List.hs+30−1 src/Rel8/Table/Maybe.hs+24−13 src/Rel8/Table/NonEmpty.hs+30−1 src/Rel8/Table/Ord.hs+70−3 src/Rel8/Table/Order.hs+13−35 src/Rel8/Table/These.hs+35−26
rel8.cabal+1
@@ -117,6 +117,7 @@ library
117117 Rel8.Schema.Kind
118118 Rel8.Schema.Name
119119 Rel8.Schema.Nullability
120+ Rel8.Schema.Nullability.Internal
120121 Rel8.Schema.Spec
121122 Rel8.Schema.Spec.ConstrainDBType
122123 Rel8.Schema.Spec.ConstrainType
src/Rel8/Schema/Context/Label.hs+8
@@ -1,4 +1,5 @@
11{-# language DataKinds #-}
2+{-# language FlexibleInstances #-}
23{-# language StandaloneKindSignatures #-}
34{-# language TypeFamilies #-}
45{-# language TypeOperators #-}
@@ -16,8 +17,10 @@ import Prelude hiding ( null )
1617
1718-- rel8
1819import Rel8.Schema.Context ( Interpretation, Col(..) )
20+import Rel8.Schema.Dict ( Dict( Dict ) )
1921import Rel8.Schema.Kind ( Context, HContext )
2022import Rel8.Schema.Spec ( Spec( Spec ) )
23+import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
2124
2225
2326type Labelable :: Context -> Constraint
@@ -50,3 +53,8 @@ class HLabelable context where
5053instance Labelable context => HLabelable (Col context) where
5154 hlabeler = labeler
5255 hunlabeler = unlabeler
56+
57+
58+instance HLabelable (Dict (ConstrainDBType constraint)) where
59+ hlabeler Dict = Dict
60+ hunlabeler Dict = Dict
src/Rel8/Schema/Context/Nullify.hs+84−13
@@ -1,19 +1,23 @@
11{-# language DataKinds #-}
22{-# language FlexibleContexts #-}
33{-# language FlexibleInstances #-}
4+{-# language InstanceSigs #-}
45{-# language MultiParamTypeClasses #-}
6+{-# language NamedFieldPuns #-}
7+{-# language ScopedTypeVariables #-}
58{-# language StandaloneKindSignatures #-}
9+{-# language TypeApplications #-}
610{-# language TypeFamilies #-}
711
812module Rel8.Schema.Context.Nullify
9− ( Nullifiable( encodeTag, decodeTag, nullifier, unnullifier )
10− , NullifiableEq
13+ ( Nullifiable( ConstrainTag, encodeTag, decodeTag, nullifier, unnullifier )
14+ , HNullifiable( HConstrainTag, hencodeTag, hdecodeTag, hnullifier, hunnullifier )
1115 , unnull, runTag
1216 )
1317where
1418
1519-- base
16−import Data.Kind ( Constraint )
20+import Data.Kind ( Constraint, Type )
1721import Prelude hiding ( null )
1822
1923-- opaleye
@@ -30,21 +34,29 @@ import Rel8.Schema.Context ( Interpretation, Col(..) )
3034import qualified Rel8.Schema.Kind as K
3135import Rel8.Schema.Nullability
3236 ( Nullify
33− , Nullability( Nullable, NonNullable )
37+ , Nullability( Nullable, NonNullable ), nullabilization
3438 , Sql
3539 )
36−import Rel8.Schema.Spec ( Spec( Spec ), SSpec )
40+import Rel8.Schema.Dict ( Dict( Dict ) )
41+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
42+import Rel8.Schema.Spec.ConstrainDBType
43+ ( ConstrainDBType
44+ , dbTypeDict, dbTypeNullability, fromNullabilityDict
45+ )
3746import Rel8.Type.Eq ( DBEq )
38−import Rel8.Type.Monoid ( DBMonoid )
47+import Rel8.Type.Monoid ( DBMonoid, memptyExpr )
3948
4049
4150type Nullifiable :: K.Context -> Constraint
4251class Interpretation context => Nullifiable context where
43− encodeTag :: (Sql DBEq a, KnownLabels labels)
52+ type ConstrainTag context :: Type -> Constraint
53+ type ConstrainTag _context = DefaultConstrainTag
54+
55+ encodeTag :: (Sql (ConstrainTag context) a, Sql DBEq a, KnownLabels labels)
4456 => Expr a
4557 -> Col context ('Spec labels 'Required a)
4658
47− decodeTag :: Sql DBMonoid a
59+ decodeTag :: (Sql (ConstrainTag context) a, Sql DBMonoid a)
4860 => Col context ('Spec labels 'Required a)
4961 -> Expr a
5062
@@ -61,11 +73,6 @@ class Interpretation context => Nullifiable context where
6173 -> Col context ('Spec labels necessity a)
6274
6375
64−type NullifiableEq :: K.Context -> K.Context -> Constraint
65−class (a ~ b, Nullifiable b) => NullifiableEq a b
66−instance (a ~ b, Nullifiable b) => NullifiableEq a b
67−
68−
6976runTag :: Nullability a -> Expr Bool -> Expr a -> Expr (Nullify a)
7077runTag nullability tag a = case nullability of
7178 Nullable -> boolExpr null a tag
@@ -78,3 +85,67 @@ unnull :: Nullability a -> Expr (Nullify a) -> Expr a
7885unnull nullability a = case nullability of
7986 Nullable -> a
8087 NonNullable -> unsafeUnnullify a
88+
89+
90+type HNullifiable :: K.HContext -> Constraint
91+class HNullifiable context where
92+ type HConstrainTag context :: Type -> Constraint
93+ type HConstrainTag _context = DefaultConstrainTag
94+
95+ hencodeTag :: (Sql (HConstrainTag context) a, Sql DBEq a, KnownLabels labels)
96+ => Expr a
97+ -> context ('Spec labels 'Required a)
98+
99+ hdecodeTag :: (Sql (HConstrainTag context) a, Sql DBMonoid a)
100+ => context ('Spec labels 'Required a)
101+ -> Expr a
102+
103+ hnullifier :: ()
104+ => Expr Bool
105+ -> SSpec ('Spec labels necessity a)
106+ -> context ('Spec labels necessity a)
107+ -> context ('Spec labels necessity (Nullify a))
108+
109+ hunnullifier :: ()
110+ => Expr Bool
111+ -> SSpec ('Spec labels necessity a)
112+ -> context ('Spec labels necessity (Nullify a))
113+ -> context ('Spec labels necessity a)
114+
115+
116+instance Nullifiable context => HNullifiable (Col context) where
117+ type HConstrainTag (Col context) = ConstrainTag context
118+ hencodeTag = encodeTag
119+ hdecodeTag = decodeTag
120+ hnullifier = nullifier
121+ hunnullifier = unnullifier
122+
123+
124+instance HNullifiable (Dict (ConstrainDBType constraint)) where
125+ type HConstrainTag (Dict (ConstrainDBType constraint)) = constraint
126+
127+ hencodeTag _ = Dict
128+
129+ hdecodeTag :: forall a context labels. (Sql (HConstrainTag context) a, Sql DBMonoid a)
130+ => context ('Spec labels 'Required a)
131+ -> Expr a
132+ hdecodeTag _ = case nullabilization @a of
133+ Nullable -> nullify memptyExpr
134+ NonNullable -> memptyExpr
135+
136+
137+ hnullifier _ SSpec {} dict = case dbTypeDict dict of
138+ Dict -> case dbTypeNullability dict of
139+ Nullable -> Dict
140+ NonNullable -> Dict
141+
142+ hunnullifier _ SSpec {nullability} dict = case dbTypeDict dict of
143+ Dict -> case nullability of
144+ Nullable -> Dict
145+ NonNullable -> case dbTypeNullability dict of
146+ Nullable -> fromNullabilityDict nullability Dict
147+
148+
149+type DefaultConstrainTag :: Type -> Constraint
150+class DefaultConstrainTag a
151+instance DefaultConstrainTag a
src/Rel8/Schema/HTable.hs−4
@@ -17,10 +17,6 @@ module Rel8.Schema.HTable
1717 ( HTable (HField, HConstrainTable)
1818 , hfield, htabulate, htraverse, hdicts, hspecs
1919 , htabulateA
20−
21− , HPair(..)
22− , HPairField(..)
23− , GHField(..)
2420 )
2521where
2622
src/Rel8/Schema/HTable/Either.hs+11
@@ -2,19 +2,25 @@
22{-# language DeriveAnyClass #-}
33{-# language DeriveGeneric #-}
44{-# language DerivingStrategies #-}
5+{-# language FlexibleInstances #-}
56{-# language StandaloneKindSignatures #-}
7+{-# language UndecidableInstances #-}
8+{-# language UndecidableSuperClasses #-}
69
710module Rel8.Schema.HTable.Either
811 ( HEitherTable(..)
12+ , HEitherNullifiable
913 )
1014where
1115
1216-- base
17+import Data.Kind ( Constraint )
1318import GHC.Generics ( Generic )
1419import Prelude ()
1520
1621-- rel8
1722import Rel8.Kind.Necessity ( Necessity( Required ) )
23+import Rel8.Schema.Context.Nullify ( HNullifiable, HConstrainTag )
1824import Rel8.Schema.HTable ( HTable )
1925import Rel8.Schema.HTable.Identity ( HIdentity(..) )
2026import Rel8.Schema.HTable.Nullify ( HNullify )
@@ -31,3 +37,8 @@ data HEitherTable left right context = HEitherTable
3137 }
3238 deriving stock Generic
3339 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+7−1
@@ -14,7 +14,13 @@
1414{-# language UndecidableInstances #-}
1515{-# language UndecidableSuperClasses #-}
1616
17−module Rel8.Schema.HTable.MapTable ( HMapTable(..), MapSpec(..), Precompose(..), HMapTableField(..) ) where
17+module Rel8.Schema.HTable.MapTable
18+ ( HMapTable(..)
19+ , MapSpec(..)
20+ , Precompose(..)
21+ , HMapTableField(..)
22+ )
23+where
1824
1925-- base
2026import Data.Kind ( Constraint, Type )
src/Rel8/Schema/HTable/Maybe.hs+11−4
@@ -1,24 +1,26 @@
1−{-# LANGUAGE NamedFieldPuns #-}
2−{-# LANGUAGE LambdaCase #-}
3−{-# LANGUAGE TypeFamilies #-}
4−{-# LANGUAGE KindSignatures #-}
51{-# language DataKinds #-}
62{-# language DeriveAnyClass #-}
73{-# language DeriveGeneric #-}
84{-# language DerivingStrategies #-}
5+{-# language FlexibleInstances #-}
96{-# language StandaloneKindSignatures #-}
7+{-# language UndecidableInstances #-}
8+{-# language UndecidableSuperClasses #-}
109
1110module Rel8.Schema.HTable.Maybe
1211 ( HMaybeTable(..)
12+ , HMaybeNullifiable
1313 )
1414where
1515
1616-- base
17+import Data.Kind ( Constraint )
1718import GHC.Generics ( Generic )
1819import Prelude
1920
2021-- rel8
2122import Rel8.Kind.Necessity ( Necessity( Required ) )
23+import Rel8.Schema.Context.Nullify ( HConstrainTag, HNullifiable )
2224import Rel8.Schema.HTable ( HTable )
2325import Rel8.Schema.HTable.Identity ( HIdentity(..) )
2426import qualified Rel8.Schema.Kind as K
@@ -34,3 +36,8 @@ data HMaybeTable table context = HMaybeTable
3436 }
3537 deriving stock Generic
3638 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/Nullability.hs+6−102
@@ -1,118 +1,22 @@
11{-# language ConstraintKinds #-}
2−{-# language DataKinds #-}
3−{-# language FlexibleContexts #-}
42{-# language FlexibleInstances #-}
5−{-# language FunctionalDependencies #-}
6−{-# language GADTs #-}
3+{-# language MonoLocalBinds #-}
74{-# language MultiParamTypeClasses #-}
8−{-# language QuantifiedConstraints #-}
9−{-# language StandaloneKindSignatures #-}
10−{-# language TypeFamilies #-}
115{-# language UndecidableInstances #-}
12−{-# language UndecidableSuperClasses #-}
6+
7+{-# options_ghc -fno-warn-orphans #-}
138
149module Rel8.Schema.Nullability
15− ( Nullify, Unnullify
16− , NotNull
17− , Homonullable
18− , Nullability( Nullable, NonNullable )
19− , HasNullability, nullabilization
20− , Sql
10+ ( module Rel8.Schema.Nullability.Internal
2111 )
2212where
2313
2414-- base
25−import Data.Kind ( Constraint, Type )
26−import Prelude
15+import Prelude ()
2716
2817-- rel8
2918import Rel8.Opaque ( Opaque )
19+import Rel8.Schema.Nullability.Internal
3020
3121
32−type IsMaybe :: Type -> Bool
33−type family IsMaybe a where
34− IsMaybe (Maybe _) = 'True
35− IsMaybe _ = 'False
36−
37−
38−type Unnullify' :: Bool -> Type -> Type
39−type family Unnullify' isMaybe ma where
40− Unnullify' 'False a = a
41− Unnullify' 'True (Maybe a) = a
42−
43−
44−type Unnullify :: Type -> Type
45−type Unnullify a = Unnullify' (IsMaybe a) a
46−
47−
48−type Nullify' :: Bool -> Type -> Type
49−type family Nullify' isMaybe a where
50− Nullify' 'False a = a
51− Nullify' 'True a = Maybe a
52−
53−
54−type Nullify :: Type -> Type
55−type Nullify a = Maybe (Unnullify a)
56−
57−
58−type NotNull :: Type -> Constraint
59−class (HasNullability a, IsMaybe a ~ 'False) => NotNull a
60−instance (HasNullability a, IsMaybe a ~ 'False) => NotNull a
61−instance {-# OVERLAPPING #-} NotNull Opaque
62−
63−
64−type Homonullable :: Type -> Type -> Constraint
65−class IsMaybe a ~ IsMaybe b => Homonullable a b
66−instance IsMaybe a ~ IsMaybe b => Homonullable a b
67−instance {-# OVERLAPPING #-} Homonullable Opaque Opaque
68−
69−
70−type Nullability :: Type -> Type
71−data Nullability a where
72− NonNullable :: NotNull a => Nullability a
73− Nullable :: NotNull a => Nullability (Maybe a)
74−
75−
76−type HasNullability' :: Bool -> Type -> Constraint
77−class
78− ( IsMaybe a ~ isMaybe
79− , IsMaybe (Unnullify a) ~ 'False
80− , Nullify' isMaybe (Unnullify a) ~ a
81− ) => HasNullability' isMaybe a
82− where
83− nullabilization' :: Nullability a
84−
85−
86−instance IsMaybe a ~ 'False => HasNullability' 'False a where
87− nullabilization' = NonNullable
88−
89−
90−instance IsMaybe a ~ 'False => HasNullability' 'True (Maybe a) where
91− nullabilization' = Nullable
92−
93−
94−type HasNullability :: Type -> Constraint
95−class HasNullability' (IsMaybe a) a => HasNullability a
96−instance HasNullability' (IsMaybe a) a => HasNullability a
97−instance {-# OVERLAPPING #-} HasNullability Opaque
98−
99−
100−nullabilization :: HasNullability a => Nullability a
101−nullabilization = nullabilization'
102−
103−
104−-- | The @Sql@ type class describes both null and not null database values,
105−-- constrained by a specific class.
106−--
107−-- For example, if you see @Sql DBEq a@, this means any database type that
108−-- supports equality, and @a@ can either be exactly an @a@, or it could also be
109−-- @Maybe a@.
110−type Sql :: (Type -> Constraint) -> Type -> Constraint
111−class
112− ( (forall c. (forall x. (constraint x => c x)) => Sql c a)
113− , HasNullability a
114− , constraint (Unnullify a)
115− )
116− => Sql constraint a
117−instance (constraint (Unnullify a), HasNullability a) => Sql constraint a
11822instance {-# OVERLAPPING #-} (c Opaque, Sql c Opaque) => Sql c Opaque
src/Rel8/Schema/Nullability/Internal.hsnew file+123
@@ -0,0 +1,123 @@
1+{-# language ConstraintKinds #-}
2+{-# language DataKinds #-}
3+{-# language FlexibleContexts #-}
4+{-# language FlexibleInstances #-}
5+{-# language FunctionalDependencies #-}
6+{-# language GADTs #-}
7+{-# language MultiParamTypeClasses #-}
8+{-# language QuantifiedConstraints #-}
9+{-# language StandaloneKindSignatures #-}
10+{-# language TypeFamilies #-}
11+{-# language UndecidableInstances #-}
12+{-# language UndecidableSuperClasses #-}
13+
14+module Rel8.Schema.Nullability.Internal
15+ ( Nullify, Unnullify
16+ , NotNull
17+ , Homonullable
18+ , Nullability( Nullable, NonNullable )
19+ , HasNullability, nullabilization
20+ , Sql, toSql
21+ )
22+where
23+
24+-- base
25+import Data.Kind ( Constraint, Type )
26+import Prelude
27+
28+-- rel8
29+import Rel8.Opaque ( Opaque )
30+import Rel8.Schema.Dict ( Dict( Dict ) )
31+
32+
33+type IsMaybe :: Type -> Bool
34+type family IsMaybe a where
35+ IsMaybe (Maybe _) = 'True
36+ IsMaybe _ = 'False
37+
38+
39+type Unnullify' :: Bool -> Type -> Type
40+type family Unnullify' isMaybe ma where
41+ Unnullify' 'False a = a
42+ Unnullify' 'True (Maybe a) = a
43+
44+
45+type Unnullify :: Type -> Type
46+type Unnullify a = Unnullify' (IsMaybe a) a
47+
48+
49+type Nullify' :: Bool -> Type -> Type
50+type family Nullify' isMaybe a where
51+ Nullify' 'False a = a
52+ Nullify' 'True a = Maybe a
53+
54+
55+type Nullify :: Type -> Type
56+type Nullify a = Maybe (Unnullify a)
57+
58+
59+type NotNull :: Type -> Constraint
60+class (HasNullability a, IsMaybe a ~ 'False) => NotNull a
61+instance (HasNullability a, IsMaybe a ~ 'False) => NotNull a
62+instance {-# OVERLAPPING #-} NotNull Opaque
63+
64+
65+type Homonullable :: Type -> Type -> Constraint
66+class IsMaybe a ~ IsMaybe b => Homonullable a b
67+instance IsMaybe a ~ IsMaybe b => Homonullable a b
68+instance {-# OVERLAPPING #-} Homonullable Opaque Opaque
69+
70+
71+type Nullability :: Type -> Type
72+data Nullability a where
73+ NonNullable :: NotNull a => Nullability a
74+ Nullable :: NotNull a => Nullability (Maybe a)
75+
76+
77+type HasNullability' :: Bool -> Type -> Constraint
78+class
79+ ( IsMaybe a ~ isMaybe
80+ , IsMaybe (Unnullify a) ~ 'False
81+ , Nullify' isMaybe (Unnullify a) ~ a
82+ ) => HasNullability' isMaybe a
83+ where
84+ nullabilization' :: Nullability a
85+
86+
87+instance IsMaybe a ~ 'False => HasNullability' 'False a where
88+ nullabilization' = NonNullable
89+
90+
91+instance IsMaybe a ~ 'False => HasNullability' 'True (Maybe a) where
92+ nullabilization' = Nullable
93+
94+
95+type HasNullability :: Type -> Constraint
96+class HasNullability' (IsMaybe a) a => HasNullability a
97+instance HasNullability' (IsMaybe a) a => HasNullability a
98+instance {-# OVERLAPPING #-} HasNullability Opaque
99+
100+
101+nullabilization :: HasNullability a => Nullability a
102+nullabilization = nullabilization'
103+
104+
105+-- | The @Sql@ type class describes both null and not null database values,
106+-- constrained by a specific class.
107+--
108+-- For example, if you see @Sql DBEq a@, this means any database type that
109+-- supports equality, and @a@ can either be exactly an @a@, or it could also be
110+-- @Maybe a@.
111+type Sql :: (Type -> Constraint) -> Type -> Constraint
112+class
113+ ( (forall c. (forall x. (constraint x => c x)) => Sql c a)
114+ , HasNullability a
115+ , constraint (Unnullify a)
116+ )
117+ => Sql constraint a
118+instance (constraint (Unnullify a), HasNullability a) => Sql constraint a
119+
120+
121+toSql :: Nullability a -> Dict constraint (Unnullify a) -> Dict (Sql constraint) a
122+toSql NonNullable Dict = Dict
123+toSql Nullable Dict = Dict
src/Rel8/Schema/Spec/ConstrainDBType.hs+37−2
@@ -9,15 +9,23 @@
99
1010module Rel8.Schema.Spec.ConstrainDBType
1111 ( ConstrainDBType
12+ , dbTypeNullability
13+ , dbTypeDict
14+ , fromNullabilityDict
1215 )
1316where
1417
1518-- base
1619import Data.Kind ( Constraint, Type )
17−import Prelude ()
20+import Prelude
1821
1922-- rel8
20−import Rel8.Schema.Nullability ( Sql )
23+import Rel8.Schema.Dict ( Dict( Dict ) )
24+import Rel8.Schema.Nullability
25+ ( Unnullify
26+ , Nullability
27+ , Sql, nullabilization, toSql
28+ )
2129import Rel8.Schema.Spec ( Spec( Spec ) )
2230
2331
@@ -33,3 +41,30 @@ instance
3341 , Sql constraint a
3442 )
3543 => ConstrainDBType constraint spec
44+
45+
46+dbTypeNullability :: Dict (ConstrainDBType c) ('Spec l n a) -> Nullability a
47+dbTypeNullability = step2 . step1
48+ where
49+ step1 :: Dict (ConstrainDBType c) ('Spec l n a) -> Dict (Sql c) a
50+ step1 Dict = Dict
51+
52+ step2 :: Dict (Sql c) a -> Nullability a
53+ step2 Dict = nullabilization
54+
55+
56+dbTypeDict :: Dict (ConstrainDBType c) ('Spec l n a) -> Dict c (Unnullify a)
57+dbTypeDict = step2 . step1
58+ where
59+ step1 :: Dict (ConstrainDBType c) ('Spec l n 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+fromNullabilityDict :: Nullability a -> Dict c (Unnullify a) -> Dict (ConstrainDBType c) ('Spec l n a)
67+fromNullabilityDict nullability = step2 . toSql nullability
68+ where
69+ step2 :: Dict (Sql c) a -> Dict (ConstrainDBType c) ('Spec l n a)
70+ step2 Dict = Dict
src/Rel8/Table/Either.hs+37−26
@@ -5,7 +5,9 @@
55{-# language FlexibleInstances #-}
66{-# language MultiParamTypeClasses #-}
77{-# language NamedFieldPuns #-}
8+{-# language ScopedTypeVariables #-}
89{-# language StandaloneKindSignatures #-}
10+{-# language TypeApplications #-}
911{-# language TypeFamilies #-}
1012{-# language UndecidableInstances #-}
1113
@@ -25,22 +27,23 @@ import Prelude hiding ( undefined )
2527-- rel8
2628import Rel8.Expr ( Expr )
2729import Rel8.Expr.Serialize ( litExpr )
28−import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
30+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler, hlabeler )
2931import Rel8.Schema.Context.Nullify
30− ( Nullifiable, NullifiableEq
31− , encodeTag, decodeTag
32− , nullifier, unnullifier
32+ ( Nullifiable, ConstrainTag
33+ , hencodeTag, hdecodeTag
34+ , hnullifier, hunnullifier
3335 )
34−import Rel8.Schema.HTable.Either ( HEitherTable(..) )
36+import Rel8.Schema.HTable.Either ( HEitherTable(..), HEitherNullifiable )
3537import Rel8.Schema.HTable.Identity ( HIdentity(..) )
3638import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
3739import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
3840import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
3941import Rel8.Table.Bool ( bool )
42+import Rel8.Table.Eq ( EqTable, eqTable )
4043import Rel8.Table.Lifted
41− ( Table1, Columns1, ConstrainContext1, fromColumns1, toColumns1
42− , Table2, Columns2, ConstrainContext2, fromColumns2, toColumns2
44+ ( Table2, Columns2, ConstrainHContext2, fromColumns2, toColumns2
4345 )
46+import Rel8.Table.Ord ( OrdTable, ordTable )
4447import Rel8.Table.Recontextualize ( Recontextualize )
4548import Rel8.Table.Undefined ( undefined )
4649import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )
@@ -89,42 +92,34 @@ instance (Table Expr a, Table Expr b) => Semigroup (EitherTable a b) where
8992
9093instance Table2 EitherTable where
9194 type Columns2 EitherTable = HEitherTable
92− type ConstrainContext2 EitherTable = Nullifiable
95+ type ConstrainHContext2 EitherTable = HEitherNullifiable
9396
9497 toColumns2 f g EitherTable {tag, left, right} = HEitherTable
9598 { htag
96− , hleft = hnullify (nullifier (isLeft tag)) $ f left
97− , hright = hnullify (nullifier (isRight tag)) $ g right
99+ , hleft = hnullify (hnullifier (isLeft tag)) $ f left
100+ , hright = hnullify (hnullifier (isRight tag)) $ g right
98101 }
99102 where
100− htag = HIdentity (encodeTag tag)
103+ htag = HIdentity (hencodeTag tag)
101104
102105 fromColumns2 f g HEitherTable {htag = htag, hleft, hright} =
103106 EitherTable
104107 { tag
105108 , left = f $ runIdentity $
106− hunnullify (\a -> pure . unnullifier (isLeft tag) a) hleft
109+ hunnullify (\a -> pure . hunnullifier (isLeft tag) a) hleft
107110 , right = g $ runIdentity $
108− hunnullify (\a -> pure . unnullifier (isRight tag) a) hright
111+ hunnullify (\a -> pure . hunnullifier (isRight tag) a) hright
109112 }
110113 where
111− tag = decodeTag $ unHIdentity htag
114+ tag = hdecodeTag $ unHIdentity htag
112115
113116 {-# INLINABLE fromColumns2 #-}
114117 {-# INLINABLE toColumns2 #-}
115118
116119
117−instance Table context a => Table1 (EitherTable a) where
118− type Columns1 (EitherTable a) = HEitherTable (Columns a)
119− type ConstrainContext1 (EitherTable a) = NullifiableEq (Context a)
120−
121− toColumns1 = toColumns2 toColumns
122− fromColumns1 = fromColumns2 fromColumns
123−
124−
125120instance
126121 ( Table context a, Table context b
127− , Labelable context, Nullifiable context
122+ , Labelable context, Nullifiable context, ConstrainTag context EitherTag
128123 ) =>
129124 Table context (EitherTable a b)
130125 where
@@ -143,14 +138,26 @@ instance
143138
144139
145140instance
146− ( Nullifiable from, Labelable from
147− , Nullifiable to, Labelable to
141+ ( Nullifiable from, Labelable from, ConstrainTag from EitherTag
142+ , Nullifiable to, Labelable to, ConstrainTag to EitherTag
148143 , Recontextualize from to a1 b1
149144 , Recontextualize from to a2 b2
150145 ) =>
151146 Recontextualize from to (EitherTable a1 a2) (EitherTable b1 b2)
152147
153148
149+instance (EqTable a, EqTable b) => EqTable (EitherTable a b) where
150+ eqTable =
151+ toColumns2 (hlabel hlabeler) (hlabel hlabeler)
152+ (rightTableWith (eqTable @a) (eqTable @b))
153+
154+
155+instance (OrdTable a, OrdTable b) => OrdTable (EitherTable a b) where
156+ ordTable =
157+ toColumns2 (hlabel hlabeler) (hlabel hlabeler)
158+ (rightTableWith (ordTable @a) (ordTable @b))
159+
160+
154161isLeftTable :: EitherTable a b -> Expr Bool
155162isLeftTable = isLeft . tag
156163
@@ -170,4 +177,8 @@ leftTable a = EitherTable (litExpr IsLeft) a undefined
170177
171178
172179rightTable :: Table Expr a => b -> EitherTable a b
173−rightTable = EitherTable (litExpr IsRight) undefined
180+rightTable = rightTableWith undefined
181+
182+
183+rightTableWith :: a -> b -> EitherTable a b
184+rightTableWith = EitherTable (litExpr IsRight)
src/Rel8/Table/Eq.hs+66−13
@@ -2,6 +2,7 @@
22{-# language BlockArguments #-}
33{-# language DataKinds #-}
44{-# language DefaultSignatures #-}
5+{-# language DisambiguateRecordFields #-}
56{-# language FlexibleContexts #-}
67{-# language FlexibleInstances #-}
78{-# language LambdaCase #-}
@@ -30,13 +31,20 @@ import Prelude
3031import Rel8.Expr ( Expr, Col(..) )
3132import Rel8.Expr.Bool ( (||.), (&&.) )
3233import Rel8.Expr.Eq ( (==.), (/=.) )
34+import Rel8.Schema.Context.Label ( hlabeler )
3335import Rel8.Schema.Dict ( Dict( Dict ) )
34−import Rel8.Schema.HTable ( HConstrainTable, HPairField(..), GHField(..), htabulate, htabulateA, hfield, hdicts, hspecs )
36+import Rel8.Schema.HTable
37+ ( HTable, HConstrainTable
38+ , htabulateA, hfield, hdicts
39+ )
40+import Rel8.Schema.HTable.Label ( hlabel )
41+import Rel8.Schema.HTable.Pair ( HPair(..) )
42+import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
43+import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
44+import Rel8.Schema.HTable.Trio ( HTrio(..) )
3545import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
3646import Rel8.Table ( Table, Columns, toColumns )
3747import Rel8.Type.Eq ( DBEq )
38−import Rel8.Schema.HTable.MapTable ( HMapTableField(..) )
39−import Rel8.Schema.Spec ( SSpec( SSpec ) )
4048import Rel8.Schema.Nullability ( Sql )
4149
4250
@@ -44,25 +52,70 @@ type EqTable :: Type -> Constraint
4452class Table Expr a => EqTable a where
4553 eqTable :: Columns a (Dict (ConstrainDBType DBEq))
4654
47− default eqTable :: HConstrainTable (Columns a) (ConstrainDBType DBEq) => Columns a (Dict (ConstrainDBType DBEq))
55+ default eqTable :: ()
56+ => HConstrainTable (Columns a) (ConstrainDBType DBEq)
57+ => Columns a (Dict (ConstrainDBType DBEq))
4858 eqTable = hdicts @(Columns a) @(ConstrainDBType DBEq)
4959
5060
51−instance (Table Expr (t Expr), f ~ Expr, HConstrainTable (Columns (t Expr)) (ConstrainDBType DBEq)) => EqTable (t f)
61+instance
62+ ( Table Expr (t Expr)
63+ , f ~ Expr
64+ , HConstrainTable (Columns (t Expr)) (ConstrainDBType DBEq)
65+ )
66+ => EqTable (t f)
67+
68+
69+instance
70+ ( HTable t
71+ , f ~ Col Expr
72+ , HConstrainTable t (ConstrainDBType DBEq)
73+ )
74+ => EqTable (t f)
5275
5376
5477instance Sql DBEq a => EqTable (Expr a)
5578
5679
5780instance (EqTable a, EqTable b) => EqTable (a, b) where
58− eqTable = htabulate \case
59− HFst (GHField (HMapTableField i)) ->
60− case hfield hspecs i of
61− SSpec{} -> case hfield (eqTable @a) i of Dict -> Dict
62−
63− HSnd (GHField (HMapTableField i)) ->
64− case hfield hspecs i of
65− SSpec{} -> case hfield (eqTable @b) i of Dict -> Dict
81+ eqTable =
82+ HPair
83+ { hfst = hlabel hlabeler (eqTable @a)
84+ , hsnd = hlabel hlabeler (eqTable @b)
85+ }
86+
87+
88+instance (EqTable a, EqTable b, EqTable c) => EqTable (a, b, c) where
89+ eqTable =
90+ HTrio
91+ { hfst = hlabel hlabeler (eqTable @a)
92+ , hsnd = hlabel hlabeler (eqTable @b)
93+ , htrd = hlabel hlabeler (eqTable @c)
94+ }
95+
96+
97+instance (EqTable a, EqTable b, EqTable c, EqTable d) => EqTable (a, b, c, d)
98+ where
99+ eqTable =
100+ HQuartet
101+ { hfst = hlabel hlabeler (eqTable @a)
102+ , hsnd = hlabel hlabeler (eqTable @b)
103+ , htrd = hlabel hlabeler (eqTable @c)
104+ , hfrt = hlabel hlabeler (eqTable @d)
105+ }
106+
107+
108+instance (EqTable a, EqTable b, EqTable c, EqTable d, EqTable e) =>
109+ EqTable (a, b, c, d, e)
110+ where
111+ eqTable =
112+ HQuintet
113+ { hfst = hlabel hlabeler (eqTable @a)
114+ , hsnd = hlabel hlabeler (eqTable @b)
115+ , htrd = hlabel hlabeler (eqTable @c)
116+ , hfrt = hlabel hlabeler (eqTable @d)
117+ , hfft = hlabel hlabeler (eqTable @e)
118+ }
66119
67120
68121-- | Compare two 'Table's for equality. This corresponds to comparing all
src/Rel8/Table/Lifted.hs+46−21
@@ -1,13 +1,18 @@
11{-# language ConstrainedClassMethods #-}
2+{-# language ConstraintKinds #-}
23{-# language DataKinds #-}
34{-# language FlexibleContexts #-}
45{-# language FlexibleInstances #-}
6+{-# language MultiParamTypeClasses #-}
7+{-# language QuantifiedConstraints #-}
58{-# language StandaloneKindSignatures #-}
69{-# language TypeFamilies #-}
10+{-# language UndecidableInstances #-}
711
812module Rel8.Table.Lifted
9− ( Table1( Columns1, ConstrainContext1, toColumns1, fromColumns1 )
10− , Table2( Columns2, ConstrainContext2, toColumns2, fromColumns2 )
13+ ( Table1( Columns1, ConstrainHContext1, toColumns1, fromColumns1 )
14+ , Table2( Columns2, ConstrainHContext2, toColumns2, fromColumns2 )
15+ , ConstrainContext
1116 )
1217where
1318
@@ -16,42 +21,62 @@ import Data.Kind ( Constraint, Type )
1621import Prelude ()
1722
1823-- rel8
19−import Rel8.Schema.Context ( Interpretation, Col )
24+import Rel8.Schema.Context ( Col )
2025import Rel8.Schema.HTable ( HTable )
26+import Rel8.Schema.HTable.Pair
2127import qualified Rel8.Schema.Kind as K
2228
2329
2430type Table1 :: (Type -> Type) -> Constraint
2531class Table1 f where
2632 type Columns1 f :: K.HTable -> K.HTable
27− type ConstrainContext1 f :: K.Context -> Constraint
28− type ConstrainContext1 _ = Interpretation
33+ type ConstrainHContext1 f :: K.HContext -> Constraint
34+ type ConstrainHContext1 _ = DefaultConstrainContext
2935
30− toColumns1 :: (ConstrainContext1 f context, HTable t)
31− => (a -> t (Col context))
36+ toColumns1 :: (ConstrainHContext1 f context, HTable t)
37+ => (a -> t context)
3238 -> f a
33− -> Columns1 f t (Col context)
39+ -> Columns1 f t context
3440
35− fromColumns1 :: (ConstrainContext1 f context, HTable t)
36− => (t (Col context) -> a)
37− -> Columns1 f t (Col context)
41+ fromColumns1 :: (ConstrainHContext1 f context, HTable t)
42+ => (t context -> a)
43+ -> Columns1 f t context
3844 -> f a
3945
4046
4147type Table2 :: (Type -> Type -> Type) -> Constraint
4248class Table2 p where
4349 type Columns2 p :: K.HTable -> K.HTable -> K.HTable
44− type ConstrainContext2 p :: K.Context -> Constraint
45− type ConstrainContext2 _ = Interpretation
50+ type ConstrainHContext2 p :: K.HContext -> Constraint
51+ type ConstrainHContext2 _ = DefaultConstrainContext
4652
47− toColumns2 :: (ConstrainContext2 p context, HTable t, HTable u)
48− => (a -> t (Col context))
49− -> (b -> u (Col context))
53+ toColumns2 :: (ConstrainHContext2 p context, HTable t, HTable u)
54+ => (a -> t context)
55+ -> (b -> u context)
5056 -> p a b
51− -> Columns2 p t u (Col context)
57+ -> Columns2 p t u context
5258
53− fromColumns2 :: (ConstrainContext2 p context, HTable t, HTable u)
54− => (t (Col context) -> a)
55− -> (u (Col context) -> b)
56− -> Columns2 p t u (Col context)
59+ fromColumns2 :: (ConstrainHContext2 p context, HTable t, HTable u)
60+ => (t context -> a)
61+ -> (u context -> b)
62+ -> Columns2 p t u context
5763 -> p a b
64+
65+
66+instance Table2 (,) where
67+ type Columns2 (,) = HPair
68+
69+ toColumns2 f g (a, b) = HPair (f a) (g b)
70+ fromColumns2 f g (HPair a b) = (f a, g b)
71+
72+
73+type DefaultConstrainContext :: K.HContext -> Constraint
74+class DefaultConstrainContext context
75+instance DefaultConstrainContext context
76+
77+
78+type ConstrainContext :: (K.Context -> Constraint) -> K.HContext -> Constraint
79+class (forall context. hcontext ~ Col context => constraint context)
80+ => ConstrainContext constraint hcontext
81+instance (hcontext ~ Col context, constraint context) =>
82+ ConstrainContext constraint hcontext
src/Rel8/Table/List.hs+30−1
@@ -1,7 +1,9 @@
11{-# language FlexibleContexts #-}
22{-# language FlexibleInstances #-}
33{-# language MultiParamTypeClasses #-}
4+{-# language ScopedTypeVariables #-}
45{-# language StandaloneKindSignatures #-}
6+{-# language TypeApplications #-}
57{-# language TypeFamilies #-}
68{-# language UndecidableInstances #-}
79
@@ -11,19 +13,26 @@ module Rel8.Table.List
1113where
1214
1315-- base
16+import Data.Functor.Identity ( Identity( Identity ) )
1417import Data.Kind ( Type )
1518import Prelude
1619
1720-- rel8
1821import Rel8.Expr ( Expr, Col(..) )
1922import Rel8.Expr.Array ( sappend, sempty )
23+import Rel8.Schema.Dict ( Dict( Dict ) )
2024import Rel8.Schema.HTable.List ( HListTable )
21−import Rel8.Schema.HTable.Vectorize ( happend, hempty )
25+import Rel8.Schema.HTable.Vectorize ( happend, hempty, hvectorize )
26+import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ) )
27+import Rel8.Schema.Spec ( SSpec( SSpec ) )
28+import Rel8.Schema.Spec.ConstrainDBType ( dbTypeDict, dbTypeNullability )
2229import Rel8.Table ( Table, Context, Columns, fromColumns, toColumns )
2330import Rel8.Table.Alternative
2431 ( AltTable, (<|>:)
2532 , AlternativeTable, emptyTable
2633 )
34+import Rel8.Table.Eq ( EqTable, eqTable )
35+import Rel8.Table.Ord ( OrdTable, ordTable )
2736import Rel8.Table.Recontextualize ( Recontextualize )
2837
2938
@@ -45,6 +54,26 @@ instance Recontextualize from to a b =>
4554 Recontextualize from to (ListTable a) (ListTable b)
4655
4756
57+instance EqTable a => EqTable (ListTable a) where
58+ eqTable =
59+ hvectorize
60+ (\SSpec {} (Identity dict) -> case dbTypeDict dict of
61+ Dict -> case dbTypeNullability dict of
62+ Nullable -> Dict
63+ NonNullable -> Dict)
64+ (Identity (eqTable @a))
65+
66+
67+instance OrdTable a => OrdTable (ListTable a) where
68+ ordTable =
69+ hvectorize
70+ (\SSpec {} (Identity dict) -> case dbTypeDict dict of
71+ Dict -> case dbTypeNullability dict of
72+ Nullable -> Dict
73+ NonNullable -> Dict)
74+ (Identity (ordTable @a))
75+
76+
4877instance AltTable ListTable where
4978 (<|>:) = (<>)
5079
src/Rel8/Table/Maybe.hs+24−13
@@ -29,15 +29,15 @@ import Rel8.Expr ( Expr )
2929import Rel8.Expr.Bool ( boolExpr )
3030import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )
3131import Rel8.Expr.Serialize ( litExpr )
32−import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
32+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler, hlabeler )
3333import Rel8.Schema.Context.Nullify
34− ( Nullifiable
35− , encodeTag, decodeTag
36− , nullifier, unnullifier
34+ ( Nullifiable, ConstrainTag
35+ , hencodeTag, hdecodeTag
36+ , hnullifier, hunnullifier
3737 )
3838import Rel8.Schema.HTable.Identity ( HIdentity(..) )
3939import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
40−import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
40+import Rel8.Schema.HTable.Maybe ( HMaybeTable(..), HMaybeNullifiable )
4141import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
4242import Rel8.Schema.Nullability
4343 ( Nullify
@@ -50,9 +50,11 @@ import Rel8.Table.Alternative
5050 , AlternativeTable, emptyTable
5151 )
5252import Rel8.Table.Bool ( bool )
53+import Rel8.Table.Eq ( EqTable, eqTable )
5354import Rel8.Table.Lifted
54− ( Table1, Columns1, ConstrainContext1, fromColumns1, toColumns1
55+ ( Table1, Columns1, ConstrainHContext1, fromColumns1, toColumns1
5556 )
57+import Rel8.Table.Ord ( OrdTable, ordTable )
5658import Rel8.Table.Recontextualize ( Recontextualize )
5759import Rel8.Table.Undefined ( undefined )
5860import Rel8.Type ( DBType )
@@ -124,22 +126,22 @@ instance (Table Expr a, Semigroup a) => Monoid (MaybeTable a) where
124126
125127instance Table1 MaybeTable where
126128 type Columns1 MaybeTable = HMaybeTable
127− type ConstrainContext1 MaybeTable = Nullifiable
129+ type ConstrainHContext1 MaybeTable = HMaybeNullifiable
128130
129131 toColumns1 f MaybeTable {tag, just} = HMaybeTable
130132 { htag
131− , hjust = hnullify (nullifier (isNonNull tag)) $ f just
133+ , hjust = hnullify (hnullifier (isNonNull tag)) $ f just
132134 }
133135 where
134− htag = HIdentity (encodeTag tag)
136+ htag = HIdentity (hencodeTag tag)
135137
136138 fromColumns1 f HMaybeTable {htag = HIdentity htag, hjust} = MaybeTable
137139 { tag
138140 , just = f $ runIdentity $
139− hunnullify (\a -> pure . unnullifier (isNonNull tag) a) hjust
141+ hunnullify (\a -> pure . hunnullifier (isNonNull tag) a) hjust
140142 }
141143 where
142− tag = decodeTag htag
144+ tag = hdecodeTag htag
143145
144146 {-# INLINABLE fromColumns1 #-}
145147 {-# INLINABLE toColumns1 #-}
@@ -148,6 +150,7 @@ instance Table1 MaybeTable where
148150instance
149151 ( Table context a
150152 , Labelable context, Nullifiable context
153+ , ConstrainTag context MaybeTag
151154 ) => Table context (MaybeTable a)
152155 where
153156 type Columns (MaybeTable a) = HMaybeTable (HLabel "Just" (Columns a))
@@ -158,12 +161,20 @@ instance
158161
159162
160163instance
161− ( Labelable from, Nullifiable from
162− , Labelable to, Nullifiable to
164+ ( Labelable from, Nullifiable from, ConstrainTag from MaybeTag
165+ , Labelable to, Nullifiable to, ConstrainTag to MaybeTag
163166 , Recontextualize from to a b
164167 ) => Recontextualize from to (MaybeTable a) (MaybeTable b)
165168
166169
170+instance EqTable a => EqTable (MaybeTable a) where
171+ eqTable = toColumns1 (hlabel hlabeler) (justTable (eqTable @a))
172+
173+
174+instance OrdTable a => OrdTable (MaybeTable a) where
175+ ordTable = toColumns1 (hlabel hlabeler) (justTable (ordTable @a))
176+
177+
167178-- | Check if a @MaybeTable@ is absent of any row.. Like 'isNothing'.
168179isNothingTable :: MaybeTable a -> Expr Bool
169180isNothingTable (MaybeTable tag _) = isNull tag
src/Rel8/Table/NonEmpty.hs+30−1
@@ -1,6 +1,8 @@
11{-# language FlexibleInstances #-}
22{-# language MultiParamTypeClasses #-}
3+{-# language ScopedTypeVariables #-}
34{-# language StandaloneKindSignatures #-}
5+{-# language TypeApplications #-}
46{-# language TypeFamilies #-}
57{-# language UndecidableInstances #-}
68
@@ -11,16 +13,23 @@ module Rel8.Table.NonEmpty
1113where
1214
1315-- base
16+import Data.Functor.Identity ( Identity( Identity ) )
1417import Data.Kind ( Type )
1518import Prelude
1619
1720-- rel8
1821import Rel8.Expr ( Expr, Col(..) )
1922import Rel8.Expr.Array ( sappend1 )
23+import Rel8.Schema.Dict ( Dict( Dict ) )
2024import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
21−import Rel8.Schema.HTable.Vectorize ( happend )
25+import Rel8.Schema.HTable.Vectorize ( happend, hvectorize )
26+import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ) )
27+import Rel8.Schema.Spec ( SSpec( SSpec ) )
28+import Rel8.Schema.Spec.ConstrainDBType ( dbTypeDict, dbTypeNullability )
2229import Rel8.Table ( Table, Context, Columns, fromColumns, toColumns )
2330import Rel8.Table.Alternative ( AltTable, (<|>:) )
31+import Rel8.Table.Eq ( EqTable, eqTable )
32+import Rel8.Table.Ord ( OrdTable, ordTable )
2433import Rel8.Table.Recontextualize ( Recontextualize )
2534
2635
@@ -43,6 +52,26 @@ instance Recontextualize from to a b =>
4352 Recontextualize from to (NonEmptyTable a) (NonEmptyTable b)
4453
4554
55+instance EqTable a => EqTable (NonEmptyTable a) where
56+ eqTable =
57+ hvectorize
58+ (\SSpec {} (Identity dict) -> case dbTypeDict dict of
59+ Dict -> case dbTypeNullability dict of
60+ Nullable -> Dict
61+ NonNullable -> Dict)
62+ (Identity (eqTable @a))
63+
64+
65+instance OrdTable a => OrdTable (NonEmptyTable a) where
66+ ordTable =
67+ hvectorize
68+ (\SSpec {} (Identity dict) -> case dbTypeDict dict of
69+ Dict -> case dbTypeNullability dict of
70+ Nullable -> Dict
71+ NonNullable -> Dict)
72+ (Identity (ordTable @a))
73+
74+
4675instance AltTable NonEmptyTable where
4776 (<|>:) = (<>)
4877
src/Rel8/Table/Ord.hs+70−3
@@ -1,6 +1,7 @@
11{-# language AllowAmbiguousTypes #-}
22{-# language DataKinds #-}
33{-# language DefaultSignatures #-}
4+{-# language DisambiguateRecordFields #-}
45{-# language FlexibleInstances #-}
56{-# language NamedFieldPuns #-}
67{-# language ScopedTypeVariables #-}
@@ -26,12 +27,22 @@ import Rel8.Expr ( Expr, Col(..) )
2627import Rel8.Expr.Bool ( (||.), (&&.), false, true )
2728import Rel8.Expr.Eq ( (==.) )
2829import Rel8.Expr.Ord ( (<.), (>.) )
30+import Rel8.Schema.Context.Label ( hlabeler )
2931import Rel8.Schema.Dict ( Dict( Dict ) )
30−import Rel8.Schema.HTable ( HConstrainTable, htabulateA, hfield, hdicts )
32+import Rel8.Schema.HTable
33+ ( HTable, HConstrainTable
34+ , htabulateA, hfield, hdicts
35+ )
36+import Rel8.Schema.HTable.Label ( hlabel )
37+import Rel8.Schema.HTable.Pair ( HPair(..) )
38+import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
39+import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
40+import Rel8.Schema.HTable.Trio ( HTrio(..) )
3141import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
32−import Rel8.Table ( Columns, toColumns )
42+import Rel8.Table ( Table, Columns, toColumns )
3343import Rel8.Table.Bool ( bool )
3444import Rel8.Table.Eq ( EqTable )
45+import Rel8.Type.Eq ( DBEq )
3546import Rel8.Type.Ord ( DBOrd )
3647import Rel8.Schema.Nullability (Sql)
3748
@@ -47,12 +58,68 @@ class EqTable a => OrdTable a where
4758 ordTable = hdicts @(Columns a) @(ConstrainDBType DBOrd)
4859
4960
50−instance (EqTable (t Expr), f ~ Expr, HConstrainTable (Columns (t Expr)) (ConstrainDBType DBOrd)) => OrdTable (t f)
61+instance
62+ ( Table Expr (t Expr)
63+ , f ~ Expr
64+ , HConstrainTable (Columns (t Expr)) (ConstrainDBType DBEq)
65+ , HConstrainTable (Columns (t Expr)) (ConstrainDBType DBOrd)
66+ )
67+ => OrdTable (t f)
68+
69+
70+instance
71+ ( HTable t
72+ , f ~ Col Expr
73+ , HConstrainTable t (ConstrainDBType DBEq)
74+ , HConstrainTable t (ConstrainDBType DBOrd)
75+ )
76+ => OrdTable (t f)
5177
5278
5379instance Sql DBOrd a => OrdTable (Expr a)
5480
5581
82+instance (OrdTable a, OrdTable b) => OrdTable (a, b) where
83+ ordTable =
84+ HPair
85+ { hfst = hlabel hlabeler (ordTable @a)
86+ , hsnd = hlabel hlabeler (ordTable @b)
87+ }
88+
89+
90+instance (OrdTable a, OrdTable b, OrdTable c) => OrdTable (a, b, c) where
91+ ordTable =
92+ HTrio
93+ { hfst = hlabel hlabeler (ordTable @a)
94+ , hsnd = hlabel hlabeler (ordTable @b)
95+ , htrd = hlabel hlabeler (ordTable @c)
96+ }
97+
98+
99+instance (OrdTable a, OrdTable b, OrdTable c, OrdTable d) => OrdTable (a, b, c, d)
100+ where
101+ ordTable =
102+ HQuartet
103+ { hfst = hlabel hlabeler (ordTable @a)
104+ , hsnd = hlabel hlabeler (ordTable @b)
105+ , htrd = hlabel hlabeler (ordTable @c)
106+ , hfrt = hlabel hlabeler (ordTable @d)
107+ }
108+
109+
110+instance (OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e) =>
111+ OrdTable (a, b, c, d, e)
112+ where
113+ ordTable =
114+ HQuintet
115+ { hfst = hlabel hlabeler (ordTable @a)
116+ , hsnd = hlabel hlabeler (ordTable @b)
117+ , htrd = hlabel hlabeler (ordTable @c)
118+ , hfrt = hlabel hlabeler (ordTable @d)
119+ , hfft = hlabel hlabeler (ordTable @e)
120+ }
121+
122+
56123-- | Test if one 'Table' sorts before another. Corresponds to comparing all
57124-- columns with '<'.
58125(<:) :: forall a. OrdTable a => a -> a -> Expr Bool
src/Rel8/Table/Order.hs+13−35
@@ -21,15 +21,11 @@ import Rel8.Expr.Order ( asc, desc, nullsFirst, nullsLast )
2121import Rel8.Order ( Order )
2222import Rel8.Schema.Dict ( Dict( Dict ) )
2323import Rel8.Schema.HTable (htabulateA, hfield, hspecs)
24−import Rel8.Schema.Nullability
25− ( Unnullify, Nullability( Nullable, NonNullable )
26− , Sql, nullabilization
27− )
28−import Rel8.Schema.Spec ( Spec( Spec ), SSpec( SSpec ) )
29−import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
24+import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ) )
25+import Rel8.Schema.Spec ( SSpec( SSpec ) )
26+import Rel8.Schema.Spec.ConstrainDBType ( dbTypeDict, dbTypeNullability )
3027import Rel8.Table
3128import Rel8.Table.Ord
32−import Rel8.Type.Ord
3329
3430
3531-- | Construct an 'Order' for a 'Table' by sorting all columns into ascending
@@ -38,10 +34,11 @@ ascTable :: forall a. OrdTable a => Order a
3834ascTable = contramap toColumns $ getConst $
3935 htabulateA @(Columns a) $ \field -> case hfield hspecs field of
4036 SSpec {} -> case hfield (ordTable @a) field of
41− dict@Dict -> case ord dict of
42− Dict -> Const $ unDB . (`hfield` field) >$< case nullability dict of
43− Nullable -> nullsFirst asc
44− NonNullable -> asc
37+ dict@Dict -> case dbTypeDict dict of
38+ Dict -> Const $ unDB . (`hfield` field) >$<
39+ case dbTypeNullability dict of
40+ Nullable -> nullsFirst asc
41+ NonNullable -> asc
4542
4643
4744-- | Construct an 'Order' for a 'Table' by sorting all columns into descending
@@ -50,27 +47,8 @@ descTable :: forall a. OrdTable a => Order a
5047descTable = contramap toColumns $ getConst $
5148 htabulateA @(Columns a) $ \field -> case hfield hspecs field of
5249 SSpec {} -> case hfield (ordTable @a) field of
53− dict@Dict -> case ord dict of
54− Dict -> Const $ unDB . (`hfield` field) >$< case nullability dict of
55− Nullable -> nullsLast desc
56− NonNullable -> desc
57−
58−
59−nullability :: Dict (ConstrainDBType DBOrd) ('Spec l n a) -> Nullability a
60−nullability = step2 . step1
61− where
62− step1 :: Dict (ConstrainDBType DBOrd) ('Spec l n a) -> Dict (Sql DBOrd) a
63− step1 Dict = Dict
64−
65− step2 :: Dict (Sql DBOrd) a -> Nullability a
66− step2 Dict = nullabilization
67−
68−
69−ord :: Dict (ConstrainDBType DBOrd) ('Spec l n a) -> Dict DBOrd (Unnullify a)
70−ord = step2 . step1
71− where
72− step1 :: Dict (ConstrainDBType DBOrd) ('Spec l n a) -> Dict (Sql DBOrd) a
73− step1 Dict = Dict
74−
75− step2 :: Dict (Sql DBOrd) a -> Dict DBOrd (Unnullify a)
76− step2 Dict = Dict
50+ dict@Dict -> case dbTypeDict dict of
51+ Dict -> Const $ unDB . (`hfield` field) >$<
52+ case dbTypeNullability dict of
53+ Nullable -> nullsLast desc
54+ NonNullable -> desc
src/Rel8/Table/These.hs+35−26
@@ -5,8 +5,10 @@
55{-# language FlexibleInstances #-}
66{-# language MultiParamTypeClasses #-}
77{-# language NamedFieldPuns #-}
8+{-# language ScopedTypeVariables #-}
89{-# language StandaloneKindSignatures #-}
910{-# language TupleSections #-}
11+{-# language TypeApplications #-}
1012{-# language TypeFamilies #-}
1113{-# language UndecidableInstances #-}
1214
@@ -29,28 +31,31 @@ import Prelude hiding ( undefined )
2931import Rel8.Expr ( Expr )
3032import Rel8.Expr.Bool ( (&&.), not_ )
3133import Rel8.Expr.Null ( isNonNull )
32−import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
34+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler, hlabeler )
3335import Rel8.Schema.Context.Nullify
34− ( Nullifiable, NullifiableEq
35− , encodeTag, decodeTag
36− , nullifier, unnullifier
36+ ( Nullifiable, ConstrainTag
37+ , hencodeTag, hdecodeTag
38+ , hnullifier, hunnullifier
3739 )
3840import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
3941import Rel8.Schema.HTable.Identity ( HIdentity(..) )
42+import Rel8.Schema.HTable.Maybe ( HMaybeNullifiable )
4043import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
4144import Rel8.Schema.HTable.These ( HTheseTable(..) )
4245import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
46+import Rel8.Table.Eq ( EqTable, eqTable )
4347import Rel8.Table.Lifted
44− ( Table1, Columns1, ConstrainContext1, fromColumns1, toColumns1
45− , Table2, Columns2, ConstrainContext2, fromColumns2, toColumns2
48+ ( Table2, Columns2, ConstrainHContext2, fromColumns2, toColumns2
4649 )
4750import Rel8.Table.Maybe
4851 ( MaybeTable(..)
4952 , maybeTable, justTable, nothingTable
5053 , isJustTable
5154 )
55+import Rel8.Table.Ord ( OrdTable, ordTable )
5256import Rel8.Table.Recontextualize ( Recontextualize )
5357import Rel8.Table.Undefined ( undefined )
58+import Rel8.Type.Tag ( MaybeTag )
5459
5560-- semigroupoids
5661import Data.Functor.Apply ( Apply, (<.>) )
@@ -108,37 +113,37 @@ instance (Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>
108113
109114instance Table2 TheseTable where
110115 type Columns2 TheseTable = HTheseTable
111− type ConstrainContext2 TheseTable = Nullifiable
116+ type ConstrainHContext2 TheseTable = HMaybeNullifiable
112117
113118 toColumns2 f g TheseTable {here, there} = HTheseTable
114− { hhereTag = HIdentity $ encodeTag (tag here)
115− , hhere = hnullify (nullifier (isNonNull (tag here))) $ f (just here)
116− , hthereTag = HIdentity $ encodeTag (tag there)
117− , hthere = hnullify (nullifier (isNonNull (tag there))) $ g (just there)
119+ { hhereTag = HIdentity $ hencodeTag (tag here)
120+ , hhere = hnullify (hnullifier (isNonNull (tag here))) $ f (just here)
121+ , hthereTag = HIdentity $ hencodeTag (tag there)
122+ , hthere = hnullify (hnullifier (isNonNull (tag there))) $ g (just there)
118123 }
119124
120125 fromColumns2 f g HTheseTable {hhereTag, hhere, hthereTag, hthere} =
121126 TheseTable
122127 { here =
123128 let
124− tag = decodeTag $ unHIdentity hhereTag
129+ tag = hdecodeTag $ unHIdentity hhereTag
125130 in
126131 MaybeTable
127132 { tag
128133 , just = f $
129134 runIdentity $
130− hunnullify (\a -> pure . unnullifier (isNonNull tag) a)
135+ hunnullify (\a -> pure . hunnullifier (isNonNull tag) a)
131136 hhere
132137 }
133138 , there =
134139 let
135− tag = decodeTag $ unHIdentity hthereTag
140+ tag = hdecodeTag $ unHIdentity hthereTag
136141 in
137142 MaybeTable
138143 { tag
139144 , just = g $
140145 runIdentity $
141− hunnullify (\a -> pure . unnullifier (isNonNull tag) a)
146+ hunnullify (\a -> pure . hunnullifier (isNonNull tag) a)
142147 hthere
143148 }
144149 }
@@ -147,17 +152,9 @@ instance Table2 TheseTable where
147152 {-# INLINABLE toColumns2 #-}
148153
149154
150−instance Table context a => Table1 (TheseTable a) where
151− type Columns1 (TheseTable a) = HTheseTable (Columns a)
152− type ConstrainContext1 (TheseTable a) = NullifiableEq (Context a)
153−
154− toColumns1 = toColumns2 toColumns
155− fromColumns1 = fromColumns2 fromColumns
156−
157−
158155instance
159156 ( Table context a, Table context b
160− , Labelable context, Nullifiable context
157+ , Labelable context, Nullifiable context, ConstrainTag context MaybeTag
161158 ) => Table context (TheseTable a b)
162159 where
163160 type Columns (TheseTable a b) =
@@ -175,14 +172,26 @@ instance
175172
176173
177174instance
178− ( Labelable from, Nullifiable from
179− , Labelable to, Nullifiable to
175+ ( Labelable from, Nullifiable from, ConstrainTag from MaybeTag
176+ , Labelable to, Nullifiable to, ConstrainTag to MaybeTag
180177 , Recontextualize from to a1 b1
181178 , Recontextualize from to a2 b2
182179 ) =>
183180 Recontextualize from to (TheseTable a1 a2) (TheseTable b1 b2)
184181
185182
183+instance (EqTable a, EqTable b) => EqTable (TheseTable a b) where
184+ eqTable =
185+ toColumns2 (hlabel hlabeler) (hlabel hlabeler)
186+ (thoseTable (eqTable @a) (eqTable @b))
187+
188+
189+instance (OrdTable a, OrdTable b) => OrdTable (TheseTable a b) where
190+ ordTable =
191+ toColumns2 (hlabel hlabeler) (hlabel hlabeler)
192+ (thoseTable (ordTable @a) (ordTable @b))
193+
194+
186195isThisTable :: TheseTable a b -> Expr Bool
187196isThisTable a = hasHereTable a &&. not_ (hasThereTable a)
188197