From 5514f68994271c3ab804ff08429f48d469529efe Mon Sep 17 00:00:00 2001 From: Felipe Lessa Date: Wed, 28 Nov 2012 18:23:52 -0200 Subject: [PATCH] Support for IN and NOT IN. --- src/Database/Esqueleto.hs | 4 +- src/Database/Esqueleto/Internal/Language.hs | 30 ++++++++++++- src/Database/Esqueleto/Internal/Sql.hs | 27 +++++++++--- test/Test.hs | 47 ++++++++++++++++++++- 4 files changed, 98 insertions(+), 10 deletions(-) diff --git a/src/Database/Esqueleto.hs b/src/Database/Esqueleto.hs index 6705224..684e0cd 100644 --- a/src/Database/Esqueleto.hs +++ b/src/Database/Esqueleto.hs @@ -24,10 +24,12 @@ module Database.Esqueleto , (==.), (>=.), (>.), (<=.), (<.), (!=.), (&&.), (||.) , (+.), (-.), (/.), (*.) , like, (%), concat_, (++.) - , exists, notExists + , subList_select, subList_selectDistinct, valList + , in_, notIn, exists, notExists , set, (=.), (+=.), (-=.), (*=.), (/=.) ) , from , Value(..) + , ValueList(..) , OrderBy -- ** Joins , InnerJoin(..) diff --git a/src/Database/Esqueleto/Internal/Language.hs b/src/Database/Esqueleto/Internal/Language.hs index 410b9c2..47a4bb7 100644 --- a/src/Database/Esqueleto/Internal/Language.hs +++ b/src/Database/Esqueleto/Internal/Language.hs @@ -16,6 +16,7 @@ module Database.Esqueleto.Internal.Language Esqueleto(..) , from , Value(..) + , ValueList(..) , SomeValue(..) , ToSomeValues(..) , InnerJoin(..) @@ -173,10 +174,12 @@ class (Functor query, Applicative query, Monad query) => -- | @OFFSET@. Usually used with 'limit'. offset :: Int64 -> query () - -- | Execute a subquery @SELECT@ in an expression. + -- | Execute a subquery @SELECT@ in an expression. Returns a + -- simple value so should be used only when the @SELECT@ query + -- is guaranteed to return just one row. sub_select :: PersistField a => query (expr (Value a)) -> expr (Value a) - -- | Execute a subquery @SELECT DISTINCT@ in an expression. + -- | Same as 'sub_select' but using @SELECT DISTINCT@. sub_selectDistinct :: PersistField a => query (expr (Value a)) -> expr (Value a) -- | Project a field of an entity. @@ -240,6 +243,22 @@ class (Functor query, Applicative query, Monad query) => -- Supported by SQLite and PostgreSQL. (++.) :: (PersistField s, IsString s) => expr (Value s) -> expr (Value s) -> expr (Value s) + -- | Execute a subquery @SELECT@ in an expression. Returns a + -- list of values. + subList_select :: PersistField a => query (expr (Value a)) -> expr (ValueList a) + + -- | Same as 'sublist_select' but using @SELECT DISTINCT@. + subList_selectDistinct :: PersistField a => query (expr (Value a)) -> expr (ValueList a) + + -- | Lift a list of constant value from Haskell-land to the query. + valList :: PersistField typ => [typ] -> expr (ValueList typ) + + -- | @IN@ operator. + in_ :: PersistField typ => expr (Value typ) -> expr (ValueList typ) -> expr (Value Bool) + + -- | @NOT IN@ operator. + notIn :: PersistField typ => expr (Value typ) -> expr (ValueList typ) -> expr (Value Bool) + -- | @EXISTS@ operator. For example: -- -- @ @@ -283,6 +302,13 @@ data Value a = Value a deriving (Eq, Ord, Show, Typeable) -- Note: because of GHC bug #6124 we use @data@ instead of @newtype@. +-- | A list of single values. There's a limited set of funcitons +-- able to work with this data type (such as 'subList_select', +-- 'valList', 'in_' and 'exists'). +data ValueList a = ValueList a deriving (Eq, Ord, Show, Typeable) +-- Note: because of GHC bug #6124 we use @data@ instead of @newtype@. + + -- | A wrapper type for for any @expr (Value a)@ for all a. data SomeValue expr where SomeValue :: Esqueleto query expr backend => expr (Value a) -> SomeValue expr diff --git a/src/Database/Esqueleto/Internal/Sql.hs b/src/Database/Esqueleto/Internal/Sql.hs index b523ff5..97ccfd7 100644 --- a/src/Database/Esqueleto/Internal/Sql.hs +++ b/src/Database/Esqueleto/Internal/Sql.hs @@ -35,7 +35,7 @@ module Database.Esqueleto.Internal.Sql , veryUnsafeCoerceSqlExprValue ) where -import Control.Applicative (Applicative(..), (<$>)) +import Control.Applicative (Applicative(..), (<$>), (<$)) import Control.Arrow ((***), first) import Control.Exception (throw, throwIO) import Control.Monad ((>=>), ap, MonadPlus(..)) @@ -228,6 +228,7 @@ data SqlExpr a where EEntity :: Ident -> SqlExpr (Entity val) EMaybe :: SqlExpr a -> SqlExpr (Maybe a) ERaw :: NeedParens -> (Connection -> (TLB.Builder, [PersistValue])) -> SqlExpr (Value a) + EList :: SqlExpr (Value a) -> SqlExpr (ValueList a) EOrderBy :: OrderByType -> SqlExpr (Value a) -> SqlExpr OrderBy ESet :: (SqlExpr (Entity val) -> SqlExpr (Value ())) -> SqlExpr (Update val) EPreprocessedFrom :: a -> FromClause -> SqlExpr (PreprocessedFrom a) @@ -324,6 +325,15 @@ instance Esqueleto SqlQuery SqlExpr SqlPersist where concat_ = unsafeSqlFunction "CONCAT" (++.) = unsafeSqlBinOp " || " + subList_select = EList . sub_select + subList_selectDistinct = EList . sub_selectDistinct + + valList vals = EList $ ERaw Parens $ const ( uncommas ("?" <$ vals) + , map toPersistValue vals ) + + v `in_` e = unsafeSqlBinOp " IN " v (veryUnsafeCoerceSqlExprValueList e) + v `notIn` e = unsafeSqlBinOp " NOT IN " v (veryUnsafeCoerceSqlExprValueList e) + exists = unsafeSqlFunction "EXISTS " . existsHelper notExists = unsafeSqlFunction "NOT EXISTS " . existsHelper @@ -341,7 +351,6 @@ instance Esqueleto SqlQuery SqlExpr SqlPersist where instance ToSomeValues SqlExpr (SqlExpr (Value a)) where toSomeValues a = [SomeValue a] - fieldName :: (PersistEntity val, PersistField typ) => Connection -> EntityField val typ -> TLB.Builder fieldName conn = fromDBName conn . fieldDB . persistFieldDef @@ -354,7 +363,7 @@ setAux field mkVal = ESet $ \ent -> unsafeSqlBinOp " = " name (mkVal ent) where name = ERaw Never $ \conn -> (fieldName conn field, mempty) sub :: PersistField a => Mode -> SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a) -sub mode query = ERaw Parens $ \conn -> first parens (toRawSql mode conn query) +sub mode query = ERaw Parens $ \conn -> toRawSql mode conn query fromDBName :: Connection -> DBName -> TLB.Builder fromDBName conn = TLB.fromText . escapeName conn @@ -432,13 +441,19 @@ instance ( UnsafeSqlFunctionArgument a toArgList = toArgList . from4 --- | (Internal) Coerce a type of a 'SqlExpr (Value a)' into --- another 'SqlExpr (Value b)'. You should /not/ use this --- function unless you know what you're doing! +-- | (Internal) Coerce a value's type from 'SqlExpr (Value a)' to +-- 'SqlExpr (Value b)'. You should /not/ use this function +-- unless you know what you're doing! veryUnsafeCoerceSqlExprValue :: SqlExpr (Value a) -> SqlExpr (Value b) veryUnsafeCoerceSqlExprValue (ERaw p f) = ERaw p f +-- | (Internal) Coerce a value's type from 'SqlExpr (ValueList +-- a)' to 'SqlExpr (Value a)'. +veryUnsafeCoerceSqlExprValueList :: SqlExpr (ValueList a) -> SqlExpr (Value a) +veryUnsafeCoerceSqlExprValueList (EList v) = v + + ---------------------------------------------------------------------- diff --git a/test/Test.hs b/test/Test.hs index 10cf961..749a5d7 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -464,6 +464,51 @@ main = do , Entity p2k p2 { personAge = Just 0 } ] describe "lists of values" $ do + it "IN works for valList" $ + run $ do + p1k <- insert p1 + p2k <- insert p2 + p3k <- insert p3 + ret <- select $ + from $ \p -> do + where_ (p ^. PersonName `in_` valList (personName <$> [p1, p2])) + return p + liftIO $ ret `shouldBe` [ Entity p1k p1 + , Entity p2k p2 ] + + it "IN works for subList_select" $ + run $ do + p1k <- insert p1 + p2k <- insert p2 + p3k <- insert p3 + _ <- insert (BlogPost "" p1k) + _ <- insert (BlogPost "" p3k) + ret <- select $ + from $ \p -> do + let subquery = + from $ \bp -> + return (bp ^. BlogPostAuthorId) + where_ (p ^. PersonId `in_` subList_select subquery) + return p + liftIO $ ret `shouldBe` [ Entity p1k p1 + , Entity p3k p3 ] + + it "NOT IN works for subList_select" $ + run $ do + p1k <- insert p1 + p2k <- insert p2 + p3k <- insert p3 + _ <- insert (BlogPost "" p1k) + _ <- insert (BlogPost "" p3k) + ret <- select $ + from $ \p -> do + let subquery = + from $ \bp -> + return (bp ^. BlogPostAuthorId) + where_ (p ^. PersonId `notIn` subList_select subquery) + return p + liftIO $ ret `shouldBe` [ Entity p2k p2 ] + it "EXISTS works for subList_select" $ run $ do p1k <- insert p1 @@ -518,7 +563,7 @@ run = verbose :: Bool -verbose = False +verbose = True run_worker :: RunDbMonad m => SqlPersist (C.ResourceT m) a -> m a