diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml
index 9a0c09228..cd321bf40 100644
--- a/.github/workflows/haskell.yml
+++ b/.github/workflows/haskell.yml
@@ -45,13 +45,12 @@ jobs:
     runs-on: ubuntu-latest
     strategy:
       matrix:
-        cabal: ["3.2"]
+        cabal: ["3.4"]
         ghc:
-          - "8.2.2"
           - "8.4.4"
           - "8.6.5"
           - "8.8.4"
-          - "8.10.1"
+          - "8.10.3"
 
     env:
       CONFIG: "--enable-tests"
diff --git a/cabal.project b/cabal.project
index 99ddaa950..34b031566 100644
--- a/cabal.project
+++ b/cabal.project
@@ -2,7 +2,7 @@ packages:
   persistent
   persistent-sqlite
   persistent-test
-  persistent-mongoDB
+  -- persistent-mongoDB
   persistent-mysql
   persistent-postgresql
   persistent-redis
diff --git a/persistent-mongoDB/Database/Persist/MongoDB.hs b/persistent-mongoDB/Database/Persist/MongoDB.hs
index 96ef4b3d6..65705559a 100644
--- a/persistent-mongoDB/Database/Persist/MongoDB.hs
+++ b/persistent-mongoDB/Database/Persist/MongoDB.hs
@@ -112,6 +112,7 @@ module Database.Persist.MongoDB
     , module Database.Persist
     ) where
 
+import qualified Data.List.NonEmpty as NEL
 import Control.Exception (throw, throwIO)
 import Control.Monad (liftM, (>=>), forM_, unless)
 import Control.Monad.IO.Class (liftIO)
@@ -409,7 +410,7 @@ updateToMongoField (BackendUpdate up)  = mongoUpdateToDoc up
 -- | convert a unique key into a MongoDB document
 toUniquesDoc :: forall record. (PersistEntity record) => Unique record -> [DB.Field]
 toUniquesDoc uniq = zipWith (DB.:=)
-  (map (unFieldNameDB . snd) $ persistUniqueToFieldNames uniq)
+  (map (unFieldNameDB . snd) $ NEL.toList $ persistUniqueToFieldNames uniq)
   (map DB.val (persistUniqueToValues uniq))
 
 -- | convert a PersistEntity into document fields.
@@ -417,31 +418,35 @@ toUniquesDoc uniq = zipWith (DB.:=)
 -- 'recordToDocument' includes nulls
 toInsertDoc :: forall record.  (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext)
             => record -> DB.Document
-toInsertDoc record = zipFilter (embeddedFields $ toEmbedEntityDef entDef)
-    (map toPersistValue $ toPersistFields record)
+toInsertDoc record =
+    zipFilter
+        (embeddedFields $ toEmbedEntityDef entDef)
+        (map toPersistValue $ toPersistFields record)
   where
     entDef = entityDef $ Just record
-    zipFilter :: [EmbedFieldDef] -> [PersistValue] -> DB.Document
-    zipFilter [] _  = []
-    zipFilter _  [] = []
-    zipFilter (fd:efields) (pv:pvs) =
-        if isNull pv then recur else
-          (fieldToLabel fd DB.:= embeddedVal (emFieldEmbed fd) pv):recur
-
+    zipFilter xs ys =
+        map (\(fd, pv) ->
+            fieldToLabel fd
+                DB.:=
+                    embeddedVal pv
+        )
+        $ filter (\(_, pv) -> isNull pv)
+        $ zip xs ys
       where
-        recur = zipFilter efields pvs
-
         isNull PersistNull = True
         isNull (PersistMap m) = null m
         isNull (PersistList l) = null l
         isNull _ = False
 
     -- make sure to removed nulls from embedded entities also
-    embeddedVal :: Maybe EmbedEntityDef -> PersistValue -> DB.Value
-    embeddedVal (Just emDef) (PersistMap m) = DB.Doc $
-      zipFilter (embeddedFields emDef) $ map snd m
-    embeddedVal je@(Just _) (PersistList l) = DB.Array $ map (embeddedVal je) l
-    embeddedVal _ pv = DB.val pv
+    embeddedVal :: PersistValue -> DB.Value
+    embeddedVal (PersistMap m) =
+        DB.Doc $ fmap (\(k, v) -> k DB.:= DB.val v) $ m
+            -- zipFilter fields $ map snd m
+    embeddedVal (PersistList l) =
+        DB.Array $ map embeddedVal l
+    embeddedVal pv =
+        DB.val pv
 
 entityToInsertDoc :: forall record.  (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext)
                   => Entity record -> DB.Document
@@ -647,7 +652,7 @@ keyToMongoDoc k = case entityPrimary $ entityDefFromKey k of
     Nothing   -> zipToDoc [FieldNameDB id_] values
     Just pdef -> [id_ DB.=: zipToDoc (primaryNames pdef)  values]
   where
-    primaryNames = map fieldDB . compositeFields
+    primaryNames = map fieldDB . NEL.toList . compositeFields
     values = keyToValues k
 
 entityDefFromKey :: PersistEntity record => Key record -> EntityDef
@@ -950,10 +955,13 @@ eitherFromPersistValues entDef doc = case mKey of
 -- Persistent creates a Haskell record from a list of PersistValue
 -- But most importantly it puts all PersistValues in the proper order
 orderPersistValues :: EmbedEntityDef -> [(Text, PersistValue)] -> [(Text, PersistValue)]
-orderPersistValues entDef castDoc = reorder
+orderPersistValues entDef castDoc =
+    match castColumns castDoc []
   where
-    castColumns = map nameAndEmbed (embeddedFields entDef)
-    nameAndEmbed fdef = (fieldToLabel fdef, emFieldEmbed fdef)
+    castColumns =
+        map nameAndEmbed (embeddedFields entDef)
+    nameAndEmbed fdef =
+        (fieldToLabel fdef, emFieldEmbed fdef)
 
     -- TODO: the below reasoning should be re-thought now that we are no longer inserting null: searching for a null column will look at every returned field before giving up
     -- Also, we are now doing the _id lookup at the start.
@@ -971,44 +979,44 @@ orderPersistValues entDef castDoc = reorder
     -- * but once we found an item in the alist use a new alist without that item for future lookups
     -- * so for the last query there is only one item left
     --
-    reorder :: [(Text, PersistValue)]
-    reorder = match castColumns castDoc []
+    match :: [(Text, Maybe (Either a EntityNameHS) )]
+          -> [(Text, PersistValue)]
+          -> [(Text, PersistValue)]
+          -> [(Text, PersistValue)]
+    -- when there are no more Persistent castColumns we are done
+    --
+    -- allow extra mongoDB fields that persistent does not know about
+    -- another application may use fields we don't care about
+    -- our own application may set extra fields with the raw driver
+    match [] _ values = values
+    match ((fieldName, medef) : columns) fields values =
+        let
+            ((_, pv) , unused) =
+                matchOne fields []
+        in
+            match columns unused $
+                values ++ [(fieldName, nestedOrder medef pv)]
       where
-        match :: [(Text, Maybe EmbedEntityDef)]
-              -> [(Text, PersistValue)]
-              -> [(Text, PersistValue)]
-              -> [(Text, PersistValue)]
-        -- when there are no more Persistent castColumns we are done
-        --
-        -- allow extra mongoDB fields that persistent does not know about
-        -- another application may use fields we don't care about
-        -- our own application may set extra fields with the raw driver
-        match [] _ values = values
-        match (column:columns) fields values =
-          let (found, unused) = matchOne fields []
-          in match columns unused $ values ++
-                [(fst column, nestedOrder (snd column) (snd found))]
-          where
-            nestedOrder (Just em) (PersistMap m) =
-              PersistMap $ orderPersistValues em m
-            nestedOrder (Just em) (PersistList l) =
-              PersistList $ map (nestedOrder (Just em)) l
-            -- implied: nestedOrder Nothing found = found
-            nestedOrder _ found = found
-
-            matchOne (field:fs) tried =
-              if fst column == fst field
+        nestedOrder (Just _) (PersistMap m) =
+            PersistMap m
+        nestedOrder (Just em) (PersistList l) =
+            PersistList $ map (nestedOrder (Just em)) l
+        nestedOrder Nothing found =
+            found
+
+        matchOne (field:fs) tried =
+            if fieldName == fst field
                 -- snd drops the name now that it has been used to make the match
                 -- persistent will add the field name later
                 then (field, tried ++ fs)
                 else matchOne fs (field:tried)
-            -- if field is not found, assume it was a Nothing
-            --
-            -- a Nothing could be stored as null, but that would take up space.
-            -- instead, we want to store no field at all: that takes less space.
-            -- Also, another ORM may be doing the same
-            -- Also, this adding a Maybe field means no migration required
-            matchOne [] tried = ((fst column, PersistNull), tried)
+        -- if field is not found, assume it was a Nothing
+        --
+        -- a Nothing could be stored as null, but that would take up space.
+        -- instead, we want to store no field at all: that takes less space.
+        -- Also, another ORM may be doing the same
+        -- Also, this adding a Maybe field means no migration required
+        matchOne [] tried = ((fieldName, PersistNull), tried)
 
 assocListFromDoc :: DB.Document -> [(Text, PersistValue)]
 assocListFromDoc = Prelude.map (\f -> ( (DB.label f), cast (DB.value f) ) )
diff --git a/persistent-mongoDB/README.md b/persistent-mongoDB/README.md
new file mode 100644
index 000000000..2e6c015c5
--- /dev/null
+++ b/persistent-mongoDB/README.md
@@ -0,0 +1,11 @@
+# persistent-mongoDB
+
+`persistent-mongoDB` is on hiatus.
+
+There's a lot of complexity around the `EmbedEntityDef` stuff that makes it
+really annoying to use.
+
+A new version of `persistent` will make that easy to work with, and I'll fix it
+up then.
+
+If you want MongoDB *now* then PRs are welcome.
diff --git a/persistent-mongoDB/persistent-mongoDB.cabal b/persistent-mongoDB/persistent-mongoDB.cabal
index 5ee632598..a4baac253 100644
--- a/persistent-mongoDB/persistent-mongoDB.cabal
+++ b/persistent-mongoDB/persistent-mongoDB.cabal
@@ -72,9 +72,6 @@ test-suite test
                    , time
                    , transformers
                    , unliftio-core
-   if impl(ghc < 8)
-     build-depends:
-       semigroups
     default-language: Haskell2010
 
 source-repository head
diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs
index a5e81e91b..b0a4daca0 100644
--- a/persistent-mysql/Database/Persist/MySQL.hs
+++ b/persistent-mysql/Database/Persist/MySQL.hs
@@ -46,6 +46,7 @@ import Control.Monad.Trans.Except (ExceptT, runExceptT)
 import Control.Monad.Trans.Reader (ReaderT, runReaderT)
 import Control.Monad.Trans.Writer (runWriterT)
 
+import qualified Data.List.NonEmpty as NEL
 import Data.Acquire (Acquire, mkAcquire, with)
 import Data.Aeson
 import Data.Aeson.Types (modifyFailure)
@@ -177,9 +178,11 @@ prepare' conn sql = do
 -- | SQL code to be executed when inserting an entity.
 insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult
 insertSql' ent vals =
-    case entityPrimary ent of
-        Just _ -> ISRManyKeys sql vals
-        Nothing -> ISRInsertGet sql "SELECT LAST_INSERT_ID()"
+    case getEntityId ent of
+        EntityIdNaturalKey _ ->
+            ISRManyKeys sql vals
+        EntityIdField _ ->
+            ISRInsertGet sql "SELECT LAST_INSERT_ID()"
   where
     (fieldNames, placeholders) = unzip (Util.mkInsertPlaceholders ent escapeFT)
     sql = T.concat
@@ -370,7 +373,7 @@ migrate' connectInfo allDefs getter val = do
                     let refTarget =
                           addReference allDefs refConstraintName refTblName cname (crFieldCascade cRef)
 
-                    guard $ cname /= fieldDB (getEntityId val)
+                    guard $ Just cname /= fmap fieldDB (getEntityIdField val)
                     return $ AlterColumn name refTarget
 
 
@@ -455,22 +458,20 @@ addTable cols entity = AddTable $ concat
     ]
   where
     nonIdCols =
-        filter (\c -> cName c /= fieldDB (getEntityId entity) ) cols
+        filter (\c -> Just (cName c) /= fmap fieldDB (getEntityIdField entity) ) cols
     name =
         getEntityDBName entity
     idtxt =
-        case entityPrimary entity of
-            Just pdef ->
+        case getEntityId entity of
+            EntityIdNaturalKey pdef ->
                 concat
                     [ " PRIMARY KEY ("
                     , intercalate ","
-                  $ map (escapeF . fieldDB) $ compositeFields pdef
+                  $ map (escapeF . fieldDB) $ NEL.toList $ compositeFields pdef
                     , ")"
                     ]
-            Nothing ->
+            EntityIdField idField ->
                 let
-                    idField =
-                        getEntityId entity
                     defText =
                         defaultAttribute $ fieldAttrs idField
                     sType =
@@ -483,7 +484,7 @@ addTable cols entity = AddTable $ concat
                         findMaxLenOfField idField
                 in
                     concat
-                        [ escapeF $ fieldDB $ getEntityId entity
+                        [ escapeF $ fieldDB idField
                         , " " <> showSqlType sType maxlen False
                         , " NOT NULL"
                         , autoIncrementText
@@ -554,7 +555,7 @@ addReference allDefs fkeyname reftable cname fc =
     referencedColumns =
         fromMaybe errorMessage $ do
             entDef <- find ((== reftable) . getEntityDBName) allDefs
-            return $ map fieldDB $ getEntityKeyFields entDef
+            return $ map fieldDB $ NEL.toList $ getEntityKeyFields entDef
 
 data AlterColumn = Change Column
                  | Add' Column
@@ -585,7 +586,7 @@ data AlterDB = AddTable String
 
 
 udToPair :: UniqueDef -> (ConstraintNameDB, [FieldNameDB])
-udToPair ud = (uniqueDBName ud, map snd $ uniqueFields ud)
+udToPair ud = (uniqueDBName ud, map snd $ NEL.toList $ uniqueFields ud)
 
 ----------------------------------------------------------------------
 
@@ -922,7 +923,8 @@ findAlters edef allDefs col@(Column name isNull type_ def gen _defConstraintName
                     case (ref == ref', ref) of
                         (False, Just ColumnReference {crTableName=tname, crConstraintName=cname, crFieldCascade = cfc })
                             | tname /= getEntityDBName edef
-                            , unConstraintNameDB cname /= unFieldNameDB (fieldDB (getEntityId edef))
+                            , Just idField <- getEntityIdField edef
+                            , unConstraintNameDB cname /= unFieldNameDB (fieldDB idField)
                             ->
                             [addReference allDefs cname tname name cfc]
                         _ -> []
@@ -1536,7 +1538,7 @@ putManySql ent n = putManySql' fields ent n
 repsertManySql :: EntityDef -> Int -> Text
 repsertManySql ent n = putManySql' fields ent n
   where
-    fields = keyAndEntityFields ent
+    fields = NEL.toList $ keyAndEntityFields ent
 
 putManySql' :: [FieldDef] -> EntityDef -> Int -> Text
 putManySql' (filter isFieldNotGenerated -> fields) ent n = q
diff --git a/persistent-mysql/test/ImplicitUuidSpec.hs b/persistent-mysql/test/ImplicitUuidSpec.hs
index 448173a3b..501b5e7da 100644
--- a/persistent-mysql/test/ImplicitUuidSpec.hs
+++ b/persistent-mysql/test/ImplicitUuidSpec.hs
@@ -42,7 +42,7 @@ implicitUuidMigrate = do
 wipe :: IO ()
 wipe = db $ do
     rawExecute "DROP TABLE IF EXISTS with_def_uuid;" []
-    runMigration implicitUuidMigrate
+    void $ runMigrationSilent implicitUuidMigrate
 
 itDb :: String -> SqlPersistT (LoggingT (ResourceT IO)) a -> SpecWith (Arg (IO ()))
 itDb msg action = it msg $ db $ void action
@@ -57,11 +57,9 @@ spec = describe "ImplicitUuidSpec" $ before_ wipe $ do
             let withDefUuidKey = WithDefUuidKey (UUID "Hello")
             pass
     describe "getEntityId" $ do
-        let idField = getEntityId (entityDef (Proxy @WithDefUuid))
+        let Just idField = getEntityIdField (entityDef (Proxy @WithDefUuid))
         it "has a SqlString SqlType" $ asIO $ do
             fieldSqlType idField `shouldBe` SqlString
-        it "has a UUID type" $ asIO $ do
-            fieldType idField `shouldBe` fieldTypeFromTypeable @UUID
         it "is an implicit ID column" $ asIO $ do
             fieldIsImplicitIdColumn idField `shouldBe` True
 
diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs
index 6e980ad8f..4ba8eaa3d 100644
--- a/persistent-postgresql/Database/Persist/Postgresql.hs
+++ b/persistent-postgresql/Database/Persist/Postgresql.hs
@@ -55,6 +55,7 @@ import qualified Database.PostgreSQL.Simple.Transaction as PG
 import qualified Database.PostgreSQL.Simple.TypeInfo.Static as PS
 import qualified Database.PostgreSQL.Simple.Types as PG
 
+import qualified Data.List.NonEmpty as NEL
 import Control.Arrow
 import Control.Exception (Exception, throw, throwIO)
 import Control.Monad
@@ -390,9 +391,11 @@ prepare' conn sql = do
 
 insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult
 insertSql' ent vals =
-    case entityPrimary ent of
-        Just _pdef -> ISRManyKeys sql vals
-        Nothing -> ISRSingle (sql <> " RETURNING " <> escapeF (fieldDB (getEntityId ent)))
+    case getEntityId ent of
+        EntityIdNaturalKey _pdef ->
+            ISRManyKeys sql vals
+        EntityIdField field ->
+            ISRSingle (sql <> " RETURNING " <> escapeF (fieldDB field))
   where
     (fieldNames, placeholders) = unzip (Util.mkInsertPlaceholders ent escapeF)
     sql = T.concat
@@ -448,7 +451,7 @@ insertManySql' ent valss =
         , ") VALUES ("
         , T.intercalate "),(" $ replicate (length valss) $ T.intercalate "," placeholders
         , ") RETURNING "
-        , Util.commaSeparated $ Util.dbIdColumnsEsc escapeF ent
+        , Util.commaSeparated $ NEL.toList $ Util.dbIdColumnsEsc escapeF ent
         ]
 
 
@@ -860,23 +863,23 @@ addTable cols entity =
             Just _ ->
                 cols
             _ ->
-                filter (\c -> cName c /= fieldDB (getEntityId entity) ) cols
+                filter (\c -> Just (cName c) /= fmap fieldDB (getEntityIdField entity) ) cols
 
     name =
         getEntityDBName entity
     idtxt =
-        case entityPrimary entity of
-            Just pdef ->
+        case getEntityId entity of
+            EntityIdNaturalKey pdef ->
                 T.concat
                     [ " PRIMARY KEY ("
-                    , T.intercalate "," $ map (escapeF . fieldDB) $ compositeFields pdef
+                    , T.intercalate "," $ map (escapeF . fieldDB) $ NEL.toList $ compositeFields pdef
                     , ")"
                     ]
-            Nothing ->
-                let defText = defaultAttribute $ fieldAttrs $ getEntityId entity
-                    sType = fieldSqlType $ getEntityId entity
+            EntityIdField field ->
+                let defText = defaultAttribute $ fieldAttrs field
+                    sType = fieldSqlType field
                 in  T.concat
-                        [ escapeF $ fieldDB (getEntityId entity)
+                        [ escapeF $ fieldDB field
                         , maySerial sType defText
                         , " PRIMARY KEY UNIQUE"
                         , mayDefault defText
@@ -1005,7 +1008,7 @@ safeToRemove :: EntityDef -> FieldNameDB -> Bool
 safeToRemove def (FieldNameDB colName)
     = any (elem FieldAttrSafeToRemove . fieldAttrs)
     $ filter ((== FieldNameDB colName) . fieldDB)
-    $ keyAndEntityFields def
+    $ NEL.toList $ keyAndEntityFields def
 
 getAlters :: [EntityDef]
           -> EntityDef
@@ -1250,13 +1253,13 @@ findAlters defs edef col@(Column name isNull sqltype def _gen _defConstraintName
                 refAdd (Just colRef) =
                     case find ((== crTableName colRef) . getEntityDBName) defs of
                         Just refdef
-                            | _oldName /= fieldDB (getEntityId edef)
+                            | Just _oldName /= fmap fieldDB (getEntityIdField edef)
                             ->
                             [AddReference
                                 (getEntityDBName edef)
                                 (crConstraintName colRef)
                                 [name]
-                                (Util.dbIdColumnsEsc escapeF refdef)
+                                (NEL.toList $ Util.dbIdColumnsEsc escapeF refdef)
                                 (crFieldCascade colRef)
                             ]
                         Just _ -> []
@@ -1269,7 +1272,7 @@ findAlters defs edef col@(Column name isNull sqltype def _gen _defConstraintName
                         else refDrop ref' ++ refAdd ref
                 modNull = case (isNull, isNull') of
                             (True, False) ->  do
-                                guard $ name /= fieldDB (getEntityId edef)
+                                guard $ Just name /= fmap fieldDB (getEntityIdField edef)
                                 pure (IsNull col)
                             (False, True) ->
                                 let up = case def of
@@ -1328,7 +1331,7 @@ getAddReference
     -> ColumnReference
     -> Maybe AlterDB
 getAddReference allDefs entity cname cr@ColumnReference {crTableName = s, crConstraintName=constraintName} = do
-    guard $ cname /= fieldDB (getEntityId entity)
+    guard $ Just cname /= fmap fieldDB (getEntityIdField entity)
     pure $ AlterColumn
         table
         (AddReference s constraintName [cname] id_ (crFieldCascade cr)
@@ -1340,7 +1343,7 @@ getAddReference allDefs entity cname cr@ColumnReference {crTableName = s, crCons
             (error $ "Could not find ID of entity " ++ show s)
             $ do
                 entDef <- find ((== s) . getEntityDBName) allDefs
-                return $ Util.dbIdColumnsEsc escapeF entDef
+                return $ NEL.toList $ Util.dbIdColumnsEsc escapeF entDef
 
 showColumn :: Column -> Text
 showColumn (Column n nu sqlType' def gen _defConstraintName _maxLen _ref) = T.concat
@@ -1661,7 +1664,7 @@ maximumIdentifierLength :: Int
 maximumIdentifierLength = 63
 
 udToPair :: UniqueDef -> (ConstraintNameDB, [FieldNameDB])
-udToPair ud = (uniqueDBName ud, map snd $ uniqueFields ud)
+udToPair ud = (uniqueDBName ud, map snd $ NEL.toList $ uniqueFields ud)
 
 mockMigrate :: [EntityDef]
          -> (Text -> IO Statement)
@@ -1739,13 +1742,13 @@ putManySql :: EntityDef -> Int -> Text
 putManySql ent n = putManySql' conflictColumns fields ent n
   where
     fields = getEntityFieldsDatabase ent
-    conflictColumns = concatMap (map (escapeF . snd) . uniqueFields) (getEntityUniques ent)
+    conflictColumns = concatMap (map (escapeF . snd) . NEL.toList . uniqueFields) (getEntityUniques ent)
 
 repsertManySql :: EntityDef -> Int -> Text
 repsertManySql ent n = putManySql' conflictColumns fields ent n
   where
-    fields = keyAndEntityFields ent
-    conflictColumns = escapeF . fieldDB <$> getEntityKeyFields ent
+    fields = NEL.toList $ keyAndEntityFields ent
+    conflictColumns = NEL.toList $ escapeF . fieldDB <$> getEntityKeyFields ent
 
 -- | This type is used to determine how to update rows using Postgres'
 -- @INSERT ... ON CONFLICT KEY UPDATE@ functionality, exposed via
@@ -1924,7 +1927,7 @@ mkBulkUpsertQuery records conn fieldValues updates filters uniqDef =
     fieldDbToText = escapeF . fieldDB
     entityDef' = entityDef records
     conflictColumns =
-        map (escapeF . snd) $ uniqueFields uniqDef
+        map (escapeF . snd) $ NEL.toList $ uniqueFields uniqDef
     firstField = case entityFieldNames of
         [] -> error "The entity you're trying to insert does not have any fields."
         (field:_) -> field
diff --git a/persistent-postgresql/test/ImplicitUuidSpec.hs b/persistent-postgresql/test/ImplicitUuidSpec.hs
index 4f08b3d5e..68f5fd587 100644
--- a/persistent-postgresql/test/ImplicitUuidSpec.hs
+++ b/persistent-postgresql/test/ImplicitUuidSpec.hs
@@ -58,11 +58,9 @@ spec = describe "ImplicitUuidSpec" $ before_ wipe $ do
             let withDefUuidKey = WithDefUuidKey (UUID "Hello")
             pass
     describe "getEntityId" $ do
-        let idField = getEntityId (entityDef (Proxy @WithDefUuid))
+        let Just idField = getEntityIdField (entityDef (Proxy @WithDefUuid))
         it "has a UUID SqlType" $ asIO $ do
             fieldSqlType idField `shouldBe` SqlOther "UUID"
-        it "has a UUID type" $ asIO $ do
-            fieldType idField `shouldBe` fieldTypeFromTypeable @UUID
         it "is an implicit ID column" $ asIO $ do
             fieldIsImplicitIdColumn idField `shouldBe` True
 
diff --git a/persistent-qq/test/PersistentTestModels.hs b/persistent-qq/test/PersistentTestModels.hs
index db6af42c9..8defbbd6d 100644
--- a/persistent-qq/test/PersistentTestModels.hs
+++ b/persistent-qq/test/PersistentTestModels.hs
@@ -18,10 +18,12 @@ import Data.Aeson
 import Data.Text (Text)
 import Data.Proxy
 
+import qualified Data.List.NonEmpty as NEL
 import Database.Persist.Sql
 import Database.Persist.TH
 import PersistTestPetType
 import PersistTestPetCollarType
+import Data.Foldable (toList)
 
 share
     [ mkPersist sqlSettings { mpsGeneric = True }
@@ -154,7 +156,7 @@ instance (PersistEntity a) => PersistEntity (ReverseFieldOrder a) where
     fromPersistValues = fmap RFO . fromPersistValues . reverse
 
     newtype Unique      (ReverseFieldOrder a)   = URFO  {unURFO  :: Unique      a  }
-    persistUniqueToFieldNames = reverse . persistUniqueToFieldNames . unURFO
+    persistUniqueToFieldNames = NEL.reverse . persistUniqueToFieldNames . unURFO
     persistUniqueToValues = reverse . persistUniqueToValues . unURFO
     persistUniqueKeys = map URFO . reverse . persistUniqueKeys . unRFO
 
diff --git a/persistent-sqlite/Database/Persist/Sqlite.hs b/persistent-sqlite/Database/Persist/Sqlite.hs
index 65743cf03..f6376496a 100644
--- a/persistent-sqlite/Database/Persist/Sqlite.hs
+++ b/persistent-sqlite/Database/Persist/Sqlite.hs
@@ -11,12 +11,14 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeFamilies #-}
+
 -- Strictly, this could go as low as GHC 8.6.1, which is when DerivingVia was
 -- introduced - this base version requires 8.6.5+
 #if MIN_VERSION_base(4,12,0)
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE UndecidableInstances #-}
 #endif
+
 -- | A sqlite backend for persistent.
 --
 -- Note: If you prepend @WAL=off @ to your connection string, it will disable
@@ -78,13 +80,13 @@ import qualified Data.HashMap.Lazy as HashMap
 import Data.Int (Int64)
 import Data.IORef
 import qualified Data.Map as Map
-import Data.Monoid ((<>))
 import Data.Pool (Pool)
 import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.IO as TIO
 import Lens.Micro.TH (makeLenses)
 import UnliftIO.Resource (ResourceT, runResourceT)
+import Data.Foldable (toList)
 
 #if MIN_VERSION_base(4,12,0)
 import Database.Persist.Compatible
@@ -336,8 +338,8 @@ prepare' conn sql = do
 
 insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult
 insertSql' ent vals =
-    case entityPrimary ent of
-        Just _ ->
+    case getEntityId ent of
+        EntityIdNaturalKey _ ->
           ISRManyKeys sql vals
             where sql = T.concat
                     [ "INSERT INTO "
@@ -348,12 +350,12 @@ insertSql' ent vals =
                     , T.intercalate "," (map (const "?") cols)
                     , ")"
                     ]
-        Nothing ->
+        EntityIdField fd ->
           ISRInsertGet ins sel
             where
               sel = T.concat
                   [ "SELECT "
-                  , escapeF $ fieldDB (getEntityId ent)
+                  , escapeF $ fieldDB fd
                   , " FROM "
                   , escapeE $ getEntityDBName ent
                   , " WHERE _ROWID_=last_insert_rowid()"
@@ -375,7 +377,7 @@ insertSql' ent vals =
     notGenerated =
         isNothing . fieldGenerated
     cols =
-        filter notGenerated $ getEntityFieldsDatabase ent
+        filter notGenerated $ getEntityFields ent
 
 execute' :: Sqlite.Connection -> Sqlite.Statement -> [PersistValue] -> IO Int64
 execute' conn stmt vals = flip finally (liftIO $ Sqlite.reset conn stmt) $ do
@@ -570,25 +572,25 @@ mkCreateTable isTemp entity (cols, uniqs, fdefs) =
         , ")"
         ]
 
-    columns = case entityPrimary entity of
-        Just pdef ->
+    columns = case getEntityId entity of
+        EntityIdNaturalKey pdef ->
             [ T.drop 1 $ T.concat $ map (sqlColumn isTemp) cols
             , ", PRIMARY KEY "
             , "("
-            , T.intercalate "," $ map (escapeF . fieldDB) $ compositeFields pdef
+            , T.intercalate "," $ map (escapeF . fieldDB) $ toList $ compositeFields pdef
             , ")"
             ]
 
-        Nothing ->
-            [ escapeF $ fieldDB (getEntityId entity)
+        EntityIdField fd ->
+            [ escapeF $ fieldDB fd
             , " "
-            , showSqlType $ fieldSqlType $ getEntityId entity
+            , showSqlType $ fieldSqlType fd
             , " PRIMARY KEY"
-            , mayDefault $ defaultAttribute $ fieldAttrs $ getEntityId entity
+            , mayDefault $ defaultAttribute $ fieldAttrs fd
             , T.concat $ map (sqlColumn isTemp) nonIdCols
             ]
 
-    nonIdCols = filter (\c -> cName c /= fieldDB (getEntityId entity)) cols
+    nonIdCols = filter (\c -> Just (cName c) /= fmap fieldDB (getEntityIdField entity)) cols
 
 mayDefault :: Maybe Text -> Text
 mayDefault def = case def of
@@ -650,7 +652,7 @@ sqlUnique (UniqueDef _ cname cols _) = T.concat
     [ ",CONSTRAINT "
     , escapeC cname
     , " UNIQUE ("
-    , T.intercalate "," $ map (escapeF . snd) cols
+    , T.intercalate "," $ map (escapeF . snd) $ toList cols
     , ")"
     ]
 
@@ -672,16 +674,16 @@ escape s =
     go c = T.singleton c
 
 putManySql :: EntityDef -> Int -> Text
-putManySql ent n = putManySql' conflictColumns fields ent n
+putManySql ent n = putManySql' conflictColumns (toList fields) ent n
   where
     fields = getEntityFieldsDatabase ent
-    conflictColumns = concatMap (map (escapeF . snd) . uniqueFields) (getEntityUniques ent)
+    conflictColumns = concatMap (map (escapeF . snd) . toList . uniqueFields) (getEntityUniques ent)
 
 repsertManySql :: EntityDef -> Int -> Text
-repsertManySql ent n = putManySql' conflictColumns fields ent n
+repsertManySql ent n = putManySql' conflictColumns (toList fields) ent n
   where
     fields = keyAndEntityFields ent
-    conflictColumns = escapeF . fieldDB <$> getEntityKeyFields ent
+    conflictColumns = escapeF . fieldDB <$> toList (getEntityKeyFields ent)
 
 putManySql' :: [Text] -> [FieldDef] -> EntityDef -> Int -> Text
 putManySql' conflictColumns fields ent n = q
diff --git a/persistent-sqlite/persistent-sqlite.cabal b/persistent-sqlite/persistent-sqlite.cabal
index 1ccc12f1b..41728af7f 100644
--- a/persistent-sqlite/persistent-sqlite.cabal
+++ b/persistent-sqlite/persistent-sqlite.cabal
@@ -114,7 +114,9 @@ test-suite test
     type:            exitcode-stdio-1.0
     main-is:         main.hs
     hs-source-dirs:  test
-    other-modules:   SqliteInit
+    other-modules:   
+        SqliteInit
+        Database.Persist.Sqlite.CompositeSpec
     ghc-options:     -Wall
 
     build-depends:   base >= 4.9 && < 5
diff --git a/persistent-sqlite/test/Database/Persist/Sqlite/CompositeSpec.hs b/persistent-sqlite/test/Database/Persist/Sqlite/CompositeSpec.hs
new file mode 100644
index 000000000..e110de7c1
--- /dev/null
+++ b/persistent-sqlite/test/Database/Persist/Sqlite/CompositeSpec.hs
@@ -0,0 +1,94 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
+
+module Database.Persist.Sqlite.CompositeSpec where
+
+import SqliteInit
+
+import Control.Monad.Reader (MonadReader)
+import Control.Monad.Trans.Resource (MonadResource)
+import qualified Data.Conduit.List as CL
+import Conduit
+import Database.Persist.Sqlite
+import System.IO (hClose)
+import Control.Exception (handle, IOException, throwIO)
+import System.IO.Temp (withSystemTempFile)
+import qualified Data.Text as T
+import qualified Lens.Micro as Lens
+
+share [mkPersist sqlSettings, mkMigrate "compositeSetup"] [persistLowerCase|
+SimpleComposite
+    int Int
+    text Text
+    Primary text int
+    deriving Show Eq
+
+SimpleCompositeReference
+    int Int
+    text Text
+    label Text
+    Foreign SimpleComposite fk_simple_composite text int
+    deriving Show Eq
+|]
+
+share [mkPersist sqlSettings, mkMigrate "compositeMigrateTest"] [persistLowerCase|
+SimpleComposite2 sql=simple_composite
+    int Int
+    text Text
+    new Int default=0
+    Primary text int
+    deriving Show Eq
+
+SimpleCompositeReference2 sql=simple_composite_reference
+    int Int
+    text Text
+    label Text
+    Foreign SimpleComposite2 fk_simple_composite text int
+    deriving Show Eq
+|]
+
+spec :: Spec
+spec = describe "CompositeSpec" $ do
+    it "properly migrates to a composite primary key (issue #669)" $ asIO $ runSqliteInfo (mkSqliteConnectionInfo ":memory:") $ do
+        void $ runMigrationSilent compositeSetup
+        void $ runMigrationSilent compositeMigrateTest
+        pure ()
+    it "test migrating sparse composite primary keys (issue #1184)" $ asIO $ withSystemTempFile "test564.sqlite3"$ \fp h -> do
+        hClose h
+        let connInfo = Lens.set fkEnabled False $ mkSqliteConnectionInfo (T.pack fp)
+
+        runSqliteInfo connInfo $ do
+            void $ runMigrationSilent compositeSetup
+            forM_ [(1,"foo"),(3,"bar")] $ \(intKey, strKey) -> do
+                let key = SimpleCompositeKey strKey intKey
+                insertKey key (SimpleComposite intKey strKey)
+                insert (SimpleCompositeReference intKey strKey "test")
+
+            validateForeignKeys
+
+        runSqliteInfo connInfo $ do
+            void $ runMigrationSilent compositeMigrateTest
+            validateForeignKeys
+
+
+validateForeignKeys
+    :: (MonadResource m, MonadReader env m, BackendCompatible SqlBackend env)
+    => m ()
+validateForeignKeys = do
+    violations <- map (T.pack . show) <$> runConduit (checkForeignKeys .| CL.consume)
+    unless (null violations) . liftIO . throwIO $
+        PersistForeignConstraintUnmet (T.unlines violations)
diff --git a/persistent-sqlite/test/SqliteInit.hs b/persistent-sqlite/test/SqliteInit.hs
index 9c299728e..2c54ec8bd 100644
--- a/persistent-sqlite/test/SqliteInit.hs
+++ b/persistent-sqlite/test/SqliteInit.hs
@@ -104,3 +104,4 @@ runConn f = do
 db :: SqlPersistT (LoggingT (ResourceT IO)) () -> Assertion
 db actions = do
     runResourceT $ runConn $ actions >> transactionUndo
+
diff --git a/persistent-sqlite/test/main.hs b/persistent-sqlite/test/main.hs
index b2e3d5b90..77643a584 100644
--- a/persistent-sqlite/test/main.hs
+++ b/persistent-sqlite/test/main.hs
@@ -70,6 +70,7 @@ import Database.Persist.Sqlite
 import qualified Database.Sqlite as Sqlite
 import PersistentTestModels
 
+import qualified Database.Persist.Sqlite.CompositeSpec as CompositeSpec
 import qualified MigrationTest
 
 type Tuple = (,)
@@ -93,37 +94,6 @@ DataTypeTable no-json
     utc UTCTime
 |]
 
-share [mkPersist sqlSettings, mkMigrate "compositeSetup"] [persistLowerCase|
-SimpleComposite
-    int Int
-    text Text
-    Primary text int
-    deriving Show Eq
-
-SimpleCompositeReference
-    int Int
-    text Text
-    label Text
-    Foreign SimpleComposite fk_simple_composite text int
-    deriving Show Eq
-|]
-
-share [mkPersist sqlSettings, mkMigrate "compositeMigrateTest"] [persistLowerCase|
-SimpleComposite2 sql=simple_composite
-    int Int
-    text Text
-    new Int default=0
-    Primary text int
-    deriving Show Eq
-
-SimpleCompositeReference2 sql=simple_composite_reference
-    int Int
-    text Text
-    label Text
-    Foreign SimpleComposite2 fk_simple_composite text int
-    deriving Show Eq
-|]
-
 share [mkPersist sqlSettings, mkMigrate "idSetup"] [persistLowerCase|
 Simple
     text Text
@@ -207,6 +177,8 @@ main = do
 
 
     hspec $ do
+        describe "Database" $ describe "Persist" $ describe "Sqlite" $ do
+            CompositeSpec.spec
         RenameTest.specsWith db
         DataTypeTest.specsWith
             db
@@ -286,43 +258,6 @@ main = do
             void $ runMigrationSilent migrateAll
             insertMany_ $ replicate 1000 (Test $ read "2014-11-30 05:15:25.123Z")
 
-        it "properly migrates to a composite primary key (issue #669)" $ asIO $ runSqliteInfo (mkSqliteConnectionInfo ":memory:") $ do
-            void $ runMigrationSilent compositeSetup
-            void $ runMigrationSilent compositeMigrateTest
-            pure ()
-
-        it "test migrating sparse primary keys (issue #1184)" $ asIO $ withSystemTempFile "test564.sqlite3"$ \fp h -> do
-            hClose h
-            let connInfo = Lens.set fkEnabled False $ mkSqliteConnectionInfo (T.pack fp)
-            runSqliteInfo connInfo $ do
-                void $ runMigrationSilent idSetup
-                forM_ (map toSqlKey [1,3]) $ \key -> do
-                    insertKey key (Simple "foo")
-                    insert (SimpleReference key "test")
-
-                validateForeignKeys
-
-            runSqliteInfo connInfo $ do
-                void $ runMigrationSilent idMigrateTest
-                validateForeignKeys
-
-        it "test migrating sparse composite primary keys (issue #1184)" $ asIO $ withSystemTempFile "test564.sqlite3"$ \fp h -> do
-            hClose h
-            let connInfo = Lens.set fkEnabled False $ mkSqliteConnectionInfo (T.pack fp)
-
-            runSqliteInfo connInfo $ do
-                void $ runMigrationSilent compositeSetup
-                forM_ [(1,"foo"),(3,"bar")] $ \(intKey, strKey) -> do
-                    let key = SimpleCompositeKey strKey intKey
-                    insertKey key (SimpleComposite intKey strKey)
-                    insert (SimpleCompositeReference intKey strKey "test")
-
-                validateForeignKeys
-
-            runSqliteInfo connInfo $ do
-                void $ runMigrationSilent compositeMigrateTest
-                validateForeignKeys
-
         it "afterException" $ asIO $ runSqliteInfo (mkSqliteConnectionInfo ":memory:") $ do
             void $ runMigrationSilent testMigrate
             let catcher :: forall m. Monad m => SomeException -> m ()
@@ -331,11 +266,3 @@ main = do
             insert_ (Person "A" 1 Nothing) `catch` catcher
             insert_ $ Person "B" 0 Nothing
             return ()
-
-validateForeignKeys
-    :: (MonadResource m, MonadReader env m, BackendCompatible SqlBackend env)
-    => m ()
-validateForeignKeys = do
-    violations <- map (T.pack . show) <$> runConduit (checkForeignKeys .| CL.consume)
-    unless (null violations) . liftIO . throwIO $
-        PersistForeignConstraintUnmet (T.unlines violations)
diff --git a/persistent-test/src/CompositeTest.hs b/persistent-test/src/CompositeTest.hs
index af8a77787..2ec18f726 100644
--- a/persistent-test/src/CompositeTest.hs
+++ b/persistent-test/src/CompositeTest.hs
@@ -7,12 +7,11 @@ module CompositeTest where
 import qualified Data.Map as Map
 import Data.Maybe (isJust)
 
-import Database.Persist.TH (mkDeleteCascade)
 import Init
 
 
 -- mpsGeneric = False is due to a bug or at least lack of a feature in mkKeyTypeDec TH.hs
-share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "compositeMigrate", mkDeleteCascade persistSettings { mpsGeneric = False }] [persistLowerCase|
+share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "compositeMigrate"] [persistLowerCase|
   TestParent
       name  String maxlen=20
       name2 String maxlen=20
@@ -233,6 +232,8 @@ specsWith runDb = describe "composite" $
 
     it "RawSql Entity instance" $ runDb $ do
       key <- insert p1
+      Just x <- get key
+      x @== p1
       newp1 <- rawSql "SELECT ?? FROM test_parent LIMIT 1" []
       [Entity key p1] @== newp1
 
diff --git a/persistent-test/src/GeneratedColumnTestSQL.hs b/persistent-test/src/GeneratedColumnTestSQL.hs
index 0803dd1fd..2eac96d5a 100644
--- a/persistent-test/src/GeneratedColumnTestSQL.hs
+++ b/persistent-test/src/GeneratedColumnTestSQL.hs
@@ -6,7 +6,7 @@ module GeneratedColumnTestSQL (specsWith) where
 import Database.Persist.TH
 import Init
 
-share [mkPersist sqlSettings, mkMigrate "migrate1", mkDeleteCascade sqlSettings] [persistLowerCase|
+share [mkPersist sqlSettings, mkMigrate "migrate1"] [persistLowerCase|
 GenTest sql=gen_test
   fieldOne Text Maybe
   fieldTwo Text Maybe
@@ -18,7 +18,7 @@ MigrateTestV1 sql=gen_migrate_test
   cromulence Int generated=5
 |]
 
-share [mkPersist sqlSettings, mkMigrate "migrate2", mkDeleteCascade sqlSettings] [persistLowerCase|
+share [mkPersist sqlSettings, mkMigrate "migrate2"] [persistLowerCase|
 MigrateTestV2 sql=gen_migrate_test
   sickness Int generated=3
   cromulence Int
diff --git a/persistent-test/src/LongIdentifierTest.hs b/persistent-test/src/LongIdentifierTest.hs
index b8fe3e808..85a6abf22 100644
--- a/persistent-test/src/LongIdentifierTest.hs
+++ b/persistent-test/src/LongIdentifierTest.hs
@@ -18,7 +18,7 @@ import Init
 -- This test creates very long identifier names. The generated foreign key is over the length limit for Postgres and MySQL
 -- persistent-postgresql handles this by truncating foreign key names using the same algorithm that Postgres itself does (see 'refName' in Postgresql.hs)
 -- MySQL currently doesn't run this test, and needs truncation logic for it to pass.
-share [mkPersist sqlSettings, mkMigrate "migration", mkDeleteCascade sqlSettings] [persistLowerCase|
+share [mkPersist sqlSettings, mkMigrate "migration"] [persistLowerCase|
 TableAnExtremelyFantasticallySuperLongNameParent
     field1 Int
 TableAnExtremelyFantasticallySuperLongNameChild
diff --git a/persistent-test/src/MigrationOnlyTest.hs b/persistent-test/src/MigrationOnlyTest.hs
index e40dd9899..850f2aec8 100644
--- a/persistent-test/src/MigrationOnlyTest.hs
+++ b/persistent-test/src/MigrationOnlyTest.hs
@@ -18,7 +18,7 @@ TwoField1 sql=two_field
     deriving Eq Show
 |]
 
-share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "migrateAll2", mkDeleteCascade sqlSettings] [persistLowerCase|
+share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "migrateAll2"] [persistLowerCase|
 TwoField
     field1 Int
     field2 T.Text
@@ -56,6 +56,7 @@ specsWith runDb mmigrate = describe "MigrationOnly field" $ do
             length fields `shouldBe` 3
         it "should have at one migration only field" $ do
             length (filter (not . isHaskellField) fields) `shouldBe` 1
+
     it "doesn't have the field in the Haskell entity" $ asIO $ runDb $ do
         sequence_ mmigrate
         sequence_ mmigrate
diff --git a/persistent-test/src/MigrationTest.hs b/persistent-test/src/MigrationTest.hs
index 40ec86001..7ee8255e0 100644
--- a/persistent-test/src/MigrationTest.hs
+++ b/persistent-test/src/MigrationTest.hs
@@ -7,7 +7,7 @@ import qualified Data.Text as T
 
 import Init
 
-share [mkPersist sqlSettings, mkMigrate "migrationMigrate", mkDeleteCascade sqlSettings] [persistLowerCase|
+share [mkPersist sqlSettings, mkMigrate "migrationMigrate"] [persistLowerCase|
 Target
     field1 Int
     field2 T.Text
@@ -23,7 +23,7 @@ CustomSqlId
     Primary pk
 |]
 
-share [mkPersist sqlSettings, mkMigrate "migrationAddCol", mkDeleteCascade sqlSettings] [persistLowerCase|
+share [mkPersist sqlSettings, mkMigrate "migrationAddCol"] [persistLowerCase|
 Target1 sql=target
     field1 Int
     field2 T.Text
diff --git a/persistent-test/src/PersistentTest.hs b/persistent-test/src/PersistentTest.hs
index 93553b7fc..f1fb19e76 100644
--- a/persistent-test/src/PersistentTest.hs
+++ b/persistent-test/src/PersistentTest.hs
@@ -640,72 +640,3 @@ specsWith runDb = describe "persistent" $ do
       fieldComments nameField
         `shouldBe`
           Just "Fields should be documentable.\n"
-
-  describe "JsonEncoding" $ do
-    let
-      subject =
-        JsonEncoding "Bob" 32
-      subjectEntity =
-        Entity (JsonEncodingKey (jsonEncodingName subject)) subject
-
-    it "encodes without an ID field" $ do
-      toJSON subjectEntity
-        `shouldBe`
-          Object (M.fromList
-            [ ("name", String "Bob")
-            , ("age", toJSON (32 :: Int))
-            , ("id", String "Bob")
-            ])
-
-    it "decodes without an ID field" $ do
-      let
-        json_ = encode . Object . M.fromList $
-          [ ("name", String "Bob")
-          , ("age", toJSON (32 :: Int))
-          ]
-      decode json_
-        `shouldBe`
-          Just subjectEntity
-
-    prop "works with a Primary" $ \jsonEncoding -> do
-      let
-        ent =
-          Entity (JsonEncodingKey (jsonEncodingName jsonEncoding)) jsonEncoding
-      decode (encode ent)
-        `shouldBe`
-          Just ent
-
-    prop "excuse me what" $ \j@JsonEncoding{..} -> do
-      let
-        ent =
-          Entity (JsonEncodingKey jsonEncodingName) j
-      toJSON ent
-        `shouldBe`
-          Object (M.fromList
-            [ ("name", toJSON jsonEncodingName)
-            , ("age", toJSON jsonEncodingAge)
-            , ("id", toJSON jsonEncodingName)
-            ])
-
-    prop "round trip works with composite key" $ \j@JsonEncoding2{..} -> do
-      let
-        key = JsonEncoding2Key jsonEncoding2Name jsonEncoding2Blood
-        ent =
-          Entity key j
-      decode (encode ent)
-        `shouldBe`
-          Just ent
-
-    prop "works with a composite key" $ \j@JsonEncoding2{..} -> do
-      let
-        key = JsonEncoding2Key jsonEncoding2Name jsonEncoding2Blood
-        ent =
-          Entity key j
-      toJSON ent
-        `shouldBe`
-          Object (M.fromList
-            [ ("name", toJSON jsonEncoding2Name)
-            , ("age", toJSON jsonEncoding2Age)
-            , ("blood", toJSON jsonEncoding2Blood)
-            , ("id", toJSON key)
-            ])
diff --git a/persistent-test/src/PersistentTestModels.hs b/persistent-test/src/PersistentTestModels.hs
index 5378e2fbc..08ceec60d 100644
--- a/persistent-test/src/PersistentTestModels.hs
+++ b/persistent-test/src/PersistentTestModels.hs
@@ -6,6 +6,7 @@ module PersistentTestModels where
 
 import Data.Aeson
 
+import qualified Data.List.NonEmpty as NEL
 import Data.Proxy
 import Test.QuickCheck
 import Database.Persist.Sql
@@ -18,7 +19,7 @@ import Data.Text (append)
 -- just need to ensure this compiles
 import PersistentTestModelsImports()
 
-share [mkPersist persistSettings { mpsGeneric = True },  mkMigrate "testMigrate", mkDeleteCascade persistSettings] [persistUpperCase|
+share [mkPersist persistSettings { mpsGeneric = True },  mkMigrate "testMigrate"] [persistUpperCase|
 
 -- Dedented comment
   -- Header-level comment
@@ -140,27 +141,6 @@ NoPrefix2
 
 |]
 
-share [mkMigrate "testNonGenericMigrate", mkPersist sqlSettings] [persistLowerCase|
-JsonEncoding json
-    name Text
-    age  Int
-    Primary name
-    deriving Show Eq
-
-JsonEncoding2 json
-    name Text
-    age Int
-    blood Text
-    Primary name blood
-    deriving Show Eq
-|]
-
-instance Arbitrary JsonEncoding where
-    arbitrary = JsonEncoding <$> arbitrary <*> arbitrary
-
-instance Arbitrary JsonEncoding2 where
-    arbitrary = JsonEncoding2 <$> arbitrary <*> arbitrary <*> arbitrary
-
 deriving instance Show (BackendKey backend) => Show (NoPrefix1Generic backend)
 deriving instance Eq (BackendKey backend) => Eq (NoPrefix1Generic backend)
 
@@ -233,9 +213,9 @@ instance (PersistEntity a) => PersistEntity (ReverseFieldOrder a) where
     fromPersistValues = fmap RFO . fromPersistValues . reverse
 
     newtype Unique      (ReverseFieldOrder a)   = URFO  {unURFO  :: Unique      a  }
-    persistUniqueToFieldNames = reverse . persistUniqueToFieldNames . unURFO
+    persistUniqueToFieldNames = NEL.reverse . persistUniqueToFieldNames . unURFO
     persistUniqueToValues = reverse . persistUniqueToValues . unURFO
-    persistUniqueKeys = map URFO . reverse . persistUniqueKeys . unRFO
+    persistUniqueKeys = fmap URFO . reverse . persistUniqueKeys . unRFO
 
     persistIdField = error "ReverseFieldOrder.persistIdField"
     fieldLens = error "ReverseFieldOrder.fieldLens"
diff --git a/persistent-test/src/RenameTest.hs b/persistent-test/src/RenameTest.hs
index 9e2a35443..051497b8e 100644
--- a/persistent-test/src/RenameTest.hs
+++ b/persistent-test/src/RenameTest.hs
@@ -75,9 +75,9 @@ specsWith
 specsWith runDb = describe "rename specs" $ do
     describe "LowerCaseTable" $ do
         it "LowerCaseTable has the right sql name" $ do
-            fieldDB (getEntityId (entityDef (Proxy @LowerCaseTable)))
+            fmap fieldDB (getEntityIdField (entityDef (Proxy @LowerCaseTable)))
                 `shouldBe`
-                    FieldNameDB "my_id"
+                    Just (FieldNameDB "my_id")
 
     it "user specified id, insertKey, no default=" $ runDb $ do
         let rec2 = IdTable "Foo2" Nothing
diff --git a/persistent-test/src/TreeTest.hs b/persistent-test/src/TreeTest.hs
index e97119c67..ce14f5c7c 100644
--- a/persistent-test/src/TreeTest.hs
+++ b/persistent-test/src/TreeTest.hs
@@ -5,15 +5,13 @@ module TreeTest where
 
 import Init
 
-import Database.Persist.TH (mkDeleteCascade)
-
 
 -- mpsGeneric = False is due to a bug or at least lack of a feature in
 -- mkKeyTypeDec TH.hs
 share
     [ mkPersist persistSettings { mpsGeneric = False }
     , mkMigrate "treeMigrate"
-    , mkDeleteCascade persistSettings { mpsGeneric = False } ] [persistLowerCase|
+    ] [persistLowerCase|
   Tree sql=trees
       name    Text
       parent  Text Maybe
@@ -60,7 +58,7 @@ specsWith runDb = describe "tree" $ do
                 ConstraintNameHS "fkparent"
         it "has the right DB constraint name" $ do
             foreignConstraintNameDBName `shouldBe`
-                ConstraintNameDB "treesfkparent"
+                ConstraintNameDB "treefkparent"
         it "has the right fields" $ do
             foreignFields `shouldBe`
                 [ ( (FieldNameHS "parent", FieldNameDB "parent")
diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md
index 96274c860..0b43685f9 100644
--- a/persistent/ChangeLog.md
+++ b/persistent/ChangeLog.md
@@ -70,15 +70,26 @@
       facilitating a solution to your problem.
 * [#1255](https://github.com/yesodweb/persistent/pull/1255)
     * `mkPersist` now checks to see if an instance already exists for
-      `PersistEntity` for the inputs. This allows you to pass `EntityDef`s into
-      `mkPersist` which have been previously defined, which allows the foreign
-      field information to be generated more reliably across modules.
+      `PersistEntity` for the inputs.
 * [#1243](https://github.com/yesodweb/persistent/pull/1243)
     * Assorted cleanup of TH module
 * [1242](https://github.com/yesodweb/persistent/pull/1242)
     * Refactor setEmbedField to use do notation
 * [#1237](https://github.com/yesodweb/persistent/pull/1237)
     * Remove nonEmptyOrFail function from recent tests
+* [#1256](https://github.com/yesodweb/persistent/pull/1256)
+    * The QuasiQuoter has been refactored and improved.
+    * You can now use `mkPersistWith` to pass in a list of pre-existing
+      `EntityDef` to improve foreign key detection and splitting up models
+      across multiple modules.
+    * The `entityId` field now returns an `EntityIdDef`, which specifies what
+      the ID field actually is. This is a move to better support natural keys.
+    * Several types that had lists have been refactored to use nonempty lists to
+      better capture the semantics.
+    * `mkDeleteCascade` is deprecated. Please use the Cascade behavior directly
+      on fields.
+    * You can use `Key Foo` and `FooId` interchangeably in fields.
+    * Support for GHC < 8.4 dropped.
 
 ## 2.12.1.1
 
diff --git a/persistent/Database/Persist/Class/DeleteCascade.hs b/persistent/Database/Persist/Class/DeleteCascade.hs
index 88cc472ec..4ab445994 100644
--- a/persistent/Database/Persist/Class/DeleteCascade.hs
+++ b/persistent/Database/Persist/Class/DeleteCascade.hs
@@ -1,5 +1,7 @@
 {-# LANGUAGE ExplicitForAll #-}
-module Database.Persist.Class.DeleteCascade
+
+
+module Database.Persist.Class.DeleteCascade {-# DEPRECATED "The DeleteCascade module is deprecated. You can now set cascade behavior directly on entities in the quasiquoter." #-}
     ( DeleteCascade (..)
     , deleteCascadeWhere
     ) where
@@ -14,6 +16,8 @@ import Database.Persist.Class.PersistStore
 import Database.Persist.Class.PersistQuery
 import Database.Persist.Class.PersistEntity
 
+{-# DEPRECATED DeleteCascade "The DeleteCascade class is deprecated since you can now define cascade behavior directly on an entity." #-}
+
 -- | For combinations of backends and entities that support
 -- cascade-deletion. “Cascade-deletion” means that entries that depend on
 -- other entries to be deleted will be deleted as well.
@@ -24,6 +28,8 @@ class (PersistStoreWrite backend, PersistEntity record, BaseBackend backend ~ Pe
     -- entry.
     deleteCascade :: MonadIO m => Key record -> ReaderT backend m ()
 
+{-# DEPRECATED deleteCascadeWhere "This function is deprecated since you can set cascading delete behavior directly on the entity." #-}
+
 -- | Cascade-deletion of entries satisfying given filters.
 deleteCascadeWhere :: forall record backend m. (MonadIO m, DeleteCascade record backend, PersistQueryWrite backend)
                    => [Filter record] -> ReaderT backend m ()
diff --git a/persistent/Database/Persist/Class/PersistEntity.hs b/persistent/Database/Persist/Class/PersistEntity.hs
index b50095444..61629ff00 100644
--- a/persistent/Database/Persist/Class/PersistEntity.hs
+++ b/persistent/Database/Persist/Class/PersistEntity.hs
@@ -1,15 +1,15 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE AllowAmbiguousTypes #-}
 
 module Database.Persist.Class.PersistEntity
     ( PersistEntity (..)
@@ -32,12 +32,22 @@ module Database.Persist.Class.PersistEntity
     , SymbolToField (..)
     ) where
 
-import Data.Aeson (ToJSON (..), withObject, FromJSON (..), fromJSON, object, (.:), (.=), Value (Object))
+import Data.Aeson
+       ( FromJSON(..)
+       , ToJSON(..)
+       , Value(Object)
+       , fromJSON
+       , object
+       , withObject
+       , (.:)
+       , (.=)
+       )
 import qualified Data.Aeson.Parser as AP
-import Data.Aeson.Types (Parser,Result(Error,Success))
 import Data.Aeson.Text (encodeToTextBuilder)
+import Data.Aeson.Types (Parser, Result(Error, Success))
 import Data.Attoparsec.ByteString (parseOnly)
 import qualified Data.HashMap.Strict as HM
+import Data.List.NonEmpty (NonEmpty(..))
 import Data.Maybe (isJust)
 import Data.Monoid (mappend)
 import Data.Text (Text)
@@ -50,8 +60,8 @@ import GHC.OverloadedLabels
 import GHC.TypeLits
 
 import Database.Persist.Class.PersistField
-import Database.Persist.Types.Base
 import Database.Persist.Names
+import Database.Persist.Types.Base
 
 -- | Persistent serialized Haskell records to the database.
 -- A Database 'Entity' (A row in SQL, a document in MongoDB, etc)
@@ -105,7 +115,7 @@ class ( PersistField (Key record), ToJSON (Key record), FromJSON (Key record)
     -- | A meta operation to retrieve all the 'Unique' keys.
     persistUniqueKeys :: record -> [Unique record]
     -- | A lower level operation.
-    persistUniqueToFieldNames :: Unique record -> [(FieldNameHS, FieldNameDB)]
+    persistUniqueToFieldNames :: Unique record -> NonEmpty (FieldNameHS, FieldNameDB)
     -- | A lower level operation.
     persistUniqueToValues :: Unique record -> [PersistValue]
 
diff --git a/persistent/Database/Persist/Class/PersistUnique.hs b/persistent/Database/Persist/Class/PersistUnique.hs
index f2597f12b..4399f8546 100644
--- a/persistent/Database/Persist/Class/PersistUnique.hs
+++ b/persistent/Database/Persist/Class/PersistUnique.hs
@@ -39,7 +39,6 @@ import GHC.TypeLits (ErrorMessage(..))
 import Database.Persist.Class.PersistEntity
 import Database.Persist.Class.PersistStore
 import Database.Persist.Types
-import Database.Persist.EntityDef
 
 -- | Queries against 'Unique' keys (other than the id 'Key').
 --
diff --git a/persistent/Database/Persist/EntityDef.hs b/persistent/Database/Persist/EntityDef.hs
index 68b5c72eb..aba4a12fa 100644
--- a/persistent/Database/Persist/EntityDef.hs
+++ b/persistent/Database/Persist/EntityDef.hs
@@ -14,6 +14,7 @@ module Database.Persist.EntityDef
     , getEntityForeignDefs
     , getEntityUniques
     , getEntityId
+    , getEntityIdField
     , getEntityKeyFields
     , getEntityComments
     , getEntityExtra
@@ -23,20 +24,23 @@ module Database.Persist.EntityDef
     , keyAndEntityFields
      -- * Setters
     , setEntityId
+    , setEntityIdDef
     , setEntityDBName
     , overEntityFields
+      -- * Related Types
+    , EntityIdDef(..)
     ) where
 
 import Data.Text (Text)
 import Data.Map (Map)
+import Data.List.NonEmpty (NonEmpty)
 
 import Database.Persist.EntityDef.Internal
-import Database.Persist.FieldDef (isHaskellField)
+import Database.Persist.FieldDef
 
 import Database.Persist.Types.Base
     ( UniqueDef
     , ForeignDef
-    , FieldDef
     , entityKeyFields
     )
 import Database.Persist.Names
@@ -131,18 +135,44 @@ isEntitySum = entitySum
 -- @since 2.13.0.0
 getEntityId
     :: EntityDef
-    -> FieldDef
+    -> EntityIdDef
 getEntityId = entityId
 
+-- |
+--
+-- @since 2.13.0.0
+getEntityIdField :: EntityDef -> Maybe FieldDef
+getEntityIdField ed =
+    case getEntityId ed of
+        EntityIdField fd ->
+            pure fd
+        _ ->
+            Nothing
+
+-- | Set an 'entityId' to be the given 'FieldDef'.
+--
+-- @since 2.13.0.0
 setEntityId
     :: FieldDef
     -> EntityDef
     -> EntityDef
-setEntityId fd ed = ed { entityId = fd }
+setEntityId fd = setEntityIdDef (EntityIdField fd)
 
+-- |
+--
+-- @since 2.13.0.0
+setEntityIdDef
+    :: EntityIdDef
+    -> EntityDef
+    -> EntityDef
+setEntityIdDef i ed = ed { entityId = i }
+
+-- |
+--
+-- @since 2.13.0.0
 getEntityKeyFields
     :: EntityDef
-    -> [FieldDef]
+    -> NonEmpty FieldDef
 getEntityKeyFields = entityKeyFields
 
 -- | TODO
diff --git a/persistent/Database/Persist/EntityDef/Internal.hs b/persistent/Database/Persist/EntityDef/Internal.hs
index 38af021bc..16adf92e0 100644
--- a/persistent/Database/Persist/EntityDef/Internal.hs
+++ b/persistent/Database/Persist/EntityDef/Internal.hs
@@ -12,6 +12,7 @@ module Database.Persist.EntityDef.Internal
     , entitiesPrimary
     , keyAndEntityFields
     , toEmbedEntityDef
+    , EntityIdDef(..)
     ) where
 
 import Database.Persist.Types.Base
diff --git a/persistent/Database/Persist/FieldDef.hs b/persistent/Database/Persist/FieldDef.hs
index 183883900..fed4c3f81 100644
--- a/persistent/Database/Persist/FieldDef.hs
+++ b/persistent/Database/Persist/FieldDef.hs
@@ -4,6 +4,10 @@
 module Database.Persist.FieldDef
     ( -- * The 'FieldDef' type
       FieldDef
+      -- ** Setters
+    , setFieldAttrs
+    , overFieldAttrs
+    , addFieldAttr
       -- ** Helpers
     , isFieldNotGenerated
     , isHaskellField
@@ -19,5 +23,23 @@ import Database.Persist.FieldDef.Internal
 
 import Database.Persist.Types.Base
     ( isHaskellField
+    , FieldAttr
     )
 
+-- | Replace the 'FieldDef' 'FieldAttr' with the new list.
+--
+-- @since 2.13.0.0
+setFieldAttrs :: [FieldAttr] -> FieldDef -> FieldDef
+setFieldAttrs fas fd = fd { fieldAttrs = fas }
+
+-- | Modify the list of field attributes.
+--
+-- @since 2.13.0.0
+overFieldAttrs :: ([FieldAttr] -> [FieldAttr]) -> FieldDef -> FieldDef
+overFieldAttrs k fd = fd { fieldAttrs = k (fieldAttrs fd) }
+
+-- | Add an attribute to the list of field attributes.
+--
+-- @since 2.13.0.0
+addFieldAttr :: FieldAttr -> FieldDef -> FieldDef
+addFieldAttr fa = overFieldAttrs (fa :)
diff --git a/persistent/Database/Persist/PersistValue.hs b/persistent/Database/Persist/PersistValue.hs
new file mode 100644
index 000000000..0317a7189
--- /dev/null
+++ b/persistent/Database/Persist/PersistValue.hs
@@ -0,0 +1,253 @@
+{-# LANGUAGE PatternSynonyms #-}
+
+-- | This module contains an intermediate representation of values before the
+-- backends serialize them into explicit database types.
+--
+-- @since 2.13.0.0
+module Database.Persist.PersistValue
+    ( module Database.Persist.PersistValue
+    , PersistValue(.., PersistLiteral, PersistLiteralEscaped, PersistDbSpecific)
+    ) where
+
+import qualified Data.ByteString.Base64 as B64
+import qualified Data.Text.Encoding as TE
+import qualified Data.ByteString.Char8 as BS8
+import qualified Data.Vector as V
+import Data.Int (Int64)
+import qualified Data.Scientific
+import Data.Text.Encoding.Error (lenientDecode)
+import Data.Bits (shiftL, shiftR)
+import Control.Arrow (second)
+import Numeric (readHex, showHex)
+import qualified Data.Text as Text
+import Data.Text (Text)
+import Data.ByteString (ByteString, foldl')
+import Data.Time (Day, TimeOfDay, UTCTime)
+import Web.PathPieces (PathPiece(..))
+import qualified Data.Aeson as A
+import qualified Data.ByteString as BS
+import qualified Data.HashMap.Strict as HM
+import Web.HttpApiData
+       ( FromHttpApiData(..)
+       , ToHttpApiData(..)
+       , parseUrlPieceMaybe
+       , readTextData
+       )
+
+-- | A raw value which can be stored in any backend and can be marshalled to
+-- and from a 'PersistField'.
+data PersistValue
+    = PersistText Text
+    | PersistByteString ByteString
+    | PersistInt64 Int64
+    | PersistDouble Double
+    | PersistRational Rational
+    | PersistBool Bool
+    | PersistDay Day
+    | PersistTimeOfDay TimeOfDay
+    | PersistUTCTime UTCTime
+    | PersistNull
+    | PersistList [PersistValue]
+    | PersistMap [(Text, PersistValue)]
+    | PersistObjectId ByteString
+    -- ^ Intended especially for MongoDB backend
+    | PersistArray [PersistValue]
+    -- ^ Intended especially for PostgreSQL backend for text arrays
+    | PersistLiteral_ LiteralType ByteString
+    -- ^ This constructor is used to specify some raw literal value for the
+    -- backend. The 'LiteralType' value specifies how the value should be
+    -- escaped. This can be used to make special, custom types avaialable
+    -- in the back end.
+    --
+    -- @since 2.12.0.0
+    deriving (Show, Read, Eq, Ord)
+
+-- | A type that determines how a backend should handle the literal.
+--
+-- @since 2.12.0.0
+data LiteralType
+    = Escaped
+    -- ^ The accompanying value will be escaped before inserting into the
+    -- database. This is the correct default choice to use.
+    --
+    -- @since 2.12.0.0
+    | Unescaped
+    -- ^ The accompanying value will not be escaped when inserting into the
+    -- database. This is potentially dangerous - use this with care.
+    --
+    -- @since 2.12.0.0
+    | DbSpecific
+    -- ^ The 'DbSpecific' constructor corresponds to the legacy
+    -- 'PersistDbSpecific' constructor. We need to keep this around because
+    -- old databases may have serialized JSON representations that
+    -- reference this. We don't want to break the ability of a database to
+    -- load rows.
+    --
+    -- @since 2.12.0.0
+    deriving (Show, Read, Eq, Ord)
+
+-- | This pattern synonym used to be a data constructor for the
+-- 'PersistValue' type. It was changed to be a pattern so that JSON-encoded
+-- database values could be parsed into their corresponding values. You
+-- should not use this, and instead prefer to pattern match on
+-- `PersistLiteral_` directly.
+--
+-- If you use this, it will overlap a patern match on the 'PersistLiteral_,
+-- 'PersistLiteral', and 'PersistLiteralEscaped' patterns. If you need to
+-- disambiguate between these constructors, pattern match on
+-- 'PersistLiteral_' directly.
+--
+-- @since 2.12.0.0
+pattern PersistDbSpecific :: ByteString -> PersistValue
+pattern PersistDbSpecific bs <- PersistLiteral_ _ bs where
+    PersistDbSpecific bs = PersistLiteral_ DbSpecific bs
+
+-- | This pattern synonym used to be a data constructor on 'PersistValue',
+-- but was changed into a catch-all pattern synonym to allow backwards
+-- compatiblity with database types. See the documentation on
+-- 'PersistDbSpecific' for more details.
+--
+-- @since 2.12.0.0
+pattern PersistLiteralEscaped :: ByteString -> PersistValue
+pattern PersistLiteralEscaped bs <- PersistLiteral_ _ bs where
+    PersistLiteralEscaped bs = PersistLiteral_ Escaped bs
+
+-- | This pattern synonym used to be a data constructor on 'PersistValue',
+-- but was changed into a catch-all pattern synonym to allow backwards
+-- compatiblity with database types. See the documentation on
+-- 'PersistDbSpecific' for more details.
+--
+-- @since 2.12.0.0
+pattern PersistLiteral :: ByteString -> PersistValue
+pattern PersistLiteral bs <- PersistLiteral_ _ bs where
+    PersistLiteral bs = PersistLiteral_ Unescaped bs
+
+{-# DEPRECATED PersistDbSpecific "Deprecated since 2.11 because of inconsistent escaping behavior across backends. The Postgres backend escapes these values, while the MySQL backend does not. If you are using this, please switch to 'PersistLiteral_' and provide a relevant 'LiteralType' for your conversion." #-}
+
+instance ToHttpApiData PersistValue where
+    toUrlPiece val =
+        case fromPersistValueText val of
+            Left  e -> error $ Text.unpack e
+            Right y -> y
+
+instance FromHttpApiData PersistValue where
+    parseUrlPiece input =
+          PersistInt64 <$> parseUrlPiece input
+      <!> PersistList  <$> readTextData input
+      <!> PersistText  <$> return input
+      where
+        infixl 3 <!>
+        Left _ <!> y = y
+        x      <!> _ = x
+
+instance PathPiece PersistValue where
+  toPathPiece   = toUrlPiece
+  fromPathPiece = parseUrlPieceMaybe
+
+fromPersistValueText :: PersistValue -> Either Text Text
+fromPersistValueText (PersistText s) = Right s
+fromPersistValueText (PersistByteString bs) =
+    Right $ TE.decodeUtf8With lenientDecode bs
+fromPersistValueText (PersistInt64 i) = Right $ Text.pack $ show i
+fromPersistValueText (PersistDouble d) = Right $ Text.pack $ show d
+fromPersistValueText (PersistRational r) = Right $ Text.pack $ show r
+fromPersistValueText (PersistDay d) = Right $ Text.pack $ show d
+fromPersistValueText (PersistTimeOfDay d) = Right $ Text.pack $ show d
+fromPersistValueText (PersistUTCTime d) = Right $ Text.pack $ show d
+fromPersistValueText PersistNull = Left "Unexpected null"
+fromPersistValueText (PersistBool b) = Right $ Text.pack $ show b
+fromPersistValueText (PersistList _) = Left "Cannot convert PersistList to Text"
+fromPersistValueText (PersistMap _) = Left "Cannot convert PersistMap to Text"
+fromPersistValueText (PersistObjectId _) = Left "Cannot convert PersistObjectId to Text"
+fromPersistValueText (PersistArray _) = Left "Cannot convert PersistArray to Text"
+fromPersistValueText (PersistLiteral_ _ _) = Left "Cannot convert PersistLiteral to Text"
+
+instance A.ToJSON PersistValue where
+    toJSON (PersistText t) = A.String $ Text.cons 's' t
+    toJSON (PersistByteString b) = A.String $ Text.cons 'b' $ TE.decodeUtf8 $ B64.encode b
+    toJSON (PersistInt64 i) = A.Number $ fromIntegral i
+    toJSON (PersistDouble d) = A.Number $ Data.Scientific.fromFloatDigits d
+    toJSON (PersistRational r) = A.String $ Text.pack $ 'r' : show r
+    toJSON (PersistBool b) = A.Bool b
+    toJSON (PersistTimeOfDay t) = A.String $ Text.pack $ 't' : show t
+    toJSON (PersistUTCTime u) = A.String $ Text.pack $ 'u' : show u
+    toJSON (PersistDay d) = A.String $ Text.pack $ 'd' : show d
+    toJSON PersistNull = A.Null
+    toJSON (PersistList l) = A.Array $ V.fromList $ map A.toJSON l
+    toJSON (PersistMap m) = A.object $ map (second A.toJSON) m
+    toJSON (PersistLiteral_ litTy b) =
+        let encoded = TE.decodeUtf8 $ B64.encode b
+            prefix =
+                case litTy of
+                    DbSpecific -> 'p'
+                    Unescaped -> 'l'
+                    Escaped -> 'e'
+         in
+            A.String $ Text.cons prefix encoded
+    toJSON (PersistArray a) = A.Array $ V.fromList $ map A.toJSON a
+    toJSON (PersistObjectId o) =
+      A.toJSON $ showChar 'o' $ showHexLen 8 (bs2i four) $ showHexLen 16 (bs2i eight) ""
+        where
+         (four, eight) = BS8.splitAt 4 o
+
+         -- taken from crypto-api
+         bs2i :: ByteString -> Integer
+         bs2i bs = foldl' (\i b -> (i `shiftL` 8) + fromIntegral b) 0 bs
+         {-# INLINE bs2i #-}
+
+         -- showHex of n padded with leading zeros if necessary to fill d digits
+         -- taken from Data.BSON
+         showHexLen :: (Show n, Integral n) => Int -> n -> ShowS
+         showHexLen d n = showString (replicate (d - sigDigits n) '0') . showHex n  where
+             sigDigits 0 = 1
+             sigDigits n' = truncate (logBase (16 :: Double) $ fromIntegral n') + 1
+
+instance A.FromJSON PersistValue where
+    parseJSON (A.String t0) =
+        case Text.uncons t0 of
+            Nothing -> fail "Null string"
+            Just ('p', t) -> either (\_ -> fail "Invalid base64") (return . PersistDbSpecific)
+                           $ B64.decode $ TE.encodeUtf8 t
+            Just ('l', t) -> either (\_ -> fail "Invalid base64") (return . PersistLiteral)
+                           $ B64.decode $ TE.encodeUtf8 t
+            Just ('e', t) -> either (\_ -> fail "Invalid base64") (return . PersistLiteralEscaped)
+                           $ B64.decode $ TE.encodeUtf8 t
+            Just ('s', t) -> return $ PersistText t
+            Just ('b', t) -> either (\_ -> fail "Invalid base64") (return . PersistByteString)
+                           $ B64.decode $ TE.encodeUtf8 t
+            Just ('t', t) -> PersistTimeOfDay <$> readMay t
+            Just ('u', t) -> PersistUTCTime <$> readMay t
+            Just ('d', t) -> PersistDay <$> readMay t
+            Just ('r', t) -> PersistRational <$> readMay t
+            Just ('o', t) -> maybe
+                (fail "Invalid base64")
+                (return . PersistObjectId . i2bs (8 * 12) . fst)
+                $ headMay $ readHex $ Text.unpack t
+            Just (c, _) -> fail $ "Unknown prefix: " ++ [c]
+      where
+        headMay []    = Nothing
+        headMay (x:_) = Just x
+        readMay t =
+            case reads $ Text.unpack t of
+                (x, _):_ -> return x
+                [] -> fail "Could not read"
+
+        -- taken from crypto-api
+        -- |@i2bs bitLen i@ converts @i@ to a 'ByteString' of @bitLen@ bits (must be a multiple of 8).
+        i2bs :: Int -> Integer -> ByteString
+        i2bs l i = BS.unfoldr (\l' -> if l' < 0 then Nothing else Just (fromIntegral (i `shiftR` l'), l' - 8)) (l-8)
+        {-# INLINE i2bs #-}
+
+
+    parseJSON (A.Number n) = return $
+        if fromInteger (floor n) == n
+            then PersistInt64 $ floor n
+            else PersistDouble $ fromRational $ toRational n
+    parseJSON (A.Bool b) = return $ PersistBool b
+    parseJSON A.Null = return PersistNull
+    parseJSON (A.Array a) = fmap PersistList (mapM A.parseJSON $ V.toList a)
+    parseJSON (A.Object o) =
+        fmap PersistMap $ mapM go $ HM.toList o
+      where
+        go (k, v) = (,) k <$> A.parseJSON v
+
diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs
index 7e3a898e3..e6c843b7a 100644
--- a/persistent/Database/Persist/Quasi/Internal.hs
+++ b/persistent/Database/Persist/Quasi/Internal.hs
@@ -1,8 +1,10 @@
 {-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveLift #-}
 {-# LANGUAGE PatternGuards #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE StrictData #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE ViewPatterns #-}
 
@@ -27,13 +29,30 @@ module Database.Persist.Quasi.Internal
     , LinesWithComments(..)
     , splitExtras
     , takeColsEx
+    -- * UnboundEntityDef
+    , UnboundEntityDef(..)
+    , getUnboundEntityNameHS
+    , unbindEntityDef
+    , getUnboundFieldDefs
+    , UnboundForeignDef(..)
+    , getSqlNameOr
+    , UnboundFieldDef(..)
+    , UnboundCompositeDef(..)
+    , UnboundIdDef(..)
+    , unbindFieldDef
+    , unboundIdDefToFieldDef
+    , PrimarySpec(..)
+    , mkAutoIdField'
+    , UnboundForeignFieldList(..)
+    , ForeignFieldReference(..)
+    , mkKeyConType
+    , isHaskellUnboundField
     ) where
 
 import Prelude hiding (lines)
 
 import Control.Applicative (Alternative((<|>)))
-import Control.Arrow ((&&&))
-import Control.Monad (mplus, msum)
+import Control.Monad (mplus)
 import Data.Char (isLower, isSpace, isUpper, toLower)
 import Data.List (find, foldl')
 import Data.List.NonEmpty (NonEmpty(..))
@@ -41,14 +60,11 @@ import qualified Data.List.NonEmpty as NEL
 import qualified Data.Map as M
 import Data.Maybe (fromMaybe, listToMaybe, mapMaybe, maybeToList)
 import Data.Monoid (mappend)
-#if !MIN_VERSION_base(4,11,0)
--- This can be removed when GHC < 8.2.2 isn't supported anymore
-import Data.Semigroup ((<>))
-#endif
 import Data.Text (Text)
 import qualified Data.Text as T
 import Database.Persist.EntityDef.Internal
 import Database.Persist.Types
+import Language.Haskell.TH.Syntax (Lift)
 import Text.Read (readEither)
 
 data ParseState a = PSDone | PSFail String | PSSuccess a Text deriving Show
@@ -143,7 +159,7 @@ toFKNameInfixed inf (EntityNameHS entName) (ConstraintNameHS conName) =
     entName <> inf <> conName
 
 -- | Parses a quasi-quoted syntax into a list of entity definitions.
-parse :: PersistSettings -> Text -> [EntityDef]
+parse :: PersistSettings -> Text -> [UnboundEntityDef]
 parse ps = maybe [] (parseLines ps) . preparse
 
 preparse :: Text -> Maybe (NonEmpty Line)
@@ -236,9 +252,9 @@ lowestIndent :: NonEmpty Line -> Int
 lowestIndent = minimum . fmap lineIndent
 
 -- | Divide lines into blocks and make entity definitions.
-parseLines :: PersistSettings -> NonEmpty Line -> [EntityDef]
+parseLines :: PersistSettings -> NonEmpty Line -> [UnboundEntityDef]
 parseLines ps = do
-    fixForeignKeysAll . fmap (mkEntityDef ps . toParsedEntityDef) . associateLines
+    fmap (mkUnboundEntityDef ps . toParsedEntityDef) . associateLines
 
 data ParsedEntityDef = ParsedEntityDef
     { parsedEntityDefComments :: [Text]
@@ -293,11 +309,17 @@ data LinesWithComments = LinesWithComments
     , lwcComments :: [Text]
     } deriving (Eq, Show)
 
--- TODO: drop this and use <> when 8.2 isn't supported anymore so the
--- monoid/semigroup nonsense isn't annoying
+instance Semigroup LinesWithComments where
+    a <> b =
+        LinesWithComments
+            { lwcLines =
+                foldr NEL.cons (lwcLines b) (lwcLines a)
+            , lwcComments =
+                lwcComments a `mappend` lwcComments b
+            }
+
 appendLwc :: LinesWithComments -> LinesWithComments -> LinesWithComments
-appendLwc a b =
-    LinesWithComments (foldr NEL.cons (lwcLines b) (lwcLines a)) (lwcComments a `mappend` lwcComments b)
+appendLwc = (<>)
 
 newLine :: Line -> LinesWithComments
 newLine l = LinesWithComments (pure l) []
@@ -349,142 +371,294 @@ associateLines lines =
 
     minimumIndentOf = lowestIndent . lwcLines
 
-fixForeignKeysAll :: [UnboundEntityDef] -> [EntityDef]
-fixForeignKeysAll unEnts = map fixForeignKeys unEnts
-  where
-    ents = map unboundEntityDef unEnts
-    entLookup = M.fromList $ map (\e -> (entityHaskell e, e)) ents
-
-    fixForeignKeys :: UnboundEntityDef -> EntityDef
-    fixForeignKeys (UnboundEntityDef foreigns ent) =
-      ent { entityForeigns = map (fixForeignKey ent) foreigns }
-
-    -- check the count and the sqltypes match and update the foreignFields with
-    -- the names of the referenced columns
-    fixForeignKey :: EntityDef -> UnboundForeignDef -> ForeignDef
-    fixForeignKey ent (UnboundForeignDef foreignFieldTexts parentFieldTexts fdef) =
-        let
-            errorNoPrimaryKeyFound =
-                error $ "no primary key found fdef="++show fdef++ " ent="++show ent
-            fdefs =
-                fromMaybe errorNoPrimaryKeyFound mfdefs
-            pentError =
-                error $ "could not find table " ++ show (foreignRefTableHaskell fdef)
-                ++ " fdef=" ++ show fdef ++ " allnames="
-                ++ show (map (unEntityNameHS . entityHaskell . unboundEntityDef) unEnts)
-                ++ "\n\nents=" ++ show ents
-            pent =
-                fromMaybe pentError $ M.lookup (foreignRefTableHaskell fdef) entLookup
-            mfdefs =
-                case parentFieldTexts of
-                    [] -> entitiesPrimary pent
-                    _  -> Just $ map (getFieldDef pent . FieldNameHS) parentFieldTexts
-        in
-             if length foreignFieldTexts /= length fdefs
-             then
-                 lengthError fdefs
-             else
-                 let
-                     fds_ffs =
-                         zipWith toForeignFields
-                             foreignFieldTexts
-                             fdefs
-                     dbname =
-                         unEntityNameDB (entityDB pent)
-                     oldDbName =
-                         unEntityNameDB (foreignRefTableDBName fdef)
-                  in
-                      fdef
-                          { foreignFields = map snd fds_ffs
-                          , foreignNullable = setNull $ map fst fds_ffs
-                          , foreignRefTableDBName =
-                              EntityNameDB dbname
-                          , foreignConstraintNameDBName =
-                              ConstraintNameDB
-                              . T.replace oldDbName dbname . unConstraintNameDB
-                              $ foreignConstraintNameDBName fdef
-                          }
-      where
-        setNull :: [FieldDef] -> Bool
-        setNull [] =
-            error "setNull: impossible!"
-        setNull (fd:fds) =
-            let
-                nullSetting = isNull fd
-            in
-                if all ((nullSetting ==) . isNull) fds
-                then nullSetting
-                else error $
-                    "foreign key columns must all be nullable or non-nullable"
-                   ++ show (map (unFieldNameHS . fieldHaskell) (fd:fds))
-
-        isNull =
-            (NotNullable /=) . nullable . fieldAttrs
-
-        toForeignFields
-            :: Text
-            -> FieldDef
-            -> (FieldDef, (ForeignFieldDef, ForeignFieldDef))
-        toForeignFields fieldText parentFieldDef =
-           case checkTypes fieldDef parentFieldDef of
-               Just err ->
-                   error err
-               Nothing ->
-                   (fieldDef, ((haskellField, fieldDB fieldDef), (parentFieldHaskellName, parentFieldNameDB)))
-          where
-            fieldDef = getFieldDef ent haskellField
-            haskellField = FieldNameHS fieldText
-            parentFieldHaskellName = fieldHaskell parentFieldDef
-            parentFieldNameDB = fieldDB parentFieldDef
-            checkTypes foreignField parentField =
-                if fieldType foreignField == fieldType parentField
-                then Nothing
-                else Just $ "fieldType mismatch: " ++ show (fieldType foreignField) ++ ", " ++ show (fieldType parentField)
-
-        getFieldDef :: EntityDef -> FieldNameHS -> FieldDef
-        getFieldDef entity t = go (keyAndEntityFields entity)
-          where
-            go [] = error $ "foreign key constraint for: " ++ show (unEntityNameHS $ entityHaskell entity)
-                       ++ " unknown column: " ++ show t
-            go (f:fs)
-                | fieldHaskell f == t = f
-                | otherwise = go fs
-
-        lengthError pdef = error $ "found " ++ show (length foreignFieldTexts) ++ " fkeys and " ++ show (length pdef) ++ " pkeys: fdef=" ++ show fdef ++ " pdef=" ++ show pdef
-
-
+-- | An 'EntityDef' produced by the QuasiQuoter. It contains information that
+-- the QuasiQuoter is capable of knowing about the entities. It is inherently
+-- unfinished, though - there are many other @Unbound@ datatypes that also
+-- contain partial information.
+--
+-- The 'unboundEntityDef' is not complete or reliable - to know which fields are
+-- safe to use, consult the parsing code.
+--
+-- This type was completely internal until 2.13.0.0, when it was exposed as part
+-- of the "Database.Persist.Quasi.Internal" module.
+--
+-- TODO: refactor this so we can expose it for consumers.
+--
+-- @since 2.13.0.0
 data UnboundEntityDef
     = UnboundEntityDef
-    { _unboundForeignDefs :: [UnboundForeignDef]
+    { unboundForeignDefs :: [UnboundForeignDef]
+    -- ^ A list of foreign definitions on the parsed entity.
+    --
+    -- @since 2.13.0.0
+    , unboundPrimarySpec :: PrimarySpec
+    -- ^ The specification for the primary key of the unbound entity.
+    --
+    -- @since 2.13.0.0
     , unboundEntityDef :: EntityDef
+    -- ^ The incomplete and partial 'EntityDef' that we're defining. We re-use
+    -- the type here to prevent duplication, but several of the fields are unset
+    -- and left to defaults.
+    --
+    -- @since 2.13.0.0
+    , unboundEntityFields :: [UnboundFieldDef]
+    -- ^ The list of fields for the entity. We're not capable of knowing
+    -- information like "is this a reference?" or "what's the underlying type of
+    -- the field?" yet, so we defer those to the Template Haskell execution.
+    --
+    -- @since 2.13.0.0
     }
+    deriving (Show, Lift)
+
+-- | Convert an 'EntityDef' into an 'UnboundEntityDef'. This "forgets"
+-- information about the 'EntityDef', but it is all kept present on the
+-- 'unboundEntityDef' field if necessary.
+--
+-- @since 2.13.0.0
+unbindEntityDef :: EntityDef -> UnboundEntityDef
+unbindEntityDef ed =
+    UnboundEntityDef
+        { unboundForeignDefs =
+            map unbindForeignDef (entityForeigns ed)
+        , unboundPrimarySpec =
+            case entityId ed of
+                EntityIdField fd ->
+                    SurrogateKey (unbindIdDef (entityHaskell ed) fd)
+                EntityIdNaturalKey cd ->
+                    NaturalKey (unbindCompositeDef cd)
+        , unboundEntityDef =
+            ed
+        , unboundEntityFields =
+            map unbindFieldDef (entityFields ed)
+        }
+
+-- | Returns the @['UnboundFieldDef']@ for an 'UnboundEntityDef'. This returns
+-- all fields defined on the entity.
+--
+-- @since 2.13.0.0
+getUnboundFieldDefs :: UnboundEntityDef -> [UnboundFieldDef]
+getUnboundFieldDefs = unboundEntityFields
+
+-- | This function forgets information about the 'CompositeDef' so that it can
+-- be remembered through Template Haskell.
+--
+-- @since 2.13.0.0
+unbindCompositeDef :: CompositeDef -> UnboundCompositeDef
+unbindCompositeDef cd =
+    UnboundCompositeDef
+        { unboundCompositeCols =
+            NEL.toList $ fmap fieldHaskell (compositeFields cd)
+        , unboundCompositeAttrs =
+            compositeAttrs cd
+        }
+
+-- | A representation of a database column, with everything that can be known at
+-- parse time.
+--
+-- @since 2.13.0.0
+data UnboundFieldDef
+    = UnboundFieldDef
+    { unboundFieldNameHS :: FieldNameHS
+    -- ^  The Haskell name of the field. This is parsed directly from the
+    -- definition, and is used to generate the Haskell record field and the
+    -- 'EntityField' definition.
+    --
+    -- @since 2.13.0.0
+    , unboundFieldNameDB :: FieldNameDB
+    -- ^ The database name of the field. By default, this is determined by the
+    -- 'PersistSettings' record at parse time. You can customize this with
+    -- a @sql=@ attribute:
+    --
+    -- @
+    --     name Text  sql=foo_name
+    -- @
+    --
+    -- @since 2.13.0.0
+    , unboundFieldAttrs :: [FieldAttr]
+    -- ^ The attributes present on the field. For rules on parsing and utility,
+    -- see the comments on the datatype.
+    --
+    -- @since 2.13.0.0
+    , unboundFieldStrict :: Bool
+    -- ^ Whether or not the field should be strict in the generated Haskell
+    -- code.
+    --
+    -- @since 2.13.0.0
+    , unboundFieldType :: FieldType
+    -- ^ The type of the field, as far as is known at parse time.
+    --
+    -- The TemplateHaskell code will reconstruct a 'Type' out of this, but the
+    -- names will be imported as-is.
+    --
+    -- @since 2.13.0.0
+    , unboundFieldCascade :: FieldCascade
+    -- ^ We parse if there's a 'FieldCascade' on the field. If the field is not
+    -- a reference, this information is ignored.
+    --
+    -- @
+    -- Post
+    --    user UserId OnDeleteCascade
+    -- @
+    --
+    -- @since 2.13.0.0
+    , unboundFieldGenerated :: Maybe Text
+    -- ^ Contains an expression to generate the column. If this is present, then
+    -- the column will not be written to the database, but generated by the
+    -- expression every time.
+    --
+    -- @
+    -- Item
+    --     subtotal Int
+    --     taxRate  Rational
+    --     total    Int      generated="subtotal * tax_rate"
+    -- @
+    --
+    -- @since 2.13.0.0
+    , unboundFieldComments :: Maybe Text
+    -- ^ Any comments present on the field. Documentation comments use
+    -- a Haskell-like syntax, and must be present before the field in question.
+    --
+    -- @
+    -- Post
+    --     -- | This is the blog post title.
+    --     title Text
+    --     -- | You can have multi-line comments.
+    --     -- | But each line must have the pipe character.
+    --     author UserId
+    -- @
+    --
+    -- @since 2.13.0.0
+    }
+    deriving (Eq, Show, Lift)
+
+-- | Forget innformation about a 'FieldDef' so it can beused as an
+-- 'UnboundFieldDef'.
+--
+-- @since 2.13.0.0
+unbindFieldDef :: FieldDef -> UnboundFieldDef
+unbindFieldDef fd = UnboundFieldDef
+    { unboundFieldNameHS =
+        fieldHaskell fd
+    , unboundFieldNameDB =
+        fieldDB fd
+    , unboundFieldAttrs =
+        fieldAttrs fd
+    , unboundFieldType =
+        fieldType fd
+    , unboundFieldStrict =
+        fieldStrict fd
+    , unboundFieldCascade =
+        fieldCascade fd
+    , unboundFieldComments =
+        fieldComments fd
+    , unboundFieldGenerated =
+        fieldGenerated fd
+    }
+
+-- | The specification for how an entity's primary key should be formed.
+--
+-- Persistent requires that every table have a primary key. By default, an
+-- implied ID is assigned, based on the 'mpsImplicitIdDef' field on
+-- 'MkPersistSettings'. Because we can't access that type at parse-time, we
+-- defer that decision until later.
+--
+-- @since 2.13.0.0
+data PrimarySpec
+    = NaturalKey UnboundCompositeDef
+    -- ^ A 'NaturalKey' contains columns that are defined on the datatype
+    -- itself. This is defined using the @Primary@ keyword and given a non-empty
+    -- list of columns.
+    --
+    -- @
+    -- User
+    --     name    Text
+    --     email   Text
+    --
+    --     Primary name email
+    -- @
+    --
+    -- A natural key may also contain only a single column. A natural key with
+    -- multiple columns is called a 'composite key'.
+    --
+    -- @since 2.13.0.0
+    | SurrogateKey UnboundIdDef
+    -- ^ A surrogate key is not part of the domain model for a database table.
+    -- You can specify a custom surro
+    --
+    -- You can specify a custom surrogate key using the @Id@ syntax.
+    --
+    -- @
+    -- User
+    --     Id    Text
+    --     name  Text
+    -- @
+    --
+    -- Note that you must provide a @default=@ expression when using this in
+    -- order to use 'insert' or related functions. The 'insertKey' function can
+    -- be used instead, as it allows you to specify a key directly. Fixing this
+    -- issue is tracked in #1247 on GitHub.
+    --
+    -- @since 2.13.0.0
+    | DefaultKey FieldNameDB
+    -- ^ The default key for the entity using the settings in
+    -- 'MkPersistSettings'.
+    --
+    -- This is implicit - a table without an @Id@ or @Primary@ declaration will
+    -- have a 'DefaultKey'.
+    --
+    -- @since 2.13.0.0
+    deriving (Show, Lift)
 
 -- | Construct an entity definition.
-mkEntityDef
+mkUnboundEntityDef
     :: PersistSettings
     -> ParsedEntityDef -- ^ parsed entity definition
     -> UnboundEntityDef
-mkEntityDef ps parsedEntDef =
-    UnboundEntityDef foreigns $
-        EntityDef
-            { entityHaskell = entNameHS
-            , entityDB = entNameDB
-            -- idField is the user-specified Id
-            -- otherwise useAutoIdField
-            -- but, adjust it if the user specified a Primary
-            , entityId = setComposite primaryComposite $ fromMaybe autoIdField idField
-            , entityAttrs = parsedEntityDefEntityAttributes parsedEntDef
-            , entityFields = cols
-            , entityUniques = uniqs
-            , entityForeigns = []
-            , entityDerives = concat $ mapMaybe takeDerives textAttribs
-            , entityExtra = parsedEntityDefExtras parsedEntDef
-            , entitySum = parsedEntityDefIsSum parsedEntDef
-            , entityComments =
-                case parsedEntityDefComments parsedEntDef of
-                    [] -> Nothing
-                    comments -> Just (T.unlines comments)
-            }
+mkUnboundEntityDef ps parsedEntDef =
+    UnboundEntityDef
+        { unboundForeignDefs =
+            foreigns
+        , unboundPrimarySpec =
+            case (idField, primaryComposite) of
+                (Just {}, Just {}) ->
+                    error "Specified both an ID field and a Primary field"
+                (Just a, Nothing) ->
+                    if unboundIdType a == Just (mkKeyConType (unboundIdEntityName a))
+                    then
+                        DefaultKey (FieldNameDB $ psIdName ps)
+                    else
+                        SurrogateKey a
+                (Nothing, Just a) ->
+                    NaturalKey a
+                (Nothing, Nothing) ->
+                    DefaultKey (FieldNameDB $ psIdName ps)
+        , unboundEntityFields =
+            cols
+        , unboundEntityDef =
+            EntityDef
+                { entityHaskell = entNameHS
+                , entityDB = entNameDB
+                -- idField is the user-specified Id
+                -- otherwise useAutoIdField
+                -- but, adjust it if the user specified a Primary
+                , entityId =
+                    EntityIdField $
+                    maybe autoIdField (unboundIdDefToFieldDef (defaultIdName ps) entNameHS) idField
+                , entityAttrs =
+                    parsedEntityDefEntityAttributes parsedEntDef
+                , entityFields =
+                    []
+                , entityUniques = uniqs
+                , entityForeigns = []
+                , entityDerives = concat $ mapMaybe takeDerives textAttribs
+                , entityExtra = parsedEntityDefExtras parsedEntDef
+                , entitySum = parsedEntityDefIsSum parsedEntDef
+                , entityComments =
+                    case parsedEntityDefComments parsedEntDef of
+                        [] -> Nothing
+                        comments -> Just (T.unlines comments)
+                }
+        }
   where
     (entNameHS, entNameDB) =
         entityNamesFromParsedDef ps parsedEntDef
@@ -496,12 +670,19 @@ mkEntityDef ps parsedEntDef =
     textAttribs =
         fmap tokenText <$> attribs
 
-    (idField, primaryComposite, uniqs, foreigns) = foldl' (\(mid, mp, us, fs) attr ->
-        let (i, p, u, f) = takeConstraint ps entNameHS cols attr
-            squish xs m = xs `mappend` maybeToList m
-        in (just1 mid i, just1 mp p, squish us u, squish fs f)) (Nothing, Nothing, [],[]) textAttribs
-
-    cols :: [FieldDef]
+    (idField, primaryComposite, uniqs, foreigns) =
+        foldl'
+            (\(mid, mp, us, fs) attr ->
+                let
+                    (i, p, u, f) = takeConstraint ps entNameHS cols attr
+                    squish xs m = xs `mappend` maybeToList m
+                in
+                    (just1 mid i, just1 mp p, squish us u, squish fs f)
+            )
+            (Nothing, Nothing, [],[])
+            textAttribs
+
+    cols :: [UnboundFieldDef]
     cols = reverse . fst . foldr k ([], []) $ reverse attribs
 
     k x (!acc, !comments) =
@@ -511,45 +692,88 @@ mkEntityDef ps parsedEntDef =
             _ ->
                 case (setFieldComments comments <$> takeColsEx ps (tokenText <$> x)) of
                   Just sm ->
-                      (maybeSetSelfReference sm : acc, [])
+                      (sm : acc, [])
                   Nothing ->
                       (acc, [])
 
-    maybeSetSelfReference field = go (fieldType field)
-      where
-        go ft =
-            case ft of
-                FTTypeCon Nothing x
-                    | x == unEntityNameHS entNameHS ->
-                        field
-                            { fieldReference =
-                                SelfReference
-                            }
-                    | otherwise ->
-                        field
-                FTTypeCon _ _ ->
-                    field
-                FTList ft' ->
-                    go ft'
-                _ ->
-                    field
-
     autoIdField =
         mkAutoIdField ps entNameHS idSqlType
 
     idSqlType =
         maybe SqlInt64 (const $ SqlOther "Primary Key") primaryComposite
 
-    setComposite Nothing fd = fd
-    setComposite (Just c) fd = fd
-        { fieldReference = CompositeRef c
+defaultIdName :: PersistSettings -> FieldNameDB
+defaultIdName = FieldNameDB . psIdName
+
+-- | Convert an 'UnboundIdDef' into a 'FieldDef' suitable for use in the
+-- 'EntityIdField' constructor.
+--
+-- @since 2.13.0.0
+unboundIdDefToFieldDef
+    :: FieldNameDB
+    -> EntityNameHS
+    -> UnboundIdDef
+    -> FieldDef
+unboundIdDefToFieldDef dbField entNameHS uid =
+    FieldDef
+        { fieldHaskell =
+            FieldNameHS "Id"
+        , fieldDB =
+            getSqlNameOr dbField (unboundIdAttrs uid)
+        , fieldType =
+            fromMaybe (mkKeyConType entNameHS) $ unboundIdType uid
+        , fieldSqlType =
+            SqlOther "SqlType unset for Id"
+        , fieldStrict =
+            False
+        , fieldReference =
+            ForeignRef entNameHS
+        , fieldAttrs =
+            unboundIdAttrs uid
+        , fieldComments =
+            Nothing
+        , fieldCascade = unboundIdCascade uid
+        , fieldGenerated = Nothing
+        , fieldIsImplicitIdColumn = True
         }
 
-setFieldComments :: [Text] -> FieldDef -> FieldDef
+-- | Convert an 'EntityNameHS' into 'FieldType' that will get parsed into the ID
+-- type for the entity.
+--
+-- @
+-- >>> mkKeyConType (EntityNameHS "Hello)
+-- FTTypeCon Nothing "HelloId"
+-- @
+--
+-- @since 2.13.0.0
+mkKeyConType :: EntityNameHS -> FieldType
+mkKeyConType entNameHs =
+    FTTypeCon Nothing (keyConName entNameHs)
+
+-- | Assuming that the provided 'FieldDef' is an ID field, this converts it into
+-- an 'UnboundIdDef'.
+--
+-- @since 2.13.0.0
+unbindIdDef :: EntityNameHS -> FieldDef -> UnboundIdDef
+unbindIdDef entityName fd =
+    UnboundIdDef
+        { unboundIdEntityName =
+            entityName
+        , unboundIdDBName =
+            fieldDB fd
+        , unboundIdAttrs =
+            fieldAttrs fd
+        , unboundIdCascade =
+            fieldCascade fd
+        , unboundIdType =
+            Just $ fieldType fd
+        }
+
+setFieldComments :: [Text] -> UnboundFieldDef -> UnboundFieldDef
 setFieldComments xs fld =
     case xs of
         [] -> fld
-        _ -> fld { fieldComments = Just (T.unlines xs) }
+        _ -> fld { unboundFieldComments = Just (T.unlines xs) }
 
 just1 :: (Show x) => Maybe x -> Maybe x -> Maybe x
 just1 (Just x) (Just y) = error $ "expected only one of: "
@@ -557,17 +781,21 @@ just1 (Just x) (Just y) = error $ "expected only one of: "
 just1 x y = x `mplus` y
 
 mkAutoIdField :: PersistSettings -> EntityNameHS -> SqlType -> FieldDef
-mkAutoIdField ps entName idSqlType =
+mkAutoIdField ps =
+    mkAutoIdField' (FieldNameDB $ psIdName ps)
+
+-- | Creates a default ID field.
+--
+-- @since 2.13.0.0
+mkAutoIdField' :: FieldNameDB -> EntityNameHS -> SqlType -> FieldDef
+mkAutoIdField' dbName entName idSqlType =
     FieldDef
         { fieldHaskell = FieldNameHS "Id"
-        -- this should be modeled as a Maybe
-        -- but that sucks for non-ID field
-        -- TODO: use a sumtype FieldDef | IdFieldDef
-        , fieldDB = FieldNameDB $ psIdName ps
+        , fieldDB = dbName
         , fieldType = FTTypeCon Nothing $ keyConName entName
         , fieldSqlType = idSqlType
-        -- the primary field is actually a reference to the entity
-        , fieldReference = ForeignRef entName defaultReferenceTypeCon
+        , fieldReference =
+            NoReference
         , fieldAttrs = []
         , fieldStrict = True
         , fieldComments = Nothing
@@ -576,9 +804,6 @@ mkAutoIdField ps entName idSqlType =
         , fieldIsImplicitIdColumn = True
         }
 
-defaultReferenceTypeCon :: FieldType
-defaultReferenceTypeCon = FTTypeCon (Just "Data.Int") "Int64"
-
 keyConName :: EntityNameHS -> Text
 keyConName entName = unEntityNameHS entName `mappend` "Id"
 
@@ -606,33 +831,38 @@ isCapitalizedText :: Text -> Bool
 isCapitalizedText t =
     not (T.null t) && isUpper (T.head t)
 
-takeColsEx :: PersistSettings -> [Text] -> Maybe FieldDef
+takeColsEx :: PersistSettings -> [Text] -> Maybe UnboundFieldDef
 takeColsEx =
     takeCols
         (\ft perr -> error $ "Invalid field type " ++ show ft ++ " " ++ perr)
 
 takeCols
-    :: (Text -> String -> Maybe FieldDef)
+    :: (Text -> String -> Maybe UnboundFieldDef)
     -> PersistSettings
     -> [Text]
-    -> Maybe FieldDef
+    -> Maybe UnboundFieldDef
 takeCols _ _ ("deriving":_) = Nothing
 takeCols onErr ps (n':typ:rest')
     | not (T.null n) && isLower (T.head n) =
         case parseFieldType typ of
             Left err -> onErr typ err
-            Right ft -> Just FieldDef
-                { fieldHaskell = FieldNameHS n
-                , fieldDB = FieldNameDB $ getDbName ps n attrs_
-                , fieldType = ft
-                , fieldSqlType = SqlOther $ "SqlType unset for " `mappend` n
-                , fieldAttrs = fieldAttrs_
-                , fieldStrict = fromMaybe (psStrictFields ps) mstrict
-                , fieldReference = NoReference
-                , fieldComments = Nothing
-                , fieldCascade = cascade_
-                , fieldGenerated = generated_
-                , fieldIsImplicitIdColumn = False
+            Right ft -> Just UnboundFieldDef
+                { unboundFieldNameHS =
+                    FieldNameHS n
+                , unboundFieldNameDB =
+                    getDbName' ps n fieldAttrs_
+                , unboundFieldType =
+                    ft
+                , unboundFieldAttrs =
+                    fieldAttrs_
+                , unboundFieldStrict =
+                    fromMaybe (psStrictFields ps) mstrict
+                , unboundFieldComments =
+                    Nothing
+                , unboundFieldCascade =
+                    cascade_
+                , unboundFieldGenerated =
+                    generated_
                 }
   where
     fieldAttrs_ = parseFieldAttrs attrs_
@@ -649,83 +879,177 @@ parseGenerated :: [Text] -> Maybe Text
 parseGenerated = foldl' (\acc x -> acc <|> T.stripPrefix "generated=" x) Nothing
 
 getDbName :: PersistSettings -> Text -> [Text] -> Text
-getDbName ps n [] = psToDBName ps n
-getDbName ps n (a:as) = fromMaybe (getDbName ps n as) $ T.stripPrefix "sql=" a
+getDbName ps n =
+    fromMaybe (psToDBName ps n) . listToMaybe . mapMaybe (T.stripPrefix "sql=")
+
+getDbName' :: PersistSettings -> Text -> [FieldAttr] -> FieldNameDB
+getDbName' ps n =
+    getSqlNameOr (FieldNameDB $ psToDBName ps n)
+
+getSqlNameOr
+    :: FieldNameDB
+    -> [FieldAttr]
+    -> FieldNameDB
+getSqlNameOr def =
+    maybe def FieldNameDB . findAttrSql
+  where
+    findAttrSql =
+        listToMaybe . mapMaybe isAttrSql
+    isAttrSql attr =
+        case attr of
+            FieldAttrSql t ->
+                Just t
+            _ ->
+                Nothing
 
 takeConstraint
     :: PersistSettings
     -> EntityNameHS
-    -> [FieldDef]
+    -> [UnboundFieldDef]
     -> [Text]
-    -> (Maybe FieldDef, Maybe CompositeDef, Maybe UniqueDef, Maybe UnboundForeignDef)
+    -> (Maybe UnboundIdDef, Maybe UnboundCompositeDef, Maybe UniqueDef, Maybe UnboundForeignDef)
 takeConstraint ps entityName defs (n:rest) | isCapitalizedText n = takeConstraint'
   where
     takeConstraint'
-          | n == "Unique"  = (Nothing, Nothing, Just $ takeUniq ps (unEntityNameHS entityName) defs rest, Nothing)
-          | n == "Foreign" = (Nothing, Nothing, Nothing, Just $ takeForeign ps entityName defs rest)
-          | n == "Primary" = (Nothing, Just $ takeComposite defs rest, Nothing, Nothing)
-          | n == "Id"      = (Just $ takeId ps entityName (n:rest), Nothing, Nothing, Nothing)
-          | otherwise      = (Nothing, Nothing, Just $ takeUniq ps "" defs (n:rest), Nothing) -- retain compatibility with original unique constraint
+          | n == "Unique"  =
+              (Nothing, Nothing, takeUniq ps (unEntityNameHS entityName) defs rest, Nothing)
+          | n == "Foreign" =
+              (Nothing, Nothing, Nothing, Just $ takeForeign ps entityName rest)
+          | n == "Primary" =
+              (Nothing, Just $ takeComposite ps defNames rest, Nothing, Nothing)
+          | n == "Id"      =
+              (Just $ takeId ps entityName rest, Nothing, Nothing, Nothing)
+          | otherwise      =
+              (Nothing, Nothing, takeUniq ps "" defs (n:rest), Nothing) -- retain compatibility with original unique constraint
+    defNames =
+        map unboundFieldNameHS defs
 takeConstraint _ _ _ _ = (Nothing, Nothing, Nothing, Nothing)
 
+-- | This type represents an @Id@ declaration in the QuasiQuoted syntax.
+--
+-- > Id
+--
+-- This uses the implied settings, and is equivalent to omitting the @Id@
+-- statement entirely.
+--
+-- > Id Text
+--
+-- This will set the field type of the ID to be 'Text'.
+--
+-- > Id Text sql=foo_id
+--
+-- This will set the field type of the Id to be 'Text' and the SQL DB name to be @foo_id@.
+--
+-- > Id FooId
+--
+-- This results in a shared primary key - the @FooId@ refers to a @Foo@ table.
+--
+-- > Id FooId OnDelete Cascade
+--
+-- You can set a cascade behavior on an ID column.
+--
+-- @since 2.13.0.0
+data UnboundIdDef = UnboundIdDef
+    { unboundIdEntityName :: EntityNameHS
+    , unboundIdDBName :: !FieldNameDB
+    , unboundIdAttrs :: [FieldAttr]
+    , unboundIdCascade :: FieldCascade
+    , unboundIdType :: Maybe FieldType
+    }
+    deriving (Show, Lift)
+
 -- TODO: this is hacky (the double takeCols, the setFieldDef stuff, and setIdName.
 -- need to re-work takeCols function
-takeId :: PersistSettings -> EntityNameHS -> [Text] -> FieldDef
-takeId ps entityName (n:rest) =
-    setFieldDef
-    $ fromMaybe (error "takeId: impossible!")
-    $ takeCols (\_ _ -> addDefaultIdType) ps (field:rest) -- `mappend` setIdName)
-  where
-    field = case T.uncons n of
-        Nothing -> error "takeId: empty field"
-        Just (f, ield) -> toLower f `T.cons` ield
-    addDefaultIdType = takeColsEx ps (field : keyCon : rest ) -- `mappend` setIdName)
-    setFieldDef fd = fd
-        { fieldReference =
-            ForeignRef entityName $
-                if fieldType fd == FTTypeCon Nothing keyCon
-                then defaultReferenceTypeCon
-                else fieldType fd
+takeId :: PersistSettings -> EntityNameHS -> [Text] -> UnboundIdDef
+takeId ps entityName texts =
+    UnboundIdDef
+        { unboundIdDBName =
+            FieldNameDB $ psIdName ps
+        , unboundIdEntityName =
+            entityName
+        , unboundIdCascade =
+            cascade_
+        , unboundIdAttrs =
+            parseFieldAttrs attrs_
+        , unboundIdType =
+            typ
         }
-    keyCon = keyConName entityName
-    -- this will be ignored if there is already an existing sql=
-    -- TODO: I think there is a ! ignore syntax that would screw this up
-    -- setIdName = ["sql=" `mappend` psIdName ps]
-takeId _ (EntityNameHS tableName) _ = error $ "empty Id field for " `mappend` show tableName
-
+  where
+    typ =
+        case texts of
+            [] ->
+                Nothing
+            (t : _) ->
+                case parseFieldType t of
+                    Left _ ->
+                        Nothing
+                    Right ft ->
+                        Just ft
+    (cascade_, attrs_) = parseCascade texts
+
+-- | A definition for a composite primary key.
+--
+-- @since.2.13.0.0
+data UnboundCompositeDef = UnboundCompositeDef
+    { unboundCompositeCols :: [FieldNameHS]
+    -- ^ The field names for the primary key.
+    --
+    -- @since 2.13.0.0
+    , unboundCompositeAttrs :: [Attr]
+    -- ^ A list of attributes defined on the primary key. This is anything that
+    -- occurs after a @!@ character.
+    --
+    -- @since 2.13.0.0
+    }
+    deriving (Show, Lift)
 
 takeComposite
-    :: [FieldDef]
+    :: PersistSettings
+    -> [FieldNameHS]
     -> [Text]
-    -> CompositeDef
-takeComposite fields pkcols =
-    CompositeDef (map (getDef fields) pkcols) attrs
+    -> UnboundCompositeDef
+takeComposite ps fields pkcols =
+    UnboundCompositeDef
+        { unboundCompositeCols =
+            map (getDef fields) cols
+        , unboundCompositeAttrs =
+            attrs
+        }
   where
-    (_, attrs) = break ("!" `T.isPrefixOf`) pkcols
+    (cols, attrs) = break ("!" `T.isPrefixOf`) pkcols
     getDef [] t = error $ "Unknown column in primary key constraint: " ++ show t
     getDef (d:ds) t
-        | fieldHaskell d == FieldNameHS t =
-            if nullable (fieldAttrs d) /= NotNullable
-                then error $ "primary key column cannot be nullable: " ++ show t ++ show fields
-                else d
-        | otherwise = getDef ds t
+        | d == FieldNameHS t =
+            -- TODO: check for nullability in later step
+            -- if nullable (fieldAttrs d) /= NotNullable
+            --     then error $ "primary key column cannot be nullable: " ++ show t ++ show fields
+            d
+        | otherwise =
+            getDef ds t
 
 -- Unique UppercaseConstraintName list of lowercasefields terminated
 -- by ! or sql= such that a unique constraint can look like:
 -- `UniqueTestNull fieldA fieldB sql=ConstraintNameInDatabase !force`
 -- Here using sql= sets the name of the constraint.
-takeUniq :: PersistSettings
-         -> Text
-         -> [FieldDef]
-         -> [Text]
-         -> UniqueDef
+takeUniq
+    :: PersistSettings
+    -> Text
+    -> [UnboundFieldDef]
+    -> [Text]
+    -> Maybe UniqueDef
 takeUniq ps tableName defs (n : rest)
-    | isCapitalizedText n
-        = UniqueDef
-            (ConstraintNameHS n)
-            dbName
-            (map (FieldNameHS &&& getDBName defs) fields)
-            attrs
+    | isCapitalizedText n = do
+        fields <- mfields
+        pure UniqueDef
+            { uniqueHaskell =
+                ConstraintNameHS n
+            , uniqueDBName =
+                dbName
+            , uniqueFields =
+                fmap (\a -> (FieldNameHS a, getDBName defs a)) fields
+            , uniqueAttrs =
+                attrs
+            }
   where
     isAttr a =
       "!" `T.isPrefixOf` a
@@ -733,8 +1057,10 @@ takeUniq ps tableName defs (n : rest)
       "sql=" `T.isPrefixOf` a
     isNonField a =
        isAttr a || isSqlName a
-    (fields, nonFields) =
-      break isNonField rest
+    (fieldsList, nonFields) =
+        break isNonField rest
+    mfields =
+        NEL.nonEmpty fieldsList
 
     attrs = filter isAttr nonFields
 
@@ -750,12 +1076,15 @@ takeUniq ps tableName defs (n : rest)
             (x : _) -> Just (ConstraintNameDB x)
             _ -> Nothing
     dbName = fromMaybe usualDbName sqlName
+
     getDBName [] t =
       error $ "Unknown column in unique constraint: " ++ show t
               ++ " " ++ show defs ++ show n ++ " " ++ show attrs
     getDBName (d:ds) t
-        | fieldHaskell d == FieldNameHS t = fieldDB d
-        | otherwise = getDBName ds t
+        | unboundFieldNameHS d == FieldNameHS t =
+            unboundFieldNameDB d
+        | otherwise =
+            getDBName ds t
 
 takeUniq _ tableName _ xs =
   error $ "invalid unique constraint on table["
@@ -763,23 +1092,126 @@ takeUniq _ tableName _ xs =
           ++ "] expecting an uppercase constraint name xs="
           ++ show xs
 
+-- | Define an explicit foreign key reference.
+--
+-- @
+-- User
+--     name Text
+--     email Text
+--
+--     Primary name email
+--
+-- Dog
+--     ownerName Text
+--     ownerEmail Text
+--
+--     Foreign User fk_dog_user ownerName ownerEmail
+-- @
+--
+-- @since 2.13.0.0
 data UnboundForeignDef
     = UnboundForeignDef
-    { _unboundForeignFields :: [Text]
-    -- ^ fields in the source entity
-    , _unboundParentFields :: [Text]
-    -- ^ fields in target entity
-    , _unboundForeignDef :: ForeignDef
+    { unboundForeignFields :: UnboundForeignFieldList
+    -- ^ Fields in the source entity.
+    --
+    -- @since 2.13.0.0
+    , unboundForeignDef :: ForeignDef
     -- ^ The 'ForeignDef' which needs information filled in.
+    --
+    -- This value is unreliable. See the parsing code to see what data is filled
+    -- in here.
+    --
+    -- @since 2.13.0.0
     }
+    deriving (Eq, Show, Lift)
+
+-- | A list of fields present on the foreign reference.
+data UnboundForeignFieldList
+    = FieldListImpliedId (NonEmpty FieldNameHS)
+    -- ^ If no @References@ keyword is supplied, then it is assumed that you are
+    -- referring to the @Primary@ key or @Id@ of the target entity.
+    --
+    -- @since 2.13.0.0
+    | FieldListHasReferences (NonEmpty ForeignFieldReference)
+    -- ^ You can specify the exact columns you're referring to here, if they
+    -- aren't part of a primary key. Most databases expect a unique index on the
+    -- columns you refer to, but Persistent doesnt' check that.
+    --
+    -- @
+    -- User
+    --     Id           UUID default="uuid_generate_v1mc()"
+    --     name         Text
+    --
+    --     UniqueName name
+    --
+    -- Dog
+    --     ownerName    Text
+    --
+    --     Foreign User fk_dog_user ownerName References name
+    -- @
+    --
+    -- @since 2.13.0.0
+    deriving (Eq, Show, Lift)
+
+-- | A pairing of the 'FieldNameHS' for the source table to the 'FieldNameHS'
+-- for the target table.
+--
+-- @since 2.13.0.0
+data ForeignFieldReference =
+    ForeignFieldReference
+    { ffrSourceField :: FieldNameHS
+    -- ^ The column on the source table.
+    --
+    -- @since 2.13.0.0
+    , ffrTargetField :: FieldNameHS
+    -- ^ The column on the target table.
+    --
+    -- @since 2.13.0.0
+    }
+    deriving (Eq, Show, Lift)
+
+unbindForeignDef :: ForeignDef -> UnboundForeignDef
+unbindForeignDef fd =
+    UnboundForeignDef
+        { unboundForeignFields =
+            FieldListHasReferences $ NEL.fromList $ fmap mk (foreignFields fd)
+        , unboundForeignDef =
+            fd
+        }
+  where
+    mk ((fH, _), (pH, _))  =
+        ForeignFieldReference
+            { ffrSourceField = fH
+            , ffrTargetField = pH
+            }
+
+mkUnboundForeignFieldList
+    :: [Text]
+    -> [Text]
+    -> Either String UnboundForeignFieldList
+mkUnboundForeignFieldList (fmap FieldNameHS -> source) (fmap FieldNameHS -> target) =
+    case NEL.nonEmpty source of
+        Nothing ->
+            Left "No fields on foreign reference."
+        Just sources ->
+            case NEL.nonEmpty target of
+                Nothing ->
+                    Right $ FieldListImpliedId sources
+                Just targets ->
+                    if length targets /= length sources
+                    then
+                        Left "Target and source length differe on foreign reference."
+                    else
+                        Right
+                        $ FieldListHasReferences
+                        $ NEL.zipWith ForeignFieldReference sources targets
 
 takeForeign
     :: PersistSettings
     -> EntityNameHS
-    -> [FieldDef]
     -> [Text]
     -> UnboundForeignDef
-takeForeign ps entityName _defs = takeRefTable
+takeForeign ps entityName = takeRefTable
   where
     errorPrefix :: String
     errorPrefix = "invalid foreign key constraint on table[" ++ show (unEntityNameHS entityName) ++ "] "
@@ -794,11 +1226,9 @@ takeForeign ps entityName _defs = takeRefTable
         go (constraintNameText:rest) onDelete onUpdate
             | not (T.null constraintNameText) && isLower (T.head constraintNameText) =
                 UnboundForeignDef
-                    { _unboundForeignFields =
-                        foreignFields
-                    , _unboundParentFields =
-                        parentFields
-                    , _unboundForeignDef =
+                    { unboundForeignFields =
+                        either error id $ mkUnboundForeignFieldList foreignFields parentFields
+                    , unboundForeignDef =
                         ForeignDef
                             { foreignRefTableHaskell =
                                 EntityNameHS refTableName
@@ -808,14 +1238,15 @@ takeForeign ps entityName _defs = takeRefTable
                                 constraintName
                             , foreignConstraintNameDBName =
                                 toFKConstraintNameDB ps entityName constraintName
-                            , foreignFieldCascade = FieldCascade
-                                { fcOnDelete = onDelete
-                                , fcOnUpdate = onUpdate
-                                }
-                            , foreignFields =
-                                []
+                            , foreignFieldCascade =
+                                FieldCascade
+                                    { fcOnDelete = onDelete
+                                    , fcOnUpdate = onUpdate
+                                    }
                             , foreignAttrs =
                                 attrs
+                            , foreignFields =
+                                []
                             , foreignNullable =
                                 False
                             , foreignToPrimary =
@@ -926,3 +1357,19 @@ nullable s
     | FieldAttrMaybe    `elem` s = Nullable ByMaybeAttr
     | FieldAttrNullable `elem` s = Nullable ByNullableAttr
     | otherwise = NotNullable
+
+
+-- | Returns 'True' if the 'UnboundFieldDef' does not have a 'MigrationOnly' or
+-- 'SafeToRemove' flag from the QuasiQuoter.
+--
+-- @since 2.13.0.0
+isHaskellUnboundField :: UnboundFieldDef -> Bool
+isHaskellUnboundField fd =
+    FieldAttrMigrationOnly `notElem` unboundFieldAttrs fd &&
+    FieldAttrSafeToRemove `notElem` unboundFieldAttrs fd
+
+-- |  Return the 'EntityNameHS' for an 'UnboundEntityDef'.
+--
+-- @since 2.13.0.0
+getUnboundEntityNameHS :: UnboundEntityDef -> EntityNameHS
+getUnboundEntityNameHS = entityHaskell . unboundEntityDef
diff --git a/persistent/Database/Persist/Sql/Class.hs b/persistent/Database/Persist/Sql/Class.hs
index 9b9044a9f..bef70fe10 100644
--- a/persistent/Database/Persist/Sql/Class.hs
+++ b/persistent/Database/Persist/Sql/Class.hs
@@ -1,10 +1,11 @@
 {-# LANGUAGE CPP #-}
-{-# LANGUAGE TypeOperators, FlexibleInstances #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE PatternGuards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE DataKinds #-}
 
 module Database.Persist.Sql.Class
     ( RawSql (..)
@@ -13,10 +14,10 @@ module Database.Persist.Sql.Class
     , unPrefix
     ) where
 
-import GHC.TypeLits (Symbol, KnownSymbol, symbolVal)
 import Data.Bits (bitSizeMaybe)
 import Data.ByteString (ByteString)
 import Data.Fixed
+import Data.Foldable (toList)
 import Data.Int
 import qualified Data.IntMap as IM
 import qualified Data.Map as M
@@ -27,9 +28,10 @@ import qualified Data.Set as S
 import Data.Text (Text, intercalate, pack)
 import qualified Data.Text as T
 import qualified Data.Text.Lazy as TL
-import Data.Time (UTCTime, TimeOfDay, Day)
+import Data.Time (Day, TimeOfDay, UTCTime)
 import qualified Data.Vector as V
 import Data.Word
+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
 import Text.Blaze.Html (Html)
 
 import Database.Persist
@@ -66,27 +68,42 @@ instance
     rawSqlProcessRow         = keyFromValues
 
 instance
-    (PersistEntity record, PersistEntityBackend record ~ backend, IsPersistBackend backend) =>
-    RawSql (Entity record) where
-    rawSqlCols escape _ent = (length sqlFields, [intercalate ", " sqlFields])
-        where
-          sqlFields = map (((name <> ".") <>) . escapeWith escape)
-              $ map fieldDB
-              -- Hacky for a composite key because
-              -- it selects the same field multiple times
-              $ getEntityKeyFields entDef ++ getEntityFields entDef
-          name = escapeWith escape (getEntityDBName entDef)
-          entDef = entityDef (Nothing :: Maybe record)
+    (PersistEntity record, PersistEntityBackend record ~ backend, IsPersistBackend backend)
+  =>
+    RawSql (Entity record)
+  where
+    rawSqlCols escape _ent = (length sqlFields, [intercalate ", " $ toList sqlFields])
+      where
+        sqlFields =
+            fmap (((name <> ".") <>) . escapeWith escape)
+            $ fmap fieldDB
+            $ keyAndEntityFields entDef
+        name =
+            escapeWith escape (getEntityDBName entDef)
+        entDef =
+            entityDef (Nothing :: Maybe record)
     rawSqlColCountReason a =
         case fst (rawSqlCols (error "RawSql") a) of
           1 -> "one column for an 'Entity' data type without fields"
-          n -> show n ++ " columns for an 'Entity' data type"
-    rawSqlProcessRow row = case splitAt nKeyFields row of
-      (rowKey, rowVal) -> Entity <$> keyFromValues rowKey
-                                 <*> fromPersistValues rowVal
-      where
-        nKeyFields = length $ getEntityKeyFields entDef
-        entDef = entityDef (Nothing :: Maybe record)
+          n -> show n <> " columns for an 'Entity' data type"
+    rawSqlProcessRow row =
+        case keyFromRecordM of
+            Just mkKey -> do
+                val <- fromPersistValues row
+                pure Entity
+                    { entityKey =
+                        mkKey val
+                    , entityVal =
+                        val
+                    }
+            Nothing ->
+                case row of
+                    (k : rest) ->
+                        Entity
+                            <$> keyFromValues [k]
+                            <*> fromPersistValues rest
+                    [] ->
+                        Left "Row was empty"
 
 -- | This newtype wrapper is useful when selecting an entity out of the
 -- database and you want to provide a prefix to the table being selected.
@@ -134,7 +151,7 @@ newtype EntityWithPrefix (prefix :: Symbol) record
 --
 -- @
 -- myQuery :: 'SqlPersistM' ['Entity' Person]
--- myQuery = map (unPrefix @\"p\") <$> rawSql query []
+-- myQuery = fmap (unPrefix @\"p\") <$> rawSql query []
 --   where
 --     query = "SELECT ?? FROM person AS p"
 -- @
@@ -149,23 +166,32 @@ instance
     , PersistEntityBackend record ~ backend
     , IsPersistBackend backend
     )
-  => RawSql (EntityWithPrefix prefix record) where
-    rawSqlCols escape _ent = (length sqlFields, [intercalate ", " sqlFields])
-        where
-          sqlFields = map (((name <> ".") <>) . escapeWith escape)
-              $ map fieldDB
+  =>
+    RawSql (EntityWithPrefix prefix record)
+  where
+    rawSqlCols escape _ent = (length sqlFields, [intercalate ", " $ toList sqlFields])
+      where
+          sqlFields =
+              fmap (((name <> ".") <>) . escapeWith escape)
+              $ fmap fieldDB
               -- Hacky for a composite key because
               -- it selects the same field multiple times
-              $ getEntityKeyFields entDef ++ getEntityFields entDef
-          name = pack $ symbolVal (Proxy :: Proxy prefix)
-          entDef = entityDef (Nothing :: Maybe record)
+              $ keyAndEntityFields entDef
+          name =
+              pack $ symbolVal (Proxy :: Proxy prefix)
+          entDef =
+              entityDef (Nothing :: Maybe record)
     rawSqlColCountReason a =
         case fst (rawSqlCols (error "RawSql") a) of
-          1 -> "one column for an 'Entity' data type without fields"
-          n -> show n ++ " columns for an 'Entity' data type"
-    rawSqlProcessRow row = case splitAt nKeyFields row of
-      (rowKey, rowVal) -> fmap EntityWithPrefix $ Entity <$> keyFromValues rowKey
-                                 <*> fromPersistValues rowVal
+            1 -> "one column for an 'Entity' data type without fields"
+            n -> show n ++ " columns for an 'Entity' data type"
+    rawSqlProcessRow row =
+        case splitAt nKeyFields row of
+            (rowKey, rowVal) ->
+                fmap EntityWithPrefix $
+                    Entity
+                        <$> keyFromValues rowKey
+                        <*> fromPersistValues rowVal
       where
         nKeyFields = length $ getEntityKeyFields entDef
         entDef = entityDef (Nothing :: Maybe record)
diff --git a/persistent/Database/Persist/Sql/Internal.hs b/persistent/Database/Persist/Sql/Internal.hs
index f3b6598c5..e44b84c29 100644
--- a/persistent/Database/Persist/Sql/Internal.hs
+++ b/persistent/Database/Persist/Sql/Internal.hs
@@ -18,11 +18,11 @@ import Data.Monoid (mappend, mconcat)
 import Data.Text (Text)
 import qualified Data.Text as T
 
+import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
+import Database.Persist.EntityDef
 import Database.Persist.Quasi
 import Database.Persist.Sql.Types
 import Database.Persist.Types
-import Database.Persist.Names
-import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
 
 -- | Record of functions to override the default behavior in 'mkColumns'.  It is
 -- recommended you initialize this with 'emptyBackendSpecificOverrides' and
@@ -88,9 +88,12 @@ mkColumns allDefs t overrides =
     cols = map goId idCol `mappend` map go (getEntityFieldsDatabase t)
 
     idCol :: [FieldDef]
-    idCol = case entityPrimary t of
-        Just _ -> []
-        Nothing -> [getEntityId t]
+    idCol =
+        case getEntityId t of
+            EntityIdNaturalKey _ ->
+                []
+            EntityIdField fd ->
+                [fd]
 
     goId :: FieldDef -> Column
     goId fd =
@@ -175,7 +178,7 @@ mkColumns allDefs t overrides =
         -> [FieldAttr]
         -> Maybe (EntityNameDB, ConstraintNameDB) -- table name, constraint name
     ref c fe []
-        | ForeignRef f _ <- fe =
+        | ForeignRef f <- fe =
             Just (resolveTableName allDefs f, refNameFn tableName c)
         | otherwise = Nothing
     ref _ _ (FieldAttrNoreference:_) = Nothing
diff --git a/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs b/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs
index e88816eb3..c81f75e62 100644
--- a/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs
+++ b/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs
@@ -26,6 +26,7 @@ import Data.Maybe (isJust)
 import Data.Monoid (Monoid(..), (<>))
 import Data.Text (Text)
 import qualified Data.Text as T
+import Data.Foldable (toList)
 
 import Database.Persist hiding (updateField)
 import Database.Persist.Sql.Orphan.PersistStore (withRawQuery)
@@ -35,7 +36,7 @@ import Database.Persist.Sql.Types.Internal
 import Database.Persist.Sql.Util
        ( commaSeparated
        , dbIdColumns
-       , entityColumnNames
+       , keyAndEntityColumnNames
        , isIdField
        , mkUpdateText
        , parseEntityValues
@@ -99,9 +100,13 @@ instance PersistQueryRead SqlBackend where
       where
         (limit, offset, orders) = limitOffsetOrder opts
 
-        parse vals = case parseEntityValues t vals of
-                       Left s -> liftIO $ throwIO $ PersistMarshalError s
-                       Right row -> return row
+        parse vals =
+            case parseEntityValues t vals of
+                Left s ->
+                    liftIO $ throwIO $
+                        PersistMarshalError ("selectSourceRes: " <> s <> ", vals: " <> T.pack (show vals ))
+                Right row ->
+                    return row
         t = entityDef $ dummyFromFilts filts
         wher conn = if null filts
                     then ""
@@ -110,7 +115,7 @@ instance PersistQueryRead SqlBackend where
             case map (orderClause False conn) orders of
                 [] -> ""
                 ords -> " ORDER BY " <> T.intercalate "," ords
-        cols = commaSeparated . entityColumnNames t
+        cols = commaSeparated . toList . keyAndEntityColumnNames t
         sql conn = connLimitOffset conn (limit,offset) $ mconcat
             [ "SELECT "
             , cols conn
@@ -126,7 +131,7 @@ instance PersistQueryRead SqlBackend where
         return $ fmap (.| CL.mapM parse) srcRes
       where
         t = entityDef $ dummyFromFilts filts
-        cols conn = T.intercalate "," $ dbIdColumns conn t
+        cols conn = T.intercalate "," $ toList $ dbIdColumns conn t
 
 
         wher conn = if null filts
@@ -156,7 +161,7 @@ instance PersistQueryRead SqlBackend where
                            [PersistDouble x] -> return [PersistInt64 (truncate x)] -- oracle returns Double
                            _ -> return xs
                       Just pdef ->
-                           let pks = map fieldHaskell $ compositeFields pdef
+                           let pks = map fieldHaskell $ toList $ compositeFields pdef
                                keyvals = map snd $ filter (\(a, _) -> let ret=isJust (find (== a) pks) in ret) $ zip (map fieldHaskell $ getEntityFields t) xs
                            in return keyvals
             case keyFromValues keyvals of
@@ -257,13 +262,14 @@ data FilterTablePrefix
     --
     -- @since 2.12.1.0
 
-filterClauseHelper :: (PersistEntity val)
-             => Maybe FilterTablePrefix -- ^ include table name or PostgresSQL EXCLUDED
-             -> Bool -- ^ include WHERE
-             -> SqlBackend
-             -> OrNull
-             -> [Filter val]
-             -> (Text, [PersistValue])
+filterClauseHelper
+    :: (PersistEntity val)
+    => Maybe FilterTablePrefix -- ^ include table name or PostgresSQL EXCLUDED
+    -> Bool -- ^ include WHERE
+    -> SqlBackend
+    -> OrNull
+    -> [Filter val]
+    -> (Text, [PersistValue])
 filterClauseHelper tablePrefix includeWhere conn orNull filters =
     (if not (T.null sql) && includeWhere
         then " WHERE " <> sql
@@ -285,85 +291,96 @@ filterClauseHelper tablePrefix includeWhere conn orNull filters =
     go (FilterOr fs)  = combine " OR " fs
     go (Filter field value pfilter) =
         let t = entityDef $ dummyFromFilts [Filter field value pfilter]
-        in case (isIdField field, entityPrimary t, allVals) of
-                 (True, Just pdef, PersistList ys:_) ->
-                    if length (compositeFields pdef) /= length ys
-                       then error $ "wrong number of entries in compositeFields vs PersistList allVals=" ++ show allVals
+        in
+            case (isIdField field, entityPrimary t, allVals) of
+                (True, Just pdef, PersistList ys:_) ->
+                    let cfields = toList $ compositeFields pdef in
+                    if length cfields /= length ys
+                    then error $ "wrong number of entries in compositeFields vs PersistList allVals=" ++ show allVals
                     else
-                      case (allVals, pfilter, isCompFilter pfilter) of
-                        ([PersistList xs], Eq, _) ->
-                           let sqlcl=T.intercalate " and " (map (\a -> connEscapeFieldName conn (fieldDB a) <> showSqlFilter pfilter <> "? ")  (compositeFields pdef))
-                           in (wrapSql sqlcl,xs)
-                        ([PersistList xs], Ne, _) ->
-                           let sqlcl=T.intercalate " or " (map (\a -> connEscapeFieldName conn (fieldDB a) <> showSqlFilter pfilter <> "? ")  (compositeFields pdef))
-                           in (wrapSql sqlcl,xs)
-                        (_, In, _) ->
-                           let xxs = transpose (map fromPersistList allVals)
-                               sqls=map (\(a,xs) -> connEscapeFieldName conn (fieldDB a) <> showSqlFilter pfilter <> "(" <> T.intercalate "," (replicate (length xs) " ?") <> ") ") (zip (compositeFields pdef) xxs)
-                           in (wrapSql (T.intercalate " and " (map wrapSql sqls)), concat xxs)
-                        (_, NotIn, _) ->
-                           let xxs = transpose (map fromPersistList allVals)
-                               sqls=map (\(a,xs) -> connEscapeFieldName conn (fieldDB a) <> showSqlFilter pfilter <> "(" <> T.intercalate "," (replicate (length xs) " ?") <> ") ") (zip (compositeFields pdef) xxs)
-                           in (wrapSql (T.intercalate " or " (map wrapSql sqls)), concat xxs)
-                        ([PersistList xs], _, True) ->
-                           let zs = tail (inits (compositeFields pdef))
-                               sql1 = map (\b -> wrapSql (T.intercalate " and " (map (\(i,a) -> sql2 (i==length b) a) (zip [1..] b)))) zs
-                               sql2 islast a = connEscapeFieldName conn (fieldDB a) <> (if islast then showSqlFilter pfilter else showSqlFilter Eq) <> "? "
-                               sqlcl = T.intercalate " or " sql1
-                           in (wrapSql sqlcl, concat (tail (inits xs)))
-                        (_, BackendSpecificFilter _, _) -> error "unhandled type BackendSpecificFilter for composite/non id primary keys"
-                        _ -> error $ "unhandled type/filter for composite/non id primary keys pfilter=" ++ show pfilter ++ " persistList="++show allVals
-                 (True, Just pdef, []) ->
-                     error $ "empty list given as filter value filter=" ++ show pfilter ++ " persistList=" ++ show allVals ++ " pdef=" ++ show pdef
-                 (True, Just pdef, _) ->
-                     error $ "unhandled error for composite/non id primary keys filter=" ++ show pfilter ++ " persistList=" ++ show allVals ++ " pdef=" ++ show pdef
-
-                 _ ->   case (isNull, pfilter, length notNullVals) of
-                            (True, Eq, _) -> (name <> " IS NULL", [])
-                            (True, Ne, _) -> (name <> " IS NOT NULL", [])
-                            (False, Ne, _) -> (T.concat
-                                [ "("
-                                , name
-                                , " IS NULL OR "
-                                , name
-                                , " <> "
-                                , qmarks
-                                , ")"
-                                ], notNullVals)
-                            -- We use 1=2 (and below 1=1) to avoid using TRUE and FALSE, since
-                            -- not all databases support those words directly.
-                            (_, In, 0) -> ("1=2" <> orNullSuffix, [])
-                            (False, In, _) -> (name <> " IN " <> qmarks <> orNullSuffix, allVals)
-                            (True, In, _) -> (T.concat
-                                [ "("
-                                , name
-                                , " IS NULL OR "
-                                , name
-                                , " IN "
-                                , qmarks
-                                , ")"
-                                ], notNullVals)
-                            (False, NotIn, 0) -> ("1=1", [])
-                            (True, NotIn, 0) -> (name <> " IS NOT NULL", [])
-                            (False, NotIn, _) -> (T.concat
-                                [ "("
-                                , name
-                                , " IS NULL OR "
-                                , name
-                                , " NOT IN "
-                                , qmarks
-                                , ")"
-                                ], notNullVals)
-                            (True, NotIn, _) -> (T.concat
-                                [ "("
-                                , name
-                                , " IS NOT NULL AND "
-                                , name
-                                , " NOT IN "
-                                , qmarks
-                                , ")"
-                                ], notNullVals)
-                            _ -> (name <> showSqlFilter pfilter <> "?" <> orNullSuffix, allVals)
+                        case (allVals, pfilter, isCompFilter pfilter) of
+                            ([PersistList xs], Eq, _) ->
+                                let
+                                    sqlcl =
+                                        T.intercalate " and "
+                                        (map (\a -> connEscapeFieldName conn (fieldDB a) <> showSqlFilter pfilter <> "? ")  cfields)
+                                in
+                                    (wrapSql sqlcl, xs)
+                            ([PersistList xs], Ne, _) ->
+                                let
+                                    sqlcl =
+                                        T.intercalate " or " (map (\a -> connEscapeFieldName conn (fieldDB a) <> showSqlFilter pfilter <> "? ")  cfields)
+                                in
+                                    (wrapSql sqlcl, xs)
+                            (_, In, _) ->
+                               let xxs = transpose (map fromPersistList allVals)
+                                   sqls=map (\(a,xs) -> connEscapeFieldName conn (fieldDB a) <> showSqlFilter pfilter <> "(" <> T.intercalate "," (replicate (length xs) " ?") <> ") ") (zip cfields xxs)
+                               in (wrapSql (T.intercalate " and " (map wrapSql sqls)), concat xxs)
+                            (_, NotIn, _) ->
+                                let
+                                    xxs = transpose (map fromPersistList allVals)
+                                    sqls = map (\(a,xs) -> connEscapeFieldName conn (fieldDB a) <> showSqlFilter pfilter <> "(" <> T.intercalate "," (replicate (length xs) " ?") <> ") ") (zip cfields xxs)
+                                in
+                                    (wrapSql (T.intercalate " or " (map wrapSql sqls)), concat xxs)
+                            ([PersistList xs], _, True) ->
+                               let zs = tail (inits (toList $ compositeFields pdef))
+                                   sql1 = map (\b -> wrapSql (T.intercalate " and " (map (\(i,a) -> sql2 (i==length b) a) (zip [1..] b)))) zs
+                                   sql2 islast a = connEscapeFieldName conn (fieldDB a) <> (if islast then showSqlFilter pfilter else showSqlFilter Eq) <> "? "
+                                   sqlcl = T.intercalate " or " sql1
+                               in (wrapSql sqlcl, concat (tail (inits xs)))
+                            (_, BackendSpecificFilter _, _) -> error "unhandled type BackendSpecificFilter for composite/non id primary keys"
+                            _ -> error $ "unhandled type/filter for composite/non id primary keys pfilter=" ++ show pfilter ++ " persistList="++show allVals
+                (True, Just pdef, []) ->
+                    error $ "empty list given as filter value filter=" ++ show pfilter ++ " persistList=" ++ show allVals ++ " pdef=" ++ show pdef
+                (True, Just pdef, _) ->
+                    error $ "unhandled error for composite/non id primary keys filter=" ++ show pfilter ++ " persistList=" ++ show allVals ++ " pdef=" ++ show pdef
+
+                _ ->   case (isNull, pfilter, length notNullVals) of
+                           (True, Eq, _) -> (name <> " IS NULL", [])
+                           (True, Ne, _) -> (name <> " IS NOT NULL", [])
+                           (False, Ne, _) -> (T.concat
+                               [ "("
+                               , name
+                               , " IS NULL OR "
+                               , name
+                               , " <> "
+                               , qmarks
+                               , ")"
+                               ], notNullVals)
+                           -- We use 1=2 (and below 1=1) to avoid using TRUE and FALSE, since
+                           -- not all databases support those words directly.
+                           (_, In, 0) -> ("1=2" <> orNullSuffix, [])
+                           (False, In, _) -> (name <> " IN " <> qmarks <> orNullSuffix, allVals)
+                           (True, In, _) -> (T.concat
+                               [ "("
+                               , name
+                               , " IS NULL OR "
+                               , name
+                               , " IN "
+                               , qmarks
+                               , ")"
+                               ], notNullVals)
+                           (False, NotIn, 0) -> ("1=1", [])
+                           (True, NotIn, 0) -> (name <> " IS NOT NULL", [])
+                           (False, NotIn, _) -> (T.concat
+                               [ "("
+                               , name
+                               , " IS NULL OR "
+                               , name
+                               , " NOT IN "
+                               , qmarks
+                               , ")"
+                               ], notNullVals)
+                           (True, NotIn, _) -> (T.concat
+                               [ "("
+                               , name
+                               , " IS NOT NULL AND "
+                               , name
+                               , " NOT IN "
+                               , qmarks
+                               , ")"
+                               ], notNullVals)
+                           _ -> (name <> showSqlFilter pfilter <> "?" <> orNullSuffix, allVals)
 
       where
         isCompFilter Lt = True
diff --git a/persistent/Database/Persist/Sql/Orphan/PersistStore.hs b/persistent/Database/Persist/Sql/Orphan/PersistStore.hs
index 3a6cb03a9..1683c6a27 100644
--- a/persistent/Database/Persist/Sql/Orphan/PersistStore.hs
+++ b/persistent/Database/Persist/Sql/Orphan/PersistStore.hs
@@ -1,29 +1,28 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE DeriveGeneric #-}
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Database.Persist.Sql.Orphan.PersistStore
-  ( withRawQuery
-  , BackendKey(..)
-  , toSqlKey
-  , fromSqlKey
-  , getFieldName
-  , getTableName
-  , tableDBName
-  , fieldDBName
-  ) where
+    ( withRawQuery
+    , BackendKey(..)
+    , toSqlKey
+    , fromSqlKey
+    , getFieldName
+    , getTableName
+    , tableDBName
+    , fieldDBName
+    ) where
 
-import GHC.Generics (Generic)
 import Control.Exception (throwIO)
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Reader (ReaderT, ask)
 import Data.Acquire (with)
 import qualified Data.Aeson as A
 import Data.ByteString.Char8 (readInteger)
-import Data.Conduit (ConduitM, (.|), runConduit)
+import Data.Conduit (ConduitM, runConduit, (.|))
 import qualified Data.Conduit.List as CL
 import qualified Data.Foldable as Foldable
 import Data.Function (on)
@@ -35,8 +34,9 @@ import Data.Monoid (mappend, (<>))
 import Data.Text (Text, unpack)
 import qualified Data.Text as T
 import Data.Void (Void)
+import GHC.Generics (Generic)
+import Web.HttpApiData (FromHttpApiData, ToHttpApiData)
 import Web.PathPieces (PathPiece)
-import Web.HttpApiData (ToHttpApiData, FromHttpApiData)
 
 import Database.Persist
 import Database.Persist.Class ()
@@ -44,9 +44,15 @@ import Database.Persist.Sql.Class (PersistFieldSql)
 import Database.Persist.Sql.Raw
 import Database.Persist.Sql.Types
 import Database.Persist.Sql.Types.Internal
-import Database.Persist.Sql.Util (
-    dbIdColumns, keyAndEntityColumnNames, parseEntityValues, entityColumnNames
-  , updatePersistValue, mkUpdateText, commaSeparated, mkInsertValues)
+import Database.Persist.Sql.Util
+       ( commaSeparated
+       , dbIdColumns
+       , keyAndEntityColumnNames
+       , mkInsertValues
+       , mkUpdateText
+       , parseEntityValues
+       , updatePersistValue
+       )
 
 withRawQuery :: MonadIO m
              => Text
@@ -66,7 +72,8 @@ fromSqlKey = unSqlBackendKey . toBackendKey
 whereStmtForKey :: PersistEntity record => SqlBackend -> Key record -> Text
 whereStmtForKey conn k =
     T.intercalate " AND "
-  $ map (<> "=? ")
+  $ Foldable.toList
+  $ fmap (<> "=? ")
   $ dbIdColumns conn entDef
   where
     entDef = entityDef $ dummyFromKey k
@@ -195,9 +202,10 @@ instance PersistStoreWrite SqlBackend where
                 ISRManyKeys sql fs -> do
                     rawExecute sql vals
                     case entityPrimary t of
-                       Nothing -> error $ "ISRManyKeys is used when Primary is defined " ++ show sql
+                       Nothing ->
+                           error $ "ISRManyKeys is used when Primary is defined " ++ show sql
                        Just pdef ->
-                            let pks = map fieldHaskell $ compositeFields pdef
+                            let pks = Foldable.toList $ fmap fieldHaskell $ compositeFields pdef
                                 keyvals = map snd $ filter (\(a, _) -> let ret=isJust (find (== a) pks) in ret) $ zip (map fieldHaskell $ getEntityFields t) fs
                             in  case keyFromValues keyvals of
                                     Right k -> return k
@@ -323,7 +331,7 @@ instance PersistStoreRead SqlBackend where
     getMany ks@(k:_)= do
         conn <- ask
         let t = entityDef . dummyFromKey $ k
-        let cols = commaSeparated . entityColumnNames t
+        let cols = commaSeparated . Foldable.toList . keyAndEntityColumnNames t
         let wher = whereStmtForKeys conn ks
         let sql = T.concat
                 [ "SELECT "
@@ -335,7 +343,8 @@ instance PersistStoreRead SqlBackend where
                 ]
         let parse vals
                 = case parseEntityValues t vals of
-                    Left s -> liftIO $ throwIO $ PersistMarshalError s
+                    Left s -> liftIO $ throwIO $
+                        PersistMarshalError ("getBy: " <> s)
                     Right row -> return row
         withRawQuery sql (Foldable.foldMap keyToValues ks) $ do
             es <- CL.mapM parse .| CL.consume
@@ -361,7 +370,7 @@ insrepHelper :: (MonadIO m, PersistEntity val)
 insrepHelper _       []  = return ()
 insrepHelper command es = do
     conn <- ask
-    let columnNames = keyAndEntityColumnNames entDef conn
+    let columnNames = Foldable.toList $ keyAndEntityColumnNames entDef conn
     rawExecute (sql conn columnNames) vals
   where
     entDef = entityDef $ map entityVal es
@@ -372,7 +381,7 @@ insrepHelper command es = do
         , "("
         , T.intercalate "," columnNames
         , ") VALUES ("
-        , T.intercalate "),(" $ replicate (length es) $ T.intercalate "," $ map (const "?") columnNames
+        , T.intercalate "),(" $ replicate (length es) $ T.intercalate "," $ fmap (const "?") columnNames
         , ")"
         ]
     vals = Foldable.foldMap entityValues es
diff --git a/persistent/Database/Persist/Sql/Orphan/PersistUnique.hs b/persistent/Database/Persist/Sql/Orphan/PersistUnique.hs
index 3d4338727..27c01be99 100644
--- a/persistent/Database/Persist/Sql/Orphan/PersistUnique.hs
+++ b/persistent/Database/Persist/Sql/Orphan/PersistUnique.hs
@@ -10,9 +10,9 @@ import Control.Monad.Trans.Reader (ask)
 import qualified Data.Conduit.List as CL
 import Data.Function (on)
 import Data.List (nubBy)
-import qualified Data.List.NonEmpty as NEL
 import Data.Monoid (mappend)
 import qualified Data.Text as T
+import Data.Foldable (toList)
 
 import Database.Persist
 import Database.Persist.Class.PersistUnique (defaultUpsertBy, defaultPutMany, persistUniqueKeyValues)
@@ -32,7 +32,7 @@ instance PersistUniqueWrite SqlBackend where
                             [] -> defaultUpsertBy uniqueKey record updates
                             _:_ -> do
                                 let upds = T.intercalate "," $ map mkUpdateText updates
-                                    sql = upsertSql t (NEL.fromList $ persistUniqueToFieldNames uniqueKey) upds
+                                    sql = upsertSql t (persistUniqueToFieldNames uniqueKey) upds
                                     vals = map toPersistValue (toPersistFields record)
                                         ++ map updatePersistValue updates
                                         ++ unqs uniqueKey
@@ -51,7 +51,7 @@ instance PersistUniqueWrite SqlBackend where
         rawExecute sql' vals
       where
         t = entityDef $ dummyFromUnique uniq
-        go = map snd . persistUniqueToFieldNames
+        go = toList . fmap snd . persistUniqueToFieldNames
         go' conn x = connEscapeFieldName conn x `mappend` "=?"
         sql conn =
             T.concat
@@ -88,7 +88,7 @@ instance PersistUniqueRead SqlBackend where
         let sql =
                 T.concat
                     [ "SELECT "
-                    , T.intercalate "," $ dbColumns conn t
+                    , T.intercalate "," $ toList $ dbColumns conn t
                     , " FROM "
                     , connEscapeTableName conn t
                     , " WHERE "
@@ -109,7 +109,7 @@ instance PersistUniqueRead SqlBackend where
             T.intercalate " AND " $ map (go conn) $ toFieldNames' uniq
         go conn x = connEscapeFieldName conn x `mappend` "=?"
         t = entityDef $ dummyFromUnique uniq
-        toFieldNames' = map snd . persistUniqueToFieldNames
+        toFieldNames' = toList . fmap snd . persistUniqueToFieldNames
 
 instance PersistUniqueRead SqlReadBackend where
     getBy uniq = withBaseBackend $ getBy uniq
diff --git a/persistent/Database/Persist/Sql/Raw.hs b/persistent/Database/Persist/Sql/Raw.hs
index 8c5eda0de..4de7f0ef9 100644
--- a/persistent/Database/Persist/Sql/Raw.hs
+++ b/persistent/Database/Persist/Sql/Raw.hs
@@ -17,7 +17,6 @@ import qualified Data.Text as T
 import Database.Persist
 import Database.Persist.Sql.Types
 import Database.Persist.Sql.Types.Internal
-import Database.Persist.SqlBackend.Internal
 import Database.Persist.Sql.Class
 
 rawQuery :: (MonadResource m, MonadReader env m, BackendCompatible SqlBackend env)
diff --git a/persistent/Database/Persist/Sql/Types/Internal.hs b/persistent/Database/Persist/Sql/Types/Internal.hs
index 4862b1629..caa3b998f 100644
--- a/persistent/Database/Persist/Sql/Types/Internal.hs
+++ b/persistent/Database/Persist/Sql/Types/Internal.hs
@@ -27,8 +27,6 @@ module Database.Persist.Sql.Types.Internal
     , IsSqlBackend
     ) where
 
-import Data.List.NonEmpty (NonEmpty(..))
-import Control.Monad.Logger (LogSource, LogLevel, Loc)
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask)
 import Data.Monoid ((<>))
diff --git a/persistent/Database/Persist/Sql/Util.hs b/persistent/Database/Persist/Sql/Util.hs
index 505ef4f64..e9a61ecf1 100644
--- a/persistent/Database/Persist/Sql/Util.hs
+++ b/persistent/Database/Persist/Sql/Util.hs
@@ -1,6 +1,7 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
 module Database.Persist.Sql.Util
     ( parseEntityValues
-    , entityColumnNames
     , keyAndEntityColumnNames
     , entityColumnCount
     , isIdField
@@ -19,31 +20,42 @@ module Database.Persist.Sql.Util
     , mkInsertPlaceholders
     ) where
 
+import Data.List.NonEmpty (NonEmpty(..))
 import qualified Data.Maybe as Maybe
 import Data.Monoid ((<>))
 import Data.Text (Text, pack)
 import qualified Data.Text as T
 
-import Database.Persist (
-    Entity(Entity), EntityDef, EntityField, FieldNameHS(FieldNameHS)
-  , PersistEntity(..), PersistValue
-  , keyFromValues, fromPersistValues, fieldDB, getEntityId, entityPrimary
-  , getEntityFields, getEntityKeyFields, fieldHaskell, compositeFields, persistFieldDef
-  , keyAndEntityFields, toPersistValue, FieldNameDB, Update(..), PersistUpdate(..)
-  , FieldDef(..)
-  )
+import Database.Persist
+       ( Entity(Entity)
+       , EntityDef
+       , EntityField
+       , FieldDef(..)
+       , FieldNameDB
+       , FieldNameHS(FieldNameHS)
+       , PersistEntity(..)
+       , PersistUpdate(..)
+       , PersistValue
+       , Update(..)
+       , compositeFields
+       , entityPrimary
+       , fieldDB
+       , fieldHaskell
+       , fromPersistValues
+       , getEntityFields
+       , getEntityKeyFields
+       , keyAndEntityFields
+       , keyFromValues
+       , persistFieldDef
+       , toPersistValue
+       )
 
 import Database.Persist.Sql.Types (Sql)
-import Database.Persist.SqlBackend.Internal(SqlBackend(..))
-
-entityColumnNames :: EntityDef -> SqlBackend -> [Sql]
-entityColumnNames ent conn =
-     (if hasNaturalKey ent
-      then [] else [connEscapeFieldName conn . fieldDB $ getEntityId ent])
-  <> map (connEscapeFieldName conn . fieldDB) (getEntityFields ent)
+import Database.Persist.SqlBackend.Internal (SqlBackend(..))
 
-keyAndEntityColumnNames :: EntityDef -> SqlBackend -> [Sql]
-keyAndEntityColumnNames ent conn = map (connEscapeFieldName conn . fieldDB) (keyAndEntityFields ent)
+keyAndEntityColumnNames :: EntityDef -> SqlBackend -> NonEmpty Sql
+keyAndEntityColumnNames ent conn =
+    fmap (connEscapeFieldName conn . fieldDB) (keyAndEntityFields ent)
 
 entityColumnCount :: EntityDef -> Int
 entityColumnCount e = length (getEntityFields e)
@@ -131,33 +143,31 @@ hasCompositePrimaryKey ed =
     case entityPrimary ed of
         Just cdef ->
             case compositeFields cdef of
-                (_ : _ : _) ->
+                (_ :| _ : _) ->
                     True
                 _ ->
                     False
         Nothing ->
             False
 
-dbIdColumns :: SqlBackend -> EntityDef -> [Text]
+dbIdColumns :: SqlBackend -> EntityDef -> NonEmpty Text
 dbIdColumns conn = dbIdColumnsEsc (connEscapeFieldName conn)
 
-dbIdColumnsEsc :: (FieldNameDB -> Text) -> EntityDef -> [Text]
-dbIdColumnsEsc esc t = map (esc . fieldDB) $ getEntityKeyFields t
+dbIdColumnsEsc :: (FieldNameDB -> Text) -> EntityDef -> NonEmpty Text
+dbIdColumnsEsc esc t = fmap (esc . fieldDB) $ getEntityKeyFields t
 
-dbColumns :: SqlBackend -> EntityDef -> [Text]
-dbColumns conn t = case entityPrimary t of
-    Just _  -> flds
-    Nothing -> escapeColumn (getEntityId t) : flds
+dbColumns :: SqlBackend -> EntityDef -> NonEmpty Text
+dbColumns conn =
+    fmap escapeColumn . keyAndEntityFields
   where
     escapeColumn = connEscapeFieldName conn . fieldDB
-    flds = map escapeColumn (getEntityFields t)
 
 parseEntityValues :: PersistEntity record
                   => EntityDef -> [PersistValue] -> Either Text (Entity record)
 parseEntityValues t vals =
     case entityPrimary t of
       Just pdef ->
-            let pks = map fieldHaskell $ compositeFields pdef
+            let pks = fmap fieldHaskell $ compositeFields pdef
                 keyvals = map snd . filter ((`elem` pks) . fst)
                         $ zip (map fieldHaskell $ getEntityFields t) vals
             in fromPersistValuesComposite' keyvals vals
@@ -182,7 +192,10 @@ parseEntityValues t vals =
                 Right key -> Right (Entity key xs')
 
 
-isIdField :: PersistEntity record => EntityField record typ -> Bool
+isIdField
+    :: forall record typ. (PersistEntity record)
+    => EntityField record typ
+    -> Bool
 isIdField f = fieldHaskell (persistFieldDef f) == FieldNameHS "Id"
 
 -- | Gets the 'FieldDef' for an 'Update'.
diff --git a/persistent/Database/Persist/SqlBackend/Internal.hs b/persistent/Database/Persist/SqlBackend/Internal.hs
index ab2958631..c059845ad 100644
--- a/persistent/Database/Persist/SqlBackend/Internal.hs
+++ b/persistent/Database/Persist/SqlBackend/Internal.hs
@@ -3,19 +3,13 @@
 
 module Database.Persist.SqlBackend.Internal where
 
-import Data.String
 import Data.Map (Map)
 import Data.List.NonEmpty (NonEmpty)
-import Control.Monad.Logger (LogSource, LogLevel, Loc, LogStr)
 import Data.Text (Text)
-import Data.Acquire
 import Database.Persist.Class.PersistStore
-import Conduit
 import Database.Persist.Types.Base
 import Database.Persist.Names
-import Data.Int
 import Data.IORef
-import Control.Monad.Reader
 import Database.Persist.SqlBackend.Internal.MkSqlBackend
 import Database.Persist.SqlBackend.Internal.Statement
 import Database.Persist.SqlBackend.Internal.InsertSqlResult
diff --git a/persistent/Database/Persist/SqlBackend/Internal/MkSqlBackend.hs b/persistent/Database/Persist/SqlBackend/Internal/MkSqlBackend.hs
index e7c04bb5c..ca1dc3a87 100644
--- a/persistent/Database/Persist/SqlBackend/Internal/MkSqlBackend.hs
+++ b/persistent/Database/Persist/SqlBackend/Internal/MkSqlBackend.hs
@@ -2,17 +2,10 @@
 
 module Database.Persist.SqlBackend.Internal.MkSqlBackend where
 
-import Conduit
 import Control.Monad.Logger (Loc, LogLevel, LogSource, LogStr)
-import Control.Monad.Reader
-import Data.Acquire
 import Data.IORef
-import Data.Int
-import Data.List.NonEmpty (NonEmpty)
 import Data.Map (Map)
-import Data.String
 import Data.Text (Text)
-import Database.Persist.Class.PersistStore
 import Database.Persist.SqlBackend.Internal.Statement
 import Database.Persist.SqlBackend.Internal.InsertSqlResult
 import Database.Persist.SqlBackend.Internal.IsolationLevel
diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
index 92537520d..dddaac81a 100644
--- a/persistent/Database/Persist/TH.hs
+++ b/persistent/Database/Persist/TH.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveLift #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -28,6 +29,7 @@ module Database.Persist.TH
     , persistManyFileWith
       -- * Turn @EntityDef@s into types
     , mkPersist
+    , mkPersistWith
     , MkPersistSettings
     , mpsBackend
     , mpsGeneric
@@ -69,6 +71,8 @@ module Database.Persist.TH
 
 import Prelude hiding (concat, exp, splitAt, take, (++))
 
+import GHC.Stack (HasCallStack)
+import Data.Coerce
 import Control.Monad
 import Data.Aeson
        ( FromJSON(parseJSON)
@@ -89,12 +93,13 @@ import Data.Int (Int64)
 import Data.Ix (Ix)
 import Data.List (foldl')
 import qualified Data.List as List
+import Data.List.NonEmpty (NonEmpty(..))
 import qualified Data.List.NonEmpty as NEL
 import qualified Data.Map as M
 import Data.Maybe (fromMaybe, isJust, listToMaybe, mapMaybe)
 import Data.Monoid (mappend, mconcat, (<>))
 import Data.Proxy (Proxy(Proxy))
-import Data.Text (Text, append, concat, cons, pack, stripSuffix, uncons, unpack)
+import Data.Text (Text, concat, cons, pack, stripSuffix, uncons, unpack)
 import qualified Data.Text as T
 import Data.Text.Encoding (decodeUtf8)
 import qualified Data.Text.Encoding as TE
@@ -102,7 +107,7 @@ import Data.Typeable (Typeable)
 import GHC.Generics (Generic)
 import GHC.TypeLits
 import Instances.TH.Lift ()
-    -- Bring `Lift (Map k v)` instance into scope, as well as `Lift Text`
+    -- Bring `Lift (fmap k v)` instance into scope, as well as `Lift Text`
     -- instance on pre-1.2.4 versions of `text`
 import Data.Foldable (toList)
 import qualified Data.Set as Set
@@ -115,13 +120,13 @@ import Web.PathPieces (PathPiece(..))
 
 import Database.Persist
 import Database.Persist.Quasi
+import Database.Persist.Quasi.Internal
 import Database.Persist.Sql
        (Migration, PersistFieldSql, SqlBackend, migrate, sqlType)
 
-import Database.Persist.EntityDef.Internal (EntityDef(..))
+import Database.Persist.EntityDef.Internal (EntityDef(..), EntityIdDef(..))
 import Database.Persist.ImplicitIdDef (autoIncrementingInteger)
 import Database.Persist.ImplicitIdDef.Internal
-import Database.Persist.Types.Base (toEmbedEntityDef)
 
 -- | Converts a quasi-quoted syntax into a list of entity definitions, to be
 -- used as input to the template haskell generation code (mkPersist).
@@ -211,151 +216,484 @@ getFileContents = fmap decodeUtf8 . BS.readFile
 -- fix the cross-references between them at runtime to create a 'Migration'.
 --
 -- @since 2.7.2
-embedEntityDefs :: [EntityDef] -> [EntityDef]
-embedEntityDefs = snd . embedEntityDefsMap
-
-embedEntityDefsMap :: [EntityDef] -> (M.Map EntityNameHS EmbedEntityDef, [EntityDef])
-embedEntityDefsMap rawEnts = (embedEntityMap, noCycleEnts)
+embedEntityDefs
+    :: [EntityDef]
+    -- ^ A list of 'EntityDef' that have been defined in a previous 'mkPersist'
+    -- call.
+    --
+    -- @since 2.13.0.0
+    -> [UnboundEntityDef]
+    -> [UnboundEntityDef]
+embedEntityDefs eds = snd . embedEntityDefsMap eds
+
+embedEntityDefsMap
+    :: [EntityDef]
+    -- ^ A list of 'EntityDef' that have been defined in a previous 'mkPersist'
+    -- call.
+    --
+    -- @since 2.13.0.0
+    -> [UnboundEntityDef]
+    -> (EmbedEntityMap, [UnboundEntityDef])
+embedEntityDefsMap existingEnts rawEnts =
+    (embedEntityMap, noCycleEnts)
   where
-    noCycleEnts = map breakEntDefCycle entsWithEmbeds
+    noCycleEnts = entsWithEmbeds
     -- every EntityDef could reference each-other (as an EmbedRef)
     -- let Haskell tie the knot
     embedEntityMap = constructEmbedEntityMap entsWithEmbeds
-    entsWithEmbeds = map setEmbedEntity rawEnts
-    setEmbedEntity ent =
-        overEntityFields
-            (map (setEmbedField (entityHaskell ent) embedEntityMap))
-            ent
-
--- self references are already broken
--- look at every emFieldEmbed to see if it refers to an already seen EntityNameHS
--- so start with entityHaskell ent and accumulate embeddedHaskell em
-breakEntDefCycle :: EntityDef -> EntityDef
-breakEntDefCycle entDef =
-    overEntityFields (map (breakCycleField (entityHaskell entDef))) entDef
-  where
-    breakCycleField entName f =
-        case fieldReference f of
-            EmbedRef em ->
-                f { fieldReference = EmbedRef $ breakCycleEmbed [entName] em }
-            _ ->
-                f
-
-    breakCycleEmbed ancestors em =
-        em { embeddedFields = breakCycleEmField (emName : ancestors) <$> embeddedFields em
-           }
-        where
-            emName = embeddedHaskell em
-
-    breakCycleEmField ancestors emf = case embeddedHaskell <$> membed of
-        Nothing -> emf
-        Just embName ->
-            if embName `elem` ancestors
-            then
-                emf { emFieldEmbed = Nothing, emFieldCycle = Just embName }
-            else emf { emFieldEmbed = breakCycleEmbed ancestors <$> membed }
-        where
-            membed = emFieldEmbed emf
+    entsWithEmbeds = fmap setEmbedEntity (rawEnts <> map unbindEntityDef existingEnts)
+    setEmbedEntity ubEnt =
+        let
+            ent = unboundEntityDef ubEnt
+        in
+            ubEnt
+                { unboundEntityDef =
+                    overEntityFields
+                        (fmap (setEmbedField (entityHaskell ent) embedEntityMap))
+                        ent
+                }
+
 
 -- | Calls 'parse' to Quasi.parse individual entities in isolation
 -- afterwards, sets references to other entities
 --
+-- In 2.13.0.0, this was changed to splice in @['UnboundEntityDef']@
+-- instead of @['EntityDef']@.
+--
 -- @since 2.5.3
 parseReferences :: PersistSettings -> Text -> Q Exp
-parseReferences ps s = lift $
-    map (mkEntityDefSqlTypeExp embedEntityMap entityMap) noCycleEnts
+parseReferences ps s = lift $ parse ps s
+
+preprocessUnboundDefs
+    :: [EntityDef]
+    -> [UnboundEntityDef]
+    -> (M.Map EntityNameHS (), [UnboundEntityDef])
+preprocessUnboundDefs preexistingEntities unboundDefs =
+    (embedEntityMap, noCycleEnts)
   where
-    (embedEntityMap, noCycleEnts) = embedEntityDefsMap $ parse ps s
-    entityMap = constructEntityMap noCycleEnts
+    (embedEntityMap, noCycleEnts) =
+        embedEntityDefsMap preexistingEntities unboundDefs
 
 stripId :: FieldType -> Maybe Text
 stripId (FTTypeCon Nothing t) = stripSuffix "Id" t
 stripId _ = Nothing
 
-foreignReference :: FieldDef -> Maybe EntityNameHS
-foreignReference field = case fieldReference field of
-    ForeignRef ref _ -> Just ref
-    _              -> Nothing
-
--- fieldSqlType at parse time can be an Exp
--- This helps delay setting fieldSqlType until lift time
-data EntityDefSqlTypeExp
-    = EntityDefSqlTypeExp EntityDef SqlTypeExp [SqlTypeExp]
-    deriving Show
-
-data SqlTypeExp
-    = SqlTypeExp FieldType
-    | SqlType' SqlType
-    deriving Show
+liftAndFixKeys
+    :: MkPersistSettings
+    -> M.Map EntityNameHS a
+    -> EntityMap
+    -> UnboundEntityDef
+    -> Q Exp
+liftAndFixKeys mps emEntities entityMap unboundEnt =
+    let
+        ent =
+            unboundEntityDef unboundEnt
+        fields =
+            getUnboundFieldDefs unboundEnt
+    in
+        [|
+    ent
+        { entityFields =
+            $(ListE <$> traverse combinedFixFieldDef fields)
+        , entityId =
+            $(fixPrimarySpec mps unboundEnt)
+        , entityForeigns =
+            $(fixUnboundForeignDefs (unboundForeignDefs unboundEnt))
+        }
+    |]
+  where
+    fixUnboundForeignDefs
+        :: [UnboundForeignDef]
+        -> Q Exp
+    fixUnboundForeignDefs fdefs =
+        fmap ListE $ forM fdefs fixUnboundForeignDef
+      where
+        fixUnboundForeignDef UnboundForeignDef{..} =
+            [|
+            unboundForeignDef
+                { foreignFields =
+                    $(lift fixForeignFields)
+                , foreignNullable =
+                    $(lift fixForeignNullable)
+                , foreignRefTableDBName =
+                    $(lift fixForeignRefTableDBName)
+                }
+            |]
+          where
+            fixForeignRefTableDBName =
+                entityDB (unboundEntityDef parentDef)
+            foreignFieldNames =
+                case unboundForeignFields of
+                    FieldListImpliedId ffns ->
+                        ffns
+                    FieldListHasReferences references ->
+                        fmap ffrSourceField references
+            parentDef =
+                case M.lookup parentTableName entityMap of
+                    Nothing ->
+                        error $ mconcat
+                        [ "Foreign table not defined: "
+                        , show parentTableName
+                        ]
+                    Just a ->
+                        a
+            parentTableName =
+                foreignRefTableHaskell unboundForeignDef
+            fixForeignFields :: [(ForeignFieldDef, ForeignFieldDef)]
+            fixForeignFields =
+                case unboundForeignFields of
+                    FieldListImpliedId ffns ->
+                        mkReferences $ toList ffns
+                    FieldListHasReferences references ->
+                        toList $ fmap convReferences references
+              where
+                -- in this case, we're up against the implied ID of the parent
+                -- dodgy assumption: columns are listed in the right order. we
+                -- can't check this any more clearly right now.
+                mkReferences fieldNames
+                    | length fieldNames /= length parentKeyFieldNames =
+                        error $ mconcat
+                            [ "Foreign reference needs to have the same number "
+                            , "of fields as the target table."
+                            , "\n  Table        : "
+                            , show (getUnboundEntityNameHS unboundEnt)
+                            , "\n  Foreign Table: "
+                            , show parentTableName
+                            , "\n  Fields       : "
+                            , show fieldNames
+                            , "\n  Parent fields: "
+                            , show (fmap fst parentKeyFieldNames)
+                            , "\n\nYou can use the References keyword to fix this."
+                            ]
+                    | otherwise =
+                        zip (fmap (withDbName fieldStore) fieldNames) parentKeyFieldNames
+                  where
+                    parentKeyFieldNames
+                        :: [(FieldNameHS, FieldNameDB)]
+                    parentKeyFieldNames =
+                        case unboundPrimarySpec parentDef of
+                            NaturalKey ucd ->
+                                fmap (withDbName parentFieldStore) (unboundCompositeCols ucd)
+                            SurrogateKey uid ->
+                                [(FieldNameHS "Id", unboundIdDBName  uid)]
+                            DefaultKey dbName ->
+                                [(FieldNameHS "Id", dbName)]
+                withDbName store fieldNameHS =
+                    ( fieldNameHS
+                    , findDBName store fieldNameHS
+                    )
+                convReferences
+                    :: ForeignFieldReference
+                    -> (ForeignFieldDef, ForeignFieldDef)
+                convReferences ForeignFieldReference {..} =
+                    ( withDbName fieldStore ffrSourceField
+                    , withDbName parentFieldStore ffrTargetField
+                    )
+            fixForeignNullable =
+                all ((NotNullable /=) . isFieldNullable) foreignFieldNames
+              where
+                isFieldNullable fieldNameHS =
+                    case getFieldDef fieldNameHS fieldStore of
+                        Nothing ->
+                            error "Field name not present in map"
+                        Just a ->
+                            nullable (unboundFieldAttrs a)
+
+            fieldStore =
+                mkFieldStore unboundEnt
+            parentFieldStore =
+                mkFieldStore parentDef
+            findDBName store fieldNameHS =
+                case getFieldDBName fieldNameHS store of
+                    Nothing ->
+                        error $ mconcat
+                            [ "findDBName: failed to fix dbname for: "
+                            , show fieldNameHS
+                            ]
+                    Just a->
+                        a
+
+    combinedFixFieldDef :: UnboundFieldDef -> Q Exp
+    combinedFixFieldDef ufd@UnboundFieldDef{..} =
+        [|
+        FieldDef
+            { fieldHaskell =
+                unboundFieldNameHS
+            , fieldDB =
+                unboundFieldNameDB
+            , fieldType =
+                unboundFieldType
+            , fieldSqlType =
+                $(sqlTyp')
+            , fieldAttrs =
+                unboundFieldAttrs
+            , fieldStrict =
+                unboundFieldStrict
+            , fieldReference =
+                $(fieldRef')
+            , fieldCascade =
+                unboundFieldCascade
+            , fieldComments =
+                unboundFieldComments
+            , fieldGenerated =
+                unboundFieldGenerated
+            , fieldIsImplicitIdColumn =
+                False
+            }
+        |]
+      where
+        sqlTypeExp =
+            getSqlType emEntities entityMap ufd
+        FieldDef _x _ _ _ _ _ _ _ _ _ _ =
+            error "need to update this record wildcard match"
+        (fieldRef', sqlTyp') =
+            case extractForeignRef entityMap ufd of
+                Just targetTable ->
+                    (lift (ForeignRef targetTable), liftSqlTypeExp (SqlTypeReference targetTable))
+                Nothing ->
+                    (lift NoReference, liftSqlTypeExp sqlTypeExp)
+
+data FieldStore
+    = FieldStore
+    { fieldStoreMap :: M.Map FieldNameHS UnboundFieldDef
+    , fieldStoreId :: Maybe FieldNameDB
+    , fieldStoreEntity :: UnboundEntityDef
+    }
 
-instance Lift SqlTypeExp where
-    lift (SqlType' t)       = lift t
-    lift (SqlTypeExp ftype) = return st
-        where
-            typ = ftToType ftype
-            mtyp = ConT ''Proxy `AppT` typ
-            typedNothing = SigE (ConE 'Proxy) mtyp
-            st = VarE 'sqlType `AppE` typedNothing
-#if MIN_VERSION_template_haskell(2,16,0)
-    liftTyped = unsafeTExpCoerce . lift
-#endif
+mkFieldStore :: UnboundEntityDef -> FieldStore
+mkFieldStore ued =
+    FieldStore
+        { fieldStoreEntity = ued
+        , fieldStoreMap =
+            M.fromList
+                $ fmap (\ufd ->
+                    ( unboundFieldNameHS ufd
+                    , ufd
+                    )
+                )
+                $ getUnboundFieldDefs
+                $ ued
+        , fieldStoreId =
+            case unboundPrimarySpec ued of
+                NaturalKey _ ->
+                    Nothing
+                SurrogateKey fd ->
+                    Just $ unboundIdDBName fd
+                DefaultKey n ->
+                    Just n
+        }
 
-data FieldsSqlTypeExp = FieldsSqlTypeExp [FieldDef] [SqlTypeExp]
+getFieldDBName :: FieldNameHS -> FieldStore -> Maybe FieldNameDB
+getFieldDBName name fs
+    | FieldNameHS "Id" == name =
+        fieldStoreId fs
+    | otherwise =
+        unboundFieldNameDB <$> getFieldDef name fs
+
+getFieldDef :: FieldNameHS -> FieldStore -> Maybe UnboundFieldDef
+getFieldDef fieldNameHS fs =
+    M.lookup fieldNameHS (fieldStoreMap fs)
+
+extractForeignRef :: EntityMap -> UnboundFieldDef -> Maybe EntityNameHS
+extractForeignRef entityMap fieldDef = do
+    refName <- guessFieldReference fieldDef
+    ent <- M.lookup refName entityMap
+    pure $ entityHaskell $ unboundEntityDef ent
+
+guessFieldReference :: UnboundFieldDef -> Maybe EntityNameHS
+guessFieldReference = guessReference . unboundFieldType
+
+guessReference :: FieldType -> Maybe EntityNameHS
+guessReference ft =
+    case ft of
+        FTTypeCon Nothing (T.stripSuffix "Id" -> Just tableName) ->
+            Just (EntityNameHS tableName)
+        FTApp (FTTypeCon Nothing "Key") (FTTypeCon Nothing tableName) ->
+            Just (EntityNameHS tableName)
+        _ ->
+            Nothing
 
-instance Lift FieldsSqlTypeExp where
-    lift (FieldsSqlTypeExp fields sqlTypeExps) =
-        lift $ zipWith FieldSqlTypeExp fields sqlTypeExps
-#if MIN_VERSION_template_haskell(2,16,0)
-    liftTyped = unsafeTExpCoerce . lift
-#endif
+mkDefaultKey
+    :: MkPersistSettings
+    -> FieldNameDB
+    -> EntityNameHS
+    -> FieldDef
+mkDefaultKey mps  pk unboundHaskellName =
+    let
+        iid =
+            mpsImplicitIdDef mps
+    in
+        maybe id addFieldAttr (FieldAttrDefault <$> iidDefault iid) $
+        maybe id addFieldAttr (FieldAttrMaxlen <$> iidMaxLen iid) $
+        mkAutoIdField' pk unboundHaskellName (iidFieldSqlType iid)
+
+fixPrimarySpec
+    :: MkPersistSettings
+    -> UnboundEntityDef
+    -> Q Exp
+fixPrimarySpec mps unboundEnt= do
+    case unboundPrimarySpec unboundEnt of
+        DefaultKey pk ->
+            lift $ EntityIdField $
+                mkDefaultKey mps pk unboundHaskellName
+        SurrogateKey uid -> do
+            let
+                entNameHS =
+                    getUnboundEntityNameHS unboundEnt
+                fieldTyp =
+                    fromMaybe (mkKeyConType entNameHS) (unboundIdType uid)
+            [|
+                EntityIdField
+                    FieldDef
+                        { fieldHaskell =
+                            FieldNameHS "Id"
+                        , fieldDB =
+                            $(lift $ getSqlNameOr (unboundIdDBName uid) (unboundIdAttrs uid))
+                        , fieldType =
+                            $(lift fieldTyp)
+                        , fieldSqlType =
+                            $( liftSqlTypeExp (SqlTypeExp  fieldTyp) )
+                        , fieldStrict =
+                            False
+                        , fieldReference =
+                            ForeignRef entNameHS
+                        , fieldAttrs =
+                            unboundIdAttrs uid
+                        , fieldComments =
+                            Nothing
+                        , fieldCascade = unboundIdCascade uid
+                        , fieldGenerated = Nothing
+                        , fieldIsImplicitIdColumn = True
+                        }
 
-data FieldSqlTypeExp = FieldSqlTypeExp FieldDef SqlTypeExp
+                |]
+        NaturalKey ucd ->
+            [| EntityIdNaturalKey $(bindCompositeDef unboundEnt ucd) |]
+  where
+    unboundHaskellName =
+        getUnboundEntityNameHS unboundEnt
+
+bindCompositeDef :: UnboundEntityDef -> UnboundCompositeDef -> Q Exp
+bindCompositeDef ued ucd = do
+    fieldDefs <-
+       fmap ListE $ forM (unboundCompositeCols ucd) $ \col ->
+           mkLookupEntityField ued col
+    [|
+        CompositeDef
+            { compositeFields =
+                NEL.fromList $(pure fieldDefs)
+            , compositeAttrs =
+                $(lift $ unboundCompositeAttrs ucd)
+            }
+        |]
 
-instance Lift FieldSqlTypeExp where
-    lift (FieldSqlTypeExp FieldDef{..} sqlTypeExp) =
-        [|FieldDef fieldHaskell fieldDB fieldType $(lift sqlTypeExp) fieldAttrs fieldStrict fieldReference fieldCascade fieldComments fieldGenerated fieldIsImplicitIdColumn|]
-      where
-        FieldDef _x _ _ _ _ _ _ _ _ _ _ =
-            error "need to update this record wildcard match"
-#if MIN_VERSION_template_haskell(2,16,0)
-    liftTyped = unsafeTExpCoerce . lift
-#endif
+getSqlType :: M.Map EntityNameHS a -> EntityMap -> UnboundFieldDef -> SqlTypeExp
+getSqlType emEntities entityMap field =
+    maybe
+        (defaultSqlTypeExp emEntities entityMap field)
+        (SqlType' . SqlOther)
+        (listToMaybe $ mapMaybe attrSqlType $ unboundFieldAttrs field)
+
+-- In the case of embedding, there won't be any datatype created yet.
+-- We just use SqlString, as the data will be serialized to JSON.
+defaultSqlTypeExp :: M.Map EntityNameHS a -> EntityMap -> UnboundFieldDef -> SqlTypeExp
+defaultSqlTypeExp emEntities entityMap field =
+    case mEmbedded emEntities ftype of
+        Right _ ->
+            SqlType' SqlString
+        Left (Just (FTKeyCon ty)) ->
+            SqlTypeExp (FTTypeCon Nothing ty)
+        Left Nothing ->
+            case extractForeignRef entityMap field of
+                Just refName ->
+                    case M.lookup refName entityMap of
+                        Nothing ->
+                            -- error $ mconcat
+                            --     [ "Failed to find model: "
+                            --     , show refName
+                            --     , " in entity list: \n"
+                            --     ]
+                            --     <> (unlines $ map show $ M.keys $ entityMap)
+                            -- going to assume that it's fine, will reify it out
+                            -- right later anyway)
+                            SqlTypeExp ftype
+                        -- A ForeignRef is blindly set to an Int64 in setEmbedField
+                        -- correct that now
+                        Just _ ->
+                            SqlTypeReference refName
+                _ ->
+                    case ftype of
+                        -- In the case of lists, we always serialize to a string
+                        -- value (via JSON).
+                        --
+                        -- Normally, this would be determined automatically by
+                        -- SqlTypeExp. However, there's one corner case: if there's
+                        -- a list of entity IDs, the datatype for the ID has not
+                        -- yet been created, so the compiler will fail. This extra
+                        -- clause works around this limitation.
+                        FTList _ ->
+                            SqlType' SqlString
+                        _ ->
+                            SqlTypeExp ftype
+    where
+        ftype = unboundFieldType field
 
-instance Lift EntityDefSqlTypeExp where
-    lift (EntityDefSqlTypeExp ent sqlTypeExp sqlTypeExps) =
-        [|ent { entityFields =
-                    $(lift $ FieldsSqlTypeExp (getEntityFieldsDatabase ent) sqlTypeExps)
-              , entityId = $(lift $ FieldSqlTypeExp (entityId ent) sqlTypeExp)
-              }
-        |]
-#if MIN_VERSION_template_haskell(2,16,0)
-    liftTyped = unsafeTExpCoerce . lift
-#endif
+attrSqlType :: FieldAttr -> Maybe Text
+attrSqlType = \case
+    FieldAttrSqltype x -> Just x
+    _ -> Nothing
 
-type EmbedEntityMap = M.Map EntityNameHS EmbedEntityDef
+data SqlTypeExp
+    = SqlTypeExp FieldType
+    | SqlType' SqlType
+    | SqlTypeReference EntityNameHS
+    deriving Show
 
-constructEmbedEntityMap :: [EntityDef] -> EmbedEntityMap
+liftSqlTypeExp :: SqlTypeExp -> Q Exp
+liftSqlTypeExp ste =
+    case ste of
+        SqlType' t ->
+            lift t
+        SqlTypeExp ftype -> do
+            let
+                typ = ftToType ftype
+                mtyp = ConT ''Proxy `AppT` typ
+                typedNothing = SigE (ConE 'Proxy) mtyp
+            pure $ VarE 'sqlType `AppE` typedNothing
+        SqlTypeReference entNameHs -> do
+            let
+                entNameId :: Name
+                entNameId =
+                    mkName $ T.unpack (unEntityNameHS entNameHs) <> "Id"
+
+            [| sqlType (Proxy :: Proxy $(conT entNameId)) |]
+
+
+type EmbedEntityMap = M.Map EntityNameHS ()
+
+constructEmbedEntityMap :: [UnboundEntityDef] -> EmbedEntityMap
 constructEmbedEntityMap =
     M.fromList . fmap
         (\ent ->
-                ( entityHaskell ent
-                , toEmbedEntityDef ent
+                ( entityHaskell (unboundEntityDef ent)
+                -- , toEmbedEntityDef (unboundEntityDef ent)
+                , ()
                 )
         )
 
-lookupEmbedEntity :: EmbedEntityMap -> FieldDef -> Maybe EntityNameHS
+lookupEmbedEntity :: M.Map EntityNameHS a -> FieldDef -> Maybe EntityNameHS
 lookupEmbedEntity allEntities field = do
     entName <- EntityNameHS <$> stripId (fieldType field)
-    guard (M.member entName allEntities) -- check entity name exists in embed map
+    guard (M.member entName allEntities) -- check entity name exists in embed fmap
     pure entName
 
-type EntityMap = M.Map EntityNameHS EntityDef
+type EntityMap = M.Map EntityNameHS UnboundEntityDef
 
-constructEntityMap :: [EntityDef] -> EntityMap
+constructEntityMap :: [UnboundEntityDef] -> EntityMap
 constructEntityMap =
-    M.fromList . fmap (\ent -> (entityHaskell ent, ent))
+    M.fromList . fmap (\ent -> (entityHaskell (unboundEntityDef ent), ent))
 
-data FTTypeConDescr = FTKeyCon
+data FTTypeConDescr = FTKeyCon Text
     deriving Show
 
 -- | Recurses through the 'FieldType'. Returns a 'Right' with the
@@ -369,26 +707,21 @@ data FTTypeConDescr = FTKeyCon
 -- If the 'FieldType' has a module qualified value, then it returns @'Left'
 -- 'Nothing'@.
 mEmbedded
-    :: EmbedEntityMap
+    :: M.Map EntityNameHS a
     -> FieldType
-    -> Either (Maybe FTTypeConDescr) EmbedEntityDef
+    -> Either (Maybe FTTypeConDescr) EntityNameHS
 mEmbedded _ (FTTypeCon Just{} _) =
     Left Nothing
 mEmbedded ents (FTTypeCon Nothing (EntityNameHS -> name)) =
-    maybe (Left Nothing) Right $ M.lookup name ents
+    maybe (Left Nothing) (\_ -> Right name) $ M.lookup name ents
 mEmbedded ents (FTList x) =
     mEmbedded ents x
-mEmbedded ents (FTApp x y) =
-    -- Key converts an Record to a RecordId
-    -- special casing this is obviously a hack
-    -- This problem may not be solvable with the current QuasiQuoted approach though
-    if x == FTTypeCon Nothing "Key"
-        then
-            Left $ Just FTKeyCon
-        else
-            mEmbedded ents y
+mEmbedded _ (FTApp (FTTypeCon Nothing "Key") (FTTypeCon _ a)) =
+    Left $ Just $ FTKeyCon $ a <> "Id"
+mEmbedded _ (FTApp _ _) =
+    Left Nothing
 
-setEmbedField :: EntityNameHS -> EmbedEntityMap -> FieldDef -> FieldDef
+setEmbedField :: EntityNameHS -> M.Map EntityNameHS a -> FieldDef -> FieldDef
 setEmbedField entName allEntities field =
     case fieldReference field of
       NoReference ->
@@ -400,98 +733,56 @@ setEmbedField entName allEntities field =
         case mEmbedded allEntities (fieldType field) of
             Left _ -> fromMaybe NoReference $ do
                 refEntName <- lookupEmbedEntity allEntities field
-                -- This can get corrected in mkEntityDefSqlTypeExp
-                let placeholderIdType = FTTypeCon (Just "Data.Int") "Int64"
-                pure $ ForeignRef refEntName placeholderIdType
+                pure $ ForeignRef refEntName
             Right em ->
-                if embeddedHaskell em /= entName
+                if em /= entName
                      then EmbedRef em
-                else if maybeNullable field
+                else if maybeNullable (unbindFieldDef field)
                      then SelfReference
                 else case fieldType field of
                          FTList _ -> SelfReference
-                         _ -> error $ unpack $ unEntityNameHS entName <> ": a self reference must be a Maybe"
+                         _ -> error $ unpack $ unEntityNameHS entName <> ": a self reference must be a Maybe or List"
 
 setFieldReference :: ReferenceDef -> FieldDef -> FieldDef
 setFieldReference ref field = field { fieldReference = ref }
 
-mkEntityDefSqlTypeExp :: EmbedEntityMap -> EntityMap -> EntityDef -> EntityDefSqlTypeExp
-mkEntityDefSqlTypeExp emEntities entityMap ent =
-    EntityDefSqlTypeExp ent (getSqlType $ entityId ent) (map getSqlType $ getEntityFieldsDatabase ent)
-  where
-    getSqlType field =
-        maybe
-            (defaultSqlTypeExp field)
-            (SqlType' . SqlOther)
-            (listToMaybe $ mapMaybe attrSqlType $ fieldAttrs field)
-
-    attrSqlType = \case
-        FieldAttrSqltype x -> Just x
-        _ -> Nothing
-
-    -- In the case of embedding, there won't be any datatype created yet.
-    -- We just use SqlString, as the data will be serialized to JSON.
-    defaultSqlTypeExp field =
-        case mEmbedded emEntities ftype of
-            Right _ ->
-                SqlType' SqlString
-            Left (Just FTKeyCon) ->
-                SqlType' SqlString
-            Left Nothing ->
-                case fieldReference field of
-                    ForeignRef refName ft ->
-                        case M.lookup refName entityMap of
-                            Nothing  ->
-                                SqlTypeExp ft
-                            -- A ForeignRef is blindly set to an Int64 in setEmbedField
-                            -- correct that now
-                            Just ent' ->
-                                case entityPrimary ent' of
-                                    Nothing -> SqlTypeExp ft
-                                    Just pdef ->
-                                        case compositeFields pdef of
-                                            [] -> error "mkEntityDefSqlTypeExp: no composite fields"
-                                            [x] -> SqlTypeExp $ fieldType x
-                                            _ -> SqlType' $ SqlOther "Composite Reference"
-                    CompositeRef _ ->
-                        SqlType' $ SqlOther "Composite Reference"
-                    _ ->
-                        case ftype of
-                            -- In the case of lists, we always serialize to a string
-                            -- value (via JSON).
-                            --
-                            -- Normally, this would be determined automatically by
-                            -- SqlTypeExp. However, there's one corner case: if there's
-                            -- a list of entity IDs, the datatype for the ID has not
-                            -- yet been created, so the compiler will fail. This extra
-                            -- clause works around this limitation.
-                            FTList _ -> SqlType' SqlString
-                            _ -> SqlTypeExp ftype
-        where
-            ftype = fieldType field
-
 -- | Create data types and appropriate 'PersistEntity' instances for the given
 -- 'EntityDef's. Works well with the persist quasi-quoter.
-mkPersist :: MkPersistSettings -> [EntityDef] -> Q [Dec]
-mkPersist mps ents' = do
-    ents <-
-        filterM shouldGenerateCode
-        $ embedEntityDefs
-        $ map (setDefaultIdFields mps)
-        $ ents'
+mkPersist
+    :: MkPersistSettings
+    -> [UnboundEntityDef]
+    -> Q [Dec]
+mkPersist mps = mkPersistWith mps []
+
+-- | Like '
+--
+-- @since 2.13.0.0
+mkPersistWith
+    :: MkPersistSettings
+    -> [EntityDef]
+    -> [UnboundEntityDef]
+    -> Q [Dec]
+mkPersistWith mps preexistingEntities ents' = do
     let
+        (embedEntityMap, predefs) =
+            preprocessUnboundDefs preexistingEntities ents'
+        allEnts =
+            embedEntityDefs preexistingEntities
+            $ fmap (setDefaultIdFields mps)
+            $ predefs
         entityMap =
-            constructEntityMap ents
+            constructEntityMap allEnts
+    ents <- filterM shouldGenerateCode allEnts
     requireExtensions
         [ [TypeFamilies], [GADTs, ExistentialQuantification]
         , [DerivingStrategies], [GeneralizedNewtypeDeriving], [StandaloneDeriving]
         , [UndecidableInstances], [DataKinds], [FlexibleInstances]
         ]
     persistFieldDecs <- fmap mconcat $ mapM (persistFieldFromEntity mps) ents
-    entityDecs <- fmap mconcat $ mapM (mkEntity entityMap mps) ents
+    entityDecs <- fmap mconcat $ mapM (mkEntity embedEntityMap entityMap mps) ents
     jsonDecs <- fmap mconcat $ mapM (mkJSON mps) ents
     uniqueKeyInstances <- fmap mconcat $ mapM (mkUniqueKeyInstances mps) ents
-    symbolToFieldInstances <- fmap mconcat $ mapM (mkSymbolToFieldInstances mps) ents
+    symbolToFieldInstances <- fmap mconcat $ mapM (mkSymbolToFieldInstances mps entityMap) ents
     return $ mconcat
         [ persistFieldDecs
         , entityDecs
@@ -501,7 +792,7 @@ mkPersist mps ents' = do
         ]
 
 -- we can't just use 'isInstance' because TH throws an error
-shouldGenerateCode :: EntityDef -> Q Bool
+shouldGenerateCode :: UnboundEntityDef -> Q Bool
 shouldGenerateCode ed = do
     mtyp <- lookupTypeName entityName
     case mtyp of
@@ -512,18 +803,25 @@ shouldGenerateCode ed = do
             pure (not instanceExists)
   where
     entityName =
-        T.unpack . unEntityNameHS . getEntityHaskellName $ ed
+        T.unpack . unEntityNameHS . getEntityHaskellName . unboundEntityDef $ ed
+
+overEntityDef :: (EntityDef -> EntityDef) -> UnboundEntityDef -> UnboundEntityDef
+overEntityDef f ued = ued { unboundEntityDef = f (unboundEntityDef ued) }
 
-setDefaultIdFields :: MkPersistSettings -> EntityDef -> EntityDef
-setDefaultIdFields mps ed
-    | defaultIdType ed || fieldIsImplicitIdColumn (getEntityId ed) =
-        setEntityId (setToMpsDefault (mpsImplicitIdDef mps) (getEntityId ed)) ed
+setDefaultIdFields :: MkPersistSettings -> UnboundEntityDef -> UnboundEntityDef
+setDefaultIdFields mps ued
+    | defaultIdType ued =
+        overEntityDef
+            (setEntityIdDef (setToMpsDefault (mpsImplicitIdDef mps) (getEntityId ed)))
+            ued
     | otherwise =
-        ed
+        ued
   where
-    setToMpsDefault :: ImplicitIdDef -> FieldDef -> FieldDef
-    setToMpsDefault iid fd =
-        fd
+    ed =
+        unboundEntityDef ued
+    setToMpsDefault :: ImplicitIdDef -> EntityIdDef -> EntityIdDef
+    setToMpsDefault iid (EntityIdField fd) =
+        EntityIdField fd
             { fieldType =
                 iidFieldType iid (getEntityHaskellName ed)
             , fieldSqlType =
@@ -539,6 +837,8 @@ setDefaultIdFields mps ed
             , fieldIsImplicitIdColumn =
                 True
             }
+    setToMpsDefault _ x =
+        x
 
 -- | Implement special preprocessing on EntityDef as necessary for 'mkPersist'.
 -- For example, strip out any fields marked as MigrationOnly.
@@ -547,9 +847,12 @@ setDefaultIdFields mps ed
 -- *should* keep all of the fields present when defining 'entityDef'. This is
 -- necessary so that migrations know to keep these columns around, or to delete
 -- them, as appropriate.
-fixEntityDef :: EntityDef -> EntityDef
-fixEntityDef =
-    overEntityFields (filter isHaskellField)
+fixEntityDef :: UnboundEntityDef -> UnboundEntityDef
+fixEntityDef ued =
+    ued
+        { unboundEntityFields =
+            filter isHaskellUnboundField (unboundEntityFields ued)
+        }
 
 -- | Settings to be passed to the 'mkPersist' function.
 data MkPersistSettings = MkPersistSettings
@@ -687,17 +990,19 @@ upperFirst t =
         Just (a, b) -> cons (toUpper a) b
         Nothing -> t
 
-dataTypeDec :: MkPersistSettings -> EntityDef -> Q Dec
-dataTypeDec mps entDef = do
-    let names = mkEntityDefDeriveNames mps entDef
+dataTypeDec :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q Dec
+dataTypeDec mps entityMap entDef = do
+    let
+        names =
+            mkEntityDefDeriveNames mps entDef
 
-    let (stocks, anyclasses) = partitionEithers (map stratFor names)
+    let (stocks, anyclasses) = partitionEithers (fmap stratFor names)
     let stockDerives = do
             guard (not (null stocks))
-            pure (DerivClause (Just StockStrategy) (map ConT stocks))
+            pure (DerivClause (Just StockStrategy) (fmap ConT stocks))
         anyclassDerives = do
             guard (not (null anyclasses))
-            pure (DerivClause (Just AnyclassStrategy) (map ConT anyclasses))
+            pure (DerivClause (Just AnyclassStrategy) (fmap ConT anyclasses))
     unless (null anyclassDerives) $ do
         requireExtensions [[DeriveAnyClass]]
     pure $ DataD [] nameFinal paramsFinal
@@ -712,7 +1017,7 @@ dataTypeDec mps entDef = do
             Right n
 
     stockClasses =
-        Set.fromList (map mkName
+        Set.fromList (fmap mkName
         [ "Eq", "Ord", "Show", "Read", "Bounded", "Enum", "Ix", "Generic", "Data", "Typeable"
         ] <> [''Eq, ''Ord, ''Show, ''Read, ''Bounded, ''Enum, ''Ix, ''Generic, ''Data, ''Typeable
         ]
@@ -724,55 +1029,56 @@ dataTypeDec mps entDef = do
 
     cols :: [VarBangType]
     cols = do
-        fieldDef <- getEntityFields entDef
+        fieldDef <- getUnboundFieldDefs entDef
         let recordName = fieldDefToRecordName mps entDef fieldDef
-            strictness = if fieldStrict fieldDef then isStrict else notStrict
-            fieldIdType = maybeIdType mps fieldDef Nothing Nothing
-         in pure (recordName, strictness, fieldIdType)
+            strictness = if unboundFieldStrict fieldDef then isStrict else notStrict
+            fieldIdType = maybeIdType mps entityMap fieldDef Nothing Nothing
+        pure (recordName, strictness, fieldIdType)
 
     constrs
-        | entitySum entDef = map sumCon $ getEntityFields entDef
+        | unboundEntitySum entDef = fmap sumCon $ getUnboundFieldDefs entDef
         | otherwise = [RecC (mkEntityDefName entDef) cols]
 
     sumCon fieldDef = NormalC
         (sumConstrName mps entDef fieldDef)
-        [(notStrict, maybeIdType mps fieldDef Nothing Nothing)]
+        [(notStrict, maybeIdType mps entityMap fieldDef Nothing Nothing)]
 
-uniqueTypeDec :: MkPersistSettings -> EntityDef -> Dec
-uniqueTypeDec mps entDef =
+uniqueTypeDec :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Dec
+uniqueTypeDec mps entityMap entDef =
+    DataInstD
+        []
 #if MIN_VERSION_template_haskell(2,15,0)
-    DataInstD [] Nothing
-        (AppT (ConT ''Unique) (genericDataType mps (entityHaskell entDef) backendT))
-            Nothing
-            (map (mkUnique mps entDef) $ entityUniques entDef)
-            []
+        Nothing
+        (AppT (ConT ''Unique) (genericDataType mps (getUnboundEntityNameHS entDef) backendT))
 #else
-    DataInstD [] ''Unique
-        [genericDataType mps (entityHaskell entDef) backendT]
-            Nothing
-            (map (mkUnique mps entDef) $ entityUniques entDef)
-            []
+        ''Unique
+        [genericDataType mps (getUnboundEntityNameHS entDef) backendT]
 #endif
+        Nothing
+        (fmap (mkUnique mps entityMap entDef) $ entityUniques (unboundEntityDef entDef))
+        []
 
-mkUnique :: MkPersistSettings -> EntityDef -> UniqueDef -> Con
-mkUnique mps entDef (UniqueDef constr _ fields attrs) =
-    NormalC (mkConstraintName constr) types
+mkUnique :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> UniqueDef -> Con
+mkUnique mps entityMap entDef (UniqueDef constr _ fields attrs) =
+    NormalC (mkConstraintName constr) $ toList types
   where
     types =
-      map (go . flip lookup3 (getEntityFields entDef) . unFieldNameHS . fst) fields
+      fmap (go . flip lookup3 (getUnboundFieldDefs entDef) . unFieldNameHS . fst) fields
 
     force = "!force" `elem` attrs
 
-    go :: (FieldDef, IsNullable) -> (Strict, Type)
+    go :: (UnboundFieldDef, IsNullable) -> (Strict, Type)
     go (_, Nullable _) | not force = error nullErrMsg
-    go (fd, y) = (notStrict, maybeIdType mps fd Nothing (Just y))
+    go (fd, y) = (notStrict, maybeIdType mps entityMap fd Nothing (Just y))
 
-    lookup3 :: Text -> [FieldDef] -> (FieldDef, IsNullable)
+    lookup3 :: Text -> [UnboundFieldDef] -> (UnboundFieldDef, IsNullable)
     lookup3 s [] =
         error $ unpack $ "Column not found: " ++ s ++ " in unique " ++ unConstraintNameHS constr
-    lookup3 x (fd@FieldDef {..}:rest)
-        | x == unFieldNameHS fieldHaskell = (fd, nullable fieldAttrs)
-        | otherwise = lookup3 x rest
+    lookup3 x (fd:rest)
+        | x == unFieldNameHS (unboundFieldNameHS fd) =
+            (fd, nullable $ unboundFieldAttrs fd)
+        | otherwise =
+            lookup3 x rest
 
     nullErrMsg =
       mconcat [ "Error:  By default we disallow NULLables in an uniqueness "
@@ -786,16 +1092,25 @@ mkUnique mps entDef (UniqueDef constr _ fields attrs) =
 
 maybeIdType
     :: MkPersistSettings
-    -> FieldDef
+    -> EntityMap
+    -> UnboundFieldDef
     -> Maybe Name -- ^ backend
     -> Maybe IsNullable
     -> Type
-maybeIdType mps fieldDef mbackend mnull = maybeTyp mayNullable idtyp
+maybeIdType mps entityMap fieldDef mbackend mnull =
+    maybeTyp mayNullable idType
   where
-    mayNullable = case mnull of
-        (Just (Nullable ByMaybeAttr)) -> True
-        _ -> maybeNullable fieldDef
-    idtyp = idType mps fieldDef mbackend
+    mayNullable =
+        case mnull of
+            Just (Nullable ByMaybeAttr) ->
+                True
+            _ ->
+                maybeNullable fieldDef
+    idType = fromMaybe (ftToType $ unboundFieldType fieldDef) $ do
+        typ <- extractForeignRef entityMap fieldDef
+        pure $
+            ConT ''Key
+            `AppT` genericDataType mps typ (VarT $ fromMaybe backendName mbackend)
 
 backendDataType :: MkPersistSettings -> Type
 backendDataType mps
@@ -811,14 +1126,6 @@ genericDataType mps name backend
     | mpsGeneric mps = ConT (mkEntityNameHSGenericName name) `AppT` backend
     | otherwise = ConT $ mkEntityNameHSName name
 
-idType :: MkPersistSettings -> FieldDef -> Maybe Name -> Type
-idType mps fieldDef mbackend =
-    case foreignReference fieldDef of
-        Just typ ->
-            ConT ''Key
-            `AppT` genericDataType mps typ (VarT $ fromMaybe backendName mbackend)
-        Nothing -> ftToType $ fieldType fieldDef
-
 degen :: [Clause] -> [Clause]
 degen [] =
     let err = VarE 'error `AppE` LitE (StringL
@@ -826,10 +1133,26 @@ degen [] =
      in [normalClause [WildP] err]
 degen x = x
 
-mkToPersistFields :: MkPersistSettings -> EntityDef -> Q Dec
+-- needs:
+--
+-- * isEntitySum ed
+--     * field accesor
+-- * getEntityFields ed
+--     * used in goSum, or sumConstrName
+-- * mkEntityDefName ed
+--     * uses entityHaskell
+-- * sumConstrName ed fieldDef
+--     * only needs entity name and field name
+--
+-- data MkToPersistFields = MkToPersistFields
+--     { isEntitySum :: Bool
+--     , entityHaskell :: HaskellNameHS
+--     , entityFieldNames :: [FieldNameHS]
+--     }
+mkToPersistFields :: MkPersistSettings -> UnboundEntityDef -> Q Dec
 mkToPersistFields mps ed = do
-    let isSum = isEntitySum ed
-        fields = getEntityFields ed
+    let isSum = unboundEntitySum ed
+        fields = getUnboundFieldDefs ed
     clauses <-
         if isSum
             then sequence $ zipWith goSum fields [1..]
@@ -840,14 +1163,14 @@ mkToPersistFields mps ed = do
     go = do
         xs <- sequence $ replicate fieldCount $ newName "x"
         let name = mkEntityDefName ed
-            pat = ConP name $ map VarP xs
+            pat = ConP name $ fmap VarP xs
         sp <- [|SomePersistField|]
-        let bod = ListE $ map (AppE sp . VarE) xs
+        let bod = ListE $ fmap (AppE sp . VarE) xs
         return $ normalClause [pat] bod
 
-    fieldCount = length (getEntityFields ed)
+    fieldCount = length (getUnboundFieldDefs ed)
 
-    goSum :: FieldDef -> Int -> Q Clause
+    goSum :: UnboundFieldDef -> Int -> Q Clause
     goSum fieldDef idx = do
         let name = sumConstrName mps ed fieldDef
         enull <- [|SomePersistField PersistNull|]
@@ -884,9 +1207,9 @@ mkUniqueToValues pairs = do
     go :: UniqueDef -> Q Clause
     go (UniqueDef constr _ names _) = do
         xs <- mapM (const $ newName "x") names
-        let pat = ConP (mkConstraintName constr) $ map VarP xs
+        let pat = ConP (mkConstraintName constr) $ fmap VarP $ toList xs
         tpv <- [|toPersistValue|]
-        let bod = ListE $ map (AppE tpv . VarE) xs
+        let bod = ListE $ fmap (AppE tpv . VarE) $ toList xs
         return $ normalClause [pat] bod
 
 isNotNull :: PersistValue -> Bool
@@ -897,24 +1220,37 @@ mapLeft :: (a -> c) -> Either a b -> Either c b
 mapLeft _ (Right r) = Right r
 mapLeft f (Left l)  = Left (f l)
 
-mkFromPersistValues :: MkPersistSettings -> EntityDef -> Q [Clause]
+-- needs:
+--
+-- * getEntityFields
+--     * sumConstrName on field
+-- * fromValues
+-- * entityHaskell
+-- * sumConstrName
+-- * entityDefConE
+--
+--
+mkFromPersistValues :: MkPersistSettings -> UnboundEntityDef -> Q [Clause]
 mkFromPersistValues mps entDef
-    | isEntitySum entDef = do
+    | unboundEntitySum entDef = do
         nothing <- [|Left ("Invalid fromPersistValues input: sum type with all nulls. Entity: " `mappend` entName)|]
-        clauses <- mkClauses [] $ getEntityFields entDef
+        clauses <- mkClauses [] $ getUnboundFieldDefs entDef
         return $ clauses `mappend` [normalClause [WildP] nothing]
     | otherwise =
-        fromValues entDef "fromPersistValues" entE $ getEntityFields entDef
+        fromValues entDef "fromPersistValues" entE
+        $ fmap unboundFieldNameHS
+        $ filter isHaskellUnboundField
+        $ getUnboundFieldDefs entDef
   where
-    entName = unEntityNameHS $ entityHaskell entDef
+    entName = unEntityNameHS $ getUnboundEntityNameHS entDef
     mkClauses _ [] = return []
     mkClauses before (field:after) = do
         x <- newName "x"
         let null' = ConP 'PersistNull []
             pat = ListP $ mconcat
-                [ map (const null') before
+                [ fmap (const null') before
                 , [VarP x]
-                , map (const null') after
+                , fmap (const null') after
                 ]
             constr = ConE $ sumConstrName mps entDef field
         fs <- [|fromPersistValue $(return $ VarE x)|]
@@ -933,7 +1269,10 @@ lensPTH sa sbt afb s = fmap (sbt s) (afb $ sa s)
 fmapE :: Exp
 fmapE = VarE 'fmap
 
-mkLensClauses :: MkPersistSettings -> EntityDef -> Q [Clause]
+unboundEntitySum :: UnboundEntityDef -> Bool
+unboundEntitySum = entitySum . unboundEntityDef
+
+mkLensClauses :: MkPersistSettings -> UnboundEntityDef -> Q [Clause]
 mkLensClauses mps entDef = do
     lens' <- [|lensPTH|]
     getId <- [|entityKey|]
@@ -946,9 +1285,9 @@ mkLensClauses mps entDef = do
     let idClause = normalClause
             [ConP (keyIdName entDef) []]
             (lens' `AppE` getId `AppE` setId)
-    if entitySum entDef
-        then return $ idClause : map (toSumClause lens' keyVar valName xName) (getEntityFields entDef)
-        else return $ idClause : map (toClause lens' getVal dot keyVar valName xName) (getEntityFields entDef)
+    return $ idClause : if unboundEntitySum entDef
+        then fmap (toSumClause lens' keyVar valName xName) (getUnboundFieldDefs entDef)
+        else fmap (toClause lens' getVal dot keyVar valName xName) (getUnboundFieldDefs entDef)
   where
     toClause lens' getVal dot keyVar valName xName fieldDef = normalClause
         [ConP (filterConName mps entDef fieldDef) []]
@@ -976,7 +1315,7 @@ mkLensClauses mps entDef = do
 
             -- FIXME It would be nice if the types expressed that the Field is
             -- a sum type and therefore could result in Maybe.
-            : if length (getEntityFields entDef) > 1 then [emptyMatch] else []
+            : if length (getUnboundFieldDefs entDef) > 1 then [emptyMatch] else []
         setter = LamE
             [ ConP 'Entity [VarP keyVar, WildP]
             , VarP xName
@@ -985,7 +1324,7 @@ mkLensClauses mps entDef = do
 
 -- | declare the key type and associated instances
 -- @'PathPiece'@, @'ToHttpApiData'@ and @'FromHttpApiData'@ instances are only generated for a Key with one field
-mkKeyTypeDec :: MkPersistSettings -> EntityDef -> Q (Dec, [Dec])
+mkKeyTypeDec :: MkPersistSettings -> UnboundEntityDef -> Q (Dec, [Dec])
 mkKeyTypeDec mps entDef = do
     (instDecs, i) <-
       if mpsGeneric mps
@@ -1011,7 +1350,7 @@ mkKeyTypeDec mps entDef = do
     -- This is much better for debugging/logging purposes
     -- cf. https://github.com/yesodweb/persistent/issues/1104
     let alwaysStockStrategyTypeclasses = [''Show, ''Read]
-        deriveClauses = map (\typeclass ->
+        deriveClauses = fmap (\typeclass ->
             if (not useNewtype || typeclass `elem` alwaysStockStrategyTypeclasses)
                 then DerivClause (Just StockStrategy) [(ConT typeclass)]
                 else DerivClause (Just NewtypeStrategy) [(ConT typeclass)]
@@ -1032,7 +1371,8 @@ mkKeyTypeDec mps entDef = do
     unKeyE = unKeyExp entDef
     dec = RecC (keyConName entDef) (keyFields mps entDef)
     k = ''Key
-    recordType = genericDataType mps (entityHaskell entDef) backendT
+    recordType =
+        genericDataType mps (getUnboundEntityNameHS entDef) backendT
     pfInstD = -- FIXME: generate a PersistMap instead of PersistList
       [d|instance PersistField (Key $(pure recordType)) where
             toPersistValue = PersistList . keyToValues
@@ -1057,9 +1397,8 @@ mkKeyTypeDec mps entDef = do
         |]
 
     genericNewtypeInstances = do
-      requirePersistentExtensions
+        requirePersistentExtensions
 
-      instances <- do
         alwaysInstances <-
           -- See the "Always use StockStrategy" comment above, on why Show/Read use "stock" here
           [d|deriving stock instance Show (BackendKey $(pure backendT)) => Show (Key $(pure recordType))
@@ -1075,12 +1414,27 @@ mkKeyTypeDec mps entDef = do
              deriving newtype instance FromJSON (BackendKey $(pure backendT)) => FromJSON (Key $(pure recordType))
               |]
 
-        if customKeyType then return alwaysInstances
-          else fmap (alwaysInstances `mappend`) backendKeyGenericI
-      return instances
+        mappend alwaysInstances <$>
+            if customKeyType
+            then pure []
+            else backendKeyGenericI
 
     useNewtype = pkNewtype mps entDef
-    customKeyType = not (defaultIdType entDef) || not useNewtype || isJust (entityPrimary entDef)
+    customKeyType =
+        or
+            [ not (defaultIdType entDef)
+            , not useNewtype
+            , isJust (entityPrimary (unboundEntityDef entDef))
+            , not isBackendKey
+            ]
+
+    isBackendKey =
+        case getImplicitIdType mps of
+            ConT bk `AppT` _
+                | bk == ''BackendKey ->
+                    True
+            _ ->
+                False
 
     supplement :: [Name] -> [Name]
     supplement names = names <> (filter (`notElem` names) $ mpsDeriveInstances mps)
@@ -1088,67 +1442,90 @@ mkKeyTypeDec mps entDef = do
 -- | Returns 'True' if the key definition has less than 2 fields.
 --
 -- @since 2.11.0.0
-pkNewtype :: MkPersistSettings -> EntityDef -> Bool
+pkNewtype :: MkPersistSettings -> UnboundEntityDef -> Bool
 pkNewtype mps entDef = length (keyFields mps entDef) < 2
 
 -- | Kind of a nasty hack. Checks to see if the 'fieldType' matches what the
 -- QuasiQuoter produces for an implicit ID and
-defaultIdType :: EntityDef -> Bool
+defaultIdType :: UnboundEntityDef -> Bool
 defaultIdType entDef =
-    fieldType field == FTTypeCon Nothing (keyIdText entDef)
-  where
-    field = getEntityId entDef
+    case unboundPrimarySpec entDef of
+        DefaultKey _ ->
+            True
+        _ ->
+            False
 
-keyFields :: MkPersistSettings -> EntityDef -> [(Name, Strict, Type)]
+keyFields :: MkPersistSettings -> UnboundEntityDef -> [(Name, Strict, Type)]
 keyFields mps entDef =
-    case entityPrimary entDef of
-        Just pdef ->
-            map primaryKeyVar (compositeFields pdef)
-        Nothing ->
-            pure . idKeyVar $
-                if defaultIdType entDef
-                then
+    case unboundPrimarySpec entDef of
+        NaturalKey ucd ->
+            fmap naturalKeyVar (unboundCompositeCols ucd)
+        DefaultKey _ ->
+            pure . idKeyVar $ getImplicitIdType mps
+        SurrogateKey k ->
+            pure . idKeyVar $ case unboundIdType k of
+                Nothing ->
                     getImplicitIdType mps
-                else ftToType $ fieldType $ entityId entDef
+                Just ty ->
+                    ftToType ty
   where
+    unboundFieldDefs =
+        getUnboundFieldDefs entDef
+    naturalKeyVar fieldName =
+        case findField fieldName unboundFieldDefs of
+            Nothing ->
+                error "column not defined on entity"
+            Just unboundFieldDef ->
+                ( keyFieldName mps entDef (unboundFieldNameHS unboundFieldDef)
+                , notStrict
+                , ftToType $ unboundFieldType unboundFieldDef
+                )
+
     idKeyVar ft =
         ( unKeyName entDef
         , notStrict
         , ft
         )
-    primaryKeyVar fieldDef =
-        ( keyFieldName mps entDef fieldDef
-        , notStrict
-        , ftToType $ fieldType fieldDef
-        )
 
-mkKeyToValues :: MkPersistSettings -> EntityDef -> Q Dec
+findField :: FieldNameHS -> [UnboundFieldDef] -> Maybe UnboundFieldDef
+findField fieldName =
+    List.find ((fieldName ==) . unboundFieldNameHS)
+
+mkKeyToValues :: MkPersistSettings -> UnboundEntityDef -> Q Dec
 mkKeyToValues mps entDef = do
-    (p, e) <- case entityPrimary entDef of
-        Nothing  ->
-          ([],) <$> [|(:[]) . toPersistValue . $(return $ unKeyExp entDef)|]
-        Just pdef ->
-          return $ toValuesPrimary pdef
-    return $ FunD 'keyToValues $ return $ normalClause p e
+    recordName <- newName "record"
+    FunD 'keyToValues . pure <$>
+        case unboundPrimarySpec entDef of
+            NaturalKey ucd -> do
+                normalClause [VarP recordName] <$>
+                    toValuesPrimary recordName ucd
+            _ -> do
+                normalClause [] <$>
+                    [|(:[]) . toPersistValue . $(pure $ unKeyExp entDef)|]
   where
-    toValuesPrimary pdef =
-      ( [VarP recordName]
-      , ListE $ map (\fieldDef -> VarE 'toPersistValue `AppE` (VarE (keyFieldName mps entDef fieldDef) `AppE` VarE recordName)) $ compositeFields pdef
-      )
-    recordName = mkName "record"
+    toValuesPrimary recName ucd =
+        ListE <$> mapM (f recName) (unboundCompositeCols ucd)
+    f recName fieldNameHS =
+        [|
+        toPersistValue ($(varE $ keyFieldName mps entDef fieldNameHS) $(varE recName))
+        |]
 
 normalClause :: [Pat] -> Exp -> Clause
 normalClause p e = Clause p (NormalB e) []
 
-mkKeyFromValues :: MkPersistSettings -> EntityDef -> Q Dec
-mkKeyFromValues _mps entDef = do
-    clauses <- case entityPrimary entDef of
-        Nothing  -> do
-            e <- [|fmap $(return keyConE) . fromPersistValue . headNote|]
-            return [normalClause [] e]
-        Just pdef ->
-            fromValues entDef "keyFromValues" keyConE (compositeFields pdef)
-    return $ FunD 'keyFromValues clauses
+-- needs:
+--
+-- * entityPrimary
+-- * keyConExp entDef
+mkKeyFromValues :: MkPersistSettings -> UnboundEntityDef -> Q Dec
+mkKeyFromValues _mps entDef =
+    FunD 'keyFromValues <$>
+        case unboundPrimarySpec entDef of
+            NaturalKey ucd ->
+                fromValues entDef "keyFromValues" keyConE (unboundCompositeCols ucd)
+            _ -> do
+                e <- [|fmap $(return keyConE) . fromPersistValue . headNote|]
+                return [normalClause [] e]
   where
     keyConE = keyConExp entDef
 
@@ -1157,15 +1534,40 @@ headNote = \case
   [x] -> x
   xs -> error $ "mkKeyFromValues: expected a list of one element, got: " `mappend` show xs
 
-fromValues :: EntityDef -> Text -> Exp -> [FieldDef] -> Q [Clause]
+-- needs from entity:
+--
+-- * entityText entDef
+--     * entityHaskell
+-- * entityDB entDef
+--
+-- needs from fields:
+--
+-- * mkPersistValue
+--     *  fieldHaskell
+--
+-- data MkFromValues = MkFromValues
+--     { entityHaskell :: EntityNameHS
+--     , entityDB :: EntitynameDB
+--     , entityFieldNames :: [FieldNameHS]
+--     }
+fromValues :: UnboundEntityDef -> Text -> Exp -> [FieldNameHS] -> Q [Clause]
 fromValues entDef funName constructExpr fields = do
     x <- newName "x"
-    let funMsg = entityText entDef `mappend` ": " `mappend` funName `mappend` " failed on: "
-    patternMatchFailure <- [|Left $ mappend funMsg (pack $ show $(return $ VarE x))|]
+    let
+        funMsg =
+            mconcat
+                [ entityText entDef
+                , ": "
+                , funName
+                , " failed on: "
+                ]
+    patternMatchFailure <-
+        [|Left $ mappend funMsg (pack $ show $(return $ VarE x))|]
     suc <- patternSuccess
     return [ suc, normalClause [VarP x] patternMatchFailure ]
   where
-    tableName = unEntityNameDB (entityDB entDef)
+    tableName =
+        unEntityNameDB (entityDB (unboundEntityDef entDef))
     patternSuccess =
         case fields of
             [] -> do
@@ -1181,14 +1583,14 @@ fromValues entDef funName constructExpr fields = do
                 let applyFromPersistValue = infixFromPersistValue applyE
 
                 return $ normalClause
-                    [ListP $ map VarP (x1:restNames)]
+                    [ListP $ fmap VarP (x1:restNames)]
                     (foldl' (\exp (name, fpv) -> applyFromPersistValue fpv exp name) conApp (zip restNames mkPersistValues))
 
     infixFromPersistValue applyE fpv exp name =
         UInfixE exp applyE (fpv `AppE` VarE name)
 
     mkPersistValue field =
-        let fieldName = (unFieldNameHS (fieldHaskell field))
+        let fieldName = unFieldNameHS field
         in [|mapLeft (fieldError tableName fieldName) . fromPersistValue|]
 
 -- |  Render an error message based on the @tableName@ and @fieldName@ with
@@ -1205,20 +1607,22 @@ fieldError tableName fieldName err = mconcat
     , err
     ]
 
-mkEntity :: EntityMap -> MkPersistSettings -> EntityDef -> Q [Dec]
-mkEntity entityMap mps entDef = do
-    fields <- mkFields mps entDef
-    entityDefExp <- liftAndFixKeys entityMap entDef
-
+mkEntity :: M.Map EntityNameHS a -> EntityMap -> MkPersistSettings -> UnboundEntityDef -> Q [Dec]
+mkEntity embedEntityMap entityMap mps preDef = do
+    entityDefExp <- liftAndFixKeys mps embedEntityMap entityMap preDef
+    let
+        entDef =
+            fixEntityDef preDef
+    fields <- mkFields mps entityMap entDef
     let name = mkEntityDefName entDef
     let clazz = ConT ''PersistEntity `AppT` genDataType
     tpf <- mkToPersistFields mps entDef
     fpv <- mkFromPersistValues mps entDef
-    utv <- mkUniqueToValues $ entityUniques entDef
+    utv <- mkUniqueToValues $ entityUniques $ unboundEntityDef entDef
     puk <- mkUniqueKeys entDef
-    fkc <- mapM (mkForeignKeysComposite mps entDef) $ entityForeigns entDef
+    fkc <- mapM (mkForeignKeysComposite mps entDef) $ unboundForeignDefs entDef
 
-    toFieldNames <- mkToFieldNames $ entityUniques entDef
+    toFieldNames <- mkToFieldNames $ entityUniques $ unboundEntityDef entDef
 
     (keyTypeDec, keyInstanceDecs) <- mkKeyTypeDec mps entDef
     keyToValues' <- mkKeyToValues mps entDef
@@ -1232,41 +1636,49 @@ mkEntity entityMap mps entDef = do
 
     lensClauses <- mkLensClauses mps entDef
 
-    lenses <- mkLenses mps entDef
+    lenses <- mkLenses mps entityMap entDef
     let instanceConstraint = if not (mpsGeneric mps) then [] else
           [mkClassP ''PersistStore [backendT]]
 
     [keyFromRecordM'] <-
-        case entityPrimary entDef of
-            Just prim -> do
+        case unboundPrimarySpec entDef of
+            NaturalKey ucd -> do
                 recordName <- newName "record"
-                let keyCon = keyConName entDef
-                    keyFields' = fieldDefToRecordName mps entDef <$> compositeFields prim
+                let
+                    keyCon =
+                        keyConName entDef
+                    keyFields' =
+                        fieldNameToRecordName mps entDef <$> unboundCompositeCols ucd
                     constr =
                         foldl'
                             AppE
                             (ConE keyCon)
-                            (map
+                            (toList $ fmap
                                 (\n ->
                                     VarE n `AppE` VarE recordName
                                 )
                                 keyFields'
                             )
                     keyFromRec = varP 'keyFromRecordM
-                [d|$(keyFromRec) = Just ( \ $(varP recordName) -> $(pure constr)) |]
+                [d|
+                    $(keyFromRec) = Just ( \ $(varP recordName) -> $(pure constr))
+                    |]
 
-            Nothing ->
+            _ ->
                 [d|$(varP 'keyFromRecordM) = Nothing|]
 
-    dtd <- dataTypeDec mps entDef
-    let allEntDefs = entityFieldTHCon <$> efthAllFields fields
-        allEntDefClauses = entityFieldTHClause <$> efthAllFields fields
+    dtd <- dataTypeDec mps entityMap entDef
+    let
+        allEntDefs =
+            entityFieldTHCon <$> efthAllFields fields
+        allEntDefClauses =
+            entityFieldTHClause <$> efthAllFields fields
     return $ addSyn $
        dtd : mconcat fkc `mappend`
       ( [ TySynD (keyIdName entDef) [] $
             ConT ''Key `AppT` ConT name
       , instanceD instanceConstraint clazz
-        [ uniqueTypeDec mps entDef
+        [ uniqueTypeDec mps entityMap entDef
         , keyTypeDec
         , keyToValues'
         , keyFromValues'
@@ -1315,8 +1727,10 @@ mkEntity entityMap mps entDef = do
         ]
       ] `mappend` lenses) `mappend` keyInstanceDecs
   where
-    genDataType = genericDataType mps entName backendT
-    entName = entityHaskell entDef
+    genDataType =
+        genericDataType mps entName backendT
+    entName =
+        getUnboundEntityNameHS preDef
 
 data EntityFieldsTH = EntityFieldsTH
     { entityFieldsTHPrimary :: EntityFieldTH
@@ -1324,18 +1738,77 @@ data EntityFieldsTH = EntityFieldsTH
     }
 
 efthAllFields :: EntityFieldsTH -> [EntityFieldTH]
-efthAllFields EntityFieldsTH{..} = entityFieldsTHPrimary : entityFieldsTHFields
+efthAllFields EntityFieldsTH{..} =
+    stripIdFieldDef entityFieldsTHPrimary : entityFieldsTHFields
+
+stripIdFieldDef :: EntityFieldTH -> EntityFieldTH
+stripIdFieldDef efth = efth
+    { entityFieldTHClause =
+        go (entityFieldTHClause efth)
+    }
+  where
+    go (Clause ps bdy ds) =
+        Clause ps bdy' ds
+      where
+        bdy' =
+            case bdy of
+                NormalB e ->
+                    NormalB $ AppE (VarE 'stripIdFieldImpl) e
+                _ ->
+                    bdy
+
+-- | @persistent@ used to assume that an Id was always a single field.
+--
+-- This method preserves as much backwards compatibility as possible.
+stripIdFieldImpl :: HasCallStack => EntityIdDef -> FieldDef
+stripIdFieldImpl eid =
+    case eid of
+        EntityIdField fd -> fd
+        EntityIdNaturalKey cd ->
+            case compositeFields cd of
+                (x :| xs) ->
+                    case xs of
+                        [] ->
+                            x
+                        _ ->
+                            dummyFieldDef
+  where
+    dummyFieldDef =
+        FieldDef
+            { fieldHaskell =
+                FieldNameHS "Id"
+            , fieldDB =
+                FieldNameDB "__composite_key_no_id__"
+            , fieldType =
+                FTTypeCon Nothing "__Composite_Key__"
+            , fieldSqlType =
+                SqlOther "Composite Key"
+            , fieldAttrs =
+                []
+            , fieldStrict =
+                False
+            , fieldReference =
+                NoReference
+            , fieldCascade =
+                noCascade
+            , fieldComments =
+                Nothing
+            , fieldGenerated =
+                Nothing
+            , fieldIsImplicitIdColumn =
+                False
+            }
 
-mkFields :: MkPersistSettings -> EntityDef -> Q EntityFieldsTH
-mkFields mps entDef =
+mkFields :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q EntityFieldsTH
+mkFields mps entityMap entDef =
     EntityFieldsTH
-        <$> mkField mps entDef (entityId entDef)
-        <*> mapM (mkField mps entDef) (entityFields entDef)
+        <$> mkIdField mps entDef
+        <*> mapM (mkField mps entityMap entDef) (getUnboundFieldDefs entDef)
 
-mkUniqueKeyInstances :: MkPersistSettings -> EntityDef -> Q [Dec]
+mkUniqueKeyInstances :: MkPersistSettings -> UnboundEntityDef -> Q [Dec]
 mkUniqueKeyInstances mps entDef = do
     requirePersistentExtensions
-    case entityUniques entDef of
+    case entityUniques (unboundEntityDef entDef) of
         [] -> mappend <$> typeErrorSingle <*> typeErrorAtLeastOne
         [_] -> mappend <$> singleUniqueKey <*> atLeastOneKey
         (_:_) -> mappend <$> typeErrorMultiple <*> atLeastOneKey
@@ -1401,15 +1874,16 @@ mkUniqueKeyInstances mps entDef = do
         cxt <- withPersistStoreWriteCxt
         pure [instanceD cxt atLeastOneUniqueKeyClass impl]
 
-    genDataType = genericDataType mps (entityHaskell entDef) backendT
+    genDataType =
+        genericDataType mps (getUnboundEntityNameHS entDef) backendT
 
-entityText :: EntityDef -> Text
-entityText = unEntityNameHS . entityHaskell
+entityText :: UnboundEntityDef -> Text
+entityText = unEntityNameHS . getUnboundEntityNameHS
 
-mkLenses :: MkPersistSettings -> EntityDef -> Q [Dec]
-mkLenses mps _ | not (mpsGenerateLenses mps) = return []
-mkLenses _ ent | entitySum ent = return []
-mkLenses mps ent = fmap mconcat $ forM (getEntityFields ent) $ \field -> do
+mkLenses :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q [Dec]
+mkLenses mps _ _ | not (mpsGenerateLenses mps) = return []
+mkLenses _ _ ent | entitySum (unboundEntityDef ent) = return []
+mkLenses mps entityMap ent = fmap mconcat $ forM (getUnboundFieldDefs ent) $ \field -> do
     let lensName = mkEntityLensName mps ent field
         fieldName = fieldDefToRecordName mps ent field
     needleN <- newName "needle"
@@ -1428,9 +1902,12 @@ mkLenses mps ent = fmap mconcat $ forM (getEntityFields ent) $ \field -> do
         -- values
         backend1 = backendName
         backend2 = backendName
-        aT = maybeIdType mps field (Just backend1) Nothing
-        bT = maybeIdType mps field (Just backend2) Nothing
-        mkST backend = genericDataType mps (entityHaskell ent) (VarT backend)
+        aT =
+            maybeIdType mps entityMap field (Just backend1) Nothing
+        bT =
+            maybeIdType mps entityMap field (Just backend2) Nothing
+        mkST backend =
+            genericDataType mps (getUnboundEntityNameHS ent) (VarT backend)
         sT = mkST backend1
         tT = mkST backend2
         t1 `arrow` t2 = ArrowT `AppT` t1 `AppT` t2
@@ -1454,35 +1931,91 @@ mkLenses mps ent = fmap mconcat $ forM (getEntityFields ent) $ \field -> do
             ]
         ]
 
-mkForeignKeysComposite :: MkPersistSettings -> EntityDef -> ForeignDef -> Q [Dec]
-mkForeignKeysComposite mps entDef ForeignDef {..} =
-    if not foreignToPrimary then return [] else do
-    let fieldName = fieldNameToRecordName mps entDef
-    let fname = fieldName (constraintToField foreignConstraintNameHaskell)
-    let reftableString = unpack $ unEntityNameHS foreignRefTableHaskell
-    let reftableKeyName = mkName $ reftableString `mappend` "Key"
-    let tablename = mkEntityDefName entDef
-    recordName <- newName "record"
+mkForeignKeysComposite
+    :: MkPersistSettings
+    -> UnboundEntityDef
+    -> UnboundForeignDef
+    -> Q [Dec]
+mkForeignKeysComposite mps entDef foreignDef
+    | foreignToPrimary (unboundForeignDef foreignDef) = do
+        let
+            fieldName =
+                fieldNameToRecordName mps entDef
+            fname =
+                fieldName $ constraintToField $ foreignConstraintNameHaskell $ unboundForeignDef foreignDef
+            reftableString =
+                unpack $ unEntityNameHS $ foreignRefTableHaskell $ unboundForeignDef foreignDef
+            reftableKeyName =
+                mkName $ reftableString `mappend` "Key"
+            tablename =
+                mkEntityDefName entDef
+            fieldStore =
+                mkFieldStore entDef
+
+        recordName <- newName "record_mkForeignKeysComposite"
+
+        let
+            mkFldE foreignName  =
+                -- using coerce here to convince SqlBackendKey to go away
+                VarE 'coerce `AppE`
+                (VarE (fieldName foreignName) `AppE` VarE recordName)
+            mkFldR ffr =
+                let
+                    e =
+                        mkFldE (ffrSourceField ffr)
+                in
+                    case ffrTargetField ffr of
+                        FieldNameHS "Id" ->
+                            VarE 'toBackendKey `AppE`
+                                e
+                        _ ->
+                            e
+            foreignFieldNames foreignFieldList =
+                case foreignFieldList of
+                    FieldListImpliedId names ->
+                        names
+                    FieldListHasReferences refs ->
+                        fmap ffrSourceField refs
+
+            fldsE =
+                getForeignNames $ (unboundForeignFields foreignDef)
+            getForeignNames = \case
+                FieldListImpliedId xs ->
+                   fmap mkFldE xs
+                FieldListHasReferences xs ->
+                    fmap mkFldR xs
+
+            nullErr n =
+               error $ "Could not find field definition for: " <> show n
+            fNullable =
+                setNull
+                   $ fmap (\n -> fromMaybe (nullErr n) $ getFieldDef n fieldStore)
+                   $ foreignFieldNames
+                   $ unboundForeignFields foreignDef
+            mkKeyE =
+                foldl' AppE (maybeExp fNullable $ ConE reftableKeyName) fldsE
+            fn =
+                FunD fname [normalClause [VarP recordName] mkKeyE]
+
+            keyTargetTable =
+                maybeTyp fNullable $ ConT ''Key `AppT` ConT (mkName reftableString)
+
+        sigTy <- [t| $(conT tablename) -> $(pure keyTargetTable) |]
+        pure
+            [ SigD fname sigTy
+            , fn
+            ]
 
-    let mkFldE ((foreignName, _),ff) = case ff of
-          (FieldNameHS {unFieldNameHS = "Id"}, FieldNameDB {unFieldNameDB = "id"})
-            -> AppE (VarE $ mkName "toBackendKey") $
-               VarE (fieldName foreignName) `AppE` VarE recordName
-          _ -> VarE (fieldName foreignName) `AppE` VarE recordName
-    let fldsE = map mkFldE foreignFields
-    let mkKeyE = foldl' AppE (maybeExp foreignNullable $ ConE reftableKeyName) fldsE
-    let fn = FunD fname [normalClause [VarP recordName] mkKeyE]
+    | otherwise =
+        pure []
+  where
+    constraintToField = FieldNameHS . unConstraintNameHS
 
-    let t2 = maybeTyp foreignNullable $ ConT ''Key `AppT` ConT (mkName reftableString)
-    let sig = SigD fname $ (ArrowT `AppT` (ConT tablename)) `AppT` t2
-    return [sig, fn]
-
-    where
-        constraintToField = FieldNameHS . unConstraintNameHS
 
 maybeExp :: Bool -> Exp -> Exp
 maybeExp may exp | may = fmapE `AppE` exp
                  | otherwise = exp
+
 maybeTyp :: Bool -> Type -> Type
 maybeTyp may typ | may = ConT ''Maybe `AppT` typ
                  | otherwise = typ
@@ -1490,8 +2023,8 @@ maybeTyp may typ | may = ConT ''Maybe `AppT` typ
 entityToPersistValueHelper :: (PersistEntity record) => record -> PersistValue
 entityToPersistValueHelper entity = PersistMap $ zip columnNames fieldsAsPersistValues
     where
-        columnNames = map (unFieldNameHS . fieldHaskell) (getEntityFields (entityDef (Just entity)))
-        fieldsAsPersistValues = map toPersistValue $ toPersistFields entity
+        columnNames = fmap (unFieldNameHS . fieldHaskell) (getEntityFields (entityDef (Just entity)))
+        fieldsAsPersistValues = fmap toPersistValue $ toPersistFields entity
 
 entityFromPersistValueHelper
     :: (PersistEntity record)
@@ -1506,7 +2039,7 @@ entityFromPersistValueHelper columnNames pv = do
         lookupPersistValueByColumnName columnName =
             fromMaybe PersistNull (HM.lookup (pack columnName) columnMap)
 
-    fromPersistValues $ map lookupPersistValueByColumnName columnNames
+    fromPersistValues $ fmap lookupPersistValueByColumnName columnNames
 
 -- | Produce code similar to the following:
 --
@@ -1516,7 +2049,7 @@ entityFromPersistValueHelper columnNames pv = do
 --      fromPersistValue = entityFromPersistValueHelper ["col1", "col2"]
 --      sqlType _ = SqlString
 -- @
-persistFieldFromEntity :: MkPersistSettings -> EntityDef -> Q [Dec]
+persistFieldFromEntity :: MkPersistSettings -> UnboundEntityDef -> Q [Dec]
 persistFieldFromEntity mps entDef = do
     sqlStringConstructor' <- [|SqlString|]
     toPersistValueImplementation <- [|entityToPersistValueHelper|]
@@ -1533,16 +2066,19 @@ persistFieldFromEntity mps entDef = do
             ]
         ]
   where
-    typ = genericDataType mps (entityHaskell entDef) backendT
-    entFields = getEntityFields entDef
-    columnNames = map (unpack . unFieldNameHS . fieldHaskell) entFields
+    typ =
+        genericDataType mps (entityHaskell (unboundEntityDef entDef)) backendT
+    entFields =
+        filter isHaskellUnboundField $ getUnboundFieldDefs entDef
+    columnNames =
+        fmap (unpack . unFieldNameHS . unboundFieldNameHS) entFields
 
 -- | Apply the given list of functions to the same @EntityDef@s.
 --
 -- This function is useful for cases such as:
 --
 -- >>> share [mkSave "myDefs", mkPersist sqlSettings] [persistLowerCase|...|]
-share :: [[EntityDef] -> Q [Dec]] -> [EntityDef] -> Q [Dec]
+share :: [[a] -> Q [Dec]] -> [a] -> Q [Dec]
 share fs x = mconcat <$> mapM ($ x) fs
 
 -- | Save the @EntityDef@s passed in under the given name.
@@ -1566,29 +2102,36 @@ data Dep = Dep
     , depSourceNull  :: IsNullable
     }
 
+{-# DEPRECATED mkDeleteCascade "You can now set update and delete cascade behavior directly on the entity in the quasiquoter. This function and class are deprecated and will be removed in the next major ersion." #-}
+
 -- | Generate a 'DeleteCascade' instance for the given @EntityDef@s.
-mkDeleteCascade :: MkPersistSettings -> [EntityDef] -> Q [Dec]
+--
+-- This function is deprecated as of 2.13.0.0. You can now set cascade
+-- behavior directly in the quasiquoter.
+mkDeleteCascade :: MkPersistSettings -> [UnboundEntityDef] -> Q [Dec]
 mkDeleteCascade mps defs = do
     let deps = concatMap getDeps defs
     mapM (go deps) defs
   where
-    getDeps :: EntityDef -> [Dep]
+    getDeps :: UnboundEntityDef -> [Dep]
     getDeps def =
-        concatMap getDeps' $ getEntityFields $ fixEntityDef def
+        concatMap getDeps' $ getUnboundFieldDefs $ fixEntityDef def
       where
-        getDeps' :: FieldDef -> [Dep]
-        getDeps' field@FieldDef {..} =
-            case foreignReference field of
+        getDeps' :: UnboundFieldDef -> [Dep]
+        getDeps' field =
+            case guessFieldReference field of
                 Just name ->
-                     return Dep
+                    return Dep
                         { depTarget = name
-                        , depSourceTable = entityHaskell def
-                        , depSourceField = fieldHaskell
-                        , depSourceNull  = nullable fieldAttrs
+                        , depSourceTable = entityHaskell (unboundEntityDef def)
+                        , depSourceField = unboundFieldNameHS field
+                        , depSourceNull  = nullable (unboundFieldAttrs field)
                         }
-                Nothing -> []
-    go :: [Dep] -> EntityDef -> Q Dec
-    go allDeps EntityDef{entityHaskell = name} = do
+                Nothing ->
+                    []
+    go :: [Dep] -> UnboundEntityDef -> Q Dec
+    go allDeps ued = do
+        let name = entityHaskell (unboundEntityDef ued)
         let deps = filter (\x -> depTarget x == name) allDeps
         key <- newName "key"
         let del = VarE 'delete
@@ -1611,7 +2154,7 @@ mkDeleteCascade mps defs = do
                 val _                      =             VarE key
 
         let stmts :: [Stmt]
-            stmts = map mkStmt deps `mappend`
+            stmts = fmap mkStmt deps `mappend`
                     [NoBindS $ del `AppE` VarE key]
 
         let entityT = genericDataType mps name backendT
@@ -1641,7 +2184,7 @@ mkDeleteCascade mps defs = do
 mkEntityDefList
     :: String
     -- ^ The name that will be given to the 'EntityDef' list.
-    -> [EntityDef]
+    -> [UnboundEntityDef]
     -> Q [Dec]
 mkEntityDefList entityList entityDefs = do
     let entityListName = mkName entityList
@@ -1656,27 +2199,27 @@ mkEntityDefList entityList entityDefs = do
         , ValD (VarP entityListName) (NormalB edefs) []
         ]
 
-mkUniqueKeys :: EntityDef -> Q Dec
-mkUniqueKeys def | entitySum def =
+mkUniqueKeys :: UnboundEntityDef -> Q Dec
+mkUniqueKeys def | entitySum (unboundEntityDef def) =
     return $ FunD 'persistUniqueKeys [normalClause [WildP] (ListE [])]
 mkUniqueKeys def = do
     c <- clause
     return $ FunD 'persistUniqueKeys [c]
   where
     clause = do
-        xs <- forM (getEntityFields def) $ \fieldDef -> do
-            let x = fieldHaskell fieldDef
+        xs <- forM (getUnboundFieldDefs def) $ \fieldDef -> do
+            let x = unboundFieldNameHS fieldDef
             x' <- newName $ '_' : unpack (unFieldNameHS x)
             return (x, x')
-        let pcs = map (go xs) $ entityUniques def
+        let pcs = fmap (go xs) $ entityUniques $ unboundEntityDef def
         let pat = ConP
                 (mkEntityDefName def)
-                (map (VarP . snd) xs)
+                (fmap (VarP . snd) xs)
         return $ normalClause [pat] (ListE pcs)
 
     go :: [(FieldNameHS, Name)] -> UniqueDef -> Exp
     go xs (UniqueDef name _ cols _) =
-        foldl' (go' xs) (ConE (mkConstraintName name)) (map fst cols)
+        foldl' (go' xs) (ConE (mkConstraintName name)) (toList $ fmap fst cols)
 
     go' :: [(FieldNameHS, Name)] -> Exp -> FieldNameHS -> Exp
     go' xs front col =
@@ -1823,7 +2366,7 @@ migrateModels defs=
 -- This avoids problems where the QuasiQuoter is unable to know what the right
 -- reference types are. This sets 'mkPersist' to be the "single source of truth"
 -- for entity definitions.
-mkMigrate :: String -> [EntityDef] -> Q [Dec]
+mkMigrate :: String -> [UnboundEntityDef] -> Q [Dec]
 mkMigrate fun eds = do
     let entityDefListName = ("entityDefListFor" <> fun)
     body <- [| migrateModels $(varE (mkName entityDefListName)) |]
@@ -1833,49 +2376,6 @@ mkMigrate fun eds = do
         , FunD (mkName fun) [normalClause [] body]
         ]
 
-liftAndFixKeys :: EntityMap -> EntityDef -> Q Exp
-liftAndFixKeys entityMap EntityDef{..} =
-    [|EntityDef
-        entityHaskell
-        entityDB
-        $(liftAndFixKey entityMap entityId)
-        entityAttrs
-        $(ListE <$> mapM (liftAndFixKey entityMap) entityFields)
-        entityUniques
-        entityForeigns
-        entityDerives
-        entityExtra
-        entitySum
-        entityComments
-    |]
-
-liftAndFixKey :: EntityMap -> FieldDef -> Q Exp
-liftAndFixKey entityMap fieldDef@(FieldDef a b c sqlTyp e f fieldRef fc mcomments fg fieldIsImplicitIdColumn)
-    | not fieldIsImplicitIdColumn =
-        [|FieldDef a b c $(sqlTyp') e f (fieldRef') fc mcomments fg fieldIsImplicitIdColumn|]
-    | otherwise =
-        [|FieldDef a b c sqlTyp e f fieldRef fc mcomments fg fieldIsImplicitIdColumn|]
-  where
-      (fieldRef', sqlTyp') =
-          case extractForeignRef entityMap fieldDef of
-            Just (fr, ft) ->
-                (fr, lift (SqlTypeExp ft))
-            Nothing ->
-                (fieldRef, lift sqlTyp)
-
-extractForeignRef :: EntityMap -> FieldDef -> Maybe (ReferenceDef, FieldType)
-extractForeignRef entityMap fieldDef =
-    case fieldReference fieldDef of
-        ForeignRef refName _ft ->  do
-            ent <- M.lookup refName entityMap
-            case fieldReference $ entityId ent of
-                fr@(ForeignRef _ ft) ->
-                    Just (fr, ft)
-                _ ->
-                    Nothing
-        _ ->
-            Nothing
-
 data EntityFieldTH = EntityFieldTH
     { entityFieldTHCon :: Con
     , entityFieldTHClause :: Clause
@@ -1887,22 +2387,77 @@ data EntityFieldTH = EntityFieldTH
 -- forall . typ ~ FieldType => EntFieldName
 --
 -- EntFieldName = FieldDef ....
-mkField :: MkPersistSettings -> EntityDef -> FieldDef -> Q EntityFieldTH
-mkField mps et cd = do
-    let con = ForallC
+--
+-- Field Def Accessors Required:
+mkField :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> UnboundFieldDef -> Q EntityFieldTH
+mkField mps entityMap et fieldDef = do
+    let
+        con =
+            ForallC
                 []
-                [mkEqualP (VarT $ mkName "typ") $ maybeIdType mps cd Nothing Nothing]
+                [mkEqualP (VarT $ mkName "typ") $ maybeIdType mps entityMap fieldDef Nothing Nothing]
                 $ NormalC name []
-    bod <- lift cd
+    bod <- mkLookupEntityField et (unboundFieldNameHS fieldDef)
     let cla = normalClause
                 [ConP name []]
                 bod
     return $ EntityFieldTH con cla
   where
-    name = filterConName mps et cd
+    name = filterConName mps et fieldDef
+
+mkIdField :: MkPersistSettings -> UnboundEntityDef -> Q EntityFieldTH
+mkIdField mps ued = do
+    let
+        entityName =
+            getUnboundEntityNameHS ued
+        entityIdType
+            | mpsGeneric mps =
+                ConT ''Key `AppT` (
+                    ConT (mkEntityNameHSGenericName entityName)
+                    `AppT` backendT
+                )
+            | otherwise =
+                ConT $ mkName $ (T.unpack $ unEntityNameHS entityName) ++ "Id"
+        name =
+            filterConName' mps entityName (FieldNameHS "Id")
+    clause  <-
+        fixPrimarySpec mps ued
+    pure EntityFieldTH
+        { entityFieldTHCon =
+            ForallC
+                []
+                [mkEqualP (VarT $ mkName "typ") entityIdType]
+                $ NormalC name []
+        , entityFieldTHClause =
+            normalClause [ConP name []] clause
+        }
 
-maybeNullable :: FieldDef -> Bool
-maybeNullable fd = nullable (fieldAttrs fd) == Nullable ByMaybeAttr
+lookupEntityField
+    :: PersistEntity entity
+    => Proxy entity
+    -> FieldNameHS
+    -> FieldDef
+lookupEntityField prxy fieldNameHS =
+    fromMaybe boom $ List.find ((fieldNameHS ==) . fieldHaskell) $ entityFields $ entityDef prxy
+  where
+    boom =
+        error "Database.Persist.TH.Internal.lookupEntityField: failed to find entity field with database name"
+
+mkLookupEntityField
+    :: UnboundEntityDef
+    -> FieldNameHS
+    -> Q Exp
+mkLookupEntityField ued ufd =
+    [|
+        lookupEntityField
+            (Proxy :: Proxy $(conT entityName))
+            $(lift ufd)
+    |]
+  where
+    entityName = mkEntityNameHSName (getUnboundEntityNameHS ued)
+
+maybeNullable :: UnboundFieldDef -> Bool
+maybeNullable fd = nullable (unboundFieldAttrs fd) == Nullable ByMaybeAttr
 
 ftToType :: FieldType -> Type
 ftToType (FTTypeCon Nothing t) = ConT $ mkName $ unpack t
@@ -1914,11 +2469,11 @@ ftToType (FTApp x y) = ftToType x `AppT` ftToType y
 ftToType (FTList x) = ListT `AppT` ftToType x
 
 infixr 5 ++
-(++) :: Text -> Text -> Text
-(++) = append
+(++) :: Monoid m => m -> m -> m
+(++) = mappend
 
-mkJSON :: MkPersistSettings -> EntityDef -> Q [Dec]
-mkJSON _ def | ("json" `notElem` entityAttrs def) = return []
+mkJSON :: MkPersistSettings -> UnboundEntityDef -> Q [Dec]
+mkJSON _ def | ("json" `notElem` entityAttrs (unboundEntityDef def)) = return []
 mkJSON mps def = do
     requireExtensions [[FlexibleInstances]]
     pureE <- [|pure|]
@@ -1930,37 +2485,51 @@ mkJSON mps def = do
     objectE <- [|object|]
     obj <- newName "obj"
     mzeroE <- [|mzero|]
+    let
+        fields =
+            getUnboundFieldDefs def
 
-    xs <- mapM fieldToJSONValName (getEntityFields def)
-
-    let conName = mkEntityDefName def
-        typ = genericDataType mps (entityHaskell def) backendT
-        toJSONI = typeInstanceD ''ToJSON (mpsGeneric mps) typ [toJSON']
-        toJSON' = FunD 'toJSON $ return $ normalClause
-            [ConP conName $ map VarP xs]
-            (objectE `AppE` ListE pairs)
-        pairs = zipWith toPair (getEntityFields def) xs
-        toPair f x = InfixE
-            (Just (packE `AppE` LitE (StringL $ unpack $ unFieldNameHS $ fieldHaskell f)))
-            dotEqualE
-            (Just $ VarE x)
-        fromJSONI = typeInstanceD ''FromJSON (mpsGeneric mps) typ [parseJSON']
-        parseJSON' = FunD 'parseJSON
-            [ normalClause [ConP 'Object [VarP obj]]
-                (foldl'
-                    (\x y -> InfixE (Just x) apE' (Just y))
-                    (pureE `AppE` ConE conName)
-                    pulls
-                )
-            , normalClause [WildP] mzeroE
-            ]
-        pulls = map toPull $ getEntityFields def
-        toPull f = InfixE
-            (Just $ VarE obj)
-            (if maybeNullable f then dotColonQE else dotColonE)
-            (Just $ AppE packE $ LitE $ StringL $ unpack $ unFieldNameHS $ fieldHaskell f)
+    xs <- mapM fieldToJSONValName fields
+
+    let
+        conName =
+            mkEntityDefName def
+        typ =
+            genericDataType mps (entityHaskell (unboundEntityDef def)) backendT
+        toJSONI =
+            typeInstanceD ''ToJSON (mpsGeneric mps) typ [toJSON']
+          where
+            toJSON' = FunD 'toJSON $ return $ normalClause
+                [ConP conName $ fmap VarP xs]
+                (objectE `AppE` ListE pairs)
+              where
+                pairs = zipWith toPair fields xs
+                toPair f x = InfixE
+                    (Just (packE `AppE` LitE (StringL $ unpack $ unFieldNameHS $ unboundFieldNameHS f)))
+                    dotEqualE
+                    (Just $ VarE x)
+        fromJSONI =
+            typeInstanceD ''FromJSON (mpsGeneric mps) typ [parseJSON']
+          where
+            parseJSON' = FunD 'parseJSON
+                [ normalClause [ConP 'Object [VarP obj]]
+                    (foldl'
+                        (\x y -> InfixE (Just x) apE' (Just y))
+                        (pureE `AppE` ConE conName)
+                        pulls
+                    )
+                , normalClause [WildP] mzeroE
+                ]
+              where
+                pulls =
+                    fmap toPull fields
+                toPull f = InfixE
+                    (Just $ VarE obj)
+                    (if maybeNullable f then dotColonQE else dotColonE)
+                    (Just $ AppE packE $ LitE $ StringL $ unpack $ unFieldNameHS $ unboundFieldNameHS f)
     case mpsEntityJSON mps of
-        Nothing -> return [toJSONI, fromJSONI]
+        Nothing ->
+            return [toJSONI, fromJSONI]
         Just entityJSON -> do
             entityJSONIs <- if mpsGeneric mps
               then [d|
@@ -1998,7 +2567,7 @@ instanceD = InstanceD Nothing
 requirePersistentExtensions :: Q ()
 requirePersistentExtensions = requireExtensions requiredExtensions
   where
-    requiredExtensions = map pure
+    requiredExtensions = fmap pure
         [ DerivingStrategies
         , GeneralizedNewtypeDeriving
         , StandaloneDeriving
@@ -2006,36 +2575,69 @@ requirePersistentExtensions = requireExtensions requiredExtensions
         , MultiParamTypeClasses
         ]
 
-mkSymbolToFieldInstances :: MkPersistSettings -> EntityDef -> Q [Dec]
-mkSymbolToFieldInstances mps ed = do
-    fmap join $ forM (keyAndEntityFields (fixEntityDef ed)) $ \fieldDef -> do
+mkSymbolToFieldInstances :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q [Dec]
+mkSymbolToFieldInstances mps entityMap (fixEntityDef -> ed) = do
+    let
+        entityHaskellName =
+            getEntityHaskellName $ unboundEntityDef ed
+        allFields =
+            getUnboundFieldDefs ed
+        mkEntityFieldConstr fieldHaskellName =
+            conE $ filterConName' mps entityHaskellName fieldHaskellName
+                :: Q Exp
+    regularFields <- forM (toList allFields) $ \fieldDef -> do
+        let
+            fieldHaskellName =
+                unboundFieldNameHS fieldDef
+
         let fieldNameT :: Q Type
             fieldNameT =
                 litT $ strTyLit
                     $ T.unpack $ lowerFirstIfId
-                    $ unFieldNameHS $ fieldHaskell fieldDef
+                    $ unFieldNameHS fieldHaskellName
 
             lowerFirstIfId "Id" = "id"
             lowerFirstIfId xs = xs
 
-            nameG = mkEntityDefGenericName ed
-
-            recordNameT
-                | mpsGeneric mps =
-                    conT nameG `appT` varT backendName
+            fieldTypeT
+                | fieldHaskellName == FieldNameHS "Id" =
+                    conT ''Key `appT` recordNameT
                 | otherwise =
-                    entityDefConT ed
-
-            fieldTypeT =
-                maybeIdType mps fieldDef Nothing Nothing
+                    pure $ maybeIdType mps entityMap fieldDef Nothing Nothing
             entityFieldConstr =
-                conE $ filterConName mps ed fieldDef
-                    :: Q Exp
+                mkEntityFieldConstr fieldHaskellName
+        mkInstance fieldNameT fieldTypeT entityFieldConstr
+
+    mkey <-
+        case unboundPrimarySpec ed of
+            NaturalKey _ ->
+                pure []
+            _ -> do
+                let
+                    fieldHaskellName =
+                        FieldNameHS "Id"
+                    entityFieldConstr =
+                        mkEntityFieldConstr fieldHaskellName
+                    fieldTypeT =
+                        conT ''Key `appT` recordNameT
+                mkInstance [t|"id"|] fieldTypeT entityFieldConstr
+
+    pure (mkey <> join regularFields)
+  where
+    nameG =
+        mkEntityDefGenericName ed
+    recordNameT
+        | mpsGeneric mps =
+            conT nameG `appT` varT backendName
+        | otherwise =
+            entityDefConT ed
+    mkInstance fieldNameT fieldTypeT entityFieldConstr =
         [d|
-            instance SymbolToField $(fieldNameT) $(recordNameT) $(pure fieldTypeT) where
+            instance SymbolToField $(fieldNameT) $(recordNameT) $(fieldTypeT) where
                 symbolToField = $(entityFieldConstr)
             |]
 
+
 -- | Pass in a list of lists of extensions, where any of the given
 -- extensions will satisfy it. For example, you might need either GADTs or
 -- ExistentialQuantification, so you'd write:
@@ -2063,18 +2665,18 @@ requireExtensions requiredExtensions = do
                      ]
     extensions -> fail $ mconcat
                     [ "Generating Persistent entities now requires the following language extensions:\n\n"
-                    , List.intercalate "\n" (map show extensions)
+                    , List.intercalate "\n" (fmap show extensions)
                     , "\n\nPlease enable the extensions by copy/pasting these lines into the top of your file:\n\n"
-                    , List.intercalate "\n" (map extensionToPragma extensions)
+                    , List.intercalate "\n" (fmap extensionToPragma extensions)
                     ]
 
   where
     extensionToPragma ext = "{-# LANGUAGE " <> show ext <> " #-}"
 
 -- | creates a TH Name for use in the ToJSON instance
-fieldToJSONValName :: FieldDef -> Q Name
+fieldToJSONValName :: UnboundFieldDef -> Q Name
 fieldToJSONValName =
-    newName . T.unpack . unFieldNameHSForJSON . fieldHaskell
+    newName . T.unpack . unFieldNameHSForJSON . unboundFieldNameHS
 
 -- | This special-cases "type_" and strips out its underscore. When
 -- used for JSON serialization and deserialization, it works around
@@ -2086,13 +2688,13 @@ unFieldNameHSForJSON = fixTypeUnderscore . unFieldNameHS
         "type" -> "type_"
         name -> name
 
-entityDefConK :: EntityDef -> Kind
+entityDefConK :: UnboundEntityDef -> Kind
 entityDefConK = conK . mkEntityDefName
 
-entityDefConT :: EntityDef -> Q Type
+entityDefConT :: UnboundEntityDef -> Q Type
 entityDefConT = pure . entityDefConK
 
-entityDefConE :: EntityDef -> Exp
+entityDefConE :: UnboundEntityDef -> Exp
 entityDefConE = ConE . mkEntityDefName
 
 -- | creates a TH Name for an entity's field, based on the entity
@@ -2102,18 +2704,18 @@ entityDefConE = ConE . mkEntityDefName
 --   name Text
 --
 -- This would generate `customerName` as a TH Name
-fieldNameToRecordName :: MkPersistSettings -> EntityDef -> FieldNameHS -> Name
+fieldNameToRecordName :: MkPersistSettings -> UnboundEntityDef -> FieldNameHS -> Name
 fieldNameToRecordName mps entDef fieldName =
-    mkRecordName mps mUnderscore (entityHaskell entDef) fieldName
+    mkRecordName mps mUnderscore (entityHaskell (unboundEntityDef entDef)) fieldName
   where
     mUnderscore
         | mpsGenerateLenses mps = Just "_"
         | otherwise = Nothing
 
 -- | as above, only takes a `FieldDef`
-fieldDefToRecordName :: MkPersistSettings -> EntityDef -> FieldDef -> Name
+fieldDefToRecordName :: MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
 fieldDefToRecordName mps entDef fieldDef =
-    fieldNameToRecordName mps entDef (fieldHaskell fieldDef)
+    fieldNameToRecordName mps entDef (unboundFieldNameHS fieldDef)
 
 -- | creates a TH Name for a lens on an entity's field, based on the entity
 -- name and the field name, so as above but for the Lens
@@ -2124,9 +2726,9 @@ fieldDefToRecordName mps entDef fieldDef =
 -- Generates a lens `customerName` when `mpsGenerateLenses` is true
 -- while `fieldNameToRecordName` generates a prefixed function
 -- `_customerName`
-mkEntityLensName :: MkPersistSettings -> EntityDef -> FieldDef -> Name
+mkEntityLensName :: MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
 mkEntityLensName mps entDef fieldDef =
-    mkRecordName mps Nothing (entityHaskell entDef) (fieldHaskell fieldDef)
+    mkRecordName mps Nothing (entityHaskell (unboundEntityDef entDef)) (unboundFieldNameHS fieldDef)
 
 mkRecordName :: MkPersistSettings -> Maybe Text -> EntityNameHS -> FieldNameHS -> Name
 mkRecordName mps prefix entNameHS fieldNameHS =
@@ -2146,11 +2748,15 @@ mkRecordName mps prefix entNameHS fieldNameHS =
         unFieldNameHS fieldNameHS
 
 -- | Construct a list of TH Names for the typeclasses of an EntityDef's `entityDerives`
-mkEntityDefDeriveNames :: MkPersistSettings -> EntityDef -> [Name]
+mkEntityDefDeriveNames :: MkPersistSettings -> UnboundEntityDef -> [Name]
 mkEntityDefDeriveNames mps entDef =
-    let entityInstances = mkName . T.unpack <$> entityDerives entDef
-        additionalInstances = filter (`notElem` entityInstances) $ mpsDeriveInstances mps
-     in entityInstances <> additionalInstances
+    let
+        entityInstances =
+            mkName . T.unpack <$> entityDerives (unboundEntityDef entDef)
+        additionalInstances =
+            filter (`notElem` entityInstances) $ mpsDeriveInstances mps
+     in
+        entityInstances <> additionalInstances
 
 -- | Make a TH Name for the EntityDef's Haskell type
 mkEntityNameHSName :: EntityNameHS -> Name
@@ -2158,44 +2764,57 @@ mkEntityNameHSName =
     mkName . T.unpack . unEntityNameHS
 
 -- | As above only taking an `EntityDef`
-mkEntityDefName :: EntityDef -> Name
+mkEntityDefName :: UnboundEntityDef -> Name
 mkEntityDefName =
-    mkEntityNameHSName . entityHaskell
+    mkEntityNameHSName . entityHaskell . unboundEntityDef
 
 -- | Make a TH Name for the EntityDef's Haskell type, when using mpsGeneric
-mkEntityDefGenericName :: EntityDef -> Name
+mkEntityDefGenericName :: UnboundEntityDef -> Name
 mkEntityDefGenericName =
-    mkEntityNameHSGenericName . entityHaskell
+    mkEntityNameHSGenericName . entityHaskell . unboundEntityDef
 
 mkEntityNameHSGenericName :: EntityNameHS -> Name
 mkEntityNameHSGenericName name =
     mkName $ T.unpack (unEntityNameHS name <> "Generic")
 
-sumConstrName :: MkPersistSettings -> EntityDef -> FieldDef -> Name
-sumConstrName mps entDef FieldDef {..} = mkName $ T.unpack name
-    where
-        name
-            | mpsPrefixFields mps = modifiedName ++ "Sum"
-            | otherwise           = fieldName ++ "Sum"
-        modifiedName = mpsConstraintLabelModifier mps entityName fieldName
-        entityName   = unEntityNameHS $ entityHaskell entDef
-        fieldName    = upperFirst $ unFieldNameHS fieldHaskell
+-- needs:
+--
+-- * entityHaskell
+--     * field on EntityDef
+-- * fieldHaskell
+--     * field on FieldDef
+--
+sumConstrName :: MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name
+sumConstrName mps entDef unboundFieldDef =
+    mkName $ T.unpack name
+  where
+    name
+        | mpsPrefixFields mps = modifiedName ++ "Sum"
+        | otherwise           = fieldName ++ "Sum"
+    fieldNameHS =
+        unboundFieldNameHS unboundFieldDef
+    modifiedName =
+        mpsConstraintLabelModifier mps entityName fieldName
+    entityName =
+        unEntityNameHS $ getUnboundEntityNameHS entDef
+    fieldName =
+        upperFirst $ unFieldNameHS fieldNameHS
 
 -- | Turn a ConstraintName into a TH Name
 mkConstraintName :: ConstraintNameHS -> Name
 mkConstraintName (ConstraintNameHS name) =
     mkName (T.unpack name)
 
-keyIdName :: EntityDef -> Name
+keyIdName :: UnboundEntityDef -> Name
 keyIdName = mkName . T.unpack . keyIdText
 
-keyIdText :: EntityDef -> Text
-keyIdText entDef = unEntityNameHS (entityHaskell entDef) `mappend` "Id"
+keyIdText :: UnboundEntityDef -> Text
+keyIdText entDef = unEntityNameHS (getUnboundEntityNameHS entDef) `mappend` "Id"
 
-unKeyName :: EntityDef -> Name
+unKeyName :: UnboundEntityDef -> Name
 unKeyName entDef = mkName $ T.unpack $ "un" `mappend` keyText entDef
 
-unKeyExp :: EntityDef -> Exp
+unKeyExp :: UnboundEntityDef -> Exp
 unKeyExp = VarE . unKeyName
 
 backendT :: Type
@@ -2204,29 +2823,51 @@ backendT = VarT backendName
 backendName :: Name
 backendName = mkName "backend"
 
-keyConName :: EntityDef -> Name
-keyConName entDef = mkName $ T.unpack $ resolveConflict $ keyText entDef
+-- needs:
+--
+-- * keyText
+--     * entityNameHaskell
+--  * fields
+--      * fieldHaskell
+--
+-- keyConName :: EntityNameHS -> [FieldHaskell] -> Name
+keyConName :: UnboundEntityDef -> Name
+keyConName entDef =
+    keyConName'
+        (getUnboundEntityNameHS entDef)
+        (unboundFieldNameHS <$> unboundEntityFields (entDef))
+
+
+keyConName' :: EntityNameHS -> [FieldNameHS] -> Name
+keyConName' entName entFields = mkName $ T.unpack $ resolveConflict $ keyText' entName
   where
     resolveConflict kn = if conflict then kn `mappend` "'" else kn
-    conflict = any ((== FieldNameHS "key") . fieldHaskell) $ getEntityFields entDef
+    conflict = any (== FieldNameHS "key") entFields
+
+-- keyConExp :: EntityNameHS -> [FieldNameHS] -> Exp
+keyConExp :: UnboundEntityDef -> Exp
+keyConExp ed = ConE $ keyConName ed
 
-keyConExp :: EntityDef -> Exp
-keyConExp = ConE . keyConName
+keyText :: UnboundEntityDef -> Text
+keyText entDef = unEntityNameHS (getUnboundEntityNameHS entDef) ++ "Key"
 
-keyText :: EntityDef -> Text
-keyText entDef = unEntityNameHS (entityHaskell entDef) ++ "Key"
+keyText' :: EntityNameHS -> Text
+keyText' entName = unEntityNameHS entName ++ "Key"
 
-keyFieldName :: MkPersistSettings -> EntityDef -> FieldDef -> Name
+keyFieldName :: MkPersistSettings -> UnboundEntityDef -> FieldNameHS -> Name
 keyFieldName mps entDef fieldDef
-  | pkNewtype mps entDef = unKeyName entDef
-  | otherwise = mkName $ T.unpack $ lowerFirst (keyText entDef) `mappend` unFieldNameHS (fieldHaskell fieldDef)
+    | pkNewtype mps entDef =
+        unKeyName entDef
+    | otherwise =
+        mkName $ T.unpack $ lowerFirst (keyText entDef) `mappend` unFieldNameHS fieldDef
 
 filterConName
     :: MkPersistSettings
-    -> EntityDef
-    -> FieldDef
+    -> UnboundEntityDef
+    -> UnboundFieldDef
     -> Name
-filterConName mps entity field = filterConName' mps (entityHaskell entity) (fieldHaskell field)
+filterConName mps (unboundEntityDef -> entity) field =
+    filterConName' mps (entityHaskell entity) (unboundFieldNameHS field)
 
 filterConName'
     :: MkPersistSettings
@@ -2255,7 +2896,7 @@ filterConName' mps entity field = mkName $ T.unpack name
 --
 -- @
 -- share
---   [ mkPersist sqlSettings . mappend $(discoverEntities)
+--   [ mkPersistWith sqlSettings $(discoverEntities)
 --   ]
 --   [persistLowerCase| ... |]
 -- @
@@ -2277,7 +2918,7 @@ filterConName' mps entity field = mkName $ T.unpack name
 -- import Bar
 --
 -- -- Since Foo and Bar are both imported, discoverEntities can find them here.
--- mkPersist sqlSettings . mappend $(discoverEntities) [persistLowerCase|
+-- mkPersistWith sqlSettings $(discoverEntities) [persistLowerCase|
 --   User
 --     name Text
 --     age  Int
@@ -2320,3 +2961,17 @@ discoverEntities = do
     fmap ListE $
         forM types $ \typ -> do
             [e| entityDef (Proxy :: Proxy $(pure typ)) |]
+
+setNull :: NonEmpty UnboundFieldDef -> Bool
+setNull (fd :| fds) =
+    let
+        nullSetting =
+            isNull fd
+        isNull =
+            (NotNullable /=) . nullable . unboundFieldAttrs
+    in
+        if all ((nullSetting ==) . isNull) fds
+        then nullSetting
+        else error $
+            "foreign key columns must all be nullable or non-nullable"
+           ++ show (fmap (unFieldNameHS . unboundFieldNameHS) (fd:fds))
diff --git a/persistent/Database/Persist/Types/Base.hs b/persistent/Database/Persist/Types/Base.hs
index cd853bca5..0a560c360 100644
--- a/persistent/Database/Persist/Types/Base.hs
+++ b/persistent/Database/Persist/Types/Base.hs
@@ -1,5 +1,4 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveLift #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE PatternSynonyms #-}
@@ -11,43 +10,25 @@
 module Database.Persist.Types.Base
     ( module Database.Persist.Types.Base
     -- * Re-exports
-    , PersistValue(.., PersistLiteral, PersistLiteralEscaped, PersistDbSpecific)
+    , PersistValue(..)
+    , fromPersistValueText
     , LiteralType(..)
     ) where
 
-import Control.Arrow (second)
 import Control.Exception (Exception)
-import qualified Data.Aeson as A
-import Data.Bits (shiftL, shiftR)
-import Data.ByteString (ByteString, foldl')
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Base64 as B64
-import qualified Data.ByteString.Char8 as BS8
 import Data.Char (isSpace)
-import qualified Data.HashMap.Strict as HM
-import Data.Int (Int64)
+import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.List.NonEmpty as NEL
 import Data.Map (Map)
 import Data.Maybe (isNothing)
-#if !MIN_VERSION_base(4,11,0)
--- This can be removed when GHC < 8.2.2 isn't supported anymore
-import Data.Semigroup ((<>))
-#endif
-import qualified Data.Scientific
 import Data.Text (Text)
 import qualified Data.Text as T
-import qualified Data.Text.Encoding as TE
-import Data.Text.Encoding.Error (lenientDecode)
-import Data.Time (Day, TimeOfDay, UTCTime)
-import qualified Data.Vector as V
 import Data.Word (Word32)
 import Language.Haskell.TH.Syntax (Lift(..))
-import Numeric (readHex, showHex)
 import Web.HttpApiData
        ( FromHttpApiData(..)
        , ToHttpApiData(..)
        , parseBoundedTextData
-       , parseUrlPieceMaybe
-       , readTextData
        , showTextData
        )
 import Web.PathPieces (PathPiece(..))
@@ -56,6 +37,7 @@ import Web.PathPieces (PathPiece(..))
 import Instances.TH.Lift ()
 
 import Database.Persist.Names
+import Database.Persist.PersistValue
 
 -- | A 'Checkmark' should be used as a field type whenever a
 -- uniqueness constraint should guarantee that a certain kind of
@@ -143,7 +125,7 @@ data EntityDef = EntityDef
     -- ^ The name of the entity as Haskell understands it.
     , entityDB      :: !EntityNameDB
     -- ^ The name of the database table corresponding to the entity.
-    , entityId      :: !FieldDef
+    , entityId      :: !EntityIdDef
     -- ^ The entity's primary key or identifier.
     , entityAttrs   :: ![Attr]
     -- ^ The @persistent@ entity syntax allows you to add arbitrary 'Attr's
@@ -170,29 +152,64 @@ data EntityDef = EntityDef
     }
     deriving (Show, Eq, Read, Ord, Lift)
 
-entitiesPrimary :: EntityDef -> Maybe [FieldDef]
-entitiesPrimary t = case fieldReference primaryField of
-    CompositeRef c -> Just $ compositeFields c
-    ForeignRef _ _ -> Just [primaryField]
-    _ -> Nothing
-  where
-    primaryField = entityId t
-
-entityPrimary :: EntityDef -> Maybe CompositeDef
-entityPrimary t = case fieldReference (entityId t) of
-    CompositeRef c -> Just c
-    _ -> Nothing
+-- | The definition for the entity's primary key ID.
+--
+-- @since 2.13.0.0
+data EntityIdDef
+    = EntityIdField !FieldDef
+    -- ^ The entity has a single key column, and it is a surrogate key - that
+    -- is, you can't go from @rec -> Key rec@.
+    --
+    -- @since 2.13.0.0
+    | EntityIdNaturalKey !CompositeDef
+    -- ^ The entity has a natural key. This means you can write @rec -> Key rec@
+    -- because all the key fields are present on the datatype.
+    --
+    -- A natural key can have one or more columns.
+    --
+    -- @since 2.13.0.0
+    deriving (Show, Eq, Read, Ord, Lift)
 
-entityKeyFields :: EntityDef -> [FieldDef]
-entityKeyFields ent =
-    maybe [entityId ent] compositeFields $ entityPrimary ent
+-- | Return the @['FieldDef']@ for the entity keys.
+entitiesPrimary :: EntityDef -> NonEmpty FieldDef
+entitiesPrimary t =
+    case entityId t of
+        EntityIdNaturalKey fds ->
+            compositeFields fds
+        EntityIdField fd ->
+            pure fd
 
-keyAndEntityFields :: EntityDef -> [FieldDef]
+entityPrimary :: EntityDef -> Maybe CompositeDef
+entityPrimary t =
+    case entityId t of
+        EntityIdNaturalKey c ->
+            Just c
+        _ ->
+            Nothing
+
+entityKeyFields :: EntityDef -> NonEmpty FieldDef
+entityKeyFields =
+    entitiesPrimary
+
+-- | Returns a 'NonEmpty' list of 'FieldDef' that correspond with the key
+-- columns for an 'EntityDef'.
+keyAndEntityFields :: EntityDef -> NonEmpty FieldDef
 keyAndEntityFields ent =
-  case entityPrimary ent of
-    Nothing -> entityId ent : entityFields ent
-    Just _  -> entityFields ent
-
+    case entityId ent of
+        EntityIdField fd ->
+            fd :| fields
+        EntityIdNaturalKey _ ->
+            case NEL.nonEmpty fields of
+                Nothing ->
+                    error $ mconcat
+                        [ "persistent internal guarantee failed: entity is "
+                        , "defined with an entityId = EntityIdNaturalKey, "
+                        , "but somehow doesn't have any entity fields."
+                        ]
+                Just xs ->
+                    xs
+  where
+    fields = filter isHaskellField $ entityFields ent
 
 type ExtraLine = [Text]
 
@@ -207,16 +224,146 @@ type Attr = Text
 -- @since 2.11.0.0
 data FieldAttr
     = FieldAttrMaybe
+    -- ^ The 'Maybe' keyword goes after the type. This indicates that the column
+    -- is nullable, and the generated Haskell code will have a @'Maybe'@ type
+    -- for it.
+    --
+    -- Example:
+    --
+    -- @
+    -- User
+    --     name Text Maybe
+    -- @
     | FieldAttrNullable
+    -- ^ This indicates that the column is nullable, but should not have
+    -- a 'Maybe' type. For this to work out, you need to ensure that the
+    -- 'PersistField' instance for the type in question can support
+    -- a 'PersistNull' value.
+    --
+    -- @
+    -- data What = NoWhat | Hello Text
+    --
+    -- instance PersistField What where
+    --     fromPersistValue PersistNull =
+    --         pure NoWhat
+    --     fromPersistValue pv =
+    --         Hello <$> fromPersistValue pv
+    --
+    -- instance PersistFieldSql What where
+    --     sqlType _ = SqlString
+    --
+    -- User
+    --     what What nullable
+    -- @
     | FieldAttrMigrationOnly
+    -- ^ This tag means that the column will not be present on the Haskell code,
+    -- but will not be removed from the database. Useful to deprecate fields in
+    -- phases.
+    --
+    -- You should set the column to be nullable in the database. Otherwise,
+    -- inserts won't have values.
+    --
+    -- @
+    -- User
+    --     oldName Text MigrationOnly
+    --     newName Text
+    -- @
     | FieldAttrSafeToRemove
+    -- ^ A @SafeToRemove@ attribute is not present on the Haskell datatype, and
+    -- the backend migrations should attempt to drop the column without
+    -- triggering any unsafe migration warnings.
+    --
+    -- Useful after you've used @MigrationOnly@ to remove a column from the
+    -- database in phases.
+    --
+    -- @
+    -- User
+    --     oldName Text SafeToRemove
+    --     newName Text
+    -- @
     | FieldAttrNoreference
+    -- ^ This attribute indicates that we should create a foreign key reference
+    -- from a column. By default, @persistent@ will try and create a foreign key
+    -- reference for a column if it can determine that the type of the column is
+    -- a @'Key' entity@ or an @EntityId@  and the @Entity@'s name was present in
+    -- 'mkPersist'.
+    --
+    -- This is useful if you want to use the explicit foreign key syntax.
+    --
+    -- @
+    -- Post
+    --     title    Text
+    --
+    -- Comment
+    --     postId   PostId      noreference
+    --     Foreign Post fk_comment_post postId
+    -- @
     | FieldAttrReference Text
+    -- ^ This is set to specify precisely the database table the column refers
+    -- to.
+    --
+    -- @
+    -- Post
+    --     title    Text
+    --
+    -- Comment
+    --     postId   PostId references="post"
+    -- @
+    --
+    -- You should not need this - @persistent@ should be capable of correctly
+    -- determining the target table's name. If you do need this, please file an
+    -- issue describing why.
     | FieldAttrConstraint Text
+    -- ^ Specify a name for the constraint on the foreign key reference for this
+    -- table.
+    --
+    -- @
+    -- Post
+    --     title    Text
+    --
+    -- Comment
+    --     postId   PostId constraint="my_cool_constraint_name"
+    -- @
     | FieldAttrDefault Text
+    -- ^ Specify the default value for a column.
+    --
+    -- @
+    -- User
+    --     createdAt    UTCTime     default="NOW()"
+    -- @
+    --
+    -- Note that a @default=@ attribute does not mean you can omit the value
+    -- while inserting.
     | FieldAttrSqltype Text
+    -- ^ Specify a custom SQL type for the column. Generally, you should define
+    -- a custom datatype with a custom 'PersistFieldSql' instance instead of
+    -- using this.
+    --
+    -- @
+    -- User
+    --     uuid     Text    sqltype="UUID"
+    -- @
     | FieldAttrMaxlen Integer
+    -- ^ Set a maximum length for a column. Useful for VARCHAR and indexes.
+    --
+    -- @
+    -- User
+    --     name     Text    maxlen=200
+    --
+    --     UniqueName name
+    -- @
+    | FieldAttrSql Text
+    -- ^ Specify the database name of the column.
+    --
+    -- @
+    -- User
+    --     blarghle     Int     sql="b_l_a_r_g_h_l_e"
+    -- @
+    --
+    -- Useful for performing phased migrations, where one column is renamed to
+    -- another column over time.
     | FieldAttrOther Text
+    -- ^ A grab bag of random attributes that were unrecognized by the parser.
     deriving (Show, Eq, Read, Ord, Lift)
 
 -- | Parse raw field attributes into structured form. Any unrecognized
@@ -239,6 +386,8 @@ parseFieldAttrs = fmap $ \case
         | Just x <- T.stripPrefix "maxlen=" raw -> case reads (T.unpack x) of
             [(n, s)] | all isSpace s -> FieldAttrMaxlen n
             _ -> error $ "Could not parse maxlen field with value " <> show raw
+        | Just x <- T.stripPrefix "sql=" raw ->
+            FieldAttrSql x
         | otherwise -> FieldAttrOther raw
 
 -- | A 'FieldType' describes a field parsed from the QuasiQuoter and is
@@ -267,14 +416,16 @@ isFieldNotGenerated = isNothing . fieldGenerated
 -- 1) composite (to fields that exist in the record)
 -- 2) single field
 -- 3) embedded
-data ReferenceDef = NoReference
-                  | ForeignRef !EntityNameHS !FieldType
-                    -- ^ A ForeignRef has a late binding to the EntityDef it references via name and has the Haskell type of the foreign key in the form of FieldType
-                  | EmbedRef EmbedEntityDef
-                  | CompositeRef CompositeDef
-                  | SelfReference
-                    -- ^ A SelfReference stops an immediate cycle which causes non-termination at compile-time (issue #311).
-                  deriving (Show, Eq, Read, Ord, Lift)
+data ReferenceDef
+    = NoReference
+    | ForeignRef !EntityNameHS
+    -- ^ A ForeignRef has a late binding to the EntityDef it references via name
+    -- and has the Haskell type of the foreign key in the form of FieldType
+    | EmbedRef EntityNameHS
+    | CompositeRef CompositeDef
+    | SelfReference
+    -- ^ A SelfReference stops an immediate cycle which causes non-termination at compile-time (issue #311).
+    deriving (Show, Eq, Read, Ord, Lift)
 
 -- | An EmbedEntityDef is the same as an EntityDef
 -- But it is only used for fieldReference
@@ -289,14 +440,13 @@ data EmbedEntityDef = EmbedEntityDef
 -- so it only has data needed for embedding
 data EmbedFieldDef = EmbedFieldDef
     { emFieldDB    :: FieldNameDB
-    , emFieldEmbed :: Maybe EmbedEntityDef
-    , emFieldCycle :: Maybe EntityNameHS
-    -- ^ 'emFieldEmbed' can create a cycle (issue #311)
-    -- when a cycle is detected, 'emFieldEmbed' will be Nothing
-    -- and 'emFieldCycle' will be Just
+    , emFieldEmbed :: Maybe (Either SelfEmbed EntityNameHS)
     }
     deriving (Show, Eq, Read, Ord, Lift)
 
+data SelfEmbed = SelfEmbed
+    deriving (Show, Eq, Read, Ord, Lift)
+
 -- | Returns 'True' if the 'FieldDef' does not have a 'MigrationOnly' or
 -- 'SafeToRemove' flag from the QuasiQuoter.
 --
@@ -323,12 +473,9 @@ toEmbedEntityDef ent = embDef
                 fieldDB field
             , emFieldEmbed =
                 case fieldReference field of
-                    EmbedRef em -> Just em
-                    SelfReference -> Just embDef
-                    _ -> Nothing
-            , emFieldCycle =
-                case fieldReference field of
-                    SelfReference -> Just $ entityHaskell ent
+                    EmbedRef em ->
+                        Just $ Right em
+                    SelfReference -> Just $ Left SelfEmbed
                     _ -> Nothing
             }
 
@@ -356,13 +503,13 @@ toEmbedEntityDef ent = embDef
 data UniqueDef = UniqueDef
     { uniqueHaskell :: !ConstraintNameHS
     , uniqueDBName  :: !ConstraintNameDB
-    , uniqueFields  :: ![(FieldNameHS, FieldNameDB)]
+    , uniqueFields  :: !(NonEmpty (FieldNameHS, FieldNameDB))
     , uniqueAttrs   :: ![Attr]
     }
     deriving (Show, Eq, Read, Ord, Lift)
 
 data CompositeDef = CompositeDef
-    { compositeFields  :: ![FieldDef]
+    { compositeFields  :: !(NonEmpty FieldDef)
     , compositeAttrs   :: ![Attr]
     }
     deriving (Show, Eq, Read, Ord, Lift)
@@ -451,221 +598,6 @@ data PersistException
 
 instance Exception PersistException
 
--- | A raw value which can be stored in any backend and can be marshalled to
--- and from a 'PersistField'.
-data PersistValue
-    = PersistText Text
-    | PersistByteString ByteString
-    | PersistInt64 Int64
-    | PersistDouble Double
-    | PersistRational Rational
-    | PersistBool Bool
-    | PersistDay Day
-    | PersistTimeOfDay TimeOfDay
-    | PersistUTCTime UTCTime
-    | PersistNull
-    | PersistList [PersistValue]
-    | PersistMap [(Text, PersistValue)]
-    | PersistObjectId ByteString -- ^ Intended especially for MongoDB backend
-    | PersistArray [PersistValue] -- ^ Intended especially for PostgreSQL backend for text arrays
-    | PersistLiteral_ LiteralType ByteString
-    -- ^ This constructor is used to specify some raw literal value for the
-    -- backend. The 'LiteralType' value specifies how the value should be
-    -- escaped. This can be used to make special, custom types avaialable
-    -- in the back end.
-    --
-    -- @since 2.12.0.0
-    deriving (Show, Read, Eq, Ord)
-
--- | A type that determines how a backend should handle the literal.
---
--- @since 2.12.0.0
-data LiteralType
-    = Escaped
-    -- ^ The accompanying value will be escaped before inserting into the
-    -- database. This is the correct default choice to use.
-    --
-    -- @since 2.12.0.0
-    | Unescaped
-    -- ^ The accompanying value will not be escaped when inserting into the
-    -- database. This is potentially dangerous - use this with care.
-    --
-    -- @since 2.12.0.0
-    | DbSpecific
-    -- ^ The 'DbSpecific' constructor corresponds to the legacy
-    -- 'PersistDbSpecific' constructor. We need to keep this around because
-    -- old databases may have serialized JSON representations that
-    -- reference this. We don't want to break the ability of a database to
-    -- load rows.
-    --
-    -- @since 2.12.0.0
-    deriving (Show, Read, Eq, Ord)
-
--- | This pattern synonym used to be a data constructor for the
--- 'PersistValue' type. It was changed to be a pattern so that JSON-encoded
--- database values could be parsed into their corresponding values. You
--- should not use this, and instead prefer to pattern match on
--- `PersistLiteral_` directly.
---
--- If you use this, it will overlap a patern match on the 'PersistLiteral_,
--- 'PersistLiteral', and 'PersistLiteralEscaped' patterns. If you need to
--- disambiguate between these constructors, pattern match on
--- 'PersistLiteral_' directly.
---
--- @since 2.12.0.0
-pattern PersistDbSpecific :: ByteString -> PersistValue
-pattern PersistDbSpecific bs <- PersistLiteral_ _ bs where
-    PersistDbSpecific bs = PersistLiteral_ DbSpecific bs
-
--- | This pattern synonym used to be a data constructor on 'PersistValue',
--- but was changed into a catch-all pattern synonym to allow backwards
--- compatiblity with database types. See the documentation on
--- 'PersistDbSpecific' for more details.
---
--- @since 2.12.0.0
-pattern PersistLiteralEscaped :: ByteString -> PersistValue
-pattern PersistLiteralEscaped bs <- PersistLiteral_ _ bs where
-    PersistLiteralEscaped bs = PersistLiteral_ Escaped bs
-
--- | This pattern synonym used to be a data constructor on 'PersistValue',
--- but was changed into a catch-all pattern synonym to allow backwards
--- compatiblity with database types. See the documentation on
--- 'PersistDbSpecific' for more details.
---
--- @since 2.12.0.0
-pattern PersistLiteral :: ByteString -> PersistValue
-pattern PersistLiteral bs <- PersistLiteral_ _ bs where
-    PersistLiteral bs = PersistLiteral_ Unescaped bs
-
-{-# DEPRECATED PersistDbSpecific "Deprecated since 2.11 because of inconsistent escaping behavior across backends. The Postgres backend escapes these values, while the MySQL backend does not. If you are using this, please switch to 'PersistLiteral_' and provide a relevant 'LiteralType' for your conversion." #-}
-
-instance ToHttpApiData PersistValue where
-    toUrlPiece val =
-        case fromPersistValueText val of
-            Left  e -> error $ T.unpack e
-            Right y -> y
-
-instance FromHttpApiData PersistValue where
-    parseUrlPiece input =
-          PersistInt64 <$> parseUrlPiece input
-      <!> PersistList  <$> readTextData input
-      <!> PersistText  <$> return input
-      where
-        infixl 3 <!>
-        Left _ <!> y = y
-        x      <!> _ = x
-
-instance PathPiece PersistValue where
-  toPathPiece   = toUrlPiece
-  fromPathPiece = parseUrlPieceMaybe
-
-fromPersistValueText :: PersistValue -> Either Text Text
-fromPersistValueText (PersistText s) = Right s
-fromPersistValueText (PersistByteString bs) =
-    Right $ TE.decodeUtf8With lenientDecode bs
-fromPersistValueText (PersistInt64 i) = Right $ T.pack $ show i
-fromPersistValueText (PersistDouble d) = Right $ T.pack $ show d
-fromPersistValueText (PersistRational r) = Right $ T.pack $ show r
-fromPersistValueText (PersistDay d) = Right $ T.pack $ show d
-fromPersistValueText (PersistTimeOfDay d) = Right $ T.pack $ show d
-fromPersistValueText (PersistUTCTime d) = Right $ T.pack $ show d
-fromPersistValueText PersistNull = Left "Unexpected null"
-fromPersistValueText (PersistBool b) = Right $ T.pack $ show b
-fromPersistValueText (PersistList _) = Left "Cannot convert PersistList to Text"
-fromPersistValueText (PersistMap _) = Left "Cannot convert PersistMap to Text"
-fromPersistValueText (PersistObjectId _) = Left "Cannot convert PersistObjectId to Text"
-fromPersistValueText (PersistArray _) = Left "Cannot convert PersistArray to Text"
-fromPersistValueText (PersistLiteral_ _ _) = Left "Cannot convert PersistLiteral to Text"
-
-instance A.ToJSON PersistValue where
-    toJSON (PersistText t) = A.String $ T.cons 's' t
-    toJSON (PersistByteString b) = A.String $ T.cons 'b' $ TE.decodeUtf8 $ B64.encode b
-    toJSON (PersistInt64 i) = A.Number $ fromIntegral i
-    toJSON (PersistDouble d) = A.Number $ Data.Scientific.fromFloatDigits d
-    toJSON (PersistRational r) = A.String $ T.pack $ 'r' : show r
-    toJSON (PersistBool b) = A.Bool b
-    toJSON (PersistTimeOfDay t) = A.String $ T.pack $ 't' : show t
-    toJSON (PersistUTCTime u) = A.String $ T.pack $ 'u' : show u
-    toJSON (PersistDay d) = A.String $ T.pack $ 'd' : show d
-    toJSON PersistNull = A.Null
-    toJSON (PersistList l) = A.Array $ V.fromList $ map A.toJSON l
-    toJSON (PersistMap m) = A.object $ map (second A.toJSON) m
-    toJSON (PersistLiteral_ litTy b) =
-        let encoded = TE.decodeUtf8 $ B64.encode b
-            prefix =
-                case litTy of
-                    DbSpecific -> 'p'
-                    Unescaped -> 'l'
-                    Escaped -> 'e'
-         in
-            A.String $ T.cons prefix encoded
-    toJSON (PersistArray a) = A.Array $ V.fromList $ map A.toJSON a
-    toJSON (PersistObjectId o) =
-      A.toJSON $ showChar 'o' $ showHexLen 8 (bs2i four) $ showHexLen 16 (bs2i eight) ""
-        where
-         (four, eight) = BS8.splitAt 4 o
-
-         -- taken from crypto-api
-         bs2i :: ByteString -> Integer
-         bs2i bs = foldl' (\i b -> (i `shiftL` 8) + fromIntegral b) 0 bs
-         {-# INLINE bs2i #-}
-
-         -- showHex of n padded with leading zeros if necessary to fill d digits
-         -- taken from Data.BSON
-         showHexLen :: (Show n, Integral n) => Int -> n -> ShowS
-         showHexLen d n = showString (replicate (d - sigDigits n) '0') . showHex n  where
-             sigDigits 0 = 1
-             sigDigits n' = truncate (logBase (16 :: Double) $ fromIntegral n') + 1
-
-instance A.FromJSON PersistValue where
-    parseJSON (A.String t0) =
-        case T.uncons t0 of
-            Nothing -> fail "Null string"
-            Just ('p', t) -> either (\_ -> fail "Invalid base64") (return . PersistDbSpecific)
-                           $ B64.decode $ TE.encodeUtf8 t
-            Just ('l', t) -> either (\_ -> fail "Invalid base64") (return . PersistLiteral)
-                           $ B64.decode $ TE.encodeUtf8 t
-            Just ('e', t) -> either (\_ -> fail "Invalid base64") (return . PersistLiteralEscaped)
-                           $ B64.decode $ TE.encodeUtf8 t
-            Just ('s', t) -> return $ PersistText t
-            Just ('b', t) -> either (\_ -> fail "Invalid base64") (return . PersistByteString)
-                           $ B64.decode $ TE.encodeUtf8 t
-            Just ('t', t) -> PersistTimeOfDay <$> readMay t
-            Just ('u', t) -> PersistUTCTime <$> readMay t
-            Just ('d', t) -> PersistDay <$> readMay t
-            Just ('r', t) -> PersistRational <$> readMay t
-            Just ('o', t) -> maybe
-                (fail "Invalid base64")
-                (return . PersistObjectId . i2bs (8 * 12) . fst)
-                $ headMay $ readHex $ T.unpack t
-            Just (c, _) -> fail $ "Unknown prefix: " ++ [c]
-      where
-        headMay []    = Nothing
-        headMay (x:_) = Just x
-        readMay t =
-            case reads $ T.unpack t of
-                (x, _):_ -> return x
-                [] -> fail "Could not read"
-
-        -- taken from crypto-api
-        -- |@i2bs bitLen i@ converts @i@ to a 'ByteString' of @bitLen@ bits (must be a multiple of 8).
-        i2bs :: Int -> Integer -> BS.ByteString
-        i2bs l i = BS.unfoldr (\l' -> if l' < 0 then Nothing else Just (fromIntegral (i `shiftR` l'), l' - 8)) (l-8)
-        {-# INLINE i2bs #-}
-
-
-    parseJSON (A.Number n) = return $
-        if fromInteger (floor n) == n
-            then PersistInt64 $ floor n
-            else PersistDouble $ fromRational $ toRational n
-    parseJSON (A.Bool b) = return $ PersistBool b
-    parseJSON A.Null = return PersistNull
-    parseJSON (A.Array a) = fmap PersistList (mapM A.parseJSON $ V.toList a)
-    parseJSON (A.Object o) =
-        fmap PersistMap $ mapM go $ HM.toList o
-      where
-        go (k, v) = (,) k <$> A.parseJSON v
-
 -- | A SQL data type. Naming attempts to reflect the underlying Haskell
 -- datatypes, eg SqlString instead of SqlVarchar. Different SQL databases may
 -- have different translations for these types.
diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal
index 712d03fe7..73f73c85f 100644
--- a/persistent/persistent.cabal
+++ b/persistent/persistent.cabal
@@ -16,7 +16,7 @@ extra-source-files: ChangeLog.md README.md
 
 library
     build-depends:   
-        base                     >= 4.9       && < 5
+        base                     >= 4.11.1.0     && < 5
       , aeson                    >= 1.0
       , attoparsec
       , base64-bytestring
@@ -34,7 +34,7 @@ library
       , resourcet                >= 1.1.10
       , scientific
       , silently
-      , template-haskell         >= 2.11 && < 2.18
+      , template-haskell         >= 2.13 && < 2.18
       , text                     >= 1.2
       , th-lift-instances        >= 0.1.14    && < 0.2
       , time                     >= 1.6
@@ -54,6 +54,7 @@ library
         Database.Persist
         Database.Persist.Types
         Database.Persist.Names
+        Database.Persist.PersistValue
         Database.Persist.EntityDef
         Database.Persist.EntityDef.Internal
         Database.Persist.FieldDef
@@ -120,37 +121,36 @@ test-suite test
       , base64-bytestring
       , blaze-html
       , bytestring
+      , conduit
       , containers
+      , fast-logger
       , hspec         >= 2.4
       , http-api-data
+      , monad-logger
+      , mtl
       , path-pieces
       , persistent
+      , QuickCheck
+      , quickcheck-instances     >= 0.3
+      , resource-pool
+      , resourcet
       , scientific
       , shakespeare
+      , silently
+      , template-haskell         >= 2.4
       , text
+      , th-lift-instances
       , time
       , transformers
+      , unliftio
+      , unliftio-core
       , unordered-containers
       , vector
-      , QuickCheck
-        -- needed because of the `source-dirs: .`
-        -- TODO: factor the internal modules out so we can use them in tests
-        -- maybe in another package
-      , template-haskell         >= 2.4
-      , unliftio-core
-      , mtl
-      , resourcet
-      , conduit
-      , monad-logger
-      , fast-logger
-      , resource-pool
-      , unliftio
-      , silently
-      , th-lift-instances
 
     hs-source-dirs:
         test/
-    cpp-options: -DTEST
+
+    ghc-options: -Wall
 
     default-extensions: FlexibleContexts
                       , MultiParamTypeClasses
@@ -165,8 +165,14 @@ test-suite test
         Database.Persist.TH.SharedPrimaryKeyImportedSpec
         Database.Persist.TH.SharedPrimaryKeySpec
         Database.Persist.TH.MultiBlockSpec
+        Database.Persist.TH.ForeignRefSpec
+        Database.Persist.TH.JsonEncodingSpec
         Database.Persist.TH.MultiBlockSpec.Model
+        Database.Persist.TH.ToFromPersistValuesSpec
         Database.Persist.THSpec
+        Database.Persist.QuasiSpec
+        Database.Persist.ClassSpec
+        Database.Persist.PersistValueSpec
         TemplateTestImports
         Database.Persist.TH.SharedPrimaryKeySpec
         Database.Persist.TH.SharedPrimaryKeyImportedSpec
diff --git a/persistent/test/Database/Persist/ClassSpec.hs b/persistent/test/Database/Persist/ClassSpec.hs
new file mode 100644
index 000000000..429b15b70
--- /dev/null
+++ b/persistent/test/Database/Persist/ClassSpec.hs
@@ -0,0 +1,16 @@
+module Database.Persist.ClassSpec where
+
+import Database.Persist.Class
+import Data.Time
+import Database.Persist.Types
+import Test.Hspec
+
+spec :: Spec
+spec = describe "Class" $ do
+    describe "PersistField" $ do
+        describe "UTCTime" $ do
+            it "fromPersistValue with format" $
+                fromPersistValue (PersistText "2018-02-27 10:49:42.123")
+                    `shouldBe`
+                        Right (UTCTime (fromGregorian 2018 02 27) (timeOfDayToTime (TimeOfDay 10 49 42.123)))
+
diff --git a/persistent/test/Database/Persist/PersistValueSpec.hs b/persistent/test/Database/Persist/PersistValueSpec.hs
new file mode 100644
index 000000000..a8ded1d27
--- /dev/null
+++ b/persistent/test/Database/Persist/PersistValueSpec.hs
@@ -0,0 +1,42 @@
+module Database.Persist.PersistValueSpec where
+
+import Test.Hspec
+import Database.Persist.PersistValue
+import Data.List.NonEmpty (NonEmpty(..), (<|))
+import qualified Data.Text as T
+import Test.Hspec
+import Test.Hspec.QuickCheck
+import Test.QuickCheck
+import Data.Aeson
+import qualified Data.ByteString.Char8 as BS8
+
+
+spec :: Spec
+spec = describe "PersistValueSpec" $ do
+    describe "PersistValue" $ do
+        describe "Aeson" $ do
+            let
+                testPrefix constr prefixChar bytes =
+                    takePrefix (toJSON (constr (BS8.pack bytes)))
+                    ===
+                    String (T.singleton prefixChar)
+                roundTrip constr bytes =
+                    fromJSON (toJSON (constr (BS8.pack bytes)))
+                    ===
+                    Data.Aeson.Success (constr (BS8.pack bytes))
+                subject constr prefixChar = do
+                    prop ("encodes with a " ++ [prefixChar] ++ " prefix") $
+                        testPrefix constr prefixChar
+                    prop "Round Trips" $
+                        roundTrip constr
+
+            describe "PersistDbSpecific" $ do
+                subject (PersistLiteral_ DbSpecific) 'p'
+            describe "PersistLiteral" $ do
+                subject PersistLiteral 'l'
+            describe "PersistLiteralEscaped" $ do
+                subject PersistLiteralEscaped 'e'
+
+takePrefix :: Value -> Value
+takePrefix (String a) = String (T.take 1 a)
+takePrefix a = a
diff --git a/persistent/test/Database/Persist/QuasiSpec.hs b/persistent/test/Database/Persist/QuasiSpec.hs
new file mode 100644
index 000000000..1c94b7f54
--- /dev/null
+++ b/persistent/test/Database/Persist/QuasiSpec.hs
@@ -0,0 +1,879 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Database.Persist.QuasiSpec where
+
+import Prelude hiding (lines)
+
+import Data.List hiding (lines)
+import Data.List.NonEmpty (NonEmpty(..), (<|))
+import qualified Data.List.NonEmpty as NEL
+import qualified Data.Map as Map
+import qualified Data.Text as T
+import Database.Persist.EntityDef.Internal
+import Database.Persist.Quasi
+import Database.Persist.Quasi.Internal
+import Database.Persist.Types
+import Test.Hspec
+import Test.Hspec.QuickCheck
+import Test.QuickCheck
+import Text.Shakespeare.Text (st)
+
+spec :: Spec
+spec = describe "Quasi" $ do
+    describe "splitExtras" $ do
+        let helloWorldTokens = Token "hello" :| [Token "world"]
+            foobarbazTokens = Token "foo" :| [Token "bar", Token "baz"]
+        it "works" $ do
+            splitExtras []
+                `shouldBe`
+                    mempty
+        it "works2" $ do
+            splitExtras
+                [ Line 0 helloWorldTokens
+                ]
+                `shouldBe`
+                    ( [NEL.toList helloWorldTokens], mempty )
+        it "works3" $ do
+            splitExtras
+                [ Line 0 helloWorldTokens
+                , Line 2 foobarbazTokens
+                ]
+                `shouldBe`
+                    ( [NEL.toList helloWorldTokens, NEL.toList foobarbazTokens], mempty )
+        it "works4" $ do
+            splitExtras
+                [ Line 0 [Token "Product"]
+                , Line 2 (Token <$> ["name", "Text"])
+                , Line 2 (Token <$> ["added", "UTCTime", "default=CURRENT_TIMESTAMP"])
+                ]
+                `shouldBe`
+                    ( []
+                    , Map.fromList
+                        [ ("Product",
+                            [ ["name", "Text"]
+                            , ["added", "UTCTime", "default=CURRENT_TIMESTAMP"]
+                            ]
+                        ) ]
+                    )
+        it "works5" $ do
+            splitExtras
+                [ Line 0 [Token "Product"]
+                , Line 2 (Token <$> ["name", "Text"])
+                , Line 4 [Token "ExtraBlock"]
+                , Line 4 (Token <$> ["added", "UTCTime", "default=CURRENT_TIMESTAMP"])
+                ]
+                `shouldBe`
+                    ( []
+                    , Map.fromList
+                        [ ("Product",
+                            [ ["name", "Text"]
+                            , ["ExtraBlock"]
+                            , ["added", "UTCTime", "default=CURRENT_TIMESTAMP"]
+                            ]
+                        )]
+                    )
+    describe "takeColsEx" $ do
+        let subject = takeColsEx upperCaseSettings
+        it "fails on a single word" $ do
+            subject ["asdf"]
+                `shouldBe`
+                    Nothing
+        it "works if it has a name and a type" $ do
+            subject ["asdf", "Int"]
+                `shouldBe`
+                    Just UnboundFieldDef
+                        { unboundFieldNameHS = FieldNameHS "asdf"
+                        , unboundFieldNameDB = FieldNameDB "asdf"
+                        , unboundFieldType = FTTypeCon Nothing "Int"
+                        , unboundFieldAttrs = []
+                        , unboundFieldStrict = True
+                        , unboundFieldCascade = noCascade
+                        , unboundFieldComments = Nothing
+                        , unboundFieldGenerated = Nothing
+                        }
+        it "works if it has a name, type, and cascade" $ do
+            subject ["asdf", "Int", "OnDeleteCascade", "OnUpdateCascade"]
+                `shouldBe`
+                    Just UnboundFieldDef
+                        { unboundFieldNameHS = FieldNameHS "asdf"
+                        , unboundFieldNameDB = FieldNameDB "asdf"
+                        , unboundFieldType = FTTypeCon Nothing "Int"
+                        , unboundFieldAttrs = []
+                        , unboundFieldStrict = True
+                        , unboundFieldCascade = FieldCascade (Just Cascade) (Just Cascade)
+                        , unboundFieldComments = Nothing
+                        , unboundFieldGenerated = Nothing
+                        }
+        it "never tries to make a refernece" $ do
+            subject ["asdf", "UserId", "OnDeleteCascade"]
+                `shouldBe`
+                    Just UnboundFieldDef
+                        { unboundFieldNameHS = FieldNameHS "asdf"
+                        , unboundFieldNameDB = FieldNameDB "asdf"
+                        , unboundFieldType = FTTypeCon Nothing "UserId"
+                        , unboundFieldAttrs = []
+                        , unboundFieldStrict = True
+                        , unboundFieldCascade = FieldCascade Nothing (Just Cascade)
+                        , unboundFieldComments = Nothing
+                        , unboundFieldGenerated = Nothing
+                        }
+
+    describe "parseLine" $ do
+        it "returns nothing when line is just whitespace" $
+            parseLine "         " `shouldBe` Nothing
+
+        it "handles normal words" $
+            parseLine " foo   bar  baz" `shouldBe`
+                Just
+                    ( Line 1
+                        [ Token "foo"
+                        , Token "bar"
+                        , Token "baz"
+                        ]
+                    )
+
+        it "handles quotes" $
+            parseLine "  \"foo bar\"  \"baz\"" `shouldBe`
+                Just
+                    ( Line 2
+                        [ Token "foo bar"
+                        , Token "baz"
+                        ]
+                    )
+
+        it "handles quotes mid-token" $
+            parseLine "  x=\"foo bar\"  \"baz\"" `shouldBe`
+                Just
+                    ( Line 2
+                        [ Token "x=foo bar"
+                        , Token "baz"
+                        ]
+                    )
+
+        it "handles escaped quote mid-token" $
+            parseLine "  x=\\\"foo bar\"  \"baz\"" `shouldBe`
+                Just
+                    ( Line 2
+                        [ Token "x=\\\"foo"
+                        , Token "bar\""
+                        , Token "baz"
+                        ]
+                    )
+
+        it "handles unnested parantheses" $
+            parseLine "  (foo bar)  (baz)" `shouldBe`
+                Just
+                    ( Line 2
+                        [ Token "foo bar"
+                        , Token "baz"
+                        ]
+                    )
+
+        it "handles unnested parantheses mid-token" $
+            parseLine "  x=(foo bar)  (baz)" `shouldBe`
+                Just
+                    ( Line 2
+                        [ Token "x=foo bar"
+                        , Token "baz"
+                        ]
+                    )
+
+        it "handles nested parantheses" $
+            parseLine "  (foo (bar))  (baz)" `shouldBe`
+                Just
+                    ( Line 2
+                        [ Token "foo (bar)"
+                        , Token "baz"
+                        ]
+                    )
+
+        it "escaping" $
+            parseLine "  (foo \\(bar)  y=\"baz\\\"\"" `shouldBe`
+                Just
+                    ( Line 2
+                        [ Token "foo (bar"
+                        , Token "y=baz\""
+                        ]
+                    )
+
+        it "mid-token quote in later token" $
+            parseLine "foo bar baz=(bin\")" `shouldBe`
+                Just
+                    ( Line 0
+                        [ Token "foo"
+                        , Token "bar"
+                        , Token "baz=bin\""
+                        ]
+                    )
+
+        describe "comments" $ do
+            it "recognizes one line" $ do
+                parseLine "-- | this is a comment" `shouldBe`
+                    Just
+                        ( Line 0
+                            [ DocComment "this is a comment"
+                            ]
+                        )
+
+            it "works if comment is indented" $ do
+                parseLine "  -- | comment" `shouldBe`
+                    Just (Line 2 [DocComment "comment"])
+
+    describe "parse" $ do
+        let subject =
+                [st|
+Bicycle -- | this is a bike
+    brand String -- | the brand of the bike
+    ExtraBike
+        foo bar  -- | this is a foo bar
+        baz
+    deriving Eq
+-- | This is a Car
+Car
+    -- | the make of the Car
+    make String
+    -- | the model of the Car
+    model String
+    UniqueModel model
+    deriving Eq Show
++Vehicle
+    bicycle BicycleId -- | the bike reference
+    car CarId         -- | the car reference
+
+                    |]
+        let [bicycle, car, vehicle] = parse lowerCaseSettings subject
+
+        it "should parse the `entityHaskell` field" $ do
+            getUnboundEntityNameHS bicycle `shouldBe` EntityNameHS "Bicycle"
+            getUnboundEntityNameHS car `shouldBe` EntityNameHS "Car"
+            getUnboundEntityNameHS vehicle `shouldBe` EntityNameHS "Vehicle"
+
+        it "should parse the `entityDB` field" $ do
+            entityDB (unboundEntityDef bicycle) `shouldBe` EntityNameDB "bicycle"
+            entityDB (unboundEntityDef car) `shouldBe` EntityNameDB "car"
+            entityDB (unboundEntityDef vehicle) `shouldBe` EntityNameDB "vehicle"
+
+        it "should parse the `entityAttrs` field" $ do
+            entityAttrs (unboundEntityDef bicycle) `shouldBe` ["-- | this is a bike"]
+            entityAttrs (unboundEntityDef car) `shouldBe` []
+            entityAttrs (unboundEntityDef vehicle) `shouldBe` []
+
+        it "should parse the `unboundEntityFields` field" $ do
+            let simplifyField field =
+                    (unboundFieldNameHS field, unboundFieldNameDB field, unboundFieldComments field)
+            (simplifyField <$> unboundEntityFields bicycle) `shouldBe`
+                [ (FieldNameHS "brand", FieldNameDB "brand", Nothing)
+                ]
+            (simplifyField <$> unboundEntityFields car) `shouldBe`
+                [ (FieldNameHS "make", FieldNameDB "make", Just "the make of the Car\n")
+                , (FieldNameHS "model", FieldNameDB "model", Just "the model of the Car\n")
+                ]
+            (simplifyField <$> unboundEntityFields vehicle) `shouldBe`
+                [ (FieldNameHS "bicycle", FieldNameDB "bicycle", Nothing)
+                , (FieldNameHS "car", FieldNameDB "car", Nothing)
+                ]
+
+        it "should parse the `entityUniques` field" $ do
+            let simplifyUnique unique =
+                    (uniqueHaskell unique, uniqueFields unique)
+            (simplifyUnique <$> entityUniques (unboundEntityDef bicycle)) `shouldBe` []
+            (simplifyUnique <$> entityUniques (unboundEntityDef car)) `shouldBe`
+                [ (ConstraintNameHS "UniqueModel", [(FieldNameHS "model", FieldNameDB "model")])
+                ]
+            (simplifyUnique <$> entityUniques (unboundEntityDef vehicle)) `shouldBe` []
+
+        it "should parse the `entityForeigns` field" $ do
+            let [user, notification] = parse lowerCaseSettings [st|
+User
+    name            Text
+    emailFirst      Text
+    emailSecond     Text
+
+    UniqueEmail emailFirst emailSecond
+
+Notification
+    content         Text
+    sentToFirst     Text
+    sentToSecond    Text
+
+    Foreign User fk_noti_user sentToFirst sentToSecond References emailFirst emailSecond
+|]
+            unboundForeignDefs user `shouldBe` []
+            map unboundForeignDef (unboundForeignDefs notification) `shouldBe`
+                [ ForeignDef
+                    { foreignRefTableHaskell = EntityNameHS "User"
+                    , foreignRefTableDBName = EntityNameDB "user"
+                    , foreignConstraintNameHaskell = ConstraintNameHS "fk_noti_user"
+                    , foreignConstraintNameDBName = ConstraintNameDB "notificationfk_noti_user"
+                    , foreignFieldCascade = FieldCascade Nothing Nothing
+                    , foreignFields =
+                        []
+                        -- the foreign fields are not set yet in an unbound
+                        -- entity def
+                    , foreignAttrs = []
+                    , foreignNullable = False
+                    , foreignToPrimary = False
+                    }
+                ]
+
+        it "should parse the `entityDerives` field" $ do
+            entityDerives (unboundEntityDef bicycle) `shouldBe` ["Eq"]
+            entityDerives (unboundEntityDef car) `shouldBe` ["Eq", "Show"]
+            entityDerives (unboundEntityDef vehicle) `shouldBe` []
+
+        it "should parse the `entityEntities` field" $ do
+            entityExtra (unboundEntityDef bicycle) `shouldBe` Map.singleton "ExtraBike" [["foo", "bar", "-- | this is a foo bar"], ["baz"]]
+            entityExtra (unboundEntityDef car) `shouldBe` mempty
+            entityExtra (unboundEntityDef vehicle) `shouldBe` mempty
+
+        it "should parse the `entitySum` field" $ do
+            entitySum (unboundEntityDef bicycle) `shouldBe` False
+            entitySum (unboundEntityDef car) `shouldBe` False
+            entitySum (unboundEntityDef vehicle) `shouldBe` True
+
+        it "should parse the `entityComments` field" $ do
+            entityComments (unboundEntityDef bicycle) `shouldBe` Nothing
+            entityComments (unboundEntityDef car) `shouldBe` Just "This is a Car\n"
+            entityComments (unboundEntityDef vehicle) `shouldBe` Nothing
+
+        describe "foreign keys" $ do
+            let definitions = [st|
+User
+    name            Text
+    emailFirst      Text
+    emailSecond     Text
+
+    UniqueEmail emailFirst emailSecond
+
+Notification
+    content         Text
+    sentToFirst     Text
+    sentToSecond    Text
+
+    Foreign User fk_noti_user sentToFirst sentToSecond References emailFirst emailSecond
+|]
+
+            it "should allow you to modify the FK name via provided function" $ do
+                let
+                    flippedFK (EntityNameHS entName) (ConstraintNameHS conName) =
+                        conName <> entName
+                    [_user, notification] =
+                        parse (setPsToFKName flippedFK lowerCaseSettings) definitions
+                    [notificationForeignDef] =
+                        unboundForeignDef <$> unboundForeignDefs notification
+                foreignConstraintNameDBName notificationForeignDef
+                    `shouldBe`
+                        ConstraintNameDB "fk_noti_user_notification"
+
+            it "should allow you to enable snake cased foriegn keys via a preset configuration function" $ do
+                let
+                    [_user, notification] =
+                        parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) definitions
+                    [notificationForeignDef] =
+                        unboundForeignDef <$> unboundForeignDefs notification
+                foreignConstraintNameDBName notificationForeignDef
+                    `shouldBe`
+                        ConstraintNameDB "notification_fk_noti_user"
+
+    describe "parseFieldType" $ do
+        it "simple types" $
+            parseFieldType "FooBar" `shouldBe` Right (FTTypeCon Nothing "FooBar")
+        it "module types" $
+            parseFieldType "Data.Map.FooBar" `shouldBe` Right (FTTypeCon (Just "Data.Map") "FooBar")
+        it "application" $
+            parseFieldType "Foo Bar" `shouldBe` Right (
+                FTTypeCon Nothing "Foo" `FTApp` FTTypeCon Nothing "Bar")
+        it "application multiple" $
+            parseFieldType "Foo Bar Baz" `shouldBe` Right (
+                (FTTypeCon Nothing "Foo" `FTApp` FTTypeCon Nothing "Bar")
+                `FTApp` FTTypeCon Nothing "Baz"
+                )
+        it "parens" $ do
+            let foo = FTTypeCon Nothing "Foo"
+                bar = FTTypeCon Nothing "Bar"
+                baz = FTTypeCon Nothing "Baz"
+            parseFieldType "Foo (Bar Baz)" `shouldBe` Right (
+                foo `FTApp` (bar `FTApp` baz))
+        it "lists" $ do
+            let foo = FTTypeCon Nothing "Foo"
+                bar = FTTypeCon Nothing "Bar"
+                bars = FTList bar
+                baz = FTTypeCon Nothing "Baz"
+            parseFieldType "Foo [Bar] Baz" `shouldBe` Right (
+                foo `FTApp` bars `FTApp` baz)
+        it "fails on lowercase starts" $ do
+            parseFieldType "nothanks" `shouldBe` Left "PSFail ('n',\"othanks\")"
+
+    describe "#1175 empty entity" $ do
+        let subject =
+                [st|
+Foo
+    name String
+    age Int
+
+EmptyEntity
+
+Bar
+    name String
+
+Baz
+    a Int
+    b String
+    c FooId
+                    |]
+
+        let preparsed =
+                preparse subject
+        it "preparse works" $ do
+            (length <$> preparsed) `shouldBe` Just 10
+
+        let fooLines =
+                [ Line
+                    { lineIndent = 0
+                    , tokens = Token "Foo" :| []
+                    }
+                , Line
+                    { lineIndent = 4
+                    , tokens = Token "name" :| [Token "String"]
+                    }
+                , Line
+                    { lineIndent = 4
+                    , tokens = Token "age" :| [Token "Int"]
+                    }
+                ]
+            emptyLines =
+                [ Line
+                    { lineIndent = 0
+                    , tokens = Token "EmptyEntity" :| []
+                    }
+                ]
+            barLines =
+                [ Line
+                    { lineIndent = 0
+                    , tokens = Token "Bar" :| []
+                    }
+                , Line
+                    { lineIndent = 4
+                    , tokens = Token "name" :| [Token "String"]
+                    }
+                ]
+            bazLines =
+                [ Line
+                    { lineIndent = 0
+                    , tokens = Token "Baz" :| []
+                    }
+                , Line
+                    { lineIndent = 4
+                    , tokens = Token "a" :| [Token "Int"]
+                    }
+                , Line
+                    { lineIndent = 4
+                    , tokens = Token "b" :| [Token "String"]
+                    }
+                , Line
+                    { lineIndent = 4
+                    , tokens = Token "c" :| [Token "FooId"]
+                    }
+                ]
+
+        let
+            linesAssociated =
+                case preparsed of
+                    Nothing -> error "preparsed failed"
+                    Just lines -> associateLines lines
+        it "associateLines works" $ do
+            linesAssociated `shouldMatchList`
+                [ LinesWithComments
+                    { lwcLines = NEL.fromList fooLines
+                    , lwcComments = []
+                    }
+                , LinesWithComments (NEL.fromList emptyLines) []
+                , LinesWithComments (NEL.fromList barLines) []
+                , LinesWithComments (NEL.fromList bazLines) []
+                ]
+
+        it "parse works" $ do
+            let test name'fieldCount parsedList = do
+                    case (name'fieldCount, parsedList) of
+                        ([], []) ->
+                            pure ()
+                        ((name, fieldCount) : _, []) ->
+                            expectationFailure
+                                $ "Expected an entity with name "
+                                <> name
+                                <> " and " <> show fieldCount <> " fields"
+                                <> ", but the list was empty..."
+
+                        ((name, fieldCount) : ys, (x : xs)) -> do
+                            let
+                                UnboundEntityDef {..} =
+                                    x
+                            (unEntityNameHS (getUnboundEntityNameHS x), length unboundEntityFields)
+                                `shouldBe`
+                                    (T.pack name, fieldCount)
+                            test ys xs
+                        ([], _:_) ->
+                            expectationFailure
+                                "more entities parsed than expected"
+
+                result =
+                    parse lowerCaseSettings subject
+            length result `shouldBe` 4
+
+            test
+                [ ("Foo", 2)
+                , ("EmptyEntity", 0)
+                , ("Bar", 1)
+                , ("Baz", 3)
+                ]
+                result
+
+
+    describe "preparse" $ do
+        prop "omits lines that are only whitespace" $ \len -> do
+            ws <- vectorOf len arbitraryWhiteSpaceChar
+            pure $ preparse (T.pack ws) === Nothing
+
+        it "recognizes entity" $ do
+            let expected =
+                    Line { lineIndent = 0, tokens = pure (Token "Person") } :|
+                    [ Line { lineIndent = 2, tokens = Token "name" :| [Token "String"] }
+                    , Line { lineIndent = 2, tokens = Token "age" :| [Token "Int"] }
+                    ]
+            preparse "Person\n  name String\n  age Int" `shouldBe` Just expected
+
+        it "recognizes comments" $ do
+            let text = "Foo\n  x X\n-- | Hello\nBar\n name String"
+            let expected =
+                    Line { lineIndent = 0, tokens = pure (Token "Foo") } :|
+                    [ Line { lineIndent = 2, tokens = Token "x" :| [Token "X"] }
+                    , Line { lineIndent = 0, tokens = pure (DocComment "Hello") }
+                    , Line { lineIndent = 0, tokens = pure (Token "Bar") }
+                    , Line { lineIndent = 1, tokens = Token "name" :| [Token "String"] }
+                    ]
+            preparse text `shouldBe` Just expected
+
+        it "preparse indented" $ do
+            let t = T.unlines
+                    [ "  Foo"
+                    , "    x X"
+                    , "  -- | Comment"
+                    , "  -- hidden comment"
+                    , "  Bar"
+                    , "    name String"
+                    ]
+                expected =
+                    Line { lineIndent = 2, tokens = pure (Token "Foo") } :|
+                    [ Line { lineIndent = 4, tokens = Token "x" :| [Token "X"] }
+                    , Line { lineIndent = 2, tokens = pure (DocComment "Comment") }
+                    , Line { lineIndent = 2, tokens = pure (Token "Bar") }
+                    , Line { lineIndent = 4, tokens = Token "name" :| [Token "String"] }
+                    ]
+            preparse t `shouldBe` Just expected
+
+        it "preparse extra blocks" $ do
+            let t = T.unlines
+                    [ "LowerCaseTable"
+                    , "  name String"
+                    , "  ExtraBlock"
+                    , "    foo bar"
+                    , "    baz"
+                    , "  ExtraBlock2"
+                    , "    something"
+                    ]
+                expected =
+                    Line { lineIndent = 0, tokens = pure (Token "LowerCaseTable") } :|
+                    [ Line { lineIndent = 2, tokens = Token "name" :| [Token "String"] }
+                    , Line { lineIndent = 2, tokens = pure (Token "ExtraBlock") }
+                    , Line { lineIndent = 4, tokens = Token "foo" :| [Token "bar"] }
+                    , Line { lineIndent = 4, tokens = pure (Token "baz") }
+                    , Line { lineIndent = 2, tokens = pure (Token "ExtraBlock2") }
+                    , Line { lineIndent = 4, tokens = pure (Token "something") }
+                    ]
+            preparse t `shouldBe` Just expected
+
+        it "field comments" $ do
+            let text = T.unlines
+                    [ "-- | Model"
+                    , "Foo"
+                    , "  -- | Field"
+                    , "  name String"
+                    ]
+                expected =
+                    Line { lineIndent = 0, tokens = [DocComment "Model"] } :|
+                    [ Line { lineIndent = 0, tokens = [Token "Foo"] }
+                    , Line { lineIndent = 2, tokens = [DocComment "Field"] }
+                    , Line { lineIndent = 2, tokens = (Token <$> ["name", "String"]) }
+                    ]
+            preparse text `shouldBe` Just expected
+
+    describe "associateLines" $ do
+        let foo =
+                Line
+                    { lineIndent = 0
+                    , tokens = pure (Token "Foo")
+                    }
+            name'String =
+                Line
+                    { lineIndent = 2
+                    , tokens = Token "name" :| [Token "String"]
+                    }
+            comment =
+                Line
+                    { lineIndent = 0
+                    , tokens = pure (DocComment "comment")
+                    }
+        it "works" $ do
+            associateLines
+                ( comment :|
+                [ foo
+                , name'String
+                ])
+                `shouldBe`
+                    [ LinesWithComments
+                        { lwcComments = ["comment"]
+                        , lwcLines = foo :| [name'String]
+                        }
+                    ]
+        let bar =
+                Line
+                    { lineIndent = 0
+                    , tokens = Token "Bar" :| [Token "sql", Token "=", Token "bars"]
+                    }
+            age'Int =
+                Line
+                    { lineIndent = 1
+                    , tokens = Token "age" :| [Token "Int"]
+                    }
+        it "works when used consecutively" $ do
+            associateLines
+                ( bar :|
+                [ age'Int
+                , comment
+                , foo
+                , name'String
+                ])
+                `shouldBe`
+                    [ LinesWithComments
+                        { lwcComments = []
+                        , lwcLines = bar :| [age'Int]
+                        }
+                    , LinesWithComments
+                        { lwcComments = ["comment"]
+                        , lwcLines = foo :| [name'String]
+                        }
+                    ]
+        it "works with textual input" $ do
+            let text = preparse "Foo\n  x X\n-- | Hello\nBar\n name String"
+            associateLines <$> text
+                `shouldBe` Just
+                    [ LinesWithComments
+                        { lwcLines =
+                            Line {lineIndent = 0, tokens = Token "Foo" :| []}
+                            :| [ Line {lineIndent = 2, tokens = Token "x" :| [Token "X"]} ]
+                        , lwcComments =
+                            []
+                        }
+                    , LinesWithComments
+                        { lwcLines =
+                            Line {lineIndent = 0, tokens = Token "Bar" :| []}
+                            :| [ Line {lineIndent = 1, tokens = Token "name" :| [Token "String"]}]
+                        , lwcComments =
+                            ["Hello"]
+                        }
+                    ]
+        it "works with extra blocks" $ do
+            let text = preparse . T.unlines $
+                    [ "LowerCaseTable"
+                    , "    Id             sql=my_id"
+                    , "    fullName Text"
+                    , "    ExtraBlock"
+                    , "        foo bar"
+                    , "        baz"
+                    , "        bin"
+                    , "    ExtraBlock2"
+                    , "        something"
+                    ]
+            associateLines <$> text `shouldBe` Just
+                [ LinesWithComments
+                    { lwcLines =
+                        Line { lineIndent = 0, tokens = pure (Token "LowerCaseTable") } :|
+                        [ Line { lineIndent = 4, tokens = Token "Id" :| [Token "sql=my_id"] }
+                        , Line { lineIndent = 4, tokens = Token "fullName" :| [Token "Text"] }
+                        , Line { lineIndent = 4, tokens = pure (Token "ExtraBlock") }
+                        , Line { lineIndent = 8, tokens = Token "foo" :| [Token "bar"] }
+                        , Line { lineIndent = 8, tokens = pure (Token "baz") }
+                        , Line { lineIndent = 8, tokens = pure (Token "bin") }
+                        , Line { lineIndent = 4, tokens = pure (Token "ExtraBlock2") }
+                        , Line { lineIndent = 8, tokens = pure (Token "something") }
+                        ]
+                    , lwcComments = []
+                    }
+                ]
+
+        it "works with extra blocks twice" $ do
+            let text = preparse . T.unlines $
+                    [ "IdTable"
+                    , "    Id Day default=CURRENT_DATE"
+                    , "    name Text"
+                    , ""
+                    , "LowerCaseTable"
+                    , "    Id             sql=my_id"
+                    , "    fullName Text"
+                    , "    ExtraBlock"
+                    , "        foo bar"
+                    , "        baz"
+                    , "        bin"
+                    , "    ExtraBlock2"
+                    , "        something"
+                    ]
+            associateLines <$> text `shouldBe` Just
+                [ LinesWithComments
+                    { lwcLines = Line 0 (pure (Token "IdTable")) :|
+                        [ Line 4 (Token "Id" <| Token "Day" :| [Token "default=CURRENT_DATE"])
+                        , Line 4 (Token "name" :| [Token "Text"])
+                        ]
+                    , lwcComments = []
+                    }
+                , LinesWithComments
+                    { lwcLines =
+                        Line { lineIndent = 0, tokens = pure (Token "LowerCaseTable") } :|
+                        [ Line { lineIndent = 4, tokens = Token "Id" :| [Token "sql=my_id"] }
+                        , Line { lineIndent = 4, tokens = Token "fullName" :| [Token "Text"] }
+                        , Line { lineIndent = 4, tokens = pure (Token "ExtraBlock") }
+                        , Line { lineIndent = 8, tokens = Token "foo" :| [Token "bar"] }
+                        , Line { lineIndent = 8, tokens = pure (Token "baz") }
+                        , Line { lineIndent = 8, tokens = pure (Token "bin") }
+                        , Line { lineIndent = 4, tokens = pure (Token "ExtraBlock2") }
+                        , Line { lineIndent = 8, tokens = pure (Token "something") }
+                        ]
+                    , lwcComments = []
+                    }
+                ]
+
+
+        it "works with field comments" $ do
+            let text = preparse . T.unlines $
+                    [ "-- | Model"
+                    , "Foo"
+                    , "  -- | Field"
+                    , "  name String"
+                    ]
+            associateLines <$> text `shouldBe` Just
+                [ LinesWithComments
+                    { lwcLines =
+                        Line { lineIndent = 0, tokens = (Token "Foo") :| [] } :|
+                            [ Line { lineIndent = 2, tokens = pure (DocComment "Field") }
+                            , Line { lineIndent = 2, tokens = Token "name" :| [Token "String"] }
+                            ]
+                    , lwcComments =
+                        ["Model"]
+                    }
+                ]
+
+
+
+    describe "parseLines" $ do
+        let lines =
+                T.unlines
+                    [ "-- | Comment"
+                    , "Foo"
+                    , "  -- | Field"
+                    , "  name String"
+                    , "  age  Int"
+                    , "  Extra"
+                    , "    foo bar"
+                    , "    baz"
+                    , "  Extra2"
+                    , "    something"
+                    ]
+        let [subject] = parse lowerCaseSettings lines
+        it "produces the right name" $ do
+            getUnboundEntityNameHS subject `shouldBe` EntityNameHS "Foo"
+        describe "unboundEntityFields" $ do
+            let fields = unboundEntityFields subject
+            it "has the right field names" $ do
+                map unboundFieldNameHS fields `shouldMatchList`
+                    [ FieldNameHS "name"
+                    , FieldNameHS "age"
+                    ]
+            it "has comments" $ do
+                map unboundFieldComments fields `shouldBe`
+                    [ Just "Field\n"
+                    , Nothing
+                    ]
+        it "has the comments" $ do
+            entityComments (unboundEntityDef subject) `shouldBe`
+                Just "Comment\n"
+        it "combines extrablocks" $ do
+            entityExtra (unboundEntityDef subject) `shouldBe` Map.fromList
+                [ ("Extra", [["foo", "bar"], ["baz"]])
+                , ("Extra2", [["something"]])
+                ]
+        describe "works with extra blocks" $ do
+            let [_, lowerCaseTable, idTable] =
+                    case parse lowerCaseSettings $ T.unlines
+                        [ ""
+                        , "IdTable"
+                        , "    Id Day default=CURRENT_DATE"
+                        , "    name Text"
+                        , ""
+                        , "LowerCaseTable"
+                        , "    Id             sql=my_id"
+                        , "    fullName Text"
+                        , "    ExtraBlock"
+                        , "        foo bar"
+                        , "        baz"
+                        , "        bin"
+                        , "    ExtraBlock2"
+                        , "        something"
+                        , ""
+                        , "IdTable"
+                        , "    Id Day default=CURRENT_DATE"
+                        , "    name Text"
+                        , ""
+                        ] of
+                            [a, b, c] ->
+                                [a, b, c] :: [UnboundEntityDef]
+                            xs ->
+                                error
+                                $ "Expected 3 elements in list, got: "
+                                <> show (length xs)
+                                <> ", list contents: \n\n" <> intercalate "\n" (map show xs)
+            describe "idTable" $ do
+                let UnboundEntityDef { unboundEntityDef = EntityDef {..}, .. } = idTable
+                it "has no extra blocks" $ do
+                    entityExtra `shouldBe` mempty
+                it "has the right name" $ do
+                    entityHaskell `shouldBe` EntityNameHS "IdTable"
+                it "has the right fields" $ do
+                    map unboundFieldNameHS unboundEntityFields `shouldMatchList`
+                        [ FieldNameHS "name"
+                        ]
+            describe "lowerCaseTable" $ do
+                let UnboundEntityDef { unboundEntityDef = EntityDef {..}, ..} = lowerCaseTable
+                it "has the right name" $ do
+                    entityHaskell `shouldBe` EntityNameHS "LowerCaseTable"
+                it "has the right fields" $ do
+                    map unboundFieldNameHS unboundEntityFields `shouldMatchList`
+                        [ FieldNameHS "fullName"
+                        ]
+                it "has ExtraBlock" $ do
+                    Map.lookup "ExtraBlock" entityExtra
+                        `shouldBe` Just
+                            [ ["foo", "bar"]
+                            , ["baz"]
+                            , ["bin"]
+                            ]
+                it "has ExtraBlock2" $ do
+                    Map.lookup "ExtraBlock2" entityExtra
+                        `shouldBe` Just
+                            [ ["something"]
+                            ]
+
+arbitraryWhiteSpaceChar :: Gen Char
+arbitraryWhiteSpaceChar =
+  oneof $ pure <$> [' ', '\t', '\n', '\r']
diff --git a/persistent/test/Database/Persist/TH/EmbedSpec.hs b/persistent/test/Database/Persist/TH/EmbedSpec.hs
index 0411157ad..7b9b6dcaf 100644
--- a/persistent/test/Database/Persist/TH/EmbedSpec.hs
+++ b/persistent/test/Database/Persist/TH/EmbedSpec.hs
@@ -17,6 +17,8 @@ module Database.Persist.TH.EmbedSpec where
 import TemplateTestImports
 
 import Data.Text (Text)
+import qualified Data.Map as M
+import qualified Data.Text as T
 
 import Database.Persist.ImplicitIdDef
 import Database.Persist.ImplicitIdDef.Internal (fieldTypeFromTypeable)
@@ -49,6 +51,17 @@ MutualEmbed
 MutualTarget
     thing [MutualEmbed]
 
+ModelWithList
+    names [Text]
+
+HasMap
+    map (M.Map T.Text T.Text)
+    deriving Show Eq Read Ord
+
+MapIdValue
+    map (M.Map T.Text (Key Thing))
+    deriving Show Eq Read Ord
+
 |]
 
 pass :: IO ()
@@ -59,6 +72,62 @@ asIO = id
 
 spec :: Spec
 spec = describe "EmbedSpec" $ do
+    describe "ModelWithList" $ do
+        let
+            edef =
+                entityDef $ Proxy @ModelWithList
+            [fieldDef] =
+                getEntityFields edef
+        it "has the right type" $ do
+            fieldType fieldDef
+                `shouldBe`
+                    FTList (FTTypeCon Nothing "Text")
+        it "has the right sqltype" $ do
+            fieldSqlType fieldDef
+                `shouldBe`
+                    SqlString
+    describe "MapIdValue" $ do
+        let
+            edef =
+                entityDef $ Proxy @MapIdValue
+            [fieldDef] =
+                getEntityFields edef
+        it "has the right type" $ do
+            fieldType fieldDef
+                `shouldBe`
+                    ( FTTypeCon (Just "M") "Map"
+                        `FTApp`
+                        FTTypeCon (Just "T") "Text"
+                        `FTApp`
+                        (FTTypeCon Nothing "Key"
+                            `FTApp`
+                            FTTypeCon Nothing "Thing"
+                        )
+                    )
+        it "has the right sqltype" $ do
+            fieldSqlType fieldDef
+                `shouldBe`
+                    SqlString
+    describe "HasMap" $ do
+        let
+            edef =
+                entityDef $ Proxy @HasMap
+            [fieldDef] =
+                getEntityFields edef
+        it "has the right type" $ do
+            fieldType fieldDef
+                `shouldBe`
+                    ( FTTypeCon (Just "M") "Map"
+                    `FTApp`
+                    FTTypeCon (Just "T") "Text"
+                    `FTApp`
+                    FTTypeCon (Just "T") "Text"
+                    )
+        it "has the right sqltype" $ do
+            fieldSqlType fieldDef
+                `shouldBe`
+                    SqlString
+
     describe "SomeThing" $ do
         let
             edef =
@@ -88,7 +157,7 @@ spec = describe "EmbedSpec" $ do
             it "has self reference" $ do
                 fieldReference selfField
                     `shouldBe`
-                        SelfReference
+                        NoReference
         describe "toEmbedEntityDef" $ do
             let
                 embedDef =
diff --git a/persistent/test/Database/Persist/TH/ForeignRefSpec.hs b/persistent/test/Database/Persist/TH/ForeignRefSpec.hs
new file mode 100644
index 000000000..b4e694e57
--- /dev/null
+++ b/persistent/test/Database/Persist/TH/ForeignRefSpec.hs
@@ -0,0 +1,178 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+--
+-- DeriveAnyClass is not actually used by persistent-template
+-- But a long standing bug was that if it was enabled, it was used to derive instead of GeneralizedNewtypeDeriving
+-- This was fixed by using DerivingStrategies to specify newtype deriving should be used.
+-- This pragma is left here as a "test" that deriving works when DeriveAnyClass is enabled.
+-- See https://github.com/yesodweb/persistent/issues/578
+{-# LANGUAGE DeriveAnyClass #-}
+
+module Database.Persist.TH.ForeignRefSpec where
+
+import Control.Applicative (Const(..))
+import Data.Aeson
+import Data.ByteString.Lazy.Char8 ()
+import Data.Coerce
+import Data.Functor.Identity (Identity(..))
+import Data.Int
+import qualified Data.List as List
+import Data.Proxy
+import Data.Text (Text, pack)
+import GHC.Generics (Generic)
+import Test.Hspec
+import Test.Hspec.QuickCheck
+import Test.QuickCheck.Arbitrary
+import Test.QuickCheck.Gen (Gen)
+
+import Database.Persist
+import Database.Persist.EntityDef.Internal
+import Database.Persist.Sql
+import Database.Persist.Sql.Util
+import Database.Persist.TH
+import TemplateTestImports
+
+mkPersist sqlSettings [persistLowerCase|
+
+HasCustomName sql=custom_name
+    name Text
+
+ForeignTarget
+    name Text
+    deriving Eq Show
+
+ForeignSource
+    name Text
+    foreignTargetId ForeignTargetId
+    Foreign ForeignTarget fk_s_t foreignTargetId
+
+ForeignPrimary
+    name Text
+    Primary name
+    deriving Eq Show
+
+ForeignPrimarySource
+    name Text
+    Foreign ForeignPrimary fk_name_target name
+
+NullableRef
+    name Text Maybe
+    Foreign ForeignPrimary fk_nullable_ref name
+
+ParentImplicit
+    name Text
+
+ChildImplicit
+    name Text
+    parent ParentImplicitId OnDeleteCascade OnUpdateCascade
+
+ParentExplicit
+    name Text
+    Primary name
+
+ChildExplicit
+    name Text
+    Foreign ParentExplicit OnDeleteCascade OnUpdateCascade fkparent name
+|]
+
+spec :: Spec
+spec = describe "ForeignRefSpec" $ do
+    describe "HasCustomName" $ do
+        let
+            edef =
+                entityDef $ Proxy @HasCustomName
+        it "should have a custom db name" $ do
+            entityDB edef
+                `shouldBe`
+                    EntityNameDB "custom_name"
+
+    it "should compile" $ do
+        True `shouldBe` True
+
+    describe "ForeignPrimarySource" $ do
+        let
+            fpsDef =
+                entityDef $ Proxy @ForeignPrimarySource
+            [foreignDef] =
+                entityForeigns fpsDef
+        it "has the right type" $ do
+            foreignPrimarySourceFk_name_target (ForeignPrimarySource "asdf")
+                `shouldBe`
+                    ForeignPrimaryKey "asdf"
+
+    describe "Cascade" $ do
+        describe "Explicit" $ do
+            let
+                parentDef =
+                    entityDef $ Proxy @ParentExplicit
+                childDef =
+                    entityDef $ Proxy @ChildExplicit
+                childForeigns =
+                    entityForeigns childDef
+            it "should have a single foreign reference defined" $ do
+                    case entityForeigns childDef of
+                        [a] ->
+                            pure ()
+                        as ->
+                            expectationFailure . mconcat $
+                                [ "Expected one foreign reference on childDef, "
+                                , "got: "
+                                , show as
+                                ]
+            let
+                [ForeignDef {..}] =
+                    childForeigns
+
+            describe "ChildExplicit" $ do
+                it "should have the right target table" $ do
+                    foreignRefTableHaskell `shouldBe`
+                        EntityNameHS "ParentExplicit"
+                    foreignRefTableDBName `shouldBe`
+                        EntityNameDB "parent_explicit"
+                it "should have the right cascade behavior" $ do
+                    foreignFieldCascade
+                        `shouldBe`
+                            FieldCascade
+                                { fcOnUpdate =
+                                    Just Cascade
+                                , fcOnDelete =
+                                    Just Cascade
+                                }
+                it "is not nullable" $ do
+                    foreignNullable `shouldBe` False
+                it "is to the Primary key" $ do
+                    foreignToPrimary `shouldBe` True
+
+        describe "Implicit" $ do
+            let
+                parentDef =
+                    entityDef $ Proxy @ParentImplicit
+                childDef =
+                    entityDef $ Proxy @ChildImplicit
+                childFields =
+                    entityFields childDef
+            describe "ChildImplicit" $ do
+                case childFields of
+                    [nameField, parentIdField] -> do
+                        it "parentId has reference" $ do
+                            fieldReference parentIdField `shouldBe`
+                                ForeignRef (EntityNameHS "ParentImplicit")
+                    as ->
+                        error . mconcat $
+                            [ "Expected one foreign reference on childDef, "
+                            , "got: "
+                            , show as
+                            ]
diff --git a/persistent/test/Database/Persist/TH/ImplicitIdColSpec.hs b/persistent/test/Database/Persist/TH/ImplicitIdColSpec.hs
index 2909f6693..f1072a34e 100644
--- a/persistent/test/Database/Persist/TH/ImplicitIdColSpec.hs
+++ b/persistent/test/Database/Persist/TH/ImplicitIdColSpec.hs
@@ -46,12 +46,19 @@ spec :: Spec
 spec = describe "ImplicitIdColSpec" $ do
     describe "UserKey" $ do
         it "has type Text -> Key User" $ do
-            let userKey = UserKey "Hello"
+            let
+                userKey = UserKey "Hello"
+                _ = UserKey :: Text -> UserId
             pass
 
     describe "getEntityId" $ do
-        let idField = getEntityId (entityDef (Nothing @User))
+        let
+            EntityIdField idField =
+                getEntityId (entityDef (Nothing @User))
         it "has SqlString SqlType" $ asIO $ do
             fieldSqlType idField `shouldBe` SqlString
         it "has Text FieldType" $ asIO $ do
-            fieldType idField `shouldBe` fieldTypeFromTypeable @Text
+            pendingWith "currently returns UserId, may not be an issue"
+            fieldType idField
+                `shouldBe`
+                    fieldTypeFromTypeable @Text
diff --git a/persistent/test/Database/Persist/TH/JsonEncodingSpec.hs b/persistent/test/Database/Persist/TH/JsonEncodingSpec.hs
new file mode 100644
index 000000000..cbc8779d3
--- /dev/null
+++ b/persistent/test/Database/Persist/TH/JsonEncodingSpec.hs
@@ -0,0 +1,128 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Database.Persist.TH.JsonEncodingSpec where
+
+import TemplateTestImports
+
+import Data.Aeson
+import qualified Data.HashMap.Lazy as M
+import Data.Text (Text)
+import Test.QuickCheck.Instances ()
+import Test.Hspec.QuickCheck
+import Test.QuickCheck
+
+import Database.Persist.EntityDef
+import Database.Persist.ImplicitIdDef
+import Database.Persist.ImplicitIdDef.Internal (fieldTypeFromTypeable)
+import Database.Persist.Types
+
+mkPersist sqlSettings [persistLowerCase|
+JsonEncoding json
+    name Text
+    age  Int
+    Primary name
+    deriving Show Eq
+
+JsonEncoding2 json
+    name Text
+    age Int
+    blood Text
+    Primary name blood
+    deriving Show Eq
+|]
+
+instance Arbitrary JsonEncoding where
+    arbitrary = JsonEncoding <$> arbitrary <*> arbitrary
+
+instance Arbitrary JsonEncoding2 where
+    arbitrary = JsonEncoding2 <$> arbitrary <*> arbitrary <*> arbitrary
+
+pass :: IO ()
+pass = pure ()
+
+asIO :: IO a -> IO a
+asIO = id
+
+spec :: Spec
+spec = describe "JsonEncodingSpec" $ do
+    let
+        subject =
+            JsonEncoding "Bob" 32
+        subjectEntity =
+            Entity (JsonEncodingKey (jsonEncodingName subject)) subject
+
+    it "encodes without an ID field" $ do
+        toJSON subjectEntity
+            `shouldBe`
+                Object (M.fromList
+                    [ ("name", String "Bob")
+                    , ("age", toJSON (32 :: Int))
+                    , ("id", String "Bob")
+                    ])
+
+    it "decodes without an ID field" $ do
+        let
+            json_ = encode . Object . M.fromList $
+                [ ("name", String "Bob")
+                , ("age", toJSON (32 :: Int))
+                ]
+        eitherDecode json_
+            `shouldBe`
+                Right subjectEntity
+
+    prop "works with a Primary" $ \jsonEncoding -> do
+        let
+            ent =
+                Entity (JsonEncodingKey (jsonEncodingName jsonEncoding)) jsonEncoding
+        decode (encode ent)
+            `shouldBe`
+                Just ent
+
+    prop "excuse me what" $ \j@JsonEncoding{..} -> do
+        let
+            ent =
+                Entity (JsonEncodingKey jsonEncodingName) j
+        toJSON ent
+            `shouldBe`
+                Object (M.fromList
+                    [ ("name", toJSON jsonEncodingName)
+                    , ("age", toJSON jsonEncodingAge)
+                    , ("id", toJSON jsonEncodingName)
+                    ])
+
+    prop "round trip works with composite key" $ \j@JsonEncoding2{..} -> do
+        let
+            key = JsonEncoding2Key jsonEncoding2Name jsonEncoding2Blood
+            ent =
+              Entity key j
+        decode (encode ent)
+            `shouldBe`
+                Just ent
+
+    prop "works with a composite key" $ \j@JsonEncoding2{..} -> do
+        let
+            key = JsonEncoding2Key jsonEncoding2Name jsonEncoding2Blood
+            ent =
+                Entity key j
+        toJSON ent
+            `shouldBe`
+                Object (M.fromList
+                  [ ("name", toJSON jsonEncoding2Name)
+                  , ("age", toJSON jsonEncoding2Age)
+                  , ("blood", toJSON jsonEncoding2Blood)
+                  , ("id", toJSON key)
+                  ])
diff --git a/persistent/test/Database/Persist/TH/MultiBlockSpec.hs b/persistent/test/Database/Persist/TH/MultiBlockSpec.hs
index 2b349f913..ba7207039 100644
--- a/persistent/test/Database/Persist/TH/MultiBlockSpec.hs
+++ b/persistent/test/Database/Persist/TH/MultiBlockSpec.hs
@@ -22,7 +22,7 @@ import TemplateTestImports
 import Database.Persist.TH.MultiBlockSpec.Model
 
 share
-    [ mkPersist sqlSettings . mappend importDefList
+    [ mkPersistWith sqlSettings importDefList
     ]
     [persistLowerCase|
 
@@ -41,8 +41,7 @@ MBBar
     thingAuto ThingAutoId
     profile MBDogId
 
-    -- TODO: make the QQ not care about this table being missing
-    -- Foreign MBCompositePrimary bar_to_comp name age
+    Foreign MBCompositePrimary bar_to_comp name age
 |]
 
 spec :: Spec
@@ -60,25 +59,21 @@ spec = describe "MultiBlockSpec" $ do
                     `shouldBe`
                         ForeignRef
                             (EntityNameHS "User")
-                            (FTTypeCon (Just "Data.Int") "Int64")
 
             it "Primary key reference works" $ do
                 fieldReference profileRef
                     `shouldBe`
                         ForeignRef
                             (EntityNameHS "MBDog")
-                            (FTTypeCon (Just "Data.Int") "Int64")
 
             it "Thing ref works (same block)" $ do
                 fieldReference thingRef
                     `shouldBe`
                         ForeignRef
                             (EntityNameHS "Thing")
-                            (FTTypeCon (Just "Data.Int") "Int64")
 
             it "ThingAuto ref works (same block)" $ do
                 fieldReference thingAutoRef
                     `shouldBe`
                         ForeignRef
                             (EntityNameHS "ThingAuto")
-                            (FTTypeCon (Just "Data.Int") "Int64")
diff --git a/persistent/test/Database/Persist/TH/SharedPrimaryKeyImportedSpec.hs b/persistent/test/Database/Persist/TH/SharedPrimaryKeyImportedSpec.hs
index e3aa2e7eb..071069614 100644
--- a/persistent/test/Database/Persist/TH/SharedPrimaryKeyImportedSpec.hs
+++ b/persistent/test/Database/Persist/TH/SharedPrimaryKeyImportedSpec.hs
@@ -46,9 +46,14 @@ spec = describe "Shared Primary Keys Imported" $ do
 
     describe "getEntityId FieldDef" $ do
         it "should match underlying primary key" $ do
-            let getSqlType :: PersistEntity a => Proxy a -> SqlType
-                getSqlType =
-                    fieldSqlType . getEntityId . entityDef
+            let
+                getSqlType :: PersistEntity a => Proxy a -> SqlType
+                getSqlType p =
+                    case getEntityId (entityDef p) of
+                        EntityIdField fd ->
+                            fieldSqlType fd
+                        _ ->
+                            SqlOther "Composite Key"
             getSqlType (Proxy @User)
                 `shouldBe`
                     getSqlType (Proxy @Profile)
diff --git a/persistent/test/Database/Persist/TH/SharedPrimaryKeySpec.hs b/persistent/test/Database/Persist/TH/SharedPrimaryKeySpec.hs
index c65e7e199..128bcd7d7 100644
--- a/persistent/test/Database/Persist/TH/SharedPrimaryKeySpec.hs
+++ b/persistent/test/Database/Persist/TH/SharedPrimaryKeySpec.hs
@@ -15,9 +15,11 @@ module Database.Persist.TH.SharedPrimaryKeySpec where
 
 import TemplateTestImports
 
+import Data.Time
 import Data.Proxy
 import Test.Hspec
 import Database.Persist
+import Database.Persist.EntityDef
 import Database.Persist.Sql
 import Database.Persist.Sql.Util
 import Database.Persist.TH
@@ -27,31 +29,127 @@ share [ mkPersist sqlSettings ] [persistLowerCase|
 User
     name    String
 
--- TODO: uncomment this out https://github.com/yesodweb/persistent/issues/1149
--- Profile
---     Id      UserId
---     email   String
-
 Profile
+    Id      UserId
+    email   String
+
+Profile2
     Id      (Key User)
     email   String
 
+DayKeyTable
+    Id Day
+    name Text
+
+RefDayKey
+    dayKey DayKeyTableId
+
 |]
 
 spec :: Spec
 spec = describe "Shared Primary Keys" $ do
+    let
+        getSqlType :: PersistEntity a => Proxy a -> SqlType
+        getSqlType p =
+            case getEntityId (entityDef p) of
+                EntityIdField fd ->
+                    fieldSqlType fd
+                _ ->
+                    SqlOther "Composite Key"
+
+        keyProxy :: Proxy a -> Proxy (Key a)
+        keyProxy _ = Proxy
+
+        sqlTypeEquivalent
+            :: (PersistFieldSql (Key a), PersistEntity a)
+            => Proxy a
+            -> Expectation
+        sqlTypeEquivalent proxy =
+            sqlType (keyProxy proxy) `shouldBe` getSqlType proxy
 
+        testSqlTypeEquivalent
+            :: (PersistFieldSql (Key a), PersistEntity a)
+            => Proxy a
+            -> Spec
+        testSqlTypeEquivalent prxy =
+            it "has equivalent SqlType from sqlType and entityId" $
+                sqlTypeEquivalent prxy
     describe "PersistFieldSql" $ do
         it "should match underlying key" $ do
             sqlType (Proxy @UserId)
                 `shouldBe`
                     sqlType (Proxy @ProfileId)
 
+    describe "User" $ do
+        it "has default ID key, SqlInt64" $ do
+            sqlType (Proxy @UserId)
+                `shouldBe`
+                    SqlInt64
+
+        testSqlTypeEquivalent (Proxy @User)
+
+    describe "Profile"  $ do
+        it "has same ID key type as User" $ do
+            sqlType (Proxy @ProfileId)
+                `shouldBe`
+                    sqlType (Proxy @UserId)
+        testSqlTypeEquivalent(Proxy @Profile)
+
+    describe "Profile2" $ do
+        it "has same ID key type as User" $ do
+            sqlType (Proxy @Profile2Id)
+                `shouldBe`
+                    sqlType (Proxy @UserId)
+        testSqlTypeEquivalent (Proxy @Profile2)
+
     describe "getEntityId FieldDef" $ do
         it "should match underlying primary key" $ do
-            let getSqlType :: PersistEntity a => Proxy a -> SqlType
-                getSqlType =
-                    fieldSqlType . getEntityId . entityDef
             getSqlType (Proxy @User)
                 `shouldBe`
                     getSqlType (Proxy @Profile)
+
+    describe "DayKeyTable" $ do
+        testSqlTypeEquivalent (Proxy @DayKeyTable)
+
+        it "sqlType has Day type" $ do
+            sqlType (Proxy @Day)
+                `shouldBe`
+                    sqlType (Proxy @DayKeyTableId)
+
+        it "getSqlType has Day type" $ do
+            sqlType (Proxy @Day)
+                `shouldBe`
+                    getSqlType (Proxy @DayKeyTable)
+
+    describe "RefDayKey" $ do
+        let
+            [dayKeyField] =
+                getEntityFields (entityDef (Proxy @RefDayKey))
+        testSqlTypeEquivalent (Proxy @RefDayKey)
+
+        it "has same sqltype as underlying" $ do
+            fieldSqlType dayKeyField
+                `shouldBe`
+                    sqlType (Proxy @Day)
+
+        it "has the right fieldType" $ do
+            fieldType dayKeyField
+                `shouldBe`
+                    FTTypeCon Nothing "DayKeyTableId"
+
+        it "has the right type" $ do
+            let
+                _ =
+                    refDayKeyDayKey
+                        :: RefDayKey -> DayKeyTableId
+                _ =
+                    RefDayKeyDayKey
+                        :: EntityField RefDayKey DayKeyTableId
+            True `shouldBe` True
+
+        it "has a foreign ref" $ do
+            case fieldReference dayKeyField of
+                ForeignRef refName -> do
+                    refName `shouldBe` EntityNameHS "DayKeyTable"
+                other ->
+                    fail $ "expected foreign ref, got: " <> show other
diff --git a/persistent/test/Database/Persist/TH/ToFromPersistValuesSpec.hs b/persistent/test/Database/Persist/TH/ToFromPersistValuesSpec.hs
new file mode 100644
index 000000000..c632d47ea
--- /dev/null
+++ b/persistent/test/Database/Persist/TH/ToFromPersistValuesSpec.hs
@@ -0,0 +1,274 @@
+{-# LANGUAGE DataKinds, ScopedTypeVariables #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+--
+-- DeriveAnyClass is not actually used by persistent-template
+-- But a long standing bug was that if it was enabled, it was used to derive instead of GeneralizedNewtypeDeriving
+-- This was fixed by using DerivingStrategies to specify newtype deriving should be used.
+-- This pragma is left here as a "test" that deriving works when DeriveAnyClass is enabled.
+-- See https://github.com/yesodweb/persistent/issues/578
+{-# LANGUAGE DeriveAnyClass #-}
+
+module Database.Persist.TH.ToFromPersistValuesSpec where
+
+import TemplateTestImports
+
+import Database.Persist.Sql.Util
+import Database.Persist.Class.PersistEntity
+import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.List.NonEmpty as NEL
+
+instance PersistFieldSql a => PersistFieldSql (NonEmpty a) where
+    sqlType _ = SqlString
+
+instance PersistField a => PersistField (NonEmpty a) where
+    toPersistValue = toPersistValue . NEL.toList
+    fromPersistValue pv = do
+        xs <- fromPersistValue pv
+        case xs of
+            [] -> Left "PersistField: NonEmpty found unexpected Empty List"
+            (l:ls) -> Right (l:|ls)
+
+mkPersist sqlSettings [persistLowerCase|
+
+NormalModel
+    name Text
+    age  Int
+    deriving Eq Show
+
+PrimaryModel
+    name Text
+    age Int
+    Primary name age
+    deriving Eq Show
+
+IsMigrationOnly
+    name Text
+    age Int
+    blargh Int MigrationOnly
+    deriving Eq Show
+
+HasListField
+    names [Text]
+    deriving Eq Show
+
+HasNonEmptyListField
+    names (NonEmpty Text)
+    deriving Eq Show
+
+HasNonEmptyListKeyField
+    names (NonEmpty (Key NormalModel))
+    deriving Eq Show
+|]
+
+spec :: Spec
+spec = describe "{to,from}PersistValues" $ do
+    let
+        toPersistValues
+            :: PersistEntity rec => rec -> [PersistValue]
+        toPersistValues =
+            map toPersistValue . toPersistFields
+
+        subject
+            :: (PersistEntity rec, Show rec, Eq rec)
+            => rec
+            -> [PersistValue]
+            -> Spec
+        subject model fields = do
+            it "toPersistValues" $ do
+                toPersistValues model
+                    `shouldBe`
+                        fields
+            it "fromPersistValues" $ do
+                fromPersistValues fields
+                    `shouldBe`
+                        Right model
+    describe "NormalModel" $ do
+        subject
+            (NormalModel "hello" 30)
+            [ PersistText "hello"
+            , PersistInt64 30
+            ]
+
+    describe "PrimaryModel" $ do
+        subject
+            (PrimaryModel "hello" 30)
+            [ PersistText "hello"
+            , PersistInt64 30
+            ]
+
+    describe "IsMigrationOnly" $ do
+        subject
+            (IsMigrationOnly "hello" 30)
+            [ PersistText "hello"
+            , PersistInt64 30
+            ]
+
+    describe "mkInsertValues" $ do
+        describe "NormalModel" $ do
+            it "has all values" $ do
+                mkInsertValues (NormalModel "hello" 30)
+                    `shouldBe`
+                        [ PersistText "hello"
+                        , PersistInt64 30
+                        ]
+        describe "PrimaryModel" $ do
+            it "has all values" $ do
+                mkInsertValues (PrimaryModel "hello" 30)
+                    `shouldBe`
+                        [ PersistText "hello"
+                        , PersistInt64 30
+                        ]
+        describe "IsMigrationOnly" $ do
+            it "has all values" $ do
+                mkInsertValues (IsMigrationOnly "hello" 30)
+                    `shouldBe`
+                        [ PersistText "hello"
+                        , PersistInt64 30
+                        ]
+    describe "parseEntityValues" $ do
+        let
+            subject
+                :: forall rec. (PersistEntity rec, Show rec, Eq rec)
+                => [PersistValue]
+                -> Entity rec
+                -> Spec
+            subject pvs rec =
+                it "parses" $ do
+                    parseEntityValues (entityDef (Proxy @rec)) pvs
+                        `shouldBe`
+                            Right rec
+        describe "NormalModel" $ do
+            subject
+                [ PersistInt64 20
+                , PersistText "hello"
+                , PersistInt64 30
+                ]
+                Entity
+                    { entityKey =
+                        NormalModelKey 20
+                    , entityVal =
+                        NormalModel "hello" 30
+                    }
+        describe "PrimaryModel" $ do
+            subject
+                [ PersistText "hey"
+                , PersistInt64 30
+                ]
+                Entity
+                    { entityKey =
+                        PrimaryModelKey "hey" 30
+                    , entityVal =
+                        PrimaryModel "hey" 30
+                    }
+        describe "IsMigrationOnly" $ do
+            subject
+                [ PersistInt64 20
+                , PersistText "hello"
+                , PersistInt64 30
+                ]
+                Entity
+                    { entityKey =
+                        IsMigrationOnlyKey 20
+                    , entityVal =
+                        IsMigrationOnly "hello" 30
+                    }
+    describe "entityValues" $ do
+        let
+            subject
+                :: forall rec. (PersistEntity rec, Show rec, Eq rec)
+                => [PersistValue]
+                -> Entity rec
+                -> Spec
+            subject pvals entity = do
+                it "renders as you would expect"$ do
+                    entityValues entity
+                        `shouldBe`
+                            pvals
+                it "round trips with parseEntityValues" $ do
+                    parseEntityValues
+                        (entityDef $ Proxy @rec)
+                        (entityValues entity)
+                        `shouldBe`
+                            Right entity
+        describe "NormalModel" $ do
+            subject
+                [ PersistInt64 10
+                , PersistText "hello"
+                , PersistInt64 20
+                ]
+                Entity
+                    { entityKey =
+                        NormalModelKey 10
+                    , entityVal =
+                        NormalModel "hello" 20
+                    }
+        describe "PrimaryModel" $ do
+            subject
+                [ PersistText "hello"
+                , PersistInt64 20
+                ]
+                Entity
+                    { entityKey =
+                        PrimaryModelKey "hello" 20
+                    , entityVal =
+                        PrimaryModel "hello" 20
+                    }
+        describe "IsMigrationOnly" $ do
+            subject
+                [ PersistInt64 20
+                , PersistText "hello"
+                , PersistInt64 20
+                ]
+                Entity
+                    { entityKey =
+                        IsMigrationOnlyKey 20
+                    , entityVal =
+                        IsMigrationOnly "hello" 20
+                    }
+
+        describe "HasListField" $ do
+            subject
+                [ PersistInt64 10
+                , PersistList [PersistText "hello"]
+                ]
+                Entity
+                    { entityKey =
+                        HasListFieldKey 10
+                    , entityVal =
+                        HasListField ["hello"]
+                    }
+        describe "HasNonEmptyListField" $ do
+            subject
+                [ PersistInt64 10
+                , PersistList [PersistText "hello"]
+                ]
+                Entity
+                    { entityKey =
+                        HasNonEmptyListFieldKey 10
+                    , entityVal =
+                        HasNonEmptyListField (pure "hello")
+                    }
+        describe "HasNonEmptyListKeyField" $ do
+            subject
+                [ PersistInt64 5
+                , PersistList [PersistInt64 4]
+                ]
+                Entity
+                    { entityKey =
+                        HasNonEmptyListKeyFieldKey 5
+                    , entityVal =
+                        HasNonEmptyListKeyField (pure (NormalModelKey 4))
+                    }
diff --git a/persistent/test/Database/Persist/THSpec.hs b/persistent/test/Database/Persist/THSpec.hs
index 592fbcc82..de6a6b785 100644
--- a/persistent/test/Database/Persist/THSpec.hs
+++ b/persistent/test/Database/Persist/THSpec.hs
@@ -45,7 +45,9 @@ import Database.Persist.Sql.Util
 import Database.Persist.TH
 import TemplateTestImports
 
-
+import qualified Database.Persist.TH.ToFromPersistValuesSpec as ToFromPersistValuesSpec
+import qualified Database.Persist.TH.ForeignRefSpec as ForeignRefSpec
+import qualified Database.Persist.TH.JsonEncodingSpec as JsonEncodingSpec
 import qualified Database.Persist.TH.MultiBlockSpec as MultiBlockSpec
 import qualified Database.Persist.TH.DiscoverEntitiesSpec as DiscoverEntitiesSpec
 import qualified Database.Persist.TH.ImplicitIdColSpec as ImplicitIdColSpec
@@ -55,7 +57,11 @@ import qualified Database.Persist.TH.OverloadedLabelSpec as OverloadedLabelSpec
 import qualified Database.Persist.TH.SharedPrimaryKeyImportedSpec as SharedPrimaryKeyImportedSpec
 import qualified Database.Persist.TH.SharedPrimaryKeySpec as SharedPrimaryKeySpec
 
-share [mkPersist sqlSettings { mpsGeneric = False, mpsDeriveInstances = [''Generic] }, mkDeleteCascade sqlSettings { mpsGeneric = False }] [persistUpperCase|
+-- test to ensure we can have types ending in Id that don't trash the TH
+-- machinery
+type TextId = Text
+
+share [mkPersist sqlSettings { mpsGeneric = False, mpsDeriveInstances = [''Generic] }] [persistUpperCase|
 
 Person json
     name Text
@@ -105,7 +111,7 @@ HasCustomSqlId
     name String
 
 SharedPrimaryKey
-    Id (Key HasDefaultId)
+    Id HasDefaultIdId
     name String
 
 SharedPrimaryKeyWithCascade
@@ -116,6 +122,21 @@ SharedPrimaryKeyWithCascadeAndCustomName
     Id (Key HasDefaultId) OnDeleteCascade sql=my_id
     name String
 
+Top
+    name Text
+
+Middle
+    top TopId
+    Primary top
+
+Bottom
+    middle MiddleId
+    Primary middle
+
+-- Test that a field can be named Key
+KeyTable
+    key Text
+
 |]
 
 share [mkPersist sqlSettings { mpsGeneric = False, mpsGenerateLenses = True }] [persistLowerCase|
@@ -153,8 +174,11 @@ spec = describe "THSpec" $ do
     EmbedSpec.spec
     DiscoverEntitiesSpec.spec
     MultiBlockSpec.spec
+    ForeignRefSpec.spec
+    ToFromPersistValuesSpec.spec
+    JsonEncodingSpec.spec
     describe "TestDefaultKeyCol" $ do
-        let FieldDef{..} =
+        let EntityIdField FieldDef{..} =
                 entityId (entityDef (Proxy @TestDefaultKeyCol))
         it "should be a BackendKey SqlBackend" $ do
             -- the purpose of this test is to verify that a custom Id column of
@@ -163,11 +187,11 @@ spec = describe "THSpec" $ do
             -- >     Id ModelNameId
             --
             -- should behave like an implicit id column.
-            TestDefaultKeyColKey (SqlBackendKey 32)
+            (TestDefaultKeyColKey (SqlBackendKey 32) :: Key TestDefaultKeyCol)
                 `shouldBe`
-                    toSqlKey 32
+                    (toSqlKey 32 :: Key TestDefaultKeyCol)
     describe "HasDefaultId" $ do
-        let FieldDef{..} =
+        let EntityIdField FieldDef{..} =
                 entityId (entityDef (Proxy @HasDefaultId))
         it "should have usual db name" $ do
             fieldDB `shouldBe` FieldNameDB "id"
@@ -181,23 +205,23 @@ spec = describe "THSpec" $ do
             fieldType `shouldBe` FTTypeCon Nothing "HasDefaultIdId"
 
     describe "HasCustomSqlId" $ do
-        let FieldDef{..} =
+        let EntityIdField FieldDef{..} =
                 entityId (entityDef (Proxy @HasCustomSqlId))
         it "should have custom db name" $ do
             fieldDB `shouldBe` FieldNameDB "my_id"
         it "should have usual haskell name" $ do
-            fieldHaskell `shouldBe` FieldNameHS "id"
+            fieldHaskell `shouldBe` FieldNameHS "Id"
         it "should have correct underlying sql type" $ do
             fieldSqlType `shouldBe` SqlString
         it "should have correct haskell type" $ do
             fieldType `shouldBe` FTTypeCon Nothing "String"
     describe "HasIdDef" $ do
-        let FieldDef{..} =
+        let EntityIdField FieldDef{..} =
                 entityId (entityDef (Proxy @HasIdDef))
         it "should have usual db name" $ do
             fieldDB `shouldBe` FieldNameDB "id"
         it "should have usual haskell name" $ do
-            fieldHaskell `shouldBe` FieldNameHS "id"
+            fieldHaskell `shouldBe` FieldNameHS "Id"
         it "should have correct underlying sql type" $ do
             fieldSqlType `shouldBe` SqlInt64
         it "should have correct haskell type" $ do
@@ -205,16 +229,18 @@ spec = describe "THSpec" $ do
 
     describe "SharedPrimaryKey" $ do
         let sharedDef = entityDef (Proxy @SharedPrimaryKey)
-            FieldDef{..} =
+            EntityIdField FieldDef{..} =
                 entityId sharedDef
         it "should have usual db name" $ do
             fieldDB `shouldBe` FieldNameDB "id"
         it "should have usual haskell name" $ do
-            fieldHaskell `shouldBe` FieldNameHS "id"
+            fieldHaskell `shouldBe` FieldNameHS "Id"
         it "should have correct underlying sql type" $ do
             fieldSqlType `shouldBe` SqlInt64
+        it "should have correct underlying (as reported by sqltype)" $ do
+            fieldSqlType `shouldBe` sqlType (Proxy :: Proxy HasDefaultIdId)
         it "should have correct haskell type" $ do
-            fieldType `shouldBe` FTApp (FTTypeCon Nothing "Key") (FTTypeCon Nothing "HasDefaultId")
+            fieldType `shouldBe` (FTTypeCon Nothing "HasDefaultIdId")
         it "should have correct sql type from PersistFieldSql" $ do
             sqlType (Proxy @SharedPrimaryKeyId)
                 `shouldBe`
@@ -228,18 +254,13 @@ spec = describe "THSpec" $ do
                 `shouldBe`
                     SharedPrimaryKeyKey (toSqlKey 3)
 
-        it "is a newtype" $ do
-            pkNewtype sqlSettings sharedDef
-                `shouldBe`
-                    True
-
     describe "SharedPrimaryKeyWithCascade" $ do
-        let FieldDef{..} =
+        let EntityIdField FieldDef{..} =
                 entityId (entityDef (Proxy @SharedPrimaryKeyWithCascade))
         it "should have usual db name" $ do
             fieldDB `shouldBe` FieldNameDB "id"
         it "should have usual haskell name" $ do
-            fieldHaskell `shouldBe` FieldNameHS "id"
+            fieldHaskell `shouldBe` FieldNameHS "Id"
         it "should have correct underlying sql type" $ do
             fieldSqlType `shouldBe` SqlInt64
         it "should have correct haskell type" $ do
@@ -270,13 +291,13 @@ spec = describe "THSpec" $ do
                             { entityHaskell = EntityNameHS "HasSimpleCascadeRef"
                             , entityDB = EntityNameDB "HasSimpleCascadeRef"
                             , entityId =
-                                FieldDef
+                                EntityIdField FieldDef
                                     { fieldHaskell = FieldNameHS "Id"
                                     , fieldDB = FieldNameDB "id"
                                     , fieldType = FTTypeCon Nothing "HasSimpleCascadeRefId"
                                     , fieldSqlType = SqlInt64
                                     , fieldReference =
-                                        ForeignRef (EntityNameHS "HasSimpleCascadeRef") (FTTypeCon (Just "Data.Int") "Int64")
+                                        NoReference
                                     , fieldAttrs = []
                                     , fieldStrict = True
                                     , fieldComments = Nothing
@@ -296,7 +317,6 @@ spec = describe "THSpec" $ do
                                     , fieldReference =
                                         ForeignRef
                                             (EntityNameHS "Person")
-                                            (FTTypeCon (Just "Data.Int") "Int64")
                                     , fieldCascade =
                                         FieldCascade { fcOnUpdate = Nothing, fcOnDelete = Just Cascade }
                                     , fieldComments = Nothing
diff --git a/persistent/test/main.hs b/persistent/test/main.hs
index 60d5200b2..4db91e2ce 100644
--- a/persistent/test/main.hs
+++ b/persistent/test/main.hs
@@ -1,933 +1,16 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE RecordWildCards #-}
+module Main where
 
-import qualified Data.Char as Char
-import Data.List
-import Data.List.NonEmpty (NonEmpty(..), (<|))
-import qualified Data.List.NonEmpty as NEL
-import qualified Data.Map as Map
-import qualified Data.Text as T
 import Test.Hspec
-import Test.Hspec.QuickCheck
-import Test.QuickCheck
-#if !MIN_VERSION_base(4,11,0)
--- This can be removed when GHC < 8.2.2 isn't supported anymore
-import Data.Semigroup ((<>))
-#endif
-import Data.Aeson
-import qualified Data.ByteString.Char8 as BS8
-import Data.Time
-import Text.Shakespeare.Text
-
-import Database.Persist.Class.PersistField
-import Database.Persist.Quasi
-import Database.Persist.Quasi.Internal
-       ( Line(..)
-       , LinesWithComments(..)
-       , Token(..)
-       , associateLines
-       , parseFieldType
-       , parseLine
-       , preparse
-       , splitExtras
-       , takeColsEx
-       )
-import Database.Persist.Types
-import Database.Persist.EntityDef.Internal
 
 import qualified Database.Persist.THSpec as THSpec
+import qualified Database.Persist.QuasiSpec as QuasiSpec
+import qualified Database.Persist.ClassSpec as ClassSpec
+import qualified Database.Persist.PersistValueSpec as PersistValueSpec
 
 main :: IO ()
 main = hspec $ do
     describe "Database" $ describe "Persist" $ do
         THSpec.spec
-
-    describe "splitExtras" $ do
-        let helloWorldTokens = Token "hello" :| [Token "world"]
-            foobarbazTokens = Token "foo" :| [Token "bar", Token "baz"]
-        it "works" $ do
-            splitExtras []
-                `shouldBe`
-                    mempty
-        it "works2" $ do
-            splitExtras
-                [ Line 0 helloWorldTokens
-                ]
-                `shouldBe`
-                    ( [NEL.toList helloWorldTokens], mempty )
-        it "works3" $ do
-            splitExtras
-                [ Line 0 helloWorldTokens
-                , Line 2 foobarbazTokens
-                ]
-                `shouldBe`
-                    ( [NEL.toList helloWorldTokens, NEL.toList foobarbazTokens], mempty )
-        it "works4" $ do
-            splitExtras
-                [ Line 0 [Token "Product"]
-                , Line 2 (Token <$> ["name", "Text"])
-                , Line 2 (Token <$> ["added", "UTCTime", "default=CURRENT_TIMESTAMP"])
-                ]
-                `shouldBe`
-                    ( []
-                    , Map.fromList
-                        [ ("Product",
-                            [ ["name", "Text"]
-                            , ["added", "UTCTime", "default=CURRENT_TIMESTAMP"]
-                            ]
-                        ) ]
-                    )
-        it "works5" $ do
-            splitExtras
-                [ Line 0 [Token "Product"]
-                , Line 2 (Token <$> ["name", "Text"])
-                , Line 4 [Token "ExtraBlock"]
-                , Line 4 (Token <$> ["added", "UTCTime", "default=CURRENT_TIMESTAMP"])
-                ]
-                `shouldBe`
-                    ( []
-                    , Map.fromList
-                        [ ("Product",
-                            [ ["name", "Text"]
-                            , ["ExtraBlock"]
-                            , ["added", "UTCTime", "default=CURRENT_TIMESTAMP"]
-                            ]
-                        )]
-                    )
-    describe "takeColsEx" $ do
-        let subject = takeColsEx upperCaseSettings
-        it "fails on a single word" $ do
-            subject ["asdf"]
-                `shouldBe`
-                    Nothing
-        it "works if it has a name and a type" $ do
-            subject ["asdf", "Int"]
-                `shouldBe`
-                    Just FieldDef
-                        { fieldHaskell = FieldNameHS "asdf"
-                        , fieldDB = FieldNameDB "asdf"
-                        , fieldType = FTTypeCon Nothing "Int"
-                        , fieldSqlType = SqlOther "SqlType unset for asdf"
-                        , fieldAttrs = []
-                        , fieldStrict = True
-                        , fieldReference = NoReference
-                        , fieldCascade = noCascade
-                        , fieldComments = Nothing
-                        , fieldGenerated = Nothing
-                        , fieldIsImplicitIdColumn = False
-                        }
-        it "works if it has a name, type, and cascade" $ do
-            subject ["asdf", "Int", "OnDeleteCascade", "OnUpdateCascade"]
-                `shouldBe`
-                    Just FieldDef
-                        { fieldHaskell = FieldNameHS "asdf"
-                        , fieldDB = FieldNameDB "asdf"
-                        , fieldType = FTTypeCon Nothing "Int"
-                        , fieldSqlType = SqlOther "SqlType unset for asdf"
-                        , fieldAttrs = []
-                        , fieldStrict = True
-                        , fieldReference = NoReference
-                        , fieldCascade = FieldCascade (Just Cascade) (Just Cascade)
-                        , fieldComments = Nothing
-                        , fieldGenerated = Nothing
-                        , fieldIsImplicitIdColumn = False
-                        }
-        it "never tries to make a refernece" $ do
-            subject ["asdf", "UserId", "OnDeleteCascade"]
-                `shouldBe`
-                    Just FieldDef
-                        { fieldHaskell = FieldNameHS "asdf"
-                        , fieldDB = FieldNameDB "asdf"
-                        , fieldType = FTTypeCon Nothing "UserId"
-                        , fieldSqlType = SqlOther "SqlType unset for asdf"
-                        , fieldAttrs = []
-                        , fieldStrict = True
-                        , fieldReference = NoReference
-                        , fieldCascade = FieldCascade Nothing (Just Cascade)
-                        , fieldComments = Nothing
-                        , fieldGenerated = Nothing
-                        , fieldIsImplicitIdColumn = False
-                        }
-
-    describe "parseLine" $ do
-        it "returns nothing when line is just whitespace" $
-            parseLine "         " `shouldBe` Nothing
-
-        it "handles normal words" $
-            parseLine " foo   bar  baz" `shouldBe`
-                Just
-                    ( Line 1
-                        [ Token "foo"
-                        , Token "bar"
-                        , Token "baz"
-                        ]
-                    )
-
-        it "handles quotes" $
-            parseLine "  \"foo bar\"  \"baz\"" `shouldBe`
-                Just
-                    ( Line 2
-                        [ Token "foo bar"
-                        , Token "baz"
-                        ]
-                    )
-
-        it "handles quotes mid-token" $
-            parseLine "  x=\"foo bar\"  \"baz\"" `shouldBe`
-                Just
-                    ( Line 2
-                        [ Token "x=foo bar"
-                        , Token "baz"
-                        ]
-                    )
-
-        it "handles escaped quote mid-token" $
-            parseLine "  x=\\\"foo bar\"  \"baz\"" `shouldBe`
-                Just
-                    ( Line 2
-                        [ Token "x=\\\"foo"
-                        , Token "bar\""
-                        , Token "baz"
-                        ]
-                    )
-
-        it "handles unnested parantheses" $
-            parseLine "  (foo bar)  (baz)" `shouldBe`
-                Just
-                    ( Line 2
-                        [ Token "foo bar"
-                        , Token "baz"
-                        ]
-                    )
-
-        it "handles unnested parantheses mid-token" $
-            parseLine "  x=(foo bar)  (baz)" `shouldBe`
-                Just
-                    ( Line 2
-                        [ Token "x=foo bar"
-                        , Token "baz"
-                        ]
-                    )
-
-        it "handles nested parantheses" $
-            parseLine "  (foo (bar))  (baz)" `shouldBe`
-                Just
-                    ( Line 2
-                        [ Token "foo (bar)"
-                        , Token "baz"
-                        ]
-                    )
-
-        it "escaping" $
-            parseLine "  (foo \\(bar)  y=\"baz\\\"\"" `shouldBe`
-                Just
-                    ( Line 2
-                        [ Token "foo (bar"
-                        , Token "y=baz\""
-                        ]
-                    )
-
-        it "mid-token quote in later token" $
-            parseLine "foo bar baz=(bin\")" `shouldBe`
-                Just
-                    ( Line 0
-                        [ Token "foo"
-                        , Token "bar"
-                        , Token "baz=bin\""
-                        ]
-                    )
-
-        describe "comments" $ do
-            it "recognizes one line" $ do
-                parseLine "-- | this is a comment" `shouldBe`
-                    Just
-                        ( Line 0
-                            [ DocComment "this is a comment"
-                            ]
-                        )
-
-            it "works if comment is indented" $ do
-                parseLine "  -- | comment" `shouldBe`
-                    Just (Line 2 [DocComment "comment"])
-
-    describe "parse" $ do
-        let subject =
-                [st|
-Bicycle -- | this is a bike
-    brand String -- | the brand of the bike
-    ExtraBike
-        foo bar  -- | this is a foo bar
-        baz
-    deriving Eq
--- | This is a Car
-Car
-    -- | the make of the Car
-    make String
-    -- | the model of the Car
-    model String
-    UniqueModel model
-    deriving Eq Show
-+Vehicle
-    bicycle BicycleId -- | the bike reference
-    car CarId         -- | the car reference
-
-                    |]
-        let [bicycle, car, vehicle] = parse lowerCaseSettings subject
-
-        it "should parse the `entityHaskell` field" $ do
-            entityHaskell bicycle `shouldBe` EntityNameHS "Bicycle"
-            entityHaskell car `shouldBe` EntityNameHS "Car"
-            entityHaskell vehicle `shouldBe` EntityNameHS "Vehicle"
-
-        it "should parse the `entityDB` field" $ do
-            entityDB bicycle `shouldBe` EntityNameDB "bicycle"
-            entityDB car `shouldBe` EntityNameDB "car"
-            entityDB vehicle `shouldBe` EntityNameDB "vehicle"
-
-        it "should parse the `entityId` field" $ do
-            fieldHaskell (entityId bicycle) `shouldBe` FieldNameHS "Id"
-            fieldComments (entityId bicycle) `shouldBe` Nothing
-            fieldHaskell (entityId car) `shouldBe` FieldNameHS "Id"
-            fieldComments (entityId car) `shouldBe` Nothing
-            fieldHaskell (entityId vehicle) `shouldBe` FieldNameHS "Id"
-            fieldComments (entityId vehicle) `shouldBe` Nothing
-
-        it "should parse the `entityAttrs` field" $ do
-            entityAttrs bicycle `shouldBe` ["-- | this is a bike"]
-            entityAttrs car `shouldBe` []
-            entityAttrs vehicle `shouldBe` []
-
-        it "should parse the `entityFields` field" $ do
-            let simplifyField field =
-                    (fieldHaskell field, fieldDB field, fieldComments field)
-            (simplifyField <$> entityFields bicycle) `shouldBe`
-                [ (FieldNameHS "brand", FieldNameDB "brand", Nothing)
-                ]
-            (simplifyField <$> entityFields car) `shouldBe`
-                [ (FieldNameHS "make", FieldNameDB "make", Just "the make of the Car\n")
-                , (FieldNameHS "model", FieldNameDB "model", Just "the model of the Car\n")
-                ]
-            (simplifyField <$> entityFields vehicle) `shouldBe`
-                [ (FieldNameHS "bicycle", FieldNameDB "bicycle", Nothing)
-                , (FieldNameHS "car", FieldNameDB "car", Nothing)
-                ]
-
-        it "should parse the `entityUniques` field" $ do
-            let simplifyUnique unique =
-                    (uniqueHaskell unique, uniqueFields unique)
-            (simplifyUnique <$> entityUniques bicycle) `shouldBe` []
-            (simplifyUnique <$> entityUniques car) `shouldBe`
-                [ (ConstraintNameHS "UniqueModel", [(FieldNameHS "model", FieldNameDB "model")])
-                ]
-            (simplifyUnique <$> entityUniques vehicle) `shouldBe` []
-
-        it "should parse the `entityForeigns` field" $ do
-            let [user, notification] = parse lowerCaseSettings [st|
-User
-    name            Text
-    emailFirst      Text
-    emailSecond     Text
-
-    UniqueEmail emailFirst emailSecond
-
-Notification
-    content         Text
-    sentToFirst     Text
-    sentToSecond    Text
-
-    Foreign User fk_noti_user sentToFirst sentToSecond References emailFirst emailSecond
-|]
-            entityForeigns user `shouldBe` []
-            entityForeigns notification `shouldBe`
-                [ ForeignDef
-                    { foreignRefTableHaskell = EntityNameHS "User"
-                    , foreignRefTableDBName = EntityNameDB "user"
-                    , foreignConstraintNameHaskell = ConstraintNameHS "fk_noti_user"
-                    , foreignConstraintNameDBName = ConstraintNameDB "notificationfk_noti_user"
-                    , foreignFieldCascade = FieldCascade Nothing Nothing
-                    , foreignFields =
-                        [ ((FieldNameHS "sentToFirst", FieldNameDB "sent_to_first"), (FieldNameHS "emailFirst", FieldNameDB "email_first"))
-                        , ((FieldNameHS "sentToSecond", FieldNameDB "sent_to_second"), (FieldNameHS "emailSecond", FieldNameDB "email_second"))
-                        ]
-                    , foreignAttrs = []
-                    , foreignNullable = False
-                    , foreignToPrimary = False
-                    }
-                ]
-
-        it "should parse the `entityDerives` field" $ do
-            entityDerives bicycle `shouldBe` ["Eq"]
-            entityDerives car `shouldBe` ["Eq", "Show"]
-            entityDerives vehicle `shouldBe` []
-
-        it "should parse the `entityEntities` field" $ do
-            entityExtra bicycle `shouldBe` Map.singleton "ExtraBike" [["foo", "bar", "-- | this is a foo bar"], ["baz"]]
-            entityExtra car `shouldBe` mempty
-            entityExtra vehicle `shouldBe` mempty
-
-        it "should parse the `entitySum` field" $ do
-            entitySum bicycle `shouldBe` False
-            entitySum car `shouldBe` False
-            entitySum vehicle `shouldBe` True
-
-        it "should parse the `entityComments` field" $ do
-            entityComments bicycle `shouldBe` Nothing
-            entityComments car `shouldBe` Just "This is a Car\n"
-            entityComments vehicle `shouldBe` Nothing
-
-        describe "foreign keys" $ do
-            let definitions = [st|
-User
-    name            Text
-    emailFirst      Text
-    emailSecond     Text
-
-    UniqueEmail emailFirst emailSecond
-
-Notification
-    content         Text
-    sentToFirst     Text
-    sentToSecond    Text
-
-    Foreign User fk_noti_user sentToFirst sentToSecond References emailFirst emailSecond
-|]
-
-            it "should allow you to modify the FK name via provided function" $ do
-                let flippedFK = \(EntityNameHS entName) (ConstraintNameHS conName) -> conName <> entName
-                let [user, notification] = parse (setPsToFKName flippedFK lowerCaseSettings) definitions
-                let [notificationForeignDef] = entityForeigns notification
-                foreignConstraintNameDBName notificationForeignDef `shouldBe` ConstraintNameDB "fk_noti_user_notification"
-
-            it "should allow you to enable snake cased foriegn keys via a preset configuration function" $ do
-                let [user, notification] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) definitions
-                let [notificationForeignDef] = entityForeigns notification
-                foreignConstraintNameDBName notificationForeignDef `shouldBe` ConstraintNameDB "notification_fk_noti_user"
-
-    describe "parseFieldType" $ do
-        it "simple types" $
-            parseFieldType "FooBar" `shouldBe` Right (FTTypeCon Nothing "FooBar")
-        it "module types" $
-            parseFieldType "Data.Map.FooBar" `shouldBe` Right (FTTypeCon (Just "Data.Map") "FooBar")
-        it "application" $
-            parseFieldType "Foo Bar" `shouldBe` Right (
-                FTTypeCon Nothing "Foo" `FTApp` FTTypeCon Nothing "Bar")
-        it "application multiple" $
-            parseFieldType "Foo Bar Baz" `shouldBe` Right (
-                (FTTypeCon Nothing "Foo" `FTApp` FTTypeCon Nothing "Bar")
-                `FTApp` FTTypeCon Nothing "Baz"
-                )
-        it "parens" $ do
-            let foo = FTTypeCon Nothing "Foo"
-                bar = FTTypeCon Nothing "Bar"
-                baz = FTTypeCon Nothing "Baz"
-            parseFieldType "Foo (Bar Baz)" `shouldBe` Right (
-                foo `FTApp` (bar `FTApp` baz))
-        it "lists" $ do
-            let foo = FTTypeCon Nothing "Foo"
-                bar = FTTypeCon Nothing "Bar"
-                bars = FTList bar
-                baz = FTTypeCon Nothing "Baz"
-            parseFieldType "Foo [Bar] Baz" `shouldBe` Right (
-                foo `FTApp` bars `FTApp` baz)
-
-    describe "#1175 empty entity" $ do
-        let subject =
-                [st|
-Foo
-    name String
-    age Int
-
-EmptyEntity
-
-Bar
-    name String
-
-Baz
-    a Int
-    b String
-    c FooId
-                    |]
-
-        let preparsed =
-                preparse subject
-        it "preparse works" $ do
-            (length <$> preparsed) `shouldBe` Just 10
-
-        let fooLines =
-                [ Line
-                    { lineIndent = 0
-                    , tokens = Token "Foo" :| []
-                    }
-                , Line
-                    { lineIndent = 4
-                    , tokens = Token "name" :| [Token "String"]
-                    }
-                , Line
-                    { lineIndent = 4
-                    , tokens = Token "age" :| [Token "Int"]
-                    }
-                ]
-            emptyLines =
-                [ Line
-                    { lineIndent = 0
-                    , tokens = Token "EmptyEntity" :| []
-                    }
-                ]
-            barLines =
-                [ Line
-                    { lineIndent = 0
-                    , tokens = Token "Bar" :| []
-                    }
-                , Line
-                    { lineIndent = 4
-                    , tokens = Token "name" :| [Token "String"]
-                    }
-                ]
-            bazLines =
-                [ Line
-                    { lineIndent = 0
-                    , tokens = Token "Baz" :| []
-                    }
-                , Line
-                    { lineIndent = 4
-                    , tokens = Token "a" :| [Token "Int"]
-                    }
-                , Line
-                    { lineIndent = 4
-                    , tokens = Token "b" :| [Token "String"]
-                    }
-                , Line
-                    { lineIndent = 4
-                    , tokens = Token "c" :| [Token "FooId"]
-                    }
-                ]
-
-        let linesAssociated =
-                case preparsed of
-                    Nothing -> error "preparsed failed"
-                    Just lines -> associateLines lines
-        it "associateLines works" $ do
-            linesAssociated `shouldMatchList`
-                [ LinesWithComments
-                    { lwcLines = NEL.fromList fooLines
-                    , lwcComments = []
-                    }
-                , LinesWithComments (NEL.fromList emptyLines) []
-                , LinesWithComments (NEL.fromList barLines) []
-                , LinesWithComments (NEL.fromList bazLines) []
-                ]
-
-        let parsed =
-                parse lowerCaseSettings subject
-        it "parse works" $ do
-            let test name'fieldCount xs = do
-                    case (name'fieldCount, xs) of
-                        ([], []) ->
-                            pure ()
-                        ((name, fieldCount) : _, []) ->
-                            expectationFailure
-                                $ "Expected an entity with name "
-                                <> name
-                                <> " and " <> show fieldCount <> " fields"
-                                <> ", but the list was empty..."
-
-                        ((name, fieldCount) : ys, (EntityDef {..} : xs)) -> do
-                            (unEntityNameHS entityHaskell, length entityFields)
-                                `shouldBe`
-                                    (T.pack name, fieldCount)
-                            test ys xs
-
-                result =
-                    parse lowerCaseSettings subject
-            length parsed `shouldBe` 4
-
-            test
-                [ ("Foo", 2)
-                , ("EmptyEntity", 0)
-                , ("Bar", 1)
-                , ("Baz", 3)
-                ]
-                parsed
-
-
-    describe "preparse" $ do
-        prop "omits lines that are only whitespace" $ \len -> do
-            ws <- vectorOf len arbitraryWhiteSpaceChar
-            pure $ preparse (T.pack ws) === Nothing
-
-        it "recognizes entity" $ do
-            let expected =
-                    Line { lineIndent = 0, tokens = pure (Token "Person") } :|
-                    [ Line { lineIndent = 2, tokens = Token "name" :| [Token "String"] }
-                    , Line { lineIndent = 2, tokens = Token "age" :| [Token "Int"] }
-                    ]
-            preparse "Person\n  name String\n  age Int" `shouldBe` Just expected
-
-        it "recognizes comments" $ do
-            let text = "Foo\n  x X\n-- | Hello\nBar\n name String"
-            let expected =
-                    Line { lineIndent = 0, tokens = pure (Token "Foo") } :|
-                    [ Line { lineIndent = 2, tokens = Token "x" :| [Token "X"] }
-                    , Line { lineIndent = 0, tokens = pure (DocComment "Hello") }
-                    , Line { lineIndent = 0, tokens = pure (Token "Bar") }
-                    , Line { lineIndent = 1, tokens = Token "name" :| [Token "String"] }
-                    ]
-            preparse text `shouldBe` Just expected
-
-        it "preparse indented" $ do
-            let t = T.unlines
-                    [ "  Foo"
-                    , "    x X"
-                    , "  -- | Comment"
-                    , "  -- hidden comment"
-                    , "  Bar"
-                    , "    name String"
-                    ]
-                expected =
-                    Line { lineIndent = 2, tokens = pure (Token "Foo") } :|
-                    [ Line { lineIndent = 4, tokens = Token "x" :| [Token "X"] }
-                    , Line { lineIndent = 2, tokens = pure (DocComment "Comment") }
-                    , Line { lineIndent = 2, tokens = pure (Token "Bar") }
-                    , Line { lineIndent = 4, tokens = Token "name" :| [Token "String"] }
-                    ]
-            preparse t `shouldBe` Just expected
-
-        it "preparse extra blocks" $ do
-            let t = T.unlines
-                    [ "LowerCaseTable"
-                    , "  name String"
-                    , "  ExtraBlock"
-                    , "    foo bar"
-                    , "    baz"
-                    , "  ExtraBlock2"
-                    , "    something"
-                    ]
-                expected =
-                    Line { lineIndent = 0, tokens = pure (Token "LowerCaseTable") } :|
-                    [ Line { lineIndent = 2, tokens = Token "name" :| [Token "String"] }
-                    , Line { lineIndent = 2, tokens = pure (Token "ExtraBlock") }
-                    , Line { lineIndent = 4, tokens = Token "foo" :| [Token "bar"] }
-                    , Line { lineIndent = 4, tokens = pure (Token "baz") }
-                    , Line { lineIndent = 2, tokens = pure (Token "ExtraBlock2") }
-                    , Line { lineIndent = 4, tokens = pure (Token "something") }
-                    ]
-            preparse t `shouldBe` Just expected
-
-        it "field comments" $ do
-            let text = T.unlines
-                    [ "-- | Model"
-                    , "Foo"
-                    , "  -- | Field"
-                    , "  name String"
-                    ]
-                expected =
-                    Line { lineIndent = 0, tokens = [DocComment "Model"] } :|
-                    [ Line { lineIndent = 0, tokens = [Token "Foo"] }
-                    , Line { lineIndent = 2, tokens = [DocComment "Field"] }
-                    , Line { lineIndent = 2, tokens = (Token <$> ["name", "String"]) }
-                    ]
-            preparse text `shouldBe` Just expected
-
-    describe "associateLines" $ do
-        let foo =
-                Line
-                    { lineIndent = 0
-                    , tokens = pure (Token "Foo")
-                    }
-            name'String =
-                Line
-                    { lineIndent = 2
-                    , tokens = Token "name" :| [Token "String"]
-                    }
-            comment =
-                Line
-                    { lineIndent = 0
-                    , tokens = pure (DocComment "comment")
-                    }
-        it "works" $ do
-            associateLines
-                ( comment :|
-                [ foo
-                , name'String
-                ])
-                `shouldBe`
-                    [ LinesWithComments
-                        { lwcComments = ["comment"]
-                        , lwcLines = foo :| [name'String]
-                        }
-                    ]
-        let bar =
-                Line
-                    { lineIndent = 0
-                    , tokens = Token "Bar" :| [Token "sql", Token "=", Token "bars"]
-                    }
-            age'Int =
-                Line
-                    { lineIndent = 1
-                    , tokens = Token "age" :| [Token "Int"]
-                    }
-        it "works when used consecutively" $ do
-            associateLines
-                ( bar :|
-                [ age'Int
-                , comment
-                , foo
-                , name'String
-                ])
-                `shouldBe`
-                    [ LinesWithComments
-                        { lwcComments = []
-                        , lwcLines = bar :| [age'Int]
-                        }
-                    , LinesWithComments
-                        { lwcComments = ["comment"]
-                        , lwcLines = foo :| [name'String]
-                        }
-                    ]
-        it "works with textual input" $ do
-            let text = preparse "Foo\n  x X\n-- | Hello\nBar\n name String"
-            associateLines <$> text
-                `shouldBe` Just
-                    [ LinesWithComments
-                        { lwcLines =
-                            Line {lineIndent = 0, tokens = Token "Foo" :| []}
-                            :| [ Line {lineIndent = 2, tokens = Token "x" :| [Token "X"]} ]
-                        , lwcComments =
-                            []
-                        }
-                    , LinesWithComments
-                        { lwcLines =
-                            Line {lineIndent = 0, tokens = Token "Bar" :| []}
-                            :| [ Line {lineIndent = 1, tokens = Token "name" :| [Token "String"]}]
-                        , lwcComments =
-                            ["Hello"]
-                        }
-                    ]
-        it "works with extra blocks" $ do
-            let text = preparse . T.unlines $
-                    [ "LowerCaseTable"
-                    , "    Id             sql=my_id"
-                    , "    fullName Text"
-                    , "    ExtraBlock"
-                    , "        foo bar"
-                    , "        baz"
-                    , "        bin"
-                    , "    ExtraBlock2"
-                    , "        something"
-                    ]
-            associateLines <$> text `shouldBe` Just
-                [ LinesWithComments
-                    { lwcLines =
-                        Line { lineIndent = 0, tokens = pure (Token "LowerCaseTable") } :|
-                        [ Line { lineIndent = 4, tokens = Token "Id" :| [Token "sql=my_id"] }
-                        , Line { lineIndent = 4, tokens = Token "fullName" :| [Token "Text"] }
-                        , Line { lineIndent = 4, tokens = pure (Token "ExtraBlock") }
-                        , Line { lineIndent = 8, tokens = Token "foo" :| [Token "bar"] }
-                        , Line { lineIndent = 8, tokens = pure (Token "baz") }
-                        , Line { lineIndent = 8, tokens = pure (Token "bin") }
-                        , Line { lineIndent = 4, tokens = pure (Token "ExtraBlock2") }
-                        , Line { lineIndent = 8, tokens = pure (Token "something") }
-                        ]
-                    , lwcComments = []
-                    }
-                ]
-
-        it "works with extra blocks twice" $ do
-            let text = preparse . T.unlines $
-                    [ "IdTable"
-                    , "    Id Day default=CURRENT_DATE"
-                    , "    name Text"
-                    , ""
-                    , "LowerCaseTable"
-                    , "    Id             sql=my_id"
-                    , "    fullName Text"
-                    , "    ExtraBlock"
-                    , "        foo bar"
-                    , "        baz"
-                    , "        bin"
-                    , "    ExtraBlock2"
-                    , "        something"
-                    ]
-            associateLines <$> text `shouldBe` Just
-                [ LinesWithComments
-                    { lwcLines = Line 0 (pure (Token "IdTable")) :|
-                        [ Line 4 (Token "Id" <| Token "Day" :| [Token "default=CURRENT_DATE"])
-                        , Line 4 (Token "name" :| [Token "Text"])
-                        ]
-                    , lwcComments = []
-                    }
-                , LinesWithComments
-                    { lwcLines =
-                        Line { lineIndent = 0, tokens = pure (Token "LowerCaseTable") } :|
-                        [ Line { lineIndent = 4, tokens = Token "Id" :| [Token "sql=my_id"] }
-                        , Line { lineIndent = 4, tokens = Token "fullName" :| [Token "Text"] }
-                        , Line { lineIndent = 4, tokens = pure (Token "ExtraBlock") }
-                        , Line { lineIndent = 8, tokens = Token "foo" :| [Token "bar"] }
-                        , Line { lineIndent = 8, tokens = pure (Token "baz") }
-                        , Line { lineIndent = 8, tokens = pure (Token "bin") }
-                        , Line { lineIndent = 4, tokens = pure (Token "ExtraBlock2") }
-                        , Line { lineIndent = 8, tokens = pure (Token "something") }
-                        ]
-                    , lwcComments = []
-                    }
-                ]
-
-
-        it "works with field comments" $ do
-            let text = preparse . T.unlines $
-                    [ "-- | Model"
-                    , "Foo"
-                    , "  -- | Field"
-                    , "  name String"
-                    ]
-            associateLines <$> text `shouldBe` Just
-                [ LinesWithComments
-                    { lwcLines =
-                        Line { lineIndent = 0, tokens = (Token "Foo") :| [] } :|
-                            [ Line { lineIndent = 2, tokens = pure (DocComment "Field") }
-                            , Line { lineIndent = 2, tokens = Token "name" :| [Token "String"] }
-                            ]
-                    , lwcComments =
-                        ["Model"]
-                    }
-                ]
-
-
-
-    describe "parseLines" $ do
-        let lines =
-                T.unlines
-                    [ "-- | Comment"
-                    , "Foo"
-                    , "  -- | Field"
-                    , "  name String"
-                    , "  age  Int"
-                    , "  Extra"
-                    , "    foo bar"
-                    , "    baz"
-                    , "  Extra2"
-                    , "    something"
-                    ]
-        let [subject] = parse lowerCaseSettings lines
-        it "produces the right name" $ do
-            entityHaskell subject `shouldBe` EntityNameHS "Foo"
-        describe "entityFields" $ do
-            let fields = entityFields subject
-            it "has the right field names" $ do
-                map fieldHaskell fields `shouldMatchList`
-                    [ FieldNameHS "name"
-                    , FieldNameHS "age"
-                    ]
-            it "has comments" $ do
-                map fieldComments fields `shouldBe`
-                    [ Just "Field\n"
-                    , Nothing
-                    ]
-        it "has the comments" $ do
-            entityComments subject `shouldBe`
-                Just "Comment\n"
-        it "combines extrablocks" $ do
-            entityExtra subject `shouldBe` Map.fromList
-                [ ("Extra", [["foo", "bar"], ["baz"]])
-                , ("Extra2", [["something"]])
-                ]
-        describe "works with extra blocks" $ do
-            let [_, lowerCaseTable, idTable] =
-                    case parse lowerCaseSettings $ T.unlines
-                        [ ""
-                        , "IdTable"
-                        , "    Id Day default=CURRENT_DATE"
-                        , "    name Text"
-                        , ""
-                        , "LowerCaseTable"
-                        , "    Id             sql=my_id"
-                        , "    fullName Text"
-                        , "    ExtraBlock"
-                        , "        foo bar"
-                        , "        baz"
-                        , "        bin"
-                        , "    ExtraBlock2"
-                        , "        something"
-                        , ""
-                        , "IdTable"
-                        , "    Id Day default=CURRENT_DATE"
-                        , "    name Text"
-                        , ""
-                        ] of
-                            [a, b, c] ->
-                                [a, b, c] :: [EntityDef]
-                            xs ->
-                                error
-                                $ "Expected 3 elements in list, got: "
-                                <> show (length xs)
-                                <> ", list contents: \n\n" <> intercalate "\n" (map show xs)
-            describe "idTable" $ do
-                let EntityDef {..} = idTable
-                it "has no extra blocks" $ do
-                    entityExtra `shouldBe` mempty
-                it "has the right name" $ do
-                    entityHaskell `shouldBe` EntityNameHS "IdTable"
-                it "has the right fields" $ do
-                    map fieldHaskell entityFields `shouldMatchList`
-                        [ FieldNameHS "name"
-                        ]
-            describe "lowerCaseTable" $ do
-                let EntityDef {..} = lowerCaseTable
-                it "has the right name" $ do
-                    entityHaskell `shouldBe` EntityNameHS "LowerCaseTable"
-                it "has the right fields" $ do
-                    map fieldHaskell entityFields `shouldMatchList`
-                        [ FieldNameHS "fullName"
-                        ]
-                it "has ExtraBlock" $ do
-                    Map.lookup "ExtraBlock" entityExtra
-                        `shouldBe` Just
-                            [ ["foo", "bar"]
-                            , ["baz"]
-                            , ["bin"]
-                            ]
-                it "has ExtraBlock2" $ do
-                    Map.lookup "ExtraBlock2" entityExtra
-                        `shouldBe` Just
-                            [ ["something"]
-                            ]
-
-    describe "fromPersistValue" $
-        describe "UTCTime" $
-            it "works with format" $
-                fromPersistValue (PersistText "2018-02-27 10:49:42.123")
-                    `shouldBe` Right (UTCTime (fromGregorian 2018 02 27) (timeOfDayToTime (TimeOfDay 10 49 42.123)))
-
-    describe "PersistValue" $ do
-        describe "Aeson" $ do
-            let
-                testPrefix constr prefixChar bytes =
-                    takePrefix (toJSON (constr (BS8.pack bytes)))
-                    ===
-                    String (T.singleton prefixChar)
-                roundTrip constr bytes =
-                    fromJSON (toJSON (constr (BS8.pack bytes)))
-                    ===
-                    Data.Aeson.Success (constr (BS8.pack bytes))
-                subject constr prefixChar = do
-                    prop ("encodes with a " ++ [prefixChar] ++ " prefix") $
-                        testPrefix constr prefixChar
-                    prop "Round Trips" $
-                        roundTrip constr
-
-            describe "PersistDbSpecific" $ do
-                subject PersistDbSpecific 'p'
-            describe "PersistLiteral" $ do
-                subject PersistLiteral 'l'
-            describe "PersistLiteralEscaped" $ do
-                subject PersistLiteralEscaped 'e'
-
-takePrefix :: Value -> Value
-takePrefix (String a) = String (T.take 1 a)
-takePrefix a = a
-
-arbitraryWhiteSpaceChar :: Gen Char
-arbitraryWhiteSpaceChar =
-  oneof $ pure <$> [' ', '\t', '\n', '\r']
+        QuasiSpec.spec
+        ClassSpec.spec
+        PersistValueSpec.spec
diff --git a/stack.yaml b/stack.yaml
index 613ca01e5..e5a1c6382 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -3,7 +3,7 @@ packages:
   - ./persistent
   - ./persistent-sqlite
   - ./persistent-test
-  - ./persistent-mongoDB
+    # - ./persistent-mongoDB
   - ./persistent-mysql
   - ./persistent-postgresql
   - ./persistent-redis