Add join operators, but I have no good idea how 'on' restriction is denoted.

relational-join/src/Database/Relational/Query/Join.hs

@@ -12,6 +12,9 @@ module Database.Relational.Query.Join (
 
   PrimeRelation, Relation,
 
+  inner', left', right', full',
+  inner, left, right, full,
+
   toSQL,
 
   toSubQuery,
@@ -40,7 +43,9 @@ import Database.Relational.Query.Internal.Product
 import Database.Relational.Query.Projection (Projection)
 import qualified Database.Relational.Query.Projection as Projection
 import Database.Relational.Query.Projectable
-  (Projectable(project), PlaceHolders, addPlaceHolders)
+  (Projectable(project), PlaceHolders, addPlaceHolders, projectZip)
+import Database.Relational.Query.ProjectableExtended
+  (ProjectableGeneralizedZip (generalizedZip))
 
 import Database.Relational.Query.Sub (SubQuery)
 import qualified Database.Relational.Query.Sub as SubQuery
@@ -127,6 +132,12 @@ qualify rel =
   do n <- newAlias
      return $ AliasId.qualify rel n
 
+subQueryWithAttr :: NodeAttr -> SubQuery -> QueryJoin (Projection t)
+subQueryWithAttr attr sub = do
+  qsub <- qualify sub
+  updateContext (updateProduct (`growProduct` (attr, qsub)))
+  return $ Projection.fromQualifiedSubQuery qsub
+
 unsafeMergeAnother :: NodeAttr -> QueryJoin a -> QueryJoin a
 unsafeMergeAnother naR qR = do
   ros   <- takeOrderByRevs
@@ -141,17 +152,13 @@ queryMergeWithAttr =  unsafeMergeAnother
 
 queryWithAttr :: NodeAttr -> PrimeRelation p r -> QueryJoin (PlaceHolders p, Projection r)
 queryWithAttr attr = addPlaceHolders . d where
-  d (SubQuery sub)    = do
-    qsub <- qualify sub
-    updateContext (updateProduct (`growProduct` (attr, qsub)))
-    return $ Projection.fromQualifiedSubQuery qsub
-  d (PrimeRelation q) =
-    queryMergeWithAttr attr q
+  d (SubQuery sub)    = subQueryWithAttr attr sub
+  d (PrimeRelation q) = queryMergeWithAttr attr q
 
 query' :: PrimeRelation p r -> QueryJoin (PlaceHolders p, Projection r)
 query' =  queryWithAttr Just'
 
-query :: PrimeRelation p r -> QueryJoin (Projection r)
+query :: Relation r -> QueryJoin (Projection r)
 query =  fmap snd . query'
 
 queryMaybe' :: PrimeRelation p r -> QueryJoin (PlaceHolders p, Projection (Maybe r))
@@ -168,8 +175,76 @@ relation =  PrimeRelation
 relation' :: QueryJoin (PlaceHolders p, Projection r) -> PrimeRelation p r
 relation' =  PrimeRelation . fmap snd
 
-from :: Table r -> QueryJoin (Projection r)
-from =  query . table
+from :: Table r -> Relation r
+from =  relation . query . table
+
+
+join' :: ProjectableGeneralizedZip pa pb pc
+      => (qa -> QueryJoin (PlaceHolders pa, Projection a))
+      -> (qb -> QueryJoin (PlaceHolders pb, Projection b))
+      -> qa
+      -> qb
+      -> PrimeRelation pc (a, b)
+join' qL qR r0 r1 = relation' $ do
+  (ph0, pj0) <- qL r0
+  (ph1, pj1) <- qR r1
+  return $ (ph0 `generalizedZip` ph1, pj0 `projectZip` pj1)
+
+inner' :: ProjectableGeneralizedZip pa pb pc
+       => PrimeRelation pa a
+       -> PrimeRelation pb b
+       -> PrimeRelation pc (a, b)
+inner' =  join' query' query'
+
+left'  :: ProjectableGeneralizedZip pa pb pc
+       => PrimeRelation pa a
+       -> PrimeRelation pb b
+       -> PrimeRelation pc (a, Maybe b)
+left'  =  join' query' queryMaybe'
+
+right' :: ProjectableGeneralizedZip pa pb pc
+       => PrimeRelation pa a
+       -> PrimeRelation pb b
+       -> PrimeRelation pc(Maybe a, b)
+right' =  join' queryMaybe' query'
+
+full'  :: ProjectableGeneralizedZip pa pb pc
+       => PrimeRelation pa a
+       -> PrimeRelation pb b
+       -> PrimeRelation pc (Maybe a, Maybe b)
+full'  =  join' queryMaybe' queryMaybe'
+
+join :: (qa -> QueryJoin (Projection a))
+     -> (qb -> QueryJoin (Projection b))
+     -> qa
+     -> qb
+     -> Relation (a, b)
+join qL qR r0 r1 = relation $ do
+  pj0 <- qL r0
+  pj1 <- qR r1
+  return $ pj0 `projectZip` pj1
+
+inner :: Relation a
+      -> Relation b
+      -> Relation (a, b)
+inner =  join query query
+
+left  :: Relation a
+      -> Relation b
+      -> Relation (a, Maybe b)
+left  =  join query queryMaybe
+
+right :: Relation a
+      -> Relation b
+      -> Relation (Maybe a, b)
+right =  join queryMaybe query
+
+full  :: Relation a
+      -> Relation b
+      -> Relation (Maybe a, Maybe b)
+full  =  join queryMaybe queryMaybe
+
+infix 8 `inner'`, `left'`, `right'`, `full'`, `inner`, `left`, `right`, `full`
 
 toSQL :: PrimeRelation p r -> String
 toSQL =  d  where

relational-join/src/Database/Relational/Query/ProjectableExtended.hs

@@ -5,14 +5,17 @@
 module Database.Relational.Query.ProjectableExtended (
   ProjectableFlattenMaybe (flatten),
 
-  (!), (!?), (!??)
+  (!), (!?), (!??),
+
+  ProjectableGeneralizedZip (generalizedZip), (>?<)
   )  where
 
 import Database.Record (PersistableWidth)
 
 import Database.Relational.Query.Projection (Projection)
 import qualified Database.Relational.Query.Projection as Projection
-import Database.Relational.Query.Projectable (Projectable(project), ProjectableMaybe (flattenMaybe))
+import Database.Relational.Query.Projectable
+  (Projectable(project), ProjectableMaybe (flattenMaybe), ProjectableZip(projectZip))
 import Database.Relational.Query.Pi (Pi)
 
 class ProjectableFlattenMaybe a b where
@@ -38,4 +41,21 @@ p !? pi' = project $ Projection.piMaybe p pi'
         => Projection c -> Pi a b -> p (Maybe b)
 p !?? pi' = project $ Projection.piMaybe (flatten p) pi'
 
+class ProjectableGeneralizedZip a b c where
+  generalizedZip :: ProjectableZip p => p a -> p b -> p c
+
+instance ProjectableGeneralizedZip a () a where
+  generalizedZip = const
+
+instance ProjectableGeneralizedZip () a a where
+  generalizedZip = const id
+
+instance ProjectableGeneralizedZip a b (a, b) where
+  generalizedZip = projectZip
+
+(>?<) :: (ProjectableGeneralizedZip a b c, ProjectableZip p)
+      => p a -> p b -> p c
+(>?<) =  generalizedZip
+
 infixl 8 !, !?, !??
+infixl 1 >?<