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.

rel8.cabal

@@ -162,7 +162,6 @@ library
     Rel8.Table.Recontextualize
     Rel8.Table.Rel8able
     Rel8.Table.Serialize
-    Rel8.Table.Tag
     Rel8.Table.These
     Rel8.Table.Undefined
     Rel8.Table.Unreify

src/Rel8.hs

@@ -59,6 +59,7 @@ module Rel8
   , optional
   , catMaybeTable
   , traverseMaybeTable
+  , aggregateMaybeTable
   , nameMaybeTable
 
     -- ** @EitherTable@
@@ -68,6 +69,7 @@ module Rel8
   , keepLeftTable
   , keepRightTable
   , bitraverseEitherTable
+  , aggregateEitherTable
   , nameEitherTable
 
     -- ** @TheseTable@
@@ -83,6 +85,7 @@ module Rel8
   , keepThatTable, loseThatTable
   , keepThoseTable, loseThoseTable
   , bitraverseTheseTable
+  , aggregateTheseTable
   , nameTheseTable
 
     -- ** @ListTable@

src/Rel8/Column/Either.hs

@@ -3,7 +3,7 @@
 {-# language LambdaCase #-}
 {-# language MultiParamTypeClasses #-}
 {-# language StandaloneKindSignatures #-}
-{-# language TypeFamilies #-}
+{-# language TypeFamilyDependencies #-}
 {-# language UndecidableInstances #-}
 
 module Rel8.Column.Either
@@ -39,11 +39,11 @@ import Rel8.Table.Recontextualize ( Recontextualize )
 -- 'EitherTable' @a b@ in the 'Expr' context, and a 'Either' @a b@ in the
 -- 'Result' context.
 type HEither :: K.Context -> Type -> Type -> Type
-type family HEither context where
+type family HEither context = either | either -> context where
   HEither (Reify context) = AHEither context
-  HEither Aggregate = EitherTable
-  HEither Expr = EitherTable
-  HEither Name = EitherTable
+  HEither Aggregate = EitherTable Aggregate
+  HEither Expr = EitherTable Expr
+  HEither Name = EitherTable Name
   HEither Result = Either
 
 

src/Rel8/Column/List.hs

@@ -3,7 +3,7 @@
 {-# language LambdaCase #-}
 {-# language MultiParamTypeClasses #-}
 {-# language StandaloneKindSignatures #-}
-{-# language TypeFamilies #-}
+{-# language TypeFamilyDependencies #-}
 {-# language UndecidableInstances #-}
 
 module Rel8.Column.List
@@ -38,11 +38,11 @@ import Rel8.Table.Unreify ( Unreifiability(..), Unreifiable, unreifiability )
 -- | Nest a list within a 'Rel8able'. @HList f a@ will produce a 'ListTable'
 -- @a@ in the 'Expr' context, and a @[a]@ in the 'Result' context.
 type HList :: K.Context -> Type -> Type
-type family HList context where
+type family HList context = list | list -> context where
   HList (Reify context) = AHList context
-  HList Aggregate = ListTable
-  HList Expr = ListTable
-  HList Name = ListTable
+  HList Aggregate = ListTable Aggregate
+  HList Expr = ListTable Expr
+  HList Name = ListTable Name
   HList Result = []
 
 

src/Rel8/Column/Maybe.hs

@@ -4,7 +4,7 @@
 {-# language LambdaCase #-}
 {-# language MultiParamTypeClasses #-}
 {-# language StandaloneKindSignatures #-}
-{-# language TypeFamilies #-}
+{-# language TypeFamilyDependencies #-}
 {-# language UndecidableInstances #-}
 
 module Rel8.Column.Maybe
@@ -38,11 +38,11 @@ import Rel8.Table.Recontextualize ( Recontextualize )
 -- 'MaybeTable' @a@ in the 'Expr' context, and a 'Maybe' @a@ in the 'Result'
 -- context.
 type HMaybe :: K.Context -> Type -> Type
-type family HMaybe context where
+type family HMaybe context = maybe | maybe -> context where
   HMaybe (Reify context) = AHMaybe context
-  HMaybe Aggregate = MaybeTable
-  HMaybe Expr = MaybeTable
-  HMaybe Name = MaybeTable
+  HMaybe Aggregate = MaybeTable Aggregate
+  HMaybe Expr = MaybeTable Expr
+  HMaybe Name = MaybeTable Name
   HMaybe Result = Maybe
 
 
@@ -70,8 +70,8 @@ instance (Reifiable context, Table (Reify context) a) =>
 instance
   ( Reifiable context, Reifiable context'
   , Recontextualize (Reify context) (Reify context') a a'
-  ) =>
-  Recontextualize
+  )
+  => Recontextualize
     (Reify context)
     (Reify context')
     (AHMaybe context a)

src/Rel8/Column/NonEmpty.hs

@@ -3,7 +3,7 @@
 {-# language LambdaCase #-}
 {-# language MultiParamTypeClasses #-}
 {-# language StandaloneKindSignatures #-}
-{-# language TypeFamilies #-}
+{-# language TypeFamilyDependencies #-}
 {-# language UndecidableInstances #-}
 
 module Rel8.Column.NonEmpty
@@ -40,11 +40,11 @@ import Rel8.Table.Unreify ( Unreifiability(..), Unreifiable, unreifiability )
 -- 'NonEmptyTable' @a@ in the 'Expr' context, and a 'NonEmpty' @a@ in the
 -- 'Result' context.
 type HNonEmpty :: K.Context -> Type -> Type
-type family HNonEmpty context where
+type family HNonEmpty context = nonEmpty | nonEmpty -> context where
   HNonEmpty (Reify context) = AHNonEmpty context
-  HNonEmpty Aggregate = NonEmptyTable
-  HNonEmpty Expr = NonEmptyTable
-  HNonEmpty Name = NonEmptyTable
+  HNonEmpty Aggregate = NonEmptyTable Aggregate
+  HNonEmpty Expr = NonEmptyTable Expr
+  HNonEmpty Name = NonEmptyTable Name
   HNonEmpty Result = NonEmpty
 
 

src/Rel8/Column/These.hs

@@ -4,7 +4,7 @@
 {-# language LambdaCase #-}
 {-# language MultiParamTypeClasses #-}
 {-# language StandaloneKindSignatures #-}
-{-# language TypeFamilies #-}
+{-# language TypeFamilyDependencies #-}
 {-# language UndecidableInstances #-}
 
 module Rel8.Column.These
@@ -43,11 +43,11 @@ import Data.These ( These )
 -- 'TheseTable' @a b@ in the 'Expr' context, and a 'These' @a b@ in the
 -- 'Result' context.
 type HThese :: K.Context -> Type -> Type -> Type
-type family HThese context where
+type family HThese context = these | these -> context where
   HThese (Reify context) = AHThese context
-  HThese Aggregate = TheseTable
-  HThese Expr = TheseTable
-  HThese Name = TheseTable
+  HThese Aggregate = TheseTable Aggregate
+  HThese Expr = TheseTable Expr
+  HThese Name = TheseTable Name
   HThese Result = These
 
 

src/Rel8/Generic/Construction.hs

@@ -59,7 +59,7 @@ import Rel8.Kind.Algebra
   , KnownAlgebra, algebraSing
   )
 import qualified Rel8.Kind.Algebra as K
-import Rel8.Schema.Context.Nullify ( runTag )
+import Rel8.Schema.Context.Nullify ( guardExpr, snullify )
 import Rel8.Schema.HTable ( HTable )
 import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )
 import qualified Rel8.Schema.Kind as K
@@ -349,7 +349,7 @@ ggaggregate gfromColumns gtoColumns agg es = case algebraSing @algebra of
       @(Eval (rep (Reify Aggregate)))
       (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)
       (\tag' SSpec {nullity} (Reify (A (Aggregate a))) ->
-        Reify $ A $ Aggregate $ runTag nullity (tag ==. litExpr tag') <$> a)
+        Reify $ A $ Aggregate $ guardExpr (tag ==. litExpr tag') . snullify nullity <$> a)
       (HType (Reify (A (groupByExpr tag))))
     where
       f =

src/Rel8/Query/Either.hs

@@ -11,6 +11,7 @@ where
 import Prelude
 
 -- rel8
+import Rel8.Expr ( Expr )
 import Rel8.Expr.Eq ( (==.) )
 import Rel8.Query ( Query )
 import Rel8.Query.Filter ( where_ )
@@ -23,14 +24,14 @@ import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
 
 
 -- | Filter 'EitherTable's, keeping only 'leftTable's.
-keepLeftTable :: EitherTable a b -> Query a
+keepLeftTable :: EitherTable Expr a b -> Query a
 keepLeftTable e@(EitherTable _ a _) = do
   where_ $ isLeftTable e
   pure a
 
 
 -- | Filter 'EitherTable's, keeping only 'rightTable's.
-keepRightTable :: EitherTable a b -> Query b
+keepRightTable :: EitherTable Expr a b -> Query b
 keepRightTable e@(EitherTable _ _ b) = do
   where_ $ isRightTable e
   pure b
@@ -55,8 +56,8 @@ keepRightTable e@(EitherTable _ _ b) = do
 bitraverseEitherTable :: ()
   => (a -> Query c)
   -> (b -> Query d)
-  -> EitherTable a b
-  -> Query (EitherTable c d)
+  -> EitherTable Expr a b
+  -> Query (EitherTable Expr c d)
 bitraverseEitherTable f g e@(EitherTable tag _ _) = do
   mc@(MaybeTable _ c) <- optional (f =<< keepLeftTable e)
   md@(MaybeTable _ d) <- optional (g =<< keepRightTable e)

src/Rel8/Query/List.hs

@@ -46,7 +46,7 @@ import Rel8.Type.Information ( TypeInformation )
 --
 -- @many@ is analogous to 'Control.Applicative.many' from
 -- @Control.Applicative@.
-many :: Table Expr a => Query a -> Query (ListTable a)
+many :: Table Expr a => Query a -> Query (ListTable Expr a)
 many =
   fmap (maybeTable mempty (\(ListTable a) -> ListTable a)) .
   optional .
@@ -62,7 +62,7 @@ many =
 --
 -- @some@ is analogous to 'Control.Applicative.some' from
 -- @Control.Applicative@.
-some :: Table Expr a => Query a -> Query (NonEmptyTable a)
+some :: Table Expr a => Query a -> Query (NonEmptyTable Expr a)
 some =
   fmap (\(NonEmptyTable a) -> NonEmptyTable a) .
   aggregate .
@@ -83,7 +83,7 @@ someExpr = aggregate . fmap nonEmptyAggExpr
 -- element of the given @ListTable@.
 --
 -- @catListTable@ is an inverse to 'many'.
-catListTable :: Table Expr a => ListTable a -> Query a
+catListTable :: Table Expr a => ListTable Expr a -> Query a
 catListTable (ListTable as) = rebind $ fromColumns $ runIdentity $
   hunvectorize (\SSpec {info} -> pure . E . sunnest info . unE) as
 
@@ -92,7 +92,7 @@ catListTable (ListTable as) = rebind $ fromColumns $ runIdentity $
 -- element of the given @NonEmptyTable@.
 --
 -- @catNonEmptyTable@ is an inverse to 'some'.
-catNonEmptyTable :: Table Expr a => NonEmptyTable a -> Query a
+catNonEmptyTable :: Table Expr a => NonEmptyTable Expr a -> Query a
 catNonEmptyTable (NonEmptyTable as) = rebind $ fromColumns $ runIdentity $
   hunvectorize (\SSpec {info} -> pure . E . sunnest info . unE) as
 

src/Rel8/Query/Maybe.hs

@@ -1,3 +1,5 @@
+{-# language GADTs #-}
+
 module Rel8.Query.Maybe
   ( optional
   , catMaybeTable
@@ -12,33 +14,33 @@ import Prelude
 import qualified Opaleye.Internal.MaybeFields as Opaleye
 
 -- rel8
+import Rel8.Expr ( Col( E ), Expr )
 import Rel8.Expr.Eq ( (==.) )
 import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr )
 import Rel8.Query ( Query )
 import Rel8.Query.Filter ( where_ )
 import Rel8.Query.Opaleye ( mapOpaleye )
 import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
-import Rel8.Table.Tag ( Tag(..), fromExpr )
 
 
 -- | Convert a query that might return zero rows to a query that always returns
 -- at least one row.
 --
 -- To speak in more concrete terms, 'optional' is most useful to write @LEFT
 -- JOIN@s.
-optional :: Query a -> Query (MaybeTable a)
+optional :: Query a -> Query (MaybeTable Expr a)
 optional =
   mapOpaleye $
     Opaleye.optionalInternal $
-      MaybeTable . fromExpr . fromPrimExpr . fromColumn
+      MaybeTable . E . fromPrimExpr . fromColumn
 
 
 -- | Filter out 'MaybeTable's, returning only the tables that are not-null.
 --
 -- This operation can be used to "undo" the effect of 'optional', which
 -- operationally is like turning a @LEFT JOIN@ back into a full @JOIN@.  You
 -- can think of this as analogous to 'Data.Maybe.catMaybes'.
-catMaybeTable :: MaybeTable a -> Query a
+catMaybeTable :: MaybeTable Expr a -> Query a
 catMaybeTable ma@(MaybeTable _ a) = do
   where_ $ isJustTable ma
   pure a
@@ -53,8 +55,8 @@ catMaybeTable ma@(MaybeTable _ a) = do
 -- have no rows. However, regardless of the given @a -> Query b@ function, if
 -- the input is @nothingTable@, you will always get exactly one @nothingTable@
 -- back.
-traverseMaybeTable :: (a -> Query b) -> MaybeTable a -> Query (MaybeTable b)
-traverseMaybeTable query ma@(MaybeTable input _) = do
-  MaybeTable output b <- optional (query =<< catMaybeTable ma)
-  where_ $ expr output ==. expr input
-  pure $ MaybeTable input b
+traverseMaybeTable :: (a -> Query b) -> MaybeTable Expr  a -> Query (MaybeTable Expr b)
+traverseMaybeTable query ma@(MaybeTable (E input) _) = do
+  MaybeTable (E output) b <- optional (query =<< catMaybeTable ma)
+  where_ $ output ==. input
+  pure $ MaybeTable (E input) b