haskell/esqueleto
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

New distinct, distinctOn. Deprecate old specializations.

Browse Source
This commit is contained in:
Felipe Lessa 2015-06-19 15:45:15 -03:00
parent e23ae2f328
commit a1a09e736f
4 changed files with 178 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
src/Database/Esqueleto.hs
View File

@ -38,7 +38,8 @@ module Database.Esqueleto
-- $gettingstarted
-- * @esqueleto@'s Language
Esqueleto( where_, on, groupBy, orderBy, rand, asc, desc, limit, offset, having
Esqueleto( where_, on, groupBy, orderBy, rand, asc, desc, limit, offset
, distinct, distinctOn, having
, sub_select, sub_selectDistinct, (^.), (?.)
, val, isNothing, just, nothing, joinV, countRows, count, not_
, (==.), (>=.), (>.), (<=.), (<.), (!=.), (&&.), (||.)

59
src/Database/Esqueleto/Internal/Language.hs
View File

@ -179,6 +179,61 @@ class (Functor query, Applicative query, Monad query) =>
-- | @OFFSET@. Usually used with 'limit'.
offset :: Int64 -> query ()
-- | @DISTINCT@. Change the current @SELECT@ into @SELECT
-- DISTINCT@. For example:
--
-- @
-- select $ distinct $
-- 'from' \\foo -> do
-- ...
-- @
--
-- Note that this also has the same effect:
--
-- @
-- select $
-- 'from' \\foo -> do
-- distinct (return ())
-- ...
-- @
--
-- /Since: 2.2.4/
distinct :: query a -> query a
-- | @DISTINCT ON@. Change the current @SELECT@ into
-- @SELECT DISTINCT ON (expressions)@. For example:
--
-- @
-- select $
-- 'from' \\foo ->
-- distinctOn [foo ^. FooName, foo ^. FooState] $ do
-- ...
-- @
--
-- You can also chain different calls to 'distinctOn' whenever
-- your fields have different types:
--
-- @
-- select $
-- 'from' \\foo ->
-- distinctOn [foo ^. FooName] $
-- distinctOn [foo ^. FooState] $ do
-- ...
-- @
--
-- Each call to 'distinctOn' adds more expressions. Calls to
-- 'distinctOn' override any calls to 'distinct'.
--
-- Note that PostgreSQL requires the expressions on @DISTINCT
-- ON@ to be the first ones to appear on a @ORDER BY@. This is
-- not managed automatically by esqueleto, keeping its spirit
-- of trying to be close to raw SQL.
--
-- Supported by PostgreSQL only.
--
-- /Since: 2.2.4/
distinctOn :: [expr (Value b)] -> query a -> query a
-- | @ORDER BY random()@ clause.
--
-- /Since: 1.3.10/
@ -390,6 +445,10 @@ class (Functor query, Applicative query, Monad query) =>
-- /Since: 2.1.2/
case_ :: PersistField a => [(expr (Value Bool), expr (Value a))] -> expr (Value a) -> expr (Value a)
{-# DEPRECATED sub_selectDistinct "Since 2.2.4: use 'sub_select' and 'distinct'." #-}
{-# DEPRECATED subList_selectDistinct "Since 2.2.4: use 'subList_select' and 'distinct'." #-}
-- Fixity declarations
infixl 9 ^.
infixl 7 *., /.

118
src/Database/Esqueleto/Internal/Sql.hs
View File

@ -103,19 +103,34 @@ type SqlEntity ent = (PersistEntity ent, PersistEntityBackend ent ~ SqlBackend)
-- | Side data written by 'SqlQuery'.
data SideData = SideData { sdFromClause :: ![FromClause]
, sdSetClause :: ![SetClause]
, sdWhereClause :: !WhereClause
, sdGroupByClause :: !GroupByClause
, sdHavingClause :: !HavingClause
, sdOrderByClause :: ![OrderByClause]
, sdLimitClause :: !LimitClause
data SideData = SideData { sdDistinctClause :: !DistinctClause
, sdFromClause :: ![FromClause]
, sdSetClause :: ![SetClause]
, sdWhereClause :: !WhereClause
, sdGroupByClause :: !GroupByClause
, sdHavingClause :: !HavingClause
, sdOrderByClause :: ![OrderByClause]
, sdLimitClause :: !LimitClause
}
instance Monoid SideData where
mempty = SideData mempty mempty mempty mempty mempty mempty mempty
SideData f s w g h o l `mappend` SideData f' s' w' g' h' o' l' =
SideData (f <> f') (s <> s') (w <> w') (g <> g') (h <> h') (o <> o') (l <> l')
mempty = SideData mempty mempty mempty mempty mempty mempty mempty mempty
SideData d f s w g h o l `mappend` SideData d' f' s' w' g' h' o' l' =
SideData (d <> d') (f <> f') (s <> s') (w <> w') (g <> g') (h <> h') (o <> o') (l <> l')
-- | The @DISTINCT@ "clause".
data DistinctClause =
DistinctAll -- ^ The default, everything.
| DistinctStandard -- ^ Only @DISTINCT@, SQL standard.
| DistinctOn [SqlExpr (Value ())] -- ^ @DISTINCT ON@, PostgreSQL extension.
instance Monoid DistinctClause where
mempty = DistinctAll
DistinctOn a `mappend` DistinctOn b = DistinctOn (a <> b)
DistinctOn a `mappend` _ = DistinctOn a
DistinctStandard `mappend` _ = DistinctStandard
DistinctAll `mappend` b = b
-- | A part of a @FROM@ clause.
@ -383,8 +398,12 @@ instance Esqueleto SqlQuery SqlExpr SqlBackend where
limit n = Q $ W.tell mempty { sdLimitClause = Limit (Just n) Nothing }
offset n = Q $ W.tell mempty { sdLimitClause = Limit Nothing (Just n) }
distinct act = Q (W.tell mempty { sdDistinctClause = DistinctStandard }) >> act
distinctOn exprs act = Q (W.tell mempty { sdDistinctClause = DistinctOn exprs' }) >> act
where exprs' = map veryUnsafeCoerceSqlExprValue exprs
sub_select = sub SELECT
sub_selectDistinct = sub SELECT_DISTINCT
sub_selectDistinct = sub_select . distinct
(^.) :: forall val typ. (PersistEntity val, PersistField typ)
=> SqlExpr (Entity val) -> EntityField val typ -> SqlExpr (Value typ)
@ -451,7 +470,7 @@ instance Esqueleto SqlQuery SqlExpr SqlBackend where
(++.) = unsafeSqlBinOp " || "
subList_select = EList . sub_select
subList_selectDistinct = EList . sub_selectDistinct
subList_selectDistinct = subList_select . distinct
valList [] = EEmptyList
valList vals = EList $ ERaw Parens $ const ( uncommas ("?" <$ vals)
@ -801,11 +820,8 @@ selectDistinctSource
, MonadResource m )
=> SqlQuery a
-> C.Source (SqlPersistT m) r
selectDistinctSource query = do
src <- lift $ do
res <- rawSelectSource SELECT_DISTINCT query
fmap snd $ allocateAcquire res
src
selectDistinctSource = selectSource . distinct
{-# DEPRECATED selectDistinctSource "Since 2.2.4: use 'selectSource' and 'distinct'." #-}
-- | Execute an @esqueleto@ @SELECT DISTINCT@ query inside
@ -813,10 +829,8 @@ selectDistinctSource query = do
selectDistinct :: ( SqlSelect a r
, MonadIO m )
=> SqlQuery a -> SqlPersistT m [r]
selectDistinct query = do
res <- rawSelectSource SELECT_DISTINCT query
conn <- R.ask
liftIO $ with res $ flip R.runReaderT conn . runSource
selectDistinct = select . distinct
{-# DEPRECATED selectDistinct "Since 2.2.4: use 'select' and 'distinct'." #-}
-- | (Internal) Run a 'C.Source' of rows.
@ -925,7 +939,8 @@ toRawSql mode (conn, firstIdentState) query =
flip S.runState firstIdentState $
W.runWriterT $
unQ query
SideData fromClauses
SideData distinctClause
fromClauses
setClauses
whereClauses
groupByClause
@ -939,7 +954,7 @@ toRawSql mode (conn, firstIdentState) query =
info = (conn, finalIdentState)
in mconcat
[ makeInsertInto info mode ret
, makeSelect info mode ret
, makeSelect info mode distinctClause ret
, makeFrom info mode fromClauses
, makeSet info setClauses
, makeWhere info whereClauses
@ -953,11 +968,9 @@ toRawSql mode (conn, firstIdentState) query =
-- | (Internal) Mode of query being converted by 'toRawSql'.
data Mode =
SELECT
| SELECT_DISTINCT
| DELETE
| UPDATE
| INSERT_INTO Mode
-- ^ 'Mode' should be either 'SELECT' or 'SELECT_DISTINCT'.
| INSERT_INTO
uncommas :: [TLB.Builder] -> TLB.Builder
@ -971,21 +984,26 @@ uncommas' = (uncommas *** mconcat) . unzip
makeInsertInto :: SqlSelect a r => IdentInfo -> Mode -> a -> (TLB.Builder, [PersistValue])
makeInsertInto info (INSERT_INTO _) ret = sqlInsertInto info ret
makeInsertInto _ _ _ = mempty
makeInsertInto info INSERT_INTO ret = sqlInsertInto info ret
makeInsertInto _ _ _ = mempty
makeSelect :: SqlSelect a r => IdentInfo -> Mode -> a -> (TLB.Builder, [PersistValue])
makeSelect info mode_ ret = process mode_
makeSelect :: SqlSelect a r => IdentInfo -> Mode -> DistinctClause -> a -> (TLB.Builder, [PersistValue])
makeSelect info mode_ distinctClause ret = process mode_
where
process mode =
case mode of
SELECT -> withCols "SELECT "
SELECT_DISTINCT -> withCols "SELECT DISTINCT "
DELETE -> plain "DELETE "
UPDATE -> plain "UPDATE "
INSERT_INTO mode' -> process mode'
withCols v = first (v <>) (sqlSelectCols info ret)
SELECT -> withCols selectKind
DELETE -> plain "DELETE "
UPDATE -> plain "UPDATE "
INSERT_INTO -> process SELECT
selectKind =
case distinctClause of
DistinctAll -> ("SELECT ", [])
DistinctStandard -> ("SELECT DISTINCT ", [])
DistinctOn exprs -> first (("SELECT DISTINCT ON (" <>) . (<> ") ")) $
uncommas' (materializeExpr info <$> exprs)
withCols v = v <> (sqlSelectCols info ret)
plain v = (v, [])
@ -1176,17 +1194,22 @@ instance PersistEntity a => SqlSelect (SqlExpr (Maybe (Entity a))) (Maybe (Entit
-- | You may return any single value (i.e. a single column) from
-- a 'select' query.
instance PersistField a => SqlSelect (SqlExpr (Value a)) (Value a) where
sqlSelectCols info (ERaw p f) =
let (b, vals) = f info
in (parensM p b, vals)
sqlSelectCols info (ECompositeKey f) =
let bs = f info
in (uncommas $ map (parensM Parens) bs, [])
sqlSelectCols = materializeExpr
sqlSelectColCount = const 1
sqlSelectProcessRow [pv] = Value <$> fromPersistValue pv
sqlSelectProcessRow pvs = Value <$> fromPersistValue (PersistList pvs)
-- | Materialize a @SqlExpr (Value a)@.
materializeExpr :: IdentInfo -> SqlExpr (Value a) -> (TLB.Builder, [PersistValue])
materializeExpr info (ERaw p f) =
let (b, vals) = f info
in (parensM p b, vals)
materializeExpr info (ECompositeKey f) =
let bs = f info
in (uncommas $ map (parensM Parens) bs, [])
-- | You may return tuples (up to 16-tuples) and tuples of tuples
-- from a 'select' query.
instance ( SqlSelect a ra
@ -1681,16 +1704,11 @@ to16 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p)) = (a,b,c,d,e,f,g,h,i,j,k,
-- | Insert a 'PersistField' for every selected value.
insertSelect :: (MonadIO m, PersistEntity a) =>
SqlQuery (SqlExpr (Insertion a)) -> SqlPersistT m ()
insertSelect = insertGeneralSelect SELECT
insertSelect = liftM (const ()) . rawEsqueleto INSERT_INTO . fmap EInsertFinal
-- | Insert a 'PersistField' for every unique selected value.
insertSelectDistinct :: (MonadIO m, PersistEntity a) =>
SqlQuery (SqlExpr (Insertion a)) -> SqlPersistT m ()
insertSelectDistinct = insertGeneralSelect SELECT_DISTINCT
insertGeneralSelect :: (MonadIO m, PersistEntity a) =>
Mode -> SqlQuery (SqlExpr (Insertion a)) -> SqlPersistT m ()
insertGeneralSelect mode =
liftM (const ()) . rawEsqueleto (INSERT_INTO mode) . fmap EInsertFinal
insertSelectDistinct = insertSelect . distinct
{-# DEPRECATED insertSelectDistinct "Since 2.2.4: use 'insertSelect' and 'distinct'." #-}

60
test/Test.hs
View File

@ -24,6 +24,8 @@ import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Logger (MonadLogger(..), runStderrLoggingT, runNoLoggingT)
import Control.Monad.Trans.Control (MonadBaseControl(..))
import Control.Monad.Trans.Reader (ReaderT)
import Data.List (sortBy)
import Data.Ord (comparing)
import Database.Esqueleto
#if defined (WITH_POSTGRESQL)
import Database.Persist.Postgresql (withPostgresqlConn)
@ -51,6 +53,12 @@ import Data.Char (toLower, toUpper)
-- Test schema
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|
Foo
name Int
Primary name
Bar
quux FooId
Person
name String
age Int Maybe
@ -773,18 +781,48 @@ main = do
liftIO $ map entityVal eps `shouldBe` reverse ps
describe "selectDistinct" $
it "works on a simple example" $
describe "SELECT DISTINCT" $ do
let selDistTest
:: ( forall m. RunDbMonad m
=> SqlQuery (SqlExpr (Value String))
-> SqlPersistT (R.ResourceT m) [Value String])
-> IO ()
selDistTest q =
run $ do
p1k <- insert p1
let (t1, t2, t3) = ("a", "b", "c")
mapM_ (insert . flip BlogPost p1k) [t1, t3, t2, t2, t1]
ret <- q $
from $ \b -> do
let title = b ^. BlogPostTitle
orderBy [asc title]
return title
liftIO $ ret `shouldBe` [ Value t1, Value t2, Value t3 ]
it "works on a simple example (selectDistinct)" $
selDistTest selectDistinct
it "works on a simple example (select . distinct)" $
selDistTest (select . distinct)
it "works on a simple example (distinct (return ()))" $
selDistTest (\act -> select $ distinct (return ()) >> act)
#if defined(WITH_POSTGRESQL)
describe "SELECT DISTINCT ON" $ do
it "works on a simple example" $ do
run $ do
p1k <- insert p1
let (t1, t2, t3) = ("a", "b", "c")
mapM_ (insert . flip BlogPost p1k) [t1, t3, t2, t2, t1]
ret <- selectDistinct $
from $ \b -> do
let title = b ^. BlogPostTitle
orderBy [asc title]
return title
liftIO $ ret `shouldBe` [ Value t1, Value t2, Value t3 ]
[p1k, p2k, _] <- mapM insert [p1, p2, p3]
[bpA, bpB, bpC] <- mapM insert'
[ BlogPost "A" p1k
, BlogPost "B" p1k
, BlogPost "C" p2k ]
ret <- select $
from $ \bp ->
distinctOn [bp ^. BlogPostAuthorId] $ do
orderBy [asc (bp ^. BlogPostAuthorId), desc (bp ^. BlogPostTitle)]
return bp
liftIO $ ret `shouldBe` sortBy (comparing (blogPostAuthorId . entityVal)) [bpB, bpC]
#endif
describe "coalesce/coalesceDefault" $ do
it "works on a simple example" $