leftJoin is out, optional is in!

opaleye.nix

@@ -1,27 +1,83 @@
-{ mkDerivation, aeson, base, base16-bytestring, bytestring
-, case-insensitive, containers, contravariant, dotenv, hspec
-, hspec-discover, multiset, postgresql-simple, pretty
-, product-profunctors, profunctors, QuickCheck, scientific
-, semigroups, stdenv, text, time, time-locale-compat, transformers
-, uuid, void
+{ mkDerivation
+, aeson
+, base
+, base16-bytestring
+, bytestring
+, case-insensitive
+, containers
+, contravariant
+  #, dotenv
+, fetchgit
+, hspec
+, hspec-discover
+, multiset
+, postgresql-simple
+, pretty
+, product-profunctors
+, profunctors
+, QuickCheck
+, scientific
+, semigroups
+, stdenv
+, text
+, time
+, time-locale-compat
+, transformers
+, uuid
+, void
 }:
 mkDerivation {
   pname = "opaleye";
-  version = "0.6.7004.1";
-  sha256 = "e12d1fdf762524997713db4538fe4b9477ff0c48e939d0c712e842c4276e4f26";
+  version = "0.6.7004.2";
+  src = fetchgit {
+    url = "https://github.com/circuithub/haskell-opaleye";
+    sha256 = "1zmdxqikzvad035c75z02whg0jvs0g3i9zc3rj97xzb2q6ay4m3r";
+    rev = "430dd995f365e68d05aa7ed9f8affec2e0f13b50";
+    fetchSubmodules = true;
+  };
   libraryHaskellDepends = [
-    aeson base base16-bytestring bytestring case-insensitive
-    contravariant postgresql-simple pretty product-profunctors
-    profunctors scientific semigroups text time time-locale-compat
-    transformers uuid void
+    aeson
+    base
+    base16-bytestring
+    bytestring
+    case-insensitive
+    contravariant
+    postgresql-simple
+    pretty
+    product-profunctors
+    profunctors
+    scientific
+    semigroups
+    text
+    time
+    time-locale-compat
+    transformers
+    uuid
+    void
   ];
+  # dotenv, which is needed for the test suite, is broken in our nixpkgs,
+  # so disable testing for now
+  doCheck = false;
   testHaskellDepends = [
-    aeson base containers contravariant dotenv hspec hspec-discover
-    multiset postgresql-simple product-profunctors profunctors
-    QuickCheck semigroups text time transformers uuid
+    aeson
+    base
+    containers
+    contravariant
+    # dotenv
+    hspec
+    hspec-discover
+    multiset
+    postgresql-simple
+    product-profunctors
+    profunctors
+    QuickCheck
+    semigroups
+    text
+    time
+    transformers
+    uuid
   ];
   testToolDepends = [ hspec-discover ];
-  doCheck = false;
   homepage = "https://github.com/tomjaguarpaw/haskell-opaleye";
   description = "An SQL-generating DSL targeting PostgreSQL";
   license = stdenv.lib.licenses.bsd3;

src/Rel8.hs

@@ -17,18 +17,18 @@ module Rel8
   , Table
   , each
   , where_
-  -- , catNulls
   , limit
   , offset
   , union
   , distinct
   , exists
 
-    -- ** Outer Joins
-  , leftJoin
+    -- ** Optional Subqueries
+  , optional
   , MaybeTable
   , nullTag
   , maybeTable
+  , catMaybeTables
 
     -- ** Aggregation
   , groupAndAggregate

src/Rel8/MaybeTable.hs

@@ -1,5 +1,6 @@
 {-# language ApplicativeDo #-}
 {-# language ConstraintKinds #-}
+{-# language DeriveFunctor #-}
 {-# language FlexibleContexts #-}
 {-# language FlexibleInstances #-}
 {-# language GADTs #-}
@@ -35,14 +36,33 @@ data MaybeTable t where
   MaybeTable
     :: { -- | Check if this @MaybeTable@ is null. In other words, check if an outer
          -- join matched any rows.
-         nullTag :: Expr Bool
+         nullTag :: Expr ( Maybe Bool )
        , table :: t
        }
     -> MaybeTable t
+  deriving
+    ( Functor )
+
+
+instance Applicative MaybeTable where
+  pure = MaybeTable (lit (Just False))
+  MaybeTable t f <*> MaybeTable t' a = MaybeTable (liftNull (or_ t t')) (f a)
+    where
+      or_ x y =
+        null_ (lit False) (\x' -> null_ (lit False) (\y' -> x' ||. y') y) x
+
+
+instance Monad MaybeTable where
+  MaybeTable t a >>= f = case f a of
+    MaybeTable t' b -> MaybeTable (liftNull (or_ t t')) b
+    where
+      or_ x y =
+        null_ (lit False) (\x' -> null_ (lit False) (\y' -> x' ||. y') y) x
+
 
 
 data MaybeTableField t a where
-  MaybeTableIsNull :: MaybeTableField t Bool
+  MaybeTableIsNull :: MaybeTableField t ( Maybe Bool )
   MaybeTableField :: Field t a -> MaybeTableField t a
 
 
@@ -51,7 +71,7 @@ instance (Table t, Context t ~ Expr) => Table (MaybeTable t) where
 
   type Context (MaybeTable t) = Context t
 
-  type ConstrainTable (MaybeTable t) c = ( c Bool, ConstrainTable t c )
+  type ConstrainTable (MaybeTable t) c = ( c ( Maybe Bool ), ConstrainTable t c )
 
   field MaybeTable{ nullTag, table } = \case
     MaybeTableIsNull ->

src/Rel8/Query.hs

@@ -28,6 +28,7 @@ import Rel8.Column
 import Rel8.ColumnSchema
 import Rel8.Expr
 import Rel8.SimpleConstraints
+import Rel8.MaybeTable
 import Rel8.Table
 import Rel8.TableSchema
 
@@ -41,6 +42,7 @@ import qualified Database.PostgreSQL.Simple.FromRow as Database.PostgreSQL.Simpl
 import qualified Opaleye ( runInsert_, Insert(..), OnConflict(..), formatAndShowSQL, runDelete_, Delete(..), runUpdate_, Update(..) )
 import qualified Opaleye.Binary as Opaleye
 import qualified Opaleye.Distinct as Opaleye
+import qualified Opaleye.Lateral as Opaleye
 import qualified Opaleye.Internal.Aggregate as Opaleye
 import qualified Opaleye.Internal.Binary as Opaleye
 import qualified Opaleye.Internal.Tag as Opaleye
@@ -59,7 +61,6 @@ import qualified Opaleye.Internal.Unpackspec as Opaleye
 import qualified Opaleye.Operators as Opaleye hiding ( restrict )
 import qualified Opaleye.Order as Opaleye
 import qualified Opaleye.Table as Opaleye
-import Rel8.MaybeTable
 import qualified Rel8.Optimize
 import {-# source #-} Rel8.FromRow
 
@@ -430,66 +431,26 @@ each_forAll schema =
 -- predicate is not satisfied, a null 'MaybeTable' is returned.
 --
 -- @leftJoin t p@ is equivalent to @LEFT JOIN t ON p@.
-leftJoin
-  :: ( Table a, Context a ~ Expr )
-  => Query a
-  -> ( a -> Expr Bool )
-  -> Query ( MaybeTable a )
-leftJoin = leftJoin_forAll
-
-
-leftJoin_forAll
-  :: forall a
-   . ( Table a, Context a ~ Expr )
-  => Query a
-  -> ( a -> Expr Bool )
-  -> Query ( MaybeTable a )
-leftJoin_forAll joinTable condition =
-  liftOpaleye $ Opaleye.QueryArr \( (), left, t ) ->
-    let
-      Opaleye.QueryArr rightQueryF =
-        liftA2
-          (,)
-          ( pure ( lit False ) )
-          ( toOpaleye joinTable )
-
-      ( right, pqR, t' ) =
-        rightQueryF ( (), Opaleye.Unit, t )
-
-      ( ( tag, renamed ), ljPEsB ) =
-        Opaleye.run
-          ( Opaleye.runUnpackspec
-              unpackColumns
-              ( Opaleye.extractLeftJoinFields 2 t' )
-              right
-          )
-
-    in ( MaybeTable
-           { nullTag = tag
-           , table = renamed
-           }
-       , Opaleye.Join
-           Opaleye.LeftJoin
-           ( toPrimExpr ( condition renamed ) )
-           []
-           ljPEsB
-           left
-           pqR
-       , Opaleye.next t'
-       )
+optional :: Query a -> Query (MaybeTable a)
+optional =
+  liftOpaleye . Opaleye.laterally (Opaleye.QueryArr . go) . toOpaleye
 
   where
 
-    unpackColumns :: Opaleye.Unpackspec ( Expr Bool, a ) ( Expr Bool, a )
-    unpackColumns =
-      Opaleye.Unpackspec $ Opaleye.PackMap \f ( tag, outer ) -> do
-        tag' <-
-          f ( toPrimExpr tag )
+    go query (i, left, tag) =
+      ( MaybeTable t' a, join, Opaleye.next tag' )
 
-        outer' <-
-          runIdentity <$> traverseTable @Id ( traverseC ( traversePrimExpr f ) ) ( Identity outer )
+      where
 
-        return ( fromPrimExpr tag', outer' )
+        ( MaybeTable t a, right, tag' ) =
+          Opaleye.runSimpleQueryArr (pure <$> query) (i, tag)
+
+        ( t', bindings ) =
+          Opaleye.run $
+          Opaleye.runUnpackspec unpackspec (Opaleye.extractAttr "maybe" tag') t
+
+        join =
+          Opaleye.Join Opaleye.LeftJoin (toPrimExpr $ lit True) [] bindings left right
 
 
 -- | Combine the results of two queries of the same type.
@@ -580,3 +541,10 @@ where_ :: Expr Bool -> Query ()
 where_ x =
   liftOpaleye $ Opaleye.QueryArr \( (), left, t ) ->
     ( (), Opaleye.restrict ( toPrimExpr x ) left, t )
+
+
+catMaybeTables :: Query ( MaybeTable a ) -> Query a
+catMaybeTables q = do
+  MaybeTable{ nullTag, table } <- q
+  where_ $ not_ $ isNull nullTag
+  return table

src/Rel8/Tests.hs

@@ -120,9 +120,10 @@ leftJoinTest = do
   Part{ partId = partId1 } <-
     each parts
 
-  projectPart <-
-    leftJoin ( each parts ) \Part{ partId = partId2 } ->
-      partId1 ==. partId2
+  projectPart <- optional do
+    part2 <- each parts
+    where_ $ partId part2 ==. partId1
+    return part2
 
   return $ maybeTable ( lit Nothing ) ( liftNull . partId ) projectPart
 
@@ -260,7 +261,7 @@ nullTest = do
 --   select c maybeTableQ
 
 
--- catNullsTest :: MonadQuery m => m ( NotNull Expr Int64 )
+-- catNullsTest :: Query ( Expr Int64 )
 -- catNullsTest =
 --   catNulls ( nullId <$> each hasNull )