Introduce Rel8.Table.Nullify (#104)

This factors out some of the common code that was duplicated in Rel8.Table.Either, Rel8.Table.Maybe and Rel8.Table.These. But it's also more complex than this code was, because it allows for the possibility of a `MaybeTable` in a non-`Nullifiable` context which is a `Table`, but not a `Functor`. This is relevant for the `Projection` work.

rel8.cabal

@@ -23,6 +23,7 @@ library
     , base ^>= 4.14 || ^>=4.15
     , bytestring
     , case-insensitive
+    , comonad
     , contravariant
     , hasql ^>= 1.4.5.1
     , opaleye ^>= 0.7.3.0
@@ -158,6 +159,7 @@ library
     Rel8.Table.Maybe
     Rel8.Table.Name
     Rel8.Table.NonEmpty
+    Rel8.Table.Nullify
     Rel8.Table.Opaleye
     Rel8.Table.Ord
     Rel8.Table.Order

src/Rel8/Generic/Construction.hs

@@ -3,7 +3,6 @@
 {-# language DataKinds #-}
 {-# language FlexibleContexts #-}
 {-# language FlexibleInstances #-}
-{-# language LambdaCase #-}
 {-# language MultiParamTypeClasses #-}
 {-# language NamedFieldPuns #-}
 {-# language ScopedTypeVariables #-}
@@ -59,7 +58,7 @@ import Rel8.Kind.Algebra
   , KnownAlgebra, algebraSing
   )
 import qualified Rel8.Kind.Algebra as K
-import Rel8.Schema.Context.Nullify ( guardExpr, snullify )
+import Rel8.Schema.Context.Nullify ( sguard, snullify )
 import Rel8.Schema.HTable ( HTable )
 import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )
 import qualified Rel8.Schema.Kind as K
@@ -349,7 +348,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 $ guardExpr (tag ==. litExpr tag') . snullify nullity <$> a)
+        Reify $ A $ Aggregate $ sguard (tag ==. litExpr tag') . snullify nullity <$> a)
       (HType (Reify (A (groupByExpr tag))))
     where
       f =

src/Rel8/Query/Either.hs

@@ -10,6 +10,9 @@ where
 -- base
 import Prelude
 
+-- comonad
+import Control.Comonad ( extract )
+
 -- rel8
 import Rel8.Expr ( Expr )
 import Rel8.Expr.Eq ( (==.) )
@@ -27,14 +30,14 @@ import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
 keepLeftTable :: EitherTable Expr a b -> Query a
 keepLeftTable e@(EitherTable _ a _) = do
   where_ $ isLeftTable e
-  pure a
+  pure (extract a)
 
 
 -- | Filter 'EitherTable's, keeping only 'rightTable's.
 keepRightTable :: EitherTable Expr a b -> Query b
 keepRightTable e@(EitherTable _ _ b) = do
   where_ $ isRightTable e
-  pure b
+  pure (extract b)
 
 
 -- | @bitraverseEitherTable f g x@ will pass all @leftTable@s through @f@ and

src/Rel8/Query/Maybe.hs

@@ -1,4 +1,5 @@
 {-# language GADTs #-}
+{-# language NamedFieldPuns #-}
 
 module Rel8.Query.Maybe
   ( optional
@@ -10,6 +11,9 @@ where
 -- base
 import Prelude
 
+-- comonad
+import Control.Comonad ( extract )
+
 -- opaleye
 import qualified Opaleye.Internal.MaybeFields as Opaleye
 
@@ -20,7 +24,7 @@ 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.Maybe ( MaybeTable(..), isJustTable )
 
 
 -- | Convert a query that might return zero rows to a query that always returns
@@ -29,10 +33,10 @@ import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
 -- To speak in more concrete terms, 'optional' is most useful to write @LEFT
 -- JOIN@s.
 optional :: Query a -> Query (MaybeTable Expr a)
-optional =
-  mapOpaleye $
-    Opaleye.optionalInternal $
-      MaybeTable . E . fromPrimExpr . fromColumn
+optional = mapOpaleye $ Opaleye.optionalInternal $ \tag a -> MaybeTable
+  { tag = E $ fromPrimExpr $ fromColumn tag
+  , just = pure a
+  }
 
 
 -- | Filter out 'MaybeTable's, returning only the tables that are not-null.
@@ -43,7 +47,7 @@ optional =
 catMaybeTable :: MaybeTable Expr a -> Query a
 catMaybeTable ma@(MaybeTable _ a) = do
   where_ $ isJustTable ma
-  pure a
+  pure (extract a)
 
 
 -- | Extend an optional query with another query.  This is useful if you want

src/Rel8/Query/These.hs

@@ -15,6 +15,9 @@ where
 -- base
 import Prelude
 
+-- comonad
+import Control.Comonad ( extract )
+
 -- opaleye
 import qualified Opaleye.Internal.PackMap as Opaleye
 import qualified Opaleye.Internal.PrimQuery as Opaleye
@@ -59,7 +62,7 @@ alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.QueryArr $ \i -> cas
       tag''' = Opaleye.next tag''
       join lateral = Opaleye.Join Opaleye.FullJoin on left'' right''
         where
-          on = toPrimExpr $ condition a b
+          on = toPrimExpr $ condition (extract a) (extract b)
           left'' = (lateral, Opaleye.Rebind True lbindings left')
           right'' = (lateral, Opaleye.Rebind True rbindings right')
       ma' = MaybeTable (E hasHere') a
@@ -87,31 +90,31 @@ loseThereTable = keepThisTable
 keepThisTable :: TheseTable Expr a b -> Query a
 keepThisTable t@(TheseTable (MaybeTable _ a) _) = do
   where_ $ isThisTable t
-  pure a
+  pure (extract a)
 
 
 loseThisTable :: TheseTable Expr a b -> Query (MaybeTable Expr a, b)
 loseThisTable t@(TheseTable ma (MaybeTable _ b)) = do
   where_ $ not_ $ isThisTable t
-  pure (ma, b)
+  pure (ma, extract b)
 
 
 keepThatTable :: TheseTable Expr a b -> Query b
 keepThatTable t@(TheseTable _ (MaybeTable _ b)) = do
   where_ $ isThatTable t
-  pure b
+  pure (extract b)
 
 
 loseThatTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b)
 loseThatTable t@(TheseTable (MaybeTable _ a) mb) = do
   where_ $ not_ $ isThatTable t
-  pure (a, mb)
+  pure (extract a, mb)
 
 
 keepThoseTable :: TheseTable Expr a b -> Query (a, b)
 keepThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
   where_ $ isThoseTable t
-  pure (a, b)
+  pure (extract a, extract b)
 
 
 loseThoseTable :: TheseTable Expr a b -> Query (EitherTable Expr a b)

src/Rel8/Schema/Context/Nullify.hs

@@ -1,17 +1,23 @@
 {-# language DataKinds #-}
+{-# language EmptyCase #-}
 {-# language FlexibleContexts #-}
 {-# language GADTs #-}
+{-# language LambdaCase #-}
 {-# language NamedFieldPuns #-}
 {-# language StandaloneKindSignatures #-}
 
 module Rel8.Schema.Context.Nullify
-  ( Nullifiable, nullifier, unnullifier
-  , guardExpr, snullify
+  ( Nullifiability(..), NonNullifiability(..), nullifiableOrNot, absurd
+  , Nullifiable, nullifiability
+  , guarder, nullifier, unnullifier
+  , sguard, snullify
   )
 where
 
 -- base
-import Data.Kind ( Constraint )
+import Data.Bifunctor ( bimap )
+import Data.Bool ( bool )
+import Data.Kind ( Constraint, Type )
 import Data.Monoid ( getFirst )
 import Prelude hiding ( null )
 
@@ -20,73 +26,129 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
 
 -- rel8
 import Rel8.Aggregate
-  ( Aggregate( Aggregate ), Col( A )
+  ( Col( A ), Aggregate( Aggregate )
   , foldInputs, mapInputs
   )
-import Rel8.Expr ( Expr, Col( E ) )
+import Rel8.Expr ( Col( E ), Expr )
 import Rel8.Expr.Bool ( boolExpr )
 import Rel8.Expr.Null ( nullify, unsafeUnnullify )
 import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
+import Rel8.Kind.Context ( SContext(..) )
 import qualified Rel8.Schema.Kind as K
-import Rel8.Schema.Name ( Name( Name ), Col( N ) )
-import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql )
-import Rel8.Schema.Reify ( Reify, Col( Reify ) )
+import Rel8.Schema.Name ( Col( N ), Name( Name ) )
+import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )
+import Rel8.Schema.Reify ( Col( Reify ), Reify )
+import Rel8.Schema.Result ( Col( R ), Result )
 import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
-import Rel8.Type ( DBType )
+
+
+type Nullifiability :: K.Context -> Type
+data Nullifiability context where
+  NAggregate :: Nullifiability Aggregate
+  NExpr :: Nullifiability Expr
+  NName :: Nullifiability Name
+  NReify :: Nullifiability context -> Nullifiability (Reify context)
 
 
 type Nullifiable :: K.Context -> Constraint
 class Nullifiable context where
-  nullifier :: Sql DBType tag
-    => Col context ('Spec tag)
-    -> (Expr tag -> Expr Bool)
-    -> SSpec ('Spec a)
-    -> Col context ('Spec a)
-    -> Col context ('Spec (Nullify a))
-
-  unnullifier :: ()
-    => SSpec ('Spec a)
-    -> Col context ('Spec (Nullify a))
-    -> Col context ('Spec a)
+  nullifiability :: Nullifiability context
 
 
 instance Nullifiable Aggregate where
-  nullifier (A tag) isNonNull SSpec {nullity} (A (Aggregate a)) =
-    A $
-    mapInputs (toPrimExpr . run . fromPrimExpr) $
-    Aggregate $
-    run <$> a
-    where
-      mtag = foldInputs (\_ -> pure . fromPrimExpr) tag
-      run = maybe id (guardExpr . isNonNull) (getFirst mtag) . snullify nullity
-
-  unnullifier SSpec {nullity} (A (Aggregate a)) =
-    A $ Aggregate $ sunnullify nullity <$> a
+  nullifiability = NAggregate
 
 
 instance Nullifiable Expr where
-  nullifier (E tag) isNonNull SSpec {nullity} (E a) =
-    E $ guardExpr condition (snullify nullity a)
-    where
-      condition = isNonNull tag
-
-  unnullifier SSpec {nullity} (E a) = E $ sunnullify nullity a
+  nullifiability = NExpr
 
 
 instance Nullifiable Name where
-  nullifier _ _ _ (N (Name a)) = N $ Name a
-  unnullifier _ (N (Name a)) = N $ Name a
+  nullifiability = NName
 
 
 instance Nullifiable context => Nullifiable (Reify context) where
-  nullifier (Reify tag) isNonNull spec (Reify a) =
-    Reify $ nullifier tag isNonNull spec a
-
-  unnullifier spec (Reify a) = Reify (unnullifier spec a)
-
-
-guardExpr :: Expr Bool -> Expr (Maybe a) -> Expr (Maybe a)
-guardExpr condition a = boolExpr null a condition
+  nullifiability = NReify nullifiability
+
+
+type NonNullifiability :: K.Context -> Type
+data NonNullifiability context where
+  NNResult :: NonNullifiability Result
+  NNReify :: NonNullifiability context -> NonNullifiability (Reify context)
+
+
+nullifiableOrNot :: ()
+  => SContext context
+  -> Either (NonNullifiability context) (Nullifiability context)
+nullifiableOrNot = \case
+  SAggregate -> Right NAggregate
+  SExpr -> Right NExpr
+  SName -> Right NName
+  SResult -> Left NNResult
+  SReify context -> bimap NNReify NReify $ nullifiableOrNot context
+
+
+absurd :: Nullifiability context -> NonNullifiability context -> a
+absurd = \case
+  NAggregate -> \case
+  NExpr -> \case
+  NName -> \case
+  NReify context -> \case
+    NNReify context' -> absurd context context'
+
+
+guarder :: ()
+  => SContext context
+  -> Col context ('Spec tag)
+  -> (tag -> Bool)
+  -> (Expr tag -> Expr Bool)
+  -> Col context ('Spec (Maybe a))
+  -> Col context ('Spec (Maybe a))
+guarder SAggregate (A tag) _ isNonNull (A (Aggregate a)) =
+  A $
+  mapInputs (toPrimExpr . run . fromPrimExpr) $
+  Aggregate $
+  run <$> a
+  where
+    mtag = foldInputs (\_ -> pure . fromPrimExpr) tag
+    run = maybe id (sguard . isNonNull) (getFirst mtag)
+guarder SExpr (E tag) _ isNonNull (E a) = E $ sguard condition a
+  where
+    condition = isNonNull tag
+guarder SName _ _ _ name = name
+guarder SResult (R tag) isNonNull _ (R a) = R (bool Nothing a condition)
+  where
+    condition = isNonNull tag
+guarder (SReify context) (Reify tag) isNonNull isNonNullExpr (Reify a) =
+  Reify $ guarder context tag isNonNull isNonNullExpr a
+
+
+nullifier :: ()
+  => Nullifiability context
+  -> SSpec ('Spec a)
+  -> Col context ('Spec a)
+  -> Col context ('Spec (Nullify a))
+nullifier NAggregate SSpec {nullity} (A (Aggregate a)) =
+  A $ Aggregate $ snullify nullity <$> a
+nullifier NExpr SSpec {nullity} (E a) = E $ snullify nullity a
+nullifier NName _ (N (Name a)) = N $ Name a
+nullifier (NReify context) spec (Reify a) = Reify $ nullifier context spec a
+
+
+unnullifier :: ()
+  => Nullifiability context
+  -> SSpec ('Spec a)
+  -> Col context ('Spec (Nullify a))
+  -> Col context ('Spec a)
+unnullifier NAggregate SSpec {nullity} (A (Aggregate a)) =
+  A $ Aggregate $ sunnullify nullity <$> a
+unnullifier NExpr SSpec {nullity} (E a) = E $ sunnullify nullity a
+unnullifier NName _ (N (Name a)) = N $ Name a
+unnullifier (NReify context) spec (Reify a) = Reify (unnullifier context spec a)
+
+
+sguard :: Expr Bool -> Expr (Maybe a) -> Expr (Maybe a)
+sguard condition a = boolExpr null a condition
   where
     null = fromPrimExpr $ Opaleye.ConstExpr Opaleye.NullLit