handle non-id/composite primary keys on ==. and !=.

src/Database/Esqueleto/Internal/Sql.hs

@@ -257,6 +257,8 @@ data SqlExpr a where
   -- interpolated by the SQL backend.
   ERaw     :: NeedParens -> (IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr (Value a)
 
+  ERawList :: (IdentInfo -> ([TLB.Builder], [PersistValue])) -> SqlExpr (Value a)
+
   -- 'EList' and 'EEmptyList' are used by list operators.
   EList      :: SqlExpr (Value a) -> SqlExpr (ValueList a)
   EEmptyList :: SqlExpr (ValueList a)
@@ -342,8 +344,8 @@ instance Esqueleto SqlQuery SqlExpr SqlBackend where
           SqlExpr (Entity val) -> EntityField val typ -> SqlExpr (Value typ)
   EEntity ident ^. field
     | isIdField field && hasCompositeKey ed
-    = ERaw Parens $
+    = ERawList $
-      \info@(conn,_) -> (uncommas (map (\a -> useIdent info ident <> "." <> TLB.fromText (connEscapeName conn (fieldDB a))) (compositeFields pdef)), [])
+      \info@(conn,_) -> (map (\a -> useIdent info ident <> "." <> TLB.fromText (connEscapeName conn (fieldDB a))) (compositeFields pdef), [])
     | otherwise = ERaw Never $ \info -> (useIdent info ident <> ("." <> fieldName info field), [])
     where
       ed = entityDef $ getEntityVal $ (Proxy :: Proxy (SqlExpr (Entity val)))
@@ -354,7 +356,11 @@ instance Esqueleto SqlQuery SqlExpr SqlBackend where
       maybelize :: SqlExpr (Value a) -> SqlExpr (Value (Maybe a))
       maybelize (ERaw p f) = ERaw p f
 
-  val = ERaw Never . const . (,) "?" . return . toPersistValue
+  val v = case v' of
+            PersistList vs -> ERawList $ const (replicate (length vs) "?", vs)
+            _              -> ERaw Never . const . (,) "?" . return $ v'
+    where v' = toPersistValue v
+    
 
   isNothing (ERaw p f) = ERaw Parens $ first ((<> " IS NULL") . parensM p) . f
   just (ERaw p f) = ERaw p f
@@ -367,12 +373,12 @@ instance Esqueleto SqlQuery SqlExpr SqlBackend where
   not_ (ERaw p f) = ERaw Never $ \info -> let (b, vals) = f info
                                           in ("NOT " <> parensM p b, vals)
 
-  (==.) = unsafeSqlBinOp " = "
+  (==.) = unsafeSqlBinOpList " = " " AND "
   (>=.) = unsafeSqlBinOp " >= "
   (>.)  = unsafeSqlBinOp " > "
   (<=.) = unsafeSqlBinOp " <= "
   (<.)  = unsafeSqlBinOp " < "
-  (!=.) = unsafeSqlBinOp " != "
+  (!=.) = unsafeSqlBinOpList " != " " OR "
   (&&.) = unsafeSqlBinOp " AND "
   (||.) = unsafeSqlBinOp " OR "
   (+.)  = unsafeSqlBinOp " + "
@@ -507,6 +513,17 @@ unsafeSqlBinOp op (ERaw p1 f1) (ERaw p2 f2) = ERaw Parens f
                 , vals1 <> vals2 )
 {-# INLINE unsafeSqlBinOp #-}
 
+unsafeSqlBinOpList :: TLB.Builder -> TLB.Builder -> SqlExpr (Value a) -> SqlExpr (Value b) -> SqlExpr (Value c)
+unsafeSqlBinOpList op sep (ERawList f1) (ERawList f2) = ERaw Never f
+  where
+    f info = let (b1, vals1) = f1 info
+                 (b2, vals2) = f2 info
+             in ( intersperseB sep . map (\(a,b) -> a <> op <> b) $
+                  zip b1 b2
+                , vals1 <> vals2 )
+unsafeSqlBinOpList op _ a@(ERaw _ _) b@(ERaw _ _) = unsafeSqlBinOp op a b
+unsafeSqlBinOpList _ _ _ _ = error "unsafeSqlBinOpList: must operate against another composite key"
+{-# INLINE unsafeSqlBinOpList #-}
 
 -- | (Internal) A raw SQL value.  The same warning from
 -- 'unsafeSqlBinOp' applies to this function as well.
@@ -842,7 +859,10 @@ data Mode =
 
 
 uncommas :: [TLB.Builder] -> TLB.Builder
-uncommas = mconcat . intersperse ", " . filter (/= mempty)
+uncommas = intersperseB ", "
+
+intersperseB :: TLB.Builder -> [TLB.Builder] -> TLB.Builder
+intersperseB a = mconcat . intersperse a . filter (/= mempty)
 
 uncommas' :: Monoid a => [(TLB.Builder, a)] -> (TLB.Builder, a)
 uncommas' = (uncommas *** mconcat) . unzip

test/Test.hs

@@ -68,7 +68,8 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|
     deriving Eq Show
   Article
     title String
-    frontcoverId FrontcoverId
+    frontcoverNumber Int
+    Foreign Frontcover fkfrontcover frontcoverNumber
     deriving Eq Show
   Point
     x Int
@@ -76,6 +77,12 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|
     name String
     Primary x y
     deriving Eq Show
+  Circle
+    centerX Int
+    centerY Int
+    name String
+    Foreign Point fkpoint centerX centerY
+    deriving Eq Show
 |]
 
 -- | this could be achieved with S.fromList, but not all lists
@@ -952,39 +959,59 @@ main = do
             ret `shouldBe` p
             pPk `shouldBe` thePk
 
-      it "can join with a custom primary key and return one entity" $
+      {- FIXME: Persistent does not create the CircleFkPoint constructor.
+       - Should it?
+      it "can join on a composite primary key" $
+        run $ do
+          let p = Point x y ""
+              c = Circle x y ""
+              x = 10
+              y = 15
+              Right thePk = keyFromValues [ PersistInt64 $ fromIntegral x
+                                          , PersistInt64 $ fromIntegral y]
+          pPk <- insert p
+          insert_ c
+          [Entity _ ret] <- select $ from $ \(c' `InnerJoin` p') -> do
+            on (p'^.PointId ==. c'^.CircleFkpoint)
+            return p'
+          liftIO $ do
+            ret `shouldBe` p
+            pPk `shouldBe` thePk
+      -}
+
+      it "can join with a non-id primary key and return one entity" $
         run $ do
           let fc = Frontcover number ""
-              article = Article "Esqueleto supports composite pks!" thePk
+              article = Article "Esqueleto supports composite pks!" number
               number = 101
               Right thePk = keyFromValues [PersistInt64 $ fromIntegral number]
           fcPk <- insert fc
           insert_ article
           [Entity _ retFc] <- select $
             from $ \(a `InnerJoin` f) -> do
-              on (f^.FrontcoverId ==. a^.ArticleFrontcoverId)
+              on (f^.FrontcoverNumber ==. a^.ArticleFrontcoverNumber)
               return f
           liftIO $ do
             retFc `shouldBe` fc
             fcPk `shouldBe` thePk
 
-      it "can join with a custom primary key and return both entities" $
+      it "can join with a non-id primary key and return both entities" $
         run $ do
           let fc = Frontcover number ""
-              article = Article "Esqueleto supports composite pks!" thePk
+              article = Article "Esqueleto supports composite pks!" number
               number = 101
               Right thePk = keyFromValues [PersistInt64 $ fromIntegral number]
           fcPk <- insert fc
           insert_ article
           [(Entity _ retFc, Entity _ retArt)] <- select $
             from $ \(a `InnerJoin` f) -> do
-              on (f^.FrontcoverId ==. a^.ArticleFrontcoverId)
+              on (f^.FrontcoverNumber ==. a^.ArticleFrontcoverNumber)
               return (f, a)
           liftIO $ do
             retFc `shouldBe` fc
             retArt `shouldBe` article
             fcPk `shouldBe` thePk
-            articleFrontcoverId retArt `shouldBe` thePk
+            articleFkfrontcover retArt `shouldBe` thePk
 ----------------------------------------------------------------------