diff --git a/src/Database/Esqueleto/Internal/Sql.hs b/src/Database/Esqueleto/Internal/Sql.hs index bc02410..db30cd6 100644 --- a/src/Database/Esqueleto/Internal/Sql.hs +++ b/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 $ - \info@(conn,_) -> (uncommas (map (\a -> useIdent info ident <> "." <> TLB.fromText (connEscapeName conn (fieldDB a))) (compositeFields pdef)), []) + = ERawList $ + \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 diff --git a/test/Test.hs b/test/Test.hs index 47f6424..29f0f99 100644 --- a/test/Test.hs +++ b/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 ----------------------------------------------------------------------