e3bde04 · rel8 · git.iko.soy

git.iko.soy/rel8

Introduce more principled way to aggregate and name {Either,Maybe,These}Tables

commite3bde04eba83acaf1d8e98781a4103b1296426b2 authorShane O'Brien <shane.obrien@circuithub.com> dateTue 30 Mar 2021, 00:48 (6 years ago) parente4b4b63

13 files changed+426−168

compare with master

unifiedsplit

rel8.cabal+1 src/Rel8/Aggregate.hs+1−33 src/Rel8/Expr.hs+1−17 src/Rel8/Query/Maybe.hs+5−3 src/Rel8/Query/These.hs+3−1 src/Rel8/Schema/Context/Nullify.hs+134−45 src/Rel8/Schema/Insert.hs+14−10 src/Rel8/Schema/Name.hs−24 src/Rel8/Schema/Nullability/Internal.hs+13−1 src/Rel8/Table/Either.hs+35−15 src/Rel8/Table/Maybe.hs+34−11 src/Rel8/Table/Tag.hs+138 src/Rel8/Table/These.hs+47−8

rel8.cabal+1

@@ -147,6 +147,7 @@ library

147147 Rel8.Table.Order

148148 Rel8.Table.Recontextualize

149149 Rel8.Table.Serialize

150+ Rel8.Table.Tag

150151 Rel8.Table.These

151152 Rel8.Table.Undefined

152153

src/Rel8/Aggregate.hs+1−33

@@ -12,7 +12,7 @@

1212{-# language UndecidableSuperClasses #-}

1313

1414module Rel8.Aggregate

15− ( Aggregate(..)

15+ ( Aggregate(..), foldInputs, mapInputs

1616 , Aggregator(..), unsafeMakeAggregate

1717 , Aggregates

1818 , Col( Aggregation )

@@ -20,12 +20,9 @@ module Rel8.Aggregate

2020where

2121

2222-- base

23−import Control.Applicative ( empty )

24−import Data.Foldable ( fold )

2523import Data.Functor.Const ( Const( Const ), getConst )

2624import Data.Functor.Identity ( Identity )

2725import Data.Kind ( Constraint, Type )

28−import Data.Monoid ( First( First ), getFirst )

2926import Prelude

3027

3128-- opaleye

@@ -35,14 +32,9 @@ import qualified Opaleye.Internal.PackMap as Opaleye

3532

3633-- rel8

3734import Rel8.Expr ( Expr, Col(..) )

38−import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )

3935import Rel8.Opaque ( Opaque )

4036import Rel8.Schema.Context ( Interpretation(..) )

4137import Rel8.Schema.Context.Label ( Labelable(..) )

42−import Rel8.Schema.Context.Nullify

43− ( Nullifiable, encodeTag, decodeTag, nullifier, unnullifier

44− , runTag, unnull

45− )

4638import Rel8.Schema.HTable ( hfield, htabulate, htabulateA, hspecs )

4739import Rel8.Schema.Name ( Name )

4840import Rel8.Schema.Nullability ( Sql )

@@ -117,30 +109,6 @@ instance Labelable Aggregate where

117109 unlabeler (Aggregation aggregate) = Aggregation aggregate

118110

119111

120−instance Nullifiable Aggregate where

121− encodeTag = Aggregation . groupByExpr

122− where

123− groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Nothing

124− decodeTag (Aggregation aggregate) = fold $ undoGroupBy aggregate

125− where

126− undoGroupBy = getFirst . foldInputs go

127− where

128− go Nothing = pure . fromPrimExpr

129− go _ = const $ First empty

130−

131− nullifier tag SSpec {nullability} (Aggregation aggregate) = Aggregation $

132− mapInputs (toPrimExpr . runTag nullability tag . fromPrimExpr) $

133− runTag nullability tag <$> aggregate

134−

135− unnullifier _ SSpec {nullability} (Aggregation aggregate) =

136− Aggregation $ unnull nullability <$> aggregate

137−

138− {-# INLINABLE encodeTag #-}

139− {-# INLINABLE decodeTag #-}

140− {-# INLINABLE nullifier #-}

141− {-# INLINABLE unnullifier #-}

142−

143−

144112-- | @Aggregates a b@ means that the columns in @a@ are all 'Aggregate' 'Expr's

145113-- for the columns in @b@.

146114type Aggregates :: Type -> Type -> Constraint

src/Rel8/Expr.hs+1−17

@@ -38,16 +38,12 @@ import Rel8.Expr.Opaleye

3838import Rel8.Expr.Serialize ( litExpr )

3939import Rel8.Schema.Context ( Interpretation, Col )

4040import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )

41−import Rel8.Schema.Context.Nullify

42− ( Nullifiable, encodeTag, decodeTag, nullifier, unnullifier

43− , runTag, unnull

44− )

4541import Rel8.Schema.HTable.Type ( HType( HType ) )

4642import Rel8.Schema.Nullability

4743 ( Nullability( Nullable, NonNullable )

4844 , Sql, nullabilization

4945 )

50−import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

46+import Rel8.Schema.Spec ( Spec( Spec ) )

5147import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )

5248import Rel8.Table.Recontextualize ( Recontextualize )

5349import Rel8.Type ( DBType )

@@ -128,15 +124,3 @@ instance Sql DBType a => Recontextualize Identity Expr (Identity a) (Expr a)

128124instance Labelable Expr where

129125 labeler (DB a) = DB a

130126 unlabeler (DB a) = DB a

131−

132−

133−instance Nullifiable Expr where

134− encodeTag = DB

135− decodeTag (DB a) = a

136− nullifier tag SSpec {nullability} (DB a) = DB $ runTag nullability tag a

137− unnullifier _ SSpec {nullability} (DB a) = DB $ unnull nullability a

138−

139− {-# INLINABLE encodeTag #-}

140− {-# INLINABLE decodeTag #-}

141− {-# INLINABLE nullifier #-}

142− {-# INLINABLE unnullifier #-}

src/Rel8/Query/Maybe.hs+5−3

@@ -25,14 +25,16 @@ import Rel8.Query.Filter ( where_ )

2525import Rel8.Query.Opaleye ( mapOpaleye )

2626import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )

2727import Rel8.Table.Opaleye ( unpackspec )

28+import Rel8.Table.Tag ( Tag(..), fromExpr )

2829

2930

3031optional :: Query a -> Query (MaybeTable a)

3132optional = mapOpaleye $ Opaleye.QueryArr . go

3233 where

33− go query (i, left, tag) = (MaybeTable t' a, join, Opaleye.next tag')

34+ go query (i, left, tag) =

35+ (MaybeTable (fromExpr t') a, join, Opaleye.next tag')

3436 where

35− (MaybeTable t a, right, tag') =

37+ (MaybeTable Tag {expr = t} a, right, tag') =

3638 Opaleye.runSimpleQueryArr (pure <$> query) (i, tag)

3739 (t', bindings) = Opaleye.run $

3840 Opaleye.runUnpackspec unpackspec (Opaleye.extractAttr "maybe" tag') t

@@ -132,5 +134,5 @@ bindMaybeTable query (MaybeTable input a) = do

132134traverseMaybeTable :: (a -> Query b) -> MaybeTable a -> Query (MaybeTable b)

133135traverseMaybeTable query ma@(MaybeTable input _) = do

134136 MaybeTable output b <- optional (query =<< catMaybeTable ma)

135− where_ $ output ==. input

137+ where_ $ expr output ==. expr input

136138 pure $ MaybeTable input b

src/Rel8/Query/These.hs+3−1

@@ -33,6 +33,7 @@ import Rel8.Table ( Table )

3333import Rel8.Table.Either ( EitherTable( EitherTable ) )

3434import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )

3535import Rel8.Table.Opaleye ( unpackspec )

36+import Rel8.Table.Tag ( Tag(..) )

3637import Rel8.Table.These

3738 ( TheseTable( TheseTable )

3839 , hasHereTable, hasThereTable

@@ -104,9 +105,10 @@ keepThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do

104105loseThoseTable :: TheseTable a b -> Query (EitherTable a b)

105106loseThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do

106107 where_ $ not_ $ isThoseTable t

107− pure $ EitherTable tag a b

108+ pure $ EitherTable result a b

108109 where

109110 tag = boolExpr (litExpr IsLeft) (litExpr IsRight) (isThatTable t)

111+ result = (mempty `asTypeOf` result) {expr = tag}

110112

111113

112114bindTheseTable :: (Table Expr a, Semigroup a, Monad m)

src/Rel8/Schema/Context/Nullify.hs+134−45

@@ -2,6 +2,7 @@

22{-# language FlexibleContexts #-}

33{-# language FlexibleInstances #-}

44{-# language InstanceSigs #-}

5+{-# language LambdaCase #-}

56{-# language MultiParamTypeClasses #-}

67{-# language NamedFieldPuns #-}

78{-# language ScopedTypeVariables #-}

@@ -12,29 +13,37 @@

1213module Rel8.Schema.Context.Nullify

1314 ( Nullifiable( ConstrainTag, encodeTag, decodeTag, nullifier, unnullifier )

1415 , HNullifiable( HConstrainTag, hencodeTag, hdecodeTag, hnullifier, hunnullifier )

15− , unnull, runTag

16+ , runTag, runTagExpr, unnull, unnullExpr

1617 )

1718where

1819

1920-- base

21+import Control.Monad ( guard )

22+import Data.Functor.Identity ( Identity )

2023import Data.Kind ( Constraint, Type )

24+import GHC.TypeLits ( KnownSymbol )

2125import Prelude hiding ( null )

2226

2327-- opaleye

2428import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

2529

2630-- rel8

27−import {-# SOURCE #-} Rel8.Expr ( Expr )

31+import Rel8.Aggregate

32+ ( Aggregate, Col(..)

33+ , mapInputs

34+ , unsafeMakeAggregate

35+ )

36+import Rel8.Expr ( Expr, Col(..) )

2837import Rel8.Expr.Bool ( boolExpr )

2938import Rel8.Expr.Null ( nullify, unsafeUnnullify )

30−import Rel8.Expr.Opaleye ( fromPrimExpr )

31−import Rel8.Kind.Labels ( KnownLabels )

39+import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )

3240import Rel8.Kind.Necessity ( Necessity( Required ) )

3341import Rel8.Schema.Context ( Interpretation, Col(..) )

3442import qualified Rel8.Schema.Kind as K

43+import Rel8.Schema.Name ( Name( Name ), Col(..) )

3544import Rel8.Schema.Nullability

3645 ( Nullify

37− , Nullability( Nullable, NonNullable ), nullabilization

46+ , Nullability( Nullable, NonNullable )

3847 , Sql

3948 )

4049import Rel8.Schema.Dict ( Dict( Dict ) )

@@ -43,8 +52,10 @@ import Rel8.Schema.Spec.ConstrainDBType

4352 ( ConstrainDBType

4453 , dbTypeDict, dbTypeNullability, fromNullabilityDict

4554 )

46−import Rel8.Type.Eq ( DBEq )

47−import Rel8.Type.Monoid ( DBMonoid, memptyExpr )

55+import Rel8.Table.Tag

56+ ( Tag(..), Taggable

57+ , fromAggregate, fromExpr, fromIdentity, fromName

58+ )

4859

4960

5061type Nullifiable :: K.Context -> Constraint

@@ -52,65 +63,150 @@ class Interpretation context => Nullifiable context where

5263 type ConstrainTag context :: Type -> Constraint

5364 type ConstrainTag _context = DefaultConstrainTag

5465

55− encodeTag :: (Sql (ConstrainTag context) a, Sql DBEq a, KnownLabels labels)

56− => Expr a

66+ encodeTag ::

67+ ( Sql (ConstrainTag context) a

68+ , KnownSymbol label

69+ , Taggable a

70+ )

71+ => Tag label a

5772 -> Col context ('Spec labels 'Required a)

5873

59− decodeTag :: (Sql (ConstrainTag context) a, Sql DBMonoid a)

74+ decodeTag ::

75+ ( Sql (ConstrainTag context) a

76+ , KnownSymbol label

77+ , Taggable a

78+ )

6079 => Col context ('Spec labels 'Required a)

61− -> Expr a

80+ -> Tag label a

6281

6382 nullifier :: ()

64− => Expr Bool

65− -> SSpec ('Spec labels necessity a)

66− -> Col context ('Spec labels necessity a)

67− -> Col context ('Spec labels necessity (Nullify a))

83+ => Tag label a

84+ -> (a -> Bool)

85+ -> (Expr a -> Expr Bool)

86+ -> SSpec ('Spec labels necessity x)

87+ -> Col context ('Spec labels necessity x)

88+ -> Col context ('Spec labels necessity (Nullify x))

6889

6990 unnullifier :: ()

70− => Expr Bool

71− -> SSpec ('Spec labels necessity a)

72− -> Col context ('Spec labels necessity (Nullify a))

73− -> Col context ('Spec labels necessity a)

91+ => SSpec ('Spec labels necessity x)

92+ -> Col context ('Spec labels necessity (Nullify x))

93+ -> Col context ('Spec labels necessity x)

7494

7595

76−runTag :: Nullability a -> Expr Bool -> Expr a -> Expr (Nullify a)

77−runTag nullability tag a = case nullability of

96+instance Nullifiable Aggregate where

97+ encodeTag Tag {aggregator, expr} =

98+ Aggregation $ unsafeMakeAggregate toPrimExpr fromPrimExpr aggregator expr

99+

100+ decodeTag (Aggregation aggregate) = fromAggregate aggregate

101+

102+ nullifier Tag {expr} _ test SSpec {nullability} (Aggregation aggregate) =

103+ Aggregation $

104+ mapInputs (toPrimExpr . runTagExpr nullability condition . fromPrimExpr) $

105+ runTagExpr nullability condition <$> aggregate

106+ where

107+ condition = test expr

108+

109+ unnullifier SSpec {nullability} (Aggregation aggregate) =

110+ Aggregation $ unnullExpr nullability <$> aggregate

111+

112+ {-# INLINABLE encodeTag #-}

113+ {-# INLINABLE decodeTag #-}

114+ {-# INLINABLE nullifier #-}

115+ {-# INLINABLE unnullifier #-}

116+

117+

118+instance Nullifiable Expr where

119+ encodeTag Tag {expr} = DB expr

120+ decodeTag (DB a) = fromExpr a

121+ nullifier Tag {expr} _ test SSpec {nullability} (DB a) =

122+ DB $ runTagExpr nullability (test expr) a

123+ unnullifier SSpec {nullability} (DB a) = DB $ unnullExpr nullability a

124+

125+ {-# INLINABLE encodeTag #-}

126+ {-# INLINABLE decodeTag #-}

127+ {-# INLINABLE nullifier #-}

128+ {-# INLINABLE unnullifier #-}

129+

130+

131+instance Nullifiable Identity where

132+ encodeTag Tag {identity} = Result identity

133+ decodeTag (Result a) = fromIdentity a

134+ nullifier Tag {identity} test _ SSpec {nullability} (Result a) =

135+ Result $ runTag nullability (test identity) a

136+ unnullifier SSpec {nullability} (Result a) = Result $ unnull nullability a

137+

138+ {-# INLINABLE encodeTag #-}

139+ {-# INLINABLE decodeTag #-}

140+ {-# INLINABLE nullifier #-}

141+ {-# INLINABLE unnullifier #-}

142+

143+

144+instance Nullifiable Name where

145+ encodeTag Tag {name = Name name} = NameCol name

146+ decodeTag (NameCol name) = fromName (Name name)

147+ nullifier _ _ _ _ (NameCol name) = NameCol name

148+ unnullifier _ (NameCol name) = NameCol name

149+

150+ {-# INLINABLE encodeTag #-}

151+ {-# INLINABLE decodeTag #-}

152+ {-# INLINABLE nullifier #-}

153+ {-# INLINABLE unnullifier #-}

154+

155+

156+runTagExpr :: Nullability a -> Expr Bool -> Expr a -> Expr (Nullify a)

157+runTagExpr nullability tag a = case nullability of

78158 Nullable -> boolExpr null a tag

79159 NonNullable -> boolExpr null (nullify a) tag

80160 where

81161 null = fromPrimExpr $ Opaleye.ConstExpr Opaleye.NullLit

82162

83163

84−unnull :: Nullability a -> Expr (Nullify a) -> Expr a

85−unnull nullability a = case nullability of

164+unnullExpr :: Nullability a -> Expr (Nullify a) -> Expr a

165+unnullExpr nullability a = case nullability of

86166 Nullable -> a

87167 NonNullable -> unsafeUnnullify a

88168

89169

170+runTag :: Nullability a -> Bool -> a -> Nullify a

171+runTag nullability tag a = case nullability of

172+ Nullable -> a <* guard tag

173+ NonNullable -> a <$ guard tag

174+

175+

176+unnull :: Nullability a -> Nullify a -> a

177+unnull nullability ma = case nullability of

178+ Nullable -> ma

179+ NonNullable -> case ma of

180+ Just a -> a

181+ Nothing ->

182+ error "Rel8.Schema.Context.Nullify.unnull: mismatch between tag and data"

183+

184+

90185type HNullifiable :: K.HContext -> Constraint

91186class HNullifiable context where

92187 type HConstrainTag context :: Type -> Constraint

93188 type HConstrainTag _context = DefaultConstrainTag

94189

95− hencodeTag :: (Sql (HConstrainTag context) a, Sql DBEq a, KnownLabels labels)

96− => Expr a

190+ hencodeTag :: (Sql (HConstrainTag context) a, KnownSymbol label, Taggable a)

191+ => Tag label a

97192 -> context ('Spec labels 'Required a)

98193

99− hdecodeTag :: (Sql (HConstrainTag context) a, Sql DBMonoid a)

194+ hdecodeTag :: (Sql (HConstrainTag context) a, KnownSymbol label, Taggable a)

100195 => context ('Spec labels 'Required a)

101− -> Expr a

196+ -> Tag label a

102197

103198 hnullifier :: ()

104− => Expr Bool

105− -> SSpec ('Spec labels necessity a)

106− -> context ('Spec labels necessity a)

107− -> context ('Spec labels necessity (Nullify a))

199+ => Tag label a

200+ -> (a -> Bool)

201+ -> (Expr a -> Expr Bool)

202+ -> SSpec ('Spec labels necessity x)

203+ -> context ('Spec labels necessity x)

204+ -> context ('Spec labels necessity (Nullify x))

108205

109206 hunnullifier :: ()

110− => Expr Bool

111− -> SSpec ('Spec labels necessity a)

112− -> context ('Spec labels necessity (Nullify a))

113− -> context ('Spec labels necessity a)

207+ => SSpec ('Spec labels necessity x)

208+ -> context ('Spec labels necessity (Nullify x))

209+ -> context ('Spec labels necessity x)

114210

115211

116212instance Nullifiable context => HNullifiable (Col context) where

@@ -125,21 +221,14 @@ instance HNullifiable (Dict (ConstrainDBType constraint)) where

125221 type HConstrainTag (Dict (ConstrainDBType constraint)) = constraint

126222

127223 hencodeTag _ = Dict

224+ hdecodeTag = mempty

128225

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

226+ hnullifier _ _ _ SSpec {} dict = case dbTypeDict dict of

138227 Dict -> case dbTypeNullability dict of

139228 Nullable -> Dict

140229 NonNullable -> Dict

141230

142− hunnullifier _ SSpec {nullability} dict = case dbTypeDict dict of

231+ hunnullifier SSpec {nullability} dict = case dbTypeDict dict of

143232 Dict -> case nullability of

144233 Nullable -> Dict

145234 NonNullable -> case dbTypeNullability dict of

src/Rel8/Schema/Insert.hs+14−10

@@ -36,7 +36,7 @@ import Rel8.Schema.Context ( Interpretation(..) )

3636import Rel8.Schema.Context.Label ( Labelable(..) )

3737import Rel8.Schema.Context.Nullify

3838 ( Nullifiable, encodeTag, decodeTag, nullifier, unnullifier

39− , runTag, unnull

39+ , runTagExpr, unnullExpr

4040 )

4141import Rel8.Schema.HTable.Type ( HType(HType) )

4242import qualified Rel8.Schema.Kind as K

@@ -47,6 +47,7 @@ import Rel8.Schema.Table ( TableSchema )

4747import Rel8.Statement.Returning ( Returning )

4848import Rel8.Table ( Table(..) )

4949import Rel8.Table.Recontextualize ( Recontextualize )

50+import Rel8.Table.Tag ( Tag(..), fromExpr )

5051import Rel8.Type ( DBType )

5152

5253

@@ -134,16 +135,20 @@ instance Labelable Insert where

134135

135136

136137instance Nullifiable Insert where

137− encodeTag = RequiredInsert

138− decodeTag (RequiredInsert a) = a

138+ encodeTag = RequiredInsert . expr

139+ decodeTag (RequiredInsert a) = fromExpr a

139140

140− nullifier tag SSpec {nullability} = \case

141− RequiredInsert a -> RequiredInsert $ runTag nullability tag a

142− OptionalInsert ma -> OptionalInsert $ runTag nullability tag <$> ma

141+ nullifier Tag {expr} _ test SSpec {nullability} = \case

142+ RequiredInsert a ->

143+ RequiredInsert $ runTagExpr nullability condition a

144+ OptionalInsert ma ->

145+ OptionalInsert $ runTagExpr nullability condition <$> ma

146+ where

147+ condition = test expr

143148

144− unnullifier _ SSpec {nullability} = \case

145− RequiredInsert a -> RequiredInsert $ unnull nullability a

146− OptionalInsert ma -> OptionalInsert $ unnull nullability <$> ma

149+ unnullifier SSpec {nullability} = \case

150+ RequiredInsert a -> RequiredInsert $ unnullExpr nullability a

151+ OptionalInsert ma -> OptionalInsert $ unnullExpr nullability <$> ma

147152

148153 {-# INLINABLE encodeTag #-}

149154 {-# INLINABLE decodeTag #-}

@@ -151,7 +156,6 @@ instance Nullifiable Insert where

151156 {-# INLINABLE unnullifier #-}

152157

153158

154−

155159-- | @Inserts a b@ means that the columns in @a@ are compatible for inserting

156160-- with the table @b@.

157161type Inserts :: Type -> Type -> Constraint

src/Rel8/Schema/Name.hs−24

@@ -21,24 +21,18 @@ where

2121

2222-- base

2323import Data.Functor.Identity ( Identity )

24−import qualified Data.List.NonEmpty as NonEmpty

2524import Data.Kind ( Constraint, Type )

2625import Data.String ( IsString )

2726import Prelude

2827

2928-- rel8

3029import Rel8.Expr ( Expr )

31−import Rel8.Kind.Labels ( KnownLabels, labelsSing, renderLabels )

3230import Rel8.Opaque ( Opaque )

3331import Rel8.Schema.Context ( Interpretation, Col )

3432import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )

35−import Rel8.Schema.Context.Nullify

36− ( Nullifiable, encodeTag, decodeTag, nullifier, unnullifier

37− )

3833import Rel8.Schema.HTable.Type ( HType( HType ) )

3934import qualified Rel8.Schema.Kind as K

4035import Rel8.Schema.Nullability ( Sql )

41−import Rel8.Schema.Spec ( Spec( Spec ) )

4236import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )

4337import Rel8.Table.Recontextualize ( Recontextualize )

4438import Rel8.Type ( DBType )

@@ -86,24 +80,6 @@ instance Labelable Name where

8680 unlabeler (NameCol a) = NameCol a

8781

8882

89−instance Nullifiable Name where

90− encodeTag _ = nameFromLabel

91− decodeTag _ = mempty

92− nullifier _ _ (NameCol name) = NameCol name

93− unnullifier _ _ (NameCol name) = NameCol name

94−

95− {-# INLINABLE encodeTag #-}

96− {-# INLINABLE decodeTag #-}

97− {-# INLINABLE nullifier #-}

98− {-# INLINABLE unnullifier #-}

99−

100−

101−nameFromLabel :: forall labels necessity a.

102− KnownLabels labels => Col Name ('Spec labels necessity a)

103−nameFromLabel = case labelsSing @labels of

104− labels -> NameCol (NonEmpty.last (renderLabels labels))

105−

106−

10783-- | @Selects a b@ means that @a@ is a schema (i.e., a 'Table' of 'Name's) for

10884-- the 'Expr' columns in @b@.

10985type Selects :: Type -> Type -> Constraint

src/Rel8/Schema/Nullability/Internal.hs+13−1

@@ -5,6 +5,7 @@

55{-# language FunctionalDependencies #-}

66{-# language GADTs #-}

77{-# language MultiParamTypeClasses #-}

8+{-# language RankNTypes #-}

89{-# language QuantifiedConstraints #-}

910{-# language StandaloneKindSignatures #-}

1011{-# language TypeFamilies #-}

@@ -17,7 +18,7 @@ module Rel8.Schema.Nullability.Internal

1718 , Homonullable

1819 , Nullability( Nullable, NonNullable )

1920 , HasNullability, nullabilization

20− , Sql, toSql

21+ , Sql, fromSql, mapSql, toSql

2122 )

2223where

2324

@@ -118,6 +119,17 @@ class

118119instance (constraint (Unnullify a), HasNullability a) => Sql constraint a

119120

120121

122+fromSql :: Dict (Sql constraint) a -> (Nullability a, Dict constraint (Unnullify a))

123+fromSql Dict = (nullabilization, Dict)

124+

125+

126+mapSql :: ()

127+ => (forall x. Dict constraint x -> Dict constraint' x)

128+ -> Dict (Sql constraint) a -> Dict (Sql constraint') a

129+mapSql f dict = case fromSql dict of

130+ (nullability, dict') -> toSql nullability (f dict')

131+

132+

121133toSql :: Nullability a -> Dict constraint (Unnullify a) -> Dict (Sql constraint) a

122134toSql NonNullable Dict = Dict

123135toSql Nullable Dict = Dict

src/Rel8/Table/Either.hs+35−15

@@ -15,6 +15,7 @@ module Rel8.Table.Either

1515 ( EitherTable(..)

1616 , eitherTable, leftTable, rightTable

1717 , isLeftTable, isRightTable

18+ , aggregateEitherTable, nameEitherTable

1819 )

1920where

2021

@@ -25,8 +26,9 @@ import Data.Kind ( Type )

2526import Prelude hiding ( undefined )

2627

2728-- rel8

29+import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )

2830import Rel8.Expr ( Expr )

29−import Rel8.Expr.Serialize ( litExpr )

31+import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )

3032import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler, hlabeler )

3133import Rel8.Schema.Context.Nullify

3234 ( Nullifiable, ConstrainTag

@@ -37,6 +39,7 @@ import Rel8.Schema.HTable.Either ( HEitherTable(..), HEitherNullifiable )

3739import Rel8.Schema.HTable.Identity ( HIdentity(..) )

3840import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )

3941import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )

42+import Rel8.Schema.Name ( Name )

4043import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )

4144import Rel8.Table.Bool ( bool )

4245import Rel8.Table.Eq ( EqTable, eqTable )

@@ -45,21 +48,22 @@ import Rel8.Table.Lifted

4548 )

4649import Rel8.Table.Ord ( OrdTable, ordTable )

4750import Rel8.Table.Recontextualize ( Recontextualize )

51+import Rel8.Table.Tag ( Tag(..), fromIdentity, fromName )

4852import Rel8.Table.Undefined ( undefined )

4953import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )

5054

5155-- semigroupoids

52−import Data.Functor.Apply ( Apply, (<.>) )

56+import Data.Functor.Apply ( Apply, (<.>), liftF3 )

5357import Data.Functor.Bind ( Bind, (>>-) )

5458

5559

5660type EitherTable :: Type -> Type -> Type

5761data EitherTable a b = EitherTable

58− { tag :: Expr EitherTag

62+ { tag :: Tag "isRight" EitherTag

5963 , left :: a

6064 , right :: b

6165 }

62− deriving stock (Show, Functor)

66+ deriving stock Functor

6367

6468

6569instance Bifunctor EitherTable where

@@ -68,7 +72,7 @@ instance Bifunctor EitherTable where

6872

6973instance Table Expr a => Apply (EitherTable a) where

7074 EitherTable tag l1 f <.> EitherTable tag' l2 a =

71− EitherTable (tag <> tag') (bool l1 l2 (isLeft tag)) (f a)

75+ EitherTable (tag <> tag') (bool l1 l2 (isLeft (expr tag))) (f a)

7276

7377

7478instance Table Expr a => Applicative (EitherTable a) where

@@ -79,7 +83,7 @@ instance Table Expr a => Applicative (EitherTable a) where

7983instance Table Expr a => Bind (EitherTable a) where

8084 EitherTable tag l1 a >>- f = case f a of

8185 EitherTable tag' l2 b ->

82− EitherTable (tag <> tag') (bool l1 l2 (isRight tag)) b

86+ EitherTable (tag <> tag') (bool l1 l2 (isRight (expr tag))) b

8387

8488

8589instance Table Expr a => Monad (EitherTable a) where

@@ -96,8 +100,8 @@ instance Table2 EitherTable where

96100

97101 toColumns2 f g EitherTable {tag, left, right} = HEitherTable

98102 { htag

99− , hleft = hnullify (hnullifier (isLeft tag)) $ f left

100− , hright = hnullify (hnullifier (isRight tag)) $ g right

103+ , hleft = hnullify (hnullifier tag (== IsLeft) isLeft) $ f left

104+ , hright = hnullify (hnullifier tag (== IsRight) isRight) $ g right

101105 }

102106 where

103107 htag = HIdentity (hencodeTag tag)

@@ -106,9 +110,9 @@ instance Table2 EitherTable where

106110 EitherTable

107111 { tag

108112 , left = f $ runIdentity $

109− hunnullify (\a -> pure . hunnullifier (isLeft tag) a) hleft

113+ hunnullify (\a -> pure . hunnullifier a) hleft

110114 , right = g $ runIdentity $

111− hunnullify (\a -> pure . hunnullifier (isRight tag) a) hright

115+ hunnullify (\a -> pure . hunnullifier a) hright

112116 }

113117 where

114118 tag = hdecodeTag $ unHIdentity htag

@@ -159,21 +163,21 @@ instance (OrdTable a, OrdTable b) => OrdTable (EitherTable a b) where

159163

160164

161165isLeftTable :: EitherTable a b -> Expr Bool

162−isLeftTable = isLeft . tag

166+isLeftTable = isLeft . expr . tag

163167

164168

165169isRightTable :: EitherTable a b -> Expr Bool

166−isRightTable = isRight . tag

170+isRightTable = isRight . expr . tag

167171

168172

169173eitherTable :: Table Expr c

170174 => (a -> c) -> (b -> c) -> EitherTable a b -> c

171175eitherTable f g EitherTable {tag, left, right} =

172− bool (f left) (g right) (isRight tag)

176+ bool (f left) (g right) (isRight (expr tag))

173177

174178

175179leftTable :: Table Expr b => a -> EitherTable a b

176−leftTable a = EitherTable (litExpr IsLeft) a undefined

180+leftTable a = EitherTable (fromIdentity IsLeft) a undefined

177181

178182

179183rightTable :: Table Expr a => b -> EitherTable a b

@@ -181,4 +185,20 @@ rightTable = rightTableWith undefined

181185

182186

183187rightTableWith :: a -> b -> EitherTable a b

184−rightTableWith = EitherTable (litExpr IsRight)

188+rightTableWith = EitherTable (fromIdentity IsRight)

189+

190+

191+aggregateEitherTable :: ()

192+ => (a -> Aggregate c)

193+ -> (b -> Aggregate d)

194+ -> EitherTable a b

195+ -> Aggregate (EitherTable c d)

196+aggregateEitherTable f g EitherTable {tag, left, right} =

197+ liftF3 EitherTable (tag <$ aggregate) (f left) (g right)

198+ where

199+ Tag {aggregator, expr} = tag

200+ aggregate = unsafeMakeAggregate toPrimExpr fromPrimExpr aggregator expr

201+

202+

203+nameEitherTable :: Name EitherTag -> a -> b -> EitherTable a b

204+nameEitherTable = EitherTable . fromName

src/Rel8/Table/Maybe.hs+34−11

@@ -16,19 +16,24 @@ module Rel8.Table.Maybe

1616 , maybeTable, nothingTable, justTable

1717 , isNothingTable, isJustTable

1818 , ($?)

19+ , aggregateMaybeTable

20+ , nameMaybeTable

1921 )

2022where

2123

2224-- base

25+import qualified Data.Bool as Bool

2326import Data.Functor.Identity ( runIdentity )

2427import Data.Kind ( Type )

28+import Data.Maybe ( isJust, isNothing )

2529import Prelude hiding ( null, repeat, undefined, zipWith )

2630

2731-- rel8

32+import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )

2833import Rel8.Expr ( Expr )

2934import Rel8.Expr.Bool ( boolExpr )

3035import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )

31−import Rel8.Expr.Serialize ( litExpr )

36+import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )

3237import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler, hlabeler )

3338import Rel8.Schema.Context.Nullify

3439 ( Nullifiable, ConstrainTag

@@ -39,6 +44,7 @@ import Rel8.Schema.HTable.Identity ( HIdentity(..) )

3944import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )

4045import Rel8.Schema.HTable.Maybe ( HMaybeTable(..), HMaybeNullifiable )

4146import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )

47+import Rel8.Schema.Name ( Name )

4248import Rel8.Schema.Nullability

4349 ( Nullify

4450 , Nullability( Nullable, NonNullable )

@@ -56,12 +62,13 @@ import Rel8.Table.Lifted

5662 )

5763import Rel8.Table.Ord ( OrdTable, ordTable )

5864import Rel8.Table.Recontextualize ( Recontextualize )

65+import Rel8.Table.Tag ( Tag(..), fromIdentity, fromName )

5966import Rel8.Table.Undefined ( undefined )

6067import Rel8.Type ( DBType )

6168import Rel8.Type.Tag ( MaybeTag( IsJust ) )

6269

6370-- semigroupoids

64−import Data.Functor.Apply ( Apply, (<.>) )

71+import Data.Functor.Apply ( Apply, (<.>), liftF2 )

6572import Data.Functor.Bind ( Bind, (>>-) )

6673

6774

@@ -75,10 +82,10 @@ import Data.Functor.Bind ( Bind, (>>-) )

7582-- a "nullTag" - to track whether or not the outer join produced any rows.

7683type MaybeTable :: Type -> Type

7784data MaybeTable a = MaybeTable

78− { tag :: Expr (Maybe MaybeTag)

85+ { tag :: Tag "isJust" (Maybe MaybeTag)

7986 , just :: a

8087 }

81− deriving stock (Show, Functor)

88+ deriving stock Functor

8289

8390

8491instance Apply MaybeTable where

@@ -105,7 +112,11 @@ instance Monad MaybeTable where

105112

106113instance AltTable MaybeTable where

107114 ma@(MaybeTable tag a) <|>: MaybeTable tag' b = MaybeTable

108− { tag = boolExpr tag tag' condition

115+ { tag = (tag <> tag')

116+ { expr = boolExpr (expr tag) (expr tag') condition

117+ , identity =

118+ Bool.bool (identity tag) (identity tag') (isNothing (identity tag))

119+ }

109120 , just = bool a b condition

110121 }

111122 where

@@ -130,7 +141,7 @@ instance Table1 MaybeTable where

130141

131142 toColumns1 f MaybeTable {tag, just} = HMaybeTable

132143 { htag

133− , hjust = hnullify (hnullifier (isNonNull tag)) $ f just

144+ , hjust = hnullify (hnullifier tag isJust isNonNull) $ f just

134145 }

135146 where

136147 htag = HIdentity (hencodeTag tag)

@@ -138,7 +149,7 @@ instance Table1 MaybeTable where

138149 fromColumns1 f HMaybeTable {htag = HIdentity htag, hjust} = MaybeTable

139150 { tag

140151 , just = f $ runIdentity $

141− hunnullify (\a -> pure . hunnullifier (isNonNull tag) a) hjust

152+ hunnullify (\a -> pure . hunnullifier a) hjust

142153 }

143154 where

144155 tag = hdecodeTag htag

@@ -177,12 +188,12 @@ instance OrdTable a => OrdTable (MaybeTable a) where

177188

178189-- | Check if a @MaybeTable@ is absent of any row.. Like 'isNothing'.

179190isNothingTable :: MaybeTable a -> Expr Bool

180−isNothingTable (MaybeTable tag _) = isNull tag

191+isNothingTable (MaybeTable tag _) = isNull (expr tag)

181192

182193

183194-- | Check if a @MaybeTable@ contains a row. Like 'isJust'.

184195isJustTable :: MaybeTable a -> Expr Bool

185−isJustTable (MaybeTable tag _) = isNonNull tag

196+isJustTable (MaybeTable tag _) = isNonNull (expr tag)

186197

187198

188199-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.

@@ -192,13 +203,13 @@ maybeTable b f ma@(MaybeTable _ a) = bool (f a) b (isNothingTable ma)

192203

193204-- | The null table. Like 'Nothing'.

194205nothingTable :: Table Expr a => MaybeTable a

195−nothingTable = MaybeTable null undefined

206+nothingTable = MaybeTable (fromIdentity Nothing) undefined

196207

197208

198209-- | Lift any table into 'MaybeTable'. Like 'Just'. Note you can also use

199210-- 'pure'.

200211justTable :: a -> MaybeTable a

201−justTable = MaybeTable (nullify (litExpr IsJust))

212+justTable = MaybeTable (fromIdentity (Just IsJust))

202213

203214

204215-- | Project a single expression out of a 'MaybeTable'. You can think of this

@@ -213,3 +224,15 @@ f $? ma@(MaybeTable _ a) = case nullabilization @b of

213224 Nullable -> boolExpr (f a) null (isNothingTable ma)

214225 NonNullable -> boolExpr (nullify (f a)) null (isNothingTable ma)

215226infixl 4 $?

227+

228+

229+aggregateMaybeTable :: ()

230+ => (a -> Aggregate b) -> MaybeTable a -> Aggregate (MaybeTable b)

231+aggregateMaybeTable f MaybeTable {tag = tag@Tag {aggregator, expr}, just} =

232+ liftF2 MaybeTable (tag <$ aggregate) (f just)

233+ where

234+ aggregate = unsafeMakeAggregate toPrimExpr fromPrimExpr aggregator expr

235+

236+

237+nameMaybeTable :: Name (Maybe MaybeTag) -> a -> MaybeTable a

238+nameMaybeTable = MaybeTable . fromName

src/Rel8/Table/Tag.hsnew file+138

@@ -0,0 +1,138 @@

1+{-# language DataKinds #-}

2+{-# language FlexibleContexts #-}

3+{-# language FlexibleInstances #-}

4+{-# language GADTs #-}

5+{-# language InstanceSigs #-}

6+{-# language NamedFieldPuns #-}

7+{-# language ScopedTypeVariables #-}

8+{-# language StandaloneKindSignatures #-}

9+{-# language TypeApplications #-}

10+{-# language UndecidableInstances #-}

11+

12+module Rel8.Table.Tag

13+ ( Tag(..), Taggable

14+ , fromAggregate

15+ , fromExpr

16+ , fromIdentity

17+ , fromName

18+ )

19+where

20+

21+-- base

22+import Control.Applicative ( (<|>), empty, liftA2 )

23+import Data.Kind ( Type )

24+import Data.Foldable ( fold )

25+import Data.Monoid ( getFirst )

26+import Data.Proxy ( Proxy( Proxy ) )

27+import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )

28+import Prelude

29+

30+-- rel8

31+import Rel8.Aggregate ( Aggregate, Aggregator, foldInputs )

32+import Rel8.Expr ( Expr )

33+import Rel8.Expr.Opaleye ( fromPrimExpr )

34+import Rel8.Expr.Serialize ( litExpr )

35+import Rel8.Schema.Dict ( Dict( Dict ) )

36+import Rel8.Schema.Name ( Name( Name ) )

37+import Rel8.Schema.Nullability

38+ ( Nullability( Nullable, NonNullable )

39+ , Sql, nullabilization, mapSql

40+ )

41+import Rel8.Type ( DBType )

42+import Rel8.Type.Monoid ( DBMonoid )

43+import Rel8.Type.Semigroup ( DBSemigroup )

44+

45+

46+type Tag :: Symbol -> Type -> Type

47+data Tag label a = Tag

48+ { expr :: Expr a

49+ , aggregator :: Maybe Aggregator

50+ , identity :: a

51+ , name :: Name a

52+ }

53+

54+

55+class Taggable a where

56+ tappend :: KnownSymbol label => Tag label a -> Tag label a -> Tag label a

57+ tempty :: KnownSymbol label => Tag label a

58+ tlit :: a -> Expr a

59+

60+

61+instance (Sql Monoid a, Sql DBMonoid a) => Taggable a where

62+ tappend :: forall label. KnownSymbol label

63+ => Tag label a -> Tag label a -> Tag label a

64+ tappend a b = Tag

65+ { expr = case mapSql dbSemigroupFromDBMonoid (Dict @_ @a) of

66+ Dict -> expr a <> expr b

67+ , aggregator = aggregator a <|> aggregator b

68+ , identity = case mapSql semigroupFromMonoid (Dict @_ @a) of

69+ Dict -> case nullabilization @a of

70+ Nullable -> liftA2 (<>) (identity a) (identity b)

71+ NonNullable -> identity a <> identity b

72+ , name = case (name a, symbolVal (Proxy @label)) of

73+ (Name x, y)

74+ | x == y -> name b

75+ | otherwise -> name a

76+ }

77+

78+ tempty :: forall label. KnownSymbol label => Tag label a

79+ tempty = Tag

80+ { expr = mempty

81+ , aggregator = empty

82+ , identity = case nullabilization @a of

83+ Nullable -> Just mempty

84+ NonNullable -> mempty

85+ , name = Name (symbolVal (Proxy @label))

86+ }

87+

88+ tlit = case mapSql (dbTypeFromDBSemigroup . dbSemigroupFromDBMonoid) dict of

89+ Dict -> litExpr

90+ where

91+ dict = Dict @_ @a

92+

93+

94+instance (KnownSymbol label, Taggable a) => Semigroup (Tag label a) where

95+ (<>) = tappend

96+

97+

98+instance (KnownSymbol label, Taggable a) => Monoid (Tag label a) where

99+ mempty = tempty

100+

101+

102+fromAggregate :: forall a label. (KnownSymbol label, Taggable a)

103+ => Aggregate (Expr a) -> Tag label a

104+fromAggregate = fold . getFirst . foldInputs go

105+ where

106+ go aggregator primExpr = pure $ (tempty @a @label)

107+ { expr = fromPrimExpr primExpr

108+ , aggregator

109+ }

110+

111+

112+fromExpr :: forall label a. (KnownSymbol label, Taggable a)

113+ => Expr a -> Tag label a

114+fromExpr expr = (tempty @a @label) {expr}

115+

116+

117+fromIdentity :: forall a label. (KnownSymbol label, Taggable a)

118+ => a -> Tag label a

119+fromIdentity identity = (mempty @(Tag label a))

120+ { expr = tlit identity

121+ , identity

122+ }

123+

124+

125+fromName :: forall a label. Taggable a => Name a -> Tag label a

126+fromName name = (mempty @(Tag "" a)) {name}

127+

128+

129+dbTypeFromDBSemigroup :: Dict DBSemigroup a -> Dict DBType a

130+dbTypeFromDBSemigroup Dict = Dict

131+

132+

133+dbSemigroupFromDBMonoid :: Dict DBMonoid a -> Dict DBSemigroup a

134+dbSemigroupFromDBMonoid Dict = Dict

135+

136+

137+semigroupFromMonoid :: Dict Monoid a -> Dict Semigroup a

138+semigroupFromMonoid Dict = Dict

src/Rel8/Table/These.hs+47−8

@@ -5,6 +5,7 @@

55{-# language FlexibleInstances #-}

66{-# language MultiParamTypeClasses #-}

77{-# language NamedFieldPuns #-}

8+{-# language RecordWildCards #-}

89{-# language ScopedTypeVariables #-}

910{-# language StandaloneKindSignatures #-}

1011{-# language TupleSections #-}

@@ -18,6 +19,7 @@ module Rel8.Table.These

1819 , isThisTable, isThatTable, isThoseTable

1920 , hasHereTable, hasThereTable

2021 , justHereTable, justThereTable

22+ , aggregateTheseTable, nameTheseTable

2123 )

2224where

2325

@@ -25,9 +27,11 @@ where

2527import Data.Bifunctor ( Bifunctor, bimap )

2628import Data.Functor.Identity ( runIdentity )

2729import Data.Kind ( Type )

30+import Data.Maybe ( isJust )

2831import Prelude hiding ( undefined )

2932

3033-- rel8

34+import Rel8.Aggregate ( Aggregate )

3135import Rel8.Expr ( Expr )

3236import Rel8.Expr.Bool ( (&&.), not_ )

3337import Rel8.Expr.Null ( isNonNull )

@@ -42,6 +46,7 @@ import Rel8.Schema.HTable.Identity ( HIdentity(..) )

4246import Rel8.Schema.HTable.Maybe ( HMaybeNullifiable )

4347import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )

4448import Rel8.Schema.HTable.These ( HTheseTable(..) )

49+import Rel8.Schema.Name ( Name )

4550import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )

4651import Rel8.Table.Eq ( EqTable, eqTable )

4752import Rel8.Table.Lifted

@@ -51,14 +56,16 @@ import Rel8.Table.Maybe

5156 ( MaybeTable(..)

5257 , maybeTable, justTable, nothingTable

5358 , isJustTable

59+ , aggregateMaybeTable, nameMaybeTable

5460 )

5561import Rel8.Table.Ord ( OrdTable, ordTable )

5662import Rel8.Table.Recontextualize ( Recontextualize )

63+import Rel8.Table.Tag ( Tag(..) )

5764import Rel8.Table.Undefined ( undefined )

5865import Rel8.Type.Tag ( MaybeTag )

5966

6067-- semigroupoids

61−import Data.Functor.Apply ( Apply, (<.>) )

68+import Data.Functor.Apply ( Apply, (<.>), liftF2 )

6269import Data.Functor.Bind ( Bind, (>>-) )

6370

6471

@@ -67,7 +74,7 @@ data TheseTable a b = TheseTable

6774 { here :: MaybeTable a

6875 , there :: MaybeTable b

6976 }

70− deriving stock (Show, Functor)

77+ deriving stock Functor

7178

7279

7380instance Bifunctor TheseTable where

@@ -116,10 +123,12 @@ instance Table2 TheseTable where

116123 type ConstrainHContext2 TheseTable = HMaybeNullifiable

117124

118125 toColumns2 f g TheseTable {here, there} = HTheseTable

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)

126+ { hhereTag = HIdentity $ hencodeTag (toHereTag (tag here))

127+ , hhere =

128+ hnullify (hnullifier (tag here) isJust isNonNull) $ f (just here)

129+ , hthereTag = HIdentity $ hencodeTag (toThereTag (tag there))

130+ , hthere =

131+ hnullify (hnullifier (tag there) isJust isNonNull) $ g (just there)

123132 }

124133

125134 fromColumns2 f g HTheseTable {hhereTag, hhere, hthereTag, hthere} =

@@ -132,7 +141,7 @@ instance Table2 TheseTable where

132141 { tag

133142 , just = f $

134143 runIdentity $

135− hunnullify (\a -> pure . hunnullifier (isNonNull tag) a)

144+ hunnullify (\a -> pure . hunnullifier a)

136145 hhere

137146 }

138147 , there =

@@ -143,7 +152,7 @@ instance Table2 TheseTable where

143152 { tag

144153 , just = g $

145154 runIdentity $

146− hunnullify (\a -> pure . hunnullifier (isNonNull tag) a)

155+ hunnullify (\a -> pure . hunnullifier a)

147156 hthere

148157 }

149158 }

@@ -192,6 +201,14 @@ instance (OrdTable a, OrdTable b) => OrdTable (TheseTable a b) where

192201 (thoseTable (ordTable @a) (ordTable @b))

193202

194203

204+toHereTag :: Tag "isJust" a -> Tag "hasHere" a

205+toHereTag Tag {..} = Tag {..}

206+

207+

208+toThereTag :: Tag "isJust" a -> Tag "hasThere" a

209+toThereTag Tag {..} = Tag {..}

210+

211+

195212isThisTable :: TheseTable a b -> Expr Bool

196213isThisTable a = hasHereTable a &&. not_ (hasThereTable a)

197214

@@ -239,3 +256,25 @@ theseTable f g h TheseTable {here, there} =

239256 (maybeTable undefined f here)

240257 (\b -> maybeTable (g b) (`h` b) here)

241258 there

259+

260+

261+aggregateTheseTable :: ()

262+ => (a -> Aggregate c)

263+ -> (b -> Aggregate d)

264+ -> TheseTable a b

265+ -> Aggregate (TheseTable c d)

266+aggregateTheseTable f g TheseTable {here, there} =

267+ liftF2 TheseTable (aggregateMaybeTable f here) (aggregateMaybeTable g there)

268+

269+

270+nameTheseTable :: ()

271+ => Name (Maybe MaybeTag)

272+ -> Name (Maybe MaybeTag)

273+ -> a

274+ -> b

275+ -> TheseTable a b

276+nameTheseTable here there a b =

277+ TheseTable

278+ { here = nameMaybeTable here a

279+ , there = nameMaybeTable there b

280+ }