diff --git a/esqueleto.cabal b/esqueleto.cabal --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -1,5 +1,5 @@ name: esqueleto -version: 0.2.8 +version: 0.2.9 synopsis: Bare bones, type-safe EDSL for SQL queries on persistent backends. homepage: https://github.com/meteficha/esqueleto license: BSD3 @@ -85,7 +85,7 @@ , persistent-template == 1.0.* , monad-control , monad-logger - , fast-logger == 0.2.* + , fast-logger >= 0.2 && < 0.4 , transformers-base , template-haskell diff --git a/src/Database/Esqueleto.hs b/src/Database/Esqueleto.hs --- a/src/Database/Esqueleto.hs +++ b/src/Database/Esqueleto.hs @@ -24,9 +24,12 @@ , (==.), (>=.), (>.), (<=.), (<.), (!=.), (&&.), (||.) , (+.), (-.), (/.), (*.) , like, (%), concat_, (++.) + , 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 --- a/src/Database/Esqueleto/Internal/Language.hs +++ b/src/Database/Esqueleto/Internal/Language.hs @@ -16,6 +16,7 @@ Esqueleto(..) , from , Value(..) + , ValueList(..) , SomeValue(..) , ToSomeValues(..) , InnerJoin(..) @@ -173,10 +174,12 @@ -- | @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,37 @@ -- 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: + -- + -- @ + -- select $ + -- from $ \person -> do + -- where_ $ exists $ + -- from $ \post -> do + -- where_ (post ^. BlogPostAuthorId ==. person ^. PersonId) + -- return person + -- @ + exists :: query () -> expr (Value Bool) + + -- | @NOT EXISTS@ operator. + notExists :: query () -> expr (Value Bool) + -- | @SET@ clause used on @UPDATE@s. Note that while it's not -- a type error to use this function on a @SELECT@, it will -- most certainly result in a runtime error. @@ -265,6 +299,13 @@ -- | A single value (as opposed to a whole entity). You may use -- @('^.')@ or @('?.')@ to get a 'Value' from an 'Entity'. 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@. diff --git a/src/Database/Esqueleto/Internal/Sql.hs b/src/Database/Esqueleto/Internal/Sql.hs --- a/src/Database/Esqueleto/Internal/Sql.hs +++ b/src/Database/Esqueleto/Internal/Sql.hs @@ -35,7 +35,7 @@ , 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 @@ 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,18 @@ 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 + set ent upds = Q $ W.tell mempty { sdSetClause = map apply upds } where apply (ESet f) = SetClause (f ent) @@ -338,7 +351,6 @@ 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 @@ -351,12 +363,18 @@ 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 +existsHelper :: SqlQuery () -> SqlExpr (Value a) +existsHelper = + ERaw Parens . + flip (toRawSql SELECT) . + (>> return (val True :: SqlExpr (Value Bool))) + ---------------------------------------------------------------------- @@ -423,11 +441,17 @@ 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 --- a/test/Test.hs +++ b/test/Test.hs @@ -463,7 +463,84 @@ , Entity p3k p3 { personAge = Just 7 } , 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 + p2k <- insert p2 + p3k <- insert p3 + _ <- insert (BlogPost "" p1k) + _ <- insert (BlogPost "" p3k) + ret <- select $ + from $ \p -> do + where_ $ exists $ + from $ \bp -> do + where_ (bp ^. BlogPostAuthorId ==. p ^. PersonId) + return p + liftIO $ ret `shouldBe` [ Entity p1k p1 + , Entity p3k p3 ] + + it "EXISTS 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 + where_ $ notExists $ + from $ \bp -> do + where_ (bp ^. BlogPostAuthorId ==. p ^. PersonId) + return p + liftIO $ ret `shouldBe` [ Entity p2k p2 ] + + ---------------------------------------------------------------------- @@ -486,7 +563,7 @@ verbose :: Bool -verbose = False +verbose = True run_worker :: RunDbMonad m => SqlPersist (C.ResourceT m) a -> m a