Refactor

package.yaml

@@ -26,13 +26,13 @@ library:
     - monad-logger >= 0.3.29 && < 0.4
     - mtl >= 2.2.2 && < 2.3
     - persistent >= 2.8.2 && < 2.14
-    - resource-pool >= 0.2.3.2 && < 0.3
+    - resource-pool >= 0.2.3.2 && < 0.5
     - resourcet >= 1.2.1 && < 1.3
     - text >= 1.2.3.0 && < 1.3
     - transformers >= 0.5.2.0 && < 0.6
     - unliftio >= 0.2.7.0 && < 0.3
     - unliftio-core >= 0.1.2.0 && < 0.3
-    - unliftio-pool >= 0.2.0.0 && < 0.3
+    - unliftio-pool >= 0.2.0.0 && < 0.5
 
 tests:
   persistent-mtl-test:

persistent-mtl.cabal

@@ -1,6 +1,6 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.34.4.
+-- This file has been generated from package.yaml by hpack version 0.35.2.
 --
 -- see: https://github.com/sol/hpack
 
@@ -35,6 +35,8 @@ library
       Control.Monad.IO.Rerunnable
       Database.Persist.Monad
       Database.Persist.Monad.Class
+      Database.Persist.Monad.Orphan.QueryLift
+      Database.Persist.Monad.Orphan.TransactionLift
       Database.Persist.Monad.Shim
       Database.Persist.Monad.SqlQueryRep
       Database.Persist.Monad.TestUtils
@@ -51,13 +53,13 @@ library
     , monad-logger >=0.3.29 && <0.4
     , mtl >=2.2.2 && <2.3
     , persistent >=2.8.2 && <2.14
-    , resource-pool >=0.2.3.2 && <0.3
+    , resource-pool >=0.2.3.2 && <0.5
     , resourcet >=1.2.1 && <1.3
     , text >=1.2.3.0 && <1.3
     , transformers >=0.5.2.0 && <0.6
     , unliftio >=0.2.7.0 && <0.3
     , unliftio-core >=0.1.2.0 && <0.3
-    , unliftio-pool >=0.2.0.0 && <0.3
+    , unliftio-pool >=0.2.0.0 && <0.5
   default-language: Haskell2010
 
 test-suite persistent-mtl-test

scripts/generate/persistent-api.yaml

@@ -479,11 +479,6 @@
     - 'Migration'
   result: '[Text]'
 
-- name: runMigrationSilent
-  args:
-    - 'Migration'
-  result: '[Text]'
-
 - name: runMigrationUnsafe
   args:
     - 'Migration'

scripts/generate/templates/Shim.mustache

@@ -1,7 +1,9 @@
 {-|
 Module: Database.Persist.Monad.Shim
 
-Defines all the @persistent@ functions lifted into 'MonadSqlQuery'.
+Defines all the @persistent@ functions lifted into 'MonadSqlQuery', and
+re-exports a version of the @Database.Persist.Sql@ module replacing each
+function with the lifted version.
 
 This file is autogenerated, to keep it in sync with
 @Database.Persist.Monad.SqlQueryRep@.
@@ -15,7 +17,15 @@ This file is autogenerated, to keep it in sync with
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
 
-module Database.Persist.Monad.Shim where
+module Database.Persist.Monad.Shim (
+  module Database.Persist.Sql,
+  {{#functions}}
+  {{#withCondition}}
+  {{{name}}},
+  {{/withCondition}}
+  {{/functions}}
+  unsafeLiftSql,
+  ) where
 
 import Control.Monad.IO.Class (MonadIO)
 import Control.Monad.Trans.Class (lift)
@@ -27,10 +37,17 @@ import Data.Map (Map)
 import Data.Text (Text)
 import Data.Typeable (Typeable)
 import Data.Void (Void)
-import Database.Persist.Sql hiding (pattern Update)
+import Database.Persist.Sql hiding (
+  {{#functions}}
+  {{#withCondition}}
+  {{{name}}},
+  {{/withCondition}}
+  {{/functions}}
+  pattern Update
+  )
 import GHC.Stack (HasCallStack)
 
-import Database.Persist.Monad.Class (MonadSqlQuery(..))
+import Database.Persist.Monad.Class (MonadSqlQuery, runCompatibleQueryRep)
 import Database.Persist.Monad.SqlQueryRep (SqlQueryRep(..))
 
 {-# ANN module "HLint: ignore" #-}
@@ -42,10 +59,10 @@ import Database.Persist.Monad.SqlQueryRep (SqlQueryRep(..))
   :: ({{#constraints}}{{{type}}}, {{/constraints}}{{#recordTypeVars}}Typeable {{.}}, {{/recordTypeVars}}MonadSqlQuery m)
   => {{#args}}{{{type}}} -> {{/args}}{{result}}
 {{#conduitFrom?}}
-{{{name}}} {{#args}}a{{index}} {{/args}}= fromAcquire $ runQueryRep $ {{{conduitFrom.nameCapital}}}{{#args}} a{{index}}{{/args}}
+{{{name}}} {{#args}}a{{index}} {{/args}}= fromAcquire $ runCompatibleQueryRep $ {{{conduitFrom.nameCapital}}}{{#args}} a{{index}}{{/args}}
 {{/conduitFrom?}}
 {{^conduitFrom?}}
-{{{name}}} {{#args}}a{{index}} {{/args}}= runQueryRep $ {{{nameCapital}}}{{#args}} a{{index}}{{/args}}
+{{{name}}} {{#args}}a{{index}} {{/args}}= runCompatibleQueryRep $ {{{nameCapital}}}{{#args}} a{{index}}{{/args}}
 {{/conduitFrom?}}
 {{/withCondition}}
 
@@ -64,7 +81,7 @@ import Database.Persist.Monad.SqlQueryRep (SqlQueryRep(..))
 -- select q = unsafeLiftSql "esqueleto-select" (E.select q)
 -- @
 unsafeLiftSql :: MonadSqlQuery m => Text -> (forall m2. MonadIO m2 => SqlPersistT m2 a) -> m a
-unsafeLiftSql label action = runQueryRep $ UnsafeLiftSql label action
+unsafeLiftSql label action = runCompatibleQueryRep $ UnsafeLiftSql label action
 
 {- Helpers -}
 

scripts/generate/templates/SqlQueryRep.mustache

@@ -12,20 +12,25 @@ This file is autogenerated, to keep it in sync with
 
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 
 module Database.Persist.Monad.SqlQueryRep
-  ( SqlQueryRep(..)
+  ( QueryRepCompatible(..)
+  , withCompatibleQueryRep
+  , SqlQueryRep(..)
   , runSqlQueryRep
   ) where
 
 import Control.Monad.IO.Class (MonadIO)
-import Control.Monad.IO.Unlift (MonadUnliftIO)
 import Data.Acquire (Acquire)
 import Data.Conduit (ConduitM)
 import Data.Int (Int64)
@@ -40,6 +45,33 @@ import GHC.Stack (HasCallStack)
 
 {-# ANN module "HLint: ignore" #-}
 
+-- | Class of compatible query representations.
+--
+-- If @'QueryRepCompatible' sup sub@, then queries in @sup@ can also
+-- represented as queries in @sub@ - so @sub@ must be at least as detailed
+-- as @sup@ in representing queries.
+--
+-- This is the equivalent to Persistent's 'BackendCompatible', but for query
+-- representations
+class QueryRepCompatible sup sub where
+  projectQueryRep :: sup record a -> sub record a
+
+instance QueryRepCompatible q q where
+  projectQueryRep = id
+
+-- | Run a function expecting a particular 'QueryRep' type using a compatible type
+-- instead. This allows for "lifting" functions from the base @sub@ 'QueryRep' to
+-- the more-powerful @sup@ 'QueryRep'.
+--
+-- This is the equivalent to Persistent's 'withCompatibleBackend', using our
+-- notion of compatiblity ('QueryRepCompatible').
+withCompatibleQueryRep
+  :: QueryRepCompatible sup sub
+  => (sub record a -> b)
+  -> sup record a
+  -> b
+withCompatibleQueryRep = (. projectQueryRep)
+
 -- | The data type containing a constructor for each persistent function we'd
 -- like to lift into 'Database.Persist.Monad.MonadSqlQuery'.
 --
@@ -81,7 +113,7 @@ instance Typeable record => Show (SqlQueryRep record a) where
 
 -- | A helper to execute the actual @persistent@ function corresponding to
 -- each 'SqlQueryRep' data constructor.
-runSqlQueryRep :: MonadUnliftIO m => SqlQueryRep record a -> Persist.SqlPersistT m a
+runSqlQueryRep :: MonadIO m => SqlQueryRep record a -> Persist.SqlPersistT m a
 runSqlQueryRep = \case
 {{#sqlQueryRepConstructors}}
 {{#withCondition}}

src/Database/Persist/Monad.hs

@@ -52,7 +52,10 @@ myFunction = do
 module Database.Persist.Monad
   (
   -- * Type class for executing database queries
-    MonadSqlQuery
+    MonadQuery
+  , MonadSqlQuery
+  , MonadTransaction
+  , MonadSqlTransaction
   , withTransaction
 
   -- * SqlQueryT monad transformer
@@ -81,7 +84,6 @@ import Control.Monad.Reader.Class (MonadReader(..))
 import Control.Monad.Trans.Class (MonadTrans(..))
 import Control.Monad.Trans.Resource (MonadResource)
 import Data.Pool (Pool)
-import Database.Persist.Sql (SqlBackend, SqlPersistT, runSqlConn)
 import qualified GHC.TypeLits as GHC
 import UnliftIO.Concurrent (threadDelay)
 import UnliftIO.Exception (Exception, SomeException, catchJust, throwIO)
@@ -117,14 +119,16 @@ instance
   => MonadIO (SqlTransaction m) where
   liftIO = undefined
 
-instance (MonadSqlQuery m, MonadUnliftIO m) => MonadSqlQuery (SqlTransaction m) where
+instance MonadTransaction m => MonadTransaction (SqlTransaction m) where
   type TransactionM (SqlTransaction m) = TransactionM m
 
-  runQueryRep = SqlTransaction . runSqlQueryRep
-
   -- Delegate to 'm', since 'm' is in charge of starting/stopping transactions.
   -- 'SqlTransaction' is ONLY in charge of executing queries.
-  withTransaction = SqlTransaction . withTransaction
+  withTransaction = SqlTransaction . lift . withTransaction
+
+instance (MonadSqlQuery m, MonadUnliftIO m) => MonadQuery (SqlTransaction m) where
+  type QueryRep (SqlTransaction m) = SqlQueryRep
+  runQueryRep = SqlTransaction . runSqlQueryRep
 
 runSqlTransaction :: MonadUnliftIO m => SqlBackend -> SqlTransaction m a -> m a
 runSqlTransaction conn = (`runSqlConn` conn) . unSqlTransaction
@@ -199,12 +203,9 @@ newtype SqlQueryT m a = SqlQueryT
     , MonadLogger
     )
 
-instance MonadUnliftIO m => MonadSqlQuery (SqlQueryT m) where
+instance MonadUnliftIO m => MonadTransaction (SqlQueryT m) where
   type TransactionM (SqlQueryT m) = SqlTransaction (SqlQueryT m)
 
-  -- Running a query directly in SqlQueryT will create a one-off transaction.
-  runQueryRep = withTransaction . runQueryRep
-
   -- Start a new transaction and run the given 'SqlTransaction'
   withTransaction m = do
     SqlQueryEnv{..} <- SqlQueryT ask
@@ -218,6 +219,13 @@ instance MonadUnliftIO m => MonadSqlQuery (SqlQueryT m) where
               else throwIO RetryLimitExceeded
       in loop 0
 
+
+instance MonadUnliftIO m => MonadQuery (SqlQueryT m) where
+  type QueryRep (SqlQueryT m) = SqlQueryRep
+
+  -- Running a query directly in SqlQueryT will create a one-off transaction.
+  runQueryRep = withTransaction . runQueryRep
+
 instance MonadUnliftIO m => MonadUnliftIO (SqlQueryT m) where
   withRunInIO = wrappedWithRunInIO SqlQueryT unSqlQueryT