From a29183028b0c6c7283a86536f98a2ebb317c5e53 Mon Sep 17 00:00:00 2001
From: Felipe Lessa <felipe.lessa@gmail.com>
Date: Wed, 5 Sep 2012 20:34:24 -0300
Subject: [PATCH] New DELETE support.

---
 src/Database/Esqueleto.hs              | 12 ++++++-
 src/Database/Esqueleto/Internal/Sql.hs | 50 +++++++++++++++++++++++---
 test/Test.hs                           | 20 +++++++++++
 3 files changed, 77 insertions(+), 5 deletions(-)

diff --git a/src/Database/Esqueleto.hs b/src/Database/Esqueleto.hs
index ef4c459..327032e 100644
--- a/src/Database/Esqueleto.hs
+++ b/src/Database/Esqueleto.hs
@@ -38,17 +38,27 @@ module Database.Esqueleto
   , selectDistinct
   , selectSource
   , selectDistinctSource
+  , delete
 
     -- * Re-exports
     -- $reexports
+  , deleteKey
   , module Database.Persist.GenericSql
   , module Database.Persist.Store
   ) where
 
 import Database.Esqueleto.Internal.Language
 import Database.Esqueleto.Internal.Sql
-import Database.Persist.Store
+import Database.Persist.Store hiding (delete)
 import Database.Persist.GenericSql
+import qualified Database.Persist.Store
+
+
+-- | Synonym for 'Database.Persist.Store.delete' that does not
+-- clash with @esqueleto@'s 'delete'.
+deleteKey :: (PersistStore backend m, PersistEntity val)
+          => Key backend val -> backend m ()
+deleteKey = Database.Persist.Store.delete
 
 -- $reexports
 --
diff --git a/src/Database/Esqueleto/Internal/Sql.hs b/src/Database/Esqueleto/Internal/Sql.hs
index d1e5001..9db1083 100644
--- a/src/Database/Esqueleto/Internal/Sql.hs
+++ b/src/Database/Esqueleto/Internal/Sql.hs
@@ -16,6 +16,8 @@ module Database.Esqueleto.Internal.Sql
   , selectDistinctSource
   , rawSelectSource
   , runSource
+  , rawExecute
+  , delete
   , toRawSql
   , Mode(..)
   ) where
@@ -33,8 +35,8 @@ import Data.Monoid (Monoid(..), (<>))
 import Database.Persist.EntityDef
 import Database.Persist.GenericSql
 import Database.Persist.GenericSql.Internal (Connection(escapeName))
-import Database.Persist.GenericSql.Raw (withStmt)
-import Database.Persist.Store
+import Database.Persist.GenericSql.Raw (withStmt, execute)
+import Database.Persist.Store hiding (delete)
 import qualified Control.Monad.Trans.Reader as R
 import qualified Control.Monad.Trans.State as S
 import qualified Control.Monad.Trans.Writer as W
@@ -370,6 +372,45 @@ runSource :: MonadResourceBase m =>
 runSource src = C.runResourceT $ src C.$$ CL.consume
 
 
+----------------------------------------------------------------------
+
+
+-- | (Internal) Execute an @esqueleto@ statement inside
+-- @persistent@'s 'SqlPersist' monad.
+rawExecute :: ( MonadLogger m
+              , MonadResourceBase m )
+           => Mode
+           -> SqlQuery ()
+           -> SqlPersist m ()
+rawExecute mode query = do
+  conn <- SqlPersist R.ask
+  uncurry execute $
+    first (TL.toStrict . TLB.toLazyText) $
+    toRawSql mode (fromDBName conn) query
+
+
+-- | Execute an @esqueleto@ @DELETE@ query inside @persistent@'s
+-- 'SqlPersist' monad.  Note that currently there are no type
+-- checks for statements that should not appear on a @DELETE@
+-- query.
+--
+-- Example of usage:
+--
+-- @
+-- delete $
+-- from $ \appointment ->
+-- where_ (appointment ^. AppointmentDate <. val now)
+-- @
+delete :: ( MonadLogger m
+          , MonadResourceBase m )
+       => SqlQuery ()
+       -> SqlPersist m ()
+delete = rawExecute DELETE
+
+
+----------------------------------------------------------------------
+
+
 -- | Pretty prints a 'SqlQuery' into a SQL query.
 toRawSql :: SqlSelect a r => Mode -> Escape -> SqlQuery a -> (TLB.Builder, [PersistValue])
 toRawSql mode esc query =
@@ -384,7 +425,7 @@ toRawSql mode esc query =
       , makeOrderBy esc orderByClauses
       ]
 
-data Mode = SELECT | SELECT_DISTINCT
+data Mode = SELECT | SELECT_DISTINCT | DELETE
 
 
 uncommas :: [TLB.Builder] -> TLB.Builder
@@ -395,11 +436,12 @@ uncommas' = (uncommas *** mconcat) . unzip
 
 
 makeSelect :: SqlSelect a r => Escape -> Mode -> a -> (TLB.Builder, [PersistValue])
-makeSelect esc mode ret = first (s <>) (sqlSelectCols esc ret)
+makeSelect esc mode   ret = first (s <>) (sqlSelectCols esc ret)
   where
     s = case mode of
           SELECT          -> "SELECT "
           SELECT_DISTINCT -> "SELECT DISTINCT "
+          DELETE          -> "DELETE"
 
 
 makeFrom :: Escape -> [FromClause] -> (TLB.Builder, [PersistValue])
diff --git a/test/Test.hs b/test/Test.hs
index 6db5fa0..75db1ee 100644
--- a/test/Test.hs
+++ b/test/Test.hs
@@ -343,6 +343,26 @@ main = do
                  return title
           liftIO $ ret `shouldBe` [ Single t1, Single t2, Single t3 ]
 
+    describe "delete" $
+      it "works on a simple example" $
+        run $ do
+          p1e <- insert' p1
+          p2e <- insert' p2
+          p3e <- insert' p3
+          ret1 <- select $
+                  from $ \p -> do
+                  orderBy [asc (p ^. PersonName)]
+                  return p
+          liftIO $ ret1 `shouldBe` [ p1e, p3e, p2e ]
+          ()   <- delete $
+                  from $ \p ->
+                  where_ (p ^. PersonName ==. val (personName p1))
+          ret2 <- select $
+                  from $ \p -> do
+                  orderBy [asc (p ^. PersonName)]
+                  return p
+          liftIO $ ret2 `shouldBe` [ p3e, p2e ]
+
 
 ----------------------------------------------------------------------