707a36a · rel8 · git.iko.soy

git.iko.soy/rel8

Add context parameter to *Table types (#101)

* Add context parameter to {Either,Maybe,These}Table This allows to get rid of all the `Tag` nonsense and to further simplify the `Nullifiable` nonsense. Arguably we should have done it like this in the first place, as it brings a lot of nonsense that was hiding inside `Tag` out into the open. It was nice to not have an extra redundant-seeming type parameter (because the `a` already has a `Context`), but it isn't actually redundant. The proposed solution to the `Projection` problem will definitely need this extra `context` parameter and there are no tricks with `Tag` we can do to get around that. * Also add context parameter to ListTable and NonEmptyTable In this case, the extra `Context` parameter is actually 100% redundant as things stand, but it opens up the possibility of a `Prelude.Functor` instance for for `ListTable` further down the line, and at least remains "consistent" with the other `*Table` types.

commit707a36a6a75b34f84d7403ce9cc4fcd4479dedd0 authorShane <shane.obrien@circuithub.com> dateMon 5 Jul 2021, 02:25 (5 years ago) parent716d9f1

21 files changed+392−469

compare with master

unifiedsplit

rel8.cabal−1

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

162162 Rel8.Table.Recontextualize

163163 Rel8.Table.Rel8able

164164 Rel8.Table.Serialize

165− Rel8.Table.Tag

166165 Rel8.Table.These

167166 Rel8.Table.Undefined

168167 Rel8.Table.Unreify

src/Rel8.hs+3

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

5959 , optional

6060 , catMaybeTable

6161 , traverseMaybeTable

62+ , aggregateMaybeTable

6263 , nameMaybeTable

6364

6465 -- ** @EitherTable@

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

6869 , keepLeftTable

6970 , keepRightTable

7071 , bitraverseEitherTable

72+ , aggregateEitherTable

7173 , nameEitherTable

7274

7375 -- ** @TheseTable@

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

8385 , keepThatTable, loseThatTable

8486 , keepThoseTable, loseThoseTable

8587 , bitraverseTheseTable

88+ , aggregateTheseTable

8689 , nameTheseTable

8790

8891 -- ** @ListTable@

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

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

33{-# language LambdaCase #-}

44{-# language MultiParamTypeClasses #-}

55{-# language StandaloneKindSignatures #-}

6−{-# language TypeFamilies #-}

6+{-# language TypeFamilyDependencies #-}

77{-# language UndecidableInstances #-}

99module Rel8.Column.Either

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

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

4040-- 'Result' context.

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

42−type family HEither context where

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

4343 HEither (Reify context) = AHEither context

44− HEither Aggregate = EitherTable

45− HEither Expr = EitherTable

46− HEither Name = EitherTable

44+ HEither Aggregate = EitherTable Aggregate

45+ HEither Expr = EitherTable Expr

46+ HEither Name = EitherTable Name

4747 HEither Result = Either

4848

4949

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

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

33{-# language LambdaCase #-}

44{-# language MultiParamTypeClasses #-}

55{-# language StandaloneKindSignatures #-}

6−{-# language TypeFamilies #-}

6+{-# language TypeFamilyDependencies #-}

77{-# language UndecidableInstances #-}

99module Rel8.Column.List

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

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

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

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

41−type family HList context where

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

4242 HList (Reify context) = AHList context

43− HList Aggregate = ListTable

44− HList Expr = ListTable

45− HList Name = ListTable

43+ HList Aggregate = ListTable Aggregate

44+ HList Expr = ListTable Expr

45+ HList Name = ListTable Name

4646 HList Result = []

4747

4848

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

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

44{-# language LambdaCase #-}

55{-# language MultiParamTypeClasses #-}

66{-# language StandaloneKindSignatures #-}

7−{-# language TypeFamilies #-}

7+{-# language TypeFamilyDependencies #-}

88{-# language UndecidableInstances #-}

1010module Rel8.Column.Maybe

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

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

3939-- context.

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

41−type family HMaybe context where

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

4242 HMaybe (Reify context) = AHMaybe context

43− HMaybe Aggregate = MaybeTable

44− HMaybe Expr = MaybeTable

45− HMaybe Name = MaybeTable

43+ HMaybe Aggregate = MaybeTable Aggregate

44+ HMaybe Expr = MaybeTable Expr

45+ HMaybe Name = MaybeTable Name

4646 HMaybe Result = Maybe

4747

4848

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

7070instance

7171 ( Reifiable context, Reifiable context'

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

73− ) =>

74− Recontextualize

73+ )

74+ => Recontextualize

7575 (Reify context)

7676 (Reify context')

7777 (AHMaybe context a)

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

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

33{-# language LambdaCase #-}

44{-# language MultiParamTypeClasses #-}

55{-# language StandaloneKindSignatures #-}

6−{-# language TypeFamilies #-}

6+{-# language TypeFamilyDependencies #-}

77{-# language UndecidableInstances #-}

99module Rel8.Column.NonEmpty

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

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

4141-- 'Result' context.

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

43−type family HNonEmpty context where

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

4444 HNonEmpty (Reify context) = AHNonEmpty context

45− HNonEmpty Aggregate = NonEmptyTable

46− HNonEmpty Expr = NonEmptyTable

47− HNonEmpty Name = NonEmptyTable

45+ HNonEmpty Aggregate = NonEmptyTable Aggregate

46+ HNonEmpty Expr = NonEmptyTable Expr

47+ HNonEmpty Name = NonEmptyTable Name

4848 HNonEmpty Result = NonEmpty

4949

5050

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

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

44{-# language LambdaCase #-}

55{-# language MultiParamTypeClasses #-}

66{-# language StandaloneKindSignatures #-}

7−{-# language TypeFamilies #-}

7+{-# language TypeFamilyDependencies #-}

88{-# language UndecidableInstances #-}

1010module Rel8.Column.These

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

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

4444-- 'Result' context.

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

46−type family HThese context where

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

4747 HThese (Reify context) = AHThese context

48− HThese Aggregate = TheseTable

49− HThese Expr = TheseTable

50− HThese Name = TheseTable

48+ HThese Aggregate = TheseTable Aggregate

49+ HThese Expr = TheseTable Expr

50+ HThese Name = TheseTable Name

5151 HThese Result = These

5252

5353

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

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

5959 , KnownAlgebra, algebraSing

6060 )

6161import qualified Rel8.Kind.Algebra as K

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

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

6363import Rel8.Schema.HTable ( HTable )

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

6565import qualified Rel8.Schema.Kind as K

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

349349 @(Eval (rep (Reify Aggregate)))

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

351351 (\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)

353353 (HType (Reify (A (groupByExpr tag))))

354354 where

355355 f =

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

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

1111import Prelude

1212

1313-- rel8

14+import Rel8.Expr ( Expr )

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

1516import Rel8.Query ( Query )

1617import Rel8.Query.Filter ( where_ )

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

2324

2425

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

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

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

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

2829 where_ $ isLeftTable e

2930 pure a

3031

3132

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

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

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

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

3536 where_ $ isRightTable e

3637 pure b

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

5556bitraverseEitherTable :: ()

5657 => (a -> Query c)

5758 -> (b -> Query d)

58− -> EitherTable a b

59− -> Query (EitherTable c d)

59+ -> EitherTable Expr a b

60+ -> Query (EitherTable Expr c d)

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

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

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

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

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

4646--

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

4848-- @Control.Applicative@.

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

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

5050many =

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

5252 optional .

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

6262--

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

6464-- @Control.Applicative@.

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

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

6666some =

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

6868 aggregate .

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

8383-- element of the given @ListTable@.

8484--

8585-- @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

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

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

8989

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

9292-- element of the given @NonEmptyTable@.

9393--

9494-- @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

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

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

9898

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

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

1+{-# language GADTs #-}

13module Rel8.Query.Maybe

24 ( optional

35 , catMaybeTable

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

1214import qualified Opaleye.Internal.MaybeFields as Opaleye

1315

1416-- rel8

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

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

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

1720import Rel8.Query ( Query )

1821import Rel8.Query.Filter ( where_ )

1922import Rel8.Query.Opaleye ( mapOpaleye )

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

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

2224

2325

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

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

2628--

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

2830-- JOIN@s.

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

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

3032optional =

3133 mapOpaleye $

3234 Opaleye.optionalInternal $

33− MaybeTable . fromExpr . fromPrimExpr . fromColumn

35+ MaybeTable . E . fromPrimExpr . fromColumn

3436

3537

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

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

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

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

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

41−catMaybeTable :: MaybeTable a -> Query a

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

4244catMaybeTable ma@(MaybeTable _ a) = do

4345 where_ $ isJustTable ma

4446 pure a

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

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

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

5557-- back.

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

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

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

59− where_ $ expr output ==. expr input

60− pure $ MaybeTable input b

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

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

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

61+ where_ $ output ==. input

62+ pure $ MaybeTable (E input) b

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

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

11{-# language FlexibleContexts #-}

2+{-# language GADTs #-}

34module Rel8.Query.These

45 ( alignBy

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

2122import qualified Opaleye.Internal.Tag as Opaleye

2223

2324-- rel8

24−import Rel8.Expr ( Expr )

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

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

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

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

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

3233import Rel8.Query.Opaleye ( zipOpaleyeWith )

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

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

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

3636import Rel8.Table.These

3737 ( TheseTable( TheseTable, here, there )

3838 , hasHereTable, hasThereTable

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

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

4545alignBy :: ()

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

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

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

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

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

5050 where

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

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

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

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

53+ MaybeTable (E hasHere) a = ma

54+ MaybeTable (E hasThere) b = mb

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

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

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

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

6262 on = toPrimExpr $ condition a b

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

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

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

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

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

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

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

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

6969

7070

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)

7372keepHereTable = loseThatTable

7473

7574

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

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

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

7876loseHereTable = keepThatTable

7977

8078

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

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

8280keepThereTable = loseThisTable

8381

8482

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

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

8684loseThereTable = keepThisTable

8785

8886

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

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

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

9189 where_ $ isThisTable t

9290 pure a

9391

9492

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

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

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

9795 where_ $ not_ $ isThisTable t

9896 pure (ma, b)

9997

10098

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

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

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

103101 where_ $ isThatTable t

104102 pure b

105103

106104

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

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

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

109107 where_ $ not_ $ isThatTable t

110108 pure (a, mb)

111109

112110

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

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

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

115113 where_ $ isThoseTable t

116114 pure (a, b)

117115

118116

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

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

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

121119 where_ $ not_ $ isThoseTable t

122− pure $ EitherTable result a b

120+ pure $ EitherTable (E tag) a b

123121 where

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

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

126123

127124

128125bitraverseTheseTable :: ()

129126 => (a -> Query c)

130127 -> (b -> Query d)

131− -> TheseTable a b

132− -> Query (TheseTable c d)

128+ -> TheseTable Expr a b

129+ -> Query (TheseTable Expr c d)

133130bitraverseTheseTable f g t = do

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

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

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

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

11{-# language DataKinds #-}

22{-# language FlexibleContexts #-}

3−{-# language FlexibleInstances #-}

4−{-# language InstanceSigs #-}

5−{-# language MultiParamTypeClasses #-}

3+{-# language GADTs #-}

64{-# language NamedFieldPuns #-}

7−{-# language ScopedTypeVariables #-}

85{-# language StandaloneKindSignatures #-}

9−{-# language TypeFamilies #-}

106

117module Rel8.Schema.Context.Nullify

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

13− , runTag, unnull

8+ ( Nullifiable, nullifier, unnullifier

9+ , guardExpr, snullify

1410 )

1511where

1612

1713-- base

1814import Data.Kind ( Constraint )

19−import GHC.TypeLits ( KnownSymbol )

15+import Data.Monoid ( getFirst )

2016import Prelude hiding ( null )

2117

2218-- opaleye

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

2521-- rel8

2622import Rel8.Aggregate

2723 ( Aggregate( Aggregate ), Col( A )

28− , mapInputs

29− , unsafeMakeAggregate

24+ , foldInputs, mapInputs

3025 )

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

3227import Rel8.Expr.Bool ( boolExpr )

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

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

35−import Rel8.Schema.Context ( Interpretation )

3630import qualified Rel8.Schema.Kind as K

3731import 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 ) )

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

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

35+import Rel8.Type ( DBType )

4136

4237

4338type Nullifiable :: K.Context -> Constraint

44−class Interpretation context => Nullifiable context where

45− encodeTag :: Taggable a

46− => Tag label a

39+class Nullifiable context where

40+ nullifier :: Sql DBType tag

41+ => Col context ('Spec tag)

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

43+ -> SSpec ('Spec a)

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

5946

6047 unnullifier :: ()

61− => SSpec ('Spec x)

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

63− -> Col context ('Spec x)

48+ => SSpec ('Spec a)

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

50+ -> Col context ('Spec a)

6451

6552

6653instance 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)) =

7355 A $

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

56+ mapInputs (toPrimExpr . run . fromPrimExpr) $

7557 Aggregate $

76− runTag nullity condition <$> a

58+ run <$> a

7759 where

78− condition = test expr

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

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

7962

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

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

82−

83− {-# INLINABLE encodeTag #-}

84− {-# INLINABLE decodeTag #-}

85− {-# INLINABLE nullifier #-}

86− {-# INLINABLE unnullifier #-}

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

8765

8866

8967instance Nullifiable Expr where

90− encodeTag Tag {expr} = E expr

91− decodeTag (E a) = fromExpr a

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

93− E $ runTag nullity (test expr) a

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

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

69+ E $ guardExpr condition (snullify nullity a)

70+ where

71+ condition = isNonNull tag

9572

96− {-# INLINABLE encodeTag #-}

97− {-# INLINABLE decodeTag #-}

98− {-# INLINABLE nullifier #-}

99− {-# INLINABLE unnullifier #-}

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

10074

10175

10276instance Nullifiable Name where

103− encodeTag Tag {name} = N name

104− decodeTag (N name) = fromName name

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

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

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

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

10784

108− {-# INLINABLE encodeTag #-}

109− {-# INLINABLE decodeTag #-}

110− {-# INLINABLE nullifier #-}

111− {-# INLINABLE unnullifier #-}

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

11286

11387

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

115−runTag nullity tag a = case nullity of

116− Null -> boolExpr null a tag

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

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

89+guardExpr condition a = boolExpr null a condition

11890 where

11991 null = fromPrimExpr $ Opaleye.ConstExpr Opaleye.NullLit

12092

12193

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

123−unnull nullity a = case nullity of

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+

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

101+sunnullify nullity a = case nullity of

124102 Null -> a

125103 NotNull -> unsafeUnnullify a

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

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

4141 hdicts = HLabel (hdicts @table)

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

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

44+ {-# INLINABLE hspecs #-}

4445

4546

4647hlabel :: 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 ->

6161-- items:

6262--

6363-- @

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

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

6565-- ordersWithItems = do

6666-- order <- each orderSchema

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

6868-- return (order, items)

6969-- @

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

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

7171listAgg (toColumns -> exprs) = fromColumns $

7272 hvectorize

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

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

7575

7676

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

7979nonEmptyAgg (toColumns -> exprs) = fromColumns $

8080 hvectorize

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

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

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

33{-# language DerivingStrategies #-}

44{-# language FlexibleContexts #-}

55{-# language FlexibleInstances #-}

6−{-# language LambdaCase #-}

76{-# language MultiParamTypeClasses #-}

87{-# language NamedFieldPuns #-}

98{-# language ScopedTypeVariables #-}

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

1817 ( EitherTable(..)

1918 , eitherTable, leftTable, rightTable

2019 , isLeftTable, isRightTable

20+ , aggregateEitherTable

2121 , nameEitherTable

2222 )

2323where

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

3030import Prelude hiding ( undefined )

3131

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

3436import Rel8.Expr.Serialize ( litExpr )

35−import Rel8.Schema.Context.Nullify

36− ( Nullifiable

37− , encodeTag, decodeTag

38− , nullifier, unnullifier

39− )

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

4038import Rel8.Schema.Dict ( Dict( Dict ) )

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

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

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

4442import 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 ) )

4646import Rel8.Table

4747 ( Table, Columns, Context, fromColumns, toColumns

4848 , reify, unreify

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

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

5353import Rel8.Table.Recontextualize ( Recontextualize )

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

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

5655import Rel8.Table.Undefined ( undefined )

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

5857

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

6766--

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

6968-- adapted to work with Rel8.

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

71−data EitherTable a b = EitherTable

72− { tag :: Tag "isRight" EitherTag

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

70+data EitherTable context a b = EitherTable

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

7372 , left :: a

7473 , right :: b

7574 }

7675 deriving stock Functor

7776

7877

79−instance Bifunctor EitherTable where

78+instance Bifunctor (EitherTable context) where

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

8180

8281

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

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

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

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

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

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

8685

8786

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

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

8988 pure = rightTable

9089 (<*>) = (<.>)

9190

9291

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

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

95− EitherTable tag' l2 b ->

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

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

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

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

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

9796

9897

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

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

10099 (>>=) = (>>-)

101100

102101

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

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

105106

106107

107108instance

108109 ( Table context a, Table context b

109− , Nullifiable context

110+ , Nullifiable context, context ~ context'

110111 )

111− => Table context (EitherTable a b)

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

112113 where

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

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

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

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

115116

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

117− { htag

118+ { htag = hlabel (HType tag)

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

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

120121 }

121− where

122− htag = hlabel $ HType $ encodeTag tag

123122

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

125− { tag

124+ { tag = unHIdentity (hunlabel htag)

126125 , left =

127126 fromColumns $

128127 runIdentity $

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

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

130129 hunlabel

131130 hleft

132131 , right =

133132 fromColumns $

134133 runIdentity $

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

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

136135 hunlabel

137136 hright

138137 }

139− where

140− tag = decodeTag $ unHIdentity $ hunlabel htag

141138

142139 reify = liftA2 bimap reify reify

143140 unreify = liftA2 bimap unreify unreify

144141

145142

146143instance

147− ( Nullifiable from, Nullifiable to

144+ ( Nullifiable from, from ~ from'

145+ , Nullifiable to, to ~ to'

148146 , Recontextualize from to a1 b1

149147 , Recontextualize from to a2 b2

150148 )

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

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

152150

153151

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

155155 eqTable = HEitherTable

156156 { htag = hlabel (HType Dict)

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

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

159159 }

160160

161161

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

163165 ordTable = HEitherTable

164166 { htag = hlabel (HType Dict)

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

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

167169 }

168170

169171

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)

171174

172175

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

174177 ToExprs x (Either a b)

175178 where

176179 fromResult =

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

182185

183186

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

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

186−isLeftTable = isLeft . expr . tag

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

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

187190

188191

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

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

191−isRightTable = isRight . expr . tag

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

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

192195

193196

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

195198-- 'leftTable' and 'rightTable'.

196199eitherTable :: Table Expr c

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

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

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

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

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

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

200203

201204

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

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

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

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

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

205208

206209

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

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

209−rightTable = rightTableWith undefined

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

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

210213

211214

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

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

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

220+ -> EitherTable Expr exprs exprs'

221+ -> EitherTable Aggregate aggregates aggregates'

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

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

214224

215225

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

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

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

225235 -> b

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

227− -> EitherTable a b

228−nameEitherTable = EitherTable . fromName

237+ -> EitherTable Name a b

238+nameEitherTable = EitherTable . N

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

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

1+{-# language DataKinds #-}

12{-# language FlexibleContexts #-}

23{-# language FlexibleInstances #-}

34{-# language MultiParamTypeClasses #-}

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

2627import Rel8.Schema.Dict ( Dict( Dict ) )

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

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

30+import qualified Rel8.Schema.Kind as K

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

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

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

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

4749

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

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

50−type ListTable :: Type -> Type

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

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

53+newtype ListTable context a =

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

5255

5356

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

55− Table context (ListTable a)

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

58+ Table context' (ListTable context a)

5659 where

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

58− type Context (ListTable a) = Context a

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

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

5962

6063 fromColumns = ListTable

6164 toColumns (ListTable a) = a

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

6568

6669

6770instance

68− ( Unreifies from a, Unreifies to b

71+ ( Unreifies from a, from ~ from'

72+ , Unreifies to b, to ~ to'

6973 , Recontextualize from to a b

7074 )

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

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

7276

7377

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

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

7579 eqTable =

7680 hvectorize

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

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

8084 (Identity (eqTable @a))

8185

8286

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

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

8488 ordTable =

8589 hvectorize

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

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

8993 (Identity (ordTable @a))

9094

9195

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

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

9397

9498

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

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

100+ ToExprs (ListTable context exprs) [a]

101+ where

96102 fromResult = fmap (fromResult @exprs) . fromColumns

97103 toResult = toColumns . fmap (toResult @exprs)

98104

99105

100−instance AltTable ListTable where

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

101107 (<|>:) = (<>)

102108

103109

104−instance AlternativeTable ListTable where

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

105111 emptyTable = mempty

106112

107113

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

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

115+ Semigroup (ListTable context a)

116+ where

109117 ListTable as <> ListTable bs = ListTable $

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

111119

112120

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

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

122+ Monoid (ListTable context a)

123+ where

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

115125

116126

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

119129listTable =

120130 ListTable .

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

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

128138nameListTable

129139 :: Table Name a

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

131− -> ListTable a

141+ -> ListTable Name a

132142nameListTable =

133143 ListTable .

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

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

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

33{-# language DerivingStrategies #-}

44{-# language FlexibleContexts #-}

55{-# language FlexibleInstances #-}

6−{-# language LambdaCase #-}

76{-# language MultiParamTypeClasses #-}

87{-# language NamedFieldPuns #-}

98{-# language ScopedTypeVariables #-}

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

1716 , maybeTable, nothingTable, justTable

1817 , isNothingTable, isJustTable

1918 , ($?)

19+ , aggregateMaybeTable

2020 , nameMaybeTable

2121 )

2222where

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

2727import Prelude hiding ( null, undefined )

2828

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

3133import Rel8.Expr.Bool ( boolExpr )

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

33−import Rel8.Schema.Context.Nullify

34− ( Nullifiable

35− , encodeTag, decodeTag

36− , nullifier, unnullifier

37− )

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

3836import Rel8.Schema.Dict ( Dict( Dict ) )

37+import qualified Rel8.Schema.Kind as K

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

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

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

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

43−import Rel8.Schema.Name ( Name )

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

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

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

4545import Rel8.Table

4646 ( Table, Columns, Context, fromColumns, toColumns

4747 , reify, unreify

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

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

5656import Rel8.Table.Recontextualize ( Recontextualize )

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

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

5958import Rel8.Table.Undefined ( undefined )

6059import Rel8.Type ( DBType )

6160import Rel8.Type.Tag ( MaybeTag )

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

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

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

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

76−type MaybeTable :: Type -> Type

77−data MaybeTable a = MaybeTable

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

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

76+data MaybeTable context a = MaybeTable

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

7978 , just :: a

8079 }

8180 deriving stock Functor

8281

8382

84−instance Apply MaybeTable where

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

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

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

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

8686

8787

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

8989-- 'Rel8.traverseMaybeTable'.

90−instance Applicative MaybeTable where

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

9191 (<*>) = (<.>)

9292 pure = justTable

9393

9494

95−instance Bind MaybeTable where

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

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

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

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

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

9898

9999

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

101−instance Monad MaybeTable where

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

102102 (>>=) = (>>-)

103103

104104

105−instance AltTable MaybeTable 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

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

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

114107

115108

116−instance AlternativeTable MaybeTable where

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

117110 emptyTable = nothingTable

118111

119112

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

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

122117

123118

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

125122 mempty = nothingTable

126123

127124

128−instance

129− ( Table context a

130− , Nullifiable context

131− )

132− => Table context (MaybeTable a)

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

126+ Table context' (MaybeTable context a)

133127 where

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

135− type Context (MaybeTable a) = Context a

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

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

136130

137131 toColumns MaybeTable {tag, just} = HMaybeTable

138− { htag

132+ { htag = hlabel (HIdentity tag)

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

140134 }

141− where

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

143135

144136 fromColumns HMaybeTable {htag, hjust} = MaybeTable

145− { tag

137+ { tag = unHIdentity (hunlabel htag)

146138 , just = fromColumns $ runIdentity $

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

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

148140 }

149− where

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

151141

152142 reify = fmap fmap reify

153143 unreify = fmap fmap unreify

154144

155145

156146instance

157− ( Nullifiable from

158− , Nullifiable to

147+ ( Nullifiable from, from ~ from'

148+ , Nullifiable to, to ~ to'

159149 , Recontextualize from to a b

160150 )

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

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

162152

163153

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

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

165155 eqTable = HMaybeTable

166156 { htag = hlabel (HType Dict)

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

168158 }

169159

170160

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

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

172162 ordTable = HMaybeTable

173163 { htag = hlabel (HType Dict)

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

175165 }

176166

177167

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

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

179169

180170

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

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

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

173+ where

182174 fromResult = fmap (fromResult @exprs) . fromColumns

183175 toResult = toColumns . fmap (toResult @exprs)

184176

185177

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

187−isNothingTable :: MaybeTable a -> Expr Bool

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

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

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

189181

190182

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

192−isJustTable :: MaybeTable a -> Expr Bool

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

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

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

194186

195187

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

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

199191{-# INLINABLE maybeTable #-}

200192

201193

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

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

204−nothingTable = MaybeTable (fromExpr null) undefined

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

196+nothingTable = MaybeTable (E null) undefined

205197

206198

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

208200-- 'pure'.

209−justTable :: a -> MaybeTable a

210−justTable = MaybeTable (fromExpr mempty)

201+justTable :: a -> MaybeTable Expr a

202+justTable = MaybeTable (E mempty)

211203

212204

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

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

215207-- @null@.

216208($?) :: 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)

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

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

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

221213infixl 4 $?

222214

223215

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+

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

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

226228-- 'TableSchema'.

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

230232 -- 'nothingTable'.

231233 -> a

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

233− -> MaybeTable a

234−nameMaybeTable = MaybeTable . fromName

235+ -> MaybeTable Name a

236+nameMaybeTable = MaybeTable . N

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

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

1+{-# language DataKinds #-}

12{-# language FlexibleContexts #-}

23{-# language FlexibleInstances #-}

34{-# language MultiParamTypeClasses #-}

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

2728import Rel8.Schema.Dict ( Dict( Dict ) )

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

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

31+import qualified Rel8.Schema.Kind as K

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

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

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

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

4547

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

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

48−type NonEmptyTable :: Type -> Type

49−newtype NonEmptyTable a =

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

51+newtype NonEmptyTable context a =

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

5153

5254

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

54− Table context (NonEmptyTable a)

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

56+ Table context' (NonEmptyTable context a)

5557 where

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

57− type Context (NonEmptyTable a) = Context a

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

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

5860

5961 fromColumns = NonEmptyTable

6062 toColumns (NonEmptyTable a) = a

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

6466

6567

6668instance

67− ( Unreifies from a, Unreifies to b

69+ ( Unreifies from a, from ~ from'

70+ , Unreifies to b, to ~ to'

6871 , Recontextualize from to a b

6972 )

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

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

7174

7275

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

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

77+ EqTable (NonEmptyTable context a)

78+ where

7479 eqTable =

7580 hvectorize

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

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

7984 (Identity (eqTable @a))

8085

8186

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

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

88+ OrdTable (NonEmptyTable context a)

89+ where

8390 ordTable =

8491 hvectorize

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

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

8895 (Identity (ordTable @a))

8996

9097

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

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

9299

93100

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

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

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

95103 where

96104 fromResult = fmap (fromResult @exprs) . fromColumns

97105 toResult = toColumns . fmap (toResult @exprs)

98106

99107

100−instance AltTable NonEmptyTable where

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

101109 (<|>:) = (<>)

102110

103111

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

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

113+ Semigroup (NonEmptyTable context a)

114+ where

105115 NonEmptyTable as <> NonEmptyTable bs = NonEmptyTable $

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

107117

108118

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

111121nonEmptyTable =

112122 NonEmptyTable .

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

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

120130nameNonEmptyTable

121131 :: Table Name a

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

123− -> NonEmptyTable a

133+ -> NonEmptyTable Name a

124134nameNonEmptyTable =

125135 NonEmptyTable .

126136 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 @@

55{-# language FlexibleInstances #-}

66{-# language MultiParamTypeClasses #-}

77{-# language NamedFieldPuns #-}

8−{-# language RecordWildCards #-}

98{-# language ScopedTypeVariables #-}

109{-# language StandaloneKindSignatures #-}

1110{-# language TupleSections #-}

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

2120 , isThisTable, isThatTable, isThoseTable

2221 , hasHereTable, hasThereTable

2322 , justHereTable, justThereTable

23+ , aggregateTheseTable

2424 , nameTheseTable

2525 )

2626where

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

3333import Prelude hiding ( undefined )

3434

3535-- rel8

36+import Rel8.Aggregate ( Aggregate )

3637import Rel8.Expr ( Expr )

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

3839import Rel8.Expr.Null ( isNonNull )

39−import Rel8.Schema.Context.Nullify

40− ( Nullifiable

41− , encodeTag, decodeTag

42− , nullifier, unnullifier

43− )

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

4441import Rel8.Schema.Dict ( Dict( Dict ) )

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

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

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

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

46+import qualified Rel8.Schema.Kind as K

4947import Rel8.Schema.Name ( Name )

5048import Rel8.Table

5149 ( Table, Columns, Context, fromColumns, toColumns

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

5654 ( MaybeTable(..)

5755 , maybeTable, justTable, nothingTable

5856 , isJustTable

57+ , aggregateMaybeTable

5958 , nameMaybeTable

6059 )

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

6261import Rel8.Table.Recontextualize ( Recontextualize )

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

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

6563import Rel8.Table.Undefined ( undefined )

6664import Rel8.Type.Tag ( MaybeTag )

6765

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

8078--

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

8280-- adapted to work with Rel8.

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

84−data TheseTable a b = TheseTable

85− { here :: MaybeTable a

86− , there :: MaybeTable b

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

82+data TheseTable context a b = TheseTable

83+ { here :: MaybeTable context a

84+ , there :: MaybeTable context b

8785 }

8886 deriving stock Functor

8987

9088

91−instance Bifunctor TheseTable where

89+instance Bifunctor (TheseTable context) where

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

9391

9492

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

9696 fs <.> as = TheseTable

9797 { here = here fs <> here as

9898 , there = there fs <.> there as

9999 }

100100

101101

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

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

103+ Applicative (TheseTable context a)

103104 where

104105 pure = thatTable

105106 (<*>) = (<.>)

106107

107108

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

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

110113 mtb -> TheseTable

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

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

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

117120

118121

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

120125 (>>=) = (>>-)

121126

122127

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

124− Semigroup (TheseTable a b)

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

129+ Semigroup (TheseTable context a b)

125130 where

126131 a <> b = TheseTable

127132 { here = here a <> here b

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

131136

132137instance

133138 ( Table context a, Table context b

134− , Nullifiable context

139+ , Nullifiable context, context ~ context'

135140 )

136− => Table context (TheseTable a b)

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

137142 where

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

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

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

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

140145

141146 toColumns TheseTable {here, there} = HTheseTable

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

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

143148 , hhere =

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

145150 just here

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

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

147152 , hthere =

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

149154 just there

150155 }

151156

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

153− { here =

154− let

155− tag = decodeTag $ unHIdentity $ hunlabel hhereTag

156− in

157− MaybeTable

158− { tag

159− , just =

160− fromColumns $

161− runIdentity $

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

163− hunlabel

164− hhere

165− }

166− , there =

167− let

168− tag = decodeTag $ unHIdentity $ hunlabel hthereTag

169− in

170− MaybeTable

171− { tag

172− , just =

173− fromColumns $

174− runIdentity $

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

176− hunlabel

177− hthere

178− }

158+ { here = MaybeTable

159+ { tag = unHIdentity $ hunlabel hhereTag

160+ , just =

161+ fromColumns $

162+ runIdentity $

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

164+ hunlabel

165+ hhere

166+ }

167+ , there = MaybeTable

168+ { tag = unHIdentity $ hunlabel hthereTag

169+ , just =

170+ fromColumns $

171+ runIdentity $

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

173+ hunlabel

174+ hthere

175+ }

179176 }

180177

181−

182178 reify = liftA2 bimap reify reify

183179 unreify = liftA2 bimap unreify unreify

184180

185181

186182instance

187− ( Nullifiable from, Nullifiable to

183+ ( Nullifiable from, from ~ from'

184+ , Nullifiable to, to ~ to'

188185 , Recontextualize from to a1 b1

189186 , Recontextualize from to a2 b2

190187 )

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

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

192189

193190

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

195194 eqTable = HTheseTable

196195 { hhereTag = hlabel (HType Dict)

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

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

200199 }

201200

202201

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

204205 ordTable = HTheseTable

205206 { hhereTag = hlabel (HType Dict)

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

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

209210 }

210211

211212

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)

213215

214216

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

216218 ToExprs x (These a b)

217219 where

218220 fromResult =

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

223225 bimap (toResult @exprs1) (toResult @exprs2)

224226

225227

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−

234228-- | Test if a 'TheseTable' was constructed with 'thisTable'.

235229--

236230-- Corresponds to 'Data.These.Combinators.isThis'.

237−isThisTable :: TheseTable a b -> Expr Bool

231+isThisTable :: TheseTable Expr a b -> Expr Bool

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

239233

240234

241235-- | Test if a 'TheseTable' was constructed with 'thatTable'.

242236--

243237-- Corresponds to 'Data.These.Combinators.isThat'.

244−isThatTable :: TheseTable a b -> Expr Bool

238+isThatTable :: TheseTable Expr a b -> Expr Bool

245239isThatTable a = not_ (hasHereTable a) &&. hasThereTable a

246240

247241

248242-- | Test if a 'TheseTable' was constructed with 'thoseTable'.

249243--

250244-- Corresponds to 'Data.These.Combinators.isThese'.

251−isThoseTable :: TheseTable a b -> Expr Bool

245+isThoseTable :: TheseTable Expr a b -> Expr Bool

252246isThoseTable a = hasHereTable a &&. hasThereTable a

253247

254248

255249-- | Test if the @a@ side of @TheseTable a b@ is present.

256250--

257251-- Corresponds to 'Data.These.Combinators.hasHere'.

258−hasHereTable :: TheseTable a b -> Expr Bool

252+hasHereTable :: TheseTable Expr a b -> Expr Bool

259253hasHereTable TheseTable {here} = isJustTable here

260254

261255

262256-- | Test if the @b@ table of @TheseTable a b@ is present.

263257--

264258-- Corresponds to 'Data.These.Combinators.hasThere'.

265−hasThereTable :: TheseTable a b -> Expr Bool

259+hasThereTable :: TheseTable Expr a b -> Expr Bool

266260hasThereTable TheseTable {there} = isJustTable there

267261

268262

269263-- | Attempt to project out the @a@ table of a @TheseTable a b@.

270264--

271265-- Corresponds to 'Data.These.Combinators.justHere'.

272−justHereTable :: TheseTable a b -> MaybeTable a

266+justHereTable :: TheseTable context a b -> MaybeTable context a

273267justHereTable = here

274268

275269

276270-- | Attempt to project out the @b@ table of a @TheseTable a b@.

277271--

278272-- Corresponds to 'Data.These.Combinators.justThere'.

279−justThereTable :: TheseTable a b -> MaybeTable b

273+justThereTable :: TheseTable context a b -> MaybeTable context b

280274justThereTable = there

281275

282276

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

285279thisTable a = TheseTable (justTable a) nothingTable

286280

287281

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

290284thatTable b = TheseTable nothingTable (justTable b)

291285

292286

293287-- | Construct a @TheseTable@. Corresponds to 'These'.

294−thoseTable :: a -> b -> TheseTable a b

288+thoseTable :: a -> b -> TheseTable Expr a b

295289thoseTable a b = TheseTable (justTable a) (justTable b)

296290

297291

298292-- | Pattern match on a 'TheseTable'. Corresponds to 'these'.

299293theseTable :: 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

301295theseTable f g h TheseTable {here, there} =

302296 maybeTable

303297 (maybeTable undefined f here)

@@ -305,6 +299,19 @@ theseTable f g h TheseTable {here, there} =

305299 there

306300

307301

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+

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

309316-- have a 'TheseTable' that you are storing in a table and need to construct a

310317-- 'TableSchema'.

@@ -317,7 +324,7 @@ nameTheseTable :: ()

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

318325 -> b

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

320− -> TheseTable a b

327+ -> TheseTable Name a b

321328nameTheseTable here there a b =

322329 TheseTable

323330 { here = nameMaybeTable here a