groundhog 0.7.0.3 → 0.8

raw patch · 10 files changed

+518/−478 lines, 10 filesdep +resourcetdep −monad-loggerdep ~basedep ~transformersPVP ok

version bump matches the API change (PVP)

Dependencies added: resourcet

Dependencies removed: monad-logger

Dependency ranges changed: base, transformers

API changes (from Hackage documentation)

Files

• Database/Groundhog.hs +2/−2
• Database/Groundhog/Core.hs +114/−116
• Database/Groundhog/Expression.hs +45/−38
• Database/Groundhog/Generic.hs +71/−66
• Database/Groundhog/Generic/Migration.hs +27/−27
• Database/Groundhog/Generic/PersistBackendHelpers.hs +111/−101
• Database/Groundhog/Generic/Sql.hs +3/−4
• Database/Groundhog/Instances.hs +134/−118
• changelog +5/−0
• groundhog.cabal +6/−6

@@ -5,7 +5,7 @@ module Database.Groundhog (   -- * Core datatypes and functions     PersistBackend(..)-  , DbPersist(..)+  , PersistBackendConn(..)   , Key   , DefaultKey   , AutoKey@@ -38,7 +38,7 @@   , printMigration ) where -import Database.Groundhog.Core+import Database.Groundhog.Core hiding (selectStream, selectAllStream, projectStream) import Database.Groundhog.Expression import Database.Groundhog.Generic import Database.Groundhog.Instances

@@ -1,9 +1,12 @@-{-# LANGUAGE GADTs, TypeFamilies, ExistentialQuantification, MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, EmptyDataDecls, ConstraintKinds, CPP #-}+{-# LANGUAGE GADTs, TypeFamilies, ExistentialQuantification, MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, EmptyDataDecls, ConstraintKinds, CPP, LiberalTypeSynonyms #-} {-# LANGUAGE UndecidableInstances #-} -- Required for Projection'+#if __GLASGOW_HASKELL__ >= 800+{-# LANGUAGE UndecidableSuperClasses #-}+#endif -- | This module defines the functions and datatypes used throughout the framework. -- Most of them are for the internal use module Database.Groundhog.Core-  ( +  (   -- * Main types     PersistEntity(..)   , PersistValue(..)@@ -73,34 +76,35 @@   , Migration   -- * Database   , PersistBackend(..)+  , PersistBackendConn(..)+  , Action+  , RowStream   , DbDescriptor(..)-  , RowPopper-  , DbPersist(..)+  , DbPersist   , runDbPersist   -- * Connections and transactions+  , ExtractConnection(..)   , ConnectionManager(..)-  , SingleConnectionManager   , Savepoint(..)+  , withSavepoint+  , runDb+  , runDbConn+  , runDb'+  , runDbConn'   ) where  import Blaze.ByteString.Builder (Builder, fromByteString, toByteString) import Control.Applicative (Applicative)-import Control.Monad.Base (MonadBase (liftBase))-import Control.Monad.Logger (MonadLogger(..))-import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.IO.Class (MonadIO(..))-import Control.Monad.Trans.Control (MonadBaseControl (..), ComposeSt, defaultLiftBaseWith, defaultRestoreM, MonadTransControl (..))-import Control.Monad.Trans.Reader (ReaderT(..), runReaderT, mapReaderT)-import Control.Monad.Trans.State (StateT)+import Control.Monad.Trans.Control (MonadBaseControl (..))+import Control.Monad.Trans.Reader (ReaderT(..), runReaderT)+import Control.Monad.Trans.State (StateT(..)) import Control.Monad.Reader (MonadReader(..))-import Control.Monad (liftM)-import qualified Control.Monad.Cont.Class as Mtl-import qualified Control.Monad.Error.Class as Mtl-import qualified Control.Monad.State.Class as Mtl-import qualified Control.Monad.Writer.Class as Mtl+import Data.Acquire (Acquire) import Data.ByteString.Char8 (ByteString) import Data.Int (Int64) import Data.Map (Map)+import Data.Text (Text) import Data.Time (Day, TimeOfDay, UTCTime) import Data.Time.LocalTime (ZonedTime, zonedTimeToUTC, zonedTimeToLocalTime, zonedTimeZone) import GHC.Exts (Constraint)@@ -126,7 +130,7 @@   -- | Constructs the value from the list of 'PersistValue'   fromEntityPersistValues :: PersistBackend m => [PersistValue] -> m (v, [PersistValue])   -- | Returns constructor number and a list of uniques names and corresponding field values-  getUniques :: DbDescriptor db => proxy db -> v -> (Int, [(String, [PersistValue] -> [PersistValue])])+  getUniques :: v -> (Int, [(String, [PersistValue] -> [PersistValue])])   -- | Is internally used by FieldLike Field instance   -- We could avoid this function if class FieldLike allowed FieldLike Fields Data or FieldLike (Fields Data). However that would require additional extensions in user-space code   entityFieldChain :: DbDescriptor db => proxy db -> Field v c a -> FieldChain@@ -255,63 +259,11 @@ distinct :: (HasSelectOptions a db r, HasDistinct a ~ HFalse) => a -> SelectOptions db r (HasLimit a) (HasOffset a) (HasOrder a) HTrue distinct opts = (getSelectOptions opts) {distinctOptions = True} -newtype DbPersist conn m a = DbPersist { unDbPersist :: ReaderT conn m a }-  deriving (Monad, MonadIO, Functor, Applicative, MonadTrans, MonadReader conn)--instance MonadBase IO m => MonadBase IO (DbPersist conn m) where-  liftBase = lift . liftBase--instance MonadTransControl (DbPersist conn) where-#if MIN_VERSION_monad_control(1, 0, 0)-  type StT (DbPersist conn) a = StT (ReaderT conn) a-  liftWith f = DbPersist $ ReaderT $ \r -> f $ \t -> runReaderT (unDbPersist t) r-  restoreT = DbPersist . ReaderT . const-#else-  newtype StT (DbPersist conn) a = StReader {unStReader :: a}-  liftWith f = DbPersist $ ReaderT $ \r -> f $ \t -> liftM StReader $ runReaderT (unDbPersist t) r-  restoreT = DbPersist . ReaderT . const . liftM unStReader-#endif--instance MonadBaseControl IO m => MonadBaseControl IO (DbPersist conn m) where-#if MIN_VERSION_monad_control(1, 0, 0)-  type StM (DbPersist conn m) a = ComposeSt (DbPersist conn) m a-  liftBaseWith = defaultLiftBaseWith-  restoreM     = defaultRestoreM-#else-  newtype StM (DbPersist conn m) a = StMSP {unStMSP :: ComposeSt (DbPersist conn) m a}-  liftBaseWith = defaultLiftBaseWith StMSP-  restoreM     = defaultRestoreM   unStMSP-#endif--instance MonadLogger m => MonadLogger (DbPersist conn m) where-  monadLoggerLog a b c = lift . monadLoggerLog a b c+{-# DEPRECATED DbPersist, runDbPersist "Use `PersistBackend` constraint instead. If you need to specify a backend, add (PersistBackend m, Conn m ~ Postgresql) " #-}+type DbPersist = ReaderT  runDbPersist :: Monad m => DbPersist conn m a -> conn -> m a-runDbPersist = runReaderT . unDbPersist--mapDbPersist :: (m a -> n b) -> DbPersist conn m a -> DbPersist conn n b-mapDbPersist f m = DbPersist $ mapReaderT f $ unDbPersist m--instance Mtl.MonadWriter w m => Mtl.MonadWriter w (DbPersist conn m) where-  writer = lift . Mtl.writer-  tell = lift . Mtl.tell-  listen = mapDbPersist Mtl.listen-  pass = mapDbPersist Mtl.pass--instance Mtl.MonadError e m => Mtl.MonadError e (DbPersist conn m) where-  throwError = lift . Mtl.throwError-  catchError m h = DbPersist $ Mtl.catchError (unDbPersist m) (unDbPersist . h)--instance Mtl.MonadCont m => Mtl.MonadCont (DbPersist conn m) where-  callCC = liftCallCC Mtl.callCC where-    liftCallCC callCC f = DbPersist $ ReaderT $ \ r ->-      callCC $ \ c ->-      runDbPersist (f (DbPersist . ReaderT . const . c)) r--instance Mtl.MonadState s m => Mtl.MonadState s (DbPersist conn m) where-  get = lift Mtl.get-  put = lift . Mtl.put-  state = lift . Mtl.state+runDbPersist = runReaderT  class PrimitivePersistField (AutoKeyType db) => DbDescriptor db where   -- | Type of the database default autoincremented key. For example, Sqlite has Int64@@ -321,66 +273,73 @@   -- | Name of backend   backendName :: proxy db -> String -class (Monad m, DbDescriptor (PhantomDb m)) => PersistBackend m where-  -- | A token which defines the DB type. For example, different monads working with Sqlite, return may Sqlite type.-  type PhantomDb m+class (DbDescriptor conn, ConnectionManager conn) => PersistBackendConn conn where   -- | Insert a new record to a database and return its autogenerated key or ()-  insert        :: PersistEntity v => v -> m (AutoKey v)+  insert        :: (PersistEntity v, PersistBackend m, Conn m ~ conn) => v -> m (AutoKey v)   -- | Insert a new record to a database. For some backends it may be faster than 'insert'.-  insert_       :: PersistEntity v => v -> m ()+  insert_       :: (PersistEntity v, PersistBackend m, Conn m ~ conn) => v -> m ()   -- | Try to insert a record and return Right newkey. If there is a constraint violation for the given constraint, Left oldkey is returned   -- , where oldkey is an identifier of the record with the matching values.-  insertBy      :: (PersistEntity v, IsUniqueKey (Key v (Unique u))) => u (UniqueMarker v) -> v -> m (Either (AutoKey v) (AutoKey v))+  insertBy      :: (PersistEntity v, IsUniqueKey (Key v (Unique u)), PersistBackend m, Conn m ~ conn) => u (UniqueMarker v) -> v -> m (Either (AutoKey v) (AutoKey v))   -- | Try to insert a record and return Right newkey. If there is a constraint violation for any constraint, Left oldkey is returned   -- , where oldkey is an identifier of the record with the matching values. Note that if several constraints are violated, a key of an arbitrary matching record is returned.-  insertByAll   :: PersistEntity v => v -> m (Either (AutoKey v) (AutoKey v))+  insertByAll   :: (PersistEntity v, PersistBackend m, Conn m ~ conn) => v -> m (Either (AutoKey v) (AutoKey v))   -- | Replace a record with the given autogenerated key. Result is undefined if the record does not exist.-  replace       :: (PersistEntity v, PrimitivePersistField (Key v BackendSpecific)) => Key v BackendSpecific -> v -> m ()+  replace       :: (PersistEntity v, PrimitivePersistField (Key v BackendSpecific), PersistBackend m, Conn m ~ conn) => Key v BackendSpecific -> v -> m ()   -- | Replace a record. The unique key marker defines what unique key of the entity is used.-  replaceBy     :: (PersistEntity v, IsUniqueKey (Key v (Unique u))) => u (UniqueMarker v) -> v -> m ()+  replaceBy     :: (PersistEntity v, IsUniqueKey (Key v (Unique u)), PersistBackend m, Conn m ~ conn) => u (UniqueMarker v) -> v -> m ()   -- | Return a list of the records satisfying the condition. Example: @select $ (FirstField ==. \"abc\" &&. SecondField >. \"def\") \`orderBy\` [Asc ThirdField] \`limitTo\` 100@-  select        :: (PersistEntity v, EntityConstr v c, HasSelectOptions opts (PhantomDb m) (RestrictionHolder v c))-                => opts -> m [v]+  select        :: (PersistEntity v, EntityConstr v c, HasSelectOptions opts conn (RestrictionHolder v c), PersistBackend m, Conn m ~ conn)+                  => opts -> m [v]+  -- | Return a list of the records satisfying the condition. Example: @select $ (FirstField ==. \"abc\" &&. SecondField >. \"def\") \`orderBy\` [Asc ThirdField] \`limitTo\` 100@+  selectStream  :: (PersistEntity v, EntityConstr v c, HasSelectOptions opts conn (RestrictionHolder v c), PersistBackend m, Conn m ~ conn)+                => opts -> m (RowStream v)   -- | Return a list of all records. Order is undefined. It can be useful for datatypes with multiple constructors.-  selectAll     :: PersistEntity v => m [(AutoKey v, v)]+  selectAll     :: (PersistEntity v, PersistBackend m, Conn m ~ conn) => m [(AutoKey v, v)]+  -- | Return a list of all records. Order is undefined. It can be useful for datatypes with multiple constructors.+  selectAllStream :: (PersistEntity v, PersistBackend m, Conn m ~ conn) => m (RowStream (AutoKey v, v))   -- | Fetch an entity from a database-  get           :: (PersistEntity v, PrimitivePersistField (Key v BackendSpecific)) => Key v BackendSpecific -> m (Maybe v)+  get           :: (PersistEntity v, PrimitivePersistField (Key v BackendSpecific), PersistBackend m, Conn m ~ conn) => Key v BackendSpecific -> m (Maybe v)   -- | Fetch an entity from a database by its unique key-  getBy         :: (PersistEntity v, IsUniqueKey (Key v (Unique u))) => Key v (Unique u) -> m (Maybe v)+  getBy         :: (PersistEntity v, IsUniqueKey (Key v (Unique u)), PersistBackend m, Conn m ~ conn) => Key v (Unique u) -> m (Maybe v)   -- | Update the records satisfying the condition. Example: @update [FirstField =. \"abc\"] $ FirstField ==. \"def\"@-  update        :: (PersistEntity v, EntityConstr v c) => [Update (PhantomDb m) (RestrictionHolder v c)] -> Cond (PhantomDb m) (RestrictionHolder v c) -> m ()+  update        :: (PersistEntity v, EntityConstr v c, PersistBackend m, Conn m ~ conn) => [Update conn (RestrictionHolder v c)] -> Cond conn (RestrictionHolder v c) -> m ()   -- | Remove the records satisfying the condition-  delete        :: (PersistEntity v, EntityConstr v c) => Cond (PhantomDb m) (RestrictionHolder v c) -> m ()+  delete        :: (PersistEntity v, EntityConstr v c, PersistBackend m, Conn m ~ conn) => Cond conn (RestrictionHolder v c) -> m ()   -- | Remove the record with given key. No-op if the record does not exist-  deleteBy      :: (PersistEntity v, PrimitivePersistField (Key v BackendSpecific)) => Key v BackendSpecific -> m ()+  deleteBy      :: (PersistEntity v, PrimitivePersistField (Key v BackendSpecific), PersistBackend m, Conn m ~ conn) => Key v BackendSpecific -> m ()   -- | Remove all records. The entity parameter is used only for type inference.-  deleteAll     :: PersistEntity v => v -> m ()+  deleteAll     :: (PersistEntity v, PersistBackend m, Conn m ~ conn) => v -> m ()   -- | Count total number of records satisfying the condition-  count         :: (PersistEntity v, EntityConstr v c) => Cond (PhantomDb m) (RestrictionHolder v c) -> m Int+  count         :: (PersistEntity v, EntityConstr v c, PersistBackend m, Conn m ~ conn) => Cond conn (RestrictionHolder v c) -> m Int   -- | Count total number of records with all constructors. The entity parameter is used only for type inference-  countAll      :: PersistEntity v => v -> m Int+  countAll      :: (PersistEntity v, PersistBackend m, Conn m ~ conn) => v -> m Int   -- | Fetch projection of some fields. Example: @project (SecondField, ThirdField) $ (FirstField ==. \"abc\" &&. SecondField >. \"def\") \`orderBy\` [Asc ThirdField] \`offsetBy\` 100@-  project       :: (PersistEntity v, EntityConstr v c, Projection' p (PhantomDb m) (RestrictionHolder v c) a, HasSelectOptions opts (PhantomDb m) (RestrictionHolder v c))+  project       :: (PersistEntity v, EntityConstr v c, Projection' p conn (RestrictionHolder v c) a, HasSelectOptions opts conn (RestrictionHolder v c), PersistBackend m, Conn m ~ conn)                 => p                 -> opts                 -> m [a]+  projectStream :: (PersistEntity v, EntityConstr v c, Projection' p conn (RestrictionHolder v c) a, HasSelectOptions opts conn (RestrictionHolder v c), PersistBackend m, Conn m ~ conn)+                => p+                -> opts+                -> m (RowStream a)   -- | Check database schema and create migrations for the entity and the entities it contains-  migrate       :: PersistEntity v => v -> Migration m+  migrate       :: (PersistEntity v, PersistBackend m, Conn m ~ conn) => v -> Migration (m)   -- | Execute raw query-  executeRaw    :: Bool           -- ^ keep in cache+  executeRaw    :: (PersistBackend m, Conn m ~ conn) => Bool           -- ^ keep in cache                 -> String         -- ^ query                 -> [PersistValue] -- ^ positional parameters                 -> m ()   -- | Execute raw query with results-  queryRaw      :: Bool           -- ^ keep in cache+  queryRaw      :: (PersistBackend m, Conn m ~ conn) => Bool           -- ^ keep in cache                 -> String         -- ^ query                 -> [PersistValue] -- ^ positional parameters-                -> (RowPopper m -> m a) -- ^ results processing function-                -> m a-  insertList    :: PersistField a => [a] -> m Int64-  getList       :: PersistField a => Int64 -> m [a]+                -> m (RowStream [PersistValue])+  insertList    :: (PersistField a, PersistBackend m, Conn m ~ conn) => [a] -> m Int64+  getList       :: (PersistField a, PersistBackend m, Conn m ~ conn) => Int64 -> m [a] -type RowPopper m = m (Maybe [PersistValue])+type Action conn = ReaderT conn IO+type RowStream a = Acquire (IO (Maybe a))  type Migration m = StateT NamedMigrations m () @@ -483,14 +442,14 @@  type DbTypePrimitive = DbTypePrimitive' String -data DbType = +data DbType =     -- | type, nullable, default value, reference       DbTypePrimitive DbTypePrimitive Bool (Maybe String) (Maybe ParentTableReference)     | DbEmbedded EmbeddedDef (Maybe ParentTableReference)     | DbList String DbType -- ^ List table name and type of its argument   deriving (Eq, Show) --- | The reference contains either EntityDef of the parent table and name of the unique constraint. Or for tables not mapped by Groundhog schema name, table name, and list of columns  +-- | The reference contains either EntityDef of the parent table and name of the unique constraint. Or for tables not mapped by Groundhog schema name, table name, and list of columns -- Reference to the autogenerated key of a mapped entity = (Left (entityDef, Nothing), onDelete, onUpdate) -- Reference to a unique key of a mapped entity = (Left (entityDef, Just uniqueKeyName), onDelete, onUpdate) -- Reference to a table that is not mapped = (Right ((schema, tableName), columns), onDelete, onUpdate)@@ -522,6 +481,7 @@ -- | A raw value which can be stored in any backend and can be marshalled to -- and from a 'PersistField'. data PersistValue = PersistString String+                  | PersistText Text                   | PersistByteString ByteString                   | PersistInt64 Int64                   | PersistDouble Double@@ -581,27 +541,65 @@  -- | Represents all datatypes that map into several columns. Getting values for those columns is pure. class PersistField a => PurePersistField a where-  toPurePersistValues :: DbDescriptor db => proxy db -> a -> ([PersistValue] -> [PersistValue])-  fromPurePersistValues :: DbDescriptor db => proxy db -> [PersistValue] -> (a, [PersistValue])+  toPurePersistValues :: a -> ([PersistValue] -> [PersistValue])+  fromPurePersistValues :: [PersistValue] -> (a, [PersistValue]) --- | Datatypes which can be converted directly to 'PersistValue'. The no-value parameter @DbDescriptor db => proxy db@ allows conversion depend the database details while keeping it pure. A type which has an instance of 'PrimitivePersistField' should be an instance of superclasses 'SinglePersistField' and 'PurePersistField' as well.+-- | Datatypes which can be converted directly to 'PersistValue' class PersistField a => PrimitivePersistField a where-  toPrimitivePersistValue :: DbDescriptor db => proxy db -> a -> PersistValue-  fromPrimitivePersistValue :: DbDescriptor db => proxy db -> PersistValue -> a+  toPrimitivePersistValue :: a -> PersistValue+  fromPrimitivePersistValue :: PersistValue -> a  delim :: Char delim = '#' --- | Connection manager provides connection to the passed function handles transations. Manager can be a connection itself, a pool, Snaplet in Snap, foundation datatype in Yesod, etc.-class ConnectionManager cm conn | cm -> conn where-  -- | Extracts the connection from manager and opens the transaction.-  withConn :: (MonadBaseControl IO m, MonadIO m) => (conn -> m a) -> cm -> m a-  -- | Extracts the connection.-  withConnNoTransaction :: (MonadBaseControl IO m, MonadIO m) => (conn -> m a) -> cm -> m a+class ExtractConnection cm conn | cm -> conn where+  -- | Extracts the connection. The connection manager can be a pool or the connection itself+  extractConn :: (MonadBaseControl IO m, MonadIO m) => (conn -> m a) -> cm -> m a --- | This connection manager always returns the same connection. This constraint is useful when performing operations which make sense only within one connection, for example, nested savepoints..-class ConnectionManager cm conn => SingleConnectionManager cm conn+-- | Connection manager provides connection to the passed function handles transations. Manager can be a connection itself, a pool, Snaplet in Snap, foundation datatype in Yesod, etc.+class ConnectionManager conn where+  -- | Opens the transaction.+  withConn :: (MonadBaseControl IO m, MonadIO m) => (conn -> m a) -> conn -> m a  class Savepoint conn where   -- | Wraps the passed action into a named savepoint   withConnSavepoint :: (MonadBaseControl IO m, MonadIO m) => String -> m a -> conn -> m a++-- | This class helps to shorten the type signatures of user monadic code.+-- If your monad has several connections, e.g., for main and audit databases, create run*Db function+-- runAuditDb :: Action conn a -> m a++class (Monad m, Applicative m, Functor m, MonadIO m, ConnectionManager (Conn m), PersistBackendConn (Conn m)) => PersistBackend m where+  type Conn m+  getConnection :: m (Conn m)++instance (Monad m, Applicative m, Functor m, MonadIO m, PersistBackendConn conn) => PersistBackend (ReaderT conn m) where+  type Conn (ReaderT conn m) = conn+  getConnection = ask++-- | It helps to run database operations within an application monad.+runDb :: PersistBackend m => Action (Conn m) a -> m a+runDb f = getConnection >>= liftIO . withConn (runReaderT f)++-- | Runs action within connection. It can handle a simple connection, a pool of them, etc.+runDbConn :: (MonadIO m, MonadBaseControl IO m, ConnectionManager conn, ExtractConnection cm conn) => Action conn a -> cm -> m a+runDbConn f cm = extractConn (liftIO . withConn (runReaderT f)) cm++-- | It helps to run database operations within an application monad. Unlike `runDb` it does not wrap action in transaction+runDb' :: PersistBackend m => Action (Conn m) a -> m a+runDb' f = getConnection >>= liftIO . runReaderT f++-- | It is similar to `runDbConn` but runs action without transaction.+--+-- @+-- flip withConn conn $ \\conn -> liftIO $ do+--   -- transaction is already opened by withConn at this point+--   someIOAction+--   runDbConn' (insert_ value) conn+-- @+runDbConn' :: (MonadIO m, MonadBaseControl IO m, ConnectionManager conn, ExtractConnection cm conn) => Action conn a -> cm -> m a+runDbConn' f cm = extractConn (liftIO . runReaderT f) cm++-- | It helps to run 'withConnSavepoint' within a monad. Make sure that transaction is open+withSavepoint :: (PersistBackend m, MonadBaseControl IO m, MonadIO m, Savepoint (Conn m)) => String -> m a -> m a+withSavepoint name m = getConnection >>= withConnSavepoint name m

@@ -1,5 +1,9 @@-{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts, FlexibleInstances, FunctionalDependencies, UndecidableInstances, OverlappingInstances, EmptyDataDecls, ConstraintKinds #-}
+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts, FlexibleInstances, FunctionalDependencies, UndecidableInstances, EmptyDataDecls, ConstraintKinds, CPP #-}
 
+#if __GLASGOW_HASKELL__ < 710
+{-# LANGUAGE OverlappingInstances #-}
+#endif
+
 -- | This module provides mechanism for flexible and typesafe usage of plain data values and fields.
 -- The expressions can used in conditions and right part of Update statement.
 -- Example:
@@ -30,76 +34,79 @@ class Expression db r a where
   toExpr :: a -> UntypedExpr db r
 
--- | This helper class can make type signatures more concise
-class (Expression db r a, PersistField a') => ExpressionOf db r a a' | a -> a'
-
-instance (Expression db r a, Normalize HTrue a (flag, a'), PersistField a') => ExpressionOf db r a a'
-
-instance PurePersistField a => Expression db r a where
-  toExpr = ExprPure
-
-instance (PersistField a, db' ~ db, r' ~ r) => Expression db' r' (Expr db r a) where
-  toExpr (Expr e) = e
-
 fieldHelper :: (FieldLike f a, DbDescriptor db, ProjectionDb f db) => f -> UntypedExpr db r
 fieldHelper f = result where
   result = ExprField $ fieldChain db f
   db = (undefined :: UntypedExpr db r -> proxy db) result
 
-instance (EntityConstr v c, DbDescriptor db, PersistField a, RestrictionHolder v c ~ r') => Expression db r' (Field v c a) where
+instance {-# OVERLAPPING #-} (EntityConstr v c, DbDescriptor db, PersistField a, RestrictionHolder v c ~ r') => Expression db r' (Field v c a) where
   toExpr = fieldHelper
 
-instance (EntityConstr v c, DbDescriptor db, PersistField a, db' ~ db, RestrictionHolder v c ~ r') => Expression db' r' (SubField db v c a) where
+instance {-# OVERLAPPING #-} (EntityConstr v c, DbDescriptor db, PersistField a, db' ~ db, RestrictionHolder v c ~ r') => Expression db' r' (SubField db v c a) where
   toExpr = fieldHelper
 
-instance (EntityConstr v c, DbDescriptor db, RestrictionHolder v c ~ r') => Expression db r' (AutoKeyField v c) where
+instance {-# OVERLAPPING #-} (EntityConstr v c, DbDescriptor db, RestrictionHolder v c ~ r') => Expression db r' (AutoKeyField v c) where
   toExpr = fieldHelper
 
-instance (PersistEntity v, DbDescriptor db, IsUniqueKey k, k ~ Key v (Unique u), RestrictionHolder v c ~ r')
+instance {-# OVERLAPPING #-} (PersistEntity v, DbDescriptor db, IsUniqueKey k, k ~ Key v (Unique u), RestrictionHolder v c ~ r')
       => Expression db r' (u (UniqueMarker v)) where
   toExpr = fieldHelper
 
-instance (db' ~ db, r' ~ r) => Expression db' r' (Cond db r) where
+instance {-# OVERLAPPING #-} (db' ~ db, r' ~ r) => Expression db' r' (Cond db r) where
   toExpr = ExprCond
 
 -- Let's call "plain type" the types that uniquely define type of a Field it is compared to.
 -- Example: Int -> Field v c Int, but Entity -> Field v c (Entity / Key Entity)
 class Unifiable a b
-instance Unifiable a a
+instance {-# OVERLAPPING #-} Unifiable a a
 -- Tie a type-level knot. Knowing if another type is plain helps to avoid indirection. In practice, it enables to infer type of polymorphic field when it is compared to a plain type.
-instance (Normalize bk a (ak, r), Normalize ak b (bk, r)) => Unifiable a b
+instance {-# OVERLAPPABLE #-} (Normalize bk a (ak, r), Normalize ak b (bk, r)) => Unifiable a b
 
+-- | This helper class can make type signatures more concise
+class (Expression db r a, PersistField a') => ExpressionOf db r a a' | a -> a'
+
+instance (Expression db r a, Normalize HTrue a (flag, a'), PersistField a') => ExpressionOf db r a a'
+
+instance {-# OVERLAPPABLE #-} PurePersistField a => Expression db r a where
+  toExpr = ExprPure
+
+instance {-# OVERLAPPING #-} (PersistField a, db' ~ db, r' ~ r) => Expression db' r' (Expr db r a) where
+  toExpr (Expr e) = e
+
 class Normalize counterpart t r | t -> r
-instance NormalizeValue a (isPlain, r) => Normalize HFalse (Field v c a) (HFalse, r)
-instance r ~ (HFalse, a)               => Normalize HTrue  (Field v c a) r
-instance NormalizeValue a (isPlain, r) => Normalize HFalse (SubField db v c a) (HFalse, r)
-instance r ~ (HFalse, a)               => Normalize HTrue  (SubField db v c a) r
-instance NormalizeValue a (isPlain, r) => Normalize HFalse (Expr db r' a) (HFalse, r)
-instance r ~ (HFalse, a)               => Normalize HTrue  (Expr db r' a) r
-instance NormalizeValue (Key v (Unique u)) (isPlain, r) => Normalize HFalse (u (UniqueMarker v)) (HFalse, r)
-instance r ~ (HFalse, Key v (Unique u))                 => Normalize HTrue  (u (UniqueMarker v)) r
-instance NormalizeValue (Key v BackendSpecific) (isPlain, r) => Normalize HFalse (AutoKeyField v c) (HFalse, r)
-instance r ~ (HFalse, Key v BackendSpecific)                 => Normalize HTrue  (AutoKeyField v c) r
-instance r ~ (HTrue, Bool) => Normalize HFalse (Cond db r') r
-instance r ~ (HTrue, Bool) => Normalize HTrue  (Cond db r') r
-instance NormalizeValue t r => Normalize HFalse t r
-instance r ~ (HTrue, t)     => Normalize HTrue  t r
 
+instance {-# OVERLAPPING #-} NormalizeValue a (isPlain, r) => Normalize HFalse (Field v c a) (HFalse, r)
+instance {-# OVERLAPS #-} r ~ (HFalse, a)               => Normalize HTrue  (Field v c a) r
+instance {-# OVERLAPPING #-} NormalizeValue a (isPlain, r) => Normalize HFalse (SubField db v c a) (HFalse, r)
+instance {-# OVERLAPS #-} r ~ (HFalse, a)               => Normalize HTrue  (SubField db v c a) r
+instance {-# OVERLAPPING #-} NormalizeValue a (isPlain, r) => Normalize HFalse (Expr db r' a) (HFalse, r)
+instance {-# OVERLAPS #-} r ~ (HFalse, a)               => Normalize HTrue  (Expr db r' a) r
+instance {-# OVERLAPPING #-} NormalizeValue (Key v (Unique u)) (isPlain, r) => Normalize HFalse (u (UniqueMarker v)) (HFalse, r)
+instance {-# OVERLAPS #-} r ~ (HFalse, Key v (Unique u))                 => Normalize HTrue  (u (UniqueMarker v)) r
+instance {-# OVERLAPPING #-} NormalizeValue (Key v BackendSpecific) (isPlain, r) => Normalize HFalse (AutoKeyField v c) (HFalse, r)
+instance {-# OVERLAPS #-} r ~ (HFalse, Key v BackendSpecific)                 => Normalize HTrue  (AutoKeyField v c) r
+instance {-# OVERLAPPING #-} r ~ (HTrue, Bool) => Normalize HFalse (Cond db r') r
+instance {-# OVERLAPPING #-} r ~ (HTrue, Bool) => Normalize HTrue  (Cond db r') r
+instance {-# OVERLAPPABLE #-} NormalizeValue t r => Normalize HFalse t r
+instance {-# OVERLAPPABLE #-} r ~ (HTrue, t)     => Normalize HTrue  t r
+
 class NormalizeValue t r | t -> r
 -- Normalize @Key v u@ to @v@ only if this key is used for storing @v@.
-instance (TypeEq (DefaultKey v) (Key v u) isDef,
+
+instance {-# OVERLAPPING #-} (TypeEq (DefaultKey v) (Key v u) isDef,
          NormalizeKey isDef v u k,
          r ~ (Not isDef, Maybe k))
          => NormalizeValue (Maybe (Key v u)) r
-instance (TypeEq (DefaultKey v) (Key v u) isDef,
+instance {-# OVERLAPPING #-} (TypeEq (DefaultKey v) (Key v u) isDef,
          NormalizeKey isDef v u k,
          r ~ (Not isDef, k))
          => NormalizeValue (Key v u) r
-instance r ~ (HTrue, a) => NormalizeValue a r
+instance {-# OVERLAPPABLE #-} r ~ (HTrue, a) => NormalizeValue a r
 
 class TypeEq x y b | x y -> b
-instance b ~ HFalse => TypeEq x y b
-instance TypeEq x x HTrue
+
+instance {-# OVERLAPPABLE #-} b ~ HFalse => TypeEq x y b
+instance {-# OVERLAPPING #-} TypeEq x x HTrue
 
 class NormalizeKey isDef v u k | isDef v u -> k, k -> v
 instance k ~ v => NormalizeKey HTrue v u k

@@ -14,12 +14,6 @@   , getQueries   , printMigration   , mergeMigrations-  -- * Helpers for running Groundhog actions-  , HasConn-  , runDb-  , runDbConn-  , runDbConnNoTransaction-  , withSavepoint   -- * Helper functions for defining *PersistValue instances   , primToPersistValue   , primFromPersistValue@@ -49,26 +43,31 @@   , replaceOne   , matchElements   , haveSameElems-  , mapAllRows   , phantomDb-  , getAutoKeyType+  , getDefaultAutoKeyType   , getUniqueFields   , isSimple+  , firstRow+  , streamToList+  , mapStream+  , joinStreams   , deleteByKey   ) where  import Database.Groundhog.Core  import Control.Applicative ((<|>))-import Control.Monad (liftM, forM_, unless, (>=>))-import Control.Monad.Logger (MonadLogger, NoLoggingT(..))+import Control.Monad (liftM, forM_, unless)+import Control.Monad.Trans.Reader (ReaderT(..), runReaderT, ask) import Control.Monad.Trans.State (StateT(..)) import Control.Monad.Trans.Control (MonadBaseControl, control, restoreM) import qualified Control.Exception as E import Control.Monad.IO.Class (MonadIO (..))-import Control.Monad.Reader.Class (MonadReader(..))+import Data.Acquire (with)+import Data.Acquire.Internal (Acquire(..), Allocated(..), ReleaseType(..)) import Data.Either (partitionEithers) import Data.Function (on)+import Data.IORef import Data.List (partition, sortBy) import qualified Data.Map as Map import System.IO (hPutStrLn, stderr)@@ -171,21 +170,22 @@ onException io what = control $ \runInIO -> E.onException (runInIO io) (runInIO what)  data PSFieldDef str = PSFieldDef {-    psFieldName :: str -- bar-  , psDbFieldName :: Maybe str -- SQLbar-  , psDbTypeName :: Maybe str -- inet, NUMERIC(5,2), VARCHAR(50)-  , psExprName :: Maybe str -- BarField+    psFieldName :: str  -- ^ name in the record, bar+  , psDbFieldName :: Maybe str -- ^ column name, SQLbar+  , psDbTypeName :: Maybe str -- ^ column type, inet, NUMERIC(5, 2), VARCHAR(50), etc.+  , psExprName :: Maybe str -- ^ name of constructor in the Field GADT, BarField   , psEmbeddedDef :: Maybe [PSFieldDef str]-  , psDefaultValue :: Maybe str+  , psDefaultValue :: Maybe str -- ^ default value in the database   , psReferenceParent :: Maybe (Maybe ((Maybe str, str), [str]), Maybe ReferenceActionType, Maybe ReferenceActionType)+  , psFieldConverter :: Maybe str -- ^ name of a pair of functions } deriving (Eq, Show)  applyDbTypeSettings :: PSFieldDef String -> DbType -> DbType-applyDbTypeSettings (PSFieldDef _ _ dbTypeName _ Nothing def psRef) typ = case typ of+applyDbTypeSettings (PSFieldDef _ _ dbTypeName _ Nothing def psRef _) typ = case typ of   DbTypePrimitive t nullable def' ref -> DbTypePrimitive (maybe t (\typeName -> DbOther $ OtherTypeDef [Left typeName]) dbTypeName) nullable (def <|> def') (applyReferencesSettings psRef ref)   DbEmbedded emb ref -> DbEmbedded emb (applyReferencesSettings psRef ref)   t -> t-applyDbTypeSettings (PSFieldDef _ _ _ _ (Just subs) _ psRef) typ = (case typ of+applyDbTypeSettings (PSFieldDef _ _ _ _ (Just subs) _ psRef _) typ = (case typ of   DbEmbedded (EmbeddedDef _ fields) ref -> DbEmbedded (uncurry EmbeddedDef $ go subs fields) (applyReferencesSettings psRef ref)   t -> error $ "applyDbTypeSettings: expected DbEmbedded, got " ++ show t) where   go [] fs = (False, fs)@@ -205,30 +205,30 @@ applyReferencesSettings _ Nothing = error $ "applyReferencesSettings: expected type with reference, got Nothing"  primToPersistValue :: (PersistBackend m, PrimitivePersistField a) => a -> m ([PersistValue] -> [PersistValue])-primToPersistValue a = phantomDb >>= \p -> return (toPrimitivePersistValue p a:)+primToPersistValue a = return (toPrimitivePersistValue a:)  primFromPersistValue :: (PersistBackend m, PrimitivePersistField a) => [PersistValue] -> m (a, [PersistValue])-primFromPersistValue (x:xs) = phantomDb >>= \p -> return (fromPrimitivePersistValue p x, xs)+primFromPersistValue (x:xs) = return (fromPrimitivePersistValue x, xs) primFromPersistValue xs = (\a -> fail (failMessage a xs) >> return (a, xs)) undefined -primToPurePersistValues :: (DbDescriptor db, PrimitivePersistField a) => proxy db -> a -> ([PersistValue] -> [PersistValue])-primToPurePersistValues p a = (toPrimitivePersistValue p a:)+primToPurePersistValues :: PrimitivePersistField a => a -> ([PersistValue] -> [PersistValue])+primToPurePersistValues a = (toPrimitivePersistValue a:) -primFromPurePersistValues :: (DbDescriptor db, PrimitivePersistField a) => proxy db -> [PersistValue] -> (a, [PersistValue])-primFromPurePersistValues p (x:xs) = (fromPrimitivePersistValue p x, xs)-primFromPurePersistValues _ xs = (\a -> error (failMessage a xs) `asTypeOf` (a, xs)) undefined+primFromPurePersistValues :: PrimitivePersistField a => [PersistValue] -> (a, [PersistValue])+primFromPurePersistValues (x:xs) = (fromPrimitivePersistValue x, xs)+primFromPurePersistValues xs = (\a -> error (failMessage a xs) `asTypeOf` (a, xs)) undefined  primToSinglePersistValue :: (PersistBackend m, PrimitivePersistField a) => a -> m PersistValue-primToSinglePersistValue a = phantomDb >>= \p -> return (toPrimitivePersistValue p a)+primToSinglePersistValue a = return (toPrimitivePersistValue a)  primFromSinglePersistValue :: (PersistBackend m, PrimitivePersistField a) => PersistValue -> m a-primFromSinglePersistValue a = phantomDb >>= \p -> return (fromPrimitivePersistValue p a)+primFromSinglePersistValue a = return (fromPrimitivePersistValue a)  pureToPersistValue :: (PersistBackend m, PurePersistField a) => a -> m ([PersistValue] -> [PersistValue])-pureToPersistValue a = phantomDb >>= \p -> return (toPurePersistValues p a)+pureToPersistValue a = return (toPurePersistValues a)  pureFromPersistValue :: (PersistBackend m, PurePersistField a) => [PersistValue] -> m (a, [PersistValue])-pureFromPersistValue xs = phantomDb >>= \p -> return (fromPurePersistValues p xs)+pureFromPersistValue xs = return (fromPurePersistValues xs)  singleToPersistValue :: (PersistBackend m, SinglePersistField a) => a -> m ([PersistValue] -> [PersistValue]) singleToPersistValue a = toSinglePersistValue a >>= \x -> return (x:)@@ -243,7 +243,7 @@  fromSinglePersistValueUnique :: forall m v u . (PersistBackend m, PersistEntity v, IsUniqueKey (Key v (Unique u)), PrimitivePersistField (Key v (Unique u)))                              => u (UniqueMarker v) -> PersistValue -> m v-fromSinglePersistValueUnique _ x = phantomDb >>= \proxy -> getBy (fromPrimitivePersistValue proxy x :: Key v (Unique u)) >>= maybe (fail $ "No data with id " ++ show x) return+fromSinglePersistValueUnique _ x = getBy (fromPrimitivePersistValue x :: Key v (Unique u)) >>= maybe (fail $ "No data with id " ++ show x) return  toPersistValuesUnique :: forall m v u . (PersistBackend m, PersistEntity v, IsUniqueKey (Key v (Unique u)))                       => u (UniqueMarker v) -> v -> m ([PersistValue] -> [PersistValue])@@ -259,7 +259,7 @@  fromSinglePersistValueAutoKey :: forall m v . (PersistBackend m, PersistEntity v, PrimitivePersistField (Key v BackendSpecific))                               => PersistValue -> m v-fromSinglePersistValueAutoKey x = phantomDb >>= \p -> get (fromPrimitivePersistValue p x :: Key v BackendSpecific) >>= maybe (fail $ "No data with id " ++ show x) return+fromSinglePersistValueAutoKey x = get (fromPrimitivePersistValue x :: Key v BackendSpecific) >>= maybe (fail $ "No data with id " ++ show x) return  replaceOne :: (Eq x, Show x) => String -> (a -> x) -> (b -> x) -> (a -> b -> b) -> a -> [b] -> [b] replaceOne what getter1 getter2 apply a bs = case filter ((getter1 a ==) . getter2) bs of@@ -287,51 +287,56 @@   ([], [], _) -> True   _           -> False -mapAllRows :: Monad m => ([PersistValue] -> m a) -> RowPopper m -> m [a]-mapAllRows f pop = go where-  go = pop >>= maybe (return []) (f >=> \a -> liftM (a:) go)--phantomDb :: PersistBackend m => m (proxy (PhantomDb m))+phantomDb :: PersistBackend m => m (proxy (Conn m)) phantomDb = return $ error "phantomDb" -getAutoKeyType :: DbDescriptor db => proxy db -> DbTypePrimitive-getAutoKeyType proxy = case dbType proxy ((undefined :: proxy db -> AutoKeyType db) proxy) of+getDefaultAutoKeyType :: DbDescriptor db => proxy db -> DbTypePrimitive+getDefaultAutoKeyType proxy = case dbType proxy ((undefined :: proxy db -> AutoKeyType db) proxy) of   DbTypePrimitive t _ _ _ -> t-  t -> error $ "autoKeyType: unexpected key type " ++ show t+  t -> error $ "getDefaultAutoKeyType: unexpected key type " ++ show t +firstRow :: MonadIO m => RowStream a -> m (Maybe a)+firstRow s = liftIO $ with s id++streamToList :: MonadIO m => RowStream a -> m [a]+streamToList s = liftIO $ with s go where+  go next = next >>= maybe (return []) (\a -> liftM (a:) (go next))++mapStream :: PersistBackendConn conn => (a -> Action conn b) -> RowStream a -> Action conn (RowStream b)+mapStream f s = do+  conn <- ask+  let apply next = next >>= \a -> case a of+        Nothing -> return Nothing+        Just a' -> liftM Just $ runReaderT (f a') conn+  return $ fmap apply s++joinStreams :: [Action conn (RowStream a)] -> Action conn (RowStream a)+joinStreams streams = do+  conn <- ask+  var <- liftIO $ newIORef $ ((return Nothing, const $ return ()), streams)+  return $ Acquire $ \restore -> do+    let joinedNext = do+          ((next, close), queue) <- readIORef var+          val <- next+          case val of+            Nothing -> case queue of+              [] -> return Nothing+              (makeStream:queue') -> do+                close ReleaseNormal+                Acquire f <- runReaderT makeStream conn+                Allocated next' close' <- f restore+                writeIORef var ((next', close'), queue')+                joinedNext+            Just a -> return $ Just a+        joinedClose typ = readIORef var >>= \((_, close),_) -> close typ+    return $ Allocated joinedNext joinedClose+ getUniqueFields :: UniqueDef' str (Either field str) -> [field] getUniqueFields (UniqueDef _ _ uFields) = map (either id (error "A unique key may not contain expressions")) uFields  isSimple :: [ConstructorDef] -> Bool isSimple [_] = True isSimple _   = False---- | This class helps to shorten the type signatures of user monadic code.-class (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadReader cm m, ConnectionManager cm conn) => HasConn m cm conn-instance (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadReader cm m, ConnectionManager cm conn) => HasConn m cm conn---- | It helps to run database operations within an application monad.-runDb :: HasConn m cm conn => DbPersist conn m a -> m a-runDb f = ask >>= withConn (runDbPersist f)---- | Runs action within connection. It can handle a simple connection, a pool of them, etc.-runDbConn :: (MonadBaseControl IO m, MonadIO m, ConnectionManager cm conn) => DbPersist conn (NoLoggingT m) a -> cm -> m a-runDbConn f cm = runNoLoggingT (withConn (runDbPersist f) cm)---- | It is similar to `runDbConn` but runs action without transaction. It can be useful if you use Groundhog within IO monad or in other cases when you cannot put `PersistBackend` instance into your monad stack.------ @--- flip withConn cm $ \\conn -> liftIO $ do---   -- transaction is already opened by withConn at this point---   someIOAction---   getValuesFromIO $ \\value -> runDbConnNoTransaction (insert_ value) conn--- @-runDbConnNoTransaction :: (MonadBaseControl IO m, MonadIO m, ConnectionManager cm conn) => DbPersist conn (NoLoggingT m) a -> cm -> m a-runDbConnNoTransaction f cm = runNoLoggingT (withConnNoTransaction (runDbPersist f) cm)---- | It helps to run 'withConnSavepoint' within a monad.-withSavepoint :: (HasConn m cm conn, SingleConnectionManager cm conn, Savepoint conn) => String -> m a -> m a-withSavepoint name m = ask >>= withConnNoTransaction (withConnSavepoint name m)  {-# DEPRECATED deleteByKey "Use deleteBy instead" #-} deleteByKey :: (PersistBackend m, PersistEntity v, PrimitivePersistField (Key v BackendSpecific)) => Key v BackendSpecific -> m ()

@@ -1,4 +1,4 @@-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RecordWildCards, TypeFamilies #-} -- | This helper module is intended for use by the backend creators module Database.Groundhog.Generic.Migration   ( Column(..)@@ -91,14 +91,14 @@              | CreateSchema String Bool   deriving Show -data MigrationPack m = MigrationPack {+data MigrationPack conn = MigrationPack {     compareTypes :: DbTypePrimitive -> DbTypePrimitive -> Bool   , compareRefs :: (Maybe String, Reference) -> (Maybe String, Reference) -> Bool   , compareUniqs :: UniqueDefInfo -> UniqueDefInfo -> Bool   , compareDefaults :: String -> String -> Bool-  , migTriggerOnDelete :: QualifiedName -> [(String, String)] -> m (Bool, [AlterDB])-  , migTriggerOnUpdate :: QualifiedName -> [(String, String)] -> m [(Bool, [AlterDB])]-  , migConstr :: MigrationPack m -> EntityDef -> ConstructorDef -> m (Bool, SingleMigration)+  , migTriggerOnDelete :: QualifiedName -> [(String, String)] -> Action conn (Bool, [AlterDB])+  , migTriggerOnUpdate :: QualifiedName -> [(String, String)] -> Action conn [(Bool, [AlterDB])]+  , migConstr :: EntityDef -> ConstructorDef -> Action conn (Bool, SingleMigration)   , escape :: String -> String   , autoincrementedKeyTypeName :: String   , mainTableId :: String@@ -113,10 +113,10 @@ }  mkColumns :: DbTypePrimitive -> (String, DbType) -> ([Column] -> [Column])-mkColumns autoKeyType field = go "" field where+mkColumns listAutoKeyType field = go "" field where   go prefix (fname, typ) acc = (case typ of     DbEmbedded (EmbeddedDef flag ts) _ -> foldr (go prefix') acc ts where prefix' = if flag then "" else prefix ++ fname ++ [delim]-    DbList _ _ -> Column fullName False autoKeyType Nothing : acc+    DbList _ _ -> Column fullName False listAutoKeyType Nothing : acc     DbTypePrimitive t nullable def _ -> Column fullName nullable t def : acc) where       fullName = prefix ++ fname @@ -165,7 +165,7 @@   -> Migration m migrateRecursively migS migE migL v = result where   result = migEntity $ entityDef proxy v-  proxy = (undefined :: t m a -> proxy (PhantomDb m)) result+  proxy = (undefined :: t m a -> proxy (Conn m)) result   go l@(DbList lName t) = f ("list " ++ lName) (migL l) (go t)   go (DbEmbedded (EmbeddedDef _ ts) ref) = mapM_ (go . snd) ts >> migRef ref   go (DbTypePrimitive _ _ _ ref) = migRef ref@@ -183,16 +183,16 @@     when (a == Nothing) $       lift mig >>= modify . Map.insert name >> cont -migrateSchema :: SchemaAnalyzer m => MigrationPack m -> String -> m SingleMigration+migrateSchema :: SchemaAnalyzer conn => MigrationPack conn -> String -> Action conn SingleMigration migrateSchema MigrationPack{..} schema = do   x <- schemaExists schema   return $ if x     then Right []     else showAlterDb $ CreateSchema schema False -migrateEntity :: (SchemaAnalyzer m, PersistBackend m) => MigrationPack m -> EntityDef -> m SingleMigration+migrateEntity :: (SchemaAnalyzer conn, PersistBackendConn conn) => MigrationPack conn -> EntityDef -> Action conn SingleMigration migrateEntity m@MigrationPack{..} e = do-  autoKeyType <- fmap getAutoKeyType phantomDb+  autoKeyType <- fmap getDefaultAutoKeyType phantomDb   let name = entityName e       constrs = constructors e       mainTableQuery = "CREATE TABLE " ++ escape name ++ " (" ++ mainTableId ++ " " ++ autoincrementedKeyTypeName ++ ", discr INTEGER NOT NULL)"@@ -205,11 +205,11 @@       case x of         Just old | null $ getAlters m old expectedMainStructure -> return $ Left           ["Datatype with multiple constructors was truncated to one constructor. Manual migration required. Datatype: " ++ name]-        _ -> liftM snd $ migConstr m e $ head constrs+        _ -> liftM snd $ migConstr e $ head constrs     else do       mainStructure <- analyzeTable (entitySchema e, name)       let constrTable c = name ++ [delim] ++ constrName c-      res <- mapM (migConstr m e) constrs+      res <- mapM (migConstr e) constrs       return $ case mainStructure of         Nothing ->            -- no constructor tables can exist if there is no main data table@@ -228,9 +228,9 @@                in mergeMigrations $ Right updateDiscriminators: map snd res           else Left ["Unexpected structure of main table for Datatype: " ++ name ++ ". Table info: " ++ show mainStructure'] -migrateList :: (SchemaAnalyzer m, PersistBackend m) => MigrationPack m -> DbType -> m SingleMigration+migrateList :: (SchemaAnalyzer conn, PersistBackendConn conn) => MigrationPack conn -> DbType -> Action conn SingleMigration migrateList m@MigrationPack{..} (DbList mainName t) = do-  autoKeyType <- fmap getAutoKeyType phantomDb+  autoKeyType <- fmap getDefaultAutoKeyType phantomDb   let valuesName = mainName ++ delim : "values"       (valueCols, valueRefs) = (($ []) . mkColumns autoKeyType) &&& mkReferences autoKeyType $ ("value", t)       refs' = Reference (Nothing, mainName) [("id", "id")] (Just Cascade) Nothing : valueRefs@@ -310,17 +310,17 @@   UniquePrimary _ -> DropConstraint name') where   name' = fromMaybe (error $ "dropUnique: constraint which should be dropped does not have a name") name   -defaultMigConstr :: (SchemaAnalyzer m, PersistBackend m) => MigrationPack m -> EntityDef -> ConstructorDef -> m (Bool, SingleMigration)+defaultMigConstr :: (SchemaAnalyzer conn, PersistBackendConn conn) => MigrationPack conn -> EntityDef -> ConstructorDef -> Action conn (Bool, SingleMigration) defaultMigConstr m@MigrationPack{..} e constr = do   let simple = isSimple $ constructors e       name = entityName e       qualifiedCName = (entitySchema e, if simple then name else name ++ [delim] ++ constrName constr)-  autoKeyType <- fmap getAutoKeyType phantomDb+  autoKeyType <- fmap getDefaultAutoKeyType phantomDb   tableStructure <- analyzeTable qualifiedCName   let dels = concatMap (mkDeletes escape) $ constrParams constr   (triggerExisted, delTrigger) <- migTriggerOnDelete qualifiedCName dels   updTriggers <- liftM (concatMap snd) $ migTriggerOnUpdate qualifiedCName dels-  +   let (expectedTableStructure, (addTable, addInAlters)) = (case constrAutoKeyName constr of         Nothing -> (TableInfo columns uniques (mkRefs refs), f [] columns uniques refs)         Just keyName -> let keyColumn = Column keyName False autoKeyType Nothing @@ -380,18 +380,18 @@   "SET DEFAULT" -> Just SetDefault   _ -> Nothing -class (Applicative m, Monad m) => SchemaAnalyzer m where-  schemaExists :: String -- ^ Schema name+class PersistBackendConn conn => SchemaAnalyzer conn where+  schemaExists :: (PersistBackend m, Conn m ~ conn) => String -- ^ Schema name                -> m Bool-  getCurrentSchema :: m (Maybe String)-  listTables :: Maybe String -- ^ Schema name+  getCurrentSchema :: (PersistBackend m, Conn m ~ conn) => m (Maybe String)+  listTables :: (PersistBackend m, Conn m ~ conn) => Maybe String -- ^ Schema name              -> m [String]-  listTableTriggers :: QualifiedName -- ^ Qualified table name+  listTableTriggers :: (PersistBackend m, Conn m ~ conn) => QualifiedName -- ^ Qualified table name                     -> m [String]-  analyzeTable :: QualifiedName -- ^ Qualified table name+  analyzeTable :: (PersistBackend m, Conn m ~ conn) => QualifiedName -- ^ Qualified table name                -> m (Maybe TableInfo)-  analyzeTrigger :: QualifiedName -- ^ Qualified trigger name+  analyzeTrigger :: (PersistBackend m, Conn m ~ conn) =>  QualifiedName -- ^ Qualified trigger name                  -> m (Maybe String)-  analyzeFunction :: QualifiedName -- ^ Qualified function name+  analyzeFunction :: (PersistBackend m, Conn m ~ conn) => QualifiedName -- ^ Qualified function name                   -> m (Maybe (Maybe [DbTypePrimitive], Maybe DbTypePrimitive, String)) -- ^ Argument types, return type, and body-  getMigrationPack :: m (MigrationPack m)+  getMigrationPack :: (PersistBackend m, Conn m ~ conn) => m (MigrationPack conn)

@@ -6,8 +6,11 @@     get   , select   , selectAll+  , selectStream+  , selectAllStream   , getBy   , project+  , projectStream   , count   , replace   , replaceBy@@ -20,152 +23,164 @@   , insertBy   ) where -import Database.Groundhog.Core hiding (PersistBackend(..))-import Database.Groundhog.Core (PersistBackend, PhantomDb)+import Database.Groundhog.Core hiding (PersistBackendConn(..))+import Database.Groundhog.Core (PersistBackendConn) import qualified Database.Groundhog.Core as Core-import Database.Groundhog.Generic+import Database.Groundhog.Generic (firstRow, mapStream, streamToList, joinStreams, isSimple, getUniqueFields) import Database.Groundhog.Generic.Sql -import Control.Monad (liftM, forM, (>=>))+import Control.Monad (liftM) import Data.Either (rights) import Data.Maybe (catMaybes, fromJust, mapMaybe) import Data.Monoid -{-# INLINABLE get #-}-get :: forall m v . (PersistBackend m, PersistEntity v, PrimitivePersistField (Key v BackendSpecific))-    => RenderConfig -> (forall a . Utf8 -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> Key v BackendSpecific -> m (Maybe v)+get :: forall conn v . (PersistBackendConn conn, PersistEntity v, PrimitivePersistField (Key v BackendSpecific))+    => RenderConfig -> (Utf8 -> [PersistValue] -> Action conn (RowStream [PersistValue])) -> Key v BackendSpecific -> Action conn (Maybe v) get RenderConfig{..} queryFunc (k :: Key v BackendSpecific) = do   let e = entityDef proxy (undefined :: v)-      proxy = undefined :: proxy (PhantomDb m)+      proxy = undefined :: proxy conn   if isSimple (constructors e)     then do       let constr = head $ constructors e       let fields = renderFields esc (constrParams constr)       let query = "SELECT " <> fields <> " FROM " <> tableName esc e constr <> " WHERE " <> fromJust (constrId esc constr) <> "=?"-      x <- queryFunc query [toPrimitivePersistValue proxy k] id+      x <- queryFunc query [toPrimitivePersistValue k] >>= firstRow       case x of         Just xs -> liftM (Just . fst) $ fromEntityPersistValues $ PersistInt64 0:xs         Nothing -> return Nothing     else do       let query = "SELECT discr FROM " <> mainTableName esc e <> " WHERE id=?"-      x <- queryFunc query [toPrimitivePersistValue proxy k] id+      x <- queryFunc query [toPrimitivePersistValue k] >>= firstRow       case x of         Just [discr] -> do-          let constructorNum = fromPrimitivePersistValue proxy discr+          let constructorNum = fromPrimitivePersistValue discr               constr = constructors e !! constructorNum               fields = renderFields esc (constrParams constr)               cQuery = "SELECT " <> fields <> " FROM " <> tableName esc e constr <> " WHERE " <> fromJust (constrId esc constr) <> "=?"-          x2 <- queryFunc cQuery [toPrimitivePersistValue proxy k] id+          x2 <- queryFunc cQuery [toPrimitivePersistValue k] >>= firstRow           case x2 of             Just xs -> liftM (Just . fst) $ fromEntityPersistValues $ discr:xs             Nothing -> fail "Missing entry in constructor table"         Just x' -> fail $ "Unexpected number of columns returned: " ++ show x'         Nothing -> return Nothing -select :: forall m db r v c opts . (SqlDb db, db ~ PhantomDb m, r ~ RestrictionHolder v c, PersistBackend m, PersistEntity v, EntityConstr v c, HasSelectOptions opts db r)-       => RenderConfig -> (forall a . Utf8 -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> (opts -> RenderS db r) -> Utf8 -> opts -> m [v]-select conf@RenderConfig{..} queryFunc preColumns noLimit options = doSelectQuery where+select :: forall conn r v c opts . (SqlDb conn, r ~ RestrictionHolder v c, PersistBackendConn conn, PersistEntity v, EntityConstr v c, HasSelectOptions opts conn r)+       => RenderConfig -> (Utf8 -> [PersistValue] -> Action conn (RowStream [PersistValue])) -> (opts -> RenderS conn r) -> Utf8 -> opts -> Action conn [v]+select conf queryFunc preColumns noLimit options = selectStream conf queryFunc preColumns noLimit options >>= streamToList++selectStream :: forall conn r v c opts . (SqlDb conn, r ~ RestrictionHolder v c, PersistBackendConn conn, PersistEntity v, EntityConstr v c, HasSelectOptions opts conn r)+       => RenderConfig -> (Utf8 -> [PersistValue] -> Action conn (RowStream [PersistValue])) -> (opts -> RenderS conn r) -> Utf8 -> opts -> Action conn (RowStream v)+selectStream conf@RenderConfig{..} queryFunc preColumns noLimit options = doSelectQuery where   SelectOptions cond limit offset ords dist _ = getSelectOptions options    e = entityDef proxy (undefined :: v)-  proxy = undefined :: proxy (PhantomDb m)+  proxy = undefined :: proxy conn   orders = renderOrders conf ords   lim = case (limit, offset) of           (Nothing, Nothing) -> mempty-          (Nothing, o) -> RenderS (" " <> noLimit <> " OFFSET ?") (toPurePersistValues proxy o)-          (l, Nothing) -> RenderS " LIMIT ?" (toPurePersistValues proxy l)-          (l, o) -> RenderS " LIMIT ? OFFSET ?" (toPurePersistValues proxy (l, o))+          (Nothing, o) -> RenderS (" " <> noLimit <> " OFFSET ?") (toPurePersistValues o)+          (l, Nothing) -> RenderS " LIMIT ?" (toPurePersistValues l)+          (l, o) -> RenderS " LIMIT ? OFFSET ?" (toPurePersistValues (l, o))   cond' = renderCond conf cond   fields = RenderS (renderFields esc (constrParams constr)) id   distinctClause = if dist then "DISTINCT " else mempty   RenderS query binds = "SELECT " <> distinctClause <> preColumns options <> fields <> " FROM " <> RenderS (tableName esc e constr) id <> whereClause <> orders <> lim   whereClause = maybe "" (" WHERE " <>) cond'-  doSelectQuery = queryFunc query (binds []) $ mapAllRows $ liftM fst . fromEntityPersistValues . (toPrimitivePersistValue proxy cNum:)+  doSelectQuery = queryFunc query (binds []) >>= mapStream (\xs -> liftM fst $ fromEntityPersistValues $ (toPrimitivePersistValue cNum):xs)   cNum = entityConstrNum (undefined :: proxy v) (undefined :: c a)   constr = constructors e !! cNum -selectAll :: forall m v . (PersistBackend m, PersistEntity v)-          => RenderConfig -> (forall a . Utf8 -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> m [(AutoKey v, v)]-selectAll RenderConfig{..} queryFunc = start where-  start = if isSimple (constructors e)-    then let-      constr = head $ constructors e-      fields = maybe id (\key cont -> key <> fromChar ',' <> cont) (constrId esc constr) $ renderFields esc (constrParams constr)-      query = "SELECT " <> fields <> " FROM " <> tableName esc e constr-      in queryFunc query [] $ mapAllRows $ mkEntity proxy 0-    else liftM concat $ forM (zip [0..] (constructors e)) $ \(cNum, constr) -> do-        let fields = fromJust (constrId esc constr) <> fromChar ',' <> renderFields esc (constrParams constr)-        let query = "SELECT " <> fields <> " FROM " <> tableName esc e constr-        queryFunc query [] $ mapAllRows $ mkEntity proxy cNum+selectAll :: forall conn v . (PersistBackendConn conn, PersistEntity v)+          => RenderConfig -> (Utf8 -> [PersistValue] -> Action conn (RowStream [PersistValue])) -> Action conn [(AutoKey v, v)]+selectAll conf queryFunc = selectAllStream conf queryFunc >>= streamToList++-- | It may call the passed function multiple times+selectAllStream :: forall conn v . (PersistBackendConn conn, PersistEntity v)+                => RenderConfig -> (Utf8 -> [PersistValue] -> Action conn (RowStream [PersistValue])) -> Action conn (RowStream (AutoKey v, v))+selectAllStream RenderConfig{..} queryFunc = start where+  start = joinStreams $ zipWith selectConstr [0..] $ constructors e+  selectConstr cNum constr = queryFunc query [] >>= mapStream (mkEntity cNum) where+    fields = maybe id (\key cont -> key <> fromChar ',' <> cont) (constrId esc constr) $ renderFields esc (constrParams constr)+    query = "SELECT " <> fields <> " FROM " <> tableName esc e constr   e = entityDef proxy (undefined :: v)-  proxy = undefined :: proxy (PhantomDb m)+  proxy = undefined :: proxy conn+  mkEntity cNum xs = do+    let (k, xs') = fromPurePersistValues xs+    (v, _) <- fromEntityPersistValues (toPrimitivePersistValue (cNum :: Int):xs')+    return (k, v) -getBy :: forall m v u . (PersistBackend m, PersistEntity v, IsUniqueKey (Key v (Unique u)))+getBy :: forall conn v u . (PersistBackendConn conn, PersistEntity v, IsUniqueKey (Key v (Unique u)))       => RenderConfig-      -> (forall a . Utf8 -> [PersistValue] -> (RowPopper m -> m a) -> m a) -- ^ function to run query+      -> (Utf8 -> [PersistValue] -> Action conn (RowStream [PersistValue])) -- ^ function to run query       -> Key v (Unique u)-      -> m (Maybe v)+      -> Action conn (Maybe v) getBy conf@RenderConfig{..} queryFunc (k :: Key v (Unique u)) = do   uniques <- toPersistValues k   let e = entityDef proxy (undefined :: v)-      proxy = undefined :: proxy (PhantomDb m)+      proxy = undefined :: proxy conn       u = (undefined :: Key v (Unique u) -> u (UniqueMarker v)) k       uFields = renderChain conf (fieldChain proxy u) []       RenderS cond vals = intercalateS " AND " $ mkUniqueCond uFields uniques       constr = head $ constructors e       fields = renderFields esc (constrParams constr)       query = "SELECT " <> fields <> " FROM " <> tableName esc e constr <> " WHERE " <> cond-  x <- queryFunc query (vals []) id+  x <- queryFunc query (vals []) >>= firstRow   case x of     Just xs -> liftM (Just . fst) $ fromEntityPersistValues $ PersistInt64 0:xs     Nothing -> return Nothing -project :: forall m db r v c p opts a'. (SqlDb db, db ~ PhantomDb m, r ~ RestrictionHolder v c, PersistBackend m, PersistEntity v, EntityConstr v c, Projection p a', ProjectionDb p db, ProjectionRestriction p r, HasSelectOptions opts db r)-        => RenderConfig -> (forall a . Utf8 -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> (opts -> RenderS db r) -> Utf8 -> p -> opts -> m [a']-project conf@RenderConfig{..} queryFunc preColumns noLimit p options = doSelectQuery where+project :: forall conn r v c p opts a'. (SqlDb conn, r ~ RestrictionHolder v c, PersistBackendConn conn, PersistEntity v, EntityConstr v c, Projection p a', ProjectionDb p conn, ProjectionRestriction p r, HasSelectOptions opts conn r)+        => RenderConfig -> (Utf8 -> [PersistValue] -> Action conn (RowStream [PersistValue])) -> (opts -> RenderS conn r) -> Utf8 -> p -> opts -> Action conn [a']+project conf queryFunc preColumns noLimit p options = projectStream conf queryFunc preColumns noLimit p options >>= streamToList++projectStream :: forall conn r v c p opts a' . (SqlDb conn, r ~ RestrictionHolder v c, PersistBackendConn conn, PersistEntity v, EntityConstr v c, Projection p a', ProjectionDb p conn, ProjectionRestriction p r, HasSelectOptions opts conn r)+        => RenderConfig -> (Utf8 -> [PersistValue] -> Action conn (RowStream [PersistValue])) -> (opts -> RenderS conn r) -> Utf8 -> p -> opts -> Action conn (RowStream a')+projectStream conf@RenderConfig{..} queryFunc preColumns noLimit p options = doSelectQuery where   SelectOptions cond limit offset ords dist _ = getSelectOptions options   e = entityDef proxy (undefined :: v)-  proxy = undefined :: proxy (PhantomDb m)+  proxy = undefined :: proxy conn   orders = renderOrders conf ords   lim = case (limit, offset) of           (Nothing, Nothing) -> mempty-          (Nothing, o) -> RenderS (" " <> noLimit <> " OFFSET ?") (toPurePersistValues proxy o)-          (l, Nothing) -> RenderS " LIMIT ?" (toPurePersistValues proxy l)-          (l, o) -> RenderS " LIMIT ? OFFSET ?" (toPurePersistValues proxy (l, o))+          (Nothing, o) -> RenderS (" " <> noLimit <> " OFFSET ?") (toPurePersistValues o)+          (l, Nothing) -> RenderS " LIMIT ?" (toPurePersistValues l)+          (l, o) -> RenderS " LIMIT ? OFFSET ?" (toPurePersistValues (l, o))   cond' = renderCond conf cond   chains = projectionExprs p []   fields = commasJoin $ concatMap (renderExprExtended conf 0) chains   distinctClause = if dist then "DISTINCT " else mempty   RenderS query binds = "SELECT " <> distinctClause <> preColumns options <> fields <> " FROM " <> RenderS (tableName esc e constr) id <> whereClause <> orders <> lim   whereClause = maybe "" (" WHERE " <>) cond'-  doSelectQuery = queryFunc query (binds []) $ mapAllRows $ liftM fst . projectionResult p+  doSelectQuery = queryFunc query (binds []) >>= mapStream (liftM fst . projectionResult p)   constr = constructors e !! entityConstrNum (undefined :: proxy v) (undefined :: c a) -count :: forall m db r v c . (SqlDb db, db ~ PhantomDb m, r ~ RestrictionHolder v c, PersistBackend m, PersistEntity v, EntityConstr v c)-      => RenderConfig -> (forall a . Utf8 -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> Cond db r -> m Int+count :: forall conn r v c . (SqlDb conn, r ~ RestrictionHolder v c, PersistBackendConn conn, PersistEntity v, EntityConstr v c)+      => RenderConfig -> (Utf8 -> [PersistValue] -> Action conn (RowStream [PersistValue])) -> Cond conn r -> Action conn Int count conf@RenderConfig{..} queryFunc cond = do   let e = entityDef proxy (undefined :: v)-      proxy = undefined :: proxy (PhantomDb m)+      proxy = undefined :: proxy conn       cond' = renderCond conf cond       constr = constructors e !! entityConstrNum (undefined :: proxy v) (undefined :: c a)       query = "SELECT COUNT(*) FROM " <> tableName esc e constr <> whereClause where       whereClause = maybe "" (\c -> " WHERE " <> getQuery c) cond'-  x <- queryFunc query (maybe [] (flip getValues []) cond') id+  x <- queryFunc query (maybe [] (flip getValues []) cond') >>= firstRow   case x of-    Just [num] -> return $ fromPrimitivePersistValue proxy num+    Just [num] -> return $ fromPrimitivePersistValue num     Just xs -> fail $ "requested 1 column, returned " ++ show (length xs)     Nothing -> fail $ "COUNT returned no rows" -replace :: forall m db r v . (PersistBackend m, PersistEntity v, PrimitivePersistField (Key v BackendSpecific))-        => RenderConfig -> (forall a . Utf8 -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> (Utf8 -> [PersistValue] -> m ()) -> (Bool -> Utf8 -> ConstructorDef -> [PersistValue] -> RenderS db r)-        -> Key v BackendSpecific -> v -> m ()+replace :: forall conn r v . (PersistBackendConn conn, PersistEntity v, PrimitivePersistField (Key v BackendSpecific))+        => RenderConfig -> (Utf8 -> [PersistValue] -> Action conn (RowStream [PersistValue]))+        -> (Utf8 -> [PersistValue] -> Action conn ())+        -> (Bool -> Utf8 -> ConstructorDef -> [PersistValue] -> RenderS conn r)+        -> Key v BackendSpecific -> v -> Action conn () replace RenderConfig{..} queryFunc execFunc insertIntoConstructorTable k v = do   vals <- toEntityPersistValues' v   let e = entityDef proxy v-      proxy = undefined :: proxy (PhantomDb m)-      constructorNum = fromPrimitivePersistValue proxy (head vals)+      proxy = undefined :: proxy conn+      constructorNum = fromPrimitivePersistValue (head vals)       constr = constructors e !! constructorNum-      k' = toPrimitivePersistValue proxy k+      k' = toPrimitivePersistValue k       RenderS upds updsVals = commasJoin $ zipWith f fields $ tail vals where         fields = foldr (flatten esc) [] $ constrParams constr         f f1 f2 = RenderS f1 id <> fromChar '=' <> renderPersistValue f2@@ -175,7 +190,7 @@     then execFunc updateQuery (updsVals [k'])     else do       let query = "SELECT discr FROM " <> mainTableName esc e <> " WHERE id=?"-      x <- queryFunc query [k'] (id >=> return . fmap (fromPrimitivePersistValue proxy . head))+      x <- queryFunc query [k'] >>= liftM (fmap $ fromPrimitivePersistValue . head) . firstRow       case x of         Just discr -> do           let cName = tableName esc e constr@@ -194,17 +209,17 @@               execFunc updateDiscrQuery [head vals, k']         Nothing -> return () -replaceBy :: forall m v u . (PersistBackend m, PersistEntity v, IsUniqueKey (Key v (Unique u)))+replaceBy :: forall conn v u . (PersistBackendConn conn, PersistEntity v, IsUniqueKey (Key v (Unique u)))           => RenderConfig-          -> (Utf8 -> [PersistValue] -> m ()) -- ^ function to execute query+          -> (Utf8 -> [PersistValue] -> Action conn ()) -- ^ function to execute query           -> u (UniqueMarker v)           -> v-          -> m ()+          -> Action conn () replaceBy conf@RenderConfig{..} execFunc u v = do   uniques <- toPersistValues $ (extractUnique v `asTypeOf` ((undefined :: u (UniqueMarker v) -> Key v (Unique u)) u))   vals <- toEntityPersistValues' v   let e = entityDef proxy (undefined :: v)-      proxy = undefined :: proxy (PhantomDb m)+      proxy = undefined :: proxy conn       uFields = renderChain conf (fieldChain proxy u) []       RenderS cond condVals = intercalateS " AND " $ mkUniqueCond uFields uniques       constr = head $ constructors e@@ -214,11 +229,11 @@       updateQuery = "UPDATE " <> tableName esc e constr <> " SET " <> upds <> " WHERE " <> cond   execFunc updateQuery (updsVals . condVals $ []) -update :: forall m db r v c . (SqlDb db, db ~ PhantomDb m, r ~ RestrictionHolder v c, PersistBackend m, PersistEntity v, EntityConstr v c)-       => RenderConfig -> (Utf8 -> [PersistValue] -> m ()) -> [Update db r] -> Cond db r -> m ()+update :: forall conn r v c . (SqlDb conn, r ~ RestrictionHolder v c, PersistBackendConn conn, PersistEntity v, EntityConstr v c)+       => RenderConfig -> (Utf8 -> [PersistValue] -> Action conn ()) -> [Update conn r] -> Cond conn r -> Action conn () update conf@RenderConfig{..} execFunc upds cond = do   let e = entityDef proxy (undefined :: v)-      proxy = undefined :: proxy (PhantomDb m)+      proxy = undefined :: proxy conn   case renderUpdates conf upds of     Just upds' -> do       let cond' = renderCond conf cond@@ -228,11 +243,11 @@       execFunc query (getValues upds' <> maybe mempty getValues cond' $ [])     Nothing -> return () -delete :: forall m db r v c . (SqlDb db, db ~ PhantomDb m, r ~ RestrictionHolder v c, PersistBackend m, PersistEntity v, EntityConstr v c)-       => RenderConfig -> (Utf8 -> [PersistValue] -> m ()) -> Cond db r -> m ()+delete :: forall conn r v c . (SqlDb conn, r ~ RestrictionHolder v c, PersistBackendConn conn, PersistEntity v, EntityConstr v c)+       => RenderConfig -> (Utf8 -> [PersistValue] -> Action conn ()) -> Cond conn r -> Action conn () delete conf@RenderConfig{..} execFunc cond = execFunc query (maybe [] (($ []) . getValues) cond') where   e = entityDef proxy (undefined :: v)-  proxy = undefined :: proxy (PhantomDb m)+  proxy = undefined :: proxy conn   constr = constructors e !! entityConstrNum (undefined :: proxy v) (undefined :: c a)   cond' = renderCond conf cond   whereClause = maybe "" (\c -> " WHERE " <> getQuery c) cond'@@ -241,15 +256,15 @@     -- the entries in the constructor table are deleted because of the reference on delete cascade     else "DELETE FROM " <> mainTableName esc e <> " WHERE id IN(SELECT " <> fromJust (constrId esc constr) <> " FROM " <> tableName esc e constr <> whereClause <> ")" -insertByAll :: forall m v . (PersistBackend m, PersistEntity v)+insertByAll :: forall conn v . (PersistBackendConn conn, PersistEntity v)             => RenderConfig-            -> (forall a . Utf8 -> [PersistValue] -> (RowPopper m -> m a) -> m a) -- ^ function to run query+            -> (Utf8 -> [PersistValue] -> Action conn (RowStream [PersistValue])) -- ^ function to run query             -> Bool -- ^ allow multiple duplication of uniques with nulls-            -> v -> m (Either (AutoKey v) (AutoKey v))+            -> v -> Action conn (Either (AutoKey v) (AutoKey v)) insertByAll RenderConfig{..} queryFunc manyNulls v = do   let e = entityDef proxy v-      proxy = undefined :: proxy (PhantomDb m)-      (constructorNum, uniques) = getUniques proxy v+      proxy = undefined :: proxy conn+      (constructorNum, uniques) = getUniques v       constr = constructors e !! constructorNum       uniqueDefs = constrUniques constr @@ -264,16 +279,16 @@   if null conds     then liftM Right $ Core.insert v     else do-      x <- queryFunc query (vals []) id+      x <- queryFunc query (vals []) >>= firstRow       case x of         Nothing -> liftM Right $ Core.insert v-        Just xs -> return $ Left $ fst $ fromPurePersistValues proxy xs+        Just xs -> return $ Left $ fst $ fromPurePersistValues xs -deleteBy :: forall m v . (PersistBackend m, PersistEntity v, PrimitivePersistField (Key v BackendSpecific))-            => RenderConfig -> (Utf8 -> [PersistValue] -> m ()) -> Key v BackendSpecific -> m ()-deleteBy RenderConfig{..} execFunc k = execFunc query [toPrimitivePersistValue proxy k] where+deleteBy :: forall conn v . (PersistBackendConn conn, PersistEntity v, PrimitivePersistField (Key v BackendSpecific))+            => RenderConfig -> (Utf8 -> [PersistValue] -> Action conn ()) -> Key v BackendSpecific -> Action conn ()+deleteBy RenderConfig{..} execFunc k = execFunc query [toPrimitivePersistValue k] where   e = entityDef proxy ((undefined :: Key v u -> v) k)-  proxy = undefined :: proxy (PhantomDb m)+  proxy = undefined :: proxy conn   constr = head $ constructors e   idName = if isSimple (constructors e)     then fromJust $ constrId esc constr@@ -281,34 +296,34 @@   -- the entries in the constructor table are deleted because of the reference on delete cascade   query = "DELETE FROM " <> mainTableName esc e <> " WHERE " <> idName <> "=?" -deleteAll :: forall m v . (PersistBackend m, PersistEntity v)-          => RenderConfig -> (Utf8 -> [PersistValue] -> m ()) -> v -> m ()+deleteAll :: forall conn v . (PersistBackendConn conn, PersistEntity v)+          => RenderConfig -> (Utf8 -> [PersistValue] -> Action conn ()) -> v -> Action conn () deleteAll RenderConfig{..} execFunc (_ :: v) = execFunc query [] where   e = entityDef proxy (undefined :: v)-  proxy = undefined :: proxy (PhantomDb m)+  proxy = undefined :: proxy conn   query = "DELETE FROM " <> mainTableName esc e -countAll :: forall m v . (PersistBackend m, PersistEntity v)-         => RenderConfig -> (forall a . Utf8 -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> v -> m Int+countAll :: forall conn v . (PersistBackendConn conn, PersistEntity v)+         => RenderConfig -> (Utf8 -> [PersistValue] -> Action conn (RowStream [PersistValue])) -> v -> Action conn Int countAll RenderConfig{..} queryFunc (_ :: v) = do   let e = entityDef proxy (undefined :: v)-      proxy = undefined :: proxy (PhantomDb m)+      proxy = undefined :: proxy conn       query = "SELECT COUNT(*) FROM " <> mainTableName esc e-  x <- queryFunc query [] id+  x <- queryFunc query [] >>= firstRow   case x of-    Just [num] -> return $ fromPrimitivePersistValue proxy num+    Just [num] -> return $ fromPrimitivePersistValue num     Just xs -> fail $ "requested 1 column, returned " ++ show (length xs)     Nothing -> fail $ "COUNT returned no rows" -insertBy :: forall m v u . (PersistBackend m, PersistEntity v, IsUniqueKey (Key v (Unique u)))+insertBy :: forall conn v u . (PersistBackendConn conn, PersistEntity v, IsUniqueKey (Key v (Unique u)))          => RenderConfig-         -> (forall a . Utf8 -> [PersistValue] -> (RowPopper m -> m a) -> m a)+         -> (Utf8 -> [PersistValue] -> Action conn (RowStream [PersistValue]))          -> Bool-         -> u (UniqueMarker v) -> v -> m (Either (AutoKey v) (AutoKey v))+         -> u (UniqueMarker v) -> v -> Action conn (Either (AutoKey v) (AutoKey v)) insertBy conf@RenderConfig{..} queryFunc manyNulls u v = do   uniques <- toPersistValues $ (extractUnique v `asTypeOf` ((undefined :: u (UniqueMarker v) -> Key v (Unique u)) u))   let e = entityDef proxy v-      proxy = undefined :: proxy (PhantomDb m)+      proxy = undefined :: proxy conn       uFields = renderChain conf (fieldChain proxy u) []       RenderS cond vals = intercalateS " AND " $ mkUniqueCond uFields uniques       -- skip condition if any value is NULL. It allows to insert many values with duplicate unique key@@ -319,24 +334,19 @@   if checkNulls uniques     then liftM Right $ Core.insert v     else do-      x <- queryFunc query (vals []) id+      x <- queryFunc query (vals []) >>= firstRow       case x of         Nothing  -> liftM Right $ Core.insert v-        Just [k] -> return $ Left $ fst $ fromPurePersistValues proxy [k]+        Just [k] -> return $ Left $ fst $ fromPurePersistValues [k]         Just xs  -> fail $ "unexpected query result: " ++ show xs  constrId :: (Utf8 -> Utf8) -> ConstructorDef -> Maybe Utf8 constrId escape = fmap (escape . fromString) . constrAutoKeyName --- | receives constructor number and row of values from the constructor table-mkEntity :: (PersistEntity v, PersistBackend m) => proxy (PhantomDb m) -> Int -> [PersistValue] -> m (AutoKey v, v)-mkEntity proxy i xs = fromEntityPersistValues (toPrimitivePersistValue proxy i:xs') >>= \(v, _) -> return (k, v) where-  (k, xs') = fromPurePersistValues proxy xs--toEntityPersistValues' :: (PersistBackend m, PersistEntity v) => v -> m [PersistValue]+toEntityPersistValues' :: (PersistBackendConn conn, PersistEntity v) => v -> Action conn [PersistValue] toEntityPersistValues' = liftM ($ []) . toEntityPersistValues -mkUniqueCond :: [Utf8] -> ([PersistValue] -> [PersistValue]) -> [RenderS db r]+mkUniqueCond :: [Utf8] -> ([PersistValue] -> [PersistValue]) -> [RenderS conn r] mkUniqueCond u vals = zipWith f u (vals []) where   f a PersistNull = RenderS (a <> " IS NULL") id   f a x = RenderS (a <> "=?") (x:)

@@ -113,12 +113,11 @@   ExprRaw (Snippet f) -> let vals = f conf p in ensureOne vals id   ExprField f -> let fs = renderChain conf f []                  in ensureOne fs $ \f' -> RenderS f' id-  ExprPure  a -> let vals = toPurePersistValues proxy a+  ExprPure  a -> let vals = toPurePersistValues a                  in ensureOne (vals []) renderPersistValue   ExprCond  a -> case renderCondPriority conf p a of                    Nothing -> error "renderExprPriority: empty condition"                    Just x -> x) where-    proxy = (undefined :: f db r -> proxy db) expr     ensureOne :: [a] -> (a -> b) -> b     ensureOne xs f = case xs of       [x] -> f x@@ -128,10 +127,9 @@ renderExprExtended conf p expr = (case expr of   ExprRaw (Snippet f) -> f conf p   ExprField f -> map (flip RenderS id) $ renderChain conf f []-  ExprPure a -> let vals = toPurePersistValues proxy a []+  ExprPure a -> let vals = toPurePersistValues a []                 in map renderPersistValue vals   ExprCond a -> maybeToList $ renderCondPriority conf p a) where-  proxy = (undefined :: f db r -> proxy db) expr  renderPersistValue :: PersistValue -> RenderS db r renderPersistValue (PersistCustom s as) = RenderS s (as++)@@ -238,6 +236,7 @@  defaultShowPrim :: PersistValue -> String defaultShowPrim (PersistString x) = "'" ++ x ++ "'"+defaultShowPrim (PersistText x) = "'" ++ show x ++ "'" defaultShowPrim (PersistByteString x) = "'" ++ show x ++ "'" defaultShowPrim (PersistInt64 x) = show x defaultShowPrim (PersistDouble x) = show x

@@ -3,10 +3,11 @@ module Database.Groundhog.Instances (Selector(..)) where  import Database.Groundhog.Core-import Database.Groundhog.Generic (primToPersistValue, primFromPersistValue, primToPurePersistValues, primFromPurePersistValues, primToSinglePersistValue, primFromSinglePersistValue, phantomDb, getUniqueFields)+import Database.Groundhog.Generic (primToPersistValue, primFromPersistValue, primToPurePersistValues, primFromPurePersistValues, primToSinglePersistValue, primFromSinglePersistValue, getUniqueFields)  import qualified Data.Aeson as A import qualified Data.Text as T+import qualified Data.Text.Lazy as TL import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding.Error as T #if MIN_VERSION_base(4, 7, 0)@@ -68,179 +69,186 @@   selectorNum Tuple5_4Selector = 4  instance PurePersistField () where-  toPurePersistValues _ _ = id-  fromPurePersistValues _ xs = ((), xs)+  toPurePersistValues _ = id+  fromPurePersistValues xs = ((), xs)  instance (PurePersistField a, PurePersistField b) => PurePersistField (a, b) where-  toPurePersistValues p (a, b) = toPurePersistValues p a . toPurePersistValues p b-  fromPurePersistValues p xs = let-    (a, rest0) = fromPurePersistValues p xs-    (b, rest1) = fromPurePersistValues p rest0+  toPurePersistValues (a, b) = toPurePersistValues a . toPurePersistValues b+  fromPurePersistValues xs = let+    (a, rest0) = fromPurePersistValues xs+    (b, rest1) = fromPurePersistValues rest0     in ((a, b), rest1)  instance (PurePersistField a, PurePersistField b, PurePersistField c) => PurePersistField (a, b, c) where-  toPurePersistValues p (a, b, c) = toPurePersistValues p a . toPurePersistValues p b . toPurePersistValues p c-  fromPurePersistValues p xs = let-    (a, rest0) = fromPurePersistValues p xs-    (b, rest1) = fromPurePersistValues p rest0-    (c, rest2) = fromPurePersistValues p rest1+  toPurePersistValues (a, b, c) = toPurePersistValues a . toPurePersistValues b . toPurePersistValues c+  fromPurePersistValues xs = let+    (a, rest0) = fromPurePersistValues xs+    (b, rest1) = fromPurePersistValues rest0+    (c, rest2) = fromPurePersistValues rest1     in ((a, b, c), rest2)-  + instance (PurePersistField a, PurePersistField b, PurePersistField c, PurePersistField d) => PurePersistField (a, b, c, d) where-  toPurePersistValues p (a, b, c, d) = toPurePersistValues p a . toPurePersistValues p b . toPurePersistValues p c . toPurePersistValues p d-  fromPurePersistValues p xs = let-    (a, rest0) = fromPurePersistValues p xs-    (b, rest1) = fromPurePersistValues p rest0-    (c, rest2) = fromPurePersistValues p rest1-    (d, rest3) = fromPurePersistValues p rest2+  toPurePersistValues (a, b, c, d) = toPurePersistValues a . toPurePersistValues b . toPurePersistValues c . toPurePersistValues d+  fromPurePersistValues xs = let+    (a, rest0) = fromPurePersistValues xs+    (b, rest1) = fromPurePersistValues rest0+    (c, rest2) = fromPurePersistValues rest1+    (d, rest3) = fromPurePersistValues rest2     in ((a, b, c, d), rest3)-  + instance (PurePersistField a, PurePersistField b, PurePersistField c, PurePersistField d, PurePersistField e) => PurePersistField (a, b, c, d, e) where-  toPurePersistValues p (a, b, c, d, e) = toPurePersistValues p a . toPurePersistValues p b . toPurePersistValues p c . toPurePersistValues p d . toPurePersistValues p e-  fromPurePersistValues p xs = let-    (a, rest0) = fromPurePersistValues p xs-    (b, rest1) = fromPurePersistValues p rest0-    (c, rest2) = fromPurePersistValues p rest1-    (d, rest3) = fromPurePersistValues p rest2-    (e, rest4) = fromPurePersistValues p rest3+  toPurePersistValues (a, b, c, d, e) = toPurePersistValues a . toPurePersistValues b . toPurePersistValues c . toPurePersistValues d . toPurePersistValues e+  fromPurePersistValues xs = let+    (a, rest0) = fromPurePersistValues xs+    (b, rest1) = fromPurePersistValues rest0+    (c, rest2) = fromPurePersistValues rest1+    (d, rest3) = fromPurePersistValues rest2+    (e, rest4) = fromPurePersistValues rest3     in ((a, b, c, d, e), rest4)  instance PrimitivePersistField String where-  toPrimitivePersistValue _ s = PersistString s-  fromPrimitivePersistValue _ (PersistString s) = s-  fromPrimitivePersistValue _ (PersistByteString bs) = T.unpack $ T.decodeUtf8With T.lenientDecode bs-  fromPrimitivePersistValue _ (PersistInt64 i) = show i-  fromPrimitivePersistValue _ (PersistDouble d) = show d-  fromPrimitivePersistValue _ (PersistDay d) = show d-  fromPrimitivePersistValue _ (PersistTimeOfDay d) = show d-  fromPrimitivePersistValue _ (PersistUTCTime d) = show d-  fromPrimitivePersistValue _ (PersistZonedTime z) = show z-  fromPrimitivePersistValue _ (PersistBool b) = show b-  fromPrimitivePersistValue _ PersistNull = error "Unexpected NULL"-  fromPrimitivePersistValue _ (PersistCustom _ _) = error "Unexpected PersistCustom"+  toPrimitivePersistValue s = PersistText (T.pack s)+  fromPrimitivePersistValue (PersistString s) = s+  fromPrimitivePersistValue (PersistText s) = T.unpack s+  fromPrimitivePersistValue (PersistByteString bs) = T.unpack $ T.decodeUtf8With T.lenientDecode bs+  fromPrimitivePersistValue (PersistInt64 i) = show i+  fromPrimitivePersistValue (PersistDouble d) = show d+  fromPrimitivePersistValue (PersistDay d) = show d+  fromPrimitivePersistValue (PersistTimeOfDay d) = show d+  fromPrimitivePersistValue (PersistUTCTime d) = show d+  fromPrimitivePersistValue (PersistZonedTime z) = show z+  fromPrimitivePersistValue (PersistBool b) = show b+  fromPrimitivePersistValue PersistNull = error "Unexpected NULL"+  fromPrimitivePersistValue (PersistCustom _ _) = error "Unexpected PersistCustom"  instance PrimitivePersistField T.Text where-  toPrimitivePersistValue _ a = PersistString (T.unpack a)-  fromPrimitivePersistValue _ (PersistByteString bs) = T.decodeUtf8With T.lenientDecode bs-  fromPrimitivePersistValue p x = T.pack $ fromPrimitivePersistValue p x+  toPrimitivePersistValue s = PersistText s+  fromPrimitivePersistValue (PersistText s) = s+  fromPrimitivePersistValue (PersistByteString bs) = T.decodeUtf8With T.lenientDecode bs+  fromPrimitivePersistValue x = T.pack $ fromPrimitivePersistValue x +instance PrimitivePersistField TL.Text where+  toPrimitivePersistValue s = toPrimitivePersistValue (TL.toStrict s)+  fromPrimitivePersistValue x = TL.fromStrict $ fromPrimitivePersistValue x+ instance PrimitivePersistField ByteString where-  toPrimitivePersistValue _ s = PersistByteString s-  fromPrimitivePersistValue _ (PersistByteString a) = a-  fromPrimitivePersistValue p x = T.encodeUtf8 . T.pack $ fromPrimitivePersistValue p x+  toPrimitivePersistValue s = PersistByteString s+  fromPrimitivePersistValue (PersistByteString a) = a+  fromPrimitivePersistValue x = T.encodeUtf8 . T.pack $ fromPrimitivePersistValue x  instance PrimitivePersistField Lazy.ByteString where-  toPrimitivePersistValue _ s = PersistByteString $ Lazy.toStrict s-  fromPrimitivePersistValue _ (PersistByteString a) = Lazy.fromStrict a-  fromPrimitivePersistValue p x = Lazy.fromStrict . T.encodeUtf8 . T.pack $ fromPrimitivePersistValue p x+  toPrimitivePersistValue s = PersistByteString $ Lazy.toStrict s+  fromPrimitivePersistValue (PersistByteString a) = Lazy.fromStrict a+  fromPrimitivePersistValue x = Lazy.fromStrict . T.encodeUtf8 . T.pack $ fromPrimitivePersistValue x  instance PrimitivePersistField Int where-  toPrimitivePersistValue _ a = PersistInt64 (fromIntegral a)-  fromPrimitivePersistValue _ (PersistInt64 a) = fromIntegral a-  fromPrimitivePersistValue _ (PersistDouble a) = truncate a-  fromPrimitivePersistValue _ x = readHelper x ("Expected Integer, received: " ++ show x)+  toPrimitivePersistValue a = PersistInt64 (fromIntegral a)+  fromPrimitivePersistValue (PersistInt64 a) = fromIntegral a+  fromPrimitivePersistValue (PersistDouble a) = truncate a+  fromPrimitivePersistValue x = readHelper x ("Expected Integer, received: " ++ show x)  instance PrimitivePersistField Int8 where-  toPrimitivePersistValue _ a = PersistInt64 (fromIntegral a)-  fromPrimitivePersistValue _ (PersistInt64 a) = fromIntegral a-  fromPrimitivePersistValue _ (PersistDouble a) = truncate a-  fromPrimitivePersistValue _ x = readHelper x ("Expected Integer, received: " ++ show x)+  toPrimitivePersistValue a = PersistInt64 (fromIntegral a)+  fromPrimitivePersistValue (PersistInt64 a) = fromIntegral a+  fromPrimitivePersistValue (PersistDouble a) = truncate a+  fromPrimitivePersistValue x = readHelper x ("Expected Integer, received: " ++ show x)  instance PrimitivePersistField Int16 where-  toPrimitivePersistValue _ a = PersistInt64 (fromIntegral a)-  fromPrimitivePersistValue _ (PersistInt64 a) = fromIntegral a-  fromPrimitivePersistValue _ (PersistDouble a) = truncate a-  fromPrimitivePersistValue _ x = readHelper x ("Expected Integer, received: " ++ show x)+  toPrimitivePersistValue a = PersistInt64 (fromIntegral a)+  fromPrimitivePersistValue (PersistInt64 a) = fromIntegral a+  fromPrimitivePersistValue (PersistDouble a) = truncate a+  fromPrimitivePersistValue x = readHelper x ("Expected Integer, received: " ++ show x)  instance PrimitivePersistField Int32 where-  toPrimitivePersistValue _ a = PersistInt64 (fromIntegral a)-  fromPrimitivePersistValue _ (PersistInt64 a) = fromIntegral a-  fromPrimitivePersistValue _ (PersistDouble a) = truncate a-  fromPrimitivePersistValue _ x = readHelper x ("Expected Integer, received: " ++ show x)+  toPrimitivePersistValue a = PersistInt64 (fromIntegral a)+  fromPrimitivePersistValue (PersistInt64 a) = fromIntegral a+  fromPrimitivePersistValue (PersistDouble a) = truncate a+  fromPrimitivePersistValue x = readHelper x ("Expected Integer, received: " ++ show x)  instance PrimitivePersistField Int64 where-  toPrimitivePersistValue _ a = PersistInt64 (fromIntegral a)-  fromPrimitivePersistValue _ (PersistInt64 a) = a-  fromPrimitivePersistValue _ (PersistDouble a) = truncate a-  fromPrimitivePersistValue _ x = readHelper x ("Expected Integer, received: " ++ show x)+  toPrimitivePersistValue a = PersistInt64 (fromIntegral a)+  fromPrimitivePersistValue (PersistInt64 a) = a+  fromPrimitivePersistValue (PersistDouble a) = truncate a+  fromPrimitivePersistValue x = readHelper x ("Expected Integer, received: " ++ show x)  instance PrimitivePersistField Word8 where-  toPrimitivePersistValue _ a = PersistInt64 (fromIntegral a)-  fromPrimitivePersistValue _ (PersistInt64 a) = fromIntegral a-  fromPrimitivePersistValue _ (PersistDouble a) = truncate a-  fromPrimitivePersistValue _ x = readHelper x ("Expected Integer, received: " ++ show x)+  toPrimitivePersistValue a = PersistInt64 (fromIntegral a)+  fromPrimitivePersistValue (PersistInt64 a) = fromIntegral a+  fromPrimitivePersistValue (PersistDouble a) = truncate a+  fromPrimitivePersistValue x = readHelper x ("Expected Integer, received: " ++ show x)  instance PrimitivePersistField Word16 where-  toPrimitivePersistValue _ a = PersistInt64 (fromIntegral a)-  fromPrimitivePersistValue _ (PersistInt64 a) = fromIntegral a-  fromPrimitivePersistValue _ (PersistDouble a) = truncate a-  fromPrimitivePersistValue _ x = readHelper x ("Expected Integer, received: " ++ show x)+  toPrimitivePersistValue a = PersistInt64 (fromIntegral a)+  fromPrimitivePersistValue (PersistInt64 a) = fromIntegral a+  fromPrimitivePersistValue (PersistDouble a) = truncate a+  fromPrimitivePersistValue x = readHelper x ("Expected Integer, received: " ++ show x)  instance PrimitivePersistField Word32 where-  toPrimitivePersistValue _ a = PersistInt64 (fromIntegral a)-  fromPrimitivePersistValue _ (PersistInt64 a) = fromIntegral a-  fromPrimitivePersistValue _ (PersistDouble a) = truncate a-  fromPrimitivePersistValue _ x = readHelper x ("Expected Integer, received: " ++ show x)+  toPrimitivePersistValue a = PersistInt64 (fromIntegral a)+  fromPrimitivePersistValue (PersistInt64 a) = fromIntegral a+  fromPrimitivePersistValue (PersistDouble a) = truncate a+  fromPrimitivePersistValue x = readHelper x ("Expected Integer, received: " ++ show x)  instance PrimitivePersistField Word64 where-  toPrimitivePersistValue _ a = PersistInt64 (fromIntegral a)-  fromPrimitivePersistValue _ (PersistInt64 a) = fromIntegral a-  fromPrimitivePersistValue _ (PersistDouble a) = truncate a-  fromPrimitivePersistValue _ x = readHelper x ("Expected Integer, received: " ++ show x)+  toPrimitivePersistValue a = PersistInt64 (fromIntegral a)+  fromPrimitivePersistValue (PersistInt64 a) = fromIntegral a+  fromPrimitivePersistValue (PersistDouble a) = truncate a+  fromPrimitivePersistValue x = readHelper x ("Expected Integer, received: " ++ show x)  instance PrimitivePersistField Double where-  toPrimitivePersistValue _ a = PersistDouble a-  fromPrimitivePersistValue _ (PersistDouble a) = a-  fromPrimitivePersistValue _ (PersistInt64 a) = fromIntegral a-  fromPrimitivePersistValue _ x = readHelper x ("Expected Double, received: " ++ show x)+  toPrimitivePersistValue a = PersistDouble a+  fromPrimitivePersistValue (PersistDouble a) = a+  fromPrimitivePersistValue (PersistInt64 a) = fromIntegral a+  fromPrimitivePersistValue x = readHelper x ("Expected Double, received: " ++ show x)  instance PrimitivePersistField Bool where-  toPrimitivePersistValue _ a = PersistBool a-  fromPrimitivePersistValue _ (PersistBool a) = a-  fromPrimitivePersistValue _ (PersistInt64 i) = i /= 0-  fromPrimitivePersistValue _ x = error $ "Expected Bool, received: " ++ show x+  toPrimitivePersistValue a = PersistBool a+  fromPrimitivePersistValue (PersistBool a) = a+  fromPrimitivePersistValue (PersistInt64 i) = i /= 0+  fromPrimitivePersistValue x = error $ "Expected Bool, received: " ++ show x  instance PrimitivePersistField Day where-  toPrimitivePersistValue _ a = PersistDay a-  fromPrimitivePersistValue _ (PersistDay a) = a-  fromPrimitivePersistValue _ x = readHelper x ("Expected Day, received: " ++ show x)+  toPrimitivePersistValue a = PersistDay a+  fromPrimitivePersistValue (PersistDay a) = a+  fromPrimitivePersistValue x = readHelper x ("Expected Day, received: " ++ show x)  instance PrimitivePersistField TimeOfDay where-  toPrimitivePersistValue _ a = PersistTimeOfDay a-  fromPrimitivePersistValue _ (PersistTimeOfDay a) = a-  fromPrimitivePersistValue _ x = readHelper x ("Expected TimeOfDay, received: " ++ show x)+  toPrimitivePersistValue a = PersistTimeOfDay a+  fromPrimitivePersistValue (PersistTimeOfDay a) = a+  fromPrimitivePersistValue x = readHelper x ("Expected TimeOfDay, received: " ++ show x)  instance PrimitivePersistField UTCTime where-  toPrimitivePersistValue _ a = PersistUTCTime a-  fromPrimitivePersistValue _ (PersistUTCTime a) = a-  fromPrimitivePersistValue _ (PersistZonedTime (ZT a)) = zonedTimeToUTC a-  fromPrimitivePersistValue _ x = readHelper x ("Expected UTCTime, received: " ++ show x)+  toPrimitivePersistValue a = PersistUTCTime a+  fromPrimitivePersistValue (PersistUTCTime a) = a+  fromPrimitivePersistValue (PersistZonedTime (ZT a)) = zonedTimeToUTC a+  fromPrimitivePersistValue x = readHelper x ("Expected UTCTime, received: " ++ show x)  instance PrimitivePersistField ZonedTime where-  toPrimitivePersistValue _ a = PersistZonedTime (ZT a)-  fromPrimitivePersistValue _ (PersistZonedTime (ZT a)) = a-  fromPrimitivePersistValue _ (PersistUTCTime a) = utcToZonedTime utc a-  fromPrimitivePersistValue _ x = readHelper x ("Expected ZonedTime, received: " ++ show x)+  toPrimitivePersistValue a = PersistZonedTime (ZT a)+  fromPrimitivePersistValue (PersistZonedTime (ZT a)) = a+  fromPrimitivePersistValue (PersistUTCTime a) = utcToZonedTime utc a+  fromPrimitivePersistValue x = readHelper x ("Expected ZonedTime, received: " ++ show x)  instance (PrimitivePersistField a, NeverNull a) => PrimitivePersistField (Maybe a) where-  toPrimitivePersistValue p a = maybe PersistNull (toPrimitivePersistValue p) a-  fromPrimitivePersistValue _ PersistNull = Nothing-  fromPrimitivePersistValue p x = Just $ fromPrimitivePersistValue p x+  toPrimitivePersistValue a = maybe PersistNull toPrimitivePersistValue a+  fromPrimitivePersistValue PersistNull = Nothing+  fromPrimitivePersistValue x = Just $ fromPrimitivePersistValue x  instance (DbDescriptor db, PersistEntity v, PersistField v) => PrimitivePersistField (KeyForBackend db v) where-  toPrimitivePersistValue p (KeyForBackend a) = toPrimitivePersistValue p a-  fromPrimitivePersistValue p x = KeyForBackend (fromPrimitivePersistValue p x)+  toPrimitivePersistValue (KeyForBackend a) = toPrimitivePersistValue a+  fromPrimitivePersistValue x = KeyForBackend (fromPrimitivePersistValue x) -instance PrimitivePersistField a => PurePersistField a where+instance (PersistField a, PrimitivePersistField a) => PurePersistField a where   toPurePersistValues = primToPurePersistValues   fromPurePersistValues = primFromPurePersistValues -instance PrimitivePersistField a => SinglePersistField a where+instance (PersistField a, PrimitivePersistField a) => SinglePersistField a where   toSinglePersistValue = primToSinglePersistValue   fromSinglePersistValue = primFromSinglePersistValue  instance NeverNull String instance NeverNull T.Text+instance NeverNull TL.Text instance NeverNull ByteString instance NeverNull Lazy.ByteString instance NeverNull Int@@ -264,6 +272,7 @@ readHelper :: Read a => PersistValue -> String -> a readHelper s errMessage = case s of   PersistString str -> readHelper' str+  PersistText str -> readHelper' (T.unpack str)   PersistByteString str -> readHelper' (unpack str)   _ -> error $ "readHelper: " ++ errMessage   where@@ -295,6 +304,12 @@   fromPersistValues = primFromPersistValue   dbType _ _ = DbTypePrimitive DbString False Nothing Nothing +instance PersistField TL.Text where+  persistName _ = "Text"+  toPersistValues = primToPersistValue+  fromPersistValues = primFromPersistValue+  dbType _ _ = DbTypePrimitive DbString False Nothing Nothing+ instance PersistField Int where   persistName _ = "Int"   toPersistValues = primToPersistValue@@ -409,7 +424,7 @@   persistName a = "List" ++ delim : delim : persistName ((undefined :: [] a -> a) a)   toPersistValues l = insertList l >>= toPersistValues   fromPersistValues [] = fail "fromPersistValues []: empty list"-  fromPersistValues (x:xs) = phantomDb >>= \p -> getList (fromPrimitivePersistValue p x) >>= \l -> return (l, xs)+  fromPersistValues (x:xs) = getList (fromPrimitivePersistValue x) >>= \l -> return (l, xs)   dbType db a = DbList (persistName a) $ dbType db ((undefined :: [] a -> a) a)  instance PersistField () where@@ -429,7 +444,7 @@     (b, rest1) <- fromPersistValues rest0     return ((a, b), rest1)   dbType db a = DbEmbedded (EmbeddedDef False [("val0", dbType db ((undefined :: (a, b) -> a) a)), ("val1", dbType db ((undefined :: (a, b) -> b) a))]) Nothing-  + instance (PersistField a, PersistField b, PersistField c) => PersistField (a, b, c) where   persistName a = "Tuple3" ++ delim : delim : persistName ((undefined :: (a, b, c) -> a) a) ++ delim : persistName ((undefined :: (a, b, c) -> b) a) ++ delim : persistName ((undefined :: (a, b, c) -> c) a)   toPersistValues (a, b, c) = do@@ -443,7 +458,7 @@     (c, rest2) <- fromPersistValues rest1     return ((a, b, c), rest2)   dbType db a = DbEmbedded (EmbeddedDef False [("val0", dbType db ((undefined :: (a, b, c) -> a) a)), ("val1", dbType db ((undefined :: (a, b, c) -> b) a)), ("val2", dbType db ((undefined :: (a, b, c) -> c) a))]) Nothing-  + instance (PersistField a, PersistField b, PersistField c, PersistField d) => PersistField (a, b, c, d) where   persistName a = "Tuple4" ++ delim : delim : persistName ((undefined :: (a, b, c, d) -> a) a) ++ delim : persistName ((undefined :: (a, b, c, d) -> b) a) ++ delim : persistName ((undefined :: (a, b, c, d) -> c) a) ++ delim : persistName ((undefined :: (a, b, c, d) -> d) a)   toPersistValues (a, b, c, d) = do@@ -459,7 +474,7 @@     (d, rest3) <- fromPersistValues rest2     return ((a, b, c, d), rest3)   dbType db a = DbEmbedded (EmbeddedDef False [("val0", dbType db ((undefined :: (a, b, c, d) -> a) a)), ("val1", dbType db ((undefined :: (a, b, c, d) -> b) a)), ("val2", dbType db ((undefined :: (a, b, c, d) -> c) a)), ("val3", dbType db ((undefined :: (a, b, c, d) -> d) a))]) Nothing-  + instance (PersistField a, PersistField b, PersistField c, PersistField d, PersistField e) => PersistField (a, b, c, d, e) where   persistName a = "Tuple5" ++ delim : delim : persistName ((undefined :: (a, b, c, d, e) -> a) a) ++ delim : persistName ((undefined :: (a, b, c, d, e) -> b) a) ++ delim : persistName ((undefined :: (a, b, c, d, e) -> c) a) ++ delim : persistName ((undefined :: (a, b, c, d, e) -> d) a) ++ delim : persistName ((undefined :: (a, b, c, d, e) -> e) a)   toPersistValues (a, b, c, d, e) = do@@ -625,7 +640,7 @@   entityConstrNum' _ = phantomConstrNum  instance A.FromJSON PersistValue where-  parseJSON (A.String t) = return $ PersistString $ T.unpack t+  parseJSON (A.String t) = return $ PersistText t #if MIN_VERSION_aeson(0, 7, 0)   parseJSON (A.Number n) = return $     if fromInteger (floor n) == n@@ -641,6 +656,7 @@  instance A.ToJSON PersistValue where   toJSON (PersistString t) = A.String $ T.pack t+  toJSON (PersistText t) = A.String t   toJSON (PersistByteString b) = A.String $ T.decodeUtf8 $ B64.encode b   toJSON (PersistInt64 i) = A.Number $ fromIntegral i   toJSON (PersistDouble d) = A.Number $

@@ -1,3 +1,8 @@+0.8+* Simplified signatures for PurePersistField and PrimitivePersistField+* Basic support for streaming API+* Support for GHC 8+ 0.7.0.3 * Add attoparsec dependency 

@@ -1,5 +1,5 @@ name:            groundhog-version:         0.7.0.3+version:         0.8 license:         BSD3 license-file:    LICENSE author:          Boris Lykah <lykahb@gmail.com>@@ -16,10 +16,10 @@     changelog  library-    build-depends:   base                     >= 4          && < 5-                   , bytestring               >= 0.9+    build-depends:   base                     >= 4.5        && < 5+                   , bytestring               >= 0.10                    , base64-bytestring-                   , transformers             >= 0.2.1      && < 0.5+                   , transformers             >= 0.2.1      && < 0.6                    , mtl                      >= 2.0                    , time                     >= 1.1.4                    , attoparsec               >= 0.11@@ -29,8 +29,8 @@                    , blaze-builder            >= 0.3        && < 0.5                    , containers               >= 0.2                    , monad-control            >= 0.3        && < 1.1-                   , monad-logger             >= 0.3        && < 0.4                    , transformers-base+                   , resourcet                >= 1.1.2     exposed-modules: Database.Groundhog                      Database.Groundhog.Core                      Database.Groundhog.Expression@@ -41,7 +41,7 @@                      Database.Groundhog.Generic.PersistBackendHelpers                      Database.Groundhog.Instances     ghc-options:     -Wall-    + source-repository head   type:     git   location: git://github.com/lykahb/groundhog.git