e3bde04 · rel8 · git.iko.soy

git.iko.soy/rel8

on master help sign in

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

e3bde04Shane O'Brien6 years ago

rel8.cabal+1

compare with master

unifiedsplit

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

147 Rel8.Table.Order

148 Rel8.Table.Recontextualize

149 Rel8.Table.Serialize

150+ Rel8.Table.Tag

150 Rel8.Table.These

151 Rel8.Table.These

151 Rel8.Table.Undefined

152 Rel8.Table.Undefined

152

153

src/Rel8/Aggregate.hs+1−33

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

12{-# language UndecidableSuperClasses #-}

14module Rel8.Aggregate

15− ( Aggregate(..)

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

16 , Aggregator(..), unsafeMakeAggregate

17 , Aggregates

18 , Col( Aggregation )

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

20where

22-- base

23−import Control.Applicative ( empty )

24−import Data.Foldable ( fold )

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

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

26import Data.Functor.Identity ( Identity )

24import Data.Functor.Identity ( Identity )

27import Data.Kind ( Constraint, Type )

25import Data.Kind ( Constraint, Type )

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

29import Prelude

26import Prelude

31-- opaleye

28-- opaleye

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

36-- rel8

33-- rel8

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

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

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

39import Rel8.Opaque ( Opaque )

35import Rel8.Opaque ( Opaque )

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

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

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

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

42−import Rel8.Schema.Context.Nullify

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

44− , runTag, unnull

45− )

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

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

47import Rel8.Schema.Name ( Name )

39import Rel8.Schema.Name ( Name )

48import Rel8.Schema.Nullability ( Sql )

40import Rel8.Schema.Nullability ( Sql )

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

117 unlabeler (Aggregation aggregate) = Aggregation aggregate

109 unlabeler (Aggregation aggregate) = Aggregation aggregate

118

110

119

111

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−

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

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

145-- for the columns in @b@.

113-- for the columns in @b@.

146type Aggregates :: Type -> Type -> Constraint

114type Aggregates :: Type -> Type -> Constraint

src/Rel8/Expr.hs+1−17

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

38import Rel8.Expr.Serialize ( litExpr )

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

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

41−import Rel8.Schema.Context.Nullify

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

43− , runTag, unnull

44− )

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

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

46import Rel8.Schema.Nullability

42import Rel8.Schema.Nullability

47 ( Nullability( Nullable, NonNullable )

43 ( Nullability( Nullable, NonNullable )

48 , Sql, nullabilization

44 , Sql, nullabilization

49 )

45 )

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

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

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

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

52import Rel8.Table.Recontextualize ( Recontextualize )

48import Rel8.Table.Recontextualize ( Recontextualize )

53import Rel8.Type ( DBType )

49import Rel8.Type ( DBType )

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

128instance Labelable Expr where

124instance Labelable Expr where

129 labeler (DB a) = DB a

125 labeler (DB a) = DB a

130 unlabeler (DB a) = DB a

126 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_ )

25import Rel8.Query.Opaleye ( mapOpaleye )

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

27import Rel8.Table.Opaleye ( unpackspec )

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

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

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

31optional = mapOpaleye $ Opaleye.QueryArr . go

32optional = mapOpaleye $ Opaleye.QueryArr . go

32 where

33 where

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

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

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

34 where

36 where

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

135− where_ $ output ==. input

137+ where_ $ expr output ==. expr input

136 pure $ MaybeTable input b

138 pure $ MaybeTable input b

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

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

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

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

35import Rel8.Table.Opaleye ( unpackspec )

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

36import Rel8.Table.These

37import Rel8.Table.These

37 ( TheseTable( TheseTable )

38 ( TheseTable( TheseTable )

38 , hasHereTable, hasThereTable

39 , hasHereTable, hasThereTable

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

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

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

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

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

106 where_ $ not_ $ isThoseTable t

107 where_ $ not_ $ isThoseTable t

107− pure $ EitherTable tag a b

108+ pure $ EitherTable result a b

108 where

109 where

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

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

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

110

112

111

113

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

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

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

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

2{-# language FlexibleContexts #-}

3{-# language FlexibleInstances #-}

4{-# language InstanceSigs #-}

5+{-# language LambdaCase #-}

5{-# language MultiParamTypeClasses #-}

6{-# language MultiParamTypeClasses #-}

6{-# language NamedFieldPuns #-}

7{-# language NamedFieldPuns #-}

7{-# language ScopedTypeVariables #-}

8{-# language ScopedTypeVariables #-}

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

12module Rel8.Schema.Context.Nullify

13module Rel8.Schema.Context.Nullify

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

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

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

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

15− , unnull, runTag

16+ , runTag, runTagExpr, unnull, unnullExpr

16 )

17 )

17where

18where

19-- base

20-- base

21+import Control.Monad ( guard )

22+import Data.Functor.Identity ( Identity )

20import Data.Kind ( Constraint, Type )

23import Data.Kind ( Constraint, Type )

24+import GHC.TypeLits ( KnownSymbol )

21import Prelude hiding ( null )

25import Prelude hiding ( null )

23-- opaleye

27-- opaleye

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

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

26-- rel8

30-- rel8

31+import Rel8.Aggregate

32+ ( Aggregate, Col(..)

33+ , mapInputs

34+ , unsafeMakeAggregate

35+ )

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

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

28import Rel8.Expr.Bool ( boolExpr )

37import Rel8.Expr.Bool ( boolExpr )

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

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

30−import Rel8.Expr.Opaleye ( fromPrimExpr )

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

31−import Rel8.Kind.Labels ( KnownLabels )

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

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

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

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

34import qualified Rel8.Schema.Kind as K

42import qualified Rel8.Schema.Kind as K

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

35import Rel8.Schema.Nullability

44import Rel8.Schema.Nullability

36 ( Nullify

45 ( Nullify

37− , Nullability( Nullable, NonNullable ), nullabilization

46+ , Nullability( Nullable, NonNullable )

38 , Sql

47 , Sql

39 )

48 )

40import Rel8.Schema.Dict ( Dict( Dict ) )

49import Rel8.Schema.Dict ( Dict( Dict ) )

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

43 ( ConstrainDBType

52 ( ConstrainDBType

44 , dbTypeDict, dbTypeNullability, fromNullabilityDict

53 , dbTypeDict, dbTypeNullability, fromNullabilityDict

45 )

54 )

46−import Rel8.Type.Eq ( DBEq )

55+import Rel8.Table.Tag

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

56+ ( Tag(..), Taggable

57+ , fromAggregate, fromExpr, fromIdentity, fromName

58+ )

50type Nullifiable :: K.Context -> Constraint

61type Nullifiable :: K.Context -> Constraint

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

52 type ConstrainTag context :: Type -> Constraint

63 type ConstrainTag context :: Type -> Constraint

53 type ConstrainTag _context = DefaultConstrainTag

64 type ConstrainTag _context = DefaultConstrainTag

66+ encodeTag ::

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

67+ ( Sql (ConstrainTag context) a

56− => Expr a

68+ , KnownSymbol label

69+ , Taggable a

70+ )

71+ => Tag label a

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

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

74+ decodeTag ::

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

75+ ( Sql (ConstrainTag context) a

76+ , KnownSymbol label

77+ , Taggable a

78+ )

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

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

61− -> Expr a

80+ -> Tag label a

63 nullifier :: ()

82 nullifier :: ()

83+ => Tag label a

84+ -> (a -> Bool)

64− => Expr Bool

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

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

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

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

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

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

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

69 unnullifier :: ()

90 unnullifier :: ()

70− => Expr Bool

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

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

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

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

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

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

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+

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

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

77−runTag nullability tag a = case nullability of

157+runTagExpr nullability tag a = case nullability of

78 Nullable -> boolExpr null a tag

158 Nullable -> boolExpr null a tag

79 NonNullable -> boolExpr null (nullify a) tag

159 NonNullable -> boolExpr null (nullify a) tag

80 where

160 where

81 null = fromPrimExpr $ Opaleye.ConstExpr Opaleye.NullLit

161 null = fromPrimExpr $ Opaleye.ConstExpr Opaleye.NullLit

162

163

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

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

85−unnull nullability a = case nullability of

165+unnullExpr nullability a = case nullability of

86 Nullable -> a

166 Nullable -> a

87 NonNullable -> unsafeUnnullify a

167 NonNullable -> unsafeUnnullify a

168

169

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+

90type HNullifiable :: K.HContext -> Constraint

185type HNullifiable :: K.HContext -> Constraint

91class HNullifiable context where

186class HNullifiable context where

92 type HConstrainTag context :: Type -> Constraint

187 type HConstrainTag context :: Type -> Constraint

93 type HConstrainTag _context = DefaultConstrainTag

188 type HConstrainTag _context = DefaultConstrainTag

189

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

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

96− => Expr a

191+ => Tag label a

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

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

193

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

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

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

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

101− -> Expr a

196+ -> Tag label a

102

197

103 hnullifier :: ()

198 hnullifier :: ()

199+ => Tag label a

200+ -> (a -> Bool)

104− => Expr Bool

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

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

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

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

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

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

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

108

205

109 hunnullifier :: ()

206 hunnullifier :: ()

110− => Expr Bool

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

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

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

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

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

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

114

210

115

211

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

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

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

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

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

126

222

127 hencodeTag _ = Dict

223 hencodeTag _ = Dict

224+ hdecodeTag = mempty

128

225

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

138 Dict -> case dbTypeNullability dict of

227 Dict -> case dbTypeNullability dict of

139 Nullable -> Dict

228 Nullable -> Dict

140 NonNullable -> Dict

229 NonNullable -> Dict

141

230

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

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

143 Dict -> case nullability of

232 Dict -> case nullability of

144 Nullable -> Dict

233 Nullable -> Dict

145 NonNullable -> case dbTypeNullability dict of

234 NonNullable -> case dbTypeNullability dict of

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

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

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

37import Rel8.Schema.Context.Nullify

38 ( Nullifiable, encodeTag, decodeTag, nullifier, unnullifier

39− , runTag, unnull

39+ , runTagExpr, unnullExpr

40 )

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

42import qualified Rel8.Schema.Kind as K

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

47import Rel8.Statement.Returning ( Returning )

48import Rel8.Table ( Table(..) )

49import Rel8.Table.Recontextualize ( Recontextualize )

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

50import Rel8.Type ( DBType )

51import Rel8.Type ( DBType )

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

134

135

136

136instance Nullifiable Insert where

137instance Nullifiable Insert where

137− encodeTag = RequiredInsert

138+ encodeTag = RequiredInsert . expr

138− decodeTag (RequiredInsert a) = a

139+ decodeTag (RequiredInsert a) = fromExpr a

139

140

140− nullifier tag SSpec {nullability} = \case

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

142+ RequiredInsert a ->

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

143+ RequiredInsert $ runTagExpr nullability condition a

144+ OptionalInsert ma ->

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

145+ OptionalInsert $ runTagExpr nullability condition <$> ma

146+ where

147+ condition = test expr

143

148

144− unnullifier _ SSpec {nullability} = \case

149+ unnullifier SSpec {nullability} = \case

145− RequiredInsert a -> RequiredInsert $ unnull nullability a

150+ RequiredInsert a -> RequiredInsert $ unnullExpr nullability a

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

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

147

152

148 {-# INLINABLE encodeTag #-}

153 {-# INLINABLE encodeTag #-}

149 {-# INLINABLE decodeTag #-}

154 {-# INLINABLE decodeTag #-}

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

151 {-# INLINABLE unnullifier #-}

156 {-# INLINABLE unnullifier #-}

152

157

153

158

154−

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

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

156-- with the table @b@.

160-- with the table @b@.

157type Inserts :: Type -> Type -> Constraint

161type Inserts :: Type -> Type -> Constraint

src/Rel8/Schema/Name.hs−24

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

22-- base

23import Data.Functor.Identity ( Identity )

24−import qualified Data.List.NonEmpty as NonEmpty

25import Data.Kind ( Constraint, Type )

24import Data.Kind ( Constraint, Type )

26import Data.String ( IsString )

25import Data.String ( IsString )

27import Prelude

26import Prelude

29-- rel8

28-- rel8

30import Rel8.Expr ( Expr )

29import Rel8.Expr ( Expr )

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

32import Rel8.Opaque ( Opaque )

30import Rel8.Opaque ( Opaque )

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

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

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

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

35−import Rel8.Schema.Context.Nullify

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

37− )

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

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

39import qualified Rel8.Schema.Kind as K

34import qualified Rel8.Schema.Kind as K

40import Rel8.Schema.Nullability ( Sql )

35import Rel8.Schema.Nullability ( Sql )

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

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

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

43import Rel8.Table.Recontextualize ( Recontextualize )

37import Rel8.Table.Recontextualize ( Recontextualize )

44import Rel8.Type ( DBType )

38import Rel8.Type ( DBType )

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

86 unlabeler (NameCol a) = NameCol a

80 unlabeler (NameCol a) = NameCol a

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−

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

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

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

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

109type Selects :: Type -> Type -> Constraint

85type Selects :: Type -> Type -> Constraint

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

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

5{-# language FunctionalDependencies #-}

6{-# language GADTs #-}

7{-# language MultiParamTypeClasses #-}

8+{-# language RankNTypes #-}

8{-# language QuantifiedConstraints #-}

9{-# language QuantifiedConstraints #-}

9{-# language StandaloneKindSignatures #-}

10{-# language StandaloneKindSignatures #-}

10{-# language TypeFamilies #-}

11{-# language TypeFamilies #-}

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

17 , Homonullable

18 , Homonullable

18 , Nullability( Nullable, NonNullable )

19 , Nullability( Nullable, NonNullable )

19 , HasNullability, nullabilization

20 , HasNullability, nullabilization

20− , Sql, toSql

21+ , Sql, fromSql, mapSql, toSql

21 )

22 )

22where

23where

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

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

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

119

120

121

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+

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

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

122toSql NonNullable Dict = Dict

134toSql NonNullable Dict = Dict

123toSql Nullable Dict = Dict

135toSql Nullable Dict = Dict

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

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

15 ( EitherTable(..)

16 , eitherTable, leftTable, rightTable

17 , isLeftTable, isRightTable

18+ , aggregateEitherTable, nameEitherTable

18 )

19 )

19where

20where

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

25import Prelude hiding ( undefined )

26import Prelude hiding ( undefined )

27-- rel8

28-- rel8

29+import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )

28import Rel8.Expr ( Expr )

30import Rel8.Expr ( Expr )

29−import Rel8.Expr.Serialize ( litExpr )

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

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

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

31import Rel8.Schema.Context.Nullify

33import Rel8.Schema.Context.Nullify

32 ( Nullifiable, ConstrainTag

34 ( Nullifiable, ConstrainTag

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

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

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

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

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

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

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

42+import Rel8.Schema.Name ( Name )

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

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

41import Rel8.Table.Bool ( bool )

44import Rel8.Table.Bool ( bool )

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

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

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

45 )

48 )

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

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

47import Rel8.Table.Recontextualize ( Recontextualize )

50import Rel8.Table.Recontextualize ( Recontextualize )

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

48import Rel8.Table.Undefined ( undefined )

52import Rel8.Table.Undefined ( undefined )

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

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

51-- semigroupoids

55-- semigroupoids

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

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

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

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

56type EitherTable :: Type -> Type -> Type

60type EitherTable :: Type -> Type -> Type

57data EitherTable a b = EitherTable

61data EitherTable a b = EitherTable

58− { tag :: Expr EitherTag

62+ { tag :: Tag "isRight" EitherTag

59 , left :: a

63 , left :: a

60 , right :: b

64 , right :: b

61 }

65 }

62− deriving stock (Show, Functor)

66+ deriving stock Functor

65instance Bifunctor EitherTable where

69instance Bifunctor EitherTable where

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

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

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

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

74 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)

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

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

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

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

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

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

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

81 EitherTable tag' l2 b ->

85 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

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

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

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

100

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

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

98 { htag

102 { htag

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

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

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

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

101 }

105 }

102 where

106 where

103 htag = HIdentity (hencodeTag tag)

107 htag = HIdentity (hencodeTag tag)

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

106 EitherTable

110 EitherTable

107 { tag

111 { tag

108 , left = f $ runIdentity $

112 , left = f $ runIdentity $

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

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

110 , right = g $ runIdentity $

114 , right = g $ runIdentity $

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

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

112 }

116 }

113 where

117 where

114 tag = hdecodeTag $ unHIdentity htag

118 tag = hdecodeTag $ unHIdentity htag

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

159

163

160

164

161isLeftTable :: EitherTable a b -> Expr Bool

165isLeftTable :: EitherTable a b -> Expr Bool

162−isLeftTable = isLeft . tag

166+isLeftTable = isLeft . expr . tag

163

167

164

168

165isRightTable :: EitherTable a b -> Expr Bool

169isRightTable :: EitherTable a b -> Expr Bool

166−isRightTable = isRight . tag

170+isRightTable = isRight . expr . tag

167

171

168

172

169eitherTable :: Table Expr c

173eitherTable :: Table Expr c

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

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

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

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

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

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

173

177

174

178

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

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

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

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

177

181

178

182

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

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

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

181

185

182

186

183rightTableWith :: a -> b -> EitherTable a b

187rightTableWith :: 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

16 , maybeTable, nothingTable, justTable

17 , isNothingTable, isJustTable

18 , ($?)

19+ , aggregateMaybeTable

20+ , nameMaybeTable

19 )

21 )

20where

22where

22-- base

24-- base

25+import qualified Data.Bool as Bool

23import Data.Functor.Identity ( runIdentity )

26import Data.Functor.Identity ( runIdentity )

24import Data.Kind ( Type )

27import Data.Kind ( Type )

28+import Data.Maybe ( isJust, isNothing )

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

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

27-- rel8

31-- rel8

32+import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )

28import Rel8.Expr ( Expr )

33import Rel8.Expr ( Expr )

29import Rel8.Expr.Bool ( boolExpr )

34import Rel8.Expr.Bool ( boolExpr )

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

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

31−import Rel8.Expr.Serialize ( litExpr )

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

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

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

33import Rel8.Schema.Context.Nullify

38import Rel8.Schema.Context.Nullify

34 ( Nullifiable, ConstrainTag

39 ( Nullifiable, ConstrainTag

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

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

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

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

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

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

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

47+import Rel8.Schema.Name ( Name )

42import Rel8.Schema.Nullability

48import Rel8.Schema.Nullability

43 ( Nullify

49 ( Nullify

44 , Nullability( Nullable, NonNullable )

50 , Nullability( Nullable, NonNullable )

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

56 )

62 )

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

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

58import Rel8.Table.Recontextualize ( Recontextualize )

64import Rel8.Table.Recontextualize ( Recontextualize )

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

59import Rel8.Table.Undefined ( undefined )

66import Rel8.Table.Undefined ( undefined )

60import Rel8.Type ( DBType )

67import Rel8.Type ( DBType )

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

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

63-- semigroupoids

70-- semigroupoids

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

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

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

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

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

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

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

76type MaybeTable :: Type -> Type

83type MaybeTable :: Type -> Type

77data MaybeTable a = MaybeTable

84data MaybeTable a = MaybeTable

78− { tag :: Expr (Maybe MaybeTag)

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

79 , just :: a

86 , just :: a

80 }

87 }

81− deriving stock (Show, Functor)

88+ deriving stock Functor

84instance Apply MaybeTable where

91instance Apply MaybeTable where

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

105

112

106instance AltTable MaybeTable where

113instance AltTable MaybeTable where

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

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

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

108− { tag = boolExpr tag tag' condition

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

117+ , identity =

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

119+ }

109 , just = bool a b condition

120 , just = bool a b condition

110 }

121 }

111 where

122 where

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

130

141

131 toColumns1 f MaybeTable {tag, just} = HMaybeTable

142 toColumns1 f MaybeTable {tag, just} = HMaybeTable

132 { htag

143 { htag

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

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

134 }

145 }

135 where

146 where

136 htag = HIdentity (hencodeTag tag)

147 htag = HIdentity (hencodeTag tag)

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

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

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

139 { tag

150 { tag

140 , just = f $ runIdentity $

151 , just = f $ runIdentity $

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

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

142 }

153 }

143 where

154 where

144 tag = hdecodeTag htag

155 tag = hdecodeTag htag

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

177

188

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

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

179isNothingTable :: MaybeTable a -> Expr Bool

190isNothingTable :: MaybeTable a -> Expr Bool

180−isNothingTable (MaybeTable tag _) = isNull tag

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

181

192

182

193

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

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

184isJustTable :: MaybeTable a -> Expr Bool

195isJustTable :: MaybeTable a -> Expr Bool

185−isJustTable (MaybeTable tag _) = isNonNull tag

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

186

197

187

198

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

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

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

192

203

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

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

194nothingTable :: Table Expr a => MaybeTable a

205nothingTable :: Table Expr a => MaybeTable a

195−nothingTable = MaybeTable null undefined

206+nothingTable = MaybeTable (fromIdentity Nothing) undefined

196

207

197

208

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

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

199-- 'pure'.

210-- 'pure'.

200justTable :: a -> MaybeTable a

211justTable :: a -> MaybeTable a

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

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

202

213

203

214

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

215-- | 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

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

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

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

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

215infixl 4 $?

226infixl 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 @@

5{-# language FlexibleInstances #-}

6{-# language MultiParamTypeClasses #-}

7{-# language NamedFieldPuns #-}

8+{-# language RecordWildCards #-}

8{-# language ScopedTypeVariables #-}

9{-# language ScopedTypeVariables #-}

9{-# language StandaloneKindSignatures #-}

10{-# language StandaloneKindSignatures #-}

10{-# language TupleSections #-}

11{-# language TupleSections #-}

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

18 , isThisTable, isThatTable, isThoseTable

19 , isThisTable, isThatTable, isThoseTable

19 , hasHereTable, hasThereTable

20 , hasHereTable, hasThereTable

20 , justHereTable, justThereTable

21 , justHereTable, justThereTable

22+ , aggregateTheseTable, nameTheseTable

21 )

23 )

22where

24where

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

25import Data.Bifunctor ( Bifunctor, bimap )

27import Data.Bifunctor ( Bifunctor, bimap )

26import Data.Functor.Identity ( runIdentity )

28import Data.Functor.Identity ( runIdentity )

27import Data.Kind ( Type )

29import Data.Kind ( Type )

30+import Data.Maybe ( isJust )

28import Prelude hiding ( undefined )

31import Prelude hiding ( undefined )

30-- rel8

33-- rel8

34+import Rel8.Aggregate ( Aggregate )

31import Rel8.Expr ( Expr )

35import Rel8.Expr ( Expr )

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

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

33import Rel8.Expr.Null ( isNonNull )

37import Rel8.Expr.Null ( isNonNull )

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

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

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

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

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

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

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

49+import Rel8.Schema.Name ( Name )

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

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

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

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

47import Rel8.Table.Lifted

52import Rel8.Table.Lifted

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

51 ( MaybeTable(..)

56 ( MaybeTable(..)

52 , maybeTable, justTable, nothingTable

57 , maybeTable, justTable, nothingTable

53 , isJustTable

58 , isJustTable

59+ , aggregateMaybeTable, nameMaybeTable

54 )

60 )

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

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

56import Rel8.Table.Recontextualize ( Recontextualize )

62import Rel8.Table.Recontextualize ( Recontextualize )

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

57import Rel8.Table.Undefined ( undefined )

64import Rel8.Table.Undefined ( undefined )

58import Rel8.Type.Tag ( MaybeTag )

65import Rel8.Type.Tag ( MaybeTag )

60-- semigroupoids

67-- semigroupoids

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

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

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

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

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

67 { here :: MaybeTable a

74 { here :: MaybeTable a

68 , there :: MaybeTable b

75 , there :: MaybeTable b

69 }

76 }

70− deriving stock (Show, Functor)

77+ deriving stock Functor

73instance Bifunctor TheseTable where

80instance Bifunctor TheseTable where

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

116 type ConstrainHContext2 TheseTable = HMaybeNullifiable

123 type ConstrainHContext2 TheseTable = HMaybeNullifiable

117

124

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

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

119− { hhereTag = HIdentity $ hencodeTag (tag here)

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

127+ , hhere =

120− , hhere = hnullify (hnullifier (isNonNull (tag here))) $ f (just here)

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

121− , hthereTag = HIdentity $ hencodeTag (tag there)

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

130+ , hthere =

122− , hthere = hnullify (hnullifier (isNonNull (tag there))) $ g (just there)

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

123 }

132 }

124

133

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

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

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

132 { tag

141 { tag

133 , just = f $

142 , just = f $

134 runIdentity $

143 runIdentity $

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

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

136 hhere

145 hhere

137 }

146 }

138 , there =

147 , there =

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

143 { tag

152 { tag

144 , just = g $

153 , just = g $

145 runIdentity $

154 runIdentity $

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

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

147 hthere

156 hthere

148 }

157 }

149 }

158 }

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

192 (thoseTable (ordTable @a) (ordTable @b))

201 (thoseTable (ordTable @a) (ordTable @b))

193

202

194

203

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+

195isThisTable :: TheseTable a b -> Expr Bool

212isThisTable :: TheseTable a b -> Expr Bool

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

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

197

214

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

239 (maybeTable undefined f here)

256 (maybeTable undefined f here)

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

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

241 there

258 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+ }