Merge pull request #66 from fpco/persistent2

Persistent2

esqueleto.cabal

@@ -1,5 +1,5 @@
 name:                esqueleto
-version:             1.4.4
+version:             2.0.0
 synopsis:            Type-safe EDSL for SQL queries on persistent backends.
 homepage:            https://github.com/prowdsponsor/esqueleto
 license:             BSD3
@@ -63,15 +63,15 @@ library
     Database.Esqueleto.Internal.PersistentImport
   build-depends:
       base                 >= 4.5    && < 4.8
-    , text                 >= 0.11
+    , text                 >= 0.11   && < 1.2
-    , persistent           >= 1.3    && < 1.4
+    , persistent           >= 2.0.2  && < 2.1
     , transformers         >= 0.2
     , unordered-containers >= 0.2
     , tagged               >= 0.2
 
     , monad-logger
     , conduit              >= 1.1
-    , resourcet
+    , resourcet            >= 1.1
   hs-source-dirs: src/
   ghc-options: -Wall
 
@@ -91,8 +91,8 @@ test-suite test
     , HUnit
     , QuickCheck
     , hspec               >= 1.8
-    , persistent-sqlite   >= 1.2 && < 1.4
+    , persistent-sqlite   >= 2.0 && < 2.1
-    , persistent-template >= 1.2 && < 1.4
+    , persistent-template >= 2.0 && < 2.1
     , monad-control
     , monad-logger        >= 0.3
 
@@ -103,14 +103,14 @@ test-suite test
     build-depends:
         postgresql-simple     >= 0.2
       , postgresql-libpq      >= 0.6
-      , persistent-postgresql >= 1.2.0
+      , persistent-postgresql >= 2.0
-
+    
     cpp-options: -DWITH_POSTGRESQL
 
   if flag(mysql)
     build-depends:
         mysql-simple          >= 0.2.2.3
       , mysql                 >= 0.1.1.3
-      , persistent-mysql      >= 1.2.0
+      , persistent-mysql      >= 2.0
 
     cpp-options: -DWITH_MYSQL

src/Database/Esqueleto.hs

@@ -90,6 +90,8 @@ module Database.Esqueleto
   , module Database.Esqueleto.Internal.PersistentImport
   ) where
 
+import Control.Monad.IO.Class (MonadIO)
+import Control.Monad.Trans.Reader (ReaderT)
 import Data.Int (Int64)
 import Database.Esqueleto.Internal.Language
 import Database.Esqueleto.Internal.Sql
@@ -373,9 +375,9 @@ import qualified Database.Persist
 
 -- | @valkey i = val (Key (PersistInt64 i))@
 -- (<https://github.com/meteficha/esqueleto/issues/9>).
-valkey :: Esqueleto query expr backend =>
+valkey :: (Esqueleto query expr backend, IsSqlKey (Key entity), PersistField (Key entity)) =>
           Int64 -> expr (Value (Key entity))
-valkey = val . Key . PersistInt64
+valkey = val . toSqlKey
 
 
 -- | @valJ@ is like @val@ but for something that is already a @Value@. The use
@@ -388,7 +390,7 @@ valkey = val . Key . PersistInt64
 -- (<https://github.com/prowdsponsor/esqueleto/pull/69>).
 --
 -- /Since: 1.4.2/
-valJ :: Esqueleto query expr backend =>
+valJ :: (Esqueleto query expr backend, PersistField (Key entity)) =>
         Value (Key entity) -> expr (Value (Key entity))
 valJ = val . unValue
 
@@ -398,8 +400,8 @@ valJ = val . unValue
 
 -- | Synonym for 'Database.Persist.Store.delete' that does not
 -- clash with @esqueleto@'s 'delete'.
-deleteKey :: ( PersistStore m
+deleteKey :: ( PersistStore (PersistEntityBackend val)
-             , PersistMonadBackend m ~ PersistEntityBackend val
+             , MonadIO m
              , PersistEntity val )
-          => Key val -> m ()
+          => Key val -> ReaderT (PersistEntityBackend val) m ()
 deleteKey = Database.Persist.delete

src/Database/Esqueleto/Internal/PersistentImport.hs

@@ -9,4 +9,5 @@ import Database.Persist.Sql hiding
   , Update(..), delete, deleteWhereCount, updateWhereCount, selectList
   , selectKeysList, deleteCascadeWhere, (=.), (+=.), (-=.), (*=.), (/=.)
   , (==.), (!=.), (<.), (>.), (<=.), (>=.), (<-.), (/<-.), (||.)
-  , listToJSON, mapToJSON, getPersistMap, limitOffsetOrder )
+  , listToJSON, mapToJSON, getPersistMap, limitOffsetOrder, selectSource
+  , update )

src/Database/Esqueleto/Internal/Sql.hs

@@ -48,10 +48,10 @@ module Database.Esqueleto.Internal.Sql
 import Control.Applicative (Applicative(..), (<$>), (<$))
 import Control.Arrow ((***), first)
 import Control.Exception (throw, throwIO)
-import Control.Monad ((>=>), ap, void, MonadPlus(..))
+import Control.Monad (ap, MonadPlus(..), liftM)
 import Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.Trans.Class (lift)
-import Control.Monad.Trans.Resource (MonadResource)
+import qualified Control.Monad.Trans.Reader as R
 import Data.Int (Int64)
 import Data.List (intersperse)
 import Data.Monoid (Monoid(..), (<>))
@@ -65,6 +65,8 @@ import qualified Data.HashSet as HS
 import qualified Data.Text as T
 import qualified Data.Text.Lazy as TL
 import qualified Data.Text.Lazy.Builder as TLB
+import Data.Acquire (with, allocateAcquire, Acquire)
+import Control.Monad.Trans.Resource (MonadResource)
 
 import Database.Esqueleto.Internal.Language
 
@@ -111,7 +113,7 @@ instance Monoid SideData where
 
 -- | A part of a @FROM@ clause.
 data FromClause =
-    FromStart Ident (EntityDef SqlType)
+    FromStart Ident EntityDef
   | FromJoin FromClause JoinKind FromClause (Maybe (SqlExpr (Value Bool)))
   | OnClause (SqlExpr (Value Bool))
 
@@ -544,19 +546,20 @@ veryUnsafeCoerceSqlExprValueList EEmptyList =
 -- | (Internal) Execute an @esqueleto@ @SELECT@ 'SqlQuery' inside
 -- @persistent@'s 'SqlPersistT' monad.
 rawSelectSource :: ( SqlSelect a r
-                   , MonadResource m
+                   , MonadIO m1
-                   , MonadSqlPersist m )
+                   , MonadIO m2 )
                  => Mode
                  -> SqlQuery a
-                 -> m (C.Source m r)
+                 -> SqlPersistT m1 (Acquire (C.Source m2 r))
-rawSelectSource mode query = src
+rawSelectSource mode query =
+      do
+        conn <- R.ask
+        res <- run conn
+        return $ (C.$= massage) `fmap` res
     where
-      src = do
-        conn <- askSqlConn
-        return $ run conn C.$= massage
 
       run conn =
-        uncurry rawQuery $
+        uncurry rawQueryRes $
         first builderToText $
         toRawSql mode (conn, initialIdentState) query
 
@@ -573,11 +576,14 @@ rawSelectSource mode query = src
 -- | Execute an @esqueleto@ @SELECT@ query inside @persistent@'s
 -- 'SqlPersistT' monad and return a 'C.Source' of rows.
 selectSource :: ( SqlSelect a r
-                , MonadResource m
+                , MonadResource m )
-                , MonadSqlPersist m )
              => SqlQuery a
-             -> m (C.Source m r)
+             -> C.Source (SqlPersistT m) r
-selectSource = rawSelectSource SELECT
+selectSource query = do
+    src <- lift $ do
+        res <- rawSelectSource SELECT query
+        fmap snd $ allocateAcquire res
+    src
 
 
 -- | Execute an @esqueleto@ @SELECT@ query inside @persistent@'s
@@ -622,10 +628,12 @@ selectSource = rawSelectSource SELECT
 -- function composition that the @p@ inside the query is of type
 -- @SqlExpr (Entity Person)@.
 select :: ( SqlSelect a r
-          , MonadResource m
+          , MonadIO m )
-          , MonadSqlPersist m )
+       => SqlQuery a -> SqlPersistT m [r]
-       => SqlQuery a -> m [r]
+select query = do
-select = selectSource >=> runSource
+    res <- rawSelectSource SELECT query
+    conn <- R.ask
+    liftIO $ with res $ flip R.runReaderT conn . runSource
 
 
 -- | Execute an @esqueleto@ @SELECT DISTINCT@ query inside
@@ -633,26 +641,31 @@ select = selectSource >=> runSource
 -- rows.
 selectDistinctSource
   :: ( SqlSelect a r
-     , MonadResource m
+     , MonadResource m )
-     , MonadSqlPersist m )
   => SqlQuery a
-  -> m (C.Source m r)
+  -> C.Source (SqlPersistT m) r
-selectDistinctSource = rawSelectSource SELECT_DISTINCT
+selectDistinctSource query = do
+    src <- lift $ do
+        res <- rawSelectSource SELECT_DISTINCT query
+        fmap snd $ allocateAcquire res
+    src
 
 
 -- | Execute an @esqueleto@ @SELECT DISTINCT@ query inside
 -- @persistent@'s 'SqlPersistT' monad and return a list of rows.
 selectDistinct :: ( SqlSelect a r
-                  , MonadResource m
+                  , MonadIO m )
-                  , MonadSqlPersist m )
+               => SqlQuery a -> SqlPersistT m [r]
-               => SqlQuery a -> m [r]
+selectDistinct query = do
-selectDistinct = selectDistinctSource >=> runSource
+    res <- rawSelectSource SELECT_DISTINCT query
+    conn <- R.ask
+    liftIO $ with res $ flip R.runReaderT conn . runSource
 
 
 -- | (Internal) Run a 'C.Source' of rows.
-runSource :: MonadResource m =>
+runSource :: Monad m =>
-             C.Source m r
+             C.Source (SqlPersistT m) r
-          -> m [r]
+          -> SqlPersistT m [r]
 runSource src = src C.$$ CL.consume
 
 
@@ -661,14 +674,12 @@ runSource src = src C.$$ CL.consume
 
 -- | (Internal) Execute an @esqueleto@ statement inside
 -- @persistent@'s 'SqlPersistT' monad.
-rawEsqueleto :: ( MonadResource m
+rawEsqueleto :: ( MonadIO m, SqlSelect a r )
-                , MonadSqlPersist m
-                , SqlSelect a r )
            => Mode
            -> SqlQuery a
-           -> m Int64
+           -> SqlPersistT m Int64
 rawEsqueleto mode query = do
-  conn <- askSqlConn
+  conn <- R.ask
   uncurry rawExecuteCount $
     first builderToText $
     toRawSql mode (conn, initialIdentState) query
@@ -696,18 +707,16 @@ rawEsqueleto mode query = do
 -- from $ \\(appointment :: SqlExpr (Entity Appointment)) ->
 -- return ()
 -- @
-delete :: ( MonadResource m
+delete :: ( MonadIO m )
-          , MonadSqlPersist m )
        => SqlQuery ()
-       -> m ()
+       -> SqlPersistT m ()
-delete = void . deleteCount
+delete = liftM (const ()) . deleteCount
 
 
 -- | Same as 'delete', but returns the number of rows affected.
-deleteCount :: ( MonadResource m
+deleteCount :: ( MonadIO m )
-               , MonadSqlPersist m )
             => SqlQuery ()
-            -> m Int64
+            -> SqlPersistT m Int64
 deleteCount = rawEsqueleto DELETE
 
 
@@ -723,42 +732,21 @@ deleteCount = rawEsqueleto DELETE
 -- set p [ PersonAge =. just (val thisYear) -. p ^. PersonBorn ]
 -- where_ $ isNothing (p ^. PersonAge)
 -- @
-update :: ( MonadResource m
+update :: ( MonadIO m
-          , MonadSqlPersist m
           , SqlEntity val )
        => (SqlExpr (Entity val) -> SqlQuery ())
-       -> m ()
+       -> SqlPersistT m ()
-update = void . updateCount
+update = liftM (const ()) . updateCount
 
 
 -- | Same as 'update', but returns the number of rows affected.
-updateCount :: ( MonadResource m
+updateCount :: ( MonadIO m
-               , MonadSqlPersist m
                , SqlEntity val )
             => (SqlExpr (Entity val) -> SqlQuery ())
-            -> m Int64
+            -> SqlPersistT m Int64
 updateCount = rawEsqueleto UPDATE . from
 
 
--- | Insert a 'PersistField' for every selected value.
-insertSelect :: ( MonadResource m
-                , MonadSqlPersist m
-                , PersistEntity a )
-             => SqlQuery (SqlExpr (Insertion a)) -> m ()
-insertSelect =
-  void . rawEsqueleto (INSERT_INTO SELECT) . fmap EInsertFinal
-
-
--- | Insert a 'PersistField' for every unique selected value.
-insertSelectDistinct
-  :: ( MonadResource m
-     , MonadSqlPersist m
-     , PersistEntity a )
-  => SqlQuery (SqlExpr (Insertion a)) -> m ()
-insertSelectDistinct =
-  void . rawEsqueleto (INSERT_INTO SELECT_DISTINCT) . fmap EInsertFinal
-
-
 ----------------------------------------------------------------------
 
 
@@ -1515,3 +1503,21 @@ from16P = const Proxy
 
 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,l,m,n,o,p)
 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,l,m,n,o,p)
+
+
+-- | Insert a 'PersistField' for every selected value.
+insertSelect :: (MonadIO m, PersistEntity a) =>
+  SqlQuery (SqlExpr (Insertion a)) -> SqlPersistT m ()
+insertSelect = insertGeneralSelect SELECT
+
+
+-- | 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

test/Test.hs

@@ -20,6 +20,7 @@ import Control.Monad (replicateM, replicateM_)
 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 Database.Esqueleto
 #if   defined (WITH_POSTGRESQL)
 import Database.Persist.Postgresql (withPostgresqlConn)
@@ -865,10 +866,10 @@ main = do
 
 
 insert' :: ( Functor m
-           , PersistStore m
+           , PersistStore (PersistEntityBackend val)
-           , PersistMonadBackend m ~ PersistEntityBackend val
+           , MonadIO m
            , PersistEntity val )
-        => val -> m (Entity val)
+        => val -> ReaderT (PersistEntityBackend val) m (Entity val)
 insert' v = flip Entity v <$> insert v