707a36a · rel8 · git.iko.soy

git.iko.soy/rel8

on master help sign in

Add context parameter to *Table types (#101)

707a36aShane5 years ago

rel8.cabal−1

compare with master

unifiedsplit

@@ -162,7 +162,6 @@ library

162 Rel8.Table.Recontextualize

163 Rel8.Table.Rel8able

164 Rel8.Table.Serialize

165− Rel8.Table.Tag

166 Rel8.Table.These

165 Rel8.Table.These

167 Rel8.Table.Undefined

166 Rel8.Table.Undefined

168 Rel8.Table.Unreify

167 Rel8.Table.Unreify

src/Rel8.hs+3

@@ -59,6 +59,7 @@ module Rel8

59 , optional

60 , catMaybeTable

61 , traverseMaybeTable

62+ , aggregateMaybeTable

62 , nameMaybeTable

63 , nameMaybeTable

64 -- ** @EitherTable@

65 -- ** @EitherTable@

@@ -68,6 +69,7 @@ module Rel8

68 , keepLeftTable

69 , keepLeftTable

69 , keepRightTable

70 , keepRightTable

70 , bitraverseEitherTable

71 , bitraverseEitherTable

72+ , aggregateEitherTable

71 , nameEitherTable

73 , nameEitherTable

73 -- ** @TheseTable@

75 -- ** @TheseTable@

@@ -83,6 +85,7 @@ module Rel8

83 , keepThatTable, loseThatTable

85 , keepThatTable, loseThatTable

84 , keepThoseTable, loseThoseTable

86 , keepThoseTable, loseThoseTable

85 , bitraverseTheseTable

87 , bitraverseTheseTable

88+ , aggregateTheseTable

86 , nameTheseTable

89 , nameTheseTable

88 -- ** @ListTable@

91 -- ** @ListTable@

src/Rel8/Column/Either.hs+5−5

@@ -3,7 +3,7 @@

3{-# language LambdaCase #-}

4{-# language MultiParamTypeClasses #-}

5{-# language StandaloneKindSignatures #-}

6−{-# language TypeFamilies #-}

6+{-# language TypeFamilyDependencies #-}

7{-# language UndecidableInstances #-}

9module Rel8.Column.Either

@@ -39,11 +39,11 @@ import Rel8.Table.Recontextualize ( Recontextualize )

39-- 'EitherTable' @a b@ in the 'Expr' context, and a 'Either' @a b@ in the

40-- 'Result' context.

41type HEither :: K.Context -> Type -> Type -> Type

42−type family HEither context where

42+type family HEither context = either | either -> context where

43 HEither (Reify context) = AHEither context

44− HEither Aggregate = EitherTable

44+ HEither Aggregate = EitherTable Aggregate

45− HEither Expr = EitherTable

45+ HEither Expr = EitherTable Expr

46− HEither Name = EitherTable

46+ HEither Name = EitherTable Name

47 HEither Result = Either

src/Rel8/Column/List.hs+5−5

@@ -3,7 +3,7 @@

3{-# language LambdaCase #-}

4{-# language MultiParamTypeClasses #-}

5{-# language StandaloneKindSignatures #-}

6−{-# language TypeFamilies #-}

6+{-# language TypeFamilyDependencies #-}

7{-# language UndecidableInstances #-}

9module Rel8.Column.List

@@ -38,11 +38,11 @@ import Rel8.Table.Unreify ( Unreifiability(..), Unreifiable, unreifiability )

38-- | Nest a list within a 'Rel8able'. @HList f a@ will produce a 'ListTable'

39-- @a@ in the 'Expr' context, and a @[a]@ in the 'Result' context.

40type HList :: K.Context -> Type -> Type

41−type family HList context where

41+type family HList context = list | list -> context where

42 HList (Reify context) = AHList context

43− HList Aggregate = ListTable

43+ HList Aggregate = ListTable Aggregate

44− HList Expr = ListTable

44+ HList Expr = ListTable Expr

45− HList Name = ListTable

45+ HList Name = ListTable Name

46 HList Result = []

src/Rel8/Column/Maybe.hs+7−7

@@ -4,7 +4,7 @@

4{-# language LambdaCase #-}

5{-# language MultiParamTypeClasses #-}

6{-# language StandaloneKindSignatures #-}

7−{-# language TypeFamilies #-}

7+{-# language TypeFamilyDependencies #-}

8{-# language UndecidableInstances #-}

10module Rel8.Column.Maybe

@@ -38,11 +38,11 @@ import Rel8.Table.Recontextualize ( Recontextualize )

38-- 'MaybeTable' @a@ in the 'Expr' context, and a 'Maybe' @a@ in the 'Result'

39-- context.

40type HMaybe :: K.Context -> Type -> Type

41−type family HMaybe context where

41+type family HMaybe context = maybe | maybe -> context where

42 HMaybe (Reify context) = AHMaybe context

43− HMaybe Aggregate = MaybeTable

43+ HMaybe Aggregate = MaybeTable Aggregate

44− HMaybe Expr = MaybeTable

44+ HMaybe Expr = MaybeTable Expr

45− HMaybe Name = MaybeTable

45+ HMaybe Name = MaybeTable Name

46 HMaybe Result = Maybe

@@ -70,8 +70,8 @@ instance (Reifiable context, Table (Reify context) a) =>

70instance

71 ( Reifiable context, Reifiable context'

72 , Recontextualize (Reify context) (Reify context') a a'

73− ) =>

73+ )

74− Recontextualize

74+ => Recontextualize

75 (Reify context)

76 (Reify context')

77 (AHMaybe context a)

src/Rel8/Column/NonEmpty.hs+5−5

@@ -3,7 +3,7 @@

3{-# language LambdaCase #-}

4{-# language MultiParamTypeClasses #-}

5{-# language StandaloneKindSignatures #-}

6−{-# language TypeFamilies #-}

6+{-# language TypeFamilyDependencies #-}

7{-# language UndecidableInstances #-}

9module Rel8.Column.NonEmpty

@@ -40,11 +40,11 @@ import Rel8.Table.Unreify ( Unreifiability(..), Unreifiable, unreifiability )

40-- 'NonEmptyTable' @a@ in the 'Expr' context, and a 'NonEmpty' @a@ in the

41-- 'Result' context.

42type HNonEmpty :: K.Context -> Type -> Type

43−type family HNonEmpty context where

43+type family HNonEmpty context = nonEmpty | nonEmpty -> context where

44 HNonEmpty (Reify context) = AHNonEmpty context

45− HNonEmpty Aggregate = NonEmptyTable

45+ HNonEmpty Aggregate = NonEmptyTable Aggregate

46− HNonEmpty Expr = NonEmptyTable

46+ HNonEmpty Expr = NonEmptyTable Expr

47− HNonEmpty Name = NonEmptyTable

47+ HNonEmpty Name = NonEmptyTable Name

48 HNonEmpty Result = NonEmpty

src/Rel8/Column/These.hs+5−5

@@ -4,7 +4,7 @@

4{-# language LambdaCase #-}

5{-# language MultiParamTypeClasses #-}

6{-# language StandaloneKindSignatures #-}

7−{-# language TypeFamilies #-}

7+{-# language TypeFamilyDependencies #-}

8{-# language UndecidableInstances #-}

10module Rel8.Column.These

@@ -43,11 +43,11 @@ import Data.These ( These )

43-- 'TheseTable' @a b@ in the 'Expr' context, and a 'These' @a b@ in the

44-- 'Result' context.

45type HThese :: K.Context -> Type -> Type -> Type

46−type family HThese context where

46+type family HThese context = these | these -> context where

47 HThese (Reify context) = AHThese context

48− HThese Aggregate = TheseTable

48+ HThese Aggregate = TheseTable Aggregate

49− HThese Expr = TheseTable

49+ HThese Expr = TheseTable Expr

50− HThese Name = TheseTable

50+ HThese Name = TheseTable Name

51 HThese Result = These

src/Rel8/Generic/Construction.hs+2−2

@@ -59,7 +59,7 @@ import Rel8.Kind.Algebra

59 , KnownAlgebra, algebraSing

60 )

61import qualified Rel8.Kind.Algebra as K

62−import Rel8.Schema.Context.Nullify ( runTag )

62+import Rel8.Schema.Context.Nullify ( guardExpr, snullify )

63import Rel8.Schema.HTable ( HTable )

64import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )

65import qualified Rel8.Schema.Kind as K

@@ -349,7 +349,7 @@ ggaggregate gfromColumns gtoColumns agg es = case algebraSing @algebra of

349 @(Eval (rep (Reify Aggregate)))

350 (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)

351 (\tag' SSpec {nullity} (Reify (A (Aggregate a))) ->

352− Reify $ A $ Aggregate $ runTag nullity (tag ==. litExpr tag') <$> a)

352+ Reify $ A $ Aggregate $ guardExpr (tag ==. litExpr tag') . snullify nullity <$> a)

353 (HType (Reify (A (groupByExpr tag))))

354 where

355 f =

src/Rel8/Query/Either.hs+5−4

@@ -11,6 +11,7 @@ where

11import Prelude

13-- rel8

14+import Rel8.Expr ( Expr )

14import Rel8.Expr.Eq ( (==.) )

15import Rel8.Expr.Eq ( (==.) )

15import Rel8.Query ( Query )

16import Rel8.Query ( Query )

16import Rel8.Query.Filter ( where_ )

17import Rel8.Query.Filter ( where_ )

@@ -23,14 +24,14 @@ import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )

25-- | Filter 'EitherTable's, keeping only 'leftTable's.

26-- | Filter 'EitherTable's, keeping only 'leftTable's.

26−keepLeftTable :: EitherTable a b -> Query a

27+keepLeftTable :: EitherTable Expr a b -> Query a

27keepLeftTable e@(EitherTable _ a _) = do

28keepLeftTable e@(EitherTable _ a _) = do

28 where_ $ isLeftTable e

29 where_ $ isLeftTable e

29 pure a

30 pure a

32-- | Filter 'EitherTable's, keeping only 'rightTable's.

33-- | Filter 'EitherTable's, keeping only 'rightTable's.

33−keepRightTable :: EitherTable a b -> Query b

34+keepRightTable :: EitherTable Expr a b -> Query b

34keepRightTable e@(EitherTable _ _ b) = do

35keepRightTable e@(EitherTable _ _ b) = do

35 where_ $ isRightTable e

36 where_ $ isRightTable e

36 pure b

37 pure b

@@ -55,8 +56,8 @@ keepRightTable e@(EitherTable _ _ b) = do

55bitraverseEitherTable :: ()

56bitraverseEitherTable :: ()

56 => (a -> Query c)

57 => (a -> Query c)

57 -> (b -> Query d)

58 -> (b -> Query d)

58− -> EitherTable a b

59+ -> EitherTable Expr a b

59− -> Query (EitherTable c d)

60+ -> Query (EitherTable Expr c d)

60bitraverseEitherTable f g e@(EitherTable tag _ _) = do

61bitraverseEitherTable f g e@(EitherTable tag _ _) = do

61 mc@(MaybeTable _ c) <- optional (f =<< keepLeftTable e)

62 mc@(MaybeTable _ c) <- optional (f =<< keepLeftTable e)

62 md@(MaybeTable _ d) <- optional (g =<< keepRightTable e)

63 md@(MaybeTable _ d) <- optional (g =<< keepRightTable e)

src/Rel8/Query/List.hs+4−4

@@ -46,7 +46,7 @@ import Rel8.Type.Information ( TypeInformation )

46--

47-- @many@ is analogous to 'Control.Applicative.many' from

48-- @Control.Applicative@.

49−many :: Table Expr a => Query a -> Query (ListTable a)

49+many :: Table Expr a => Query a -> Query (ListTable Expr a)

50many =

51 fmap (maybeTable mempty (\(ListTable a) -> ListTable a)) .

52 optional .

@@ -62,7 +62,7 @@ many =

62--

63-- @some@ is analogous to 'Control.Applicative.some' from

64-- @Control.Applicative@.

65−some :: Table Expr a => Query a -> Query (NonEmptyTable a)

65+some :: Table Expr a => Query a -> Query (NonEmptyTable Expr a)

66some =

67 fmap (\(NonEmptyTable a) -> NonEmptyTable a) .

68 aggregate .

@@ -83,7 +83,7 @@ someExpr = aggregate . fmap nonEmptyAggExpr

83-- element of the given @ListTable@.

84--

85-- @catListTable@ is an inverse to 'many'.

86−catListTable :: Table Expr a => ListTable a -> Query a

86+catListTable :: Table Expr a => ListTable Expr a -> Query a

87catListTable (ListTable as) = rebind $ fromColumns $ runIdentity $

88 hunvectorize (\SSpec {info} -> pure . E . sunnest info . unE) as

@@ -92,7 +92,7 @@ catListTable (ListTable as) = rebind $ fromColumns $ runIdentity $

92-- element of the given @NonEmptyTable@.

93--

94-- @catNonEmptyTable@ is an inverse to 'some'.

95−catNonEmptyTable :: Table Expr a => NonEmptyTable a -> Query a

95+catNonEmptyTable :: Table Expr a => NonEmptyTable Expr a -> Query a

96catNonEmptyTable (NonEmptyTable as) = rebind $ fromColumns $ runIdentity $

97 hunvectorize (\SSpec {info} -> pure . E . sunnest info . unE) as

src/Rel8/Query/Maybe.hs+11−9

@@ -1,3 +1,5 @@

1+{-# language GADTs #-}

1module Rel8.Query.Maybe

3module Rel8.Query.Maybe

2 ( optional

4 ( optional

3 , catMaybeTable

5 , catMaybeTable

@@ -12,13 +14,13 @@ import Prelude

12import qualified Opaleye.Internal.MaybeFields as Opaleye

14import qualified Opaleye.Internal.MaybeFields as Opaleye

14-- rel8

16-- rel8

17+import Rel8.Expr ( Col( E ), Expr )

15import Rel8.Expr.Eq ( (==.) )

18import Rel8.Expr.Eq ( (==.) )

16import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr )

19import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr )

17import Rel8.Query ( Query )

20import Rel8.Query ( Query )

18import Rel8.Query.Filter ( where_ )

21import Rel8.Query.Filter ( where_ )

19import Rel8.Query.Opaleye ( mapOpaleye )

22import Rel8.Query.Opaleye ( mapOpaleye )

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

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

21−import Rel8.Table.Tag ( Tag(..), fromExpr )

24-- | Convert a query that might return zero rows to a query that always returns

26-- | Convert a query that might return zero rows to a query that always returns

@@ -26,11 +28,11 @@ import Rel8.Table.Tag ( Tag(..), fromExpr )

26--

28--

27-- To speak in more concrete terms, 'optional' is most useful to write @LEFT

29-- To speak in more concrete terms, 'optional' is most useful to write @LEFT

28-- JOIN@s.

30-- JOIN@s.

29−optional :: Query a -> Query (MaybeTable a)

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

30optional =

32optional =

31 mapOpaleye $

33 mapOpaleye $

32 Opaleye.optionalInternal $

34 Opaleye.optionalInternal $

33− MaybeTable . fromExpr . fromPrimExpr . fromColumn

35+ MaybeTable . E . fromPrimExpr . fromColumn

36-- | Filter out 'MaybeTable's, returning only the tables that are not-null.

38-- | Filter out 'MaybeTable's, returning only the tables that are not-null.

@@ -38,7 +40,7 @@ optional =

38-- This operation can be used to "undo" the effect of 'optional', which

40-- This operation can be used to "undo" the effect of 'optional', which

39-- operationally is like turning a @LEFT JOIN@ back into a full @JOIN@. You

41-- operationally is like turning a @LEFT JOIN@ back into a full @JOIN@. You

40-- can think of this as analogous to 'Data.Maybe.catMaybes'.

42-- can think of this as analogous to 'Data.Maybe.catMaybes'.

41−catMaybeTable :: MaybeTable a -> Query a

43+catMaybeTable :: MaybeTable Expr a -> Query a

42catMaybeTable ma@(MaybeTable _ a) = do

44catMaybeTable ma@(MaybeTable _ a) = do

43 where_ $ isJustTable ma

45 where_ $ isJustTable ma

44 pure a

46 pure a

@@ -53,8 +55,8 @@ catMaybeTable ma@(MaybeTable _ a) = do

53-- have no rows. However, regardless of the given @a -> Query b@ function, if

55-- have no rows. However, regardless of the given @a -> Query b@ function, if

54-- the input is @nothingTable@, you will always get exactly one @nothingTable@

56-- the input is @nothingTable@, you will always get exactly one @nothingTable@

55-- back.

57-- back.

56−traverseMaybeTable :: (a -> Query b) -> MaybeTable a -> Query (MaybeTable b)

58+traverseMaybeTable :: (a -> Query b) -> MaybeTable Expr a -> Query (MaybeTable Expr b)

57−traverseMaybeTable query ma@(MaybeTable input _) = do

59+traverseMaybeTable query ma@(MaybeTable (E input) _) = do

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

60+ MaybeTable (E output) b <- optional (query =<< catMaybeTable ma)

59− where_ $ expr output ==. expr input

61+ where_ $ output ==. input

60− pure $ MaybeTable input b

62+ pure $ MaybeTable (E input) b

src/Rel8/Query/These.hs+20−23

@@ -1,4 +1,5 @@

1{-# language FlexibleContexts #-}

2+{-# language GADTs #-}

3module Rel8.Query.These

4module Rel8.Query.These

4 ( alignBy

5 ( alignBy

@@ -21,7 +22,7 @@ import qualified Opaleye.Internal.QueryArr as Opaleye

21import qualified Opaleye.Internal.Tag as Opaleye

22import qualified Opaleye.Internal.Tag as Opaleye

23-- rel8

24-- rel8

24−import Rel8.Expr ( Expr )

25+import Rel8.Expr ( Col( E ), Expr )

25import Rel8.Expr.Bool ( boolExpr, not_ )

26import Rel8.Expr.Bool ( boolExpr, not_ )

26import Rel8.Expr.Eq ( (==.) )

27import Rel8.Expr.Eq ( (==.) )

27import Rel8.Expr.Opaleye ( toPrimExpr, traversePrimExpr )

28import Rel8.Expr.Opaleye ( toPrimExpr, traversePrimExpr )

@@ -32,7 +33,6 @@ import Rel8.Query.Maybe ( optional )

32import Rel8.Query.Opaleye ( zipOpaleyeWith )

33import Rel8.Query.Opaleye ( zipOpaleyeWith )

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

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

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

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

35−import Rel8.Table.Tag ( Tag(..), fromExpr )

36import Rel8.Table.These

37 ( TheseTable( TheseTable, here, there )

38 , hasHereTable, hasThereTable

@@ -44,14 +44,14 @@ import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ) )

44-- | Corresponds to a @FULL OUTER JOIN@ between two queries.

45alignBy :: ()

46 => (a -> b -> Expr Bool)

47− -> Query a -> Query b -> Query (TheseTable a b)

47+ -> Query a -> Query b -> Query (TheseTable Expr a b)

48alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.QueryArr $ \i -> case i of

49 (_, tag) -> (tab, join', tag''')

50 where

51 (ma, left', tag') = Opaleye.runSimpleQueryArr (pure <$> left) ((), tag)

52 (mb, right', tag'') = Opaleye.runSimpleQueryArr (pure <$> right) ((), tag')

53− MaybeTable Tag {expr = hasHere} a = ma

53+ MaybeTable (E hasHere) a = ma

54− MaybeTable Tag {expr = hasThere} b = mb

54+ MaybeTable (E hasThere) b = mb

55 (hasHere', lbindings) = Opaleye.run $ do

56 traversePrimExpr (Opaleye.extractAttr "hasHere" tag'') hasHere

57 (hasThere', rbindings) = Opaleye.run $ do

@@ -62,74 +62,71 @@ alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.QueryArr $ \i -> cas

62 on = toPrimExpr $ condition a b

63 left'' = (lateral, Opaleye.Rebind True lbindings left')

64 right'' = (lateral, Opaleye.Rebind True rbindings right')

65− ma' = MaybeTable (fromExpr hasHere') a

65+ ma' = MaybeTable (E hasHere') a

66− mb' = MaybeTable (fromExpr hasThere') b

66+ mb' = MaybeTable (E hasThere') b

67 tab = TheseTable {here = ma', there = mb'}

68 join' lateral input = Opaleye.times lateral input (join lateral)

71−-- | Filter 'TheseTable's, keeping only 'thisTable's and 'thoseTable's.

72−keepHereTable :: TheseTable a b -> Query (a, MaybeTable b)

71+keepHereTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b)

73keepHereTable = loseThatTable

72keepHereTable = loseThatTable

76−-- | Filter 'TheseTable's, keeping on

77−loseHereTable :: TheseTable a b -> Query b

75+loseHereTable :: TheseTable Expr a b -> Query b

78loseHereTable = keepThatTable

76loseHereTable = keepThatTable

81−keepThereTable :: TheseTable a b -> Query (MaybeTable a, b)

79+keepThereTable :: TheseTable Expr a b -> Query (MaybeTable Expr a, b)

82keepThereTable = loseThisTable

80keepThereTable = loseThisTable

85−loseThereTable :: TheseTable a b -> Query a

83+loseThereTable :: TheseTable Expr a b -> Query a

86loseThereTable = keepThisTable

84loseThereTable = keepThisTable

89−keepThisTable :: TheseTable a b -> Query a

87+keepThisTable :: TheseTable Expr a b -> Query a

90keepThisTable t@(TheseTable (MaybeTable _ a) _) = do

88keepThisTable t@(TheseTable (MaybeTable _ a) _) = do

91 where_ $ isThisTable t

89 where_ $ isThisTable t

92 pure a

90 pure a

95−loseThisTable :: TheseTable a b -> Query (MaybeTable a, b)

93+loseThisTable :: TheseTable Expr a b -> Query (MaybeTable Expr a, b)

96loseThisTable t@(TheseTable ma (MaybeTable _ b)) = do

94loseThisTable t@(TheseTable ma (MaybeTable _ b)) = do

97 where_ $ not_ $ isThisTable t

95 where_ $ not_ $ isThisTable t

98 pure (ma, b)

96 pure (ma, b)

100

101−keepThatTable :: TheseTable a b -> Query b

99+keepThatTable :: TheseTable Expr a b -> Query b

102keepThatTable t@(TheseTable _ (MaybeTable _ b)) = do

100keepThatTable t@(TheseTable _ (MaybeTable _ b)) = do

103 where_ $ isThatTable t

101 where_ $ isThatTable t

104 pure b

102 pure b

105

103

106

104

107−loseThatTable :: TheseTable a b -> Query (a, MaybeTable b)

105+loseThatTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b)

108loseThatTable t@(TheseTable (MaybeTable _ a) mb) = do

106loseThatTable t@(TheseTable (MaybeTable _ a) mb) = do

109 where_ $ not_ $ isThatTable t

107 where_ $ not_ $ isThatTable t

110 pure (a, mb)

108 pure (a, mb)

111

109

112

110

113−keepThoseTable :: TheseTable a b -> Query (a, b)

111+keepThoseTable :: TheseTable Expr a b -> Query (a, b)

114keepThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do

112keepThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do

115 where_ $ isThoseTable t

113 where_ $ isThoseTable t

116 pure (a, b)

114 pure (a, b)

117

115

118

116

119−loseThoseTable :: TheseTable a b -> Query (EitherTable a b)

117+loseThoseTable :: TheseTable Expr a b -> Query (EitherTable Expr a b)

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

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

121 where_ $ not_ $ isThoseTable t

119 where_ $ not_ $ isThoseTable t

122− pure $ EitherTable result a b

120+ pure $ EitherTable (E tag) a b

123 where

121 where

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

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

125− result = (mempty `asTypeOf` result) {expr = tag}

126

123

127

124

128bitraverseTheseTable :: ()

125bitraverseTheseTable :: ()

129 => (a -> Query c)

126 => (a -> Query c)

130 -> (b -> Query d)

127 -> (b -> Query d)

131− -> TheseTable a b

128+ -> TheseTable Expr a b

132− -> Query (TheseTable c d)

129+ -> Query (TheseTable Expr c d)

133bitraverseTheseTable f g t = do

130bitraverseTheseTable f g t = do

134 mc <- optional (f . fst =<< keepHereTable t)

131 mc <- optional (f . fst =<< keepHereTable t)

135 md <- optional (g . snd =<< keepThereTable t)

132 md <- optional (g . snd =<< keepThereTable t)

src/Rel8/Schema/Context/Nullify.hs+46−68

@@ -1,22 +1,18 @@

1{-# language DataKinds #-}

2{-# language FlexibleContexts #-}

3−{-# language FlexibleInstances #-}

3+{-# language GADTs #-}

4−{-# language InstanceSigs #-}

5−{-# language MultiParamTypeClasses #-}

6{-# language NamedFieldPuns #-}

4{-# language NamedFieldPuns #-}

7−{-# language ScopedTypeVariables #-}

8{-# language StandaloneKindSignatures #-}

5{-# language StandaloneKindSignatures #-}

9−{-# language TypeFamilies #-}

11module Rel8.Schema.Context.Nullify

7module Rel8.Schema.Context.Nullify

12− ( Nullifiable( encodeTag, decodeTag, nullifier, unnullifier )

8+ ( Nullifiable, nullifier, unnullifier

13− , runTag, unnull

9+ , guardExpr, snullify

14 )

10 )

15where

11where

17-- base

13-- base

18import Data.Kind ( Constraint )

14import Data.Kind ( Constraint )

19−import GHC.TypeLits ( KnownSymbol )

15+import Data.Monoid ( getFirst )

20import Prelude hiding ( null )

16import Prelude hiding ( null )

22-- opaleye

18-- opaleye

@@ -25,101 +21,83 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

25-- rel8

21-- rel8

26import Rel8.Aggregate

22import Rel8.Aggregate

27 ( Aggregate( Aggregate ), Col( A )

23 ( Aggregate( Aggregate ), Col( A )

28− , mapInputs

24+ , foldInputs, mapInputs

29− , unsafeMakeAggregate

30 )

25 )

31import Rel8.Expr ( Expr, Col( E ) )

26import Rel8.Expr ( Expr, Col( E ) )

32import Rel8.Expr.Bool ( boolExpr )

27import Rel8.Expr.Bool ( boolExpr )

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

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

34import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )

29import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )

35−import Rel8.Schema.Context ( Interpretation )

36import qualified Rel8.Schema.Kind as K

30import qualified Rel8.Schema.Kind as K

37import Rel8.Schema.Name ( Name( Name ), Col( N ) )

31import Rel8.Schema.Name ( Name( Name ), Col( N ) )

38−import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )

32+import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql )

33+import Rel8.Schema.Reify ( Reify, Col( Reify ) )

39import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

34import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

40−import Rel8.Table.Tag ( Tag(..), Taggable, fromAggregate, fromExpr, fromName )

35+import Rel8.Type ( DBType )

43type Nullifiable :: K.Context -> Constraint

38type Nullifiable :: K.Context -> Constraint

44−class Interpretation context => Nullifiable context where

39+class Nullifiable context where

45− encodeTag :: Taggable a

40+ nullifier :: Sql DBType tag

46− => Tag label a

41+ => Col context ('Spec tag)

42+ -> (Expr tag -> Expr Bool)

43+ -> SSpec ('Spec a)

47 -> Col context ('Spec a)

44 -> Col context ('Spec a)

48−

49− decodeTag :: (KnownSymbol label, Taggable a)

50− => Col context ('Spec a)

51− -> Tag label a

52−

53− nullifier :: ()

54− => Tag label a

55− -> (Expr a -> Expr Bool)

56− -> SSpec ('Spec x)

57− -> Col context ('Spec x)

58− -> Col context ('Spec (Nullify x))

45+ -> Col context ('Spec (Nullify a))

60 unnullifier :: ()

47 unnullifier :: ()

61− => SSpec ('Spec x)

48+ => SSpec ('Spec a)

62− -> Col context ('Spec (Nullify x))

49+ -> Col context ('Spec (Nullify a))

63− -> Col context ('Spec x)

50+ -> Col context ('Spec a)

66instance Nullifiable Aggregate where

53instance Nullifiable Aggregate where

67− encodeTag Tag {aggregator, expr} =

68− A $ unsafeMakeAggregate toPrimExpr fromPrimExpr aggregator expr

69−

70− decodeTag (A aggregate) = fromAggregate aggregate

71−

72− nullifier Tag {expr} test SSpec {nullity} (A (Aggregate a)) =

54+ nullifier (A tag) isNonNull SSpec {nullity} (A (Aggregate a)) =

73 A $

55 A $

74− mapInputs (toPrimExpr . runTag nullity condition . fromPrimExpr) $

56+ mapInputs (toPrimExpr . run . fromPrimExpr) $

75 Aggregate $

57 Aggregate $

76− runTag nullity condition <$> a

58+ run <$> a

77 where

59 where

78− condition = test expr

60+ mtag = foldInputs (\_ -> pure . fromPrimExpr) tag

61+ run = maybe id (guardExpr . isNonNull) (getFirst mtag) . snullify nullity

80 unnullifier SSpec {nullity} (A (Aggregate a)) =

63 unnullifier SSpec {nullity} (A (Aggregate a)) =

81− A (Aggregate (unnull nullity <$> a))

64+ A $ Aggregate $ sunnullify nullity <$> a

82−

83− {-# INLINABLE encodeTag #-}

84− {-# INLINABLE decodeTag #-}

85− {-# INLINABLE nullifier #-}

86− {-# INLINABLE unnullifier #-}

89instance Nullifiable Expr where

67instance Nullifiable Expr where

90− encodeTag Tag {expr} = E expr

91− decodeTag (E a) = fromExpr a

92− nullifier Tag {expr} test SSpec {nullity} (E a) =

68+ nullifier (E tag) isNonNull SSpec {nullity} (E a) =

93− E $ runTag nullity (test expr) a

69+ E $ guardExpr condition (snullify nullity a)

94− unnullifier SSpec {nullity} (E a) = E $ unnull nullity a

70+ where

71+ condition = isNonNull tag

96− {-# INLINABLE encodeTag #-}

73+ unnullifier SSpec {nullity} (E a) = E $ sunnullify nullity a

97− {-# INLINABLE decodeTag #-}

98− {-# INLINABLE nullifier #-}

99− {-# INLINABLE unnullifier #-}

100

101

102instance Nullifiable Name where

76instance Nullifiable Name where

103− encodeTag Tag {name} = N name

104− decodeTag (N name) = fromName name

105− nullifier _ _ _ (N (Name name)) = N (Name name)

77+ nullifier _ _ _ (N (Name a)) = N $ Name a

106− unnullifier _ (N (Name name)) = N (Name name)

78+ unnullifier _ (N (Name a)) = N $ Name a

79+

80+

81+instance Nullifiable context => Nullifiable (Reify context) where

82+ nullifier (Reify tag) isNonNull spec (Reify a) =

83+ Reify $ nullifier tag isNonNull spec a

107

108− {-# INLINABLE encodeTag #-}

85+ unnullifier spec (Reify a) = Reify (unnullifier spec a)

109− {-# INLINABLE decodeTag #-}

110− {-# INLINABLE nullifier #-}

111− {-# INLINABLE unnullifier #-}

112

113

114−runTag :: Nullity a -> Expr Bool -> Expr a -> Expr (Nullify a)

88+guardExpr :: Expr Bool -> Expr (Maybe a) -> Expr (Maybe a)

115−runTag nullity tag a = case nullity of

116− Null -> boolExpr null a tag

89+guardExpr condition a = boolExpr null a condition

117− NotNull -> boolExpr null (nullify a) tag

118 where

90 where

119 null = fromPrimExpr $ Opaleye.ConstExpr Opaleye.NullLit

91 null = fromPrimExpr $ Opaleye.ConstExpr Opaleye.NullLit

120

121

94+snullify :: Nullity a -> Expr a -> Expr (Nullify a)

95+snullify nullity a = case nullity of

96+ Null -> a

97+ NotNull -> nullify a

98+

99+

122−unnull :: Nullity a -> Expr (Nullify a) -> Expr a

100+sunnullify :: Nullity a -> Expr (Nullify a) -> Expr a

123−unnull nullity a = case nullity of

101+sunnullify nullity a = case nullity of

124 Null -> a

102 Null -> a

125 NotNull -> unsafeUnnullify a

103 NotNull -> unsafeUnnullify a

src/Rel8/Schema/HTable/Label.hs+1

@@ -41,6 +41,7 @@ instance (HTable table, KnownSymbol label) => HTable (HLabel label table) where

41 hdicts = HLabel (hdicts @table)

42 hspecs = HLabel $ htabulate $ \field -> case hfield (hspecs @table) field of

43 SSpec {..} -> SSpec {labels = symbolVal (Proxy @label) : labels, ..}

44+ {-# INLINABLE hspecs #-}

46hlabel :: forall label t context. t context -> HLabel label t context

47hlabel :: forall label t context. t context -> HLabel label t context

src/Rel8/Table/Aggregate.hs+3−3

@@ -61,13 +61,13 @@ hgroupBy eqs exprs = fromColumns $ htabulate $ \field ->

61-- items:

62--

63-- @

64−-- ordersWithItems :: Query (Order Expr, ListTable (Item Expr))

64+-- ordersWithItems :: Query (Order Expr, ListTable Expr (Item Expr))

65-- ordersWithItems = do

66-- order <- each orderSchema

67-- items <- aggregate $ listAgg <$> itemsFromOrder order

68-- return (order, items)

69-- @

70−listAgg :: Aggregates aggregates exprs => exprs -> ListTable aggregates

70+listAgg :: Aggregates aggregates exprs => exprs -> ListTable Aggregate aggregates

71listAgg (toColumns -> exprs) = fromColumns $

72 hvectorize

73 (\SSpec {info} (Identity (E a)) -> A $ slistAggExpr info a)

@@ -75,7 +75,7 @@ listAgg (toColumns -> exprs) = fromColumns $

77-- | Like 'listAgg', but the result is guaranteed to be a non-empty list.

78−nonEmptyAgg :: Aggregates aggregates exprs => exprs -> NonEmptyTable aggregates

78+nonEmptyAgg :: Aggregates aggregates exprs => exprs -> NonEmptyTable Aggregate aggregates

79nonEmptyAgg (toColumns -> exprs) = fromColumns $

80 hvectorize

81 (\SSpec {info} (Identity (E a)) -> A $ snonEmptyAggExpr info a)

src/Rel8/Table/Either.hs+66−56

@@ -3,7 +3,6 @@

3{-# language DerivingStrategies #-}

4{-# language FlexibleContexts #-}

5{-# language FlexibleInstances #-}

6−{-# language LambdaCase #-}

7{-# language MultiParamTypeClasses #-}

6{-# language MultiParamTypeClasses #-}

8{-# language NamedFieldPuns #-}

7{-# language NamedFieldPuns #-}

9{-# language ScopedTypeVariables #-}

8{-# language ScopedTypeVariables #-}

@@ -18,6 +17,7 @@ module Rel8.Table.Either

18 ( EitherTable(..)

17 ( EitherTable(..)

19 , eitherTable, leftTable, rightTable

18 , eitherTable, leftTable, rightTable

20 , isLeftTable, isRightTable

19 , isLeftTable, isRightTable

20+ , aggregateEitherTable

21 , nameEitherTable

22 )

23where

@@ -30,19 +30,19 @@ import Data.Kind ( Type )

30import Prelude hiding ( undefined )

32-- rel8

33−import Rel8.Expr ( Expr )

33+import Rel8.Aggregate ( Col( A ), Aggregate )

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

35+import Rel8.Expr.Aggregate ( groupByExpr )

34import Rel8.Expr.Serialize ( litExpr )

36import Rel8.Expr.Serialize ( litExpr )

35−import Rel8.Schema.Context.Nullify

37+import Rel8.Schema.Context.Nullify ( Nullifiable, nullifier, unnullifier )

36− ( Nullifiable

37− , encodeTag, decodeTag

38− , nullifier, unnullifier

39− )

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

38import Rel8.Schema.Dict ( Dict( Dict ) )

41import Rel8.Schema.HTable.Either ( HEitherTable(..) )

39import Rel8.Schema.HTable.Either ( HEitherTable(..) )

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

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

43import Rel8.Schema.HTable.Label ( hlabel, hunlabel )

41import Rel8.Schema.HTable.Label ( hlabel, hunlabel )

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

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

45−import Rel8.Schema.Name ( Name )

43+import qualified Rel8.Schema.Kind as K

44+import Rel8.Schema.Name ( Col( N ), Name )

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

46import Rel8.Table

47 ( Table, Columns, Context, fromColumns, toColumns

48 , reify, unreify

@@ -52,7 +52,6 @@ import Rel8.Table.Eq ( EqTable, eqTable )

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

53import Rel8.Table.Recontextualize ( Recontextualize )

54import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )

55−import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )

56import Rel8.Table.Undefined ( undefined )

55import Rel8.Table.Undefined ( undefined )

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

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

@@ -67,91 +66,92 @@ import Data.Functor.Bind ( Bind, (>>-) )

67--

66--

68-- An @EitherTable@ is operationally the same as Haskell's 'Either' type, but

67-- An @EitherTable@ is operationally the same as Haskell's 'Either' type, but

69-- adapted to work with Rel8.

68-- adapted to work with Rel8.

70−type EitherTable :: Type -> Type -> Type

69+type EitherTable :: K.Context -> Type -> Type -> Type

71−data EitherTable a b = EitherTable

70+data EitherTable context a b = EitherTable

72− { tag :: Tag "isRight" EitherTag

71+ { tag :: Col context ('Spec EitherTag)

73 , left :: a

72 , left :: a

74 , right :: b

73 , right :: b

75 }

74 }

76 deriving stock Functor

75 deriving stock Functor

79−instance Bifunctor EitherTable where

78+instance Bifunctor (EitherTable context) where

80 bimap f g (EitherTable tag a b) = EitherTable tag (f a) (g b)

79 bimap f g (EitherTable tag a b) = EitherTable tag (f a) (g b)

83−instance Table Expr a => Apply (EitherTable a) where

82+instance (context ~ Expr, Table Expr a) => Apply (EitherTable context a) where

84− EitherTable tag l1 f <.> EitherTable tag' l2 a =

83+ EitherTable (E tag) l1 f <.> EitherTable (E tag') l2 a =

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

84+ EitherTable (E (tag <> tag')) (bool l1 l2 (isLeft tag)) (f a)

88−instance Table Expr a => Applicative (EitherTable a) where

87+instance (context ~ Expr, Table Expr a) => Applicative (EitherTable context a) where

89 pure = rightTable

88 pure = rightTable

90 (<*>) = (<.>)

89 (<*>) = (<.>)

93−instance Table Expr a => Bind (EitherTable a) where

92+instance (context ~ Expr, Table Expr a) => Bind (EitherTable context a) where

94− EitherTable tag l1 a >>- f = case f a of

93+ EitherTable (E tag) l1 a >>- f = case f a of

95− EitherTable tag' l2 b ->

94+ EitherTable (E tag') l2 b ->

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

95+ EitherTable (E (tag <> tag')) (bool l1 l2 (isRight tag)) b

99−instance Table Expr a => Monad (EitherTable a) where

98+instance (context ~ Expr, Table Expr a) => Monad (EitherTable context a) where

100 (>>=) = (>>-)

99 (>>=) = (>>-)

101

100

102

101

103−instance (Table Expr a, Table Expr b) => Semigroup (EitherTable a b) where

102+instance (context ~ Expr, Table Expr a, Table Expr b) =>

103+ Semigroup (EitherTable context a b)

104+ where

104 a <> b = bool a b (isRightTable a)

105 a <> b = bool a b (isRightTable a)

105

106

107

107instance

108instance

108 ( Table context a, Table context b

109 ( Table context a, Table context b

109− , Nullifiable context

110+ , Nullifiable context, context ~ context'

110 )

111 )

111− => Table context (EitherTable a b)

112+ => Table context' (EitherTable context a b)

112 where

113 where

113− type Columns (EitherTable a b) = HEitherTable (Columns a) (Columns b)

114+ type Columns (EitherTable context a b) = HEitherTable (Columns a) (Columns b)

114− type Context (EitherTable a b) = Context a

115+ type Context (EitherTable context a b) = Context a

115

116

116 toColumns EitherTable {tag, left, right} = HEitherTable

117 toColumns EitherTable {tag, left, right} = HEitherTable

117− { htag

118+ { htag = hlabel (HType tag)

118 , hleft = hlabel $ hnullify (nullifier tag isLeft) $ toColumns left

119 , hleft = hlabel $ hnullify (nullifier tag isLeft) $ toColumns left

119 , hright = hlabel $ hnullify (nullifier tag isRight) $ toColumns right

120 , hright = hlabel $ hnullify (nullifier tag isRight) $ toColumns right

120 }

121 }

121− where

122− htag = hlabel $ HType $ encodeTag tag

123

122

124 fromColumns HEitherTable {htag, hleft, hright} = EitherTable

123 fromColumns HEitherTable {htag, hleft, hright} = EitherTable

125− { tag

124+ { tag = unHIdentity (hunlabel htag)

126 , left =

125 , left =

127 fromColumns $

126 fromColumns $

128 runIdentity $

127 runIdentity $

129− hunnullify (\a -> pure . unnullifier a) $

128+ hunnullify (\spec -> pure . unnullifier spec) $

130 hunlabel

129 hunlabel

131 hleft

130 hleft

132 , right =

131 , right =

133 fromColumns $

132 fromColumns $

134 runIdentity $

133 runIdentity $

135− hunnullify (\a -> pure . unnullifier a) $

134+ hunnullify (\spec -> pure . unnullifier spec) $

136 hunlabel

135 hunlabel

137 hright

136 hright

138 }

137 }

139− where

140− tag = decodeTag $ unHIdentity $ hunlabel htag

141

138

142 reify = liftA2 bimap reify reify

139 reify = liftA2 bimap reify reify

143 unreify = liftA2 bimap unreify unreify

140 unreify = liftA2 bimap unreify unreify

144

141

145

142

146instance

143instance

147− ( Nullifiable from, Nullifiable to

144+ ( Nullifiable from, from ~ from'

145+ , Nullifiable to, to ~ to'

148 , Recontextualize from to a1 b1

146 , Recontextualize from to a1 b1

149 , Recontextualize from to a2 b2

147 , Recontextualize from to a2 b2

150 )

148 )

151− => Recontextualize from to (EitherTable a1 a2) (EitherTable b1 b2)

149+ => Recontextualize from to (EitherTable from' a1 a2) (EitherTable to' b1 b2)

152

150

153

151

154−instance (EqTable a, EqTable b) => EqTable (EitherTable a b) where

152+instance (EqTable a, EqTable b, context ~ Expr) =>

153+ EqTable (EitherTable context a b)

154+ where

155 eqTable = HEitherTable

156 { htag = hlabel (HType Dict)

157 , hleft = hlabel (hnullify (\_ Dict -> Dict) (eqTable @a))

@@ -159,7 +159,9 @@ instance (EqTable a, EqTable b) => EqTable (EitherTable a b) where

159 }

160

161

162−instance (OrdTable a, OrdTable b) => OrdTable (EitherTable a b) where

162+instance (OrdTable a, OrdTable b, context ~ Expr) =>

163+ OrdTable (EitherTable context a b)

164+ where

163 ordTable = HEitherTable

165 ordTable = HEitherTable

164 { htag = hlabel (HType Dict)

166 { htag = hlabel (HType Dict)

165 , hleft = hlabel (hnullify (\_ Dict -> Dict) (ordTable @a))

167 , hleft = hlabel (hnullify (\_ Dict -> Dict) (ordTable @a))

@@ -167,10 +169,11 @@ instance (OrdTable a, OrdTable b) => OrdTable (EitherTable a b) where

167 }

169 }

168

170

169

171

170−type instance FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)

172+type instance FromExprs (EitherTable _context a b) =

173+ Either (FromExprs a) (FromExprs b)

171

174

172

175

173−instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable exprs1 exprs2) =>

176+instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable Expr exprs1 exprs2) =>

174 ToExprs x (Either a b)

177 ToExprs x (Either a b)

175 where

178 where

176 fromResult =

179 fromResult =

@@ -182,35 +185,42 @@ instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable exprs1 exprs2) =>

182

185

183

186

184-- | Test if an 'EitherTable' is a 'leftTable'.

187-- | Test if an 'EitherTable' is a 'leftTable'.

185−isLeftTable :: EitherTable a b -> Expr Bool

188+isLeftTable :: EitherTable Expr a b -> Expr Bool

186−isLeftTable = isLeft . expr . tag

189+isLeftTable EitherTable {tag = E tag} = isLeft tag

187

190

188

191

189-- | Test if an 'EitherTable' is a 'rightTable'.

192-- | Test if an 'EitherTable' is a 'rightTable'.

190−isRightTable :: EitherTable a b -> Expr Bool

193+isRightTable :: EitherTable Expr a b -> Expr Bool

191−isRightTable = isRight . expr . tag

194+isRightTable EitherTable {tag = E tag} = isRight tag

192

195

193

196

194-- | Pattern match/eliminate an 'EitherTable', by providing mappings from a

197-- | Pattern match/eliminate an 'EitherTable', by providing mappings from a

195-- 'leftTable' and 'rightTable'.

198-- 'leftTable' and 'rightTable'.

196eitherTable :: Table Expr c

199eitherTable :: Table Expr c

197− => (a -> c) -> (b -> c) -> EitherTable a b -> c

200+ => (a -> c) -> (b -> c) -> EitherTable Expr a b -> c

198−eitherTable f g EitherTable {tag, left, right} =

201+eitherTable f g EitherTable {tag = E tag, left, right} =

199− bool (f left) (g right) (isRight (expr tag))

202+ bool (f left) (g right) (isRight tag)

200

203

201

204

202-- | Construct a left 'EitherTable'. Like 'Left'.

205-- | Construct a left 'EitherTable'. Like 'Left'.

203−leftTable :: Table Expr b => a -> EitherTable a b

206+leftTable :: Table Expr b => a -> EitherTable Expr a b

204−leftTable a = EitherTable (fromExpr (litExpr IsLeft)) a undefined

207+leftTable a = EitherTable (E (litExpr IsLeft)) a undefined

205

208

206

209

207-- | Construct a right 'EitherTable'. Like 'Right'.

210-- | Construct a right 'EitherTable'. Like 'Right'.

208−rightTable :: Table Expr a => b -> EitherTable a b

211+rightTable :: Table Expr a => b -> EitherTable Expr a b

209−rightTable = rightTableWith undefined

212+rightTable = EitherTable (E (litExpr IsRight)) undefined

210

213

211

214

215+-- | Lift a pair of aggregating functions to operate on an 'EitherTable'.

216+-- @leftTable@s and @rightTable@s are grouped separately.

217+aggregateEitherTable :: ()

218+ => (exprs -> aggregates)

219+ -> (exprs' -> aggregates')

212−rightTableWith :: a -> b -> EitherTable a b

220+ -> EitherTable Expr exprs exprs'

213−rightTableWith = EitherTable (fromExpr (litExpr IsRight))

221+ -> EitherTable Aggregate aggregates aggregates'

222+aggregateEitherTable f g (EitherTable (E tag) a b) =

223+ EitherTable (A (groupByExpr tag)) (f a) (g b)

214

224

215

225

216-- | Construct a 'EitherTable' in the 'Name' context. This can be useful if you

226-- | Construct a 'EitherTable' in the 'Name' context. This can be useful if you

@@ -224,5 +234,5 @@ nameEitherTable

224 -- ^ Names of the columns in the @a@ table.

234 -- ^ Names of the columns in the @a@ table.

225 -> b

235 -> b

226 -- ^ Names of the columns in the @b@ table.

236 -- ^ Names of the columns in the @b@ table.

227− -> EitherTable a b

237+ -> EitherTable Name a b

228−nameEitherTable = EitherTable . fromName

238+nameEitherTable = EitherTable . N

src/Rel8/Table/List.hs+28−18

@@ -1,3 +1,4 @@

1+{-# language DataKinds #-}

1{-# language FlexibleContexts #-}

2{-# language FlexibleContexts #-}

2{-# language FlexibleInstances #-}

3{-# language FlexibleInstances #-}

3{-# language MultiParamTypeClasses #-}

4{-# language MultiParamTypeClasses #-}

@@ -26,6 +27,7 @@ import Rel8.Expr.Array ( sappend, sempty, slistOf )

26import Rel8.Schema.Dict ( Dict( Dict ) )

27import Rel8.Schema.Dict ( Dict( Dict ) )

27import Rel8.Schema.HTable.List ( HListTable )

28import Rel8.Schema.HTable.List ( HListTable )

28import Rel8.Schema.HTable.Vectorize ( happend, hempty, hvectorize )

29import Rel8.Schema.HTable.Vectorize ( happend, hempty, hvectorize )

30+import qualified Rel8.Schema.Kind as K

29import Rel8.Schema.Name ( Col( N ), Name( Name ) )

31import Rel8.Schema.Name ( Col( N ), Name( Name ) )

30import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

32import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

31import Rel8.Schema.Spec ( SSpec(..) )

33import Rel8.Schema.Spec ( SSpec(..) )

@@ -47,15 +49,16 @@ import Rel8.Table.Unreify ( Unreifies )

48-- | A @ListTable@ value contains zero or more instances of @a@. You construct

50-- | A @ListTable@ value contains zero or more instances of @a@. You construct

49-- @ListTable@s with 'Rel8.many' or 'Rel8.listAgg'.

51-- @ListTable@s with 'Rel8.many' or 'Rel8.listAgg'.

50−type ListTable :: Type -> Type

52+type ListTable :: K.Context -> Type -> Type

53+newtype ListTable context a =

51−newtype ListTable a = ListTable (HListTable (Columns a) (Col (Context a)))

54+ ListTable (HListTable (Columns a) (Col (Context a)))

54−instance (Table context a, Unreifies context a) =>

57+instance (Table context a, Unreifies context a, context ~ context') =>

55− Table context (ListTable a)

58+ Table context' (ListTable context a)

56 where

59 where

57− type Columns (ListTable a) = HListTable (Columns a)

60+ type Columns (ListTable context a) = HListTable (Columns a)

58− type Context (ListTable a) = Context a

61+ type Context (ListTable context a) = Context a

60 fromColumns = ListTable

63 fromColumns = ListTable

61 toColumns (ListTable a) = a

64 toColumns (ListTable a) = a

@@ -65,13 +68,14 @@ instance (Table context a, Unreifies context a) =>

67instance

70instance

68− ( Unreifies from a, Unreifies to b

71+ ( Unreifies from a, from ~ from'

72+ , Unreifies to b, to ~ to'

69 , Recontextualize from to a b

73 , Recontextualize from to a b

70 )

74 )

71− => Recontextualize from to (ListTable a) (ListTable b)

75+ => Recontextualize from to (ListTable from' a) (ListTable to' b)

74−instance EqTable a => EqTable (ListTable a) where

78+instance (EqTable a, context ~ Expr) => EqTable (ListTable context a) where

75 eqTable =

79 eqTable =

76 hvectorize

80 hvectorize

77 (\SSpec {nullity} (Identity Dict) -> case nullity of

81 (\SSpec {nullity} (Identity Dict) -> case nullity of

@@ -80,7 +84,7 @@ instance EqTable a => EqTable (ListTable a) where

80 (Identity (eqTable @a))

84 (Identity (eqTable @a))

83−instance OrdTable a => OrdTable (ListTable a) where

87+instance (OrdTable a, context ~ Expr) => OrdTable (ListTable context a) where

84 ordTable =

88 ordTable =

85 hvectorize

89 hvectorize

86 (\SSpec {nullity} (Identity Dict) -> case nullity of

90 (\SSpec {nullity} (Identity Dict) -> case nullity of

@@ -89,33 +93,39 @@ instance OrdTable a => OrdTable (ListTable a) where

89 (Identity (ordTable @a))

93 (Identity (ordTable @a))

92−type instance FromExprs (ListTable a) = [FromExprs a]

96+type instance FromExprs (ListTable _context a) = [FromExprs a]

99+instance (ToExprs exprs a, context ~ Expr) =>

95−instance ToExprs exprs a => ToExprs (ListTable exprs) [a] where

100+ ToExprs (ListTable context exprs) [a]

101+ where

96 fromResult = fmap (fromResult @exprs) . fromColumns

102 fromResult = fmap (fromResult @exprs) . fromColumns

97 toResult = toColumns . fmap (toResult @exprs)

103 toResult = toColumns . fmap (toResult @exprs)

104

105

100−instance AltTable ListTable where

106+instance context ~ Expr => AltTable (ListTable context) where

101 (<|>:) = (<>)

107 (<|>:) = (<>)

102

108

103

109

104−instance AlternativeTable ListTable where

110+instance context ~ Expr => AlternativeTable (ListTable context) where

105 emptyTable = mempty

111 emptyTable = mempty

106

112

107

113

114+instance (context ~ Expr, Table Expr a) =>

108−instance Table Expr a => Semigroup (ListTable a) where

115+ Semigroup (ListTable context a)

116+ where

109 ListTable as <> ListTable bs = ListTable $

117 ListTable as <> ListTable bs = ListTable $

110 happend (\_ _ (E a) (E b) -> E (sappend a b)) as bs

118 happend (\_ _ (E a) (E b) -> E (sappend a b)) as bs

111

119

112

120

113−instance Table Expr a => Monoid (ListTable a) where

121+instance (context ~ Expr, Table Expr a) =>

122+ Monoid (ListTable context a)

123+ where

114 mempty = ListTable $ hempty $ \_ -> E . sempty

124 mempty = ListTable $ hempty $ \_ -> E . sempty

115

125

116

126

117-- | Construct a @ListTable@ from a list of expressions.

127-- | Construct a @ListTable@ from a list of expressions.

118−listTable :: Table Expr a => [a] -> ListTable a

128+listTable :: Table Expr a => [a] -> ListTable Expr a

119listTable =

129listTable =

120 ListTable .

130 ListTable .

121 hvectorize (\SSpec {info} -> E . slistOf info . fmap unE) .

131 hvectorize (\SSpec {info} -> E . slistOf info . fmap unE) .

@@ -128,7 +138,7 @@ listTable =

128nameListTable

138nameListTable

129 :: Table Name a

139 :: Table Name a

130 => a -- ^ The names of the columns of elements of the list.

140 => a -- ^ The names of the columns of elements of the list.

131− -> ListTable a

141+ -> ListTable Name a

132nameListTable =

142nameListTable =

133 ListTable .

143 ListTable .

134 hvectorize (\_ (Identity (N (Name a))) -> N (Name a)) .

144 hvectorize (\_ (Identity (N (Name a))) -> N (Name a)) .

src/Rel8/Table/Maybe.hs+66−64

@@ -3,7 +3,6 @@

3{-# language DerivingStrategies #-}

4{-# language FlexibleContexts #-}

5{-# language FlexibleInstances #-}

6−{-# language LambdaCase #-}

7{-# language MultiParamTypeClasses #-}

6{-# language MultiParamTypeClasses #-}

8{-# language NamedFieldPuns #-}

7{-# language NamedFieldPuns #-}

9{-# language ScopedTypeVariables #-}

8{-# language ScopedTypeVariables #-}

@@ -17,6 +16,7 @@ module Rel8.Table.Maybe

17 , maybeTable, nothingTable, justTable

16 , maybeTable, nothingTable, justTable

18 , isNothingTable, isJustTable

17 , isNothingTable, isJustTable

19 , ($?)

18 , ($?)

19+ , aggregateMaybeTable

20 , nameMaybeTable

21 )

22where

@@ -27,21 +27,21 @@ import Data.Kind ( Type )

27import Prelude hiding ( null, undefined )

29-- rel8

30−import Rel8.Expr ( Expr )

30+import Rel8.Aggregate ( Col( A ), Aggregate )

31+import Rel8.Expr ( Col( E ), Expr )

32+import Rel8.Expr.Aggregate ( groupByExpr )

31import Rel8.Expr.Bool ( boolExpr )

33import Rel8.Expr.Bool ( boolExpr )

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

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

33−import Rel8.Schema.Context.Nullify

35+import Rel8.Schema.Context.Nullify ( Nullifiable, nullifier, unnullifier )

34− ( Nullifiable

35− , encodeTag, decodeTag

36− , nullifier, unnullifier

37− )

38import Rel8.Schema.Dict ( Dict( Dict ) )

36import Rel8.Schema.Dict ( Dict( Dict ) )

37+import qualified Rel8.Schema.Kind as K

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

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

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

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

41import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )

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

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

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

43−import Rel8.Schema.Name ( Name )

42+import Rel8.Schema.Name ( Col( N ), Name )

44import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql, nullable )

43import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql, nullable )

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

45import Rel8.Table

46 ( Table, Columns, Context, fromColumns, toColumns

47 , reify, unreify

@@ -55,7 +55,6 @@ import Rel8.Table.Eq ( EqTable, eqTable )

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

56import Rel8.Table.Recontextualize ( Recontextualize )

57import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )

58−import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )

59import Rel8.Table.Undefined ( undefined )

58import Rel8.Table.Undefined ( undefined )

60import Rel8.Type ( DBType )

59import Rel8.Type ( DBType )

61import Rel8.Type.Tag ( MaybeTag )

60import Rel8.Type.Tag ( MaybeTag )

@@ -73,154 +72,157 @@ import Data.Functor.Bind ( Bind, (>>-) )

73-- entirely of nulls, you can't distinguish if you matched an all null row, or

72-- entirely of nulls, you can't distinguish if you matched an all null row, or

74-- if the match failed. For this reason @MaybeTable@ contains an extra field -

73-- if the match failed. For this reason @MaybeTable@ contains an extra field -

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

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

76−type MaybeTable :: Type -> Type

75+type MaybeTable :: K.Context -> Type -> Type

77−data MaybeTable a = MaybeTable

76+data MaybeTable context a = MaybeTable

78− { tag :: Tag "isJust" (Maybe MaybeTag)

77+ { tag :: Col context ('Spec (Maybe MaybeTag))

79 , just :: a

78 , just :: a

80 }

79 }

81 deriving stock Functor

80 deriving stock Functor

84−instance Apply MaybeTable where

83+instance context ~ Expr => Apply (MaybeTable context) where

85− MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f a)

84+ MaybeTable (E tag) f <.> MaybeTable (E tag') a =

85+ MaybeTable (E (tag <> tag')) (f a)

88-- | Has the same behavior as the @Applicative@ instance for @Maybe@. See also:

89-- 'Rel8.traverseMaybeTable'.

90−instance Applicative MaybeTable where

90+instance context ~ Expr => Applicative (MaybeTable context) where

91 (<*>) = (<.>)

92 pure = justTable

95−instance Bind MaybeTable where

95+instance context ~ Expr => Bind (MaybeTable context) where

96− MaybeTable tag a >>- f = case f a of

96+ MaybeTable (E tag) a >>- f = case f a of

97− MaybeTable tag' b -> MaybeTable (tag <> tag') b

97+ MaybeTable (E tag') b -> MaybeTable (E (tag <> tag')) b

100-- | Has the same behavior as the @Monad@ instance for @Maybe@.

101−instance Monad MaybeTable where

101+instance context ~ Expr => Monad (MaybeTable context) where

102 (>>=) = (>>-)

103

104

105−instance AltTable MaybeTable where

105+instance context ~ Expr => AltTable (MaybeTable context) where

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

107− { tag = (tag <> tag')

108− { expr = boolExpr (expr tag) (expr tag') condition

109− }

110− , just = bool a b condition

111− }

112− where

113− condition = isNothingTable ma

106+ ma <|>: mb = bool ma mb (isNothingTable ma)

114

107

115

108

116−instance AlternativeTable MaybeTable where

109+instance context ~ Expr => AlternativeTable (MaybeTable context) where

117 emptyTable = nothingTable

110 emptyTable = nothingTable

118

111

119

112

120−instance (Table Expr a, Semigroup a) => Semigroup (MaybeTable a) where

113+instance (context ~ Expr, Table Expr a, Semigroup a) =>

114+ Semigroup (MaybeTable context a)

115+ where

121 ma <> mb = maybeTable mb (\a -> maybeTable ma (justTable . (a <>)) mb) ma

116 ma <> mb = maybeTable mb (\a -> maybeTable ma (justTable . (a <>)) mb) ma

122

117

123

118

124−instance (Table Expr a, Semigroup a) => Monoid (MaybeTable a) where

119+instance (context ~ Expr, Table Expr a, Semigroup a) =>

120+ Monoid (MaybeTable context a)

121+ where

125 mempty = nothingTable

122 mempty = nothingTable

126

123

127

124

128−instance

129− ( Table context a

130− , Nullifiable context

125+instance (Table context a, Nullifiable context, context ~ context') =>

131− )

132− => Table context (MaybeTable a)

126+ Table context' (MaybeTable context a)

133 where

127 where

134− type Columns (MaybeTable a) = HMaybeTable (Columns a)

128+ type Columns (MaybeTable context a) = HMaybeTable (Columns a)

135− type Context (MaybeTable a) = Context a

129+ type Context (MaybeTable context a) = Context a

136

130

137 toColumns MaybeTable {tag, just} = HMaybeTable

131 toColumns MaybeTable {tag, just} = HMaybeTable

138− { htag

132+ { htag = hlabel (HIdentity tag)

139 , hjust = hlabel $ hnullify (nullifier tag isNonNull) $ toColumns just

133 , hjust = hlabel $ hnullify (nullifier tag isNonNull) $ toColumns just

140 }

134 }

141− where

142− htag = hlabel (HType (encodeTag tag))

143

135

144 fromColumns HMaybeTable {htag, hjust} = MaybeTable

136 fromColumns HMaybeTable {htag, hjust} = MaybeTable

145− { tag

137+ { tag = unHIdentity (hunlabel htag)

146 , just = fromColumns $ runIdentity $

138 , just = fromColumns $ runIdentity $

147− hunnullify (\a -> pure . unnullifier a) (hunlabel hjust)

139+ hunnullify ((pure .) . unnullifier) (hunlabel hjust)

148 }

140 }

149− where

150− tag = decodeTag (unHIdentity (hunlabel htag))

151

141

152 reify = fmap fmap reify

142 reify = fmap fmap reify

153 unreify = fmap fmap unreify

143 unreify = fmap fmap unreify

154

144

155

145

156instance

146instance

157− ( Nullifiable from

147+ ( Nullifiable from, from ~ from'

158− , Nullifiable to

148+ , Nullifiable to, to ~ to'

159 , Recontextualize from to a b

149 , Recontextualize from to a b

160 )

150 )

161− => Recontextualize from to (MaybeTable a) (MaybeTable b)

151+ => Recontextualize from to (MaybeTable from' a) (MaybeTable to' b)

162

152

163

153

164−instance EqTable a => EqTable (MaybeTable a) where

154+instance (EqTable a, context ~ Expr) => EqTable (MaybeTable context a) where

165 eqTable = HMaybeTable

155 eqTable = HMaybeTable

166 { htag = hlabel (HType Dict)

156 { htag = hlabel (HType Dict)

167 , hjust = hlabel (hnullify (\_ Dict -> Dict) (eqTable @a))

157 , hjust = hlabel (hnullify (\_ Dict -> Dict) (eqTable @a))

168 }

158 }

169

159

170

160

171−instance OrdTable a => OrdTable (MaybeTable a) where

161+instance (OrdTable a, context ~ Expr) => OrdTable (MaybeTable context a) where

172 ordTable = HMaybeTable

162 ordTable = HMaybeTable

173 { htag = hlabel (HType Dict)

163 { htag = hlabel (HType Dict)

174 , hjust = hlabel (hnullify (\_ Dict -> Dict) (ordTable @a))

164 , hjust = hlabel (hnullify (\_ Dict -> Dict) (ordTable @a))

175 }

165 }

176

166

177

167

178−type instance FromExprs (MaybeTable a) = Maybe (FromExprs a)

168+type instance FromExprs (MaybeTable _context a) = Maybe (FromExprs a)

179

169

180

170

171+instance (ToExprs exprs a, context ~ Expr) =>

181−instance ToExprs exprs a => ToExprs (MaybeTable exprs) (Maybe a) where

172+ ToExprs (MaybeTable context exprs) (Maybe a)

173+ where

182 fromResult = fmap (fromResult @exprs) . fromColumns

174 fromResult = fmap (fromResult @exprs) . fromColumns

183 toResult = toColumns . fmap (toResult @exprs)

175 toResult = toColumns . fmap (toResult @exprs)

184

176

185

177

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

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

187−isNothingTable :: MaybeTable a -> Expr Bool

179+isNothingTable :: MaybeTable Expr a -> Expr Bool

188−isNothingTable (MaybeTable tag _) = isNull (expr tag)

180+isNothingTable (MaybeTable (E tag) _) = isNull tag

189

181

190

182

191-- | Check if a @MaybeTable@ contains a row. Like 'Data.Maybe.isJust'.

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

192−isJustTable :: MaybeTable a -> Expr Bool

184+isJustTable :: MaybeTable Expr a -> Expr Bool

193−isJustTable (MaybeTable tag _) = isNonNull (expr tag)

185+isJustTable (MaybeTable (E tag) _) = isNonNull tag

194

186

195

187

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

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

197−maybeTable :: Table Expr b => b -> (a -> b) -> MaybeTable a -> b

189+maybeTable :: Table Expr b => b -> (a -> b) -> MaybeTable Expr a -> b

198maybeTable b f ma@(MaybeTable _ a) = bool (f a) b (isNothingTable ma)

190maybeTable b f ma@(MaybeTable _ a) = bool (f a) b (isNothingTable ma)

199{-# INLINABLE maybeTable #-}

191{-# INLINABLE maybeTable #-}

200

192

201

193

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

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

203−nothingTable :: Table Expr a => MaybeTable a

195+nothingTable :: Table Expr a => MaybeTable Expr a

204−nothingTable = MaybeTable (fromExpr null) undefined

196+nothingTable = MaybeTable (E null) undefined

205

197

206

198

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

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

208-- 'pure'.

200-- 'pure'.

209−justTable :: a -> MaybeTable a

201+justTable :: a -> MaybeTable Expr a

210−justTable = MaybeTable (fromExpr mempty)

202+justTable = MaybeTable (E mempty)

211

203

212

204

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

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

214-- operator like the '$' operator, but it also has the ability to return

206-- operator like the '$' operator, but it also has the ability to return

215-- @null@.

207-- @null@.

216($?) :: forall a b. Sql DBType b

208($?) :: forall a b. Sql DBType b

217− => (a -> Expr b) -> MaybeTable a -> Expr (Nullify b)

209+ => (a -> Expr b) -> MaybeTable Expr a -> Expr (Nullify b)

218f $? ma@(MaybeTable _ a) = case nullable @b of

210f $? ma@(MaybeTable _ a) = case nullable @b of

219 Null -> boolExpr (f a) null (isNothingTable ma)

211 Null -> boolExpr (f a) null (isNothingTable ma)

220 NotNull -> boolExpr (nullify (f a)) null (isNothingTable ma)

212 NotNull -> boolExpr (nullify (f a)) null (isNothingTable ma)

221infixl 4 $?

213infixl 4 $?

222

214

223

215

216+-- | Lift an aggregating function to operate on a 'MaybeTable'.

217+-- @nothingTable@s and @justTable@s are grouped separately.

218+aggregateMaybeTable :: ()

219+ => (exprs -> aggregates)

220+ -> MaybeTable Expr exprs

221+ -> MaybeTable Aggregate aggregates

222+aggregateMaybeTable f (MaybeTable (E tag) a) =

223+ MaybeTable (A (groupByExpr tag)) (f a)

224+

225+

224-- | Construct a 'MaybeTable' in the 'Name' context. This can be useful if you

226-- | Construct a 'MaybeTable' in the 'Name' context. This can be useful if you

225-- have a 'MaybeTable' that you are storing in a table and need to construct a

227-- have a 'MaybeTable' that you are storing in a table and need to construct a

226-- 'TableSchema'.

228-- 'TableSchema'.

@@ -230,5 +232,5 @@ nameMaybeTable

230 -- 'nothingTable'.

232 -- 'nothingTable'.

231 -> a

233 -> a

232 -- ^ Names of the columns in @a@.

234 -- ^ Names of the columns in @a@.

233− -> MaybeTable a

235+ -> MaybeTable Name a

234−nameMaybeTable = MaybeTable . fromName

236+nameMaybeTable = MaybeTable . N

src/Rel8/Table/NonEmpty.hs+26−16

@@ -1,3 +1,4 @@

1+{-# language DataKinds #-}

1{-# language FlexibleContexts #-}

2{-# language FlexibleContexts #-}

2{-# language FlexibleInstances #-}

3{-# language FlexibleInstances #-}

3{-# language MultiParamTypeClasses #-}

4{-# language MultiParamTypeClasses #-}

@@ -27,6 +28,7 @@ import Rel8.Expr.Array ( sappend1, snonEmptyOf )

27import Rel8.Schema.Dict ( Dict( Dict ) )

28import Rel8.Schema.Dict ( Dict( Dict ) )

28import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )

29import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )

29import Rel8.Schema.HTable.Vectorize ( happend, hvectorize )

30import Rel8.Schema.HTable.Vectorize ( happend, hvectorize )

31+import qualified Rel8.Schema.Kind as K

30import Rel8.Schema.Name ( Col( N ), Name( Name ) )

32import Rel8.Schema.Name ( Col( N ), Name( Name ) )

31import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

33import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

32import Rel8.Schema.Reify ( hreify, hunreify )

34import Rel8.Schema.Reify ( hreify, hunreify )

@@ -45,16 +47,16 @@ import Rel8.Table.Unreify ( Unreifies )

46-- | A @NonEmptyTable@ value contains one or more instances of @a@. You

48-- | A @NonEmptyTable@ value contains one or more instances of @a@. You

47-- construct @NonEmptyTable@s with 'Rel8.some' or 'nonEmptyAgg'.

49-- construct @NonEmptyTable@s with 'Rel8.some' or 'nonEmptyAgg'.

48−type NonEmptyTable :: Type -> Type

50+type NonEmptyTable :: K.Context -> Type -> Type

49−newtype NonEmptyTable a =

51+newtype NonEmptyTable context a =

50 NonEmptyTable (HNonEmptyTable (Columns a) (Col (Context a)))

52 NonEmptyTable (HNonEmptyTable (Columns a) (Col (Context a)))

53−instance (Table context a, Unreifies context a) =>

55+instance (Table context a, Unreifies context a, context ~ context') =>

54− Table context (NonEmptyTable a)

56+ Table context' (NonEmptyTable context a)

55 where

57 where

56− type Columns (NonEmptyTable a) = HNonEmptyTable (Columns a)

58+ type Columns (NonEmptyTable context a) = HNonEmptyTable (Columns a)

57− type Context (NonEmptyTable a) = Context a

59+ type Context (NonEmptyTable context a) = Context a

59 fromColumns = NonEmptyTable

61 fromColumns = NonEmptyTable

60 toColumns (NonEmptyTable a) = a

62 toColumns (NonEmptyTable a) = a

@@ -64,13 +66,16 @@ instance (Table context a, Unreifies context a) =>

66instance

68instance

67− ( Unreifies from a, Unreifies to b

69+ ( Unreifies from a, from ~ from'

70+ , Unreifies to b, to ~ to'

68 , Recontextualize from to a b

71 , Recontextualize from to a b

69 )

72 )

70− => Recontextualize from to (NonEmptyTable a) (NonEmptyTable b)

73+ => Recontextualize from to (NonEmptyTable from' a) (NonEmptyTable to' b)

76+instance (EqTable a, context ~ Expr) =>

73−instance EqTable a => EqTable (NonEmptyTable a) where

77+ EqTable (NonEmptyTable context a)

78+ where

74 eqTable =

79 eqTable =

75 hvectorize

80 hvectorize

76 (\SSpec {nullity} (Identity Dict) -> case nullity of

81 (\SSpec {nullity} (Identity Dict) -> case nullity of

@@ -79,7 +84,9 @@ instance EqTable a => EqTable (NonEmptyTable a) where

79 (Identity (eqTable @a))

84 (Identity (eqTable @a))

87+instance (OrdTable a, context ~ Expr) =>

82−instance OrdTable a => OrdTable (NonEmptyTable a) where

88+ OrdTable (NonEmptyTable context a)

89+ where

83 ordTable =

90 ordTable =

84 hvectorize

91 hvectorize

85 (\SSpec {nullity} (Identity Dict) -> case nullity of

92 (\SSpec {nullity} (Identity Dict) -> case nullity of

@@ -88,26 +95,29 @@ instance OrdTable a => OrdTable (NonEmptyTable a) where

88 (Identity (ordTable @a))

95 (Identity (ordTable @a))

91−type instance FromExprs (NonEmptyTable a) = NonEmpty (FromExprs a)

98+type instance FromExprs (NonEmptyTable _context a) = NonEmpty (FromExprs a)

100

101+instance (ToExprs exprs a, context ~ Expr) =>

94−instance ToExprs exprs a => ToExprs (NonEmptyTable exprs) (NonEmpty a)

102+ ToExprs (NonEmptyTable context exprs) (NonEmpty a)

95 where

103 where

96 fromResult = fmap (fromResult @exprs) . fromColumns

104 fromResult = fmap (fromResult @exprs) . fromColumns

97 toResult = toColumns . fmap (toResult @exprs)

105 toResult = toColumns . fmap (toResult @exprs)

106

107

100−instance AltTable NonEmptyTable where

108+instance context ~ Expr => AltTable (NonEmptyTable context) where

101 (<|>:) = (<>)

109 (<|>:) = (<>)

102

110

103

111

112+instance (Table Expr a, context ~ Expr) =>

104−instance Table Expr a => Semigroup (NonEmptyTable a) where

113+ Semigroup (NonEmptyTable context a)

114+ where

105 NonEmptyTable as <> NonEmptyTable bs = NonEmptyTable $

115 NonEmptyTable as <> NonEmptyTable bs = NonEmptyTable $

106 happend (\_ _ (E a) (E b) -> E (sappend1 a b)) as bs

116 happend (\_ _ (E a) (E b) -> E (sappend1 a b)) as bs

107

117

108

118

109-- | Construct a @NonEmptyTable@ from a non-empty list of expressions.

119-- | Construct a @NonEmptyTable@ from a non-empty list of expressions.

110−nonEmptyTable :: Table Expr a => NonEmpty a -> NonEmptyTable a

120+nonEmptyTable :: Table Expr a => NonEmpty a -> NonEmptyTable Expr a

111nonEmptyTable =

121nonEmptyTable =

112 NonEmptyTable .

122 NonEmptyTable .

113 hvectorize (\SSpec {info} -> E . snonEmptyOf info . fmap unE) .

123 hvectorize (\SSpec {info} -> E . snonEmptyOf info . fmap unE) .

@@ -120,7 +130,7 @@ nonEmptyTable =

120nameNonEmptyTable

130nameNonEmptyTable

121 :: Table Name a

131 :: Table Name a

122 => a -- ^ The names of the columns of elements of the list.

132 => a -- ^ The names of the columns of elements of the list.

123− -> NonEmptyTable a

133+ -> NonEmptyTable Name a

124nameNonEmptyTable =

134nameNonEmptyTable =

125 NonEmptyTable .

135 NonEmptyTable .

126 hvectorize (\_ (Identity (N (Name a))) -> N (Name a)) .

136 hvectorize (\_ (Identity (N (Name a))) -> N (Name a)) .

src/Rel8/Table/Tag.hsdeleted−97

@@ -1,97 +0,0 @@

1−{-# language DataKinds #-}

2−{-# language FlexibleInstances #-}

3−{-# language GADTs #-}

4−{-# language InstanceSigs #-}

5−{-# language NamedFieldPuns #-}

6−{-# language ScopedTypeVariables #-}

7−{-# language StandaloneKindSignatures #-}

8−{-# language TypeApplications #-}

9−{-# language UndecidableInstances #-}

10−

11−module Rel8.Table.Tag

12− ( Tag(..), Taggable

13− , fromAggregate

14− , fromExpr

15− , fromName

16− )

17−where

18−

19−-- base

20−import Control.Applicative ( (<|>), empty )

21−import Data.Kind ( Constraint, Type )

22−import Data.Foldable ( fold )

23−import Data.Monoid ( getFirst )

24−import Data.Proxy ( Proxy( Proxy ) )

25−import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )

26−import Prelude

27−

28−-- rel8

29−import Rel8.Aggregate ( Aggregate, Aggregator, foldInputs )

30−import Rel8.Expr ( Expr )

31−import Rel8.Expr.Opaleye ( fromPrimExpr )

32−import Rel8.Schema.Name ( Name( Name ) )

33−import Rel8.Schema.Null ( Sql )

34−import Rel8.Type.Monoid ( DBMonoid )

35−

36−

37−type Tag :: Symbol -> Type -> Type

38−data Tag label a = Tag

39− { expr :: Expr a

40− , aggregator :: Maybe Aggregator

41− , name :: Name a

42− }

43−

44−

45−type Taggable :: Type -> Constraint

46−class Taggable a where

47− tappend :: KnownSymbol label => Tag label a -> Tag label a -> Tag label a

48− tempty :: KnownSymbol label => Tag label a

49−

50−

51−instance Sql DBMonoid a => Taggable a where

52− tappend :: forall label. KnownSymbol label

53− => Tag label a -> Tag label a -> Tag label a

54− tappend a b = Tag

55− { expr = expr a <> expr b

56− , aggregator = aggregator a <|> aggregator b

57− , name = case (name a, symbolVal (Proxy @label)) of

58− (Name x, y)

59− | x == y -> name b

60− | otherwise -> name a

61− }

62− {-# INLINABLE tappend #-}

63−

64− tempty :: forall label. KnownSymbol label => Tag label a

65− tempty = Tag

66− { expr = mempty

67− , aggregator = empty

68− , name = Name (symbolVal (Proxy @label))

69− }

70− {-# INLINABLE tempty #-}

71−

72−

73−instance (KnownSymbol label, Taggable a) => Semigroup (Tag label a) where

74− (<>) = tappend

75−

76−

77−instance (KnownSymbol label, Taggable a) => Monoid (Tag label a) where

78− mempty = tempty

79−

80−

81−fromAggregate :: forall a label. (KnownSymbol label, Taggable a)

82− => Aggregate a -> Tag label a

83−fromAggregate = fold . getFirst . foldInputs go

84− where

85− go aggregator primExpr = pure $ (tempty @a @label)

86− { expr = fromPrimExpr primExpr

87− , aggregator

88− }

89−

90−

91−fromExpr :: forall label a. (KnownSymbol label, Taggable a)

92− => Expr a -> Tag label a

93−fromExpr expr = (tempty @a @label) {expr}

94−

95−

96−fromName :: forall a label. Taggable a => Name a -> Tag label a

97−fromName name = (tempty @a @"") {name}

src/Rel8/Table/These.hs+84−77

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

5{-# language FlexibleInstances #-}

6{-# language MultiParamTypeClasses #-}

7{-# language NamedFieldPuns #-}

8−{-# language RecordWildCards #-}

9{-# language ScopedTypeVariables #-}

8{-# language ScopedTypeVariables #-}

10{-# language StandaloneKindSignatures #-}

9{-# language StandaloneKindSignatures #-}

11{-# language TupleSections #-}

10{-# language TupleSections #-}

@@ -21,6 +20,7 @@ module Rel8.Table.These

21 , isThisTable, isThatTable, isThoseTable

20 , isThisTable, isThatTable, isThoseTable

22 , hasHereTable, hasThereTable

21 , hasHereTable, hasThereTable

23 , justHereTable, justThereTable

22 , justHereTable, justThereTable

23+ , aggregateTheseTable

24 , nameTheseTable

25 )

26where

@@ -33,19 +33,17 @@ import Data.Kind ( Type )

33import Prelude hiding ( undefined )

35-- rel8

36+import Rel8.Aggregate ( Aggregate )

36import Rel8.Expr ( Expr )

37import Rel8.Expr ( Expr )

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

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

38import Rel8.Expr.Null ( isNonNull )

39import Rel8.Expr.Null ( isNonNull )

39−import Rel8.Schema.Context.Nullify

40+import Rel8.Schema.Context.Nullify ( Nullifiable, nullifier, unnullifier )

40− ( Nullifiable

41− , encodeTag, decodeTag

42− , nullifier, unnullifier

43− )

44import Rel8.Schema.Dict ( Dict( Dict ) )

41import Rel8.Schema.Dict ( Dict( Dict ) )

45import Rel8.Schema.HTable.Label ( hlabel, hunlabel )

42import Rel8.Schema.HTable.Label ( hlabel, hunlabel )

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

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

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

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

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

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

46+import qualified Rel8.Schema.Kind as K

49import Rel8.Schema.Name ( Name )

47import Rel8.Schema.Name ( Name )

50import Rel8.Table

48import Rel8.Table

51 ( Table, Columns, Context, fromColumns, toColumns

49 ( Table, Columns, Context, fromColumns, toColumns

@@ -56,12 +54,12 @@ import Rel8.Table.Maybe

56 ( MaybeTable(..)

54 ( MaybeTable(..)

57 , maybeTable, justTable, nothingTable

55 , maybeTable, justTable, nothingTable

58 , isJustTable

56 , isJustTable

57+ , aggregateMaybeTable

59 , nameMaybeTable

58 , nameMaybeTable

60 )

59 )

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

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

62import Rel8.Table.Recontextualize ( Recontextualize )

61import Rel8.Table.Recontextualize ( Recontextualize )

63import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )

62import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )

64−import Rel8.Table.Tag ( Tag(..) )

65import Rel8.Table.Undefined ( undefined )

63import Rel8.Table.Undefined ( undefined )

66import Rel8.Type.Tag ( MaybeTag )

64import Rel8.Type.Tag ( MaybeTag )

@@ -80,32 +78,37 @@ import Data.These ( These )

80--

78--

81-- @TheseTable@ is operationally the same as Haskell's 'These' type, but

79-- @TheseTable@ is operationally the same as Haskell's 'These' type, but

82-- adapted to work with Rel8.

80-- adapted to work with Rel8.

83−type TheseTable :: Type -> Type -> Type

81+type TheseTable :: K.Context -> Type -> Type -> Type

84−data TheseTable a b = TheseTable

82+data TheseTable context a b = TheseTable

85− { here :: MaybeTable a

83+ { here :: MaybeTable context a

86− , there :: MaybeTable b

84+ , there :: MaybeTable context b

87 }

85 }

88 deriving stock Functor

86 deriving stock Functor

91−instance Bifunctor TheseTable where

89+instance Bifunctor (TheseTable context) where

92 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)

90 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)

95−instance (Table Expr a, Semigroup a) => Apply (TheseTable a) where

93+instance (context ~ Expr, Table Expr a, Semigroup a) =>

94+ Apply (TheseTable context a)

95+ where

96 fs <.> as = TheseTable

97 { here = here fs <> here as

98 , there = there fs <.> there as

99 }

100

101

102−instance (Table Expr a, Semigroup a) => Applicative (TheseTable a)

102+instance (context ~ Expr, Table Expr a, Semigroup a) =>

103+ Applicative (TheseTable context a)

103 where

104 where

104 pure = thatTable

105 pure = thatTable

105 (<*>) = (<.>)

106 (<*>) = (<.>)

106

107

108

108−instance (Table Expr a, Semigroup a) => Bind (TheseTable a) where

109+instance (context ~ Expr, Table Expr a, Semigroup a) =>

110+ Bind (TheseTable context a)

111+ where

109 TheseTable here1 ma >>- f = case ma >>- f' of

112 TheseTable here1 ma >>- f = case ma >>- f' of

110 mtb -> TheseTable

113 mtb -> TheseTable

111 { here = maybeTable here1 ((here1 <>) . fst) mtb

114 { here = maybeTable here1 ((here1 <>) . fst) mtb

@@ -116,12 +119,14 @@ instance (Table Expr a, Semigroup a) => Bind (TheseTable a) where

116 TheseTable here2 mb -> (here2,) <$> mb

119 TheseTable here2 mb -> (here2,) <$> mb

117

120

118

121

119−instance (Table Expr a, Semigroup a) => Monad (TheseTable a) where

122+instance (context ~ Expr, Table Expr a, Semigroup a) =>

123+ Monad (TheseTable context a)

124+ where

120 (>>=) = (>>-)

125 (>>=) = (>>-)

121

126

122

127

123−instance (Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>

128+instance (context ~ Expr, Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>

124− Semigroup (TheseTable a b)

129+ Semigroup (TheseTable context a b)

125 where

130 where

126 a <> b = TheseTable

131 a <> b = TheseTable

127 { here = here a <> here b

132 { here = here a <> here b

@@ -131,67 +136,61 @@ instance (Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>

131

136

132instance

137instance

133 ( Table context a, Table context b

138 ( Table context a, Table context b

134− , Nullifiable context

139+ , Nullifiable context, context ~ context'

135 )

140 )

136− => Table context (TheseTable a b)

141+ => Table context' (TheseTable context a b)

137 where

142 where

138− type Columns (TheseTable a b) = HTheseTable (Columns a) (Columns b)

143+ type Columns (TheseTable context a b) = HTheseTable (Columns a) (Columns b)

139− type Context (TheseTable a b) = Context a

144+ type Context (TheseTable context a b) = Context a

140

145

141 toColumns TheseTable {here, there} = HTheseTable

146 toColumns TheseTable {here, there} = HTheseTable

142− { hhereTag = hlabel $ HType $ encodeTag (toHereTag (tag here))

147+ { hhereTag = hlabel (HIdentity (tag here))

143 , hhere =

148 , hhere =

144 hlabel $ hnullify (nullifier (tag here) isNonNull) $ toColumns $

149 hlabel $ hnullify (nullifier (tag here) isNonNull) $ toColumns $

145 just here

150 just here

146− , hthereTag = hlabel $ HType $ encodeTag (toThereTag (tag there))

151+ , hthereTag = hlabel (HIdentity (tag there))

147 , hthere =

152 , hthere =

148 hlabel $ hnullify (nullifier (tag there) isNonNull) $ toColumns $

153 hlabel $ hnullify (nullifier (tag there) isNonNull) $ toColumns $

149 just there

154 just there

150 }

155 }

151

156

152 fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable

157 fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable

153− { here =

158+ { here = MaybeTable

154− let

155− tag = decodeTag $ unHIdentity $ hunlabel hhereTag

159+ { tag = unHIdentity $ hunlabel hhereTag

156− in

157− MaybeTable

158− { tag

159− , just =

160+ , just =

160− fromColumns $

161+ fromColumns $

161− runIdentity $

162+ runIdentity $

162− hunnullify (\a -> pure . unnullifier a) $

163+ hunnullify (\a -> pure . unnullifier a) $

163− hunlabel

164+ hunlabel

164− hhere

165+ hhere

165− }

166+ }

166− , there =

167+ , there = MaybeTable

167− let

168− tag = decodeTag $ unHIdentity $ hunlabel hthereTag

168+ { tag = unHIdentity $ hunlabel hthereTag

169− in

170− MaybeTable

171− { tag

172− , just =

169+ , just =

173− fromColumns $

170+ fromColumns $

174− runIdentity $

171+ runIdentity $

175− hunnullify (\a -> pure . unnullifier a) $

172+ hunnullify (\a -> pure . unnullifier a) $

176− hunlabel

173+ hunlabel

177− hthere

174+ hthere

178− }

175+ }

179 }

176 }

180

177

181−

182 reify = liftA2 bimap reify reify

178 reify = liftA2 bimap reify reify

183 unreify = liftA2 bimap unreify unreify

179 unreify = liftA2 bimap unreify unreify

184

180

185

181

186instance

182instance

187− ( Nullifiable from, Nullifiable to

183+ ( Nullifiable from, from ~ from'

184+ , Nullifiable to, to ~ to'

188 , Recontextualize from to a1 b1

185 , Recontextualize from to a1 b1

189 , Recontextualize from to a2 b2

186 , Recontextualize from to a2 b2

190 )

187 )

191− => Recontextualize from to (TheseTable a1 a2) (TheseTable b1 b2)

188+ => Recontextualize from to (TheseTable from' a1 a2) (TheseTable to' b1 b2)

192

189

193

190

194−instance (EqTable a, EqTable b) => EqTable (TheseTable a b) where

191+instance (EqTable a, EqTable b, context ~ Expr) =>

192+ EqTable (TheseTable context a b)

193+ where

195 eqTable = HTheseTable

194 eqTable = HTheseTable

196 { hhereTag = hlabel (HType Dict)

195 { hhereTag = hlabel (HType Dict)

197 , hhere = hlabel (hnullify (\_ Dict -> Dict) (eqTable @a))

196 , hhere = hlabel (hnullify (\_ Dict -> Dict) (eqTable @a))

@@ -200,7 +199,9 @@ instance (EqTable a, EqTable b) => EqTable (TheseTable a b) where

200 }

199 }

201

200

202

201

203−instance (OrdTable a, OrdTable b) => OrdTable (TheseTable a b) where

202+instance (OrdTable a, OrdTable b, context ~ Expr) =>

203+ OrdTable (TheseTable context a b)

204+ where

204 ordTable = HTheseTable

205 ordTable = HTheseTable

205 { hhereTag = hlabel (HType Dict)

206 { hhereTag = hlabel (HType Dict)

206 , hhere = hlabel (hnullify (\_ Dict -> Dict) (ordTable @a))

207 , hhere = hlabel (hnullify (\_ Dict -> Dict) (ordTable @a))

@@ -209,10 +210,11 @@ instance (OrdTable a, OrdTable b) => OrdTable (TheseTable a b) where

209 }

210 }

210

211

212

212−type instance FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)

213+type instance FromExprs (TheseTable _context a b) =

214+ These (FromExprs a) (FromExprs b)

213

215

214

216

215−instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable exprs1 exprs2) =>

217+instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable Expr exprs1 exprs2) =>

216 ToExprs x (These a b)

218 ToExprs x (These a b)

217 where

219 where

218 fromResult =

220 fromResult =

@@ -223,81 +225,73 @@ instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable exprs1 exprs2) =>

223 bimap (toResult @exprs1) (toResult @exprs2)

225 bimap (toResult @exprs1) (toResult @exprs2)

224

226

225

227

226−toHereTag :: Tag "isJust" a -> Tag "hasHere" a

227−toHereTag Tag {..} = Tag {..}

228−

229−

230−toThereTag :: Tag "isJust" a -> Tag "hasThere" a

231−toThereTag Tag {..} = Tag {..}

232−

233−

234-- | Test if a 'TheseTable' was constructed with 'thisTable'.

228-- | Test if a 'TheseTable' was constructed with 'thisTable'.

235--

229--

236-- Corresponds to 'Data.These.Combinators.isThis'.

230-- Corresponds to 'Data.These.Combinators.isThis'.

237−isThisTable :: TheseTable a b -> Expr Bool

231+isThisTable :: TheseTable Expr a b -> Expr Bool

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

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

239

233

240

234

241-- | Test if a 'TheseTable' was constructed with 'thatTable'.

235-- | Test if a 'TheseTable' was constructed with 'thatTable'.

242--

236--

243-- Corresponds to 'Data.These.Combinators.isThat'.

237-- Corresponds to 'Data.These.Combinators.isThat'.

244−isThatTable :: TheseTable a b -> Expr Bool

238+isThatTable :: TheseTable Expr a b -> Expr Bool

245isThatTable a = not_ (hasHereTable a) &&. hasThereTable a

239isThatTable a = not_ (hasHereTable a) &&. hasThereTable a

246

240

247

241

248-- | Test if a 'TheseTable' was constructed with 'thoseTable'.

242-- | Test if a 'TheseTable' was constructed with 'thoseTable'.

249--

243--

250-- Corresponds to 'Data.These.Combinators.isThese'.

244-- Corresponds to 'Data.These.Combinators.isThese'.

251−isThoseTable :: TheseTable a b -> Expr Bool

245+isThoseTable :: TheseTable Expr a b -> Expr Bool

252isThoseTable a = hasHereTable a &&. hasThereTable a

246isThoseTable a = hasHereTable a &&. hasThereTable a

253

247

254

248

255-- | Test if the @a@ side of @TheseTable a b@ is present.

249-- | Test if the @a@ side of @TheseTable a b@ is present.

256--

250--

257-- Corresponds to 'Data.These.Combinators.hasHere'.

251-- Corresponds to 'Data.These.Combinators.hasHere'.

258−hasHereTable :: TheseTable a b -> Expr Bool

252+hasHereTable :: TheseTable Expr a b -> Expr Bool

259hasHereTable TheseTable {here} = isJustTable here

253hasHereTable TheseTable {here} = isJustTable here

260

254

261

255

262-- | Test if the @b@ table of @TheseTable a b@ is present.

256-- | Test if the @b@ table of @TheseTable a b@ is present.

263--

257--

264-- Corresponds to 'Data.These.Combinators.hasThere'.

258-- Corresponds to 'Data.These.Combinators.hasThere'.

265−hasThereTable :: TheseTable a b -> Expr Bool

259+hasThereTable :: TheseTable Expr a b -> Expr Bool

266hasThereTable TheseTable {there} = isJustTable there

260hasThereTable TheseTable {there} = isJustTable there

267

261

268

262

269-- | Attempt to project out the @a@ table of a @TheseTable a b@.

263-- | Attempt to project out the @a@ table of a @TheseTable a b@.

270--

264--

271-- Corresponds to 'Data.These.Combinators.justHere'.

265-- Corresponds to 'Data.These.Combinators.justHere'.

272−justHereTable :: TheseTable a b -> MaybeTable a

266+justHereTable :: TheseTable context a b -> MaybeTable context a

273justHereTable = here

267justHereTable = here

274

268

275

269

276-- | Attempt to project out the @b@ table of a @TheseTable a b@.

270-- | Attempt to project out the @b@ table of a @TheseTable a b@.

277--

271--

278-- Corresponds to 'Data.These.Combinators.justThere'.

272-- Corresponds to 'Data.These.Combinators.justThere'.

279−justThereTable :: TheseTable a b -> MaybeTable b

273+justThereTable :: TheseTable context a b -> MaybeTable context b

280justThereTable = there

274justThereTable = there

281

275

282

276

283-- | Construct a @TheseTable@. Corresponds to 'This'.

277-- | Construct a @TheseTable@. Corresponds to 'This'.

284−thisTable :: Table Expr b => a -> TheseTable a b

278+thisTable :: Table Expr b => a -> TheseTable Expr a b

285thisTable a = TheseTable (justTable a) nothingTable

279thisTable a = TheseTable (justTable a) nothingTable

286

280

287

281

288-- | Construct a @TheseTable@. Corresponds to 'That'.

282-- | Construct a @TheseTable@. Corresponds to 'That'.

289−thatTable :: Table Expr a => b -> TheseTable a b

283+thatTable :: Table Expr a => b -> TheseTable Expr a b

290thatTable b = TheseTable nothingTable (justTable b)

284thatTable b = TheseTable nothingTable (justTable b)

291

285

292

286

293-- | Construct a @TheseTable@. Corresponds to 'These'.

287-- | Construct a @TheseTable@. Corresponds to 'These'.

294−thoseTable :: a -> b -> TheseTable a b

288+thoseTable :: a -> b -> TheseTable Expr a b

295thoseTable a b = TheseTable (justTable a) (justTable b)

289thoseTable a b = TheseTable (justTable a) (justTable b)

296

290

297

291

298-- | Pattern match on a 'TheseTable'. Corresponds to 'these'.

292-- | Pattern match on a 'TheseTable'. Corresponds to 'these'.

299theseTable :: Table Expr c

293theseTable :: Table Expr c

300− => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable a b -> c

294+ => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable Expr a b -> c

301theseTable f g h TheseTable {here, there} =

295theseTable f g h TheseTable {here, there} =

302 maybeTable

296 maybeTable

303 (maybeTable undefined f here)

297 (maybeTable undefined f here)

@@ -305,6 +299,19 @@ theseTable f g h TheseTable {here, there} =

305 there

299 there

306

300

307

301

302+-- | Lift a pair of aggregating functions to operate on an 'TheseTable'.

303+-- @thisTable@s, @thatTable@s and @thoseTable@s are grouped separately.

304+aggregateTheseTable :: ()

305+ => (exprs -> aggregates)

306+ -> (exprs' -> aggregates')

307+ -> TheseTable Expr exprs exprs'

308+ -> TheseTable Aggregate aggregates aggregates'

309+aggregateTheseTable f g (TheseTable here there) = TheseTable

310+ { here = aggregateMaybeTable f here

311+ , there = aggregateMaybeTable g there

312+ }

313+

314+

308-- | Construct a 'TheseTable' in the 'Name' context. This can be useful if you

315-- | Construct a 'TheseTable' in the 'Name' context. This can be useful if you

309-- have a 'TheseTable' that you are storing in a table and need to construct a

316-- have a 'TheseTable' that you are storing in a table and need to construct a

310-- 'TableSchema'.

317-- 'TableSchema'.

@@ -317,7 +324,7 @@ nameTheseTable :: ()

317 -- ^ Names of the columns in the @a@ table.

324 -- ^ Names of the columns in the @a@ table.

318 -> b

325 -> b

319 -- ^ Names of the columns in the @b@ table.

326 -- ^ Names of the columns in the @b@ table.

320− -> TheseTable a b

327+ -> TheseTable Name a b

321nameTheseTable here there a b =

328nameTheseTable here there a b =

322 TheseTable

329 TheseTable

323 { here = nameMaybeTable here a

330 { here = nameMaybeTable here a