diff --git a/Database/Groundhog.hs b/Database/Groundhog.hs
--- a/Database/Groundhog.hs
+++ b/Database/Groundhog.hs
@@ -1,56 +1,65 @@
 -- | This module exports the most commonly used functions and datatypes.
 --
--- An example which shows the main features:
+-- The example below shows the most of the main features. See more examples in the examples directory.
 --
 -- @
--- {-\# LANGUAGE GADTs, TypeFamilies, TemplateHaskell \#-}
--- import Control.Monad.IO.Class(liftIO)
--- import Database.Groundhog.Sqlite
--- import Database.Groundhog.TH
--- 
--- data Customer a = Customer {customerName :: String, details :: a} deriving Show
--- data Item = ProductItem {productName :: String, quantity :: Int, customer :: Customer String}
---           | ServiceItem {serviceName :: String, deliveryAddress :: String, servicePrice :: Int}
---      deriving Show
--- 
--- 'deriveEntity' ''Customer $ Just $ do
---   setConstructor 'Customer $ do
---     setConstraints [(\"NameConstraint\", [\"customerName\"])]
--- deriveEntity ''Item Nothing
--- 
--- main = withSqliteConn \":memory:\" $ runSqliteConn $ do
---   -- Customer is also migrated because Item contains it
---   'runMigration' 'silentMigrationLogger' $ 'migrate' (undefined :: Item)
---   let john = Customer \"John Doe\" \"Phone: 01234567\"
---   johnKey <- 'insert' john
---   -- John is inserted only once because of the name constraint
---   insert $ ProductItem \"Apples\" 5 john
---   insert $ ProductItem \"Melon\" 2 john
---   insert $ ServiceItem \"Taxi\" \"Elm Street\" 50
---   insert $ ProductItem \"Melon\" 6 (Customer \"Jack Smith\" \"Don't let him pay by check\")
---   -- bonus melon for all large melon orders
---   'update' [QuantityField '=.' toArith QuantityField + 1] (ProductNameField '==.' \"Melon\" '&&.' QuantityField '>.' (5 :: Int))
---   productsForJohn <- 'select' (CustomerField ==. johnKey) [] 0 0
---   liftIO $ putStrLn $ \"Products for John: \" ++ show productsForJohn
---   -- let's check bonus
---   melon <- select (ProductNameField ==. \"Melon\") ['Desc' QuantityField] 0 0
---   liftIO $ putStrLn $ \"Melon orders: \" ++ show melon
+--{-\# LANGUAGE GADTs, TypeFamilies, TemplateHaskell, QuasiQuotes, FlexibleInstances \#-}
+--import Control.Monad.IO.Class (liftIO)
+--import Database.Groundhog.TH
+--import Database.Groundhog.Sqlite
+--
+--data Customer a = Customer {customerName :: String, remark :: a} deriving Show
+--data Product = Product {productName :: String, quantity :: Int, customer :: Customer String} deriving Show
+--
+--'mkPersist' ('defaultCodegenConfig' {migrationFunction = Just \"migrateAll\"}) [groundhog|
+-- - entity: Customer
+--   constructors:
+--     - name: Customer
+--       uniques:
+--         - name: NameConstraint
+--           fields: [customerName]
+-- - entity: Product
+-- |]
+--
+--main = withSqliteConn \":memory:\" $ runSqliteConn $ do
+--  -- Customer is also migrated because Product references it.
+--  -- It is possible to migrate schema for given type, e.g. migrate (undefined :: Customer String), or run migrateAll
+--  'runMigration' 'defaultMigrationLogger' migrateAll
+--  let john = Customer \"John Doe\" \"Phone: 01234567\"
+--  johnKey <- 'insert' john
+--  -- John is inserted only once because of the name constraint
+--  insert $ Product \"Apples\" 5 john
+--  insert $ Product \"Melon\" 2 john
+--  -- Groundhog prevents SQL injections. Quotes and other special symbols are safe.
+--  insert $ Product \"Melon\" 6 (Customer \"Jack Smith\" \"Don't let him pay by check\")
+--  -- Bonus melon for all large melon orders. The values used in expressions should have known type, so literal 5 is annotated.
+--  'update' [QuantityField '=.' toArith QuantityField + 1] (ProductNameField '==.' \"Melon\" '&&.' QuantityField '>.' (5 :: Int))
+--  productsForJohn <- 'select' $ CustomerField ==. johnKey
+--  liftIO $ putStrLn $ \"Products for John: \" ++ show productsForJohn
+--  -- Check bonus
+--  melon <- select $ (ProductNameField ==. \"Melon\") \`orderBy\` ['Desc' QuantityField]
+--  liftIO $ putStrLn $ \"Melon orders: \" ++ show melon
 -- @
-module Database.Groundhog
-  ( module Database.Groundhog.Core
-  , module Database.Groundhog.Generic
-  ) where
+module Database.Groundhog (module G) where
 
-import Database.Groundhog.Core
+import Database.Groundhog.Core as G
   ( PersistBackend(..)
   , DbPersist(..)
   , Key(..)
+  , Unique
+  , BackendSpecific
+  , extractUnique
   , Cond(..)
   , Order(..)
-  , (=.), (&&.), (||.), (==.), (/=.), (<.), (<=.), (>.), (>=.)
-  , wrapPrim
+  , Selector(..)
+  , AutoKeyField(..)
+  , (~>)
+  , limitTo
+  , offsetBy
+  , orderBy
   , toArith)
-import Database.Groundhog.Generic
+import Database.Groundhog.Expression as G
+import Database.Groundhog.Generic as G
   ( createMigration
   , executeMigration
   , executeMigrationUnsafe
@@ -60,4 +69,4 @@
   , silentMigrationLogger
   , defaultMigrationLogger)
 
-import Database.Groundhog.TH
+import Database.Groundhog.Instances as G
diff --git a/Database/Groundhog/Core.hs b/Database/Groundhog/Core.hs
--- a/Database/Groundhog/Core.hs
+++ b/Database/Groundhog/Core.hs
@@ -1,245 +1,273 @@
-{-# LANGUAGE GADTs, TypeFamilies, ExistentialQuantification, StandaloneDeriving, TypeSynonymInstances, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, OverlappingInstances, ScopedTypeVariables, GeneralizedNewtypeDeriving, UndecidableInstances, EmptyDataDecls #-}
-
+{-# LANGUAGE GADTs, TypeFamilies, ExistentialQuantification, MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, EmptyDataDecls #-}
 -- | This module defines the functions and datatypes used throughout the framework.
--- Most of them are for internal use
+-- Most of them are for the internal use
 module Database.Groundhog.Core
   ( 
   -- * Main types
     PersistEntity(..)
   , PersistValue(..)
   , PersistField(..)
-  , Key(..)
+  , SinglePersistField(..)
+  , PurePersistField(..)
+  , PrimitivePersistField(..)
+  , Embedded(..)
+  , Projection(..)
+  , RestrictionHolder
+  , Unique
+  , KeyForBackend(..)
+  , BackendSpecific
+  , ConstructorMarker
+  , UniqueMarker
+  , Proxy
+  , HFalse
+  , HTrue
+  , ZT (..) -- ZonedTime wrapper
+  , delim
   -- * Constructing expressions
-  -- $exprDoc
   , Cond(..)
+  , ExprRelation(..)
   , Update(..)
-  , (=.), (&&.), (||.), (==.), (/=.), (<.), (<=.), (>.), (>=.)
-  , wrapPrim
+  , (~>)
   , toArith
-  , Expression(..)
-  , Primitive(..)
-  , HasOrder
-  , Numeric
+  , FieldLike(..)
+  , SubField(..)
+  , AutoKeyField(..)
+  , FieldChain
   , NeverNull
+  , Numeric
   , Arith(..)
   , Expr(..)
   , Order(..)
+  , HasSelectOptions(..)
+  , SelectOptions(..)
+  , limitTo
+  , offsetBy
+  , orderBy
   -- * Type description
   , DbType(..)
-  , NamedType
-  , namedType
-  , getName
-  , getType
   , EntityDef(..)
+  , EmbeddedDef(..)
   , ConstructorDef(..)
   , Constructor(..)
-  , Constraint
+  , IsUniqueKey(..)
+  , UniqueDef(..)
   -- * Migration
   , SingleMigration
   , NamedMigrations
   , Migration
   -- * Database
   , PersistBackend(..)
+  , DbDescriptor(..)
   , RowPopper
   , DbPersist(..)
   , runDbPersist
   ) where
 
-import Control.Applicative(Applicative)
-import Control.Monad(liftM, liftM2, liftM3, liftM4, liftM5)
-import Control.Monad.Trans.Class(MonadTrans(..))
-import Control.Monad.IO.Class(MonadIO(..))
-import Control.Monad.IO.Control (MonadControlIO)
-import Control.Monad.Trans.Reader(ReaderT, runReaderT)
-import Control.Monad.Trans.State(StateT)
-import Data.Bits(bitSize)
-import Data.ByteString.Char8 (ByteString, unpack)
-import Data.Enumerator(Enumerator)
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as T
-import qualified Data.Text.Encoding.Error as T
-import Data.Int (Int8, Int16, Int32, Int64)
-import Data.Word (Word8, Word16, Word32, Word64)
-import Data.Map(Map)
-import Data.Time(Day, TimeOfDay, UTCTime)
-import Unsafe.Coerce(unsafeCoerce)
+import Control.Applicative (Applicative)
+import Control.Monad.Base (MonadBase (liftBase))
+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)
+import Control.Monad.Trans.State (StateT)
+import Control.Monad (liftM)
+import Data.ByteString.Char8 (ByteString)
+import Data.Int (Int64)
+import Data.Map (Map)
+import Data.Time (Day, TimeOfDay, UTCTime)
+import Data.Time.LocalTime (ZonedTime, zonedTimeToUTC, zonedTimeToLocalTime, zonedTimeZone)
 
 -- | Only instances of this class can be persisted in a database
-class PersistField v => PersistEntity v where
+class (PersistField v, PurePersistField (AutoKey v)) => PersistEntity v where
   -- | This type is used for typesafe manipulation of separate fields of datatype v.
-  -- Each constructor in 'Fields' corresponds to its field in a datatype v.
+  -- Each constructor in 'Field' corresponds to its field in a datatype v.
   -- It is parametrised by constructor phantom type and field value type.
-  data Fields v :: * -> * -> *
+  data Field v :: ((* -> *) -> *) -> * -> *
+  -- | A unique identifier of a value stored in a database. This may be a primary key, a constraint or unique indices. The second parameter is the key description.
+  data Key v :: * -> *
+  -- | This type is the default autoincremented key for the entity. If entity does not have such key, AutoKey v = ().
+  type AutoKey v
+  -- | This type is the default key for the entity.
+  type DefaultKey v
   -- | Returns a complete description of the type
   entityDef :: v -> EntityDef
   -- | Marshalls value to a list of 'PersistValue' ready for insert to a database
-  toPersistValues   :: PersistBackend m => v -> m [PersistValue]
+  toEntityPersistValues :: PersistBackend m => v -> m ([PersistValue] -> [PersistValue])
   -- | Constructs the value from the list of 'PersistValue'
-  fromPersistValues :: PersistBackend m => [PersistValue] -> m v
-  -- | Returns constructor number and a list of constraint names and corresponding field names with their values
-  getConstraints    :: v -> (Int, [(String, [(String, PersistValue)])])
-  -- Show (Fields v c a) constraint would be nicer, but free c & a params don't allow this
-  showField :: Fields v c a -> String
-  eqField :: Fields v c a -> Fields v c a -> Bool
-
-instance PersistEntity v => Show (Fields v c a) where show = showField
-instance PersistEntity v => Eq (Fields v c a) where (==) = eqField
-
--- | A unique identifier of a value stored in a database
-data PersistEntity v => Key v = Key Int64 deriving Show
-
-data Any
-
-type family MoreSpecific a b
-type instance MoreSpecific Any a = a
-type instance MoreSpecific a Any = a
-type instance MoreSpecific a a = a
-type instance MoreSpecific Any Any = Any
-
-class TypesCastV x y z | x y -> z
--- instance TypesCastV x x x would not work. For example, it does not match TypesCastV (Type a1) (Type a2) z
-instance (x ~ y, MoreSpecific x y ~ z) => TypesCastV x y z
-instance TypesCastV Any x x
-instance TypesCastV x Any x
-instance TypesCastV Any Any Any
+  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])])
+  -- | 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 :: Field v c a -> FieldChain
 
-class TypesEqualC x y
-instance TypesEqualC x x
-instance TypesEqualC Any x
-instance TypesEqualC x Any
-instance TypesEqualC Any Any
+-- | A holder for Unique constraints
+data Unique (u :: (* -> *) -> *)
+-- | Key marked with this type can have value for any backend
+data BackendSpecific
+-- | A phantom datatype to make instance head diffirent @c (ConstructorMarker, v)@
+data ConstructorMarker v a
+-- | A phantom datatype to make instance head diffirent @u (UniqueMarker, v)@
+data UniqueMarker v a
 
-class TypesCastC x y z | x y -> z
-instance (TypesEqualC x y, MoreSpecific x y ~ z) => TypesCastC x y z
+-- | A holder for DB type in backend-specific keys
+data KeyForBackend db v = (DbDescriptor db, PersistEntity v) => KeyForBackend (AutoKeyType db)
 
-class (Expression a, Expression b) => TypeCast a b v c | a b -> v, a b -> c
-instance (Expression a, Expression b, TypesCastV (FuncV a) (FuncV b) v, TypesCastC (FuncC a) (FuncC b) c) => TypeCast a b v c
---instance (Expression a, Expression b, FuncV a ~ Any, FuncC a ~ Any, FuncV b ~ v, FuncC b ~ c) => TypeCast a b v c
---instance (FuncV a ~ v, FuncC a ~ c) => TypeCast a Any v c
---instance TypeCast Any Any Any Any
+data Proxy a
 
--- $exprDoc
--- The expressions are used in conditions and right part of Update statement.
--- Despite the wordy types of the comparison functions, they are simple to use.
--- Type of the compared polymorphic values like numbers or Nothing must be supplied manually. Example:
---
--- @
--- StringField ==. \"abc\" &&. NumberField >. (0 :: Int) ||. MaybeField ==. (Nothing :: Maybe String) ||. MaybeField ==. Just \"def\"
--- @
---
+data HFalse
+data HTrue
 
 -- | Represents condition for a query.
-data Cond v c =
+data Cond v (c :: (* -> *) -> *) =
     And (Cond v c) (Cond v c)
   | Or  (Cond v c) (Cond v c)
   | Not (Cond v c)
-  | forall a.(HasOrder a, PersistField a) => Lesser  (Expr v c a) (Expr v c a)
-  | forall a.(HasOrder a, PersistField a) => Greater (Expr v c a) (Expr v c a)
-  | forall a.(PersistField a) => Equals    (Expr v c a) (Expr v c a)
-  | forall a.(PersistField a) => NotEquals (Expr v c a) (Expr v c a)
-  -- | Lookup will be performed only in table for the specified constructor c. To fetch value by key without constructor limitation use 'get'
-  | KeyIs (Key v)
+  | forall a b . Compare ExprRelation (Expr v c a) (Expr v c b)
 
-data Update v c = forall a.Update (Fields v c a) (Expr v c a)
---deriving instance (Show (Fields c a)) => Show (Update c)
+data ExprRelation = Eq | Ne | Gt | Lt | Ge | Le deriving Show
 
+data Update v c = forall f a b . (FieldLike f (RestrictionHolder v c) a) => Update f (Expr v c b)
+
 -- | Defines sort order of a result-set
-data Order v c = forall a.HasOrder a => Asc  (Fields v c a)
-               | forall a.HasOrder a => Desc (Fields v c a)
+data Order v c = forall a f . (FieldLike f (RestrictionHolder v c) a) => Asc  f
+               | forall a f . (FieldLike f (RestrictionHolder v c) a) => Desc f
 
--- TODO: UGLY: we use unsafeCoerce to cast phantom types Any and Any to more specific type if possible. The safety is assured by TypeEqual and TypeEqualC classes. I hope it will work w/o woes of segfaults
+type FieldChain = ((String, DbType), [(String, EmbeddedDef)])
 
--- | Update field
-infixr 3 =.
-(=.) ::
-  ( Expression a
-  , TypesCastV v (FuncV a) v
-  , TypesCastC c (FuncC a) c)
-  => Fields v c (FuncA a) -> a -> Update v c
-f =. a = Update f (unsafeCoerceExpr $ wrap a)
+-- | Generalises data that can occur in expressions (so far there are Field and SubField).
+class Projection f r a => FieldLike f r a | f -> r a where
+  -- | It is used to map field to column names. It can be either a column name for a regular field of non-embedded type or a list of this field and the outer fields in reverse order. Eg, fieldChain $ SomeField ~> Tuple2_0Selector may result in Right [(\"val0\", DbString), (\"some\", DbEmbedded False [dbType \"\", dbType True])].
+  -- Function fieldChain can be simplified to f v c a -> [(String, DbType)]. Datatype Either is used for optimisation of the common case, eg Field v c Int.
+  fieldChain :: f -> FieldChain
 
--- | Boolean \"and\" operator.
-(&&.) :: (TypesCastV v1 v2 v3, TypesCastC c1 c2 c3) =>
-  Cond v1 c1 -> Cond v2 c2 -> Cond v3 c3
-  
--- | Boolean \"or\" operator.  
-(||.) :: (TypesCastV v1 v2 v3, TypesCastC c1 c2 c3) =>
-  Cond v1 c1 -> Cond v2 c2 -> Cond v3 c3
-  
-infixr 3 &&.
-a &&. b = And (unsafeCoerce a) (unsafeCoerce b)
+class PersistField v => Embedded v where
+  data Selector v :: * -> *
+  selectorNum :: Selector v a -> Int
 
-infixr 2 ||.
-a ||. b = Or (unsafeCoerce a) (unsafeCoerce b)
+infixl 5 ~>
+-- | Accesses fields of the embedded datatypes. For example, @SomeField ==. (\"abc\", \"def\") ||. SomeField ~> Tuple2_0Selector ==. \"def\"@
+(~>) :: (PersistEntity v, Constructor c, FieldLike f (RestrictionHolder v c) a, Embedded a) => f -> Selector a a' -> SubField v c a'
+field ~> sel = case fieldChain field of
+  ((name, typ), prefix) -> case typ of
+    DbEmbedded emb@(EmbeddedDef _ ts)             -> SubField (ts !! selectorNum sel, (name, emb):prefix)
+    DbEntity (Just (emb@(EmbeddedDef _ ts), _)) _ -> SubField (ts !! selectorNum sel, (name, emb):prefix)
+    other -> error $ "(~>): cannot get subfield of non-embedded type " ++ show other
 
-unsafeCoerceExpr :: Expr v1 c1 a -> Expr v2 c2 a
-unsafeCoerceExpr = unsafeCoerce
+newtype SubField v (c :: (* -> *) -> *) a = SubField ((String, DbType), [(String, EmbeddedDef)])
 
-(==.), (/=.) ::
-  ( TypeCast a b v c
-  , FuncA a ~ FuncA b
-  , PersistField (FuncA a))
-  => a -> b -> Cond v c
+-- | It can be used in expressions like a regular field. Note that the constructor should be specified for the condition.
+-- For example, @delete (AutoKeyField `asTypeOf` (undefined :: f v SomeConstructor) ==. k)@
+-- or @delete (AutoKeyField ==. k ||. SomeField ==. \"DUPLICATE\")@
+data AutoKeyField v c where
+  AutoKeyField :: (PersistEntity v, Constructor c) => AutoKeyField v c
 
-(<.), (<=.), (>.), (>=.) ::
-  ( TypeCast a b v c
-  , FuncA a ~ FuncA b
-  , PersistField (FuncA a)
-  , HasOrder (FuncA a))
-  => a -> b -> Cond v c
+data RestrictionHolder v (c :: (* -> *) -> *)
 
-infix 4 ==., <., <=., >., >=.
-a ==. b = Equals (unsafeCoerceExpr $ wrap a) (unsafeCoerceExpr $ wrap b)
-a /=. b = NotEquals (unsafeCoerceExpr $ wrap a) (unsafeCoerceExpr $ wrap b)
-a <.  b = Lesser (unsafeCoerceExpr $ wrap a) (unsafeCoerceExpr $ wrap b)
-a <=. b = Not $ a >. b
-a >.  b = Greater (unsafeCoerceExpr $ wrap a) (unsafeCoerceExpr $ wrap b)
-a >=. b = Not $ a <. b
+-- | Any data that can be fetched from a database
+class Projection p r a | p -> r a where
+  -- | It is like a 'fieldChain' for many fields. Difflist is used for concatenation efficiency.
+  projectionFieldChains :: p -> [FieldChain] -> [FieldChain]
+  -- | It is like 'fromPersistValues'. However, we cannot use it for projections in all cases. For the 'PersistEntity' instances 'fromPersistValues' expects entity id instead of the entity values.
+  projectionResult :: PersistBackend m => p -> [PersistValue] -> m (a, [PersistValue])
 
+data SelectOptions v c hasLimit hasOffset hasOrder = SelectOptions {
+    condOptions   :: Cond v c
+  , limitOptions  :: Maybe Int
+  , offsetOptions :: Maybe Int
+  , orderOptions  :: [Order v c]
+  }
+
+class HasSelectOptions a v c | a -> v c where
+  type HasLimit a
+  type HasOffset a
+  type HasOrder a
+  getSelectOptions :: a -> SelectOptions v c (HasLimit a) (HasOffset a) (HasOrder a)
+
+instance HasSelectOptions (Cond v c) v c where
+  type HasLimit (Cond v c) = HFalse
+  type HasOffset (Cond v c) = HFalse
+  type HasOrder (Cond v c) = HFalse
+  getSelectOptions a = SelectOptions a Nothing Nothing []
+
+instance HasSelectOptions (SelectOptions v c hasLimit hasOffset hasOrder) v c where
+  type HasLimit (SelectOptions v c hasLimit hasOffset hasOrder) = hasLimit
+  type HasOffset (SelectOptions v c hasLimit hasOffset hasOrder) = hasOffset
+  type HasOrder (SelectOptions v c hasLimit hasOffset hasOrder) = hasOrder
+  getSelectOptions = id
+
+limitTo :: (HasSelectOptions a v c, HasLimit a ~ HFalse) => a -> Int -> SelectOptions v c HTrue (HasOffset a) (HasOrder a)
+limitTo opts lim = case getSelectOptions opts of
+  SelectOptions c _ off ord -> SelectOptions c (Just lim) off ord
+
+offsetBy :: (HasSelectOptions a v c, HasOffset a ~ HFalse) => a -> Int -> SelectOptions v c (HasLimit a) HTrue (HasOrder a)
+offsetBy opts off = case getSelectOptions opts of
+  SelectOptions c lim _ ord -> SelectOptions c lim (Just off) ord
+
+orderBy :: (HasSelectOptions a v c, HasOrder a ~ HFalse) => a -> [Order v c] -> SelectOptions v c (HasLimit a) (HasOffset a) HTrue
+orderBy opts ord = case getSelectOptions opts of
+  SelectOptions c lim off _ -> SelectOptions c lim off ord
+
 newtype Monad m => DbPersist conn m a = DbPersist { unDbPersist :: ReaderT conn m a }
-  deriving (Monad, MonadIO, Functor, Applicative, MonadControlIO, MonadTrans)
+  deriving (Monad, MonadIO, Functor, Applicative, MonadTrans)
 
+instance MonadBase IO m => MonadBase IO (DbPersist conn m) where
+  liftBase = lift . liftBase
+
+instance MonadTransControl (DbPersist conn) where
+  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
+
+instance MonadBaseControl IO m => MonadBaseControl IO (DbPersist conn m) where
+  newtype StM (DbPersist conn m) a = StMSP {unStMSP :: ComposeSt (DbPersist conn) m a}
+  liftBaseWith = defaultLiftBaseWith StMSP
+  restoreM     = defaultRestoreM   unStMSP
+
 runDbPersist :: Monad m => DbPersist conn m a -> conn -> m a
-runDbPersist = runReaderT.unDbPersist
+runDbPersist = runReaderT . unDbPersist
 
-class Monad m => PersistBackend m where
+class PrimitivePersistField (AutoKeyType a) => DbDescriptor a where
+  -- | Type of the database default autoincremented key. For example, Sqlite has Int64
+  type AutoKeyType a
+
+class (Monad m, DbDescriptor (PhantomDb m)) => PersistBackend m where
+  -- | A token which defines the DB type. For example, different monads working with Sqlite, return Sqlite type.
+  type PhantomDb m
   -- | Insert a new record to a database and return its 'Key'
-  insert        :: PersistEntity v => v -> m (Key v)
-  -- | Try to insert a record and return Right newkey. If there is a constraint violation, Left oldkey is returned
-  -- , where oldkey is an identifier of the record with the same constraint values. Note that if several constraints are violated, a key of an arbitrary matching record is returned.
-  insertBy      :: PersistEntity v => v -> m (Either (Key v) (Key v))
-  -- | Replace a record with the given key. Result is undefined if the record does not exist.
-  replace       :: PersistEntity v => Key v -> v -> m ()
-  -- | Return a list of all records
-  selectEnum    :: (PersistEntity v, Constructor c)
-                => Cond v c
-                -> [Order v c]
-                -> Int -- ^ limit
-                -> Int -- ^ offset
-                -> Enumerator (Key v, v) m a
-  -- | Get all records. Order is undefined
-  selectAllEnum :: PersistEntity v => Enumerator (Key v, v) m a
+  insert        :: PersistEntity v => v -> m (AutoKey v)
+  -- | 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))
+  -- | 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))
+  -- | 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 ()
   -- | Return a list of the records satisfying the condition
-  select        :: (PersistEntity v, Constructor c)
-                => Cond v c
-                -> [Order v c]
-                -> Int -- ^ limit
-                -> Int -- ^ offset
-                -> m [(Key v, v)]
-  -- | Return a list of all records. Order is undefined
-  selectAll     :: PersistEntity v => m [(Key v, v)]
+  select        :: (PersistEntity v, Constructor c, HasSelectOptions opts v c)
+                => opts -> m [v]
+  -- | Return a list of all records. Order is undefined. It is useful for datatypes with multiple constructors.
+  selectAll     :: PersistEntity v => m [(AutoKey v, v)]
   -- | Fetch an entity from a database
-  get           :: PersistEntity v => Key v -> m (Maybe v)
+  get           :: (PersistEntity v, PrimitivePersistField (Key v BackendSpecific)) => 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)
   -- | Update the records satisfying the condition
   update        :: (PersistEntity v, Constructor c) => [Update v c] -> Cond v c -> m ()
   -- | Remove the records satisfying the condition
   delete        :: (PersistEntity v, Constructor c) => Cond v c -> m ()
   -- | Remove the record with given key. No-op if the record does not exist
-  deleteByKey   :: PersistEntity v => Key v -> m ()
+  deleteByKey   :: (PersistEntity v, PrimitivePersistField (Key v BackendSpecific)) => Key v BackendSpecific -> m ()
   -- | Count total number of records satisfying the condition
   count         :: (PersistEntity v, Constructor c) => Cond v c -> m Int
   -- | Count total number of records with all constructors
   countAll      :: PersistEntity v => v -> m Int
+  -- | Fetch projection of some fields
+  project       :: (PersistEntity v, Constructor c, Projection p (RestrictionHolder v c) a', HasSelectOptions opts v c)
+                => p
+                -> opts
+                -> m [a']
   -- | Check database schema and create migrations for the entity and the entities it contains
   migrate       :: PersistEntity v => v -> Migration m
   -- | Execute raw query
@@ -253,12 +281,9 @@
                 -> [PersistValue] -- ^ positional parameters
                 -> (RowPopper m -> m a) -- ^ results processing function
                 -> m a
-  -- TODO: we need to supply names of the tables or other info
-  insertTuple   :: NamedType -> [PersistValue] -> m Int64
-  getTuple      :: NamedType -> Int64 -> m [PersistValue]
   insertList    :: PersistField a => [a] -> m Int64
   getList       :: PersistField a => Int64 -> m [a]
-  
+
 type RowPopper m = m (Maybe [PersistValue])
 
 type Migration m = StateT NamedMigrations m ()
@@ -266,15 +291,15 @@
 -- | Datatype names and corresponding migrations
 type NamedMigrations = Map String SingleMigration
 
--- | Either error messages or migration queries with safety flags
-type SingleMigration = Either [String] [(Bool, String)]
+-- | Either error messages or migration queries with safety flag and execution order
+type SingleMigration = Either [String] [(Bool, Int, String)]
 
 -- | Describes an ADT.
 data EntityDef = EntityDef {
-  -- | Emtity name
+  -- | Entity name. @entityName (entityDef v) == persistName v@
     entityName   :: String
   -- | Named types of the instantiated polymorphic type parameters
-  , typeParams   :: [NamedType]
+  , typeParams   :: [DbType]
   -- | List of entity constructors definitions
   , constructors :: [ConstructorDef]
 } deriving (Show, Eq)
@@ -285,25 +310,35 @@
     constrNum     :: Int
   -- | Constructor name
   , constrName    :: String
+  -- | Autokey name if any
+  , constrAutoKeyName :: Maybe String
   -- | Parameter names with their named type
-  , constrParams  :: [(String, NamedType)]
+  , constrParams  :: [(String, DbType)]
   -- | Uniqueness constraints on the constructor fiels
-  , constrConstrs :: [Constraint]
+  , constrUniques :: [UniqueDef]
 } deriving (Show, Eq)
 
 -- | Phantom constructors are made instances of this class. This class should be used only by Template Haskell codegen
-class Constructor a where
+class Constructor c where
   -- returning ConstructorDef seems more logical, but it would require the value datatype
   -- it can be supplied either as a part of constructor type, eg instance Constructor (MyDataConstructor (MyData a)) which requires -XFlexibleInstances
   -- or as a separate type, eg instance Constructor MyDataConstructor (MyData a) which requires -XMultiParamTypeClasses
   -- the phantoms are primarily used to get the constructor name. So to keep user code cleaner we return only the name and number, which can be later used to get ConstructorDef from the EntityDef
-  phantomConstrName :: a -> String
-  phantomConstrNum :: a -> Int
+  phantomConstrName :: c (a :: * -> *) -> String
+  phantomConstrNum :: c (a :: * -> *) -> Int
 
--- | Constraint name and list of the field names that form a unique combination.
--- Only fields of 'Primitive' types can be used in a constraint
-type Constraint = (String, [String])
+class (Constructor (UniqueConstr uKey), PurePersistField uKey) => IsUniqueKey uKey where
+  type UniqueConstr uKey :: (* -> *) -> *
+  extractUnique :: uKey ~ Key v u => v -> uKey
+  uniqueNum :: uKey -> Int
 
+-- | Unique name and list of the field names that form a unique combination.
+-- Only fields of 'PrimitivePersistField' types can be used in a unique definition
+data UniqueDef = UniqueDef {
+    uniqueName :: String
+  , uniqueFields :: [(String, DbType)]
+}  deriving (Show, Eq)
+
 -- | A DB data type. Naming attempts to reflect the underlying Haskell
 -- datatypes, eg DbString instead of DbVarchar. Different databases may
 -- have different translations for these types.
@@ -315,33 +350,19 @@
             | DbDay
             | DbTime
             | DbDayTime
+            | DbDayTimeZoned
             | DbBlob    -- ByteString
 -- More complex types
-            | DbMaybe NamedType
-            | DbList NamedType
-            | DbTuple Int [NamedType]
-            | DbEntity EntityDef
-  deriving Show
-
--- TODO: this type can be changed to avoid storing the value itself. For example, ([String, DbType). Restriction: can be used to get DbType and name
--- | It is used to store type 'DbType' and persist name of a value
-data NamedType = forall v.PersistField v => NamedType v
-
-namedType :: PersistField v => v -> NamedType
-namedType = NamedType
-
-getName :: NamedType -> String
-getName (NamedType v) = persistName v
-
-getType :: NamedType -> DbType
-getType (NamedType v) = dbType v
-
-instance Show NamedType where
-  show (NamedType v) = show (dbType v)
+            | DbMaybe DbType
+            | DbList String DbType -- list name and type of its argument
+            | DbEmbedded EmbeddedDef
+            -- Nothing means autokey, Just contains a unique key definition and a name of unique constraint.
+            | DbEntity (Maybe (EmbeddedDef, String)) EntityDef
+  deriving (Eq, Show)
 
--- rely on the invariant that no two types have the same name
-instance Eq NamedType where
-  (NamedType v1) == (NamedType v2) = persistName v1 == persistName v2
+-- | The first argument is a flag which defines if the field names should be concatenated with the outer field name (False) or used as is which provides full control over table column names (True).
+-- Value False should be the default value so that a datatype can be embedded without name conflict concern. The second argument list of field names and field types.
+data EmbeddedDef = EmbeddedDef Bool [(String, DbType)] deriving (Eq, Show)
 
 -- | A raw value which can be stored in any backend and can be marshalled to
 -- and from a 'PersistField'.
@@ -353,37 +374,59 @@
                   | PersistDay Day
                   | PersistTimeOfDay TimeOfDay
                   | PersistUTCTime UTCTime
+                  | PersistZonedTime ZT
                   | PersistNull
-  deriving (Show, Eq)
+  deriving (Eq, Show)
 
+-- | Avoid orphan instances.
+newtype ZT = ZT ZonedTime deriving (Show, Read)
+
+instance Eq ZT where
+    ZT a == ZT b = zonedTimeToLocalTime a == zonedTimeToLocalTime b && zonedTimeZone a == zonedTimeZone b
+instance Ord ZT where
+    ZT a `compare` ZT b = zonedTimeToUTC a `compare` zonedTimeToUTC b
+
 -- | Arithmetic expressions which can include fields and literals
 data Arith v c a =
     Plus  (Arith v c a) (Arith v c a)
   | Minus (Arith v c a) (Arith v c a)
   | Mult  (Arith v c a) (Arith v c a)
   | Abs   (Arith v c a)
-  | ArithField (Fields v c a)
+  | forall f . (FieldLike f (RestrictionHolder v c) a) => ArithField f
   | Lit   Int64
-deriving instance Eq (Fields v c a) => Eq (Arith v c a)
-deriving instance Show (Fields v c a) => Show (Arith v c a)
 
-instance (Eq (Fields v c a), Show (Fields v c a), Numeric a) => Num (Arith v c a) where
-  a + b = Plus  a b
-  a - b = Minus a b
-  a * b = Mult  a b
-  abs   = Abs
-  signum = error "no signum"
+instance (PersistEntity v, Constructor c) => Eq (Arith v c a) where
+  (Plus a1 b1)   == (Plus a2 b2)   = a1 == a2 && b1 == b2
+  (Minus a1 b1)  == (Minus a2 b2)  = a1 == a2 && b1 == b2
+  (Mult a1 b1)   == (Mult a2 b2)   = a1 == a2 && b1 == b2
+  (Abs a)        == (Abs b)        = a == b
+  (ArithField a) == (ArithField b) = fieldChain a == fieldChain b
+  (Lit a)        == (Lit b)        = a == b
+  _              == _              = False
+
+instance (PersistEntity v, Constructor c) => Show (Arith v c a) where
+  show (Plus a b)     = "Plus (" ++ show a ++ ") (" ++ show b ++ ")"
+  show (Minus a b)    = "Minus (" ++ show a ++ ") (" ++ show b ++ ")"
+  show (Mult a b)     = "Mult (" ++ show a ++ ") (" ++ show b ++ ")"
+  show (Abs a)        = "Abs (" ++ show a ++ ")"
+  show (ArithField a) = "ArithField " ++ show (fieldChain a)
+  show (Lit a)        = "Lit " ++ show a
+
+instance (PersistEntity v, Constructor c, Numeric a) => Num (Arith v c a) where
+  a + b       = Plus  a b
+  a - b       = Minus a b
+  a * b       = Mult  a b
+  abs         = Abs
+  signum      = error "no signum"
   fromInteger = Lit . fromInteger
   
 -- | Convert field to an arithmetic value
-toArith :: Fields v c a -> Arith v c a
+toArith :: (PersistEntity v, FieldLike f (RestrictionHolder v c) a') => f -> Arith v c a'
 toArith = ArithField
 
--- | Constraint for use in arithmetic expressions. 'Num' is not used to explicitly include only types supported by the library .
+-- | Constraint for use in arithmetic expressions. 'Num' is not used to explicitly include only types supported by the library.
 -- TODO: consider replacement with 'Num'
 class Numeric a
--- | The same goals as for 'Numeric'. Certain types like String which have order in Haskell may not have it in DB
-class HasOrder a
 
 -- | Types which when converted to 'PersistValue' are never NULL.
 -- Consider the type @Maybe (Maybe a)@. Now Nothing is stored as NULL, so we cannot distinguish between Just Nothing and Nothing which is a problem.
@@ -391,451 +434,39 @@
 -- Maybe this class can be removed when support for inner Maybe's appears.
 class NeverNull a
 
--- | Datatypes which can be converted directly to 'PersistValue'
-class Primitive a where
-  toPrim :: a -> PersistValue
-  fromPrim :: PersistValue -> a
-
--- | Used to uniformly represent fields, literals and arithmetic expressions.
--- A value should be convertec to 'Expr' for usage in expressions
+-- | Used to uniformly represent fields, constants and arithmetic expressions.
+-- A value should be converted to 'Expr' for usage in expressions
 data Expr v c a where
-  ExprPrim  :: Primitive a => a -> Expr v c a
-  ExprField :: PersistEntity v => Fields v c a -> Expr v c a
-  ExprArith :: PersistEntity v => Arith v c a -> Expr v c a
-  -- we need this field for Key and Maybe mostly
-  ExprPlain :: Primitive a => a -> Expr v c (FuncA a)
-
--- I wish wrap could return Expr with both fixed and polymorphic v&c. Any is used to emulate polymorphic types.
--- | Instances of this type can be converted to 'Expr'
-class Expression a where
-  type FuncV a; type FuncC a; type FuncA a
-  wrap :: a -> Expr (FuncV a) (FuncC a) (FuncA a)
-
--- | By default during converting values of certain types to 'Expr', the types can be changed. For example, @'Key' a@ is transformed into @a@.
--- It is convenient because the fields usually contain reference to a certain datatype, not its 'Key'.
--- But sometimes when automatic transformation gets in the way function 'wrapPrim' will help. Use it when a field in a datatype has type @(Key a)@ or @Maybe (Key a)@. Example:
---
--- @
---data Example = Example {entity1 :: Maybe Smth, entity2 :: Key Smth}
---Entity1Field ==. Just k &&. Entity2Field ==. wrapPrim k
--- @
-wrapPrim :: Primitive a => a -> Expr Any Any a
--- We cannot create different Expression instances for (Fields v c a) and (Fields v c (Key a))
--- so that Func (Fields v c a) = a and Func (Fields v c (Key a)) = a
--- because of the type families overlap restrictions. Neither we can create different instances for Key a
-wrapPrim = ExprPrim
+  ExprField :: (PersistEntity v, FieldLike f (RestrictionHolder v c) a') => f -> Expr v c f
+  ExprArith :: PersistEntity v => Arith v c a -> Expr v c (Arith v c a)
+  ExprPure :: forall v c a . PurePersistField a => a -> Expr v c a
 
+-- | Represents everything which can be put into a database. This data can be stored in multiple columns and tables. To get value of those columns we might need to access another table. That is why the result type is monadic.
 class PersistField a where
-  -- | Return name of the type. If it is polymorhic, the names of parameter types are separated with \"$\" symbol
+  -- | Return name of the type. If it is polymorhic, the names of parameter types are separated with 'Database.Groundhog.Generic.delim' symbol
   persistName :: a -> String
   -- | Convert a value into something which can be stored in a database column.
   -- Note that for complex datatypes it may insert them to return identifier
-  toPersistValue :: PersistBackend m => a -> m PersistValue
+  toPersistValues :: PersistBackend m => a -> m ([PersistValue] -> [PersistValue])
   -- | Constructs a value from a 'PersistValue'. For complex datatypes it may query the database
-  fromPersistValue :: PersistBackend m => PersistValue -> m a
+  fromPersistValues :: PersistBackend m => [PersistValue] -> m (a, [PersistValue])
   -- | Description of value type
   dbType :: a -> DbType
 
----- INSTANCES
-
-instance Numeric Int
-instance Numeric Int8
-instance Numeric Int16
-instance Numeric Int32
-instance Numeric Int64
-instance Numeric Word8
-instance Numeric Word16
-instance Numeric Word32
-instance Numeric Word64
-instance Numeric Double
-
-instance HasOrder Int
-instance HasOrder Int8
-instance HasOrder Int16
-instance HasOrder Int32
-instance HasOrder Int64
-instance HasOrder Word8
-instance HasOrder Word16
-instance HasOrder Word32
-instance HasOrder Word64
-instance HasOrder Double
-instance HasOrder Bool
-instance HasOrder Day
-instance HasOrder TimeOfDay
-instance HasOrder UTCTime
-
-instance Primitive String where
-  toPrim = PersistString
-  fromPrim (PersistString s) = s
-  fromPrim (PersistByteString bs) = T.unpack $ T.decodeUtf8With T.lenientDecode bs
-  fromPrim (PersistInt64 i) = show i
-  fromPrim (PersistDouble d) = show d
-  fromPrim (PersistDay d) = show d
-  fromPrim (PersistTimeOfDay d) = show d
-  fromPrim (PersistUTCTime d) = show d
-  fromPrim (PersistBool b) = show b
-  fromPrim PersistNull = error "Unexpected null"
-
-instance Primitive T.Text where
-  toPrim = PersistString . T.unpack
-  fromPrim (PersistByteString bs) = T.decodeUtf8With T.lenientDecode bs
-  fromPrim x = T.pack $ fromPrim x
-
-instance Primitive ByteString where
-  toPrim = PersistByteString
-  fromPrim (PersistByteString a) = a
-  fromPrim x = T.encodeUtf8 . T.pack $ fromPrim x
-
-instance Primitive Int where
-  toPrim = PersistInt64 . fromIntegral
-  fromPrim (PersistInt64 a) = fromIntegral a
-  fromPrim x = error $ "Expected Integer, received: " ++ show x
-
-instance Primitive Int8 where
-  toPrim = PersistInt64 . fromIntegral
-  fromPrim (PersistInt64 a) = fromIntegral a
-  fromPrim x = error $ "Expected Integer, received: " ++ show x
-
-instance Primitive Int16 where
-  toPrim = PersistInt64 . fromIntegral
-  fromPrim (PersistInt64 a) = fromIntegral a
-  fromPrim x = error $ "Expected Integer, received: " ++ show x
-
-instance Primitive Int32 where
-  toPrim = PersistInt64 . fromIntegral
-  fromPrim (PersistInt64 a) = fromIntegral a
-  fromPrim x = error $ "Expected Integer, received: " ++ show x
-
-instance Primitive Int64 where
-  toPrim = PersistInt64
-  fromPrim (PersistInt64 a) = a
-  fromPrim x = error $ "Expected Integer, received: " ++ show x
-
-instance Primitive Word8 where
-  toPrim = PersistInt64 . fromIntegral
-  fromPrim (PersistInt64 a) = fromIntegral a
-  fromPrim x = error $ "Expected Integer, received: " ++ show x
-
-instance Primitive Word16 where
-  toPrim = PersistInt64 . fromIntegral
-  fromPrim (PersistInt64 a) = fromIntegral a
-  fromPrim x = error $ "Expected Integer, received: " ++ show x
-
-instance Primitive Word32 where
-  toPrim = PersistInt64 . fromIntegral
-  fromPrim (PersistInt64 a) = fromIntegral a
-  fromPrim x = error $ "Expected Integer, received: " ++ show x
-
-instance Primitive Word64 where
-  toPrim = PersistInt64 . fromIntegral
-  fromPrim (PersistInt64 a) = fromIntegral a
-  fromPrim x = error $ "Expected Integer, received: " ++ show x
-
-instance Primitive Double where
-  toPrim = PersistDouble
-  fromPrim (PersistDouble a) = a
-  fromPrim x = error $ "Expected Double, received: " ++ show x
-
-instance Primitive Bool where
-  toPrim = PersistBool
-  fromPrim (PersistBool a) = a
-  fromPrim (PersistInt64 i) = i /= 0
-  fromPrim x = error $ "Expected Bool, received: " ++ show x
-
-instance Primitive Day where
-  toPrim = PersistDay
-  fromPrim (PersistDay a) = a
-  fromPrim x = readHelper x ("Expected Day, received: " ++ show x)
-
-instance Primitive TimeOfDay where
-  toPrim = PersistTimeOfDay
-  fromPrim (PersistTimeOfDay a) = a
-  fromPrim x = readHelper x ("Expected TimeOfDay, received: " ++ show x)
-
-instance Primitive UTCTime where
-  toPrim = PersistUTCTime
-  fromPrim (PersistUTCTime a) = a
-  fromPrim x = readHelper x ("Expected UTCTime, received: " ++ show x)
-
-instance Primitive (Key a) where
-  toPrim (Key a) = PersistInt64 a
-  fromPrim (PersistInt64 a) = Key a
-  fromPrim x = error $ "Expected Integer(entity key), received: " ++ show x
-
-instance (Primitive a, NeverNull a) => Primitive (Maybe a) where
-  toPrim = maybe PersistNull toPrim
-  fromPrim PersistNull = Nothing
-  fromPrim x = Just $ fromPrim x
-
-instance NeverNull String
-instance NeverNull T.Text
-instance NeverNull ByteString
-instance NeverNull Int
-instance NeverNull Int64
-instance NeverNull Double
-instance NeverNull Bool
-instance NeverNull Day
-instance NeverNull TimeOfDay
-instance NeverNull UTCTime
-instance NeverNull (Key a)
-instance NeverNull [a]
-instance NeverNull (a, b)
-instance NeverNull (a, b, c)
-instance NeverNull (a, b, c, d)
-instance NeverNull (a, b, c, d, e)
-instance PersistEntity a => NeverNull a
-
-instance Expression (Expr v c a) where
-  type FuncV (Expr v c a) = v
-  type FuncC (Expr v c a) = c
-  type FuncA (Expr v c a) = a
-  wrap = id
-
-instance PersistEntity v => Expression (Fields v c a) where
-  type FuncV (Fields v c a) = v
-  type FuncC (Fields v c a) = c
-  type FuncA (Fields v c a) = a
-  wrap = ExprField
-
-instance PersistEntity v => Expression (Arith v c a) where
-  type FuncV (Arith v c a) = v
-  type FuncC (Arith v c a) = c
-  type FuncA (Arith v c a) = a
-  wrap = ExprArith
-
-instance (Expression a, Primitive a, NeverNull a) => Expression (Maybe a) where
-  type FuncV (Maybe a) = Any
-  type FuncC (Maybe a) = Any
-  type FuncA (Maybe a) = (Maybe (FuncA a))
-  wrap = ExprPlain
-
-instance Expression (Key a) where
-  type FuncV (Key a) = Any; type FuncC (Key a) = Any; type FuncA (Key a) = a
-  wrap = ExprPlain
-
-instance Expression Int where
-  type FuncV Int = Any; type FuncC Int = Any; type FuncA Int = Int
-  wrap = ExprPrim
-
-instance Expression Int8 where
-  type FuncV Int8 = Any; type FuncC Int8 = Any; type FuncA Int8 = Int8
-  wrap = ExprPrim
-
-instance Expression Int16 where
-  type FuncV Int16 = Any; type FuncC Int16 = Any; type FuncA Int16 = Int16
-  wrap = ExprPrim
-
-instance Expression Int32 where
-  type FuncV Int32 = Any; type FuncC Int32 = Any; type FuncA Int32 = Int32
-  wrap = ExprPrim
-
-instance Expression Int64 where
-  type FuncV Int64 = Any; type FuncC Int64 = Any; type FuncA Int64 = Int64
-  wrap = ExprPrim
-
-instance Expression Word8 where
-  type FuncV Word8 = Any; type FuncC Word8 = Any; type FuncA Word8 = Word8
-  wrap = ExprPrim
-
-instance Expression Word16 where
-  type FuncV Word16 = Any; type FuncC Word16 = Any; type FuncA Word16 = Word16
-  wrap = ExprPrim
-
-instance Expression Word32 where
-  type FuncV Word32 = Any; type FuncC Word32 = Any; type FuncA Word32 = Word32
-  wrap = ExprPrim
-
-instance Expression Word64 where
-  type FuncV Word64 = Any; type FuncC Word64 = Any; type FuncA Word64 = Word64
-  wrap = ExprPrim
-
-instance Expression String where
-  type FuncV String = Any; type FuncC String = Any; type FuncA String = String
-  wrap = ExprPrim
-
-instance Expression ByteString where
-  type FuncV ByteString = Any; type FuncC ByteString = Any; type FuncA ByteString = ByteString
-  wrap = ExprPrim
-
-instance Expression T.Text where
-  type FuncV T.Text = Any; type FuncC T.Text = Any; type FuncA T.Text = T.Text
-  wrap = ExprPrim
-
-instance Expression Bool where
-  type FuncV Bool = Any; type FuncC Bool = Any; type FuncA Bool = Bool
-  wrap = ExprPrim
-
-readHelper :: Read a => PersistValue -> String -> a
-readHelper s errMessage = case s of
-  PersistString str -> readHelper' str
-  PersistByteString str -> readHelper' (unpack str)
-  _ -> error errMessage
-  where
-    readHelper' str = case reads str of
-      (a, _):_ -> a
-      _        -> error errMessage
-
-instance PersistField ByteString where
-  persistName _ = "ByteString"
-  toPersistValue = return . toPrim
-  fromPersistValue = return . fromPrim
-  dbType _ = DbBlob
-
-instance PersistField String where
-  persistName _ = "String"
-  toPersistValue = return . toPrim
-  fromPersistValue = return . fromPrim
-  dbType _ = DbString
-
-instance PersistField T.Text where
-  persistName _ = "Text"
-  toPersistValue = return . toPrim
-  fromPersistValue = return . fromPrim
-  dbType _ = DbString
-
-instance PersistField Int where
-  persistName _ = "Int"
-  toPersistValue = return . toPrim
-  fromPersistValue = return . fromPrim
-  dbType a = if bitSize a == 32 then DbInt32 else DbInt64
-
-instance PersistField Int8 where
-  persistName _ = "Int8"
-  toPersistValue = return . toPrim
-  fromPersistValue = return . fromPrim
-  dbType _ = DbInt64
-
-instance PersistField Int16 where
-  persistName _ = "Int16"
-  toPersistValue = return . toPrim
-  fromPersistValue = return . fromPrim
-  dbType _ = DbInt64
-
-instance PersistField Int32 where
-  persistName _ = "Int32"
-  toPersistValue = return . toPrim
-  fromPersistValue = return . fromPrim
-  dbType _ = DbInt64
-
-instance PersistField Int64 where
-  persistName _ = "Int64"
-  toPersistValue = return . toPrim
-  fromPersistValue = return . fromPrim
-  dbType _ = DbInt64
-
-instance PersistField Word8 where
-  persistName _ = "Word8"
-  toPersistValue = return . toPrim
-  fromPersistValue = return . fromPrim
-  dbType _ = DbInt64
-
-instance PersistField Word16 where
-  persistName _ = "Word16"
-  toPersistValue = return . toPrim
-  fromPersistValue = return . fromPrim
-  dbType _ = DbInt64
-
-instance PersistField Word32 where
-  persistName _ = "Word32"
-  toPersistValue = return . toPrim
-  fromPersistValue = return . fromPrim
-  dbType _ = DbInt64
-
-instance PersistField Word64 where
-  persistName _ = "Word64"
-  toPersistValue = return . toPrim
-  fromPersistValue = return . fromPrim
-  dbType _ = DbInt64
-
-instance PersistField Double where
-  persistName _ = "Double"
-  toPersistValue = return . PersistDouble
-  fromPersistValue = return . fromPrim
-  dbType _ = DbReal
-
-instance PersistField Bool where
-  persistName _ = "Bool"
-  toPersistValue = return . PersistBool
-  fromPersistValue = return . fromPrim
-  dbType _ = DbBool
-
-instance PersistField Day where
-  persistName _ = "Day"
-  toPersistValue = return . PersistDay
-  fromPersistValue = return . fromPrim
-  dbType _ = DbDay
-
-instance PersistField TimeOfDay where
-  persistName _ = "TimeOfDay"
-  toPersistValue = return . PersistTimeOfDay
-  fromPersistValue = return . fromPrim
-  dbType _ = DbTime
-
-instance PersistField UTCTime where
-  persistName _ = "UTCTime"
-  toPersistValue = return . PersistUTCTime
-  fromPersistValue = return . fromPrim
-  dbType _ = DbDayTime
+-- | Represents all datatypes that map into a single column. Getting value for that column might require monadic actions to access other tables.
+class PersistField a => SinglePersistField a where
+  toSinglePersistValue :: PersistBackend m => a -> m PersistValue
+  fromSinglePersistValue :: PersistBackend m => PersistValue -> m a
 
-instance (PersistField a, NeverNull a) => PersistField (Maybe a) where
-  persistName (_ :: Maybe a) = "Maybe$" ++ persistName (undefined :: a)
-  toPersistValue = maybe (return PersistNull) toPersistValue
-  fromPersistValue PersistNull = return Nothing
-  fromPersistValue x = liftM Just $ fromPersistValue x
-  dbType (_ :: Maybe a) = DbMaybe $ namedType (undefined :: a)
-  
-instance (PersistEntity a) => PersistField (Key a) where
-  persistName (_ :: Key a) = "Key$" ++ persistName (undefined :: a)
-  toPersistValue (Key a) = return $ PersistInt64 a
-  fromPersistValue = return . fromPrim
-  dbType (_ :: Key a) = DbEntity $ entityDef (undefined :: a)
+-- | 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])
 
-instance (PersistField a) => PersistField [a] where
-  persistName (_ :: [a]) = "List$$" ++ persistName (undefined :: a)
-  toPersistValue l = insertList l >>= toPersistValue
-  fromPersistValue k = getList (fromPrim k)
-  dbType (_ :: [a]) = DbList $ namedType (undefined :: a)
+-- | 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.
+class (SinglePersistField a, PurePersistField a) => PrimitivePersistField a where
+  toPrimitivePersistValue :: DbDescriptor db => Proxy db -> a -> PersistValue
+  fromPrimitivePersistValue :: DbDescriptor db => Proxy db -> PersistValue -> a
 
-instance (PersistField a, PersistField b) => PersistField (a, b) where
-  persistName (_ :: (a, b)) = "Tuple2$$" ++ persistName (undefined :: a) ++ "$" ++ persistName (undefined :: b)
-  toPersistValue x@(a, b) = do
-    vals <- sequence [toPersistValue a, toPersistValue b]
-    liftM PersistInt64 $ insertTuple (namedType x) vals 
-  fromPersistValue (PersistInt64 key) = do
-    [a, b] <- getTuple (namedType (undefined :: (a, b))) key
-    liftM2 (,) (fromPersistValue a) (fromPersistValue b)
-  fromPersistValue x = fail $ "Expected Integer(tuple key), received: " ++ show x
-  dbType (_ :: (a, b)) = DbTuple 2 [namedType (undefined :: a), namedType (undefined :: b)]
-  
-instance (PersistField a, PersistField b, PersistField c) => PersistField (a, b, c) where
-  persistName (_ :: (a, b, c)) = "Tuple3$$" ++ persistName (undefined :: a) ++ "$" ++ persistName (undefined :: b) ++ "$" ++ persistName (undefined :: c)
-  toPersistValue x@(a, b, c) = do
-    vals <- sequence [toPersistValue a, toPersistValue b, toPersistValue c]
-    liftM PersistInt64 $ insertTuple (namedType x) vals 
-  fromPersistValue (PersistInt64 key) = do
-    [a, b, c] <- getTuple (namedType (undefined :: (a, b, c))) key
-    liftM3 (,,) (fromPersistValue a) (fromPersistValue b) (fromPersistValue c)
-  fromPersistValue x = fail $ "Expected Integer(tuple key), received: " ++ show x
-  dbType (_ :: (a, b, c)) = DbTuple 3 [namedType (undefined :: a), namedType (undefined :: b), namedType (undefined :: c)]
-  
-instance (PersistField a, PersistField b, PersistField c, PersistField d) => PersistField (a, b, c, d) where
-  persistName (_ :: (a, b, c, d)) = "Tuple4$$" ++ persistName (undefined :: a) ++ "$" ++ persistName (undefined :: b) ++ "$" ++ persistName (undefined :: c) ++ "$" ++ persistName (undefined :: d)
-  toPersistValue x@(a, b, c, d) = do
-    vals <- sequence [toPersistValue a, toPersistValue b, toPersistValue c, toPersistValue d]
-    liftM PersistInt64 $ insertTuple (namedType x) vals 
-  fromPersistValue (PersistInt64 key) = do
-    [a, b, c, d] <- getTuple (namedType (undefined :: (a, b, c, d))) key
-    liftM4 (,,,) (fromPersistValue a) (fromPersistValue b) (fromPersistValue c) (fromPersistValue d)
-  fromPersistValue x = fail $ "Expected Integer(tuple key), received: " ++ show x
-  dbType (_ :: (a, b, c, d)) = DbTuple 4 [namedType (undefined :: a), namedType (undefined :: b), namedType (undefined :: c), namedType (undefined :: d)]
-  
-instance (PersistField a, PersistField b, PersistField c, PersistField d, PersistField e) => PersistField (a, b, c, d, e) where
-  persistName (_ :: (a, b, c, d, e)) = "Tuple5$$" ++ persistName (undefined :: a) ++ "$" ++ persistName (undefined :: b) ++ "$" ++ persistName (undefined :: c) ++ "$" ++ persistName (undefined :: d) ++ "$" ++ persistName (undefined :: e)
-  toPersistValue x@(a, b, c, d, e) = do
-    vals <- sequence [toPersistValue a, toPersistValue b, toPersistValue c, toPersistValue d, toPersistValue e]
-    liftM PersistInt64 $ insertTuple (namedType x) vals 
-  fromPersistValue (PersistInt64 key) = do
-    [a, b, c, d, e] <- getTuple (namedType (undefined :: (a, b, c, d, e))) key
-    liftM5 (,,,,) (fromPersistValue a) (fromPersistValue b) (fromPersistValue c) (fromPersistValue d) (fromPersistValue e)
-  fromPersistValue x = fail $ "Expected Integer(tuple key), received: " ++ show x
-  dbType (_ :: (a, b, c, d, e)) = DbTuple 5 [namedType (undefined :: a), namedType (undefined :: b), namedType (undefined :: c), namedType (undefined :: d), namedType (undefined :: e)]
+delim :: Char
+delim = '#'
diff --git a/Database/Groundhog/Expression.hs b/Database/Groundhog/Expression.hs
new file mode 100644
--- /dev/null
+++ b/Database/Groundhog/Expression.hs
@@ -0,0 +1,129 @@
+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts, FlexibleInstances, FunctionalDependencies, UndecidableInstances, OverlappingInstances, EmptyDataDecls #-}
+
+-- | 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:
+--
+-- @
+-- StringField ==. \"abc\" &&. NumberField >. (0 :: Int) ||. MaybeField ==. (Nothing :: Maybe String) ||. MaybeField ==. Just \"def\"
+-- @
+--
+-- Note that polymorphic values like numbers or Nothing must have a type annotation
+
+module Database.Groundhog.Expression
+  ( Expression(..)
+  , (=.)
+  , (&&.), (||.)
+  , (==.), (/=.), (<.), (<=.), (>.), (>=.)
+  ) where
+
+import Database.Groundhog.Core
+import Database.Groundhog.Instances ()
+
+-- | Instances of this type can be converted to 'Expr'. It is useful for uniform manipulation over fields and plain values
+class Expression a v c where
+  wrap :: a -> Expr v c a
+
+instance PurePersistField a => Expression a v c where
+  wrap = ExprPure
+
+instance (PersistEntity v, Constructor c, PersistField a, v ~ v', c ~ c') => Expression (Arith v c a) v' c' where
+  wrap = ExprArith
+
+instance (PersistEntity v, Constructor c, PersistField a, v ~ v', c ~ c') => Expression (Field v c a) v' c' where
+  wrap = ExprField
+
+instance (PersistEntity v, Constructor c, PersistField a, v ~ v', c ~ c') => Expression (SubField v c a) v' c' where
+  wrap = ExprField
+
+instance (PersistEntity v, Constructor c, FieldLike (AutoKeyField v c) (RestrictionHolder v c) a', v ~ v', c ~ c') => Expression (AutoKeyField v c) v' c' where
+  wrap = ExprField
+
+instance (PersistEntity v, Constructor c, FieldLike (u (UniqueMarker v)) (RestrictionHolder v c) a', v ~ v', c ~ c') => Expression (u (UniqueMarker v)) v' c' where
+  wrap = ExprField
+
+-- 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
+-- 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
+
+class Normalize counterpart t r | t -> r
+instance (ExtractValue t (isPlain, r), NormalizeValue counterpart isPlain r r') => Normalize counterpart t r'
+
+class ExtractValue t r | t -> r
+instance r ~ (HTrue, a) => ExtractValue (Arith v c a) r
+instance r ~ (HFalse, a) => ExtractValue (Field v c a) r
+instance r ~ (HFalse, a) => ExtractValue (SubField v c a) r
+instance r ~ (HFalse, Key v BackendSpecific) => ExtractValue (AutoKeyField v c) r
+instance r ~ (HFalse, Key v (Unique u)) => ExtractValue (u (UniqueMarker v)) r
+instance r ~ (HTrue, a) => ExtractValue a r
+
+class NormalizeValue counterpart isPlain t r | t isPlain -> r
+instance NormalizeValue' t (isPlain, r) => NormalizeValue HFalse HFalse t (HFalse, r)
+instance NormalizeValue' t (isPlain, r) => NormalizeValue HFalse HTrue t (isPlain, r)
+instance r ~ (isPlain, t) => NormalizeValue HTrue isPlain 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 a) (Key a u) isDef,
+         r ~ (Not isDef, Maybe (NormalizeKey isDef (Key a u))))
+         => NormalizeValue' (Maybe (Key a u)) r
+instance (TypeEq (DefaultKey a) (Key a u) isDef,
+         r ~ (Not isDef, NormalizeKey isDef (Key a u)))
+         => NormalizeValue' (Key a u) r
+instance 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
+
+type family NormalizeKey isDef key
+type instance NormalizeKey HTrue (Key a u) = a
+type instance NormalizeKey HFalse a = a
+
+type family Not bool
+type instance Not HTrue  = HFalse
+type instance Not HFalse = HTrue
+
+-- | Update field
+infixr 3 =.
+(=.) ::
+  ( Expression b v c
+  , FieldLike f (RestrictionHolder v c) a'
+  , Unifiable f b)
+  => f -> b -> Update v c
+f =. b = Update f (wrap b)
+
+-- | Boolean \"and\" operator.
+(&&.) :: Cond v c -> Cond v c -> Cond v c
+
+-- | Boolean \"or\" operator.  
+(||.) :: Cond v c -> Cond v c -> Cond v c
+
+infixr 3 &&.
+a &&. b = And a b
+
+infixr 2 ||.
+a ||. b = Or a b
+
+(==.), (/=.) ::
+  ( Expression a v c
+  , Expression b v c
+  , Unifiable a b)
+  => a -> b -> Cond v c
+
+(<.), (<=.), (>.), (>=.) ::
+  ( Expression a v c
+  , Expression b v c
+  , Unifiable a b)
+  => a -> b -> Cond v c
+
+infix 4 ==., <., <=., >., >=.
+a ==. b = Compare Eq (wrap a) (wrap b)
+a /=. b = Compare Ne (wrap a) (wrap b)
+a <.  b = Compare Lt (wrap a) (wrap b)
+a <=. b = Compare Le (wrap a) (wrap b)
+a >.  b = Compare Gt (wrap a) (wrap b)
+a >=. b = Compare Ge (wrap a) (wrap b)
diff --git a/Database/Groundhog/Generic.hs b/Database/Groundhog/Generic.hs
--- a/Database/Groundhog/Generic.hs
+++ b/Database/Groundhog/Generic.hs
@@ -1,56 +1,61 @@
+{-# LANGUAGE FlexibleContexts, ExistentialQuantification, ScopedTypeVariables #-}
+
 -- | This helper module is intended for use by the backend creators
 module Database.Groundhog.Generic
-  ( migrateRecursively
-  , createMigration
+  ( 
+  -- * Migration
+    createMigration
   , executeMigration
   , executeMigrationUnsafe
   , runMigration
   , runMigrationUnsafe
   , printMigration
-  , getEntityName
   , mergeMigrations
   , silentMigrationLogger
   , defaultMigrationLogger
-  , defaultSelect
-  , defaultSelectAll
+  , failMessage
+  -- * Helper functions defining *PersistValue instances
+  , primToPersistValue
+  , primFromPersistValue
+  , pureToPersistValue
+  , pureFromPersistValue
+  , singleToPersistValue
+  , singleFromPersistValue
+  , toSinglePersistValueUnique
+  , fromSinglePersistValueUnique
+  , toPersistValuesUnique
+  , fromPersistValuesUnique
+  , toSinglePersistValueAutoKey
+  , fromSinglePersistValueAutoKey
+  -- * Other
+  , bracket
+  , finally
+  , onException
+  , PSEmbeddedFieldDef(..)
+  , applyEmbeddedDbTypeSettings
+  , findOne
+  , replaceOne
+  , matchElements
+  , haveSameElems
+  , mapAllRows
+  , phantomDb
+  , isSimple
   ) where
 
 import Database.Groundhog.Core
 
-import Control.Monad(liftM, forM_)
-import Control.Monad.Trans.State
-import Control.Monad.Trans.Class(lift)
+import Control.Monad (liftM, forM_, (>=>))
+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 Data.Enumerator(Iteratee(..), run, (==<<))
-import Data.Enumerator.List(consume)
-import Data.Either(partitionEithers)
-import Data.List(intercalate)
+import Data.Either (partitionEithers)
+import Data.Function (on)
+import Data.List (partition, sortBy)
+import Data.Maybe (fromMaybe)
 import qualified Data.Map as Map
 
--- | Create migration for a given entity and all entities it depends on.
--- The stateful Map is used to avoid duplicate migrations when an entity type
--- occurs several times in a datatype
-migrateRecursively :: (Monad m, PersistEntity e) => 
-     (EntityDef -> m SingleMigration)          -- ^ migrate entity
-  -> (Int -> [NamedType] -> m SingleMigration) -- ^ migrate tuple
-  -> (NamedType -> m SingleMigration)          -- ^ migrate list
-  -> e                                         -- ^ initial entity
-  -> StateT NamedMigrations m ()
-migrateRecursively migE migT migL = go . namedType where
-  go w = case getType w of
-    (DbList t)     -> f (getName w) (migL t) (go t)
-    (DbTuple n ts) -> f (getName w) (migT n ts) (mapM_ go ts)
-    (DbEntity e) -> f (getName w) (migE e) (mapM_ go (allSubtypes e))
-    (DbMaybe t)    -> go t
-    _              -> return ()    -- ordinary types need not migration
-  f name mig cont = do
-    v <- gets (Map.lookup name)
-    case v of
-      Nothing -> lift mig >>= modify.Map.insert name >> cont
-      _ -> return ()
-  allSubtypes = map snd . concatMap constrParams . constructors
-
-getCorrectMigrations :: NamedMigrations -> [(Bool, String)]
+getCorrectMigrations :: NamedMigrations -> [(Bool, Int, String)]
 getCorrectMigrations = either (error.unlines) id . mergeMigrations . Map.elems
 
 -- | Produce the migrations but not execute them. Fails when an unsafe migration occurs.
@@ -61,18 +66,18 @@
 executeMigration :: (PersistBackend m, MonadIO m) => (String -> IO ()) -> NamedMigrations -> m ()
 executeMigration logger m = do
   let migs = getCorrectMigrations m
-  let unsafe = map snd $ filter fst migs
+  let unsafe = filter (\(isUnsafe, _, _) -> isUnsafe) migs
   if null unsafe
-    then mapM_ (executeMigrate logger.snd) migs
+    then mapM_ (\(_, _, query) -> executeMigrate logger query) $ sortBy (compare `on` \(_, i, _) -> i) migs
     else error $ concat
             [ "\n\nDatabase migration: manual intervention required.\n"
             , "The following actions are considered unsafe:\n\n"
-            , unlines $ map (\s -> "    " ++ s ++ ";") unsafe
+            , unlines $ map (\(_, _, query) -> "    " ++ query ++ ";") unsafe
             ]
 
 -- | Execute migrations and log them. Executes the unsafe migrations without warnings
 executeMigrationUnsafe :: (PersistBackend m, MonadIO m) => (String -> IO ()) -> NamedMigrations -> m ()
-executeMigrationUnsafe logger = mapM_ (executeMigrate logger.snd) . getCorrectMigrations
+executeMigrationUnsafe logger = mapM_ (\(_, _, query) -> executeMigrate logger query) . getCorrectMigrations
 
 -- | Pretty print the migrations
 printMigration :: MonadIO m => NamedMigrations -> m ()
@@ -83,8 +88,8 @@
     case v of
       Left errors -> mapM_ (putStrLn . ("\tError:\t" ++)) errors
       Right sqls  -> do
-        let showSql (isUnsafe, sql) = (if isUnsafe then "Unsafe:\t" else "Safe:\t") ++ sql
-        mapM_ (putStrLn . ("\t" ++).showSql) sqls
+        let showSql (isUnsafe, _, sql) = (if isUnsafe then "Unsafe:\t" else "Safe:\t") ++ sql
+        mapM_ (putStrLn . ("\t" ++) . showSql) sqls
 
 -- | Run migrations and log them. Fails when an unsafe migration occurs.
 runMigration :: (PersistBackend m, MonadIO m) => (String -> IO ()) -> Migration m -> m ()
@@ -116,24 +121,131 @@
        then Right (concat statements)
        else Left  (concat errors)
 
--- | Get full entity name with the names of its parameters.
---
--- @ getEntityName (entityDef v) == persistName v @
-getEntityName :: EntityDef -> String
-getEntityName e = intercalate "$" $ entityName e:map getName (typeParams e)
+failMessage :: PersistField a => a -> [PersistValue] -> String
+failMessage a xs = "Invalid list for " ++ persistName a ++ ": " ++ show xs
 
--- | Call 'selectEnum' but return the result as a list
-defaultSelect :: (PersistBackend m, PersistEntity v, Constructor c) => Cond v c -> [Order v c] -> Int -> Int -> m [(Key v, v)]
-defaultSelect cond ord off lim = do
-    res <- run $ selectEnum cond ord off lim ==<< consume
-    case res of
-        Left e -> error $ show e
-        Right x -> return x
+finally :: MonadBaseControl IO m
+        => m a -- ^ computation to run first
+        -> m b -- ^ computation to run afterward (even if an exception was raised)
+        -> m a
+finally a sequel = control $ \runInIO ->
+                     E.finally (runInIO a)
+                               (runInIO sequel)
 
--- | Call 'selectAllEnum' but return the result as a list
-defaultSelectAll :: (PersistBackend m, PersistEntity v) => m [(Key v, v)]
-defaultSelectAll = do
-    res <- run $ Iteratee (runIteratee consume >>= runIteratee . selectAllEnum)
-    case res of
-        Left e -> error $ show e
-        Right x -> return x
+bracket :: MonadBaseControl IO m
+        => m a        -- ^ computation to run first ("acquire resource")
+        -> (a -> m b) -- ^ computation to run last ("release resource")
+        -> (a -> m c) -- ^ computation to run in-between
+        -> m c
+bracket before after thing = control $ \runInIO ->
+                     E.bracket (runInIO before) (\st -> runInIO $ restoreM st >>= after) (\st -> runInIO $ restoreM st >>= thing)
+
+onException :: MonadBaseControl IO m
+        => m a
+        -> m b
+        -> m a
+onException io what = control $ \runInIO -> E.onException (runInIO io) (runInIO what)
+
+data PSEmbeddedFieldDef = PSEmbeddedFieldDef {
+    psEmbeddedFieldName :: String -- bar
+  , psDbEmbeddedFieldName :: Maybe String -- SQLbar
+  , psSubEmbedded :: Maybe [PSEmbeddedFieldDef]
+} deriving Show
+
+applyEmbeddedDbTypeSettings :: [PSEmbeddedFieldDef] -> DbType -> DbType
+applyEmbeddedDbTypeSettings settings typ = (case typ of
+  DbEmbedded emb                 -> DbEmbedded $ applyToDef emb
+  DbEntity (Just (emb, uniq)) e -> DbEntity (Just (applyToDef emb, uniq)) e
+  t -> error $ "applyEmbeddedDbTypeSettings: expected DbEmbedded, got " ++ show t) where
+  applyToDef (EmbeddedDef _ fields) = EmbeddedDef True $ go settings fields
+  go [] fs = fs
+  go st [] = error $ "applyEmbeddedDbTypeSettings: embedded datatype does not have following fields: " ++ show st
+  go st (f@(fName, fType):fs) = case find fName st of
+    Just (rest, PSEmbeddedFieldDef _ dbName subs) -> (fromMaybe fName dbName, maybe id applyEmbeddedDbTypeSettings subs fType):go rest fs
+    Nothing -> f:go st fs
+  find :: String -> [PSEmbeddedFieldDef] -> Maybe ([PSEmbeddedFieldDef], PSEmbeddedFieldDef)
+  find _ [] = Nothing
+  find name (def:defs) | psEmbeddedFieldName def == name = Just (defs, def)
+                       | otherwise = fmap (\(defs', result) -> (def:defs', result)) $ find name defs
+
+primToPersistValue :: (PersistBackend m, PrimitivePersistField a) => a -> m ([PersistValue] -> [PersistValue])
+primToPersistValue a = phantomDb >>= \p -> return (toPrimitivePersistValue p a:)
+
+primFromPersistValue :: (PersistBackend m, PrimitivePersistField a) => [PersistValue] -> m (a, [PersistValue])
+primFromPersistValue (x:xs) = phantomDb >>= \p -> return (fromPrimitivePersistValue p x, xs)
+primFromPersistValue xs = (\a -> fail (failMessage a xs) >> return (a, xs)) undefined
+
+pureToPersistValue :: (PersistBackend m, PurePersistField a) => a -> m ([PersistValue] -> [PersistValue])
+pureToPersistValue a = phantomDb >>= \p -> return (toPurePersistValues p a)
+
+pureFromPersistValue :: (PersistBackend m, PurePersistField a) => [PersistValue] -> m (a, [PersistValue])
+pureFromPersistValue xs = phantomDb >>= \p -> return (fromPurePersistValues p xs)
+
+singleToPersistValue :: (PersistBackend m, SinglePersistField a) => a -> m ([PersistValue] -> [PersistValue])
+singleToPersistValue a = toSinglePersistValue a >>= \x -> return (x:)
+
+singleFromPersistValue :: (PersistBackend m, SinglePersistField a) => [PersistValue] -> m (a, [PersistValue])
+singleFromPersistValue (x:xs) = fromSinglePersistValue x >>= \a -> return (a, xs)
+singleFromPersistValue xs = (\a -> fail (failMessage a xs) >> return (a, xs)) undefined
+
+toSinglePersistValueUnique :: forall m v u . (PersistBackend m, PersistEntity v, IsUniqueKey (Key v (Unique u)), PrimitivePersistField (Key v (Unique u)))
+                           => u (UniqueMarker v) -> v -> m PersistValue
+toSinglePersistValueUnique u v = insertBy u v >> toSinglePersistValue (extractUnique v :: Key v (Unique u))
+
+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
+
+toPersistValuesUnique :: forall m v u . (PersistBackend m, PersistEntity v, IsUniqueKey (Key v (Unique u)))
+                      => u (UniqueMarker v) -> v -> m ([PersistValue] -> [PersistValue])
+toPersistValuesUnique u v = insertBy u v >> toPersistValues (extractUnique v :: Key v (Unique u))
+
+fromPersistValuesUnique :: forall m v u . (PersistBackend m, PersistEntity v, IsUniqueKey (Key v (Unique u)))
+                        => u (UniqueMarker v) -> [PersistValue] -> m (v, [PersistValue])
+fromPersistValuesUnique _ xs = fromPersistValues xs >>= \(k, xs') -> getBy (k :: Key v (Unique u)) >>= maybe (fail $ "No data with id " ++ show xs) (\v -> return (v, xs'))
+
+toSinglePersistValueAutoKey :: forall m v . (PersistBackend m, PersistEntity v, PrimitivePersistField (AutoKey v))
+                            => v -> m PersistValue
+toSinglePersistValueAutoKey a = insertByAll a >>= toSinglePersistValue . either id id
+
+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
+
+replaceOne :: (Eq c, Show c) => String -> (a -> c) -> (b -> c) -> (a -> b -> b) -> a -> [b] -> [b]
+replaceOne what getter1 getter2 apply a bs = case length (filter ((getter1 a ==) . getter2) bs) of
+  1 -> map (\b -> if getter1 a == getter2 b then apply a b else b) bs
+  0 -> error $ "Not found " ++ what ++ " with name " ++ show (getter1 a)
+  _ -> error $ "Found more than one " ++ what ++ " with name " ++ show (getter1 a)
+
+findOne :: (Eq c, Show c) => String -> (a -> c) -> (b -> c) -> a -> [b] -> b
+findOne what getter1 getter2 a bs = case filter ((getter1 a ==) . getter2) bs of
+  [b] -> b
+  []  -> error $ "Not found " ++ what ++ " with name " ++ show (getter1 a)
+  _   -> error $ "Found more than one " ++ what ++ " with name " ++ show (getter1 a)
+
+-- | Returns only old elements, only new elements, and matched pairs (old, new).
+-- The new ones exist only in datatype, the old are present only in DB, match is typically by name (the properties of the matched elements may differ).
+matchElements :: Show a => (a -> b -> Bool) -> [a] -> [b] -> ([a], [b], [(a, b)])
+matchElements eq oldElems newElems = foldr f (oldElems, [], []) newElems where
+  f new (olds, news, matches) = case partition (`eq` new) olds of
+    ([], rest) -> (rest, new:news, matches)
+    ([old], rest) -> (rest, news, (old, new):matches)
+    (xs, _) -> error $ "matchElements: more than one element matched " ++ show xs
+
+haveSameElems :: Show a => (a -> b -> Bool) -> [a] -> [b] -> Bool
+haveSameElems p xs ys = case matchElements p xs ys of
+  ([], [], _) -> 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 = return $ error "phantomDb"
+
+isSimple :: [ConstructorDef] -> Bool
+isSimple [_] = True
+isSimple _   = False
diff --git a/Database/Groundhog/Generic/Migration.hs b/Database/Groundhog/Generic/Migration.hs
new file mode 100644
--- /dev/null
+++ b/Database/Groundhog/Generic/Migration.hs
@@ -0,0 +1,318 @@
+{-# LANGUAGE RecordWildCards #-}
+-- | This helper module is intended for use by the backend creators
+module Database.Groundhog.Generic.Migration
+  ( Column(..)
+  , UniqueDef'(..)
+  , Reference
+  , TableInfo(..)
+  , AlterColumn(..)
+  , AlterColumn'
+  , AlterTable(..)
+  , AlterDB(..)
+  , MigrationPack(..)
+  , mkColumns
+  , migrateRecursively
+  , migrateEntity
+  , migrateList
+  , getAlters
+  , defaultMigConstr
+  ) where
+
+import Database.Groundhog.Core
+import Database.Groundhog.Generic
+
+import Control.Arrow ((***), (&&&))
+import Control.Monad (liftM)
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.State (StateT (..), gets, modify)
+import qualified Data.Map as Map
+import Data.List (group, intercalate)
+import Data.Maybe (fromJust, fromMaybe, mapMaybe, maybeToList)
+
+-- Describes a database column. Field cType always contains DbType that maps to one column (no DbEmbedded)
+data Column typ = Column
+    { colName :: String
+    , colNull :: Bool
+    , colType :: typ
+    , colDefault :: Maybe String
+    } deriving (Eq, Show)
+
+-- | Foreign table name and names of the corresponding columns
+type Reference = (String, [(String, String)])
+
+data TableInfo typ = TableInfo {
+    tablePrimaryKeyName :: Maybe String
+  , tableColumns :: [Column typ]
+  , tableUniques :: [UniqueDef']
+    -- | constraint name and reference
+  , tableReferences :: [(Maybe String, Reference)]
+} deriving Show
+
+data AlterColumn = Type DbType | IsNull | NotNull | Add (Column DbType) | Drop | AddPrimaryKey
+                 | Default String | NoDefault | UpdateValue String deriving Show
+
+type AlterColumn' = (String, AlterColumn)
+
+data AlterTable = AddUniqueConstraint String [String]
+                | DropConstraint String
+                | AddReference Reference
+                | DropReference String
+                | AlterColumn AlterColumn' deriving Show
+
+data AlterDB typ = AddTable String
+                 -- | Table name, create statement, structure of table from DB, structure of table from datatype, alters
+                 | AlterTable String String (TableInfo typ) (TableInfo DbType) [AlterTable]
+                 -- | Trigger name, table name
+                 | DropTrigger String String
+                 -- | Trigger name, table name, body
+                 | AddTriggerOnDelete String String String
+                 -- | Trigger name, table name, field name, body
+                 | AddTriggerOnUpdate String String String String
+                 | CreateOrReplaceFunction String
+                 | DropFunction String
+  deriving Show
+
+data UniqueDef' = UniqueDef' String [String] deriving Show
+
+data MigrationPack m typ = MigrationPack {
+    compareColumns :: Column typ -> Column DbType -> Bool
+  , compareRefs :: (Maybe String, Reference) -> (Maybe String, Reference) -> Bool
+  , compareUniqs :: UniqueDef' -> UniqueDef' -> Bool
+  , checkTable :: String -> m (Maybe (Either [String] (TableInfo typ)))
+  , migTriggerOnDelete :: String -> [(String, String)] -> m (Bool, [AlterDB typ])
+  , migTriggerOnUpdate :: String -> String -> String -> m (Bool, [AlterDB typ])
+  , migConstr :: MigrationPack m typ -> Bool -> String -> ConstructorDef -> m (Bool, SingleMigration)
+  , escape :: String -> String
+  , primaryKeyType :: String
+  , foreignKeyType :: String
+  , mainTableId :: String
+  , defaultPriority :: Int
+  , convertType :: DbType -> typ
+  -- | Sql pieces for the create table statement that add constraints and alterations for running after the table is created
+  , addUniquesReferences :: [UniqueDef'] -> [Reference] -> ([String], [AlterTable])
+  , showColumn :: Column DbType -> String
+  , showAlterDb :: AlterDB typ -> SingleMigration
+}
+
+mkColumns :: (DbType -> typ) -> String -> DbType -> ([Column typ], [Reference])
+mkColumns mkType columnName dbtype = go "" (columnName, dbtype) where
+  go prefix (fname, typ) = (case typ of
+    DbEmbedded (EmbeddedDef False ts) -> concatMap' (go $ prefix ++ fname ++ [delim]) ts
+    DbEmbedded (EmbeddedDef True  ts) -> concatMap' (go "") ts
+    DbMaybe a      -> case go prefix (fname, a) of
+      ([c], refs) -> ([c {colNull = True}], refs)
+      _ -> error $ "mkColumns: datatype inside DbMaybe must be one column " ++ show a
+    DbEntity (Just (emb, uName)) e  -> (cols, ref:refs) where
+      (cols, refs) = go prefix (fname, DbEmbedded emb)
+      ref = (entityName e, zipWith' (curry $ colName *** colName) cols foreignColumns)
+      cDef = case constructors e of
+        [cDef'] -> cDef'
+        _       -> error "mkColumns: datatype with unique key cannot have more than one constructor"
+      UniqueDef _ uFields = findOne "unique" id uniqueName uName $ constrUniques cDef
+      fields = map (\(fName, _) -> findOne "field" id fst fName $ constrParams cDef) uFields
+      (foreignColumns, _) = concatMap' (go "") fields
+    t@(DbEntity Nothing e) -> ([Column name False (mkType t) Nothing], refs) where
+      refs = [(entityName e, [(name, keyName)])]
+      keyName = case constructors e of
+        [cDef] -> fromMaybe (error "mkColumns: autokey name is Nothing") $ constrAutoKeyName cDef
+        _      -> "id"
+    t@(DbList lName _) -> ([Column name False (mkType t) Nothing], refs) where
+      refs = [(lName, [(name, "id")])]
+    t -> ([Column name False (mkType t) Nothing], [])) where
+      name = prefix ++ fname
+      concatMap' f xs = concat *** concat $ unzip $ map f xs
+      zipWith' _ [] [] = []
+      zipWith' f (x:xs) (y:ys) = f x y: zipWith' f xs ys
+      zipWith' _ _ _ = error "mkColumns: the lists have different length"
+
+-- | Create migration for a given entity and all entities it depends on.
+-- The stateful Map is used to avoid duplicate migrations when an entity type
+-- occurs several times in a datatype
+migrateRecursively :: (Monad m, PersistEntity v) => 
+     (EntityDef -> m SingleMigration) -- ^ migrate entity
+  -> (DbType    -> m SingleMigration) -- ^ migrate list
+  -> v                                -- ^ initial entity
+  -> StateT NamedMigrations m ()
+migrateRecursively migE migL = go . dbType where
+  go l@(DbList lName t) = f lName (migL l) (go t)
+  go (DbEntity _ e)     = f (entityName e) (migE e) (mapM_ go (allSubtypes e))
+  go (DbMaybe t)        = go t
+  go (DbEmbedded (EmbeddedDef _ ts))  = mapM_ (go . snd) ts
+  go _                  = return ()    -- ordinary types need not migration
+  f name mig cont = do
+    v <- gets (Map.lookup name)
+    case v of
+      Nothing -> lift mig >>= modify . Map.insert name >> cont
+      _ -> return ()
+  allSubtypes = map snd . concatMap constrParams . constructors
+
+migrateEntity :: (Monad m, Show typ) => MigrationPack m typ -> EntityDef -> m SingleMigration
+migrateEntity m@MigrationPack{..} e = do
+  let name = entityName e
+  let constrs = constructors e
+  let mainTableQuery = "CREATE TABLE " ++ escape name ++ " (" ++ mainTableId ++ " " ++ primaryKeyType ++ ", discr INTEGER NOT NULL)"
+  let mainTableColumns = [Column "discr" False DbInt32 Nothing]
+
+  if isSimple constrs
+    then do
+      x <- checkTable name
+      -- check whether the table was created for multiple constructors before
+      case x of
+        Just (Right old) | haveSameElems compareColumns (tableColumns old) mainTableColumns -> do
+          return $ Left ["Datatype with multiple constructors was truncated to one constructor. Manual migration required. Datatype: " ++ name]
+        Just (Left errs) -> return (Left errs)
+        _ -> liftM snd $ migConstr m True name $ head constrs
+    else do
+      maincolumns <- checkTable name
+      let constrTable c = name ++ [delim] ++ constrName c
+      res <- mapM (\c -> migConstr m False name c) constrs
+      case maincolumns of
+        Nothing -> do
+          -- no constructor tables can exist if there is no main data table
+          let orphans = filter (fst . fst) $ zip res constrs
+          return $ if null orphans
+            then mergeMigrations $ Right [(False, defaultPriority, mainTableQuery)]:map snd res
+            else Left $ map (\(_, c) -> "Orphan constructor table found: " ++ constrTable c) orphans
+        Just (Right (TableInfo (Just _) columns [] [])) -> do
+          if haveSameElems compareColumns columns mainTableColumns
+            then do
+              -- the datatype had also many constructors before
+              -- check whether any new constructors appeared and increment older discriminators, which were shifted by newer constructors inserted not in the end
+              let updateDiscriminators = Right . go 0 . map (head &&& length) . group . map fst $ res where
+                  go acc ((False, n):(True, n2):xs) = (False, defaultPriority, "UPDATE " ++ escape name ++ " SET discr = discr + " ++ show n ++ " WHERE discr >= " ++ show acc) : go (acc + n + n2) xs
+                  go acc ((True, n):xs) = go (acc + n) xs
+                  go _ _ = []
+              return $ mergeMigrations $ updateDiscriminators: (map snd res)
+            else do
+              return $ Left ["Migration from one constructor to many will be implemented soon. Datatype: " ++ name]
+        Just (Right structure) -> do
+          return $ Left ["Unexpected structure of main table for Datatype: " ++ name ++ ". Table info: " ++ show structure]
+        Just (Left errs) -> return (Left errs)
+
+migrateList :: (Monad m, Show typ) => MigrationPack m typ -> DbType -> m SingleMigration
+migrateList m@MigrationPack{..} (DbList mainName t) = do
+  let valuesName = mainName ++ delim : "values"
+  let (valueCols, valueRefs) = mkColumns id "value" t
+  let mainQuery = "CREATE TABLE " ++ escape mainName ++ " (id " ++ primaryKeyType ++ ")"
+  let (addInCreate, addInAlters) = addUniquesReferences [] valueRefs
+  let items = ("id " ++ foreignKeyType ++ " NOT NULL REFERENCES " ++ escape mainName ++ " ON DELETE CASCADE"):"ord INTEGER NOT NULL" : map showColumn valueCols ++ addInCreate
+  let valuesQuery = "CREATE TABLE " ++ escape valuesName ++ " (" ++ intercalate ", " items ++ ")"
+  let expectedMainStructure = TableInfo (Just "id") [] [] []
+  let valueColumns = Column "id" False DbInt64 Nothing : Column "ord" False DbInt32 Nothing : valueCols
+  let expectedValuesStructure = TableInfo Nothing valueColumns [] (map (\x -> (Nothing, x)) $ (mainName, [("id", "id")]) : valueRefs)
+  mainStructure <- checkTable mainName
+  valuesStructure <- checkTable valuesName
+  let triggerMain = []
+  (_, triggerValues) <- migTriggerOnDelete valuesName $ mkDeletes m valueCols
+  return $ case (mainStructure, valuesStructure) of
+    (Nothing, Nothing) -> let
+      oldValuesStructure = expectedValuesStructure {tableColumns = map (\c -> c {colType = convertType (colType c)}) valueColumns}
+      rest = [AlterTable valuesName valuesQuery oldValuesStructure expectedValuesStructure addInAlters]
+      in mergeMigrations $ map showAlterDb $ [AddTable mainQuery, AddTable valuesQuery] ++ rest ++ triggerMain ++ triggerValues
+    (Just (Right mainStructure'), Just (Right valuesStructure')) -> let
+      f name a@(TableInfo id1 cols1 uniqs1 refs1) b@(TableInfo id2 cols2 uniqs2 refs2) = if id1 == id2 && haveSameElems compareColumns cols1 cols2 && haveSameElems compareUniqs uniqs1 uniqs2 && haveSameElems compareRefs refs1 refs2
+        then []
+        else ["List table " ++ name ++ " error. Expected: " ++ show b ++ ". Found: " ++ show a]
+      errors = f mainName mainStructure' expectedMainStructure ++ f valuesName valuesStructure' expectedValuesStructure
+      in if null errors then Right [] else Left errors
+    (Just (Left errs1), Just (Left errs2)) -> Left $ errs1 ++ errs2
+    (Just (Left errs), Just _) -> Left errs
+    (Just _, Just (Left errs)) -> Left errs
+    (_, Nothing) -> Left ["Found orphan main list table " ++ mainName]
+    (Nothing, _) -> Left ["Found orphan list values table " ++ valuesName]
+migrateList _ t = fail $ "migrateList: expected DbList, got " ++ show t
+
+-- from database, from datatype
+getAlters :: (Eq typ, Show typ) =>
+             MigrationPack m typ
+          -> TableInfo typ
+          -> TableInfo DbType
+          -> [AlterTable]
+getAlters m@MigrationPack{..} (TableInfo oldId oldColumns oldUniques oldRefs) (TableInfo newId newColumns newUniques newRefs) = map AlterColumn colAlters ++ tableAlters
+  where
+    (oldOnlyColumns, newOnlyColumns, commonColumns) = matchElements compareColumns oldColumns newColumns
+    (oldOnlyUniques, newOnlyUniques, commonUniques) = matchElements compareUniqs oldUniques newUniques
+    primaryKeyAlters = case (oldId, newId) of
+      (Nothing, Just newName) -> [(newName, AddPrimaryKey)]
+      (Just oldName, Nothing) -> [(oldName, Drop)]
+      (Just oldName, Just newName) | oldName /= newName -> error $ "getAlters: cannot rename primary key (old " ++ oldName ++ ", new " ++ newName ++ ")"
+      _ -> []
+    (oldOnlyRefs, newOnlyRefs, _) = matchElements compareRefs oldRefs newRefs
+
+    colAlters = map (\x -> (colName x, Drop)) oldOnlyColumns ++ map (\x -> (colName x, Add x)) newOnlyColumns ++ concatMap (migrateColumn m) commonColumns ++ primaryKeyAlters
+    tableAlters = 
+         map (\(UniqueDef' name _) -> DropConstraint name) oldOnlyUniques
+      ++ map (\(UniqueDef' name cols) -> AddUniqueConstraint name cols) newOnlyUniques
+      ++ concatMap migrateUniq commonUniques
+      ++ map (DropReference . fromMaybe (error "getAlters: old reference does not have name") . fst) oldOnlyRefs
+      ++ map (AddReference . snd) newOnlyRefs
+
+-- from database, from datatype
+migrateColumn :: Eq typ => MigrationPack m typ -> (Column typ, Column DbType) -> [AlterColumn']
+migrateColumn MigrationPack{..} (Column name1 isNull1 type1 def1, Column _ isNull2 type2 def2) = modDef ++ modNull ++ modType where
+  modNull = case (isNull1, isNull2) of
+    (False, True) -> [(name1, IsNull)]
+    (True, False) -> case def2 of
+      Nothing -> [(name1, NotNull)]
+      Just s -> [(name1, UpdateValue s), (name1, NotNull)]
+    _ -> []
+  modType = if type1 == convertType type2 then [] else [(name1, Type type2)]
+  modDef = if def1 == def2
+    then []
+    else [(name1, maybe NoDefault Default def2)]
+
+-- from database, from datatype
+migrateUniq :: (UniqueDef', UniqueDef') -> [AlterTable]
+migrateUniq (UniqueDef' name1 cols1, UniqueDef' name2 cols2) = if haveSameElems (==) cols1 cols2
+  then []
+  else [DropConstraint name1, AddUniqueConstraint name2 cols2]
+  
+defaultMigConstr :: (Monad m, Eq typ, Show typ) => MigrationPack m typ -> Bool -> String -> ConstructorDef -> m (Bool, SingleMigration)
+defaultMigConstr migPack@MigrationPack{..} simple name constr = do
+  let cName = if simple then name else name ++ [delim] ++ constrName constr
+  let mkColumns' xs = concat *** concat $ unzip $ map (uncurry $ mkColumns id) xs
+  let (columns, refs) = mkColumns' $ constrParams constr
+  tableStructure <- checkTable cName
+  let dels = mkDeletes migPack columns
+  (triggerExisted, delTrigger) <- migTriggerOnDelete cName dels
+  updTriggers <- liftM concat $ mapM (liftM snd . uncurry (migTriggerOnUpdate cName)) dels
+  
+  let mainTableName = if simple then Nothing else Just name
+      refs' = maybeToList (fmap (\x -> (x, [(fromJust $ constrAutoKeyName constr, mainTableId)])) mainTableName) ++ refs
+
+      mainRef = maybe "" (\x -> " REFERENCES " ++ escape x ++ " ON DELETE CASCADE ") mainTableName
+      autoKey = fmap (\x -> escape x ++ " " ++ primaryKeyType ++ mainRef) $ constrAutoKeyName constr
+
+      uniques = map (\(UniqueDef uName cols) -> UniqueDef' uName (map colName $ fst $ mkColumns' cols)) $ constrUniques constr
+      (addInCreate, addInAlters) = addUniquesReferences uniques refs
+      -- refs instead of refs' because the reference to the main table id is hardcoded in mainRef
+      items = maybeToList autoKey ++ map showColumn columns ++ addInCreate
+      addTable = "CREATE TABLE " ++ escape cName ++ " (" ++ intercalate ", " items ++ ")"
+
+      expectedTableStructure = TableInfo (constrAutoKeyName constr) columns uniques (map (\r -> (Nothing, r)) refs')
+      (migErrs, constrExisted, mig) = case tableStructure of
+        Nothing  -> let
+          oldTableStructure = expectedTableStructure {tableColumns = map (\c -> c {colType = convertType (colType c)}) columns}
+          rest = AlterTable cName addTable oldTableStructure expectedTableStructure addInAlters
+          in ([], False, [AddTable addTable, rest])
+        Just (Right oldTableStructure) -> let
+          alters = getAlters migPack oldTableStructure expectedTableStructure
+          in ([], True, [AlterTable cName addTable oldTableStructure expectedTableStructure alters])
+        Just (Left x) -> (x, True, [])
+      -- this can happen when an ephemeral field was added. Consider doing something else except throwing an error
+      errs = if constrExisted == triggerExisted || (constrExisted && null dels)
+        then migErrs
+        else ["Both trigger and constructor table must exist: " ++ cName] ++ migErrs
+  return $ (constrExisted, if null errs
+    then mergeMigrations $ map showAlterDb $ mig ++ delTrigger ++ updTriggers
+    else Left errs)
+
+-- on delete removes all ephemeral data
+-- returns column name and delete statement for the referenced table
+mkDeletes :: MigrationPack m typ -> [Column DbType] -> [(String, String)]
+mkDeletes MigrationPack{..} columns = mapMaybe delField columns where
+  delField (Column name _ t _) = fmap delStatement $ ephemeralName t where
+    delStatement ref = (name, "DELETE FROM " ++ escape ref ++ " WHERE id=old." ++ escape name ++ ";")
+  ephemeralName (DbMaybe x) = ephemeralName x
+  ephemeralName (DbList name _) = Just name
+  ephemeralName _ = Nothing
diff --git a/Database/Groundhog/Generic/PersistBackendHelpers.hs b/Database/Groundhog/Generic/PersistBackendHelpers.hs
new file mode 100644
--- /dev/null
+++ b/Database/Groundhog/Generic/PersistBackendHelpers.hs
@@ -0,0 +1,333 @@
+{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, OverloadedStrings, RecordWildCards, Rank2Types #-}
+
+-- | This helper module contains generic versions of PersistBackend functions
+module Database.Groundhog.Generic.PersistBackendHelpers
+  ( 
+    get
+  , select
+  , selectAll
+  , getBy
+  , project
+  , count
+  , replace
+  , update
+  , delete
+  , insertByAll
+  , deleteByKey
+  , countAll
+  , insertBy
+  ) where
+
+import Database.Groundhog.Core hiding (PersistBackend(..))
+import Database.Groundhog.Core (PersistBackend, PhantomDb)
+import qualified Database.Groundhog.Core as Core
+import Database.Groundhog.Generic
+import Database.Groundhog.Generic.Sql
+
+import Control.Monad (liftM, forM, (>=>))
+import Data.Maybe (fromJust)
+import Data.Monoid
+
+{-# INLINABLE get #-}
+get :: forall m s v . (PersistBackend m, StringLike s, PersistEntity v, PrimitivePersistField (Key v BackendSpecific))
+    => (s -> s) -> (forall a . s -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> Key v BackendSpecific -> m (Maybe v)
+get escape queryFunc (k :: Key v BackendSpecific) = do
+  let e = entityDef (undefined :: v)
+  let proxy = undefined :: Proxy (PhantomDb m)
+  let name = persistName (undefined :: v)
+  if isSimple (constructors e)
+    then do
+      let constr = head $ constructors e
+      let fields = renderFields escape (constrParams constr)
+      let query = "SELECT " <> fields <> " FROM " <> escape (fromString name) <> " WHERE " <> fromJust (constrId escape constr) <> "=?"
+      let types = getConstructorTypes constr
+      x <- queryFunc query types [toPrimitivePersistValue proxy k] id
+      case x of
+        Just xs -> liftM (Just . fst) $ fromEntityPersistValues $ PersistInt64 0:xs
+        Nothing -> return Nothing
+    else do
+      let query = "SELECT discr FROM " <> escape (fromString name) <> " WHERE id=?"
+      x <- queryFunc query [DbInt32] [toPrimitivePersistValue proxy k] id
+      case x of
+        Just [discr] -> do
+          let constructorNum = fromPrimitivePersistValue proxy discr
+          let constr = constructors e !! constructorNum
+          let cName = fromString $ name ++ [delim] ++ constrName constr
+          let fields = renderFields escape (constrParams constr)
+          let cQuery = "SELECT " <> fields <> " FROM " <> escape cName <> " WHERE " <> fromJust (constrId escape constr) <> "=?"
+          x2 <- queryFunc cQuery (getConstructorTypes constr) [toPrimitivePersistValue proxy k] id
+          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 s v c opts . (PersistBackend m, StringLike s, PersistEntity v, Constructor c, HasSelectOptions opts v c)
+       => (s -> s) -> (forall a . s -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> s -> (Cond v c -> Maybe (RenderS s)) -> opts -> m [v]
+select escape queryFunc noLimit renderCond' options = start where
+  SelectOptions cond limit offset ords = getSelectOptions options
+  start = if isSimple (constructors e)
+    then doSelectQuery (mkQuery name) (0 :: Int)
+    else let
+      cName = name ++ [delim] ++ constrName constr
+      in doSelectQuery (mkQuery cName) $ constrNum constr
+
+  e = entityDef (undefined :: v)
+  proxy = undefined :: Proxy (PhantomDb m)
+  orders = renderOrders escape ords
+  name = persistName (undefined :: v)
+  (lim, limps) = case (limit, offset) of
+        (Nothing, Nothing) -> ("", [])
+        (Nothing, o) -> (" " <> noLimit <> " OFFSET ?", [toPrimitivePersistValue proxy o])
+        (l, Nothing) -> (" LIMIT ?", [toPrimitivePersistValue proxy l])
+        (l, o) -> (" LIMIT ? OFFSET ?", [toPrimitivePersistValue proxy l, toPrimitivePersistValue proxy o])
+  cond' = renderCond' cond
+  fields = renderFields escape (constrParams constr)
+  mkQuery tname = "SELECT " <> fields <> " FROM " <> escape (fromString tname) <> whereClause <> orders <> lim
+  whereClause = maybe "" (\c -> " WHERE " <> getQuery c) cond'
+  doSelectQuery query cNum = queryFunc query types binds $ mapAllRows $ liftM fst . fromEntityPersistValues . (toPrimitivePersistValue proxy cNum:)
+  binds = maybe id getValues cond' $ limps
+  constr = constructors e !! phantomConstrNum (undefined :: c a)
+  types = getConstructorTypes constr
+
+selectAll :: forall m s v . (PersistBackend m, StringLike s, PersistEntity v)
+          => (s -> s) -> (forall a . s -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> m [(AutoKey v, v)]
+selectAll escape queryFunc = start where
+  start = if isSimple (constructors e)
+    then let
+      constr = head $ constructors e
+      fields = maybe id (\key cont -> key <> fromChar ',' <> cont) (constrId escape constr) $ renderFields escape (constrParams constr)
+      query = "SELECT " <> fields <> " FROM " <> escape (fromString name)
+      types = maybe id (const $ (DbInt64:)) (constrId escape constr) $ getConstructorTypes constr
+      in queryFunc query types [] $ mapAllRows $ mkEntity proxy 0
+    else liftM concat $ forM (zip [0..] (constructors e)) $ \(cNum, constr) -> do
+        let fields = fromJust (constrId escape constr) <> fromChar ',' <> renderFields escape (constrParams constr)
+        let cName = fromString $ name ++ [delim] ++ constrName constr
+        let query = "SELECT " <> fields <> " FROM " <> escape cName
+        let types = DbInt64:getConstructorTypes constr
+        queryFunc query types [] $ mapAllRows $ mkEntity proxy cNum
+  e = entityDef (undefined :: v)
+  proxy = undefined :: Proxy (PhantomDb m)
+  name = persistName (undefined :: v)
+
+getBy :: forall m s v u . (PersistBackend m, StringLike s, PersistEntity v, IsUniqueKey (Key v (Unique u)))
+      => (s -> s) -> (forall a . s -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> Key v (Unique u) -> m (Maybe v)
+getBy escape queryFunc (k :: Key v (Unique u)) = do
+  let e = entityDef (undefined :: v)
+  let name = persistName (undefined :: v)
+  uniques <- toPersistValues k
+  let u = (undefined :: Key v (Unique u) -> u (UniqueMarker v)) k
+  let uFields = foldr (renderChain escape) [] $ projectionFieldChains u []
+  let cond = intercalateS " AND " $ map (<> "=?") uFields
+  let constr = head $ constructors e
+  let fields = renderFields escape (constrParams constr)
+  let query = "SELECT " <> fields <> " FROM " <> escape (fromString name) <> " WHERE " <> cond
+  x <- queryFunc query (getConstructorTypes constr) (uniques []) id
+  case x of
+    Just xs -> liftM (Just . fst) $ fromEntityPersistValues $ PersistInt64 0:xs
+    Nothing -> return Nothing
+
+project :: forall m s v c p opts a'. (PersistBackend m, StringLike s, PersistEntity v, Constructor c, Projection p (RestrictionHolder v c) a', HasSelectOptions opts v c)
+        => (s -> s) -> (forall a . s -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> s -> (Cond v c -> Maybe (RenderS s)) -> p -> opts -> m [a']
+project escape queryFunc noLimit renderCond' p options = start where
+  SelectOptions cond limit offset ords = getSelectOptions options
+  start = doSelectQuery $ if isSimple (constructors e)
+    then mkQuery name
+    else let
+      cName = name ++ [delim] ++ constrName constr
+      in mkQuery cName
+
+  e = entityDef (undefined :: v)
+  proxy = undefined :: Proxy (PhantomDb m)
+  orders = renderOrders escape ords
+  name = persistName (undefined :: v)
+  (lim, limps) = case (limit, offset) of
+        (Nothing, Nothing) -> ("", [])
+        (Nothing, o) -> (" " <> noLimit <> " OFFSET ?", [toPrimitivePersistValue proxy o])
+        (l, Nothing) -> (" LIMIT ?", [toPrimitivePersistValue proxy l])
+        (l, o) -> (" LIMIT ? OFFSET ?", [toPrimitivePersistValue proxy l, toPrimitivePersistValue proxy o])
+  cond' = renderCond' cond
+  chains = projectionFieldChains p []
+  fields = intercalateS (fromChar ',') $ foldr (renderChain escape) [] chains
+  mkQuery tname = "SELECT " <> fields <> " FROM " <> escape (fromString tname) <> whereClause <> orders <> lim
+  whereClause = maybe "" (\c -> " WHERE " <> getQuery c) cond'
+  doSelectQuery query = queryFunc query types binds $ mapAllRows $ liftM fst . projectionResult p
+  binds = maybe id getValues cond' $ limps
+  constr = constructors e !! phantomConstrNum (undefined :: c a)
+  types = foldr getDbTypes [] $ map (snd . fst) chains
+
+count :: forall m s v c . (PersistBackend m, StringLike s, PersistEntity v, Constructor c)
+      => (s -> s) -> (forall a . s -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> (Cond v c -> Maybe (RenderS s)) -> Cond v c -> m Int
+count escape queryFunc renderCond' (cond :: Cond v c) = do
+  let e = entityDef (undefined :: v)
+  let proxy = undefined :: Proxy (PhantomDb m)
+  let cond' = renderCond' cond
+  let name = persistName (undefined :: v)
+  let tname = fromString $ if isSimple (constructors e)
+       then name
+       else name ++ [delim] ++ phantomConstrName (undefined :: c a)
+  let query = "SELECT COUNT(*) FROM " <> escape tname <> whereClause where
+      whereClause = maybe "" (\c -> " WHERE " <> getQuery c) cond'
+  x <- queryFunc query [DbInt32] (maybe [] (flip getValues []) cond') id
+  case x of
+    Just [num] -> return $ fromPrimitivePersistValue proxy num
+    Just xs -> fail $ "requested 1 column, returned " ++ show (length xs)
+    Nothing -> fail $ "COUNT returned no rows"
+
+replace :: forall m s v . (PersistBackend m, StringLike s, PersistEntity v, PrimitivePersistField (Key v BackendSpecific))
+        => (s -> s) -> (forall a . s -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> (s -> [PersistValue] -> m ()) -> (Bool -> String -> ConstructorDef -> s)
+        -> Key v BackendSpecific -> v -> m ()
+replace escape queryFunc execFunc insertIntoConstructorTable k v = do
+  vals <- toEntityPersistValues' v
+  let e = entityDef v
+  let proxy = undefined :: Proxy (PhantomDb m)
+  let name = persistName v
+  let constructorNum = fromPrimitivePersistValue proxy (head vals)
+  let constr = constructors e !! constructorNum
+
+  let upds = renderFields (\f -> escape f <> "=?") $ constrParams constr
+  let mkQuery tname = "UPDATE " <> escape (fromString tname) <> " SET " <> upds <> " WHERE " <> fromString (fromJust $ constrAutoKeyName constr) <> "=?"
+
+  if isSimple (constructors e)
+    then execFunc (mkQuery name) (tail vals ++ [toPrimitivePersistValue proxy k])
+    else do
+      let query = "SELECT discr FROM " <> escape (fromString name) <> " WHERE id=?"
+      x <- queryFunc query [DbInt32] [toPrimitivePersistValue proxy k] (id >=> return . fmap (fromPrimitivePersistValue proxy . head))
+      case x of
+        Just discr -> do
+          let cName = name ++ [delim] ++ constrName constr
+
+          if discr == constructorNum
+            then execFunc (mkQuery cName) (tail vals ++ [toPrimitivePersistValue proxy k])
+            else do
+              let insQuery = insertIntoConstructorTable True cName constr
+              execFunc insQuery (toPrimitivePersistValue proxy k:tail vals)
+
+              let oldCName = fromString $ name ++ [delim] ++ constrName (constructors e !! discr)
+              let delQuery = "DELETE FROM " <> escape oldCName <> " WHERE " <> fromJust (constrId escape constr) <> "=?"
+              execFunc delQuery [toPrimitivePersistValue proxy k]
+
+              let updateDiscrQuery = "UPDATE " <> escape (fromString name) <> " SET discr=? WHERE id=?"
+              execFunc updateDiscrQuery [head vals, toPrimitivePersistValue proxy k]
+        Nothing -> return ()
+
+update :: forall m s v c . (PersistBackend m, StringLike s, PersistEntity v, Constructor c)
+       => (s -> s) -> (s -> [PersistValue] -> m ()) -> (Cond v c -> Maybe (RenderS s)) -> [Update v c] -> Cond v c -> m ()
+update escape execFunc renderCond' upds (cond :: Cond v c) = do
+  let e = entityDef (undefined :: v)
+  let proxy = undefined :: Proxy (PhantomDb m)
+  let name = persistName (undefined :: v)
+  case renderUpdates proxy escape upds of
+    Just upds' -> do
+      let cond' = renderCond' cond
+      let mkQuery tname = "UPDATE " <> escape tname <> " SET " <> whereClause where
+          whereClause = maybe (getQuery upds') (\c -> getQuery upds' <> " WHERE " <> getQuery c) cond'
+      let tname = fromString $ if isSimple (constructors e) then name else name ++ [delim] ++ phantomConstrName (undefined :: c a)
+      execFunc (mkQuery tname) (getValues upds' <> maybe mempty getValues cond' $ [])
+    Nothing -> return ()
+
+delete :: forall m s v c . (PersistBackend m, StringLike s, PersistEntity v, Constructor c)
+       => (s -> s) -> (s -> [PersistValue] -> m ()) -> (Cond v c -> Maybe (RenderS s)) -> Cond v c -> m ()
+delete escape execFunc renderCond' (cond :: Cond v c) = execFunc query (maybe [] (($ []) . getValues) cond') where
+  e = entityDef (undefined :: v)
+  constr = head $ constructors e
+  cond' = renderCond' cond
+  name = persistName (undefined :: v)
+  whereClause = maybe "" (\c -> " WHERE " <> getQuery c) cond'
+  query = if isSimple (constructors e)
+    then "DELETE FROM " <> escape (fromString name) <> whereClause
+    -- the entries in the constructor table are deleted because of the reference on delete cascade
+    else "DELETE FROM " <> escape (fromString name) <> " WHERE id IN(SELECT " <> fromJust (constrId escape constr) <> " FROM " <> escape cName <> whereClause <> ")" where
+      cName = fromString $ name ++ [delim] ++ phantomConstrName (undefined :: c a)
+
+insertByAll :: forall m s v . (PersistBackend m, StringLike s, PersistEntity v)
+            => (s -> s) -> (forall a . s -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a)
+            -> v -> m (Either (AutoKey v) (AutoKey v))
+insertByAll escape queryFunc v = do
+  let e = entityDef v
+  let proxy = undefined :: Proxy (PhantomDb m)
+  let name = persistName v
+
+  let (constructorNum, uniques) = getUniques proxy v
+  let uniqueDefs = constrUniques $ constructors e !! constructorNum
+  let cond = intercalateS " OR " $ map (intercalateS " AND " . map (\(fname, _) -> escape (fromString fname) <> "=?")) $ map (\(UniqueDef _ fields) -> fields) uniqueDefs
+
+  let ifAbsent tname constr = do
+      let query = "SELECT " <> maybe "1" id (constrId escape constr) <> " FROM " <> escape (fromString tname) <> " WHERE " <> cond
+      x <- queryFunc query [DbInt64] (concatMap snd uniques) id
+      case x of
+        Nothing  -> liftM Right $ Core.insert v
+        Just [k] -> return $ Left $ fst $ fromPurePersistValues proxy [k]
+        Just xs  -> fail $ "unexpected query result: " ++ show xs
+  if null uniques
+    then liftM Right $ Core.insert v
+    else if isSimple (constructors e)
+      then do
+        let constr = head $ constructors e
+        ifAbsent name constr
+      else do
+        let constr = constructors e !! constructorNum
+        let cName = name ++ [delim] ++ constrName constr
+        ifAbsent cName constr
+
+deleteByKey :: forall m s v . (PersistBackend m, StringLike s, PersistEntity v, PrimitivePersistField (Key v BackendSpecific))
+            => (s -> s) -> (s -> [PersistValue] -> m ()) -> Key v BackendSpecific -> m ()
+deleteByKey escape execFunc k = execFunc query [toPrimitivePersistValue proxy k] where
+  e = entityDef ((undefined :: Key v u -> v) k)
+  proxy = undefined :: Proxy (PhantomDb m)
+  constr = head $ constructors e
+  name = fromString (persistName $ (undefined :: Key v u -> v) k)
+  query = "DELETE FROM " <> escape name <> " WHERE " <> fromJust (constrId escape constr) <> "=?"
+
+countAll :: forall m s v . (PersistBackend m, StringLike s, PersistEntity v)
+         => (s -> s) -> (forall a . s -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> v -> m Int
+countAll escape queryFunc (_ :: v) = do
+  let proxy = undefined :: Proxy (PhantomDb m)
+  let name = persistName (undefined :: v)
+  let query = "SELECT COUNT(*) FROM " <> escape (fromString name)
+  x <- queryFunc query [DbInt64] [] id
+  case x of
+    Just [num] -> return $ fromPrimitivePersistValue proxy num
+    Just xs -> fail $ "requested 1 column, returned " ++ show (length xs)
+    Nothing -> fail $ "COUNT returned no rows"
+
+insertBy :: forall m s v u . (PersistBackend m, StringLike s, PersistEntity v, IsUniqueKey (Key v (Unique u)))
+         => (s -> s) -> (forall a . s -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a)
+         -> u (UniqueMarker v) -> v -> m (Either (AutoKey v) (AutoKey v))
+insertBy escape queryFunc u v = do
+  let e = entityDef v
+  let proxy = undefined :: Proxy (PhantomDb m)
+  let name = persistName v
+  uniques <- toPersistValues $ (extractUnique v `asTypeOf` ((undefined :: u (UniqueMarker v) -> Key v (Unique u)) u))
+  let fields = foldr (renderChain escape) [] $ projectionFieldChains u []
+  let cond = intercalateS " AND " $ map (<> "=?") fields
+  
+  let ifAbsent tname constr = do
+      let query = "SELECT " <> maybe "1" id (constrId escape constr) <> " FROM " <> escape (fromString tname) <> " WHERE " <> cond
+      x <- queryFunc query [DbInt64] (uniques []) id
+      case x of
+        Nothing  -> liftM Right $ Core.insert v
+        Just [k] -> return $ Left $ fst $ fromPurePersistValues proxy [k]
+        Just xs  -> fail $ "unexpected query result: " ++ show xs
+  let constr = head $ constructors e
+  ifAbsent name constr
+
+getConstructorTypes :: ConstructorDef -> [DbType]
+getConstructorTypes = foldr getDbTypes [] . map snd . constrParams where
+
+getDbTypes :: DbType -> [DbType] -> [DbType]
+getDbTypes typ acc = case typ of
+  DbEmbedded (EmbeddedDef _ ts) -> foldr (getDbTypes . snd) acc ts
+  DbEntity (Just (EmbeddedDef _ ts, _)) _ -> foldr (getDbTypes . snd) acc ts
+  t               -> t:acc
+
+constrId :: StringLike s => (s -> s) -> ConstructorDef -> Maybe s
+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' = liftM ($ []) . toEntityPersistValues
diff --git a/Database/Groundhog/Generic/Sql.hs b/Database/Groundhog/Generic/Sql.hs
--- a/Database/Groundhog/Generic/Sql.hs
+++ b/Database/Groundhog/Generic/Sql.hs
@@ -1,4 +1,5 @@
-{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, Rank2Types, GADTs #-}
+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, GADTs, OverloadedStrings, TypeSynonymInstances, FlexibleInstances, TypeFamilies #-}
+{-# LANGUAGE CPP #-}
 
 -- | This module defines the functions which are used only for backends creation.
 module Database.Groundhog.Generic.Sql
@@ -7,105 +8,186 @@
     , renderArith
     , renderOrders
     , renderUpdates
-    , defId
-    , defDelim
-    , defRenderEquals
-    , defRenderNotEquals
-    , renderExpr
-    , RenderS
+    , renderFields
+    , renderChain
+    , intercalateS
+    , RenderS(..)
+    , StringLike(..)
+    , fromString
     , (<>)
+    , parens
     ) where
 
 import Database.Groundhog.Core
+import Database.Groundhog.Instances ()
+import Data.List (foldl')
+import Data.Maybe (mapMaybe)
+import Data.Monoid
+import Data.String
 
-parens :: Int -> Int -> RenderS -> RenderS
+class (Monoid a, IsString a) => StringLike a where
+  fromChar :: Char -> a
+
+data RenderS s = RenderS {
+    getQuery  :: s
+  , getValues :: [PersistValue] -> [PersistValue]
+}
+
+instance Monoid s => Monoid (RenderS s) where
+  mempty = RenderS mempty id
+  (RenderS f1 g1) `mappend` (RenderS f2 g2) = RenderS (f1 `mappend` f2) (g1 . g2)
+
+-- Has bad performance. This instance exists only for testing purposes
+instance StringLike String where
+  fromChar c = [c]
+
+{-# INLINABLE parens #-}
+parens :: StringLike s => Int -> Int -> RenderS s -> RenderS s
 parens p1 p2 expr = if p1 < p2 then char '(' <> expr <> char ')' else expr
 
-(<>) :: RenderS -> RenderS -> RenderS
-(f1, g1) <> (f2, g2) = (f1.f2, g1.g2)
+#if !MIN_VERSION_base(4, 5, 0)
+{-# INLINABLE (<>) #-}
+(<>) :: Monoid m => m -> m -> m
+(<>) = mappend
+#endif
 
-string :: String -> RenderS
-string s = ((s++), id)
+string :: StringLike s => String -> RenderS s
+string s = RenderS (fromString s) id
 
-char :: Char -> RenderS
-char c = ((c:), id)
-  
-type RenderS = (ShowS, [PersistValue] -> [PersistValue])
+char :: StringLike s => Char -> RenderS s
+char c = RenderS (fromChar c) id
 
-renderArith :: PersistEntity v => (String -> String) -> Arith v c a -> RenderS
-renderArith escape arith = go arith 0 where
-  go :: PersistEntity v => Arith v c a -> Int -> RenderS
+{-# INLINABLE renderArith #-}
+renderArith :: (PersistEntity v, Constructor c, StringLike s, DbDescriptor db) => Proxy db -> (s -> s) -> Arith v c a -> RenderS s
+renderArith proxy escape arith = go arith 0 where
   go (Plus a b)     p = parens 6 p $ go a 6 <> char '+' <> go b 6
   go (Minus a b)    p = parens 6 p $ go a 6 <> char '-' <> go b 6
   go (Mult a b)     p = parens 7 p $ go a 7 <> char '*' <> go b 7
   go (Abs a)        p = parens 9 p $ string "ABS(" <> go a 0 <> char ')'
-  go (ArithField f) _ = string (escape (show f))
-  go (Lit a)        _ = (('?':), (toPrim a:))
+  go (ArithField f) _ = RenderS (head $ renderField escape f []) id
+  go (Lit a)        _ = RenderS (fromChar '?') (toPurePersistValues proxy a)
 
-renderCond :: PersistEntity v
-  => (String -> String) -- escape
-  -> String -- name of id in constructor table
-  -> (forall a.PersistField a => (String -> String) -> Expr v c a -> Expr v c a -> RenderS) -- render equals
-  -> (forall a.PersistField a => (String -> String) -> Expr v c a -> Expr v c a -> RenderS) -- render not equals
-  -> Cond v c -> RenderS
-renderCond esc idName rendEq rendNotEq (cond :: Cond v c) = go cond 0 where
-  go :: Cond v c -> Int -> RenderS
-  go (And a b)       p = parens 3 p $ go a 3 <> string " AND " <> go b 3
-  go (Or a b)        p = parens 2 p $ go a 2 <> string " OR " <> go b 2
-  go (Not a)         p = parens 1 p $ string "NOT " <> go a 1
-  -- the comparisons have the highest priority, so they never need parentheses
-  go (Lesser a b)    _ = renderExpr esc a <> char '<' <> renderExpr esc b
-  go (Greater a b)   _ = renderExpr esc a <> char '>' <> renderExpr esc b
-  go (Equals a b)    _ = rendEq esc a b
-  go (NotEquals a b) _ = rendNotEq esc a b
-  go (KeyIs k) _ = ((idName ++) . ("=?" ++), (toPrim k:))
+{-# INLINABLE renderCond #-}
+-- | Renders conditions for SQL backend. Returns Nothing if the fields don't have any columns.
+renderCond :: forall v c s db . (PersistEntity v, Constructor c, StringLike s, DbDescriptor db)
+  => Proxy db
+  -> (s -> s) -- escape
+  -> (s -> s -> s) -- render equals
+  -> (s -> s -> s) -- render not equals
+  -> Cond v c -> Maybe (RenderS s)
+renderCond proxy esc rendEq rendNotEq (cond :: Cond v c) = go cond 0 where
+  go (And a b)       p = perhaps 3 p " AND " a b
+  go (Or a b)        p = perhaps 2 p " OR " a b
+  go (Not a)         p = fmap (\a' -> parens 1 p $ string "NOT " <> a') $ go a 1
+  go (Compare op f1 f2) p = case op of
+    Eq -> renderComp 3 p " AND " rendEq f1 f2
+    Ne -> renderComp 2 p " OR " rendNotEq f1 f2
+    Gt -> renderComp 2 p " OR " (\a b -> a <> fromChar '>' <> b) f1 f2
+    Lt -> renderComp 2 p " OR " (\a b -> a <> fromChar '<' <> b) f1 f2
+    Ge -> renderComp 2 p " OR " (\a b -> a <> ">=" <> b) f1 f2
+    Le -> renderComp 2 p " OR " (\a b -> a <> "<=" <> b) f1 f2
 
+  renderComp :: Int -> Int -> s -> (s -> s -> s) -> Expr v c a -> Expr v c b -> Maybe (RenderS s)
+  renderComp p pOuter logicOp op expr1 expr2 = (case expr1 of
+    ExprField field -> (case expr2 of
+        ExprPure  a -> guard (map (\f -> f `op` fromChar '?') fs) (toPurePersistValues proxy a)
+        ExprField a -> guard (zipWith op fs $ renderField esc a []) id
+        ExprArith a -> case fs of
+          [f] -> let RenderS q v = renderArith proxy esc a in Just $ RenderS (f `op` q) v
+          _   -> error $ "renderComp: expected one column field, found " ++ show (length fs)) where
+        fs = renderField esc field []
+    ExprPure pure -> (case expr2 of
+      ExprPure  a -> guard (replicate (length fs) $ fromChar '?' `op` fromChar '?') (interleave fs $ toPurePersistValues proxy a [])
+      ExprField a -> guard (map (\f -> fromChar '?' `op` f) $ renderField esc a []) (toPurePersistValues proxy pure)
+      ExprArith a -> case fs of
+        [_] -> let RenderS q v = renderArith proxy esc a in Just $ RenderS (fromChar '?' `op` q) (toPurePersistValues proxy pure . v)
+        _   -> error $ "renderComp: expected one column field, found " ++ show (length fs)) where
+      fs = toPurePersistValues proxy pure []
+    ExprArith arith -> (case expr2 of
+      ExprPure  a -> Just $ RenderS (q `op` fromChar '?') (v . toPurePersistValues proxy a) -- TODO: check list size
+      ExprField a -> Just $ RenderS (q `op` head (renderField esc a [])) v -- TODO: check list size
+      ExprArith a -> let RenderS q2 v2 = renderArith proxy esc a in Just $ RenderS (q `op` q2) (v . v2)) where
+        RenderS q v = renderArith proxy esc arith
+      ) where
+        guard :: [s] -> ([PersistValue] -> [PersistValue]) -> Maybe (RenderS s)
+        guard clauses values = case clauses of
+          [] -> Nothing
+          [clause] -> Just $ RenderS clause values
+          clauses' -> Just $ parens p pOuter $ RenderS (intercalateS logicOp clauses') values
+        interleave [] [] acc = acc
+        interleave (x:xs) (y:ys) acc = x:y:interleave xs ys acc
+        interleave _ _ _ = error "renderComp: pure values lists must have the same size"
+  
+  perhaps :: Int -> Int -> s -> Cond v c -> Cond v c -> Maybe (RenderS s)
+  perhaps p pOuter op a b = result where
+    -- we don't know if the current operator is present until we render both operands. Rendering requires priority of the outer operator. We tie a knot to defer calculating the priority
+    (priority, result) = case (go a priority, go b priority) of
+       (Just a', Just b') -> (p, Just $ parens p pOuter $ a' <> RenderS op id <> b')
+       (Just a', Nothing) -> (pOuter, Just a')
+       (Nothing, Just b') -> (pOuter, Just b')
+       (Nothing, Nothing) -> (pOuter, Nothing)
+
+{-
 -- TODO: they don't support all cases
-defRenderEquals :: PersistField a => (String -> String) -> Expr v c a -> Expr v c a -> RenderS
+{-# INLINABLE defRenderEquals #-}
+defRenderEquals :: (PersistField a, StringLike s) => (String -> String) -> Expr v c a -> Expr v c a -> RenderS s
 defRenderEquals esc a b | not (isNullable a) = renderExpr esc a <> char '=' <> renderExpr esc b
 -- only ExprPrim and ExprField can come here here
 -- if one of arguments is Nothing, compare the other with NULL
-defRenderEquals _ (ExprPlain a) (ExprPlain b) | isNull a && isNull b = string "NULL IS NULL"
-defRenderEquals esc (ExprPlain a) b | isNull a = renderExpr esc b <> string " IS NULL"
+defRenderEquals _ (ExprPure a) (ExprPure b) | isNull a && isNull b = string "NULL IS NULL"
+defRenderEquals esc (ExprPure a) b | isNull a = renderExpr esc b <> string " IS NULL"
                                     | otherwise = renderPrim a <> char '=' <> renderExpr esc b
-defRenderEquals esc a (ExprPlain b) | isNull b = renderExpr esc a <> string " IS NULL"
+defRenderEquals esc a (ExprPure b) | isNull b = renderExpr esc a <> string " IS NULL"
                                     | otherwise = renderExpr esc a <> char '=' <> renderPrim b
 --  if both are fields we compare them to each other and to null
 defRenderEquals esc (ExprField a) (ExprField b) = char '(' <> a' <> char '=' <> b' <> string " OR " <> a' <> string " IS NULL AND " <> b' <> string " IS NULL)" where
   a' = string $ esc (show a)
   b' = string $ esc (show b)
-defRenderEquals _ _ _ = error "for nullable values there must be no other expressions than ExprField and ExprPlain"
+defRenderEquals _ _ _ = error "for nullable values there must be no other expressions than ExprField and ExprPure"
 
-defRenderNotEquals :: PersistField a => (String -> String) -> Expr v c a -> Expr v c a -> RenderS
+{-# INLINABLE defRenderNotEquals #-}
+defRenderNotEquals :: (PersistField a, StringLike s) => (String -> String) -> Expr v c a -> Expr v c a -> RenderS s
 defRenderNotEquals esc a b | not (isNullable a) = renderExpr esc a <> string "<>" <> renderExpr esc b
 -- if one of arguments is Nothing, compare the other with NULL
-defRenderNotEquals _ (ExprPlain a) (ExprPlain b) | isNull a && isNull b = string "NULL IS NOT NULL"
-defRenderNotEquals esc (ExprPlain a) b | isNull a  = renderExpr esc b <> string " IS NOT NULL"
+defRenderNotEquals _ (ExprPure a) (ExprPure b) | isNull a && isNull b = string "NULL IS NOT NULL"
+defRenderNotEquals esc (ExprPure a) b | isNull a  = renderExpr esc b <> string " IS NOT NULL"
                                        | otherwise = char '(' <> renderPrim a <> string "<>" <> renderExpr esc b <> string " OR " <> renderExpr esc b <> string " IS NULL)"
-defRenderNotEquals esc a (ExprPlain b) | isNull b = renderExpr esc a <> string " IS NOT NULL"
+defRenderNotEquals esc a (ExprPure b) | isNull b = renderExpr esc a <> string " IS NOT NULL"
                                        | otherwise = char '(' <> renderExpr esc a <> string "<>" <> renderPrim b <> string " OR " <> renderExpr esc a <> string " IS NULL)"
 defRenderNotEquals esc (ExprField a) (ExprField b) = a' <> string "<>" <> b' <> string " OR (" <> a' <> string " IS NULL AND " <> b' <> string " IS NOT NULL) OR (" <> a' <> string " IS NOT NULL AND " <> b' <> string " IS NULL)" where
   a' = string $ esc (show a)
   b' = string $ esc (show b)
-defRenderNotEquals _ _ _ = error "for nullable values there must be no other expressions than ExprField and ExprPlain"
+defRenderNotEquals _ _ _ = error "for nullable values there must be no other expressions than ExprField and ExprPure"
 
 isNull :: Primitive a => a -> Bool
 isNull a = toPrim a == PersistNull
 
-renderExpr :: (String -> String) -> Expr v c a -> RenderS
-renderExpr esc (ExprField a) = string $ esc (show a)
-renderExpr _   (ExprPrim a)  = (('?':), (toPrim a:))
-renderExpr _   (ExprPlain a)  = (('?':), (toPrim a:))
-renderExpr esc (ExprArith a) = renderArith esc a
-
-renderPrim :: Primitive a => a -> RenderS
-renderPrim a = (('?':), (toPrim a:))
-
 isNullable :: PersistField a => Expr v c a -> Bool
 isNullable (_ :: Expr v c a) = case dbType (undefined :: a) of
   DbMaybe _ -> True
   _         -> False
 
+-}
+
+renderField :: (PersistEntity v, Constructor c, FieldLike f (RestrictionHolder v c) a', StringLike s) => (s -> s) -> f -> [s] -> [s]
+renderField esc field acc = renderChain esc (fieldChain field) acc
+
+{-
+examples of prefixes
+[("val1", DbEmbedded False _), ("val4", EmbeddedDef False _), ("val5", EmbeddedDef False _)] -> "val5$val4$val1"
+[("val1", DbEmbedded True _),  ("val4", EmbeddedDef False _), ("val5", EmbeddedDef False _)] -> ""
+[("val1", DbEmbedded False _), ("val4", EmbeddedDef True _),  ("val5", EmbeddedDef False _)] -> "val1"
+[("val1", DbEmbedded False _), ("val4", EmbeddedDef True _),  ("val5", EmbeddedDef True _)] -> "val1"
+[("val1", DbEmbedded False _), ("val4", EmbeddedDef False _), ("val5", EmbeddedDef True _)] -> "val4$val1"
+-}
+{-# INLINABLE renderChain #-}
+renderChain :: StringLike s => (s -> s) -> FieldChain -> [s] -> [s]
+renderChain esc (f, prefix) acc = (case prefix of
+  ((name, EmbeddedDef False _):fs) -> flattenP esc (goP (fromString name) fs) f acc
+  _ -> flatten esc f acc) where
+  goP p ((name, EmbeddedDef False _):fs) = goP (fromString name <> fromChar delim <> p) fs
+  goP p _ = p
+
 defaultShowPrim :: PersistValue -> String
 defaultShowPrim (PersistString x) = "'" ++ x ++ "'"
 defaultShowPrim (PersistByteString x) = "'" ++ show x ++ "'"
@@ -115,23 +197,71 @@
 defaultShowPrim (PersistDay x) = show x
 defaultShowPrim (PersistTimeOfDay x) = show x
 defaultShowPrim (PersistUTCTime x) = show x
+defaultShowPrim (PersistZonedTime x) = show x
 defaultShowPrim (PersistNull) = "NULL"
 
-renderOrders :: PersistEntity v => (String -> String) -> [Order v c] -> ShowS
-renderOrders _ [] = id
-renderOrders esc (x:xs) = (" ORDER BY " ++) . f x . rest where
-  rest = foldr (\ord r -> (',':) . f ord . r) id xs
-  f (Asc a)  = (esc (show a) ++)
-  f (Desc a) = (esc (show a) ++) . (" DESC" ++)
+{-# INLINABLE renderOrders #-}
+renderOrders :: forall v c s . (PersistEntity v, Constructor c, StringLike s) => (s -> s) -> [Order v c] -> s
+renderOrders _ [] = mempty
+renderOrders esc xs = if null orders then mempty else " ORDER BY " <> commasJoin orders where
+  orders = foldr go [] xs
+  go (Asc a) acc = renderField esc a acc
+  go (Desc a) acc = renderField (\f -> esc f <> " DESC") a acc
 
-renderUpdates :: PersistEntity v => (String -> String) -> [Update v c] -> RenderS
-renderUpdates _ [] = (id, id)
-renderUpdates esc (x:xs) = f x <> rest where
-  rest = foldr (\ord r -> char ',' <> f ord <> r) (id, id) xs
-  f (Update field a) = string (esc (show field)) <> char '=' <> renderExpr esc a
+{-# INLINABLE renderFields #-}
+-- Returns string with comma separated escaped fields like "name,age"
+-- If there are other columns before renderFields result, do not put comma because the result might be an empty string. This happens when the fields have no columns like ().
+-- One of the solutions is to add one more field with datatype that is known to have columns, eg renderFields id (("id$", namedType (0 :: Int64)) : constrParams constr)
+renderFields :: StringLike s => (s -> s) -> [(String, DbType)] -> s
+renderFields esc = commasJoin . foldr (flatten esc) []
 
-defId :: String
-defId = "id$"
+-- TODO: merge code of flatten and flattenP
+flatten :: StringLike s => (s -> s) -> (String, DbType) -> ([s] -> [s])
+flatten esc (fname, typ) acc = go typ where
+  go typ' = case typ' of
+    DbMaybe t -> go t
+    DbEmbedded emb -> handleEmb emb
+    DbEntity (Just (emb, _)) _ -> handleEmb emb
+    _            -> esc fullName : acc
+  fullName = fromString fname
+  handleEmb (EmbeddedDef False ts) = foldr (flattenP esc fullName) acc ts
+  handleEmb (EmbeddedDef True  ts) = foldr (flatten esc) acc ts
 
-defDelim :: Char
-defDelim = '$'
+flattenP :: StringLike s => (s -> s) -> s -> (String, DbType) -> ([s] -> [s])
+flattenP esc prefix (fname, typ) acc = go typ where
+  go typ' = case typ' of
+    DbMaybe t -> go t
+    DbEmbedded emb -> handleEmb emb
+    DbEntity (Just (emb, _)) _ -> handleEmb emb
+    _            -> esc fullName : acc
+  fullName = prefix <> fromChar delim <> fromString fname
+  handleEmb (EmbeddedDef False ts) = foldr (flattenP esc fullName) acc ts
+  handleEmb (EmbeddedDef True  ts) = foldr (flatten esc) acc ts
+
+commasJoin :: StringLike s => [s] -> s
+commasJoin = intercalateS (fromChar ',')
+
+{-# INLINEABLE intercalateS #-}
+intercalateS :: StringLike s => s -> [s] -> s
+intercalateS _ [] = mempty
+intercalateS a (x:xs) = x <> go xs where
+  go [] = mempty
+  go (f:fs) = a <> f <> go fs
+
+commasJoinRenders :: StringLike s => [RenderS s] -> Maybe (RenderS s)
+commasJoinRenders [] = Nothing
+commasJoinRenders (x:xs) = Just $ foldl' f x xs where
+  f (RenderS str1 vals1) (RenderS str2 vals2) = RenderS (str1 <> comma <> str2) (vals1 <> vals2)
+  comma = fromChar ','
+
+{-# INLINABLE renderUpdates #-}
+renderUpdates :: (PersistEntity v, Constructor c, StringLike s, DbDescriptor db) => Proxy db -> (s -> s) -> [Update v c] -> Maybe (RenderS s)
+renderUpdates p esc = commasJoinRenders . mapMaybe go where
+  go (Update field expr) = (case expr of
+      ExprPure  a -> guard $ RenderS (commasJoin $ map (\f -> f <> "=?") fs) (toPurePersistValues p a)
+      ExprField a -> guard $ RenderS (commasJoin $ zipWith (\f1 f2 -> f1 <> fromChar '=' <> f2) fs $ renderField esc a []) id
+      ExprArith a -> case fs of
+        [f] -> Just $ RenderS (f <> fromChar '=') id <> renderArith p esc a
+        _   -> error $ "renderUpdates: expected one column field, found " ++ show (length fs)) where
+      guard a = if null fs then Nothing else Just a
+      fs = renderField esc field []
diff --git a/Database/Groundhog/Instances.hs b/Database/Groundhog/Instances.hs
new file mode 100644
--- /dev/null
+++ b/Database/Groundhog/Instances.hs
@@ -0,0 +1,538 @@
+{-# LANGUAGE TypeFamilies, GADTs, TypeSynonymInstances, OverlappingInstances, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Database.Groundhog.Instances (Selector(..)) where
+
+import Control.Monad (liftM)
+
+import Database.Groundhog.Core
+import Database.Groundhog.Generic (failMessage, primToPersistValue, primFromPersistValue, pureFromPersistValue, phantomDb)
+
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import qualified Data.Text.Encoding.Error as T
+import Data.Bits (bitSize)
+import Data.ByteString.Char8 (ByteString, unpack)
+import Data.Int (Int8, Int16, Int32, Int64)
+import Data.Time (Day, TimeOfDay, UTCTime)
+import Data.Time.LocalTime (ZonedTime)
+import Data.Word (Word8, Word16, Word32, Word64)
+
+instance (PersistField a', PersistField b') => Embedded (a', b') where
+  data Selector (a', b') constr where
+    Tuple2_0Selector :: Selector (a, b) a
+    Tuple2_1Selector :: Selector (a, b) b
+  selectorNum Tuple2_0Selector = 0
+  selectorNum Tuple2_1Selector = 1
+
+instance (PersistField a', PersistField b', PersistField c') => Embedded (a', b', c') where
+  data Selector (a', b', c') constr where
+    Tuple3_0Selector :: Selector (a, b, c) a
+    Tuple3_1Selector :: Selector (a, b, c) b
+    Tuple3_2Selector :: Selector (a, b, c) c
+  selectorNum Tuple3_0Selector = 0
+  selectorNum Tuple3_1Selector = 1
+  selectorNum Tuple3_2Selector = 2
+
+instance (PersistField a', PersistField b', PersistField c', PersistField d') => Embedded (a', b', c', d') where
+  data Selector (a', b', c', d') constr where
+    Tuple4_0Selector :: Selector (a, b, c, d) a
+    Tuple4_1Selector :: Selector (a, b, c, d) b
+    Tuple4_2Selector :: Selector (a, b, c, d) c
+    Tuple4_3Selector :: Selector (a, b, c, d) d
+  selectorNum Tuple4_0Selector = 0
+  selectorNum Tuple4_1Selector = 1
+  selectorNum Tuple4_2Selector = 2
+  selectorNum Tuple4_3Selector = 3
+
+instance (PersistField a', PersistField b', PersistField c', PersistField d', PersistField e') => Embedded (a', b', c', d', e') where
+  data Selector (a', b', c', d', e') constr where
+    Tuple5_0Selector :: Selector (a, b, c, d, e) a
+    Tuple5_1Selector :: Selector (a, b, c, d, e) b
+    Tuple5_2Selector :: Selector (a, b, c, d, e) c
+    Tuple5_3Selector :: Selector (a, b, c, d, e) d
+    Tuple5_4Selector :: Selector (a, b, c, d, e) e
+  selectorNum Tuple5_0Selector = 0
+  selectorNum Tuple5_1Selector = 1
+  selectorNum Tuple5_2Selector = 2
+  selectorNum Tuple5_3Selector = 3
+  selectorNum Tuple5_4Selector = 4
+  
+instance PrimitivePersistField a => SinglePersistField a where
+  toSinglePersistValue a = phantomDb >>= \p -> return (toPrimitivePersistValue p a)
+  fromSinglePersistValue a = phantomDb >>= \p -> return (fromPrimitivePersistValue p a)
+
+instance (SinglePersistField a, NeverNull a) => SinglePersistField (Maybe a) where
+  toSinglePersistValue Nothing = return PersistNull
+  toSinglePersistValue (Just a) = toSinglePersistValue a
+  fromSinglePersistValue PersistNull = return Nothing
+  fromSinglePersistValue a = liftM Just $ fromSinglePersistValue a
+
+instance PrimitivePersistField a => PurePersistField a where
+  toPurePersistValues p a = (toPrimitivePersistValue p a:)
+  fromPurePersistValues p (x:xs) = (fromPrimitivePersistValue p x, xs)
+  fromPurePersistValues _ xs = (\a -> error (failMessage a xs) `asTypeOf` (a, xs)) undefined
+
+instance (PrimitivePersistField a, NeverNull a) => PurePersistField (Maybe a) where
+  toPurePersistValues p a = (maybe PersistNull (toPrimitivePersistValue p) a:)
+  fromPurePersistValues _ (PersistNull:xs) = (Nothing, xs)
+  fromPurePersistValues p (x:xs) = (fromPrimitivePersistValue p x, xs)
+  fromPurePersistValues _ xs = (\a -> error (failMessage a xs) `asTypeOf` (a, xs)) undefined
+
+instance PurePersistField () where
+  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
+    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
+    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
+    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
+    in ((a, b, c, d, e), rest4)
+
+instance Numeric Int
+instance Numeric Int8
+instance Numeric Int16
+instance Numeric Int32
+instance Numeric Int64
+instance Numeric Word8
+instance Numeric Word16
+instance Numeric Word32
+instance Numeric Word64
+instance Numeric Double
+
+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"
+
+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
+
+instance PrimitivePersistField ByteString where
+  toPrimitivePersistValue _ s = PersistByteString s
+  fromPrimitivePersistValue _ (PersistByteString a) = a
+  fromPrimitivePersistValue p x = T.encodeUtf8 . T.pack $ fromPrimitivePersistValue p x
+
+instance PrimitivePersistField Int where
+  toPrimitivePersistValue _ a = PersistInt64 (fromIntegral a)
+  fromPrimitivePersistValue _ (PersistInt64 a) = fromIntegral 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 _ x = readHelper x ("Expected Integer, received: " ++ show x)
+
+instance PrimitivePersistField Int16 where
+  toPrimitivePersistValue _ a = PersistInt64 (fromIntegral a)
+  fromPrimitivePersistValue _ (PersistInt64 a) = fromIntegral 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 _ x = readHelper x ("Expected Integer, received: " ++ show x)
+
+instance PrimitivePersistField Int64 where
+  toPrimitivePersistValue _ a = PersistInt64 (fromIntegral a)
+  fromPrimitivePersistValue _ (PersistInt64 a) = 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 _ x = readHelper x ("Expected Integer, received: " ++ show x)
+
+instance PrimitivePersistField Word16 where
+  toPrimitivePersistValue _ a = PersistInt64 (fromIntegral a)
+  fromPrimitivePersistValue _ (PersistInt64 a) = fromIntegral 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 _ x = readHelper x ("Expected Integer, received: " ++ show x)
+
+instance PrimitivePersistField Word64 where
+  toPrimitivePersistValue _ a = PersistInt64 (fromIntegral a)
+  fromPrimitivePersistValue _ (PersistInt64 a) = fromIntegral a
+  fromPrimitivePersistValue _ x = readHelper x ("Expected Integer, received: " ++ show x)
+
+instance PrimitivePersistField Double where
+  toPrimitivePersistValue _ a = PersistDouble a
+  fromPrimitivePersistValue _ (PersistDouble a) = 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
+
+instance PrimitivePersistField Day where
+  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)
+
+instance PrimitivePersistField UTCTime where
+  toPrimitivePersistValue _ a = PersistUTCTime a
+  fromPrimitivePersistValue _ (PersistUTCTime a) = 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 _ 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
+
+instance (DbDescriptor db, PersistEntity v) => PrimitivePersistField (KeyForBackend db v) where
+  toPrimitivePersistValue p (KeyForBackend a) = toPrimitivePersistValue p a
+  fromPrimitivePersistValue p x = KeyForBackend (fromPrimitivePersistValue p x)
+
+instance NeverNull String
+instance NeverNull T.Text
+instance NeverNull ByteString
+instance NeverNull Int
+instance NeverNull Int64
+instance NeverNull Double
+instance NeverNull Bool
+instance NeverNull Day
+instance NeverNull TimeOfDay
+instance NeverNull UTCTime
+instance NeverNull (Key v u)
+instance NeverNull (KeyForBackend db v)
+
+readHelper :: Read a => PersistValue -> String -> a
+readHelper s errMessage = case s of
+  PersistString str -> readHelper' str
+  PersistByteString str -> readHelper' (unpack str)
+  _ -> error $ "readHelper: " ++ errMessage
+  where
+    readHelper' str = case reads str of
+      (a, _):_ -> a
+      _        -> error $ "readHelper: " ++ errMessage
+
+instance PersistField ByteString where
+  persistName _ = "ByteString"
+  toPersistValues = primToPersistValue
+  fromPersistValues = primFromPersistValue
+  dbType _ = DbBlob
+
+instance PersistField String where
+  persistName _ = "String"
+  toPersistValues = primToPersistValue
+  fromPersistValues = primFromPersistValue
+  dbType _ = DbString
+
+instance PersistField T.Text where
+  persistName _ = "Text"
+  toPersistValues = primToPersistValue
+  fromPersistValues = primFromPersistValue
+  dbType _ = DbString
+
+instance PersistField Int where
+  persistName _ = "Int"
+  toPersistValues = primToPersistValue
+  fromPersistValues = primFromPersistValue
+  dbType a = if bitSize a == 32 then DbInt32 else DbInt64
+
+instance PersistField Int8 where
+  persistName _ = "Int8"
+  toPersistValues = primToPersistValue
+  fromPersistValues = primFromPersistValue
+  dbType _ = DbInt32
+
+instance PersistField Int16 where
+  persistName _ = "Int16"
+  toPersistValues = primToPersistValue
+  fromPersistValues = primFromPersistValue
+  dbType _ = DbInt32
+
+instance PersistField Int32 where
+  persistName _ = "Int32"
+  toPersistValues = primToPersistValue
+  fromPersistValues = primFromPersistValue
+  dbType _ = DbInt32
+
+instance PersistField Int64 where
+  persistName _ = "Int64"
+  toPersistValues = primToPersistValue
+  fromPersistValues = primFromPersistValue
+  dbType _ = DbInt64
+
+instance PersistField Word8 where
+  persistName _ = "Word8"
+  toPersistValues = primToPersistValue
+  fromPersistValues = primFromPersistValue
+  dbType _ = DbInt32
+
+instance PersistField Word16 where
+  persistName _ = "Word16"
+  toPersistValues = primToPersistValue
+  fromPersistValues = primFromPersistValue
+  dbType _ = DbInt32
+
+instance PersistField Word32 where
+  persistName _ = "Word32"
+  toPersistValues = primToPersistValue
+  fromPersistValues = primFromPersistValue
+  dbType _ = DbInt64
+
+instance PersistField Word64 where
+  persistName _ = "Word64"
+  toPersistValues = primToPersistValue
+  fromPersistValues = primFromPersistValue
+  dbType _ = DbInt64
+
+instance PersistField Double where
+  persistName _ = "Double"
+  toPersistValues = primToPersistValue
+  fromPersistValues = primFromPersistValue
+  dbType _ = DbReal
+
+instance PersistField Bool where
+  persistName _ = "Bool"
+  toPersistValues = primToPersistValue
+  fromPersistValues = primFromPersistValue
+  dbType _ = DbBool
+
+instance PersistField Day where
+  persistName _ = "Day"
+  toPersistValues = primToPersistValue
+  fromPersistValues = primFromPersistValue
+  dbType _ = DbDay
+
+instance PersistField TimeOfDay where
+  persistName _ = "TimeOfDay"
+  toPersistValues = primToPersistValue
+  fromPersistValues = primFromPersistValue
+  dbType _ = DbTime
+
+instance PersistField UTCTime where
+  persistName _ = "UTCTime"
+  toPersistValues = primToPersistValue
+  fromPersistValues = primFromPersistValue
+  dbType _ = DbDayTime
+
+instance PersistField ZonedTime where
+  persistName _ = "ZonedTime"
+  toPersistValues = primToPersistValue
+  fromPersistValues = primFromPersistValue
+  dbType _ = DbDayTimeZoned
+
+-- There is a weird bug in GHC 7.4.1 which causes program to hang. See ticket 7126.
+-- instance (PersistField a, NeverNull a) => PersistField (Maybe a) where -- OK
+-- instance (SinglePersistField a, NeverNull a) => PersistField (Maybe a) where -- HANGS
+instance (PersistField a, NeverNull a) => PersistField (Maybe a) where
+  persistName a = "Maybe" ++ delim : persistName ((undefined :: Maybe a -> a) a)
+  toPersistValues Nothing = return (PersistNull:)
+  toPersistValues (Just a) = toPersistValues a
+  fromPersistValues [] = fail "fromPersistValues Maybe: empty list"
+  fromPersistValues (PersistNull:xs) = return (Nothing, xs)
+  fromPersistValues xs = fromPersistValues xs >>= \(x, xs') -> return (Just x, xs')
+  dbType a = DbMaybe $ dbType ((undefined :: Maybe a -> a) a)
+
+instance (PersistField a) => PersistField [a] where
+  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)
+  dbType a = DbList (persistName a) $ dbType ((undefined :: [] a -> a) a)
+
+instance PersistField () where
+  persistName _ = "Unit" ++ [delim]
+  toPersistValues _ = return id
+  fromPersistValues xs = return ((), xs)
+  dbType _ = DbEmbedded $ EmbeddedDef False []
+
+instance (PersistField a, PersistField b) => PersistField (a, b) where
+  persistName a = "Tuple2" ++ delim : delim : persistName ((undefined :: (a, b) -> a) a) ++ delim : persistName ((undefined :: (a, b) -> b) a)
+  toPersistValues (a, b) = do
+    a' <- toPersistValues a
+    b' <- toPersistValues b
+    return $ a' . b'
+  fromPersistValues xs = do
+    (a, rest0) <- fromPersistValues xs
+    (b, rest1) <- fromPersistValues rest0
+    return ((a, b), rest1)
+  dbType a = DbEmbedded $ EmbeddedDef False [("val0", dbType ((undefined :: (a, b) -> a) a)), ("val1", dbType ((undefined :: (a, b) -> b) a))]
+  
+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
+    a' <- toPersistValues a
+    b' <- toPersistValues b
+    c' <- toPersistValues c
+    return $ a' . b' . c'
+  fromPersistValues xs = do
+    (a, rest0) <- fromPersistValues xs
+    (b, rest1) <- fromPersistValues rest0
+    (c, rest2) <- fromPersistValues rest1
+    return ((a, b, c), rest2)
+  dbType a = DbEmbedded $ EmbeddedDef False [("val0", dbType ((undefined :: (a, b, c) -> a) a)), ("val1", dbType ((undefined :: (a, b, c) -> b) a)), ("val2", dbType ((undefined :: (a, b, c) -> c) a))]
+  
+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
+    a' <- toPersistValues a
+    b' <- toPersistValues b
+    c' <- toPersistValues c
+    d' <- toPersistValues d
+    return $ a' . b' . c' . d'
+  fromPersistValues xs = do
+    (a, rest0) <- fromPersistValues xs
+    (b, rest1) <- fromPersistValues rest0
+    (c, rest2) <- fromPersistValues rest1
+    (d, rest3) <- fromPersistValues rest2
+    return ((a, b, c, d), rest3)
+  dbType a = DbEmbedded $ EmbeddedDef False [("val0", dbType ((undefined :: (a, b, c, d) -> a) a)), ("val1", dbType ((undefined :: (a, b, c, d) -> b) a)), ("val2", dbType ((undefined :: (a, b, c, d) -> c) a)), ("val3", dbType ((undefined :: (a, b, c, d) -> d) a))]
+  
+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
+    a' <- toPersistValues a
+    b' <- toPersistValues b
+    c' <- toPersistValues c
+    d' <- toPersistValues d
+    e' <- toPersistValues e
+    return $ a' . b' . c' . d' . e'
+  fromPersistValues xs = do
+    (a, rest0) <- fromPersistValues xs
+    (b, rest1) <- fromPersistValues rest0
+    (c, rest2) <- fromPersistValues rest1
+    (d, rest3) <- fromPersistValues rest2
+    (e, rest4) <- fromPersistValues rest3
+    return ((a, b, c, d, e), rest4)
+  dbType a = DbEmbedded $ EmbeddedDef False [("val0", dbType ((undefined :: (a, b, c, d, e) -> a) a)), ("val1", dbType ((undefined :: (a, b, c, d, e) -> b) a)), ("val2", dbType ((undefined :: (a, b, c, d, e) -> c) a)), ("val3", dbType ((undefined :: (a, b, c, d, e) -> d) a)), ("val4", dbType ((undefined :: (a, b, c, d, e) -> e) a))]
+
+instance (DbDescriptor db, PersistEntity v) => PersistField (KeyForBackend db v) where
+  persistName a = "KeyForBackend" ++ delim : persistName ((undefined :: KeyForBackend db v -> v) a)
+  toPersistValues = primToPersistValue
+  fromPersistValues = primFromPersistValue
+  dbType a = dbType ((undefined :: KeyForBackend db v -> v) a)
+
+instance (PersistEntity v, Constructor c, PersistField a) => Projection (Field v c a) (RestrictionHolder v c) a where
+  projectionFieldChains f = (fieldChain f:)
+  projectionResult _ = fromPersistValues
+
+instance (PersistEntity v, Constructor c, PersistField a) => Projection (SubField v c a) (RestrictionHolder v c) a where
+  projectionFieldChains f = (fieldChain f:)
+  projectionResult _ = fromPersistValues
+
+instance (PersistEntity v, Constructor c, PersistField (Key v BackendSpecific)) => Projection (AutoKeyField v c) (RestrictionHolder v c) (Key v BackendSpecific) where
+  projectionFieldChains f = (fieldChain f:)
+  projectionResult _ = fromPersistValues
+
+instance (PersistEntity v, Constructor c) => Projection (c (ConstructorMarker v)) (RestrictionHolder v c) v where
+  projectionFieldChains c = (chains++) where
+    chains = map (\f -> (f, [])) $ constrParams constr
+    e = entityDef ((undefined :: c (ConstructorMarker v) -> v) c)
+    constr = constructors e !! phantomConstrNum c
+  projectionResult c xs = toSinglePersistValue (phantomConstrNum c) >>= \cNum -> fromEntityPersistValues (cNum:xs)
+
+instance (PersistEntity v, IsUniqueKey (Key v (Unique u)), r ~ RestrictionHolder v (UniqueConstr (Key v (Unique u))))
+      => Projection (u (UniqueMarker v)) r (Key v (Unique u)) where
+  projectionFieldChains u = (chains++) where
+    UniqueDef _ uFields = constrUniques constr !! uniqueNum ((undefined :: u (UniqueMarker v) -> Key v (Unique u)) u)
+    chains = map (\f -> (f, [])) uFields
+    constr = head $ constructors (entityDef ((undefined :: u (UniqueMarker v) -> v) u))
+  projectionResult _ = pureFromPersistValue
+
+instance (Projection a1 r a1', Projection a2 r a2') => Projection (a1, a2) r (a1', a2') where
+  projectionFieldChains (a1, a2) = projectionFieldChains a1 . projectionFieldChains a2
+  projectionResult (a', b') xs = do
+    (a, rest0) <- projectionResult a' xs
+    (b, rest1) <- projectionResult b' rest0
+    return ((a, b), rest1)
+
+instance (Projection a1 r a1', Projection a2 r a2', Projection a3 r a3') => Projection (a1, a2, a3) r (a1', a2', a3') where
+  projectionFieldChains (a1, a2, a3) = projectionFieldChains a1 . projectionFieldChains a2 . projectionFieldChains a3
+  projectionResult (a', b', c') xs = do
+    (a, rest0) <- projectionResult a' xs
+    (b, rest1) <- projectionResult b' rest0
+    (c, rest2) <- projectionResult c' rest1
+    return ((a, b, c), rest2)
+
+instance (Projection a1 r a1', Projection a2 r a2', Projection a3 r a3', Projection a4 r a4') => Projection (a1, a2, a3, a4) r (a1', a2', a3', a4') where
+  projectionFieldChains (a1, a2, a3, a4) = projectionFieldChains a1 . projectionFieldChains a2 . projectionFieldChains a3 . projectionFieldChains a4
+  projectionResult (a', b', c', d') xs = do
+    (a, rest0) <- projectionResult a' xs
+    (b, rest1) <- projectionResult b' rest0
+    (c, rest2) <- projectionResult c' rest1
+    (d, rest3) <- projectionResult d' rest2
+    return ((a, b, c, d), rest3)
+
+instance (Projection a1 r a1', Projection a2 r a2', Projection a3 r a3', Projection a4 r a4', Projection a5 r a5') => Projection (a1, a2, a3, a4, a5) r (a1', a2', a3', a4', a5') where
+  projectionFieldChains (a1, a2, a3, a4, a5) = projectionFieldChains a1 . projectionFieldChains a2 . projectionFieldChains a3 . projectionFieldChains a4 . projectionFieldChains a5
+  projectionResult (a', b', c', d', e') xs = do
+    (a, rest0) <- projectionResult a' xs
+    (b, rest1) <- projectionResult b' rest0
+    (c, rest2) <- projectionResult c' rest1
+    (d, rest3) <- projectionResult d' rest2
+    (e, rest4) <- projectionResult e' rest3
+    return ((a, b, c, d, e), rest4)
+
+instance (PersistEntity v, Constructor c, Projection (AutoKeyField v c) r a') => FieldLike (AutoKeyField v c) r a' where
+  fieldChain a = chain where
+    chain = maybe (error "fieldChain AutoKeyField: constructor constrAutoKeyName == Nothing") (\idName -> ((idName, DbEntity Nothing e), [])) $ constrAutoKeyName constr
+    e = entityDef ((undefined :: AutoKeyField v c -> v) a)
+    cNum = phantomConstrNum ((undefined :: AutoKeyField v c -> c (ConstructorMarker v)) a)
+    constr = constructors e !! cNum
+
+instance (PersistEntity v, Constructor c, Projection (SubField v c a) r a') => FieldLike (SubField v c a) r a' where
+  fieldChain (SubField a) = a
+
+instance (PersistEntity v, Constructor c, Projection (Field v c a) r a') => FieldLike (Field v c a) r a' where
+  fieldChain = entityFieldChain
+
+instance (PersistEntity v, IsUniqueKey (Key v (Unique u)), Projection (u (UniqueMarker v)) r a') => FieldLike (u (UniqueMarker v)) r a' where
+  fieldChain u = chain where
+    UniqueDef _ uFields = constrUniques constr !! uniqueNum ((undefined :: u (UniqueMarker v) -> Key v (Unique u)) u)
+    chain = (("will_be_ignored", DbEmbedded $ EmbeddedDef True $ uFields), [])
+    constr = head $ constructors (entityDef ((undefined :: u (UniqueMarker v) -> v) u))
diff --git a/Database/Groundhog/TH.hs b/Database/Groundhog/TH.hs
deleted file mode 100644
--- a/Database/Groundhog/TH.hs
+++ /dev/null
@@ -1,330 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-
--- | This module provides functions to generate the auxiliary structures for the user data type
-module Database.Groundhog.TH
-  ( deriveEntity
-  , setDbEntityName
-  , setConstructor
-  , setPhantomName
-  , setDbConstrName
-  , setConstraints
-  , setField
-  , setDbFieldName
-  , setExprFieldName
-  ) where
-
-import Database.Groundhog.Core(PersistEntity(..), PersistField(..), NeverNull, Primitive(toPrim), PersistBackend(..), DbType(DbEntity), Constraint, Constructor(..), namedType, EntityDef(..), ConstructorDef(..), PersistValue(..))
-import Language.Haskell.TH
-import Language.Haskell.TH.Syntax(StrictType, VarStrictType)
-import Control.Monad(liftM, forM, forM_)
-import Control.Monad.Trans.State(State, runState, modify)
-import Data.Char(toUpper, toLower, isSpace)
-import Data.List(nub, (\\))
-
--- data SomeData a = U1 { foo :: Int} | U2 { bar :: Maybe String, asc :: Int64, add :: a} | U3 deriving (Show, Eq)
-
-data THEntityDef = THEntityDef {
-    dataName :: Name -- SomeData
-  , dbEntityName :: String  -- SQLSomeData
-  , thTypeParams :: [TyVarBndr]
-  , thConstructors :: [THConstructorDef]
-} deriving Show
-
-data THConstructorDef = THConstructorDef {
-    thConstrName    :: Name -- U2
-  , thPhantomConstrName :: String -- U2Constructor
-  , dbConstrName    :: String -- SQLU2
-  , thConstrParams  :: [FieldDef]
-  , thConstrConstrs :: [Constraint]
-} deriving Show
-
-data FieldDef = FieldDef {
-    fieldName :: String -- bar
-  , dbFieldName :: String -- SQLbar
-  , exprName :: String -- BarField
-  , fieldType :: Type
-} deriving Show
-
--- | Set name of the table in the datatype
-setDbEntityName :: String -> State THEntityDef ()
-setDbEntityName name = modify $ \d -> d {dbEntityName = name}
-
--- | Modify constructor
-setConstructor :: Name -> State THConstructorDef () -> State THEntityDef ()
-setConstructor name f = modify $ \d ->
-  d {thConstructors = replaceOne thConstrName name f $ thConstructors d}
-
--- | Set name used to parametrise fields
-setPhantomName :: String -> State THConstructorDef ()
-setPhantomName name = modify $ \c -> c {thPhantomConstrName = name}
-
--- | Set name of the constructor specific table
-setDbConstrName :: String -> State THConstructorDef ()
-setDbConstrName name = modify $ \c -> c {dbConstrName = name}
-
--- | Set constraints of the constructor. The names should be database names of the fields
-setConstraints :: [Constraint] -> State THConstructorDef ()
-setConstraints cs = modify $ \c -> c {thConstrConstrs = cs}
-
--- | Modify field. Field name is a regular field name in record constructor. Otherwise, it is lower-case constructor name with field number.
-setField :: String -> State FieldDef () -> State THConstructorDef ()
-setField name f = modify $ \c ->
-  c {thConstrParams = replaceOne fieldName name f $ thConstrParams c}
-
--- | Set name of the field column in a database
-setDbFieldName :: String -> State FieldDef ()
-setDbFieldName name = modify $ \f -> f {dbFieldName = name}
-
--- | Set name of field constructor used in expressions
-setExprFieldName :: String -> State FieldDef ()
-setExprFieldName name = modify $ \f -> f {exprName = name}
-
-replaceOne :: (Eq b, Show b) => (a -> b) -> b -> State a () -> [a] -> [a]
-replaceOne p a f xs = case length (filter ((==a).p) xs) of
-  1 -> map (\x -> if p x == a then runModify f x else x) xs
-  0 -> error $ "Element with name " ++ show a ++ " not found"
-  _ -> error $ "Found more than one element with name " ++ show a
-
-runModify :: State a () -> a -> a
-runModify m a = snd $ runState m a
-
--- | Creates the auxiliary structures for a user datatype, which are required by Groundhog to manipulate it.
--- 
--- It creates GADT 'Fields' data instance for referring to the fields in
--- expressions and phantom types for data constructors. For record constructors the Field name is the regular field name with 
--- first letter capitalized and postpended \"Field\". If the field is an ordinary constructor, its name is constructor name
--- and postponed field name. The constructor phantom datatypes have the same name as constructors with \"Constructor\" postpended.
---
--- The generation can be adjusted using the optional modifier function. Example:
---
--- > data SomeData a = Normal Int | Record { bar :: Maybe String, asc :: a}
--- > deriveEntity ''SomeData $ Just $ do
--- >   setDbEntityName "SomeTableName"
--- >   setConstructor 'Normal $ do
--- >     setPhantomName "NormalConstructor" -- the same as default
---
--- It will generate these new datatypes and required instances.
---
--- > data NormalConstructor
--- > data RecordConstructor
--- > instance PersistEntity where
--- >   data Fields (SomeData a) where
--- >     Normal0Field :: Fields NormalConstructor Int
--- >     BarField :: Fields RecordConstructor (Maybe String)
--- >     AscField :: Fields RecordConstructor a
--- > ...
-
-deriveEntity :: Name -> Maybe (State THEntityDef ()) -> Q [Dec]
-deriveEntity name f = do
-  info <- reify name
-  let f' = maybe id runModify f
-  case info of
-    TyConI x -> do
-      case x of
-        def@(DataD _ _ _ _ _)  -> mkDecs $ either error id $ validate $ f' $ mkTHEntityDef def
-        NewtypeD _ _ _ _ _ -> error "Newtypes are not supported"
-        _ -> error $ "Unknown declaration type"
-    _        -> error "Only datatypes can be processed"
-
-validate :: THEntityDef -> Either String THEntityDef
-validate def = do
-  let notUniqueBy f xs = let xs' = map f xs in nub $ xs' \\ nub xs'
-  let assertUnique f xs what = case notUniqueBy f xs of
-        [] -> return ()
-        ys -> fail $ "All " ++ what ++ " must be unique: " ++ show ys
-  -- we need to validate datatype names because TH just creates unusable fields with spaces
-  let isSpaceFree = not . any isSpace
-  let assertSpaceFree s what = if isSpaceFree s then return () else fail $ "Spaces in " ++ what ++ " are not allowed: " ++ show s
-  let constrs = thConstructors def
-  assertUnique thPhantomConstrName constrs "constructor phantom name"
-  assertUnique dbConstrName constrs "constructor db name"
-  forM_ constrs $ \cdef -> do
-    let fields = thConstrParams cdef
-    assertSpaceFree (thPhantomConstrName cdef) "constructor phantom name"
-    assertUnique exprName fields "expr field name in a constructor"
-    assertUnique dbFieldName fields "db field name in a constructor"
-    forM_ fields $ \fdef -> assertSpaceFree (exprName fdef) "field expr name"
-  return def
-
-mkTHEntityDef :: Dec -> THEntityDef
-mkTHEntityDef (DataD _ dname typeVars cons _) =
-  THEntityDef dname (nameBase dname) typeVars constrs where
-  constrs = map mkConstr cons
-
-  mkConstr (NormalC name params) = mkConstr' name $ zipWith (\p i -> mkField (firstLetter toLower (nameBase name) ++ show i) p) params [0::Int ..]
-  mkConstr (RecC name params) = mkConstr' name (map mkVarField params)
-  mkConstr (InfixC _ _ _) = error "Types with infix constructors are not supported"
-  mkConstr (ForallC _ _ _) = error "Types with existential quantification are not supported"
-  mkConstr' name params = THConstructorDef name (nameBase name ++ "Constructor") (nameBase name) params []
-  
-  mkField :: String -> StrictType -> FieldDef
-  mkField name (_, t) = mkField' name t
-  mkVarField :: VarStrictType -> FieldDef
-  mkVarField (name, _, t) = mkField' (nameBase name) t
-  mkField' name t = FieldDef name name (firstLetter toUpper name ++ "Field") t
-mkTHEntityDef _ = error "Only datatypes can be processed"
-
-firstLetter :: (Char -> Char) -> String -> String
-firstLetter f s = f (head s):tail s
-
-mkDecs :: THEntityDef -> Q [Dec]
-mkDecs def = do
---  runIO (print def)
-  decs <- fmap concat $ sequence
-    [ mkPhantomConstructors def
-    , mkPhantomConstructorInstances def
-    , mkPersistFieldInstance def
-    , mkPersistEntityInstance def
-    ]
---  runIO $ putStrLn $ pprint decs
-  return decs
--- $(reify ''SomeData >>= stringE.show)
-
-mkPhantomConstructors :: THEntityDef -> Q [Dec]
-mkPhantomConstructors def = mapM f $ thConstructors def where
-  f c = dataD (cxt []) (mkName $ thPhantomConstrName c) [] [] []
-  
-mkPhantomConstructorInstances :: THEntityDef -> Q [Dec]
-mkPhantomConstructorInstances def = sequence $ zipWith f [0..] $ thConstructors def where
-  f :: Int -> THConstructorDef -> Q Dec
-  f cNum c = instanceD (cxt []) (appT (conT ''Constructor) (conT $ mkName $ thPhantomConstrName c)) [phantomConstrName', phantomConstrNum'] where
-    phantomConstrName' = funD 'phantomConstrName [clause [wildP] (normalB $ stringE $ dbConstrName c) []]
-    phantomConstrNum' = funD 'phantomConstrNum [clause [wildP] (normalB $ [|cNum  |]) []]
-
-mkPersistEntityInstance :: THEntityDef -> Q [Dec]
-mkPersistEntityInstance def = do
-  let entity = foldl AppT (ConT (dataName def)) $ map getType $ thTypeParams def
-  
-  fields' <- do
-    cParam <- newName "c"
-    fParam <- newName "f"
-    let mkField name field = ForallC [] ([EqualP (VarT cParam) (ConT name), EqualP (VarT fParam) (fieldType field)]) $ NormalC (mkName $ exprName field) []
-    let f cdef = map (mkField $ mkName $ thPhantomConstrName cdef) $ thConstrParams cdef
-    let constrs = concatMap f $ thConstructors def
-    return $ DataInstD [] ''Fields [entity, VarT cParam, VarT fParam] constrs []
-    
-  entityDef' <- do
-    v <- newName "v"
-    let mkLambda t = [|undefined :: $(forallT (thTypeParams def) (cxt []) [t| $(return entity) -> $(return t) |]) |]
-    let typeParams' = listE $ map (\t -> [| namedType ($(mkLambda $ getType t) $(varE v)) |]) $ thTypeParams def
-    let mkField c fNum f = do
-        a <- newName "a"
-        let fname = dbFieldName f
-        let pats = replicate fNum wildP ++ [varP a] ++ replicate (length (thConstrParams c) - fNum - 1) wildP
-        let nvar = case hasFreeVars (fieldType f) of
-             True ->  appE (lamE [conP (thConstrName c) pats] (varE a)) (varE v)
-             False -> [| undefined :: $(return $ fieldType f) |]
-        [| (fname, namedType $nvar) |]
-         
-    let constrs = listE $ zipWith (\cNum c@(THConstructorDef _ _ name params conss) -> [| ConstructorDef cNum name $(listE $ zipWith (mkField c) [0..] params) conss |]) [0..] $ thConstructors def
-    let body = normalB [| EntityDef $(stringE $ dbEntityName def) $typeParams' $constrs |]
-    funD 'entityDef $ [ clause [varP v] body [] ]
-
-  toPersistValues' <- liftM (FunD 'toPersistValues) $ forM (zip [0..] $ thConstructors def) $ \(cNum, c) -> do
-    names <- mapM (const $ newName "f") $ thConstrParams c
-    let pat = conP (thConstrName c) (map varP names)
-    let body = normalB $ [| sequence $(listE $ map (appE (varE 'toPersistValue)) ([|cNum::Int|]:map varE names) ) |]
-    clause [pat] body []
-  
---  fromPersistValues' <- funD 'fromPersistValues $ [ clause [wildP] (normalB [| error "fromPersistValues" |])[] ]
-  fromPersistValues' <- do
-    clauses <- forM (zip [0..] (thConstructors def)) $ \(cNum, c) -> do
-      names <- mapM (const $ newName "x") $ thConstrParams c
-      names' <- mapM (const $ newName "x'") $ thConstrParams c
-      let pat = conP '(:) [conP 'PersistInt64 [litP $ integerL cNum], listP $ map varP names]
-      let result = noBindS (appE (varE 'return) ( foldl (\a -> appE a . varE) (conE (thConstrName c)) names'))
-      let getField name name' f = bindS (varP name') [| fromPersistValue $(varE name) |]
-      let body = normalB $ doE $ (zipWith3 getField names names' (thConstrParams c)) ++ [result]
---      let body = normalB [|undefined|]
-      clause [pat] body []
-    unexpected <- newName "xs" >>= \xs -> clause [varP xs] (normalB [| fail $ "Invalid values: " ++ show $(varE xs) |]) []
-    return $ FunD 'fromPersistValues $ clauses ++ [unexpected]
-  
-  getConstraints' <- let
-    hasConstraints = not . null . thConstrConstrs
-    clauses = zipWith mkClause [0::Int ..] (thConstructors def)
-    mkClause cNum cdef | not (hasConstraints cdef) = clause [conP (thConstrName cdef) pats] (normalB [| (cNum, []) |]) [] where
-      pats = map (const wildP) $ thConstrParams cdef
-    mkClause cNum cdef = clause [conP (thConstrName cdef) (map varP names)] body [] where
-      getFieldName n = case filter ((==n).dbFieldName) $ thConstrParams cdef of
-        [f] -> varE $ mkName $ fieldName f
-        []  -> error $ "Database field name " ++ show n ++ " declared in constraint not found"
-        _   -> error $ "It can never happen. Found several fields with one database name " ++ show n
-      body = normalB $ [| (cNum, $(listE $ map (\(cname, fnames) -> [|(cname, $(listE $ map (\fname -> [| (fname, toPrim $(getFieldName fname)) |] ) fnames )) |] ) $ thConstrConstrs cdef)) |]
-      names = map (mkName . fieldName) $ thConstrParams cdef
-    in funD 'getConstraints clauses
-  
-  showField' <- do
-    let fields = concatMap thConstrParams $ thConstructors def
-    funD 'showField $ map (\f -> clause [conP (mkName $ exprName f) []] (normalB $ stringE $ dbFieldName f)[] ) fields
-
-  eqField' <- let
-    fieldNames = thConstructors def >>= thConstrParams >>= return.mkName.exprName
-    clauses = map (\n -> clause [conP n [], conP n []] (normalB [| True |]) []) fieldNames
-    in funD 'eqField $ if length clauses > 1
-     then clauses ++ [clause [wildP, wildP] (normalB [| False |]) []]
-     else clauses
-
-  let context = paramsContext def
-  let decs = [fields', entityDef', toPersistValues', fromPersistValues', getConstraints', showField', eqField']
-  return $ [InstanceD context (AppT (ConT ''PersistEntity) entity) decs]
-  
-mkPersistFieldInstance :: THEntityDef -> Q [Dec]
-mkPersistFieldInstance def = do
-  let types = map getType $ thTypeParams def
-  let entity = foldl AppT (ConT (dataName def)) types
-  
-  persistName' <- do
-    v <- newName "v"
-    let mkLambda t = [|undefined :: $(forallT (thTypeParams def) (cxt []) [t| $(return entity) -> $(return t) |]) |]
-    
-    let paramNames = foldr1 (\p xs -> [| $p ++ "$" ++ $xs |] ) $ map (\t -> [| persistName ($(mkLambda t) $(varE v)) |]) types
-    let namesList = case null types of
-         True  -> [| $(stringE $ dbEntityName def) |]
-         False -> [| $(stringE $ dbEntityName def) ++ "$" ++ $(paramNames) |]
-    let body = normalB $ namesList
-    funD 'persistName $ [ clause [varP v] body [] ]
-  
-  toPersistValue' <- do
-    let body = normalB [| liftM (either toPrim toPrim) . insertBy |]
-    funD 'toPersistValue $ [ clause [] body [] ]
-  fromPersistValue' <- do
-    x <- newName "x"
-    let body = normalB [| fromPersistValue $(varE x) >>= get >>= maybe (fail $ "No data with id " ++ show $(varE x)) return |]
-    funD 'fromPersistValue $ [ clause [varP x] body [] ]
-  dbType' <- funD 'dbType $ [ clause [] (normalB [| DbEntity . entityDef |]) [] ]
-
-  let context = paramsContext def
-  let decs = [persistName', toPersistValue', fromPersistValue', dbType']
-  return $ [InstanceD context (AppT (ConT ''PersistField) entity) decs]
-
-paramsContext :: THEntityDef -> Cxt
-paramsContext def = classPred ''PersistField params ++ classPred ''NeverNull maybys where
-  classPred clazz = map (\t -> ClassP clazz [t])
-  -- every type must be an instance of PersistField
-  params = map getType $ thTypeParams def
-  -- all datatype fields also must be instances of PersistField
-  -- if Maybe is applied to a type param, the param must be also an instance of NeverNull
-  -- so that (Maybe param) is an instance of PersistField
-  maybys = nub $ thConstructors def >>= thConstrParams >>= insideMaybe . fieldType
-
-getType :: TyVarBndr -> Type
-getType (PlainTV name) = VarT name
-getType (KindedTV name _) = VarT name
-
-foldType :: (Type -> a) -> (a -> a -> a) -> Type -> a
-foldType f (<>) = go where
-  go (ForallT _ _ _) = error "forall'ed fields are not allowed"
-  go z@(AppT a b)    = f z <> go a <> go b
-  go z@(SigT t _)    = f z <> go t
-  go z               = f z
-
-hasFreeVars :: Type -> Bool
-hasFreeVars = foldType f (||) where
-  f (VarT _) = True
-  f _ = False
-
-insideMaybe :: Type -> [Type]
-insideMaybe = foldType f (++) where
-  f (AppT (ConT c) t@(VarT _)) | c == ''Maybe = [t]
-  f _ = []
diff --git a/groundhog.cabal b/groundhog.cabal
--- a/groundhog.cabal
+++ b/groundhog.cabal
@@ -1,5 +1,5 @@
 name:            groundhog
-version:         0.0.1.1
+version:         0.1.0
 license:         BSD3
 license-file:    LICENSE
 author:          Boris Lykah <lykahb@gmail.com>
@@ -8,24 +8,28 @@
 description:     This library provides just the general interface and helper functions. You must use a specific backend in order to make this useful.
 category:        Database
 stability:       Non-stable
-cabal-version:   >= 1.10
+cabal-version:   >= 1.6
 build-type:      Simple
 
 library
     build-depends:   base                     >= 4         && < 5
-                   , template-haskell
                    , bytestring               >= 0.9       && < 0.10
-                   , transformers             >= 0.2.1     && < 0.3
-                   , time                     >= 1.1.4     && < 1.3
+                   , transformers             >= 0.2.1     && < 0.4
+                   , time                     >= 1.1.4
                    , text                     >= 0.8       && < 0.12
                    , containers               >= 0.2       && < 0.5
-                   , enumerator               >= 0.4.9     && < 0.5
-                   , monad-control            >= 0.2       && < 0.3
-                   , pool                     >= 0.1       && < 0.2
+                   , monad-control            >= 0.3       && < 0.4
+                   , transformers-base
     exposed-modules: Database.Groundhog
                      Database.Groundhog.Core
+                     Database.Groundhog.Expression
                      Database.Groundhog.Generic
+                     Database.Groundhog.Generic.Migration
                      Database.Groundhog.Generic.Sql
-                     Database.Groundhog.TH
+                     Database.Groundhog.Generic.PersistBackendHelpers
+                     Database.Groundhog.Instances
     ghc-options:     -Wall
-    default-language: Haskell2010
+    
+source-repository head
+  type:     git
+  location: git://github.com/lykahb/groundhog.git