diff --git a/Database/Persist.hs b/Database/Persist.hs
--- a/Database/Persist.hs
+++ b/Database/Persist.hs
@@ -1,244 +1,11 @@
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PackageImports #-}
-
--- | This defines the API for performing database actions. There are two levels
--- to this API: dealing with fields, and dealing with entities. In SQL, a field
--- corresponds to a column, and should be a single, non-composite value. An
--- entity corresponds to a SQL table.  In other words: An entity is a
--- collection of fields.
 module Database.Persist
-    ( -- * Fields
-      PersistValue (..)
-    , SqlType (..)
-    , PersistField (..)
-      -- * Entities
+    ( PersistField (..)
     , PersistEntity (..)
+    , PersistBackend (..)
+    , mkPersist
+    , persist
     ) where
 
-import Data.Time (Day, TimeOfDay, UTCTime)
-import Data.ByteString.Char8 (ByteString, unpack)
-import qualified Data.ByteString.UTF8 as BSU
-import Control.Applicative
-import Data.Typeable (Typeable)
-import Data.Int (Int64)
-import Text.Hamlet
-import qualified Data.Text as T
-import qualified Data.ByteString as S
-import qualified Data.ByteString.Lazy as L
-import "MonadCatchIO-transformers" Control.Monad.CatchIO (MonadCatchIO)
-
--- | A raw value which can be stored in any backend and can be marshalled to
--- and from a 'PersistField'.
-data PersistValue = PersistString String
-                  | PersistByteString ByteString
-                  | PersistInt64 Int64
-                  | PersistDouble Double
-                  | PersistBool Bool
-                  | PersistDay Day
-                  | PersistTimeOfDay TimeOfDay
-                  | PersistUTCTime UTCTime
-                  | PersistNull
-    deriving (Show, Read, Eq, Typeable)
-
--- | A SQL data type. Naming attempts to reflect the underlying Haskell
--- datatypes, eg SqlString instead of SqlVarchar. Different SQL databases may
--- have different translations for these types.
-data SqlType = SqlString
-             | SqlInteger
-             | SqlReal
-             | SqlBool
-             | SqlDay
-             | SqlTime
-             | SqlDayTime
-             | SqlBlob
-    deriving (Show, Read, Eq, Typeable)
-
--- | A value which can be marshalled to and from a 'PersistValue'.
-class PersistField a where
-    toPersistValue :: a -> PersistValue
-    fromPersistValue :: PersistValue -> Either String a
-    sqlType :: a -> SqlType
-    isNullable :: a -> Bool
-    isNullable _ = False
-
-instance PersistField String where
-    toPersistValue = PersistString
-    fromPersistValue (PersistString s) = Right s
-    fromPersistValue (PersistByteString bs) = Right $ BSU.toString bs
-    fromPersistValue (PersistInt64 i) = Right $ show i
-    fromPersistValue (PersistDouble d) = Right $ show d
-    fromPersistValue (PersistDay d) = Right $ show d
-    fromPersistValue (PersistTimeOfDay d) = Right $ show d
-    fromPersistValue (PersistUTCTime d) = Right $ show d
-    fromPersistValue PersistNull = Left "Unexpected null"
-    fromPersistValue (PersistBool b) = Right $ show b
-    sqlType _ = SqlString
-
-instance PersistField ByteString where
-    toPersistValue = PersistByteString
-    fromPersistValue (PersistByteString bs) = Right bs
-    fromPersistValue x = BSU.fromString <$> fromPersistValue x
-    sqlType _ = SqlBlob
-
-instance PersistField T.Text where
-    toPersistValue = PersistString . T.unpack
-    fromPersistValue = fmap T.pack . fromPersistValue
-    sqlType _ = SqlString
-
-instance PersistField (Html ()) where
-    toPersistValue = PersistByteString . S.concat . L.toChunks . renderHtml
-    fromPersistValue = fmap unsafeByteString . fromPersistValue
-    sqlType _ = SqlString
-
-instance PersistField Int where
-    toPersistValue = PersistInt64 . fromIntegral
-    fromPersistValue (PersistInt64 i) = Right $ fromIntegral i
-    fromPersistValue x = Left $ "Expected Integer, received: " ++ show x
-    sqlType _ = SqlInteger
-
-instance PersistField Int64 where
-    toPersistValue = PersistInt64 . fromIntegral
-    fromPersistValue (PersistInt64 i) = Right $ fromIntegral i
-    fromPersistValue x = Left $ "Expected Integer, received: " ++ show x
-    sqlType _ = SqlInteger
-
-instance PersistField Double where
-    toPersistValue = PersistDouble
-    fromPersistValue (PersistDouble d) = Right d
-    fromPersistValue x = Left $ "Expected Double, received: " ++ show x
-    sqlType _ = SqlReal
-
-instance PersistField Bool where
-    toPersistValue = PersistBool
-    fromPersistValue (PersistBool b) = Right b
-    fromPersistValue (PersistInt64 i) = Right $ i /= 0
-    fromPersistValue x = Left $ "Expected Bool, received: " ++ show x
-    sqlType _ = SqlBool
-
-instance PersistField Day where
-    toPersistValue = PersistDay
-    fromPersistValue (PersistDay d) = Right d
-    fromPersistValue x@(PersistString s) =
-        case reads s of
-            (d, _):_ -> Right d
-            _ -> Left $ "Expected Day, received " ++ show x
-    fromPersistValue x@(PersistByteString s) =
-        case reads $ unpack s of
-            (d, _):_ -> Right d
-            _ -> Left $ "Expected Day, received " ++ show x
-    fromPersistValue x = Left $ "Expected Day, received: " ++ show x
-    sqlType _ = SqlDay
-
-instance PersistField TimeOfDay where
-    toPersistValue = PersistTimeOfDay
-    fromPersistValue (PersistTimeOfDay d) = Right d
-    fromPersistValue x@(PersistString s) =
-        case reads s of
-            (d, _):_ -> Right d
-            _ -> Left $ "Expected TimeOfDay, received " ++ show x
-    fromPersistValue x@(PersistByteString s) =
-        case reads $ unpack s of
-            (d, _):_ -> Right d
-            _ -> Left $ "Expected TimeOfDay, received " ++ show x
-    fromPersistValue x = Left $ "Expected TimeOfDay, received: " ++ show x
-    sqlType _ = SqlTime
-
-instance PersistField UTCTime where
-    toPersistValue = PersistUTCTime
-    fromPersistValue (PersistUTCTime d) = Right d
-    fromPersistValue x@(PersistString s) =
-        case reads s of
-            (d, _):_ -> Right d
-            _ -> Left $ "Expected UTCTime, received " ++ show x
-    fromPersistValue x@(PersistByteString s) =
-        case reads $ unpack s of
-            (d, _):_ -> Right d
-            _ -> Left $ "Expected UTCTime, received " ++ show x
-    fromPersistValue x = Left $ "Expected UTCTime, received: " ++ show x
-    sqlType _ = SqlDayTime
-
-instance PersistField a => PersistField (Maybe a) where
-    toPersistValue Nothing = PersistNull
-    toPersistValue (Just a) = toPersistValue a
-    fromPersistValue PersistNull = Right Nothing
-    fromPersistValue x = fmap Just $ fromPersistValue x
-    sqlType _ = sqlType (error "this is the problem" :: a)
-    isNullable _ = True
-
--- | A single database entity. For example, if writing a blog application, a
--- blog entry would be an entry, containing fields such as title and content.
-class PersistEntity val where
-    -- | The monad transformer in which actions for this entity must occur. For
-    -- example, entities declared to work with a sqlite backend would most
-    -- likely use a ReaderT monad transformer holding onto a database
-    -- connection.
-    --
-    -- By using a monad transformer here, users can allow arbitrary effects to
-    -- exist in the underlying monad. For example, Yesod applications can embed
-    -- a Handler monad here. The only restriction on that underlying monad is
-    -- it must be an instance of 'MonadCatchIO'.
-    type PersistMonad val :: (* -> *) -> * -> *
-
-    -- | The unique identifier associated with this entity. In general, backends also define a type synonym for this, such that \"type MyEntityId = Key MyEntity\".
-    data Key    val
-    -- | Fields which can be updated using the 'update' and 'updateWhere'
-    -- functions.
-    data Update val
-    -- | Filters which are available for 'select', 'updateWhere' and
-    -- 'deleteWhere'. Each filter constructor specifies the field being
-    -- filtered on, the type of comparison applied (equals, not equals, etc)
-    -- and the argument for the comparison.
-    data Filter val
-    -- | How you can sort the results of a 'select'.
-    data Order  val
-    -- | Unique keys in existence on this entity.
-    data Unique val
-
-    -- | Prepare database for this entity, if necessary. In SQL, this creates
-    -- values and indices if they don't exist. The first argument is not used,
-    -- so you can used 'undefined'.
-    initialize :: MonadCatchIO m => val -> (PersistMonad val) m ()
-
-    -- | Create a new record in the database, returning the newly created
-    -- identifier.
-    insert :: MonadCatchIO m => val -> (PersistMonad val) m (Key val)
-
-    -- | Replace the record in the database with the given key. Result is
-    -- undefined if such a record does not exist.
-    replace :: MonadCatchIO m => Key val -> val -> (PersistMonad val) m ()
-
-    -- | Update individual fields on a specific record.
-    update :: MonadCatchIO m => Key val -> [Update val]
-           -> (PersistMonad val) m ()
-
-    -- | Update individual fields on any record matching the given criterion.
-    updateWhere :: MonadCatchIO m => [Filter val] -> [Update val]
-                -> (PersistMonad val) m ()
-
-    -- | Delete a specific record by identifier. Does nothing if record does
-    -- not exist.
-    delete :: MonadCatchIO m => Key val -> (PersistMonad val) m ()
-
-    -- | Delete a specific record by unique key. Does nothing if no record
-    -- matches.
-    deleteBy :: MonadCatchIO m => Unique val -> (PersistMonad val) m ()
-
-    -- | Delete all records matching the given criterion.
-    deleteWhere :: MonadCatchIO m => [Filter val] -> (PersistMonad val) m ()
-
-    -- | Get a record by identifier, if available.
-    get :: MonadCatchIO m => Key val -> (PersistMonad val) m (Maybe val)
-
-    -- | Get a record by unique key, if available. Returns also the identifier.
-    getBy :: MonadCatchIO m => Unique val
-          -> (PersistMonad val) m (Maybe (Key val, val))
-
-    -- | Get all records matching the given criterion in the specified order.
-    -- Returns also the identifiers.
-    select :: MonadCatchIO m => [Filter val] -> [Order val]
-           -> (PersistMonad val) m [(Key val, val)]
+import Database.Persist.Base
+import Database.Persist.TH
+import Database.Persist.Quasi
diff --git a/Database/Persist/Base.hs b/Database/Persist/Base.hs
new file mode 100644
--- /dev/null
+++ b/Database/Persist/Base.hs
@@ -0,0 +1,300 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE ExistentialQuantification #-}
+
+-- | This defines the API for performing database actions. There are two levels
+-- to this API: dealing with fields, and dealing with entities. In SQL, a field
+-- corresponds to a column, and should be a single, non-composite value. An
+-- entity corresponds to a SQL table.  In other words: An entity is a
+-- collection of fields.
+module Database.Persist.Base
+    ( PersistValue (..)
+    , SqlType (..)
+    , PersistField (..)
+    , PersistEntity (..)
+    , EntityDef (..)
+    , PersistBackend (..)
+    , PersistFilter (..)
+    , PersistOrder (..)
+    , SomePersistField (..)
+    ) where
+
+import Language.Haskell.TH.Syntax
+import Data.Time (Day, TimeOfDay, UTCTime)
+import Data.ByteString.Char8 (ByteString, unpack)
+import qualified Data.ByteString.UTF8 as BSU
+import Control.Applicative
+import Data.Typeable (Typeable)
+import Data.Int (Int64)
+import Text.Blaze
+import qualified Data.Text as T
+import qualified Data.ByteString as S
+import qualified Data.ByteString.Lazy as L
+
+-- | A raw value which can be stored in any backend and can be marshalled to
+-- and from a 'PersistField'.
+data PersistValue = PersistString String
+                  | PersistByteString ByteString
+                  | PersistInt64 Int64
+                  | PersistDouble Double
+                  | PersistBool Bool
+                  | PersistDay Day
+                  | PersistTimeOfDay TimeOfDay
+                  | PersistUTCTime UTCTime
+                  | PersistNull
+    deriving (Show, Read, Eq, Typeable)
+
+-- | A SQL data type. Naming attempts to reflect the underlying Haskell
+-- datatypes, eg SqlString instead of SqlVarchar. Different SQL databases may
+-- have different translations for these types.
+data SqlType = SqlString
+             | SqlInteger
+             | SqlReal
+             | SqlBool
+             | SqlDay
+             | SqlTime
+             | SqlDayTime
+             | SqlBlob
+    deriving (Show, Read, Eq, Typeable)
+
+-- | A value which can be marshalled to and from a 'PersistValue'.
+class PersistField a where
+    toPersistValue :: a -> PersistValue
+    fromPersistValue :: PersistValue -> Either String a
+    sqlType :: a -> SqlType
+    isNullable :: a -> Bool
+    isNullable _ = False
+
+instance PersistField String where
+    toPersistValue = PersistString
+    fromPersistValue (PersistString s) = Right s
+    fromPersistValue (PersistByteString bs) = Right $ BSU.toString bs
+    fromPersistValue (PersistInt64 i) = Right $ show i
+    fromPersistValue (PersistDouble d) = Right $ show d
+    fromPersistValue (PersistDay d) = Right $ show d
+    fromPersistValue (PersistTimeOfDay d) = Right $ show d
+    fromPersistValue (PersistUTCTime d) = Right $ show d
+    fromPersistValue PersistNull = Left "Unexpected null"
+    fromPersistValue (PersistBool b) = Right $ show b
+    sqlType _ = SqlString
+
+instance PersistField ByteString where
+    toPersistValue = PersistByteString
+    fromPersistValue (PersistByteString bs) = Right bs
+    fromPersistValue x = BSU.fromString <$> fromPersistValue x
+    sqlType _ = SqlBlob
+
+instance PersistField T.Text where
+    toPersistValue = PersistString . T.unpack
+    fromPersistValue = fmap T.pack . fromPersistValue
+    sqlType _ = SqlString
+
+instance PersistField (Html ()) where
+    toPersistValue = PersistByteString . S.concat . L.toChunks . renderHtml
+    fromPersistValue = fmap unsafeByteString . fromPersistValue
+    sqlType _ = SqlString
+
+instance PersistField Int where
+    toPersistValue = PersistInt64 . fromIntegral
+    fromPersistValue (PersistInt64 i) = Right $ fromIntegral i
+    fromPersistValue x = Left $ "Expected Integer, received: " ++ show x
+    sqlType _ = SqlInteger
+
+instance PersistField Int64 where
+    toPersistValue = PersistInt64 . fromIntegral
+    fromPersistValue (PersistInt64 i) = Right $ fromIntegral i
+    fromPersistValue x = Left $ "Expected Integer, received: " ++ show x
+    sqlType _ = SqlInteger
+
+instance PersistField Double where
+    toPersistValue = PersistDouble
+    fromPersistValue (PersistDouble d) = Right d
+    fromPersistValue x = Left $ "Expected Double, received: " ++ show x
+    sqlType _ = SqlReal
+
+instance PersistField Bool where
+    toPersistValue = PersistBool
+    fromPersistValue (PersistBool b) = Right b
+    fromPersistValue (PersistInt64 i) = Right $ i /= 0
+    fromPersistValue x = Left $ "Expected Bool, received: " ++ show x
+    sqlType _ = SqlBool
+
+instance PersistField Day where
+    toPersistValue = PersistDay
+    fromPersistValue (PersistDay d) = Right d
+    fromPersistValue x@(PersistString s) =
+        case reads s of
+            (d, _):_ -> Right d
+            _ -> Left $ "Expected Day, received " ++ show x
+    fromPersistValue x@(PersistByteString s) =
+        case reads $ unpack s of
+            (d, _):_ -> Right d
+            _ -> Left $ "Expected Day, received " ++ show x
+    fromPersistValue x = Left $ "Expected Day, received: " ++ show x
+    sqlType _ = SqlDay
+
+instance PersistField TimeOfDay where
+    toPersistValue = PersistTimeOfDay
+    fromPersistValue (PersistTimeOfDay d) = Right d
+    fromPersistValue x@(PersistString s) =
+        case reads s of
+            (d, _):_ -> Right d
+            _ -> Left $ "Expected TimeOfDay, received " ++ show x
+    fromPersistValue x@(PersistByteString s) =
+        case reads $ unpack s of
+            (d, _):_ -> Right d
+            _ -> Left $ "Expected TimeOfDay, received " ++ show x
+    fromPersistValue x = Left $ "Expected TimeOfDay, received: " ++ show x
+    sqlType _ = SqlTime
+
+instance PersistField UTCTime where
+    toPersistValue = PersistUTCTime
+    fromPersistValue (PersistUTCTime d) = Right d
+    fromPersistValue x@(PersistString s) =
+        case reads s of
+            (d, _):_ -> Right d
+            _ -> Left $ "Expected UTCTime, received " ++ show x
+    fromPersistValue x@(PersistByteString s) =
+        case reads $ unpack s of
+            (d, _):_ -> Right d
+            _ -> Left $ "Expected UTCTime, received " ++ show x
+    fromPersistValue x = Left $ "Expected UTCTime, received: " ++ show x
+    sqlType _ = SqlDayTime
+
+instance PersistField a => PersistField (Maybe a) where
+    toPersistValue Nothing = PersistNull
+    toPersistValue (Just a) = toPersistValue a
+    fromPersistValue PersistNull = Right Nothing
+    fromPersistValue x = fmap Just $ fromPersistValue x
+    sqlType _ = sqlType (error "this is the problem" :: a)
+    isNullable _ = True
+
+-- | A single database entity. For example, if writing a blog application, a
+-- blog entry would be an entry, containing fields such as title and content.
+class PersistEntity val where
+    -- | The unique identifier associated with this entity. In general, backends also define a type synonym for this, such that \"type MyEntityId = Key MyEntity\".
+    data Key    val
+    -- | Fields which can be updated using the 'update' and 'updateWhere'
+    -- functions.
+    data Update val
+    -- | Filters which are available for 'select', 'updateWhere' and
+    -- 'deleteWhere'. Each filter constructor specifies the field being
+    -- filtered on, the type of comparison applied (equals, not equals, etc)
+    -- and the argument for the comparison.
+    data Filter val
+    -- | How you can sort the results of a 'select'.
+    data Order  val
+    -- | Unique keys in existence on this entity.
+    data Unique val
+
+    entityDef :: val -> EntityDef
+    toPersistFields :: val -> [SomePersistField]
+    fromPersistValues :: [PersistValue] -> Either String val
+    halfDefined :: val
+    toPersistKey :: Int64 -> Key val
+    fromPersistKey :: Key val -> Int64
+    showPersistKey :: Key val -> String
+
+    persistFilterToFieldName :: Filter val -> String
+    persistFilterToFilter :: Filter val -> PersistFilter
+    persistFilterIsNull :: Filter val -> Bool
+    persistFilterToValue :: Filter val -> PersistValue
+
+    persistOrderToFieldName :: Order val -> String
+    persistOrderToOrder :: Order val -> PersistOrder
+
+    persistUpdateToFieldName :: Update val -> String
+    persistUpdateToValue :: Update val -> PersistValue
+
+    persistUniqueToFieldNames :: Unique val -> [String]
+    persistUniqueToValues :: Unique val -> [PersistValue]
+
+data SomePersistField = forall a. PersistField a => SomePersistField a
+instance PersistField SomePersistField where
+    toPersistValue (SomePersistField a) = toPersistValue a
+    fromPersistValue x = fmap SomePersistField (fromPersistValue x :: Either String String)
+    sqlType (SomePersistField a) = sqlType a
+
+class PersistBackend m where
+    -- | Prepare database for this entity, if necessary. In SQL, this creates
+    -- values and indices if they don't exist. The first argument is not used,
+    -- so you can used 'undefined'.
+    initialize :: PersistEntity val => val -> m ()
+
+    -- | Create a new record in the database, returning the newly created
+    -- identifier.
+    insert :: PersistEntity val => val -> m (Key val)
+
+    -- | Replace the record in the database with the given key. Result is
+    -- undefined if such a record does not exist.
+    replace :: PersistEntity val => Key val -> val -> m ()
+
+    -- | Update individual fields on a specific record.
+    update :: PersistEntity val => Key val -> [Update val] -> m ()
+
+    -- | Update individual fields on any record matching the given criterion.
+    updateWhere :: PersistEntity val => [Filter val] -> [Update val] -> m ()
+
+    -- | Delete a specific record by identifier. Does nothing if record does
+    -- not exist.
+    delete :: PersistEntity val => Key val -> m ()
+
+    -- | Delete a specific record by unique key. Does nothing if no record
+    -- matches.
+    deleteBy :: PersistEntity val => Unique val -> m ()
+
+    -- | Delete all records matching the given criterion.
+    deleteWhere :: PersistEntity val => [Filter val] -> m ()
+
+    -- | Get a record by identifier, if available.
+    get :: PersistEntity val => Key val -> m (Maybe val)
+
+    -- | Get a record by unique key, if available. Returns also the identifier.
+    getBy :: PersistEntity val => Unique val -> m (Maybe (Key val, val))
+
+    -- | Get all records matching the given criterion in the specified order.
+    -- Returns also the identifiers.
+    select :: PersistEntity val => [Filter val] -> [Order val]
+           -> m [(Key val, val)]
+
+data EntityDef = EntityDef
+    { entityName    :: String
+    , entityAttribs :: [String]
+    , entityColumns :: [(String, String, [String])] -- ^ name, type, attribs
+    , entityUniques :: [(String, [String])] -- ^ name, columns
+    , entityDerives :: [String]
+    }
+    deriving Show
+
+instance Lift EntityDef where
+    lift (EntityDef a b c d e) = do
+        x <- [|EntityDef|]
+        a' <- lift a
+        b' <- lift b
+        c' <- lift c
+        d' <- lift d
+        e' <- lift e
+        return $ x `AppE` a' `AppE` b' `AppE` c' `AppE` d' `AppE` e'
+
+data PersistFilter = Eq | Ne | Gt | Lt | Ge | Le
+    deriving (Read, Show)
+
+instance Lift PersistFilter where
+    lift Eq = [|Eq|]
+    lift Ne = [|Ne|]
+    lift Gt = [|Gt|]
+    lift Lt = [|Lt|]
+    lift Ge = [|Ge|]
+    lift Le = [|Le|]
+
+data PersistOrder = Asc | Desc
+    deriving (Read, Show)
+
+instance Lift PersistOrder where
+    lift Asc = [|Asc|]
+    lift Desc = [|Desc|]
diff --git a/Database/Persist/GenericSql.hs b/Database/Persist/GenericSql.hs
--- a/Database/Persist/GenericSql.hs
+++ b/Database/Persist/GenericSql.hs
@@ -8,24 +8,25 @@
 -- | This is a helper module for creating SQL backends. Regular users do not
 -- need to use this module.
 module Database.Persist.GenericSql
-    ( Int64
-    , module Database.Persist.Helper
-    , persist
-    , deriveGenericSql
+    ( GenericSql (..)
     , RowPopper
-    , GenericSql (..)
+    , initialize
+    , insert
+    , get
+    , replace
+    , select
+    , deleteWhere
+    , update
+    , updateWhere
+    , getBy
+    , delete
+    , deleteBy
     ) where
 
-import Database.Persist (PersistEntity, Key, Order, Filter, Update,
-                         Unique, SqlType (..), PersistValue (..),
-                         PersistField (..))
-import Database.Persist.Helper
-import Language.Haskell.TH.Syntax hiding (lift)
-import qualified Language.Haskell.TH.Syntax as TH
+import Database.Persist.Base hiding (PersistBackend (..))
 import Data.List (intercalate)
 import Control.Monad (unless, liftM)
 import Data.Int (Int64)
-import Database.Persist.Quasi
 import Control.Arrow (second)
 
 data GenericSql m = GenericSql
@@ -35,100 +36,13 @@
     , gsInsert :: String -> [String] -> [PersistValue] -> m Int64
     , gsEntityDefExists :: String -> m Bool
     , gsKeyType :: String
+    , gsShowSqlType :: SqlType -> String
     }
 
 type RowPopper m = m (Maybe [PersistValue])
 
-deriveGenericSql :: Type -> Exp -> EntityDef -> Q [Dec]
-deriveGenericSql monad gs t = do
-    let name = entityName t
-    let dt = dataTypeDec t
-
-    fsv <- mkFromPersistValues t
-    let sq =
-          InstanceD [] (ConT ''FromPersistValues `AppT` ConT (mkName name))
-            [ FunD (mkName "fromPersistValues") fsv
-            ]
-
-    let keysyn = TySynD (mkName $ name ++ "Id") [] $
-                    ConT ''Key `AppT` ConT (mkName name)
-
-    t' <- TH.lift t
-    let mkFun s e = FunD (mkName s) [Clause [] (NormalB $ e `AppE` t') []]
-
-    let gs' = fmap (`AppE` gs)
-    init' <- gs' [|initialize|]
-    insert' <- gs' [|insert|]
-    replace' <- gs' [|replace|]
-    get' <- gs' [|get|]
-    getBy' <- gs' [|getBy|]
-    select' <- gs' [|select|]
-    deleteWhere' <- gs' [|deleteWhere|]
-    delete' <- gs' [|delete|]
-    deleteBy' <- gs' [|deleteBy|]
-    update' <- gs' [|update|]
-    updateWhere' <- gs' [|updateWhere|]
-
-    let inst =
-          InstanceD
-            []
-            (ConT ''PersistEntity `AppT` ConT (mkName name))
-            [ persistMonadTypeDec monad t
-            , keyTypeDec (name ++ "Id") "Int64" t
-            , filterTypeDec t
-            , updateTypeDec t
-            , orderTypeDec t
-            , uniqueTypeDec t
-            , mkFun "initialize" $ init'
-            , mkFun "insert" $ insert'
-            , mkFun "replace" $ replace'
-            , mkFun "get" $ get'
-            , mkFun "getBy" $ getBy'
-            , mkFun "select" $ select'
-            , mkFun "deleteWhere" $ deleteWhere'
-            , mkFun "delete" $ delete'
-            , mkFun "deleteBy" $ deleteBy'
-            , mkFun "update" $ update'
-            , mkFun "updateWhere" $ updateWhere'
-            ]
-
-    tops <- mkToPersistFields (ConT $ mkName name)
-                [(name, length $ tableColumns t)]
-    topsUn <- mkToPersistFields (ConT ''Unique `AppT` ConT (mkName name))
-            $ map (\(x, y) -> (x, length y))
-            $ entityUniques t
-
-    return
-        [ dt, sq, inst, keysyn, tops, topsUn
-        , mkToFieldName (ConT ''Update `AppT` ConT (mkName name))
-                $ map (\(s, _, _) -> (name ++ upperFirst s, s))
-                $ entityUpdates t
-        , mkPersistField (ConT ''Update `AppT` ConT (mkName name))
-                $ map (\(s, _, _) -> name ++ upperFirst s) $ entityUpdates t
-        , mkToFieldNames (ConT ''Unique `AppT` ConT (mkName name))
-                $ entityUniques t
-        , mkPersistField (ConT ''Filter `AppT` ConT (mkName name))
-                $ map (\(x, _, _, y) -> name ++ upperFirst x ++ show y)
-                $ entityFilters t
-        , mkToFieldName (ConT ''Filter `AppT` ConT (mkName name))
-                $ map (\(x, _, _, y) -> (name ++ upperFirst x ++ show y, x))
-                $ entityFilters t
-        , mkToFilter (ConT ''Filter `AppT` ConT (mkName name))
-                $ map (\(x, _, z, y) ->
-                    (name ++ upperFirst x ++ show y, y, z))
-                $ entityFilters t
-        , mkToFieldName (ConT ''Order `AppT` ConT (mkName name))
-                $ map (\(x, y) -> (name ++ upperFirst x ++ y, x))
-                $ entityOrders t
-        , mkToOrder (ConT ''Order `AppT` ConT (mkName name))
-                $ map (\(x, y) -> (name ++ upperFirst x ++ y, y))
-                $ entityOrders t
-        , mkHalfDefined (ConT $ mkName name) name $ length $ tableColumns t
-        ]
-
-initialize :: (ToPersistFields v, Monad m, HalfDefined v)
-           => GenericSql m -> EntityDef -> v -> m ()
-initialize gs t v = do
+initialize :: (Monad m, PersistEntity v) => GenericSql m -> v -> m ()
+initialize gs v = do
     doesExist <- gsEntityDefExists gs $ tableName t
     unless doesExist $ do
         let cols = zip (tableColumns t) $ toPersistFields
@@ -139,90 +53,67 @@
         gsExecute gs sql []
         mapM_ go $ tableUniques' t
   where
+    t = entityDef v
     go' ((colName, _, as), p) = concat
         [ ","
         , colName
         , " "
-        , showSqlType $ sqlType p
+        , gsShowSqlType gs $ sqlType p
         , if "null" `elem` as then " NULL" else " NOT NULL"
         ]
     go (index, fields) = do
         let sql = "CREATE UNIQUE INDEX " ++ index ++ " ON " ++
                   tableName t ++ "(" ++ intercalate "," fields ++ ")"
         gsExecute gs sql []
-    showSqlType SqlString = "VARCHAR"
-    showSqlType SqlInteger = "INTEGER"
-    showSqlType SqlReal = "REAL"
-    showSqlType SqlDay = "DATE"
-    showSqlType SqlTime = "TIME"
-    showSqlType SqlDayTime = "TIMESTAMP"
-    showSqlType SqlBlob = "BLOB"
-    showSqlType SqlBool = "BOOLEAN"
 
-mkFromPersistValues :: EntityDef -> Q [Clause]
-mkFromPersistValues t = do
-    nothing <- [|Left "Invalid fromPersistValues input"|]
-    let cons = ConE $ mkName $ entityName t
-    xs <- mapM (const $ newName "x") $ entityColumns t
-    fs <- [|fromPersistValue|]
-    let xs' = map (AppE fs . VarE) xs
-    let pat = ListP $ map VarP xs
-    ap' <- [|apE|]
-    just <- [|Right|]
-    let cons' = just `AppE` cons
-    return
-        [ Clause [pat] (NormalB $ foldl (go ap') cons' xs') []
-        , Clause [WildP] (NormalB nothing) []
-        ]
-  where
-    go ap' x y = InfixE (Just x) ap' (Just y)
-
-insert :: (Monad m, ToPersistFields val, Num (Key val))
-       => GenericSql m -> EntityDef -> val -> m (Key val)
-insert gs t = liftM fromIntegral
+insert :: (Monad m, PersistEntity val)
+       => GenericSql m -> val -> m (Key val)
+insert gs v = liftM toPersistKey
             . gsInsert gs (tableName t) (map fst3 $ tableColumns t)
-            . toPersistValues
+            . map toPersistValue . toPersistFields
+            $ v
   where
     fst3 (x, _, _) = x
+    t = entityDef v
 
-replace :: (Integral (Key v), ToPersistFields v, Monad m)
-        => GenericSql m -> EntityDef -> Key v -> v -> m ()
-replace gs t k val = do
+replace :: (PersistEntity v, Monad m)
+        => GenericSql m -> Key v -> v -> m ()
+replace gs k val = do
+    let t = entityDef val
     let sql = "UPDATE " ++ tableName t ++ " SET " ++
               intercalate "," (map (go . fst3) $ tableColumns t) ++
               " WHERE id=?"
     gsExecute gs sql $
                     map toPersistValue (toPersistFields val)
-                    ++ [PersistInt64 (fromIntegral k)]
+                    ++ [PersistInt64 $ fromPersistKey k]
   where
     go = (++ "=?")
     fst3 (x, _, _) = x
 
-get :: (Integral (Key v), FromPersistValues v, Monad m)
-    => GenericSql m -> EntityDef -> Key v -> m (Maybe v)
-get gs t k = do
+dummyFromKey :: Key v -> v
+dummyFromKey _ = error "dummyFromKey"
+
+get :: (PersistEntity v, Monad m)
+    => GenericSql m -> Key v -> m (Maybe v)
+get gs k = do
+    let t = entityDef $ dummyFromKey k
     let sql = "SELECT * FROM " ++ tableName t ++ " WHERE id=?"
-    gsWithStmt gs sql [PersistInt64 $ fromIntegral k] $ \pop -> do
+    gsWithStmt gs sql [PersistInt64 $ fromPersistKey k] $ \pop -> do
         res <- pop
         case res of
             Nothing -> return Nothing
             Just (_:vals) ->
                 case fromPersistValues vals of
-                    Left e -> error $ "get " ++ show k ++ ": " ++ e
+                    Left e -> error $ "get " ++ showPersistKey k ++ ": " ++ e
                     Right v -> return $ Just v
             Just [] -> error "Database.Persist.GenericSql: Empty list in get"
 
-select :: ( FromPersistValues val, Num key
-          , PersistField (Filter val), ToFieldName (Filter val)
-          , ToFilter (Filter val), ToFieldName (Order val)
-          , ToOrder (Order val), Monad m
-          )
+select :: (PersistEntity val, Monad m)
        => GenericSql m
-       -> EntityDef
        -> [Filter val]
        -> [Order val]
-       -> m [(key, val)]
-select gs t filts ords = do
+       -> m [(Key val, val)]
+select gs filts ords = do
     let wher = if null filts
                 then ""
                 else " WHERE " ++
@@ -232,15 +123,17 @@
                 else " ORDER BY " ++
                      intercalate "," (map orderClause ords)
     let sql = "SELECT * FROM " ++ tableName t ++ wher ++ ord
-    gsWithStmt gs sql (map toPersistValue filts) $ flip go id
+    gsWithStmt gs sql (map persistFilterToValue filts) $ flip go id
   where
-    orderClause o = toFieldName' o ++ case toOrder o of
+    t = entityDef $ dummyFromFilts filts
+    orderClause o = getFieldName t (persistOrderToFieldName o)
+                    ++ case persistOrderToOrder o of
                                         Asc -> ""
                                         Desc -> " DESC"
     fromPersistValues' (PersistInt64 x:xs) = do
         case fromPersistValues xs of
             Left e -> Left e
-            Right xs' -> Right (fromIntegral x, xs')
+            Right xs' -> Right (toPersistKey x, xs')
     fromPersistValues' _ = Left "error in fromPersistValues'"
     go pop front = do
         res <- pop
@@ -251,14 +144,16 @@
                     Left _ -> go pop front -- FIXME error?
                     Right row -> go pop $ front . (:) row
 
-filterClause :: (ToFilter f, ToFieldName f) => f -> String
-filterClause f = if isNull f then nullClause else mainClause
+filterClause :: PersistEntity val => Filter val -> String
+filterClause f = if persistFilterIsNull f then nullClause else mainClause
   where
-    mainClause = toFieldName' f ++ showSqlFilter (toFilter f) ++ "?"
+    t = entityDef $ dummyFromFilts [f]
+    name = getFieldName t $ persistFilterToFieldName f
+    mainClause = name ++ showSqlFilter (persistFilterToFilter f) ++ "?"
     nullClause =
-        case toFilter f of
-          Eq -> '(' : mainClause ++ " OR " ++ toFieldName' f ++ " IS NULL)"
-          Ne -> '(' : mainClause ++ " OR " ++ toFieldName' f ++ " IS NOT NULL)"
+        case persistFilterToFilter f of
+          Eq -> '(' : mainClause ++ " OR " ++ name ++ " IS NULL)"
+          Ne -> '(' : mainClause ++ " OR " ++ name ++ " IS NOT NULL)"
           _ -> mainClause
     showSqlFilter Eq = "="
     showSqlFilter Ne = "<>"
@@ -267,90 +162,117 @@
     showSqlFilter Ge = ">="
     showSqlFilter Le = "<="
 
-delete :: (Integral (Key v), Monad m)
-       => GenericSql m -> EntityDef -> Key v -> m ()
-delete gs t k =
-    gsExecute gs sql [PersistInt64 $ fromIntegral k]
+delete :: (PersistEntity v, Monad m) => GenericSql m -> Key v -> m ()
+delete gs k =
+    gsExecute gs sql [PersistInt64 $ fromPersistKey k]
   where
+    t = entityDef $ dummyFromKey k
     sql = "DELETE FROM " ++ tableName t ++ " WHERE id=?"
 
-deleteWhere :: (PersistField (Filter v), ToFilter (Filter v),
-                ToFieldName (Filter v), Monad m)
-            => GenericSql m -> EntityDef -> [Filter v] -> m ()
-deleteWhere gs t filts = do
+dummyFromFilts :: [Filter v] -> v
+dummyFromFilts _ = error "dummyFromFilts"
+
+deleteWhere :: (PersistEntity v, Monad m)
+            => GenericSql m -> [Filter v] -> m ()
+deleteWhere gs filts = do
+    let t = entityDef $ dummyFromFilts filts
     let wher = if null filts
                 then ""
                 else " WHERE " ++
                      intercalate " AND " (map filterClause filts)
         sql = "DELETE FROM " ++ tableName t ++ wher
-    gsExecute gs sql $ map toPersistValue filts
+    gsExecute gs sql $ map persistFilterToValue filts
 
-deleteBy :: (ToPersistFields (Unique v), ToFieldNames (Unique v), Monad m)
-         => GenericSql m -> EntityDef -> Unique v -> m ()
-deleteBy gs t uniq = do
-    let sql = "DELETE FROM " ++ tableName t ++ " WHERE " ++
-              intercalate " AND " (map (++ "=?") $ toFieldNames' uniq)
-    gsExecute gs sql $ map toPersistValue $ toPersistFields uniq
+deleteBy :: (PersistEntity v, Monad m) => GenericSql m -> Unique v -> m ()
+deleteBy gs uniq =
+    gsExecute gs sql $ persistUniqueToValues uniq
+  where
+    t = entityDef $ dummyFromUnique uniq
+    go = map (getFieldName t) . persistUniqueToFieldNames
+    sql = "DELETE FROM " ++ tableName t ++ " WHERE " ++
+          intercalate " AND " (map (++ "=?") $ go uniq)
 
-update :: ( Integral (Key v), PersistField (Update v), ToFieldName (Update v)
-          , Monad m)
-       => GenericSql m -> EntityDef -> Key v -> [Update v] -> m ()
-update _ _ _ [] = return ()
-update gs t k upds = do
+update :: (PersistEntity v, Monad m)
+       => GenericSql m -> Key v -> [Update v] -> m ()
+update _ _ [] = return ()
+update gs k upds = do
     let sql = "UPDATE " ++ tableName t ++ " SET " ++
-              intercalate "," (map (++ "=?") $ map toFieldName' upds) ++
+              intercalate "," (map (++ "=?") $ map go upds) ++
               " WHERE id=?"
     gsExecute gs sql $
-        map toPersistValue upds ++ [PersistInt64 $ fromIntegral k]
+        map persistUpdateToValue upds ++ [PersistInt64 $ fromPersistKey k]
+  where
+    t = entityDef $ dummyFromKey k
+    go = getFieldName t . persistUpdateToFieldName
 
-updateWhere :: (PersistField (Filter v), PersistField (Update v),
-                ToFieldName (Update v), ToFilter (Filter v),
-                ToFieldName (Filter v), Monad m)
-            => GenericSql m
-            -> EntityDef -> [Filter v] -> [Update v] -> m ()
-updateWhere _ _ _ [] = return ()
-updateWhere gs t filts upds = do
+updateWhere :: (PersistEntity v, Monad m)
+            => GenericSql m -> [Filter v] -> [Update v] -> m ()
+updateWhere _ _ [] = return ()
+updateWhere gs filts upds = do
     let wher = if null filts
                 then ""
                 else " WHERE " ++
                      intercalate " AND " (map filterClause filts)
     let sql = "UPDATE " ++ tableName t ++ " SET " ++
-              intercalate "," (map (++ "=?") $ map toFieldName' upds) ++ wher
-    let dat = map toPersistValue upds ++ map toPersistValue filts
+              intercalate "," (map (++ "=?") $ map go upds) ++ wher
+    let dat = map persistUpdateToValue upds
+           ++ map persistFilterToValue filts
     gsWithStmt gs sql dat  $ const $ return ()
+  where
+    t = entityDef $ dummyFromFilts filts
+    go = getFieldName t . persistUpdateToFieldName
 
-getBy :: (Num (Key v), FromPersistValues v, Monad m,
-          ToPersistFields (Unique v), ToFieldNames (Unique v))
-      => GenericSql m
-      -> EntityDef -> Unique v -> m (Maybe (Key v, v))
-getBy gs t uniq = do
+getBy :: (PersistEntity v, Monad m)
+      => GenericSql m -> Unique v -> m (Maybe (Key v, v))
+getBy gs uniq = do
     let sql = "SELECT * FROM " ++ tableName t ++ " WHERE " ++ sqlClause
-    gsWithStmt gs sql (toPersistValues uniq) $ \pop -> do
+    gsWithStmt gs sql (persistUniqueToValues uniq) $ \pop -> do
         row <- pop
         case row of
             Nothing -> return Nothing
             Just (PersistInt64 k:vals) ->
                 case fromPersistValues vals of
                     Left _ -> return Nothing
-                    Right x -> return $ Just (fromIntegral k, x)
+                    Right x -> return $ Just (toPersistKey k, x)
             Just _ -> error "Database.Persist.GenericSql: Bad list in getBy"
   where
     sqlClause = intercalate " AND " $ map (++ "=?") $ toFieldNames' uniq
+    t = entityDef $ dummyFromUnique uniq
+    toFieldNames' = map (getFieldName t) . persistUniqueToFieldNames
 
+dummyFromUnique :: Unique v -> v
+dummyFromUnique _ = error "dummyFromUnique"
+
 tableName :: EntityDef -> String
-tableName t = "tbl" ++ entityName t
+tableName t =
+    case getSqlValue $ entityAttribs t of
+        Nothing -> "tbl" ++ entityName t
+        Just x -> x
 
-toField :: String -> String
-toField = (++) "fld"
+toField :: (String, String, [String]) -> String
+toField (n, _, as) =
+    case getSqlValue as of
+        Just x -> x
+        Nothing -> "fld" ++ n
 
-tableColumns :: EntityDef -> [(String, String, [String])]
-tableColumns = map (\(x, y, z) -> (toField x, y, z)) . entityColumns
+getFieldName :: EntityDef -> String -> String
+getFieldName t s = toField $ tableColumn t s
 
-tableUniques' :: EntityDef -> [(String, [String])]
-tableUniques' = map (second $ map toField) . entityUniques
+getSqlValue :: [String] -> Maybe String
+getSqlValue (('s':'q':'l':'=':x):_) = Just x
+getSqlValue (_:x) = getSqlValue x
+getSqlValue [] = Nothing
 
-toFieldName' :: ToFieldName x => x -> String
-toFieldName' = toField . toFieldName
+tableColumns :: EntityDef -> [(String, String, [String])]
+tableColumns = map (\a@(x, y, z) -> (toField a, y, z)) . entityColumns
 
-toFieldNames' :: ToFieldNames x => x -> [String]
-toFieldNames' = map toField . toFieldNames
+tableColumn :: EntityDef -> String -> (String, String, [String])
+tableColumn t s = go $ entityColumns t
+  where
+    go [] = error $ "Unknown table column: " ++ s
+    go ((x, y, z):rest)
+        | x == s = (x, y, z)
+        | otherwise = go rest
+
+tableUniques' :: EntityDef -> [(String, [String])]
+tableUniques' t = map (second $ map $ getFieldName t) $ entityUniques t
diff --git a/Database/Persist/Helper.hs b/Database/Persist/Helper.hs
deleted file mode 100644
--- a/Database/Persist/Helper.hs
+++ /dev/null
@@ -1,326 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE ExistentialQuantification #-}
--- | This module provides utilities for creating backends. Regular users do not
--- need to use this module.
-module Database.Persist.Helper
-    ( recName
-    , upperFirst
-      -- * High level design
-    , EntityDef (..)
-    , entityOrders
-    , entityFilters
-    , entityUpdates
-      -- * TH datatype helpers
-    , dataTypeDec
-    , persistMonadTypeDec
-    , keyTypeDec
-    , filterTypeDec
-    , updateTypeDec
-    , orderTypeDec
-    , uniqueTypeDec
-      -- * TH typeclass helpers
-    , mkToPersistFields
-    , mkToFieldNames
-    , mkToFieldName
-    , mkPersistField
-    , mkToFilter
-    , mkToOrder
-    , mkHalfDefined
-      -- * Type classes
-    , SomePersistField (..)
-    , ToPersistFields (..)
-    , FromPersistValues (..)
-    , toPersistValues
-    , ToFieldNames (..)
-    , ToOrder (..)
-    , PersistOrder (..)
-    , ToFieldName (..)
-    , PersistFilter (..)
-    , ToFilter (..)
-    , HalfDefined (..)
-      -- * Utils
-    , apE
-    , addIsNullable
-    ) where
-
-import Database.Persist
-import Language.Haskell.TH.Syntax
-import Data.Char (toLower, toUpper)
-import Data.Maybe (fromJust, mapMaybe)
-import Web.Routes.Quasi (SinglePiece)
-
-data EntityDef = EntityDef
-    { entityName    :: String
-    , entityColumns :: [(String, String, [String])] -- ^ name, type, attribs
-    , entityUniques :: [(String, [String])] -- ^ name, columns
-    , entityDerives :: [String]
-    }
-    deriving Show
-
-instance Lift EntityDef where
-    lift (EntityDef a b c d) = do
-        e <- [|EntityDef|]
-        a' <- lift a
-        b' <- lift b
-        c' <- lift c
-        d' <- lift d
-        return $ e `AppE` a' `AppE` b' `AppE` c' `AppE` d'
-
-recName :: String -> String -> String
-recName dt f = lowerFirst dt ++ upperFirst f
-
-lowerFirst :: String -> String
-lowerFirst (x:xs) = toLower x : xs
-lowerFirst [] = []
-
-upperFirst :: String -> String
-upperFirst (x:xs) = toUpper x : xs
-upperFirst [] = []
-
-dataTypeDec :: EntityDef -> Dec
-dataTypeDec t =
-    let name = mkName $ entityName t
-        cols = map (mkCol $ entityName t) $ entityColumns t
-     in DataD [] name [] [RecC name cols] $ map mkName $ entityDerives t
-  where
-    mkCol x (n, ty, as) =
-        (mkName $ recName x n, NotStrict, pairToType (ty, "null" `elem` as))
-
-persistMonadTypeDec :: Type -> EntityDef -> Dec
-persistMonadTypeDec monad t =
-    TySynInstD ''PersistMonad [ConT $ mkName $ entityName t] monad
-
-keyTypeDec :: String -> String -> EntityDef -> Dec
-keyTypeDec constr typ t =
-    NewtypeInstD [] ''Key [ConT $ mkName $ entityName t]
-                (NormalC (mkName constr) [(NotStrict, ConT $ mkName typ)])
-                [''Show, ''Read, ''Num, ''Integral, ''Enum, ''Eq, ''Ord,
-                 ''Real, ''PersistField, ''SinglePiece]
-
-filterTypeDec :: EntityDef -> Dec
-filterTypeDec t =
-    DataInstD [] ''Filter [ConT $ mkName $ entityName t]
-            (map (mkFilter $ entityName t) filts)
-            (if null filts then [] else [''Show, ''Read, ''Eq])
-  where
-    filts = entityFilters t
-
-entityFilters :: EntityDef -> [(String, String, Bool, PersistFilter)]
-entityFilters = mapMaybe go' . concatMap go . entityColumns
-  where
-    go (x, y, as) = map (\a -> (x, y, "null" `elem` as, a)) as
-    go' (x, y, z, a) =
-        case readMay a of
-            Nothing -> Nothing
-            Just a' -> Just (x, y, z, a')
-    readMay s =
-        case reads s of
-            (x, _):_ -> Just x
-            [] -> Nothing
-
-mkFilter :: String -> (String, String, Bool, PersistFilter) -> Con
-mkFilter x (s, ty, isNull', filt) =
-    NormalC (mkName $ x ++ upperFirst s ++ show filt)
-                       [(NotStrict, pairToType (ty, isNull'))]
-
-updateTypeDec :: EntityDef -> Dec
-updateTypeDec t =
-    DataInstD [] ''Update [ConT $ mkName $ entityName t]
-        (map (mkUpdate $ entityName t) tu)
-        (if null tu then [] else [''Show, ''Read, ''Eq])
-  where
-    tu = entityUpdates t
-
-entityUpdates :: EntityDef -> [(String, String, Bool)]
-entityUpdates = mapMaybe go . entityColumns
-  where
-    go (name, typ, attribs)
-        | "update" `elem` attribs =
-            Just (name, typ, "null" `elem` attribs)
-        | otherwise = Nothing
-
-mkUpdate :: String -> (String, String, Bool) -> Con
-mkUpdate x (s, ty, isBool) =
-    NormalC (mkName $ x ++ upperFirst s)
-                [(NotStrict, pairToType (ty, isBool))]
-
-orderTypeDec :: EntityDef -> Dec
-orderTypeDec t =
-    DataInstD [] ''Order [ConT $ mkName $ entityName t]
-            (map (mkOrder $ entityName t) ords)
-            (if null ords then [] else [''Show, ''Read, ''Eq])
-  where
-    ords = entityOrders t
-
-entityOrders :: EntityDef -> [(String, String)]
-entityOrders = concatMap go . entityColumns
-  where
-    go (x, _, ys) = mapMaybe (go' x) ys
-    go' x "Asc" = Just (x, "Asc")
-    go' x "Desc" = Just (x, "Desc")
-    go' _ _ = Nothing
-
-mkOrder :: String -> (String, String) -> Con
-mkOrder x (s, ad) = NormalC (mkName $ x ++ upperFirst s ++ ad) []
-
-uniqueTypeDec :: EntityDef -> Dec
-uniqueTypeDec t =
-    DataInstD [] ''Unique [ConT $ mkName $ entityName t]
-            (map (mkUnique t) $ entityUniques t)
-            (if null (entityUniques t) then [] else [''Show, ''Read, ''Eq])
-
-mkUnique :: EntityDef -> (String, [String]) -> Con
-mkUnique t (constr, fields) =
-    NormalC (mkName constr) types
-  where
-    types = map (go . fromJust . flip lookup3 (entityColumns t)) fields
-    go (_, True) = error "Error: cannot have nullables in unique"
-    go x = (NotStrict, pairToType x)
-    lookup3 _ [] = Nothing
-    lookup3 x ((x', y, z):rest)
-        | x == x' = Just (y, "null" `elem` z)
-        | otherwise = lookup3 x rest
-
-pairToType :: (String, Bool) -> Type
-pairToType (s, False) = ConT $ mkName s
-pairToType (s, True) = ConT (mkName "Maybe") `AppT` ConT (mkName s)
-
-data SomePersistField = forall a. PersistField a => SomePersistField a
-instance PersistField SomePersistField where
-    toPersistValue (SomePersistField a) = toPersistValue a
-    fromPersistValue x = fmap SomePersistField (fromPersistValue x :: Either String String)
-    sqlType (SomePersistField a) = sqlType a
-
-class ToPersistFields a where
-    toPersistFields :: a -> [SomePersistField]
-
-degen :: [Clause] -> [Clause]
-degen [] =
-    let err = VarE (mkName "error") `AppE` LitE (StringL
-                "Degenerate case, should never happen")
-     in [Clause [WildP] (NormalB err) []]
-degen x = x
-
-mkToPersistFields :: Type
-                 -> [(String, Int)]
-                 -> Q Dec
-mkToPersistFields typ pairs = do
-    clauses <- mapM go pairs
-    return $ InstanceD [] (ConT ''ToPersistFields `AppT` typ)
-                [FunD (mkName "toPersistFields") $ degen clauses]
-  where
-    go (constr, fields) = do
-        xs <- sequence $ replicate fields $ newName "x"
-        let pat = ConP (mkName constr) $ map VarP xs
-        sp <- [|SomePersistField|]
-        let bod = ListE $ map (AppE sp . VarE) xs
-        return $ Clause [pat] (NormalB bod) []
-
-class FromPersistValues a where
-    fromPersistValues :: [PersistValue] -> Either String a
-
-toPersistValues :: ToPersistFields a => a -> [PersistValue]
-toPersistValues = map toPersistValue . toPersistFields
-
-class ToFieldNames a where
-    toFieldNames :: a -> [String]
-
-mkToFieldNames :: Type -> [(String, [String])] -> Dec
-mkToFieldNames typ pairs =
-    InstanceD [] (ConT ''ToFieldNames `AppT` typ)
-        [FunD (mkName "toFieldNames") $ degen $ map go pairs]
-  where
-    go (constr, names) =
-        Clause [RecP (mkName constr) []]
-               (NormalB $ ListE $ map (LitE . StringL) names)
-               []
-
-class ToFieldName a where
-    toFieldName :: a -> String
-
-mkToFieldName :: Type -> [(String, String)] -> Dec
-mkToFieldName typ pairs =
-    InstanceD [] (ConT ''ToFieldName `AppT` typ)
-        [FunD (mkName "toFieldName") $ degen $ map go pairs]
-  where
-    go (constr, name) =
-        Clause [RecP (mkName constr) []] (NormalB $ LitE $ StringL name) []
-
-data PersistOrder = Asc | Desc
-class ToOrder a where
-    toOrder :: a -> PersistOrder
-
-mkToOrder :: Type -> [(String, String)] -> Dec
-mkToOrder typ pairs =
-    InstanceD [] (ConT ''ToOrder `AppT` typ)
-        [FunD (mkName "toOrder") $ degen $ map go pairs]
-  where
-    go (constr, val) =
-        Clause [RecP (mkName constr) []] (NormalB $ ConE $ mkName val) []
-
-data PersistFilter = Eq | Ne | Gt | Lt | Ge | Le
-    deriving (Read, Show)
-class ToFilter a where
-    toFilter :: a -> PersistFilter
-    isNull :: a -> Bool
-
-mkToFilter :: Type -> [(String, PersistFilter, Bool)] -> Dec
-mkToFilter typ pairs =
-    InstanceD [] (ConT ''ToFilter `AppT` typ)
-        [ FunD (mkName "toFilter") $ degen $ map go pairs
-        , FunD (mkName "isNull") $ degen $ concatMap go' pairs
-        ]
-  where
-    go (constr, pf, _) =
-        Clause [RecP (mkName constr) []] (NormalB $ ConE $ mkName $ show pf) []
-    go' (constr, _, False) =
-        [Clause [RecP (mkName constr) []]
-            (NormalB $ ConE $ mkName "False") []]
-    go' (constr, _, True) =
-        [ Clause [ConP (mkName constr) [ConP (mkName "Nothing") []]]
-            (NormalB $ ConE $ mkName "True") []
-        , Clause [ConP (mkName constr) [WildP]]
-            (NormalB $ ConE $ mkName "False") []
-        ]
-
-mkPersistField :: Type -> [String] -> Dec
-mkPersistField typ constrs =
-    InstanceD [] (ConT ''PersistField `AppT` typ)
-        $ fpv : map go
-            [ "toPersistValue"
-            , "sqlType"
-            , "isNullable"
-            ]
-  where
-    go func = FunD (mkName func) $ degen $ map (go' func) constrs
-    go' func constr =
-        let x = mkName "x"
-         in Clause [ConP (mkName constr) [VarP x]]
-                   (NormalB $ VarE (mkName func) `AppE` VarE x)
-                   []
-    fpv = FunD (mkName "fromPersistValue")
-            [Clause [WildP] (NormalB $ VarE (mkName "error")
-                `AppE` LitE (StringL "fromPersistValue")) []]
-
-class HalfDefined a where
-    halfDefined :: a
-
-mkHalfDefined :: Type -> String -> Int -> Dec
-mkHalfDefined typ constr count =
-    InstanceD [] (ConT ''HalfDefined `AppT` typ)
-        [FunD (mkName "halfDefined")
-            [Clause [] (NormalB
-            $ foldl AppE (ConE $ mkName constr)
-                    (replicate count $ VarE $ mkName "undefined")) []]]
-
-apE :: Either x (y -> z) -> Either x y -> Either x z
-apE (Left x) _ = Left x
-apE _ (Left x) = Left x
-apE (Right f) (Right y) = Right $ f y
-
-addIsNullable :: EntityDef -> (String, (String, String))
-              -> (String, (String, Bool))
-addIsNullable ed (col, (name, typ)) =
-    case filter (\(x, _, _) -> x == col) $ entityColumns ed of
-        [] -> error $ "Missing columns: " ++ col ++ ", " ++ show ed
-        (_, _, attribs):_ -> (name, (typ, "null" `elem` attribs))
diff --git a/Database/Persist/Pool.hs b/Database/Persist/Pool.hs
new file mode 100644
--- /dev/null
+++ b/Database/Persist/Pool.hs
@@ -0,0 +1,85 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE PackageImports #-}
+module Database.Persist.Pool
+    ( createPool
+    , withPool
+    , withPool'
+    , Pool
+    ) where
+
+import Control.Concurrent.MVar hiding (modifyMVar, modifyMVar_)
+import Control.Exception (throwIO)
+import Data.Typeable
+import "MonadCatchIO-transformers" Control.Monad.CatchIO
+import Control.Monad.IO.Class
+import Control.Monad
+
+data PoolData a = PoolData
+    { poolAvail :: [a]
+    , poolCreated :: Int
+    }
+
+data Pool a = Pool
+    { poolMax :: Int
+    , poolData :: MVar (PoolData a)
+    , poolMake :: IO a
+    }
+
+createPool :: MonadCatchIO m
+           => IO a -> (a -> IO ()) -> Int -> (Pool a -> m b) -> m b
+createPool mk fr mx f = do
+    pd <- liftIO $ newMVar $ PoolData [] 0
+    finally (f $ Pool mx pd mk) $ do
+        mress <- liftIO $ tryTakeMVar pd
+        case mress of
+            Nothing -> return ()
+            Just (PoolData ress _) -> liftIO $ mapM_ fr ress
+
+data PoolExhaustedException = PoolExhaustedException
+    deriving (Show, Typeable)
+instance Exception PoolExhaustedException
+
+withPool' :: MonadCatchIO m => Pool a -> (a -> m b) -> m b
+withPool' p f = do
+    x <- withPool p f
+    case x of
+        Nothing -> liftIO $ throwIO PoolExhaustedException
+        Just x' -> return x'
+
+withPool :: MonadCatchIO m => Pool a -> (a -> m b) -> m (Maybe b)
+withPool p f = block $ do
+    eres <- modifyMVar (poolData p) $ \pd -> do
+        case poolAvail pd of
+            (x:xs) -> return (pd { poolAvail = xs }, Right x)
+            [] -> return (pd, Left $ poolCreated pd)
+    case eres of
+        Left pc ->
+            if pc >= poolMax p
+                then return Nothing
+                else bracket
+                        (liftIO $ poolMake p)
+                        (insertResource 1)
+                        (liftM Just . unblock . f)
+        Right res -> finally
+                        (liftM Just $ unblock $ f res)
+                        (insertResource 0 res)
+  where
+    insertResource i x = modifyMVar_ (poolData p) $ \pd ->
+        return pd { poolAvail = x : poolAvail pd
+                  , poolCreated = i + poolCreated pd
+                  }
+
+modifyMVar :: MonadCatchIO m => MVar a -> (a -> m (a,b)) -> m b
+modifyMVar m io =
+  block $ do
+    a      <- liftIO $ takeMVar m
+    (a',b) <- unblock (io a) `onException` liftIO (putMVar m a)
+    liftIO $ putMVar m a'
+    return b
+
+modifyMVar_ :: MonadCatchIO m => MVar a -> (a -> m a) -> m ()
+modifyMVar_ m io =
+  block $ do
+    a  <- liftIO $ takeMVar m
+    a' <- unblock (io a) `onException` liftIO (putMVar m a)
+    liftIO $ putMVar m a'
diff --git a/Database/Persist/Quasi.hs b/Database/Persist/Quasi.hs
--- a/Database/Persist/Quasi.hs
+++ b/Database/Persist/Quasi.hs
@@ -1,24 +1,23 @@
-module Database.Persist.Quasi
-    ( persist
-    ) where
+module Database.Persist.Quasi (persist) where
 
 import Language.Haskell.TH.Quote
 import Language.Haskell.TH.Syntax
-import Database.Persist.Helper
+import Database.Persist.Base
 import Data.Char
 import Data.Maybe (mapMaybe)
+import Text.ParserCombinators.Parsec hiding (token)
 
 -- | Converts a quasi-quoted syntax into a list of entity definitions, to be
--- used as input to the backend-specific template haskell generation code.
+-- used as input to the template haskell generation code (mkPersist).
 persist :: QuasiQuoter
 persist = QuasiQuoter
-    { quoteExp = lift . parse
+    { quoteExp = lift . parse_
     , quotePat = error "Cannot quasi-quote a Persist pattern."
     }
 
-parse :: String -> [EntityDef]
-parse = map parse' . nest . map words' . filter (not . null)
-      . map killCarriage . lines
+parse_ :: String -> [EntityDef]
+parse_ = map parse' . nest . map words' . filter (not . null)
+       . map killCarriage . lines
 
 killCarriage :: String -> String
 killCarriage "" = ""
@@ -27,19 +26,37 @@
     | otherwise = s
 
 words' :: String -> (Bool, [String])
-words' (' ':x) = (True, words x)
-words' x = (False, words x)
+words' s = case parse words'' s s of
+            Left e -> error $ show e
+            Right x -> x
 
-nest :: [(Bool, [String])] -> [(String, [[String]])]
-nest ((False, [name]):rest) =
+words'' :: Parser (Bool, [String])
+words'' = do
+    s <- fmap (not . null) $ many space
+    t <- many token
+    eof
+    return (s, t)
+  where
+    token = do
+        t <- (char '"' >> quoted) <|> unquoted
+        spaces
+        return t
+    quoted = do
+        s <- many1 $ noneOf "\""
+        _ <- char '"'
+        return s
+    unquoted = many1 $ noneOf " \t"
+
+nest :: [(Bool, [String])] -> [(String, [String], [[String]])]
+nest ((False, name:entattribs):rest) =
     let (x, y) = break (not . fst) rest
-     in (name, map snd x) : nest y
-nest ((False, _):_) = error "First line in block must have exactly one word"
+     in (name, entattribs, map snd x) : nest y
 nest ((True, _):_) = error "Blocks must begin with non-indented lines"
 nest [] = []
 
-parse' :: (String, [[String]]) -> EntityDef
-parse' (name, attribs) = EntityDef name cols uniqs derives
+parse' :: (String, [String], [[String]]) -> EntityDef
+parse' (name, entattribs, attribs) =
+    EntityDef name entattribs cols uniqs derives
   where
     cols = concatMap takeCols attribs
     uniqs = concatMap takeUniqs attribs
diff --git a/Database/Persist/TH.hs b/Database/Persist/TH.hs
new file mode 100644
--- /dev/null
+++ b/Database/Persist/TH.hs
@@ -0,0 +1,306 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ExistentialQuantification #-}
+-- | This module provides utilities for creating backends. Regular users do not
+-- need to use this module.
+module Database.Persist.TH (mkPersist) where
+
+import Database.Persist.Base
+import Language.Haskell.TH.Syntax
+import Data.Char (toLower, toUpper)
+import Data.Maybe (mapMaybe, catMaybes)
+import Web.Routes.Quasi (SinglePiece)
+import Data.Int (Int64)
+
+-- | Create data types and appropriate 'PersistEntity' instances for the given
+-- 'EntityDef's. Works well with the persist quasi-quoter.
+mkPersist :: [EntityDef] -> Q [Dec]
+mkPersist = fmap concat . mapM mkEntity
+
+recName :: String -> String -> String
+recName dt f = lowerFirst dt ++ upperFirst f
+
+lowerFirst :: String -> String
+lowerFirst (x:xs) = toLower x : xs
+lowerFirst [] = []
+
+upperFirst :: String -> String
+upperFirst (x:xs) = toUpper x : xs
+upperFirst [] = []
+
+dataTypeDec :: EntityDef -> Dec
+dataTypeDec t =
+    let name = mkName $ entityName t
+        cols = map (mkCol $ entityName t) $ entityColumns t
+     in DataD [] name [] [RecC name cols] $ map mkName $ entityDerives t
+  where
+    mkCol x (n, ty, as) =
+        (mkName $ recName x n, NotStrict, pairToType (ty, "null" `elem` as))
+
+keyTypeDec :: String -> Name -> EntityDef -> Dec
+keyTypeDec constr typ t =
+    NewtypeInstD [] ''Key [ConT $ mkName $ entityName t]
+                (NormalC (mkName constr) [(NotStrict, ConT typ)])
+                [''Show, ''Read, ''Num, ''Integral, ''Enum, ''Eq, ''Ord,
+                 ''Real, ''PersistField, ''SinglePiece]
+
+filterTypeDec :: EntityDef -> Dec
+filterTypeDec t =
+    DataInstD [] ''Filter [ConT $ mkName $ entityName t]
+            (map (mkFilter $ entityName t) filts)
+            (if null filts then [] else [''Show, ''Read, ''Eq])
+  where
+    filts = entityFilters t
+
+entityFilters :: EntityDef -> [(String, String, Bool, PersistFilter)]
+entityFilters = mapMaybe go' . concatMap go . entityColumns
+  where
+    go (x, y, as) = map (\a -> (x, y, "null" `elem` as, a)) as
+    go' (x, y, z, a) =
+        case readMay a of
+            Nothing -> Nothing
+            Just a' -> Just (x, y, z, a')
+    readMay s =
+        case reads s of
+            (x, _):_ -> Just x
+            [] -> Nothing
+
+mkFilter :: String -> (String, String, Bool, PersistFilter) -> Con
+mkFilter x (s, ty, isNull', filt) =
+    NormalC (mkName $ x ++ upperFirst s ++ show filt)
+                       [(NotStrict, pairToType (ty, isNull'))]
+
+updateTypeDec :: EntityDef -> Dec
+updateTypeDec t =
+    DataInstD [] ''Update [ConT $ mkName $ entityName t]
+        (map (mkUpdate $ entityName t) tu)
+        (if null tu then [] else [''Show, ''Read, ''Eq])
+  where
+    tu = entityUpdates t
+
+entityUpdates :: EntityDef -> [(String, String, Bool)]
+entityUpdates = mapMaybe go . entityColumns
+  where
+    go (name, typ, attribs)
+        | "update" `elem` attribs =
+            Just (name, typ, "null" `elem` attribs)
+        | otherwise = Nothing
+
+mkUpdate :: String -> (String, String, Bool) -> Con
+mkUpdate x (s, ty, isBool) =
+    NormalC (mkName $ x ++ upperFirst s)
+                [(NotStrict, pairToType (ty, isBool))]
+
+orderTypeDec :: EntityDef -> Q Dec
+orderTypeDec t = do
+    ords <- entityOrders t
+    return $ DataInstD [] ''Order [ConT $ mkName $ entityName t]
+            (map (mkOrder $ entityName t) ords)
+            (if null ords then [] else [''Show, ''Read, ''Eq])
+
+entityOrders :: EntityDef -> Q [(String, String, Exp)]
+entityOrders = fmap concat . mapM go . entityColumns
+  where
+    go (x, _, ys) = fmap catMaybes $ mapM (go' x) ys
+    go' x s =
+        case reads s of
+            (y, _):_ -> do
+                z <- lift (y :: PersistOrder)
+                return $ Just (x, s, z)
+            _ -> return Nothing
+
+mkOrder :: String -> (String, String, Exp) -> Con
+mkOrder x (s, ad, _) = NormalC (mkName $ x ++ upperFirst s ++ ad) []
+
+uniqueTypeDec :: EntityDef -> Dec
+uniqueTypeDec t =
+    DataInstD [] ''Unique [ConT $ mkName $ entityName t]
+            (map (mkUnique t) $ entityUniques t)
+            (if null (entityUniques t) then [] else [''Show, ''Read, ''Eq])
+
+mkUnique :: EntityDef -> (String, [String]) -> Con
+mkUnique t (constr, fields) =
+    NormalC (mkName constr) types
+  where
+    types = map (go . flip lookup3 (entityColumns t)) fields
+    go (_, True) = error "Error: cannot have nullables in unique"
+    go x = (NotStrict, pairToType x)
+    lookup3 s [] =
+        error $ "Column not found: " ++ s ++ " in unique " ++ constr
+    lookup3 x ((x', y, z):rest)
+        | x == x' = (y, "null" `elem` z)
+        | otherwise = lookup3 x rest
+
+pairToType :: (String, Bool) -> Type
+pairToType (s, False) = ConT $ mkName s
+pairToType (s, True) = ConT (mkName "Maybe") `AppT` ConT (mkName s)
+
+degen :: [Clause] -> [Clause]
+degen [] =
+    let err = VarE (mkName "error") `AppE` LitE (StringL
+                "Degenerate case, should never happen")
+     in [Clause [WildP] (NormalB err) []]
+degen x = x
+
+mkToPersistFields :: [(String, Int)] -> Q Dec
+mkToPersistFields pairs = do
+    clauses <- mapM go pairs
+    return $ FunD (mkName "toPersistFields") $ degen clauses
+  where
+    go (constr, fields) = do
+        xs <- sequence $ replicate fields $ newName "x"
+        let pat = ConP (mkName constr) $ map VarP xs
+        sp <- [|SomePersistField|]
+        let bod = ListE $ map (AppE sp . VarE) xs
+        return $ Clause [pat] (NormalB bod) []
+
+mkToFieldNames :: [(String, [String])] -> Dec
+mkToFieldNames pairs =
+        FunD (mkName "persistUniqueToFieldNames") $ degen $ map go pairs
+  where
+    go (constr, names) =
+        Clause [RecP (mkName constr) []]
+               (NormalB $ ListE $ map (LitE . StringL) names)
+               []
+
+mkUniqueToValues :: [(String, [String])] -> Q Dec
+mkUniqueToValues pairs = do
+    pairs' <- mapM go pairs
+    return $ FunD (mkName "persistUniqueToValues") $ degen pairs'
+  where
+    go (constr, names) = do
+        xs <- mapM (const $ newName "x") names
+        let pat = ConP (mkName constr) $ map VarP xs
+        tpv <- [|toPersistValue|]
+        let bod = ListE $ map (AppE tpv . VarE) xs
+        return $ Clause [pat] (NormalB bod) []
+
+mkToFieldName :: String -> [(String, String)] -> Dec
+mkToFieldName func pairs =
+        FunD (mkName func) $ degen $ map go pairs
+  where
+    go (constr, name) =
+        Clause [RecP (mkName constr) []] (NormalB $ LitE $ StringL name) []
+
+mkToOrder :: [(String, Exp)] -> Dec
+mkToOrder pairs =
+        FunD (mkName "persistOrderToOrder") $ degen $ map go pairs
+  where
+    go (constr, val) =
+        Clause [RecP (mkName constr) []] (NormalB val) []
+
+mkToFilter :: [(String, PersistFilter, Bool)] -> Q [Dec]
+mkToFilter pairs = do
+    c1 <- mapM go pairs
+    let c2 = concatMap go' pairs
+    return
+        [ FunD (mkName "persistFilterToFilter") $ degen c1
+        , FunD (mkName "persistFilterIsNull") $ degen c2
+        ]
+  where
+    go (constr, pf, _) = do
+        pf' <- lift pf
+        return $ Clause [RecP (mkName constr) []] (NormalB pf') []
+    go' (constr, _, False) =
+        [Clause [RecP (mkName constr) []]
+            (NormalB $ ConE $ mkName "False") []]
+    go' (constr, _, True) =
+        [ Clause [ConP (mkName constr) [ConP (mkName "Nothing") []]]
+            (NormalB $ ConE $ mkName "True") []
+        , Clause [ConP (mkName constr) [WildP]]
+            (NormalB $ ConE $ mkName "False") []
+        ]
+
+mkToValue :: String -> [String] -> Dec
+mkToValue func = FunD (mkName func) . degen . map go
+  where
+    go constr =
+        let x = mkName "x"
+         in Clause [ConP (mkName constr) [VarP x]]
+                   (NormalB $ VarE (mkName "toPersistValue") `AppE` VarE x)
+                   []
+
+mkHalfDefined :: String -> Int -> Dec
+mkHalfDefined constr count =
+        FunD (mkName "halfDefined")
+            [Clause [] (NormalB
+            $ foldl AppE (ConE $ mkName constr)
+                    (replicate count $ VarE $ mkName "undefined")) []]
+
+apE :: Either x (y -> z) -> Either x y -> Either x z
+apE (Left x) _ = Left x
+apE _ (Left x) = Left x
+apE (Right f) (Right y) = Right $ f y
+
+mkFromPersistValues :: EntityDef -> Q [Clause]
+mkFromPersistValues t = do
+    nothing <- [|Left "Invalid fromPersistValues input"|]
+    let cons = ConE $ mkName $ entityName t
+    xs <- mapM (const $ newName "x") $ entityColumns t
+    fs <- [|fromPersistValue|]
+    let xs' = map (AppE fs . VarE) xs
+    let pat = ListP $ map VarP xs
+    ap' <- [|apE|]
+    just <- [|Right|]
+    let cons' = just `AppE` cons
+    return
+        [ Clause [pat] (NormalB $ foldl (go ap') cons' xs') []
+        , Clause [WildP] (NormalB nothing) []
+        ]
+  where
+    go ap' x y = InfixE (Just x) ap' (Just y)
+
+mkEntity :: EntityDef -> Q [Dec]
+mkEntity t = do
+    t' <- lift t
+    let name = entityName t
+    let clazz = ConT ''PersistEntity `AppT` ConT (mkName $ entityName t)
+    tpf <- mkToPersistFields [(name, length $ entityColumns t)]
+    fpv <- mkFromPersistValues t
+    fromIntegral' <- [|fromIntegral|]
+    utv <- mkUniqueToValues $ entityUniques t
+    show' <- [|show|]
+    entityOrders' <- entityOrders t
+    otd <- orderTypeDec t
+    tf <- mkToFilter
+                (map (\(x, _, z, y) ->
+                    (name ++ upperFirst x ++ show y, y, z))
+                $ entityFilters t)
+    return
+      [ dataTypeDec t
+      , TySynD (mkName $ entityName t ++ "Id") [] $
+            ConT ''Key `AppT` ConT (mkName $ entityName t)
+      , InstanceD [] clazz $
+        [ keyTypeDec (entityName t ++ "Id") ''Int64 t
+        , filterTypeDec t
+        , updateTypeDec t
+        , otd
+        , uniqueTypeDec t
+        , FunD (mkName "entityDef") [Clause [WildP] (NormalB t') []]
+        , tpf
+        , FunD (mkName "fromPersistValues") fpv
+        , mkHalfDefined name $ length $ entityColumns t
+        , FunD (mkName "toPersistKey") [Clause [] (NormalB fromIntegral') []]
+        , FunD (mkName "fromPersistKey") [Clause [] (NormalB fromIntegral') []]
+        , FunD (mkName "showPersistKey") [Clause [] (NormalB show') []]
+        , mkToFieldName "persistOrderToFieldName"
+                $ map (\(x, y, _) -> (name ++ upperFirst x ++ y, x))
+                entityOrders'
+        , mkToOrder
+                $ map (\(x, y, z) -> (name ++ upperFirst x ++ y, z))
+                entityOrders'
+        , mkToFieldName "persistUpdateToFieldName"
+                $ map (\(s, _, _) -> (name ++ upperFirst s, s))
+                $ entityUpdates t
+        , mkToValue "persistUpdateToValue"
+                $ map (\(s, _, _) -> name ++ upperFirst s)
+                $ entityUpdates t
+        , mkToFieldName "persistFilterToFieldName"
+                $ map (\(x, _, _, y) -> (name ++ upperFirst x ++ show y, x))
+                $ entityFilters t
+        , mkToValue "persistFilterToValue"
+                $ map (\(x, _, _, y) -> name ++ upperFirst x ++ show y)
+                $ entityFilters t
+        , mkToFieldNames $ entityUniques t
+        , utv
+        ] ++ tf
+        ]
diff --git a/persistent.cabal b/persistent.cabal
--- a/persistent.cabal
+++ b/persistent.cabal
@@ -1,5 +1,5 @@
 name:            persistent
-version:         0.0.0.1
+version:         0.1.0
 license:         BSD3
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -17,15 +17,19 @@
                      template-haskell >= 2.4 && < 2.5,
                      bytestring >= 0.9.1 && < 0.10,
                      MonadCatchIO-transformers >= 0.2.2 && < 0.3,
-                     time >= 1.1.4 && < 1.2,
+                     transformers >= 0.2.1 && < 0.3,
+                     time >= 1.1.4 && < 1.3,
                      utf8-string >= 0.3.4 && < 0.4,
                      text >= 0.7.1 && < 0.8,
-                     hamlet >= 0.3.1 && < 0.4,
-                     web-routes-quasi >= 0.4.0 && < 0.5
+                     blaze-html >= 0.1 && < 0.2,
+                     web-routes-quasi >= 0.5.0 && < 0.6,
+                     parsec >= 2.1 && < 4
     exposed-modules: Database.Persist
-                     Database.Persist.Helper
+                     Database.Persist.Base
+                     Database.Persist.TH
                      Database.Persist.Quasi
                      Database.Persist.GenericSql
+                     Database.Persist.Pool
     ghc-options:     -Wall
 
 source-repository head