From 31aeab8b2138a9a282796c863b20e5f2ccddb9b1 Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Sun, 25 Apr 2021 21:45:53 -0600
Subject: [PATCH 01/12] Better migrations

---
 persistent/Database/Persist/TH.hs | 48 ++++++++++++++-----------------
 1 file changed, 21 insertions(+), 27 deletions(-)

diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
index d7bba56b4..5860c10ab 100644
--- a/persistent/Database/Persist/TH.hs
+++ b/persistent/Database/Persist/TH.hs
@@ -1644,35 +1644,29 @@ derivePersistFieldJSON s = do
 -- defined here. One thing to be aware of is dependencies: if you have entities
 -- with foreign references, make sure to place those definitions after the
 -- entities they reference.
+--
+-- In @persistent-2.13.0.0@, this was changed to *ignore* the input entity def
+-- list, and instead defer to 'mkEntityDefList' to get the correct entities.
+-- 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 fun allDefs = do
-    body' <- body
-    return
-        [ SigD (mkName fun) typ
-        , FunD (mkName fun) [normalClause [] body']
+mkMigrate fun eds = do
+    let entityDefListName = ("entityDefListFor" <> fun)
+    body <-
+        [|
+          let
+              defs = $(varE (mkName entityDefListName))
+              isMigrated def = pack "no-migrate" `notElem` entityAttrs def
+           in
+              forM_ (filter isMigrated defs) $ \def ->
+                  migrate defs def
+        |]
+    edList <- mkEntityDefList entityDefListName eds
+    pure $ edList <>
+        [ SigD (mkName fun) (ConT ''Migration)
+        , FunD (mkName fun) [normalClause [] body]
         ]
-  where
-    defs = filter isMigrated allDefs
-    isMigrated def = "no-migrate" `notElem` entityAttrs def
-    typ = ConT ''Migration
-    entityMap = constructEntityMap allDefs
-    body :: Q Exp
-    body =
-        case defs of
-            [] -> [|return ()|]
-            _  -> do
-              defsName <- newName "defs"
-              defsStmt <- do
-                defs' <- mapM (liftAndFixKeys entityMap) defs
-                let defsExp = ListE defs'
-                return $ LetS [ValD (VarP defsName) (NormalB defsExp) []]
-              stmts <- mapM (toStmt $ VarE defsName) defs
-              return (DoE $ defsStmt : stmts)
-    toStmt :: Exp -> EntityDef -> Q Stmt
-    toStmt defsExp ed = do
-        u <- liftAndFixKeys entityMap ed
-        m <- [|migrate|]
-        return $ NoBindS $ m `AppE` defsExp `AppE` u
 
 makePersistEntityDefExp :: MkPersistSettings -> EntityMap -> EntityDef -> Q Exp
 makePersistEntityDefExp mps entityMap entDef@EntityDef{..} =

From 7c2a107522a9a805035211a3fae8993973c94a86 Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Mon, 26 Apr 2021 09:55:02 -0600
Subject: [PATCH 02/12] why is the test failing

---
 persistent-mysql/test/main.hs | 10 +++++++---
 1 file changed, 7 insertions(+), 3 deletions(-)

diff --git a/persistent-mysql/test/main.hs b/persistent-mysql/test/main.hs
index 56e165d8f..ac57145ee 100644
--- a/persistent-mysql/test/main.hs
+++ b/persistent-mysql/test/main.hs
@@ -19,6 +19,7 @@ import Test.QuickCheck
 import qualified Data.Text as T
 import Data.IntMap (IntMap)
 import qualified Data.ByteString as BS
+import Database.Persist.Sql
 
 import qualified CompositeTest
 import qualified CustomPersistFieldTest
@@ -169,9 +170,12 @@ main = do
     Recursive.specsWith db
     SumTypeTest.specsWith db (Just (runMigrationSilent SumTypeTest.sumTypeMigrate))
     MigrationOnlyTest.specsWith db
-        (Just
-            $ runMigrationSilent MigrationOnlyTest.migrateAll1
-            >> runMigrationSilent MigrationOnlyTest.migrateAll2
+        (Just $ do
+            runSqlCommand $ do
+                rawExecute_ "DROP TABLE IF EXISTS two_field;" []
+                rawExecute_ "DROP TABLE IF EXISTS referencing;" []
+            runMigrationSilent MigrationOnlyTest.migrateAll1
+            runMigrationSilent MigrationOnlyTest.migrateAll2
         )
     PersistentTest.specsWith db
     PersistentTest.filterOrSpecs db

From 20e417c2239ec845de85f3eea992138be1347eab Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Mon, 26 Apr 2021 11:25:49 -0600
Subject: [PATCH 03/12] Columns are present in entityFields now, but the
 generated code is broken.

---
 persistent-mysql/test/ImplicitUuidSpec.hs     |  2 +-
 persistent-mysql/test/main.hs                 | 46 ++++-----
 .../test/ImplicitUuidSpec.hs                  |  2 +-
 persistent-test/src/MigrationOnlyTest.hs      | 25 ++++-
 persistent/ChangeLog.md                       |  8 ++
 persistent/Database/Persist/EntityDef.hs      | 31 +++++-
 persistent/Database/Persist/FieldDef.hs       | 12 +++
 persistent/Database/Persist/TH.hs             | 97 +++++++++++++------
 persistent/persistent.cabal                   |  9 +-
 .../Database/Persist/TH/MigrationOnlySpec.hs  | 53 ++++++++++
 persistent/test/Database/Persist/THSpec.hs    |  5 +-
 persistent/test/main.hs                       |  5 +-
 12 files changed, 231 insertions(+), 64 deletions(-)
 create mode 100644 persistent/test/Database/Persist/TH/MigrationOnlySpec.hs

diff --git a/persistent-mysql/test/ImplicitUuidSpec.hs b/persistent-mysql/test/ImplicitUuidSpec.hs
index bdc1e4f14..448173a3b 100644
--- a/persistent-mysql/test/ImplicitUuidSpec.hs
+++ b/persistent-mysql/test/ImplicitUuidSpec.hs
@@ -51,7 +51,7 @@ pass :: IO ()
 pass = pure ()
 
 spec :: Spec
-spec = fdescribe "ImplicitUuidSpec" $ before_ wipe $ do
+spec = describe "ImplicitUuidSpec" $ before_ wipe $ do
     describe "WithDefUuidKey" $ do
         it "works on UUIDs" $ do
             let withDefUuidKey = WithDefUuidKey (UUID "Hello")
diff --git a/persistent-mysql/test/main.hs b/persistent-mysql/test/main.hs
index da6451e8e..a0551dafb 100644
--- a/persistent-mysql/test/main.hs
+++ b/persistent-mysql/test/main.hs
@@ -1,25 +1,28 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE DataKinds, FlexibleInstances #-}
-{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
 {-# OPTIONS_GHC -Wno-unused-top-binds #-}
 
 import MyInit
 
-import Data.Time (Day, UTCTime (..), TimeOfDay, timeToTimeOfDay, timeOfDayToTime)
-import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime)
+import qualified Data.ByteString as BS
 import Data.Fixed
-import Test.QuickCheck
-import qualified Data.Text as T
 import Data.IntMap (IntMap)
-import qualified Data.ByteString as BS
+import qualified Data.Text as T
+import Data.Time (Day, TimeOfDay, UTCTime(..), timeOfDayToTime, timeToTimeOfDay)
+import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
 import Database.Persist.Sql
+import Test.QuickCheck
 
 import qualified CompositeTest
 import qualified CustomPersistFieldTest
@@ -36,26 +39,26 @@ import qualified MaxLenTest
 import qualified MigrationColumnLengthTest
 import qualified MigrationIdempotencyTest
 import qualified MigrationOnlyTest
-import qualified MpsNoPrefixTest
 import qualified MpsCustomPrefixTest
-import qualified PersistentTest
+import qualified MpsNoPrefixTest
 import qualified PersistUniqueTest
+import qualified PersistentTest
 -- FIXME: Not used... should it be?
 -- import qualified PrimaryTest
 import qualified RawSqlTest
 import qualified ReadWriteTest
 import qualified Recursive
 -- TODO: can't use this as MySQL can't do DEFAULT CURRENT_DATE
+import qualified CustomConstraintTest
+import qualified ForeignKey
+import qualified GeneratedColumnTestSQL
+import qualified ImplicitUuidSpec
+import qualified LongIdentifierTest
 import qualified RenameTest
 import qualified SumTypeTest
 import qualified TransactionLevelTest
 import qualified UniqueTest
 import qualified UpsertTest
-import qualified CustomConstraintTest
-import qualified LongIdentifierTest
-import qualified GeneratedColumnTestSQL
-import qualified ForeignKey
-import qualified ImplicitUuidSpec
 
 type Tuple a b = (a, b)
 
@@ -173,11 +176,10 @@ main = do
         SumTypeTest.specsWith db (Just (runMigrationSilent SumTypeTest.sumTypeMigrate))
         MigrationOnlyTest.specsWith db
             (Just $ do
-                runSqlCommand $ do
-                    rawExecute_ "DROP TABLE IF EXISTS two_field;" []
-                    rawExecute_ "DROP TABLE IF EXISTS referencing;" []
-                runMigrationSilent MigrationOnlyTest.migrateAll1
-                runMigrationSilent MigrationOnlyTest.migrateAll2
+                void $ rawExecute "DROP TABLE IF EXISTS referencing;" []
+                void $ rawExecute "DROP TABLE IF EXISTS two_field;" []
+                void $ runMigrationSilent MigrationOnlyTest.migrateAll1
+                void $ runMigrationSilent MigrationOnlyTest.migrateAll2
             )
         PersistentTest.specsWith db
         PersistentTest.filterOrSpecs db
diff --git a/persistent-postgresql/test/ImplicitUuidSpec.hs b/persistent-postgresql/test/ImplicitUuidSpec.hs
index 0520d516d..4f08b3d5e 100644
--- a/persistent-postgresql/test/ImplicitUuidSpec.hs
+++ b/persistent-postgresql/test/ImplicitUuidSpec.hs
@@ -52,7 +52,7 @@ pass :: IO ()
 pass = pure ()
 
 spec :: Spec
-spec = fdescribe "ImplicitUuidSpec" $ before_ wipe $ do
+spec = describe "ImplicitUuidSpec" $ before_ wipe $ do
     describe "WithDefUuidKey" $ do
         it "works on UUIDs" $ do
             let withDefUuidKey = WithDefUuidKey (UUID "Hello")
diff --git a/persistent-test/src/MigrationOnlyTest.hs b/persistent-test/src/MigrationOnlyTest.hs
index 2240b9045..e40dd9899 100644
--- a/persistent-test/src/MigrationOnlyTest.hs
+++ b/persistent-test/src/MigrationOnlyTest.hs
@@ -1,11 +1,14 @@
-{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TypeApplications, UndecidableInstances #-}
+
 {-# OPTIONS_GHC -Wno-unused-top-binds #-}
+
 module MigrationOnlyTest (specsWith, migrateAll1, migrateAll2) where
 
 import qualified Data.Text as T
 
 import Database.Persist.TH
 import Init
+import Database.Persist.EntityDef
 
 share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "migrateAll1"] [persistLowerCase|
 TwoField1 sql=two_field
@@ -33,6 +36,26 @@ specsWith
     -> Maybe (ReaderT backend m a)
     -> Spec
 specsWith runDb mmigrate = describe "MigrationOnly field" $ do
+    let
+        edef =
+            entityDef $ Proxy @TwoField
+    describe "getEntityFields" $ do
+        let
+            fields =
+                getEntityFields edef
+        it "should have two fields" $ do
+            length fields `shouldBe` 2
+        it "should not have any migration only fields" $ do
+            fields `shouldSatisfy` all isHaskellField
+
+    describe "getEntityFieldsDatabase" $ do
+        let
+            fields =
+                getEntityFieldsDatabase edef
+        it "should have three fields" $ 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/ChangeLog.md b/persistent/ChangeLog.md
index 97f8dc9d7..b6cb560cb 100644
--- a/persistent/ChangeLog.md
+++ b/persistent/ChangeLog.md
@@ -2,6 +2,14 @@
 
 ## 2.13.0.0 (unreleased)
 
+* [#1252](https://github.com/yesodweb/persistent/pull/1252)
+    * `mkMigrate` now defers to `mkEntityDefList` and `migrateModels` instead of
+      fixing the foreign key references itself.
+    * `mkSave` was deprecated - the function did not fix foreign key references.
+      Please use `mkEntityDefList` instead.
+    * `EntityDef` will now include fields marked `MigrationOnly` and
+      `SafeToRemove`. Beforehand, those were filtered out, and `mkMigrate`
+      applied
 * [#1225](https://github.com/yesodweb/persistent/pull/1225)
     * The fields and constructor for `SqlBackend` are no longer exported by
       default. They are available from an internal module,
diff --git a/persistent/Database/Persist/EntityDef.hs b/persistent/Database/Persist/EntityDef.hs
index 1d80d9592..68b5c72eb 100644
--- a/persistent/Database/Persist/EntityDef.hs
+++ b/persistent/Database/Persist/EntityDef.hs
@@ -10,6 +10,7 @@ module Database.Persist.EntityDef
     , getEntityHaskellName
     , getEntityDBName
     , getEntityFields
+    , getEntityFieldsDatabase
     , getEntityForeignDefs
     , getEntityUniques
     , getEntityId
@@ -30,6 +31,7 @@ import Data.Text (Text)
 import Data.Map (Map)
 
 import Database.Persist.EntityDef.Internal
+import Database.Persist.FieldDef (isHaskellField)
 
 import Database.Persist.Types.Base
     ( UniqueDef
@@ -92,11 +94,29 @@ getEntityForeignDefs = entityForeigns
 -- will return the key columns if you used the @Primary@ syntax for defining the
 -- primary key.
 --
+-- This does not return fields that are marked 'SafeToRemove' or 'MigrationOnly'
+-- - so it only returns fields that are represented in the Haskell type. If you
+-- need those fields, use 'getEntityFieldsDatabase'.
+--
 -- @since 2.13.0.0
 getEntityFields
     :: EntityDef
     -> [FieldDef]
-getEntityFields = entityFields
+getEntityFields = filter isHaskellField . entityFields
+
+-- | This returns all of the 'FieldDef' defined for the 'EntityDef', including
+-- those fields that are marked as 'MigrationOnly' (and therefore only present
+-- in the database) or 'SafeToRemove' (and a migration will drop the column if
+-- it exists in the database).
+--
+-- For all the fields that are present on the Haskell-type, see
+-- 'getEntityFields'.
+--
+-- @since 2.13.0.0
+getEntityFieldsDatabase
+    :: EntityDef
+    -> [FieldDef]
+getEntityFieldsDatabase = entityFields
 
 -- |
 --
@@ -125,12 +145,19 @@ getEntityKeyFields
     -> [FieldDef]
 getEntityKeyFields = entityKeyFields
 
+-- | TODO
+--
+-- @since 2.13.0.0
 setEntityFields :: [FieldDef] -> EntityDef -> EntityDef
 setEntityFields fd ed = ed { entityFields = fd }
 
+-- | Perform a mapping function over all of the entity fields, as determined by
+-- 'getEntityFieldsDatabase'.
+--
+-- @since 2.13.0.0
 overEntityFields
     :: ([FieldDef] -> [FieldDef])
     -> EntityDef
     -> EntityDef
 overEntityFields f ed =
-    setEntityFields (f (getEntityFields ed)) ed
+    setEntityFields (f (getEntityFieldsDatabase ed)) ed
diff --git a/persistent/Database/Persist/FieldDef.hs b/persistent/Database/Persist/FieldDef.hs
index d06d4ef0d..4f73d92a8 100644
--- a/persistent/Database/Persist/FieldDef.hs
+++ b/persistent/Database/Persist/FieldDef.hs
@@ -6,6 +6,7 @@ module Database.Persist.FieldDef
       FieldDef
       -- ** Helpers
     , isFieldNotGenerated
+    , isHaskellField
       -- * 'FieldCascade'
     , FieldCascade(..)
     , renderFieldCascade
@@ -15,3 +16,14 @@ module Database.Persist.FieldDef
     ) where
 
 import Database.Persist.FieldDef.Internal
+
+import Database.Persist.Types.Base (FieldAttr(..))
+
+-- | Returns 'True' if the 'FieldDef' does not have a 'MigrationOnly' or
+-- 'SafeToRemove' flag from the QuasiQuoter.
+--
+-- @since 2.13.0.0
+isHaskellField :: FieldDef -> Bool
+isHaskellField fd =
+    FieldAttrMigrationOnly `notElem` fieldAttrs fd &&
+    FieldAttrSafeToRemove `notElem` fieldAttrs fd
diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
index 8770fac9c..6bb09c8b6 100644
--- a/persistent/Database/Persist/TH.hs
+++ b/persistent/Database/Persist/TH.hs
@@ -70,6 +70,7 @@ module Database.Persist.TH
 import Prelude hiding (concat, exp, splitAt, take, (++))
 
 import Control.Monad
+import Control.Monad.IO.Class
 import Data.Aeson
        ( FromJSON(parseJSON)
        , ToJSON(toJSON)
@@ -320,7 +321,7 @@ instance Lift FieldSqlTypeExp where
 
 instance Lift EntityDefSqlTypeExp where
     lift (EntityDefSqlTypeExp ent sqlTypeExp sqlTypeExps) =
-        [|ent { entityFields = $(lift $ FieldsSqlTypeExp (getEntityFields ent) sqlTypeExps)
+        [|ent { entityFields = $(lift $ FieldsSqlTypeExp (getEntityFieldsDatabase ent) sqlTypeExps)
               , entityId = $(lift $ FieldSqlTypeExp (entityId ent) sqlTypeExp)
               }
         |]
@@ -404,13 +405,17 @@ setEmbedField entName allEntities field = field
 
 mkEntityDefSqlTypeExp :: EmbedEntityMap -> EntityMap -> EntityDef -> EntityDefSqlTypeExp
 mkEntityDefSqlTypeExp emEntities entityMap ent =
-    EntityDefSqlTypeExp ent (getSqlType $ entityId ent) (map getSqlType $ getEntityFields ent)
+    EntityDefSqlTypeExp ent (getSqlType $ entityId ent) (map getSqlType $ getEntityFieldsDatabase ent)
   where
     getSqlType field =
         maybe
             (defaultSqlTypeExp field)
             (SqlType' . SqlOther)
-            (listToMaybe $ mapMaybe (\case {FieldAttrSqltype x -> Just x; _ -> Nothing}) $ fieldAttrs field)
+            (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.
@@ -456,6 +461,11 @@ mkEntityDefSqlTypeExp emEntities entityMap ent =
 -- 'EntityDef's. Works well with the persist quasi-quoter.
 mkPersist :: MkPersistSettings -> [EntityDef] -> Q [Dec]
 mkPersist mps ents' = do
+    forM_ ents' $ \preEntDef ->
+        liftIO $ do
+            when (getEntityHaskellName preEntDef == EntityNameHS "HasMigrationOnly") $ do
+                void $ traverse print (entityFields preEntDef)
+
     requireExtensions
         [ [TypeFamilies], [GADTs, ExistentialQuantification]
         , [DerivingStrategies], [GeneralizedNewtypeDeriving], [StandaloneDeriving]
@@ -474,7 +484,7 @@ mkPersist mps ents' = do
         , symbolToFieldInstances
         ]
   where
-    ents = map (fixEntityDef . setDefaultIdFields mps) ents'
+    ents = map (setDefaultIdFields mps) ents'
     entityMap = constructEntityMap ents
 
 setDefaultIdFields :: MkPersistSettings -> EntityDef -> EntityDef
@@ -505,12 +515,14 @@ setDefaultIdFields mps ed
 
 -- | Implement special preprocessing on EntityDef as necessary for 'mkPersist'.
 -- For example, strip out any fields marked as MigrationOnly.
+--
+-- This should be called when performing Haskell codegen, but the 'EntityDef'
+-- *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 keepField)
-  where
-    keepField fd = FieldAttrMigrationOnly `notElem` fieldAttrs fd &&
-                   FieldAttrSafeToRemove `notElem` fieldAttrs fd
+    overEntityFields (filter isHaskellField)
 
 -- | Settings to be passed to the 'mkPersist' function.
 data MkPersistSettings = MkPersistSettings
@@ -1181,19 +1193,27 @@ fieldError tableName fieldName err = mconcat
     ]
 
 mkEntity :: EntityMap -> MkPersistSettings -> EntityDef -> Q [Dec]
-mkEntity entityMap mps entDef = do
+mkEntity entityMap mps preEntDef = do
+    liftIO $ do
+        when (getEntityHaskellName preEntDef == EntityNameHS "HasMigrationOnly") $ do
+            void $ traverse print (entityFields preEntDef)
     entityDefExp <-
         if mpsGeneric mps
-           then liftAndFixKeys entityMap entDef
-           else makePersistEntityDefExp mps entityMap entDef
-    let name = mkEntityDefName entDef
-    let clazz = ConT ''PersistEntity `AppT` genDataType
+           then liftAndFixKeys entityMap preEntDef
+           else makePersistEntityDefExp mps entityMap preEntDef
+    let
+        entDef = fixEntityDef preEntDef
+        genDataType = genericDataType mps entName backendT
+        entName = entityHaskell entDef
+        name = mkEntityDefName entDef
+        clazz = ConT ''PersistEntity `AppT` genDataType
+
     tpf <- mkToPersistFields mps entDef
     fpv <- mkFromPersistValues mps entDef
     utv <- mkUniqueToValues $ entityUniques entDef
     puk <- mkUniqueKeys entDef
     let primaryField = entityId entDef
-    fields <- mapM (mkField mps entDef) $ primaryField : getEntityFields entDef
+    fields <- mapM (mkField mps entDef) $ primaryField : getEntityFieldsDatabase entDef
     fkc <- mapM (mkForeignKeysComposite mps entDef) $ entityForeigns entDef
 
     toFieldNames <- mkToFieldNames $ entityUniques entDef
@@ -1290,9 +1310,6 @@ mkEntity entityMap mps entDef = do
         , FunD 'fieldLens lensClauses
         ]
       ] `mappend` lenses) `mappend` keyInstanceDecs
-  where
-    genDataType = genericDataType mps entName backendT
-    entName = entityHaskell entDef
 
 mkUniqueKeyInstances :: MkPersistSettings -> EntityDef -> Q [Dec]
 mkUniqueKeyInstances mps entDef = do
@@ -1509,6 +1526,9 @@ share :: [[EntityDef] -> Q [Dec]] -> [EntityDef] -> Q [Dec]
 share fs x = mconcat <$> mapM ($ x) fs
 
 -- | Save the @EntityDef@s passed in under the given name.
+--
+-- This function was deprecated in @persistent-2.13.0.0@. It doesn't properly
+-- fix foreign keys. Please refer to 'mkEntityDefList' for a replacement.
 mkSave :: String -> [EntityDef] -> Q [Dec]
 mkSave name' defs' = do
     let name = mkName name'
@@ -1517,6 +1537,8 @@ mkSave name' defs' = do
            , FunD name [normalClause [] defs]
            ]
 
+{-# DEPRECATED mkSave "This function is broken. mkEntityDefList is a drop-in replacement that will properly handle foreign keys correctly." #-}
+
 data Dep = Dep
     { depTarget :: EntityNameHS
     , depSourceTable :: EntityNameHS
@@ -1739,11 +1761,36 @@ derivePersistFieldJSON s = do
 -- migrateAll = 'migrateModels' entities
 -- @
 --
+-- The function 'mkMigrate' currently implements exactly this behavior now. If
+-- you're splitting up the entity definitions into separate files, then it is
+-- better to use the entity definition list and the concatenate all the models
+-- together into a big list to call with 'migrateModels'.
+--
+-- @
+-- module Foo where
+--
+--     share [mkPersist s, mkEntityDefList "fooModels"] ...
+--
+--
+-- module Bar where
+--
+--     share [mkPersist s, mkEntityDefList "barModels"] ...
+--
+-- module Migration where
+--
+--     import Foo
+--     import Bar
+--
+--     migrateAll = migrateModels (fooModels <> barModels)
+-- @
+--
 -- @since 2.13.0.0
 migrateModels :: [EntityDef] -> Migration
-migrateModels eds =
-    forM_ eds $ \ed ->
-        migrate eds ed
+migrateModels defs=
+    forM_ (filter isMigrated defs) $ \def ->
+        migrate defs def
+  where
+    isMigrated def = pack "no-migrate" `notElem` entityAttrs def
 
 -- | Creates a single function to perform all migrations for the entities
 -- defined here. One thing to be aware of is dependencies: if you have entities
@@ -1758,15 +1805,7 @@ migrateModels eds =
 mkMigrate :: String -> [EntityDef] -> Q [Dec]
 mkMigrate fun eds = do
     let entityDefListName = ("entityDefListFor" <> fun)
-    body <-
-        [|
-          let
-              defs = $(varE (mkName entityDefListName))
-              isMigrated def = pack "no-migrate" `notElem` entityAttrs def
-           in
-              forM_ (filter isMigrated defs) $ \def ->
-                  migrate defs def
-        |]
+    body <- [| migrateModels $(varE (mkName entityDefListName)) |]
     edList <- mkEntityDefList entityDefListName eds
     pure $ edList <>
         [ SigD (mkName fun) (ConT ''Migration)
diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal
index 35fbe6d42..7ded0e0cb 100644
--- a/persistent/persistent.cabal
+++ b/persistent/persistent.cabal
@@ -158,12 +158,13 @@ test-suite test
                       , TypeFamilies
 
     other-modules:   
+        Database.Persist.TH.ImplicitIdColSpec
+        Database.Persist.TH.MigrationOnlySpec
+        Database.Persist.TH.OverloadedLabelSpec
+        Database.Persist.TH.SharedPrimaryKeyImportedSpec
+        Database.Persist.TH.SharedPrimaryKeySpec
         Database.Persist.THSpec
         TemplateTestImports
-        Database.Persist.TH.SharedPrimaryKeySpec
-        Database.Persist.TH.SharedPrimaryKeyImportedSpec
-        Database.Persist.TH.OverloadedLabelSpec
-        Database.Persist.TH.ImplicitIdColSpec
     default-language: Haskell2010
 
 source-repository head
diff --git a/persistent/test/Database/Persist/TH/MigrationOnlySpec.hs b/persistent/test/Database/Persist/TH/MigrationOnlySpec.hs
new file mode 100644
index 000000000..ba12ea35d
--- /dev/null
+++ b/persistent/test/Database/Persist/TH/MigrationOnlySpec.hs
@@ -0,0 +1,53 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+{-# OPTIONS_GHC -ddump-splices #-}
+
+module Database.Persist.TH.MigrationOnlySpec where
+
+import TemplateTestImports
+
+import Data.Text (Text)
+
+import Database.Persist.ImplicitIdDef
+import Database.Persist.ImplicitIdDef.Internal (fieldTypeFromTypeable)
+
+mkPersist sqlSettings [persistLowerCase|
+
+HasMigrationOnly
+    name String
+    blargh Int MigrationOnly
+
+|]
+
+pass :: IO ()
+pass = pure ()
+
+asIO :: IO a -> IO a
+asIO = id
+
+spec :: Spec
+spec = describe "MigrationOnlySpec" $ do
+    fdescribe "HasMigrationOnly" $ do
+        let
+            edef =
+                entityDef $ Proxy @HasMigrationOnly
+        describe "getEntityFields" $ do
+            it "has one field" $ do
+                length (getEntityFields edef)
+                    `shouldBe` 1
+        describe "getEntityFieldsDatabase" $ do
+            it "has two fields" $ do
+                length (getEntityFieldsDatabase edef)
+                    `shouldBe` 2
diff --git a/persistent/test/Database/Persist/THSpec.hs b/persistent/test/Database/Persist/THSpec.hs
index 89fe8e805..6d5bdb805 100644
--- a/persistent/test/Database/Persist/THSpec.hs
+++ b/persistent/test/Database/Persist/THSpec.hs
@@ -47,6 +47,7 @@ import qualified Database.Persist.TH.SharedPrimaryKeySpec as SharedPrimaryKeySpe
 import qualified Database.Persist.TH.SharedPrimaryKeyImportedSpec as SharedPrimaryKeyImportedSpec
 import qualified Database.Persist.TH.OverloadedLabelSpec as OverloadedLabelSpec
 import qualified Database.Persist.TH.ImplicitIdColSpec as ImplicitIdColSpec
+import qualified Database.Persist.TH.MigrationOnlySpec as MigrationOnlySpec
 
 share [mkPersist sqlSettings { mpsGeneric = False, mpsDeriveInstances = [''Generic] }, mkDeleteCascade sqlSettings { mpsGeneric = False }] [persistUpperCase|
 
@@ -108,6 +109,7 @@ SharedPrimaryKeyWithCascade
 SharedPrimaryKeyWithCascadeAndCustomName
     Id (Key HasDefaultId) OnDeleteCascade sql=my_id
     name String
+
 |]
 
 share [mkPersist sqlSettings { mpsGeneric = False, mpsGenerateLenses = True }] [persistLowerCase|
@@ -136,11 +138,12 @@ instance Arbitrary Address where
     arbitrary = Address <$> arbitraryT <*> arbitraryT <*> arbitrary
 
 spec :: Spec
-spec = do
+spec = describe "THSpec" $ do
     OverloadedLabelSpec.spec
     SharedPrimaryKeySpec.spec
     SharedPrimaryKeyImportedSpec.spec
     ImplicitIdColSpec.spec
+    MigrationOnlySpec.spec
     describe "TestDefaultKeyCol" $ do
         let FieldDef{..} =
                 entityId (entityDef (Proxy @TestDefaultKeyCol))
diff --git a/persistent/test/main.hs b/persistent/test/main.hs
index 99c5d22ea..6335758af 100644
--- a/persistent/test/main.hs
+++ b/persistent/test/main.hs
@@ -30,10 +30,9 @@ import qualified Database.Persist.THSpec as THSpec
 
 main :: IO ()
 main = hspec $ do
-    describe "Database.Persist" $ do
-        describe "THSpec" THSpec.spec
+    describe "Database" $ describe "Persist" $ do
+        THSpec.spec
 
-    THSpec.spec
     describe "splitExtras" $ do
         let helloWorldTokens = Token "hello" :| [Token "world"]
             foobarbazTokens = Token "foo" :| [Token "bar", Token "baz"]

From 9b6b41ede02d4dc3bbd804245ab0f681cd2554a4 Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Mon, 26 Apr 2021 11:30:21 -0600
Subject: [PATCH 04/12] th specs work

---
 persistent/Database/Persist/TH.hs               | 17 +++++------------
 .../Database/Persist/TH/MigrationOnlySpec.hs    |  4 +---
 2 files changed, 6 insertions(+), 15 deletions(-)

diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
index 6bb09c8b6..a954729b2 100644
--- a/persistent/Database/Persist/TH.hs
+++ b/persistent/Database/Persist/TH.hs
@@ -461,11 +461,6 @@ mkEntityDefSqlTypeExp emEntities entityMap ent =
 -- 'EntityDef's. Works well with the persist quasi-quoter.
 mkPersist :: MkPersistSettings -> [EntityDef] -> Q [Dec]
 mkPersist mps ents' = do
-    forM_ ents' $ \preEntDef ->
-        liftIO $ do
-            when (getEntityHaskellName preEntDef == EntityNameHS "HasMigrationOnly") $ do
-                void $ traverse print (entityFields preEntDef)
-
     requireExtensions
         [ [TypeFamilies], [GADTs, ExistentialQuantification]
         , [DerivingStrategies], [GeneralizedNewtypeDeriving], [StandaloneDeriving]
@@ -1194,13 +1189,11 @@ fieldError tableName fieldName err = mconcat
 
 mkEntity :: EntityMap -> MkPersistSettings -> EntityDef -> Q [Dec]
 mkEntity entityMap mps preEntDef = do
-    liftIO $ do
-        when (getEntityHaskellName preEntDef == EntityNameHS "HasMigrationOnly") $ do
-            void $ traverse print (entityFields preEntDef)
     entityDefExp <-
-        if mpsGeneric mps
-           then liftAndFixKeys entityMap preEntDef
-           else makePersistEntityDefExp mps entityMap preEntDef
+        liftAndFixKeys entityMap preEntDef
+--        if mpsGeneric mps
+--           then liftAndFixKeys entityMap preEntDef
+--           else makePersistEntityDefExp mps entityMap preEntDef
     let
         entDef = fixEntityDef preEntDef
         genDataType = genericDataType mps entName backendT
@@ -1997,7 +1990,7 @@ requirePersistentExtensions = requireExtensions requiredExtensions
 
 mkSymbolToFieldInstances :: MkPersistSettings -> EntityDef -> Q [Dec]
 mkSymbolToFieldInstances mps ed = do
-    fmap join $ forM (keyAndEntityFields ed) $ \fieldDef -> do
+    fmap join $ forM (keyAndEntityFields (fixEntityDef ed)) $ \fieldDef -> do
         let fieldNameT :: Q Type
             fieldNameT =
                 litT $ strTyLit
diff --git a/persistent/test/Database/Persist/TH/MigrationOnlySpec.hs b/persistent/test/Database/Persist/TH/MigrationOnlySpec.hs
index ba12ea35d..aebf53a7f 100644
--- a/persistent/test/Database/Persist/TH/MigrationOnlySpec.hs
+++ b/persistent/test/Database/Persist/TH/MigrationOnlySpec.hs
@@ -12,8 +12,6 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
 
-{-# OPTIONS_GHC -ddump-splices #-}
-
 module Database.Persist.TH.MigrationOnlySpec where
 
 import TemplateTestImports
@@ -39,7 +37,7 @@ asIO = id
 
 spec :: Spec
 spec = describe "MigrationOnlySpec" $ do
-    fdescribe "HasMigrationOnly" $ do
+    describe "HasMigrationOnly" $ do
         let
             edef =
                 entityDef $ Proxy @HasMigrationOnly

From ca945d56cfdda27f894c573cd3d73ffd045de00a Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Mon, 26 Apr 2021 11:44:23 -0600
Subject: [PATCH 05/12] fixed mkColumns

---
 persistent-mysql/Database/Persist/MySQL.hs    |  8 ++---
 .../Database/Persist/Postgresql.hs            |  6 ++--
 persistent-postgresql/test/PgInit.hs          |  2 --
 persistent-sqlite/Database/Persist/Sqlite.hs  |  6 ++--
 persistent/Database/Persist/Quasi/Internal.hs |  6 ----
 persistent/Database/Persist/Sql/Internal.hs   |  2 +-
 persistent/Database/Persist/TH.hs             | 29 +------------------
 7 files changed, 12 insertions(+), 47 deletions(-)

diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs
index 34229e070..8b27b1cf5 100644
--- a/persistent-mysql/Database/Persist/MySQL.hs
+++ b/persistent-mysql/Database/Persist/MySQL.hs
@@ -500,7 +500,7 @@ findTypeOfColumn allDefs name col =
         ((,) col)
         $ do
             entDef   <- find ((== name) . getEntityDBName) allDefs
-            fieldDef <- find ((== col)  . fieldDB) (getEntityFields entDef)
+            fieldDef <- find ((== col)  . fieldDB) (getEntityFieldsDatabase entDef)
             return (fieldType fieldDef)
 
 -- | Find out the maxlen of a column (default to 200)
@@ -509,7 +509,7 @@ findMaxLenOfColumn allDefs name col =
    maybe (col, 200)
          ((,) col) $ do
            entDef     <- find ((== name) . getEntityDBName) allDefs
-           fieldDef   <- find ((== col) . fieldDB) (getEntityFields entDef)
+           fieldDef   <- find ((== col) . fieldDB) (getEntityFieldsDatabase entDef)
            findMaxLenOfField fieldDef
 
 -- | Find out the maxlen of a field
@@ -1484,7 +1484,7 @@ mkBulkInsertQuery records fieldValues updates =
     firstField = case entityFieldNames of
         [] -> error "The entity you're trying to insert does not have any fields."
         (field:_) -> field
-    entityFieldNames = map fieldDbToText (getEntityFields entityDef')
+    entityFieldNames = map fieldDbToText (getEntityFieldsDatabase entityDef')
     tableName = T.pack . escapeE . getEntityDBName $ entityDef'
     copyUnlessValues = map snd fieldsToMaybeCopy
     recordValues = concatMap (map toPersistValue . toPersistFields) records
@@ -1521,7 +1521,7 @@ mkBulkInsertQuery records fieldValues updates =
 putManySql :: EntityDef -> Int -> Text
 putManySql ent n = putManySql' fields ent n
   where
-    fields = getEntityFields ent
+    fields = getEntityFieldsDatabase ent
 
 repsertManySql :: EntityDef -> Int -> Text
 repsertManySql ent n = putManySql' fields ent n
diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs
index e783a1234..6e980ad8f 100644
--- a/persistent-postgresql/Database/Persist/Postgresql.hs
+++ b/persistent-postgresql/Database/Persist/Postgresql.hs
@@ -398,7 +398,7 @@ insertSql' ent vals =
     sql = T.concat
         [ "INSERT INTO "
         , escapeE $ getEntityDBName ent
-        , if null (getEntityFields ent)
+        , if null (getEntityFieldsDatabase ent)
             then " DEFAULT VALUES"
             else T.concat
                 [ "("
@@ -1738,7 +1738,7 @@ mockMigration mig = do
 putManySql :: EntityDef -> Int -> Text
 putManySql ent n = putManySql' conflictColumns fields ent n
   where
-    fields = getEntityFields ent
+    fields = getEntityFieldsDatabase ent
     conflictColumns = concatMap (map (escapeF . snd) . uniqueFields) (getEntityUniques ent)
 
 repsertManySql :: EntityDef -> Int -> Text
@@ -1928,7 +1928,7 @@ mkBulkUpsertQuery records conn fieldValues updates filters uniqDef =
     firstField = case entityFieldNames of
         [] -> error "The entity you're trying to insert does not have any fields."
         (field:_) -> field
-    entityFieldNames = map fieldDbToText (getEntityFields entityDef')
+    entityFieldNames = map fieldDbToText (getEntityFieldsDatabase entityDef')
     nameOfTable = escapeE . getEntityDBName $ entityDef'
     copyUnlessValues = map snd fieldsToMaybeCopy
     recordValues = concatMap (map toPersistValue . toPersistFields) records
diff --git a/persistent-postgresql/test/PgInit.hs b/persistent-postgresql/test/PgInit.hs
index 0faf89ac0..dec295ad7 100644
--- a/persistent-postgresql/test/PgInit.hs
+++ b/persistent-postgresql/test/PgInit.hs
@@ -107,8 +107,6 @@ import qualified Data.Text.Encoding as TE
 import Test.HUnit (Assertion, assertBool, assertFailure, (@=?), (@?=))
 import Test.QuickCheck
 
-import Web.PathPieces
-import Web.Internal.HttpApiData
 import Control.Monad (unless, (>=>))
 import Control.Monad.IO.Unlift (MonadUnliftIO)
 import Control.Monad.Logger
diff --git a/persistent-sqlite/Database/Persist/Sqlite.hs b/persistent-sqlite/Database/Persist/Sqlite.hs
index 0e4d58867..65743cf03 100644
--- a/persistent-sqlite/Database/Persist/Sqlite.hs
+++ b/persistent-sqlite/Database/Persist/Sqlite.hs
@@ -375,7 +375,7 @@ insertSql' ent vals =
     notGenerated =
         isNothing . fieldGenerated
     cols =
-        filter notGenerated $ getEntityFields ent
+        filter notGenerated $ getEntityFieldsDatabase ent
 
 execute' :: Sqlite.Connection -> Sqlite.Statement -> [PersistValue] -> IO Int64
 execute' conn stmt vals = flip finally (liftIO $ Sqlite.reset conn stmt) $ do
@@ -497,7 +497,7 @@ safeToRemove :: EntityDef -> FieldNameDB -> Bool
 safeToRemove def (FieldNameDB colName)
     = any (elem FieldAttrSafeToRemove . fieldAttrs)
     $ filter ((== FieldNameDB colName) . fieldDB)
-    $ getEntityFields def
+    $ getEntityFieldsDatabase def
 
 getCopyTable :: [EntityDef]
              -> (Text -> IO Statement)
@@ -674,7 +674,7 @@ escape s =
 putManySql :: EntityDef -> Int -> Text
 putManySql ent n = putManySql' conflictColumns fields ent n
   where
-    fields = getEntityFields ent
+    fields = getEntityFieldsDatabase ent
     conflictColumns = concatMap (map (escapeF . snd) . uniqueFields) (getEntityUniques ent)
 
 repsertManySql :: EntityDef -> Int -> Text
diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs
index 27ab77d45..acf565548 100644
--- a/persistent/Database/Persist/Quasi/Internal.hs
+++ b/persistent/Database/Persist/Quasi/Internal.hs
@@ -407,12 +407,6 @@ overUnboundEntityDef
 overUnboundEntityDef f ubed =
     ubed { unboundEntityDef = f (unboundEntityDef ubed) }
 
-lookupKeyVal :: Text -> [Text] -> Maybe Text
-lookupKeyVal key = lookupPrefix $ key `mappend` "="
-
-lookupPrefix :: Text -> [Text] -> Maybe Text
-lookupPrefix prefix = msum . map (T.stripPrefix prefix)
-
 -- | Construct an entity definition.
 mkEntityDef
     :: PersistSettings
diff --git a/persistent/Database/Persist/Sql/Internal.hs b/persistent/Database/Persist/Sql/Internal.hs
index 15b6222ac..f3b6598c5 100644
--- a/persistent/Database/Persist/Sql/Internal.hs
+++ b/persistent/Database/Persist/Sql/Internal.hs
@@ -85,7 +85,7 @@ mkColumns allDefs t overrides =
     (cols, getEntityUniques t, getEntityForeignDefs t)
   where
     cols :: [Column]
-    cols = map goId idCol `mappend` map go (getEntityFields t)
+    cols = map goId idCol `mappend` map go (getEntityFieldsDatabase t)
 
     idCol :: [FieldDef]
     idCol = case entityPrimary t of
diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
index a954729b2..c05ebb756 100644
--- a/persistent/Database/Persist/TH.hs
+++ b/persistent/Database/Persist/TH.hs
@@ -70,7 +70,6 @@ module Database.Persist.TH
 import Prelude hiding (concat, exp, splitAt, take, (++))
 
 import Control.Monad
-import Control.Monad.IO.Class
 import Data.Aeson
        ( FromJSON(parseJSON)
        , ToJSON(toJSON)
@@ -1189,11 +1188,7 @@ fieldError tableName fieldName err = mconcat
 
 mkEntity :: EntityMap -> MkPersistSettings -> EntityDef -> Q [Dec]
 mkEntity entityMap mps preEntDef = do
-    entityDefExp <-
-        liftAndFixKeys entityMap preEntDef
---        if mpsGeneric mps
---           then liftAndFixKeys entityMap preEntDef
---           else makePersistEntityDefExp mps entityMap preEntDef
+    entityDefExp <- liftAndFixKeys entityMap preEntDef
     let
         entDef = fixEntityDef preEntDef
         genDataType = genericDataType mps entName backendT
@@ -1805,28 +1800,6 @@ mkMigrate fun eds = do
         , FunD (mkName fun) [normalClause [] body]
         ]
 
-makePersistEntityDefExp :: MkPersistSettings -> EntityMap -> EntityDef -> Q Exp
-makePersistEntityDefExp mps entityMap entDef@EntityDef{..} =
-    [|EntityDef
-        entityHaskell
-        entityDB
-        $(liftAndFixKey entityMap entityId)
-        entityAttrs
-        $(fieldDefReferences mps entDef entityFields)
-        entityUniques
-        entityForeigns
-        entityDerives
-        entityExtra
-        entitySum
-        entityComments
-    |]
-
-fieldDefReferences :: MkPersistSettings -> EntityDef -> [FieldDef] -> Q Exp
-fieldDefReferences mps entDef fieldDefs =
-  fmap ListE $ forM fieldDefs $ \fieldDef -> do
-    let fieldDefConE = ConE (filterConName mps entDef fieldDef)
-    pure $ VarE 'persistFieldDef `AppE` fieldDefConE
-
 liftAndFixKeys :: EntityMap -> EntityDef -> Q Exp
 liftAndFixKeys entityMap EntityDef{..} =
     [|EntityDef

From ca7bad5965e545f4812db715c19ed87a2f2199a8 Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Mon, 26 Apr 2021 11:45:23 -0600
Subject: [PATCH 06/12] changelog entry

---
 persistent/ChangeLog.md | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md
index b6cb560cb..b79957aee 100644
--- a/persistent/ChangeLog.md
+++ b/persistent/ChangeLog.md
@@ -9,7 +9,8 @@
       Please use `mkEntityDefList` instead.
     * `EntityDef` will now include fields marked `MigrationOnly` and
       `SafeToRemove`. Beforehand, those were filtered out, and `mkMigrate`
-      applied
+      applied. The function `getEntityFields` wll only return fields defiend on
+      the Haskell type - for all columns, see `getEntityFieldsDatabase`.
 * [#1225](https://github.com/yesodweb/persistent/pull/1225)
     * The fields and constructor for `SqlBackend` are no longer exported by
       default. They are available from an internal module,

From dc73c82b9e7df736e10baeca1c18ddb7b6caaad8 Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Mon, 26 Apr 2021 16:27:27 -0600
Subject: [PATCH 07/12] fix mongo

---
 .../Database/Persist/MongoDB.hs               |  2 +-
 persistent-test/src/Recursive.hs              |  5 ++
 persistent/Database/Persist/FieldDef.hs       | 12 +---
 persistent/Database/Persist/Quasi/Internal.hs | 12 +++-
 persistent/Database/Persist/TH.hs             |  3 +-
 persistent/Database/Persist/Types/Base.hs     | 37 +++++++++----
 persistent/persistent.cabal                   |  1 +
 .../test/Database/Persist/TH/EmbedSpec.hs     | 55 +++++++++++++++++++
 .../Database/Persist/TH/MigrationOnlySpec.hs  | 14 +++++
 persistent/test/Database/Persist/THSpec.hs    |  2 +
 10 files changed, 119 insertions(+), 24 deletions(-)
 create mode 100644 persistent/test/Database/Persist/TH/EmbedSpec.hs

diff --git a/persistent-mongoDB/Database/Persist/MongoDB.hs b/persistent-mongoDB/Database/Persist/MongoDB.hs
index 96ef4b3d6..409b8ae3e 100644
--- a/persistent-mongoDB/Database/Persist/MongoDB.hs
+++ b/persistent-mongoDB/Database/Persist/MongoDB.hs
@@ -659,7 +659,7 @@ collectionNameFromKey = collectionName . recordTypeFromKey
 
 projectionFromEntityDef :: EntityDef -> DB.Projector
 projectionFromEntityDef eDef =
-  map toField (getEntityFields eDef)
+  map toField (getEntityFieldsDatabase eDef)
   where
     toField :: FieldDef -> DB.Field
     toField fDef = (unFieldNameDB (fieldDB fDef)) DB.=: (1 :: Int)
diff --git a/persistent-test/src/Recursive.hs b/persistent-test/src/Recursive.hs
index 3173b4c37..1991692b4 100644
--- a/persistent-test/src/Recursive.hs
+++ b/persistent-test/src/Recursive.hs
@@ -1,16 +1,21 @@
 {-# LANGUAGE UndecidableInstances #-}
+
 {-# OPTIONS_GHC -Wno-unused-top-binds #-}
+
 module Recursive (specsWith, recursiveMigrate, cleanup) where
 
 import Init
 
 share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "recursiveMigrate"] [persistLowerCase|
+
 SubType
   object [MenuObject]
   deriving Show Eq
+
 MenuObject
   sub SubType Maybe
   deriving Show Eq
+
 |]
 
 cleanup
diff --git a/persistent/Database/Persist/FieldDef.hs b/persistent/Database/Persist/FieldDef.hs
index 4f73d92a8..183883900 100644
--- a/persistent/Database/Persist/FieldDef.hs
+++ b/persistent/Database/Persist/FieldDef.hs
@@ -17,13 +17,7 @@ module Database.Persist.FieldDef
 
 import Database.Persist.FieldDef.Internal
 
-import Database.Persist.Types.Base (FieldAttr(..))
+import Database.Persist.Types.Base
+    ( isHaskellField
+    )
 
--- | Returns 'True' if the 'FieldDef' does not have a 'MigrationOnly' or
--- 'SafeToRemove' flag from the QuasiQuoter.
---
--- @since 2.13.0.0
-isHaskellField :: FieldDef -> Bool
-isHaskellField fd =
-    FieldAttrMigrationOnly `notElem` fieldAttrs fd &&
-    FieldAttrSafeToRemove `notElem` fieldAttrs fd
diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs
index acf565548..3215292e6 100644
--- a/persistent/Database/Persist/Quasi/Internal.hs
+++ b/persistent/Database/Persist/Quasi/Internal.hs
@@ -459,10 +459,20 @@ mkEntityDef ps name entattribs lines =
             _ ->
                 case (setFieldComments comments <$> takeColsEx ps (tokenText <$> x)) of
                   Just sm ->
-                      (sm : acc, [])
+                      (maybeSetSelfReference sm : acc, [])
                   Nothing ->
                       (acc, [])
 
+    maybeSetSelfReference field =
+        case fieldType field of
+            FTTypeCon Nothing x
+                | x == name ->
+                    field
+                        { fieldReference =
+                            SelfReference
+                        }
+            _ ->
+                field
     autoIdField = mkAutoIdField ps entName idSqlType
     idSqlType = maybe SqlInt64 (const $ SqlOther "Primary Key") primaryComposite
 
diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
index c05ebb756..d80787955 100644
--- a/persistent/Database/Persist/TH.hs
+++ b/persistent/Database/Persist/TH.hs
@@ -395,7 +395,8 @@ setEmbedField entName allEntities field = field
                              then EmbedRef em
                         else if maybeNullable field
                              then SelfReference
-                        else case fieldType field of
+                        else
+                            case fieldType field of
                                  FTList _ -> SelfReference
                                  _ -> error $ unpack $ unEntityNameHS entName <> ": a self reference must be a Maybe"
             existing ->
diff --git a/persistent/Database/Persist/Types/Base.hs b/persistent/Database/Persist/Types/Base.hs
index 5650e49de..3b206061e 100644
--- a/persistent/Database/Persist/Types/Base.hs
+++ b/persistent/Database/Persist/Types/Base.hs
@@ -297,24 +297,37 @@ data EmbedFieldDef = EmbedFieldDef
     }
     deriving (Show, Eq, Read, Ord, Lift)
 
+-- | Returns 'True' if the 'FieldDef' does not have a 'MigrationOnly' or
+-- 'SafeToRemove' flag from the QuasiQuoter.
+--
+-- @since 2.13.0.0
+isHaskellField :: FieldDef -> Bool
+isHaskellField fd =
+    FieldAttrMigrationOnly `notElem` fieldAttrs fd &&
+    FieldAttrSafeToRemove `notElem` fieldAttrs fd
+
 toEmbedEntityDef :: EntityDef -> EmbedEntityDef
 toEmbedEntityDef ent = embDef
   where
     embDef = EmbedEntityDef
-      { embeddedHaskell = entityHaskell ent
-      , embeddedFields = map toEmbedFieldDef $ entityFields ent
-      }
+        { embeddedHaskell = entityHaskell ent
+        , embeddedFields = map toEmbedFieldDef $ filter isHaskellField $ entityFields ent
+        }
     toEmbedFieldDef :: FieldDef -> EmbedFieldDef
     toEmbedFieldDef field =
-      EmbedFieldDef { emFieldDB       = fieldDB field
-                    , emFieldEmbed = case fieldReference field of
-                        EmbedRef em -> Just em
-                        SelfReference -> Just embDef
-                        _ -> Nothing
-                    , emFieldCycle = case fieldReference field of
-                        SelfReference -> Just $ entityHaskell ent
-                        _ -> Nothing
-                    }
+        EmbedFieldDef
+          { emFieldDB =
+              fieldDB field
+          , emFieldEmbed =
+              case fieldReference field of
+                  EmbedRef em -> Just em
+                  SelfReference -> Just embDef
+                  _ -> Nothing
+          , emFieldCycle =
+              case fieldReference field of
+                  SelfReference -> Just $ entityHaskell ent
+                  _ -> Nothing
+          }
 
 -- | Type for storing the Uniqueness constraint in the Schema.  Assume you have
 -- the following schema with a uniqueness constraint:
diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal
index 7ded0e0cb..05d7800da 100644
--- a/persistent/persistent.cabal
+++ b/persistent/persistent.cabal
@@ -158,6 +158,7 @@ test-suite test
                       , TypeFamilies
 
     other-modules:   
+        Database.Persist.TH.EmbedSpec
         Database.Persist.TH.ImplicitIdColSpec
         Database.Persist.TH.MigrationOnlySpec
         Database.Persist.TH.OverloadedLabelSpec
diff --git a/persistent/test/Database/Persist/TH/EmbedSpec.hs b/persistent/test/Database/Persist/TH/EmbedSpec.hs
new file mode 100644
index 000000000..c0eca8798
--- /dev/null
+++ b/persistent/test/Database/Persist/TH/EmbedSpec.hs
@@ -0,0 +1,55 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Database.Persist.TH.EmbedSpec where
+
+import TemplateTestImports
+
+import Data.Text (Text)
+
+import Database.Persist.ImplicitIdDef
+import Database.Persist.ImplicitIdDef.Internal (fieldTypeFromTypeable)
+import Database.Persist.Types
+
+mkPersist sqlSettings [persistLowerCase|
+
+Thing
+    name String
+
+    deriving Eq Show
+
+EmbedThing
+    someThing Thing
+
+    deriving Eq Show
+
+SelfEmbed
+    name Text
+    self SelfEmbed Maybe
+    deriving Eq Show
+|]
+
+pass :: IO ()
+pass = pure ()
+
+asIO :: IO a -> IO a
+asIO = id
+
+spec :: Spec
+spec = describe "EmbedSpec" $ do
+    describe "EmbedThing" $ do
+        it "generates" $ do
+            let embedThing :: EmbedThing
+                embedThing = EmbedThing (Thing "asdf")
+            pass
diff --git a/persistent/test/Database/Persist/TH/MigrationOnlySpec.hs b/persistent/test/Database/Persist/TH/MigrationOnlySpec.hs
index aebf53a7f..bc1ff419f 100644
--- a/persistent/test/Database/Persist/TH/MigrationOnlySpec.hs
+++ b/persistent/test/Database/Persist/TH/MigrationOnlySpec.hs
@@ -20,6 +20,7 @@ import Data.Text (Text)
 
 import Database.Persist.ImplicitIdDef
 import Database.Persist.ImplicitIdDef.Internal (fieldTypeFromTypeable)
+import Database.Persist.Types
 
 mkPersist sqlSettings [persistLowerCase|
 
@@ -27,6 +28,7 @@ HasMigrationOnly
     name String
     blargh Int MigrationOnly
 
+    deriving Eq Show
 |]
 
 pass :: IO ()
@@ -49,3 +51,15 @@ spec = describe "MigrationOnlySpec" $ do
             it "has two fields" $ do
                 length (getEntityFieldsDatabase edef)
                     `shouldBe` 2
+        describe "toPersistFields" $ do
+            it "should have one field" $ do
+                map toPersistValue (toPersistFields (HasMigrationOnly "asdf"))
+                    `shouldBe`
+                        map toPersistValue [SomePersistField ("asdf" :: Text)]
+        describe "fromPersistValues" $ do
+            it "should work with only item in list" $ do
+                fromPersistValues [PersistText "Hello"]
+                    `shouldBe`
+                        Right (HasMigrationOnly "Hello")
+
+
diff --git a/persistent/test/Database/Persist/THSpec.hs b/persistent/test/Database/Persist/THSpec.hs
index 6d5bdb805..dac6f5019 100644
--- a/persistent/test/Database/Persist/THSpec.hs
+++ b/persistent/test/Database/Persist/THSpec.hs
@@ -48,6 +48,7 @@ import qualified Database.Persist.TH.SharedPrimaryKeyImportedSpec as SharedPrima
 import qualified Database.Persist.TH.OverloadedLabelSpec as OverloadedLabelSpec
 import qualified Database.Persist.TH.ImplicitIdColSpec as ImplicitIdColSpec
 import qualified Database.Persist.TH.MigrationOnlySpec as MigrationOnlySpec
+import qualified Database.Persist.TH.EmbedSpec as EmbedSpec
 
 share [mkPersist sqlSettings { mpsGeneric = False, mpsDeriveInstances = [''Generic] }, mkDeleteCascade sqlSettings { mpsGeneric = False }] [persistUpperCase|
 
@@ -144,6 +145,7 @@ spec = describe "THSpec" $ do
     SharedPrimaryKeyImportedSpec.spec
     ImplicitIdColSpec.spec
     MigrationOnlySpec.spec
+    EmbedSpec.spec
     describe "TestDefaultKeyCol" $ do
         let FieldDef{..} =
                 entityId (entityDef (Proxy @TestDefaultKeyCol))

From 5d319b1fb2032442dd4897ea203165c121cee80e Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Mon, 26 Apr 2021 17:08:38 -0600
Subject: [PATCH 08/12] no idea why this is broken now

---
 persistent/Database/Persist/Quasi/Internal.hs |  26 ++--
 .../Database/Persist/Sql/Types/Internal.hs    |   1 -
 persistent/Database/Persist/TH.hs             | 144 ++++++------------
 persistent/Database/Persist/Types/Base.hs     |   2 +-
 .../test/Database/Persist/TH/EmbedSpec.hs     |   7 +
 5 files changed, 74 insertions(+), 106 deletions(-)

diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs
index 3215292e6..b066585ae 100644
--- a/persistent/Database/Persist/Quasi/Internal.hs
+++ b/persistent/Database/Persist/Quasi/Internal.hs
@@ -463,16 +463,24 @@ mkEntityDef ps name entattribs lines =
                   Nothing ->
                       (acc, [])
 
-    maybeSetSelfReference field =
-        case fieldType field of
-            FTTypeCon Nothing x
-                | x == name ->
+    maybeSetSelfReference field = go (fieldType field)
+      where
+        go ft =
+            case ft of
+                FTTypeCon Nothing x
+                    | x == name ->
+                        field
+                            { fieldReference =
+                                SelfReference
+                            }
+                    | otherwise ->
+                        field
+                FTTypeCon _ _ ->
+                    field
+                FTList ft' ->
+                    go ft'
+                _ ->
                     field
-                        { fieldReference =
-                            SelfReference
-                        }
-            _ ->
-                field
     autoIdField = mkAutoIdField ps entName idSqlType
     idSqlType = maybe SqlInt64 (const $ SqlOther "Primary Key") primaryComposite
 
diff --git a/persistent/Database/Persist/Sql/Types/Internal.hs b/persistent/Database/Persist/Sql/Types/Internal.hs
index 831071e7d..da3983be7 100644
--- a/persistent/Database/Persist/Sql/Types/Internal.hs
+++ b/persistent/Database/Persist/Sql/Types/Internal.hs
@@ -42,7 +42,6 @@ import Database.Persist.Class
     , BackendCompatible(..)
     )
 import Database.Persist.Class.PersistStore (IsPersistBackend (..))
-import Database.Persist.Types
 import Database.Persist.SqlBackend.Internal
 import Database.Persist.SqlBackend.Internal.InsertSqlResult
 import Database.Persist.SqlBackend.Internal.MkSqlBackend
diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
index d0fa517f6..12ec743a4 100644
--- a/persistent/Database/Persist/TH.hs
+++ b/persistent/Database/Persist/TH.hs
@@ -47,7 +47,6 @@ module Database.Persist.TH
       -- * Various other TH functions
     , mkMigrate
     , migrateModels
-    , discoverEntities
     , mkSave
     , mkDeleteCascade
     , mkEntityDefList
@@ -70,6 +69,7 @@ module Database.Persist.TH
 
 import Prelude hiding (concat, exp, splitAt, take, (++))
 
+import qualified Debug.Trace as Debug
 import Control.Monad
 import Data.Aeson
        ( FromJSON(parseJSON)
@@ -91,7 +91,7 @@ import Data.Ix (Ix)
 import Data.List (foldl')
 import qualified Data.List as List
 import qualified Data.List.NonEmpty as NEL
-import qualified Data.Map as M
+import qualified Data.Map.Strict as M
 import Data.Maybe (fromMaybe, isJust, listToMaybe, mapMaybe)
 import Data.Monoid (mappend, mconcat, (<>))
 import Data.Proxy (Proxy(Proxy))
@@ -235,13 +235,16 @@ embedEntityDefsMap rawEnts = (embedEntityMap, noCycleEnts)
         let entName = getEntityHaskellName entDef
          in overEntityFields (map (breakCycleField entName)) entDef
 
-    breakCycleField entName f = case f of
-        FieldDef { fieldReference = EmbedRef em } ->
-            f { fieldReference = EmbedRef $ breakCycleEmbed [entName] em }
-        _ ->
-            f
+    breakCycleField entName f =
+        case fieldReference f of
+            EmbedRef em ->
+                Debug.trace "breakCycleField, hit embedRef" $
+                f { fieldReference = EmbedRef $ breakCycleEmbed [entName] em }
+            _ ->
+                f
 
     breakCycleEmbed ancestors em =
+        Debug.trace ("Ancestors: " <> show ancestors) $
         em { embeddedFields = breakCycleEmField (emName : ancestors) <$> embeddedFields em
            }
         where
@@ -249,8 +252,11 @@ embedEntityDefsMap rawEnts = (embedEntityMap, noCycleEnts)
 
     breakCycleEmField ancestors emf = case embeddedHaskell <$> membed of
         Nothing -> emf
-        Just embName -> if embName `elem` ancestors
-            then emf { emFieldEmbed = Nothing, emFieldCycle = Just embName }
+        Just embName ->
+            if embName `elem` ancestors
+            then
+                Debug.trace ("emFieldCycle: " <> show embName) $
+                emf { emFieldEmbed = Nothing, emFieldCycle = Just embName }
             else emf { emFieldEmbed = breakCycleEmbed ancestors <$> membed }
         where
             membed = emFieldEmbed emf
@@ -359,44 +365,65 @@ mEmbedded
     -> FieldType
     -> Either (Maybe FTTypeConDescr) EmbedEntityDef
 mEmbedded _ (FTTypeCon Just{} _) =
+    Debug.trace "Hit a qualified type" $
     Left Nothing
 mEmbedded ents (FTTypeCon Nothing (EntityNameHS -> name)) =
+    Debug.trace ("Looking up " <> show name) $
     maybe (Left Nothing) Right $ M.lookup name ents
 mEmbedded ents (FTList x) =
+    Debug.trace "Hit FTList, recurring" $
     mEmbedded ents x
 mEmbedded ents (FTApp x y) =
+    Debug.trace "Hit FTApp" $
     -- 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
+        then
+            Debug.trace ("Got a key constructor") $
+            Left $ Just FTKeyCon
+        else
+            Debug.trace ("else branch, recurring on " <> show y) $
+            mEmbedded ents y
 
 setEmbedField :: EntityNameHS -> EmbedEntityMap -> FieldDef -> FieldDef
-setEmbedField entName allEntities field = field
+setEmbedField entName allEntities field = Debug.traceShowId $ field
     { fieldReference =
+        Debug.trace ("setEmbedField for " <> show entName) $
+        Debug.trace ("field name: " <> show (fieldDB field)) $
+        Debug.trace ("field ref: " <> show (fieldReference field)) $
+        Debug.trace ("field typ: " <> show (fieldType field)) $
         case fieldReference field of
             NoReference ->
+                Debug.trace "On NoReference..." $
                 case mEmbedded allEntities (fieldType field) of
                     Left _ ->
+                        Debug.trace "On LeftNothing..." $
                         case stripId $ fieldType field of
                             Nothing ->
+                                Debug.trace "No ID on fieldType" $
                                 NoReference
                             Just name ->
+                                Debug.trace ("Found a name: " <> show name) $
                                 case M.lookup (EntityNameHS name) allEntities of
                                     Nothing ->
+                                        Debug.trace "Name not in allEntities" $
                                         NoReference
                                     Just _ ->
+                                        Debug.trace "Found it!" $
                                         ForeignRef
                                             (EntityNameHS name)
                                             -- This can get corrected in mkEntityDefSqlTypeExp
                                             (FTTypeCon (Just "Data.Int") "Int64")
                     Right em ->
+                        Debug.trace ("on Right em: " <> show em) $
+                        Debug.trace ("embedded Haskell: " <> do show $ embeddedHaskell em) $
                         if embeddedHaskell em /= entName
                              then EmbedRef em
                         else if maybeNullable field
-                             then SelfReference
+                             then Debug.trace "hiut maybeNullable" SelfReference
                         else
+                            Debug.trace "hit a self reference" $
                             case fieldType field of
                                  FTList _ -> SelfReference
                                  _ -> error $ unpack $ unEntityNameHS entName <> ": a self reference must be a Maybe"
@@ -406,6 +433,7 @@ setEmbedField entName allEntities field = field
 
 mkEntityDefSqlTypeExp :: EmbedEntityMap -> EntityMap -> EntityDef -> EntityDefSqlTypeExp
 mkEntityDefSqlTypeExp emEntities entityMap ent =
+    Debug.trace ("making " <> show (getEntityHaskellName ent)) $
     EntityDefSqlTypeExp ent (getSqlType $ entityId ent) (map getSqlType $ getEntityFieldsDatabase ent)
   where
     getSqlType field =
@@ -421,16 +449,22 @@ mkEntityDefSqlTypeExp emEntities entityMap ent =
     -- 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 =
+        Debug.trace ("on defaultSqlTypeExpr for field: " <> show (fieldDB field)) $
         case mEmbedded emEntities ftype of
             Right _ ->
+                Debug.trace ("Found Right, returning SqlType' SqlString") $
                 SqlType' SqlString
             Left (Just FTKeyCon) ->
+                Debug.trace ("Assuming SqlString for FTKeyCon") $
                 SqlType' SqlString
             Left Nothing ->
                 case fieldReference field of
                     ForeignRef refName ft ->
                         case M.lookup refName entityMap of
-                            Nothing  -> SqlTypeExp ft
+                            Nothing  ->
+                                Debug.trace "refName not in entityMap, sqlTypeExp" $
+                                Debug.traceShowId $
+                                SqlTypeExp ft
                             -- A ForeignRef is blindly set to an Int64 in setEmbedField
                             -- correct that now
                             Just ent' ->
@@ -480,7 +514,7 @@ mkPersist mps ents' = do
         , symbolToFieldInstances
         ]
   where
-    ents = map (setDefaultIdFields mps) ents'
+    ents = embedEntityDefs $ map (setDefaultIdFields mps) ents'
     entityMap = constructEntityMap ents
 
 setDefaultIdFields :: MkPersistSettings -> EntityDef -> EntityDef
@@ -596,9 +630,6 @@ data MkPersistSettings = MkPersistSettings
     -- @since 2.13.0.0
     }
 
-
-{-# DEPRECATED mpsGeneric "The mpsGeneric function adds a considerable amount of overhead and complexity to the library without bringing significant benefit. We would like to remove it. If you require this feature, please comment on the linked GitHub issue, and we'll either keep it around, or we can figure out a nicer way to solve your problem.\n\n Github: https://github.com/yesodweb/persistent/issues/1204" #-}
-
 -- |  Set the 'ImplicitIdDef' in the given 'MkPersistSettings'. The default
 -- value is 'autoIncrementingInteger'.
 --
@@ -2164,80 +2195,3 @@ filterConName' mps entity field = mkName $ T.unpack name
         modifiedName = mpsConstraintLabelModifier mps entityName fieldName
         entityName   = unEntityNameHS entity
         fieldName    = upperFirst $ unFieldNameHS field
-
--- | Splice in a list of all 'EntityDef' in scope. This is useful when running
--- 'mkPersist' to ensure that all entity definitions are available for setting
--- foreign keys, and for performing migrations with all entities available.
---
--- 'mkPersist' has the type @MkPersistSettings -> [EntityDef] -> DecsQ@. So, to
--- account for entities defined elsewhere, you'll @mappend $(discoverEntities)@.
---
--- For example,
---
--- @
--- share
---   [ mkPersist sqlSettings . mappend $(discoverEntities)
---   ]
---   [persistLowerCase| ... |]
--- @
---
--- Likewise, to run migrations with all entity instances in scope, you'd write:
---
--- @
--- migrateAll = migrateModels $(discoverEntities)
--- @
---
--- Note that there is some odd behavior with Template Haskell and splicing
--- groups. If you call 'discoverEntities' in the same module that defines
--- 'PersistEntity' instances, you need to ensure they are in different top-level
--- binding groups. You can write @$(pure [])@ at the top level to do this.
---
--- @
--- -- Foo and Bar both export an instance of PersistEntity
--- import Foo
--- import Bar
---
--- -- Since Foo and Bar are both imported, discoverEntities can find them here.
--- mkPersist sqlSettings . mappend $(discoverEntities) [persistLowerCase|
---   User
---     name Text
---     age  Int
---   |]
---
--- -- onlyFooBar is defined in the same 'top level group' as the above generated
--- -- instance for User, so it isn't present in this list.
--- onlyFooBar :: [EntityDef]
--- onlyFooBar = $(discoverEntities)
---
--- -- We can manually create a new binding group with this, which splices an
--- -- empty list of declarations in.
--- $(pure [])
---
--- -- fooBarUser is able to see the 'User' instance.
--- fooBarUser :: [EntityDef]
--- fooBarUser = $(discoverEntities)
--- @
---
--- @since 2.13.0.0
-discoverEntities :: Q Exp
-discoverEntities = do
-    instances <- reifyInstances ''PersistEntity [VarT (mkName "a")]
-    let
-        types =
-            mapMaybe getDecType instances
-        getDecType dec =
-            case dec of
-                InstanceD _moverlap _cxt typ _decs ->
-                    stripPersistEntity typ
-                _ ->
-                    Nothing
-        stripPersistEntity typ =
-            case typ of
-                AppT (ConT tyName) t | tyName == ''PersistEntity ->
-                    Just t
-                _ ->
-                    Nothing
-
-    fmap ListE $
-        forM types $ \typ -> do
-            [e| entityDef (Proxy :: Proxy $(pure typ)) |]
diff --git a/persistent/Database/Persist/Types/Base.hs b/persistent/Database/Persist/Types/Base.hs
index 3b206061e..ad644c70c 100644
--- a/persistent/Database/Persist/Types/Base.hs
+++ b/persistent/Database/Persist/Types/Base.hs
@@ -311,7 +311,7 @@ toEmbedEntityDef ent = embDef
   where
     embDef = EmbedEntityDef
         { embeddedHaskell = entityHaskell ent
-        , embeddedFields = map toEmbedFieldDef $ filter isHaskellField $ entityFields ent
+        , embeddedFields = map toEmbedFieldDef $ entityFields ent
         }
     toEmbedFieldDef :: FieldDef -> EmbedFieldDef
     toEmbedFieldDef field =
diff --git a/persistent/test/Database/Persist/TH/EmbedSpec.hs b/persistent/test/Database/Persist/TH/EmbedSpec.hs
index c0eca8798..adee56630 100644
--- a/persistent/test/Database/Persist/TH/EmbedSpec.hs
+++ b/persistent/test/Database/Persist/TH/EmbedSpec.hs
@@ -38,6 +38,13 @@ SelfEmbed
     name Text
     self SelfEmbed Maybe
     deriving Eq Show
+
+MutualEmbed
+    thing MutualTarget
+
+MutualTarget
+    thing [MutualEmbed]
+
 |]
 
 pass :: IO ()

From f539122b25040fc607c22f501e34fc5612c51b8e Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Tue, 27 Apr 2021 08:52:41 -0600
Subject: [PATCH 09/12] why on earth did this work

---
 .../Database/Persist/MongoDB.hs               |   2 +-
 persistent-test/src/PersistentTestModels.hs   |   2 +-
 persistent/Database/Persist/TH.hs             | 134 +++++++++++++++---
 persistent/Database/Persist/Types/Base.hs     |  35 ++---
 .../test/Database/Persist/TH/EmbedSpec.hs     |  40 +++++-
 5 files changed, 172 insertions(+), 41 deletions(-)

diff --git a/persistent-mongoDB/Database/Persist/MongoDB.hs b/persistent-mongoDB/Database/Persist/MongoDB.hs
index 409b8ae3e..96ef4b3d6 100644
--- a/persistent-mongoDB/Database/Persist/MongoDB.hs
+++ b/persistent-mongoDB/Database/Persist/MongoDB.hs
@@ -659,7 +659,7 @@ collectionNameFromKey = collectionName . recordTypeFromKey
 
 projectionFromEntityDef :: EntityDef -> DB.Projector
 projectionFromEntityDef eDef =
-  map toField (getEntityFieldsDatabase eDef)
+  map toField (getEntityFields eDef)
   where
     toField :: FieldDef -> DB.Field
     toField fDef = (unFieldNameDB (fieldDB fDef)) DB.=: (1 :: Int)
diff --git a/persistent-test/src/PersistentTestModels.hs b/persistent-test/src/PersistentTestModels.hs
index 80d698f3a..5378e2fbc 100644
--- a/persistent-test/src/PersistentTestModels.hs
+++ b/persistent-test/src/PersistentTestModels.hs
@@ -18,7 +18,7 @@ import Data.Text (append)
 -- just need to ensure this compiles
 import PersistentTestModelsImports()
 
-share [mkPersist persistSettings { mpsGeneric = True },  mkMigrate "testMigrate", mkDeleteCascade persistSettings, mkSave "_ignoredSave"] [persistUpperCase|
+share [mkPersist persistSettings { mpsGeneric = True },  mkMigrate "testMigrate", mkDeleteCascade persistSettings] [persistUpperCase|
 
 -- Dedented comment
   -- Header-level comment
diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
index 12ec743a4..605840e14 100644
--- a/persistent/Database/Persist/TH.hs
+++ b/persistent/Database/Persist/TH.hs
@@ -11,7 +11,6 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE StrictData #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
@@ -47,6 +46,7 @@ module Database.Persist.TH
       -- * Various other TH functions
     , mkMigrate
     , migrateModels
+    , discoverEntities
     , mkSave
     , mkDeleteCascade
     , mkEntityDefList
@@ -91,7 +91,7 @@ import Data.Ix (Ix)
 import Data.List (foldl')
 import qualified Data.List as List
 import qualified Data.List.NonEmpty as NEL
-import qualified Data.Map.Strict as M
+import qualified Data.Map as M
 import Data.Maybe (fromMaybe, isJust, listToMaybe, mapMaybe)
 import Data.Monoid (mappend, mconcat, (<>))
 import Data.Proxy (Proxy(Proxy))
@@ -327,7 +327,9 @@ instance Lift FieldSqlTypeExp where
 
 instance Lift EntityDefSqlTypeExp where
     lift (EntityDefSqlTypeExp ent sqlTypeExp sqlTypeExps) =
-        [|ent { entityFields = $(lift $ FieldsSqlTypeExp (getEntityFieldsDatabase ent) sqlTypeExps)
+        [|ent { entityFields =
+                    Debug.trace "[Lift EntityDefSqlTypeExp]" $
+                    $(lift $ FieldsSqlTypeExp (getEntityFieldsDatabase ent) sqlTypeExps)
               , entityId = $(lift $ FieldSqlTypeExp (entityId ent) sqlTypeExp)
               }
         |]
@@ -339,7 +341,13 @@ type EmbedEntityMap = M.Map EntityNameHS EmbedEntityDef
 
 constructEmbedEntityMap :: [EntityDef] -> EmbedEntityMap
 constructEmbedEntityMap =
-    M.fromList . fmap (\ent -> (entityHaskell ent, toEmbedEntityDef ent))
+    M.fromList . fmap
+        (\ent ->
+                ( entityHaskell ent
+                , Debug.trace ("[constructEmbedEntityMap] demanding embedDefFor " <> show (entityHaskell ent))
+                $ toEmbedEntityDef ent
+                )
+        )
 
 type EntityMap = M.Map EntityNameHS EntityDef
 
@@ -365,59 +373,59 @@ mEmbedded
     -> FieldType
     -> Either (Maybe FTTypeConDescr) EmbedEntityDef
 mEmbedded _ (FTTypeCon Just{} _) =
-    Debug.trace "Hit a qualified type" $
+    Debug.trace "[mEmbedded] Hit a qualified type" $
     Left Nothing
 mEmbedded ents (FTTypeCon Nothing (EntityNameHS -> name)) =
-    Debug.trace ("Looking up " <> show name) $
+    Debug.trace ("[mEmbedded] Looking up " <> show name) $
     maybe (Left Nothing) Right $ M.lookup name ents
 mEmbedded ents (FTList x) =
-    Debug.trace "Hit FTList, recurring" $
+    Debug.trace "[mEmbedded] Hit FTList, recurring" $
     mEmbedded ents x
 mEmbedded ents (FTApp x y) =
-    Debug.trace "Hit FTApp" $
+    Debug.trace "[mEmbedded] Hit FTApp" $
     -- 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
-            Debug.trace ("Got a key constructor") $
+            Debug.trace ("[mEmbedded] Got a key constructor") $
             Left $ Just FTKeyCon
         else
-            Debug.trace ("else branch, recurring on " <> show y) $
+            Debug.trace ("[mEmbedded] else branch, recurring on " <> show y) $
             mEmbedded ents y
 
 setEmbedField :: EntityNameHS -> EmbedEntityMap -> FieldDef -> FieldDef
-setEmbedField entName allEntities field = Debug.traceShowId $ field
+setEmbedField entName allEntities field = field
     { fieldReference =
-        Debug.trace ("setEmbedField for " <> show entName) $
-        Debug.trace ("field name: " <> show (fieldDB field)) $
-        Debug.trace ("field ref: " <> show (fieldReference field)) $
-        Debug.trace ("field typ: " <> show (fieldType field)) $
+        Debug.trace ("[setEmbedField] for " <> show entName) $
+        Debug.trace ("[setEmbedField] field name: " <> show (fieldDB field)) $
+        -- Debug.trace ("field ref: " <> show (fieldReference field)) $
+        -- Debug.trace ("field typ: " <> show (fieldType field)) $
         case fieldReference field of
             NoReference ->
-                Debug.trace "On NoReference..." $
+                Debug.trace "[setEmbedField] On NoReference..." $
                 case mEmbedded allEntities (fieldType field) of
                     Left _ ->
-                        Debug.trace "On LeftNothing..." $
+                        Debug.trace "[setEmbedField] On LeftNothing..." $
                         case stripId $ fieldType field of
                             Nothing ->
                                 Debug.trace "No ID on fieldType" $
                                 NoReference
                             Just name ->
-                                Debug.trace ("Found a name: " <> show name) $
+                                Debug.trace ("[setEmbedField] Found a name: " <> show name) $
                                 case M.lookup (EntityNameHS name) allEntities of
                                     Nothing ->
-                                        Debug.trace "Name not in allEntities" $
+                                        Debug.trace "[setEmbedField] Name not in allEntities" $
                                         NoReference
                                     Just _ ->
-                                        Debug.trace "Found it!" $
+                                        Debug.trace "[setEmbedField] Found it!" $
                                         ForeignRef
                                             (EntityNameHS name)
                                             -- This can get corrected in mkEntityDefSqlTypeExp
                                             (FTTypeCon (Just "Data.Int") "Int64")
                     Right em ->
-                        Debug.trace ("on Right em: " <> show em) $
-                        Debug.trace ("embedded Haskell: " <> do show $ embeddedHaskell em) $
+                        Debug.trace ("on Right em: ") $
+                        Debug.trace ("embedded Haskell: " ) $
                         if embeddedHaskell em /= entName
                              then EmbedRef em
                         else if maybeNullable field
@@ -428,6 +436,7 @@ setEmbedField entName allEntities field = Debug.traceShowId $ field
                                  FTList _ -> SelfReference
                                  _ -> error $ unpack $ unEntityNameHS entName <> ": a self reference must be a Maybe"
             existing ->
+                Debug.trace "existing" $
                 existing
   }
 
@@ -437,6 +446,7 @@ mkEntityDefSqlTypeExp emEntities entityMap ent =
     EntityDefSqlTypeExp ent (getSqlType $ entityId ent) (map getSqlType $ getEntityFieldsDatabase ent)
   where
     getSqlType field =
+        Debug.trace "[mkEntityDefSqlTypeExp] getSqlType" $
         maybe
             (defaultSqlTypeExp field)
             (SqlType' . SqlOther)
@@ -458,8 +468,10 @@ mkEntityDefSqlTypeExp emEntities entityMap ent =
                 Debug.trace ("Assuming SqlString for FTKeyCon") $
                 SqlType' SqlString
             Left Nothing ->
+                Debug.trace ("in defaultSqlTypeExp, got Left Nothing") $
                 case fieldReference field of
                     ForeignRef refName ft ->
+                        Debug.trace ("[defaultSqlTypeExp] got ForeignReif") $
                         case M.lookup refName entityMap of
                             Nothing  ->
                                 Debug.trace "refName not in entityMap, sqlTypeExp" $
@@ -468,6 +480,7 @@ mkEntityDefSqlTypeExp emEntities entityMap ent =
                             -- A ForeignRef is blindly set to an Int64 in setEmbedField
                             -- correct that now
                             Just ent' ->
+                                Debug.trace "[defaultSqlTypeExp] Got Just ent'" $
                                 case entityPrimary ent' of
                                     Nothing -> SqlTypeExp ft
                                     Just pdef ->
@@ -2195,3 +2208,80 @@ filterConName' mps entity field = mkName $ T.unpack name
         modifiedName = mpsConstraintLabelModifier mps entityName fieldName
         entityName   = unEntityNameHS entity
         fieldName    = upperFirst $ unFieldNameHS field
+
+-- | Splice in a list of all 'EntityDef' in scope. This is useful when running
+-- 'mkPersist' to ensure that all entity definitions are available for setting
+-- foreign keys, and for performing migrations with all entities available.
+--
+-- 'mkPersist' has the type @MkPersistSettings -> [EntityDef] -> DecsQ@. So, to
+-- account for entities defined elsewhere, you'll @mappend $(discoverEntities)@.
+--
+-- For example,
+--
+-- @
+-- share
+--   [ mkPersist sqlSettings . mappend $(discoverEntities)
+--   ]
+--   [persistLowerCase| ... |]
+-- @
+--
+-- Likewise, to run migrations with all entity instances in scope, you'd write:
+--
+-- @
+-- migrateAll = migrateModels $(discoverEntities)
+-- @
+--
+-- Note that there is some odd behavior with Template Haskell and splicing
+-- groups. If you call 'discoverEntities' in the same module that defines
+-- 'PersistEntity' instances, you need to ensure they are in different top-level
+-- binding groups. You can write @$(pure [])@ at the top level to do this.
+--
+-- @
+-- -- Foo and Bar both export an instance of PersistEntity
+-- import Foo
+-- import Bar
+--
+-- -- Since Foo and Bar are both imported, discoverEntities can find them here.
+-- mkPersist sqlSettings . mappend $(discoverEntities) [persistLowerCase|
+--   User
+--     name Text
+--     age  Int
+--   |]
+--
+-- -- onlyFooBar is defined in the same 'top level group' as the above generated
+-- -- instance for User, so it isn't present in this list.
+-- onlyFooBar :: [EntityDef]
+-- onlyFooBar = $(discoverEntities)
+--
+-- -- We can manually create a new binding group with this, which splices an
+-- -- empty list of declarations in.
+-- $(pure [])
+--
+-- -- fooBarUser is able to see the 'User' instance.
+-- fooBarUser :: [EntityDef]
+-- fooBarUser = $(discoverEntities)
+-- @
+--
+-- @since 2.13.0.0
+discoverEntities :: Q Exp
+discoverEntities = do
+    instances <- reifyInstances ''PersistEntity [VarT (mkName "a")]
+    let
+        types =
+            mapMaybe getDecType instances
+        getDecType dec =
+            case dec of
+                InstanceD _moverlap _cxt typ _decs ->
+                    stripPersistEntity typ
+                _ ->
+                    Nothing
+        stripPersistEntity typ =
+            case typ of
+                AppT (ConT tyName) t | tyName == ''PersistEntity ->
+                    Just t
+                _ ->
+                    Nothing
+
+    fmap ListE $
+        forM types $ \typ -> do
+            [e| entityDef (Proxy :: Proxy $(pure typ)) |]
diff --git a/persistent/Database/Persist/Types/Base.hs b/persistent/Database/Persist/Types/Base.hs
index ad644c70c..cd853bca5 100644
--- a/persistent/Database/Persist/Types/Base.hs
+++ b/persistent/Database/Persist/Types/Base.hs
@@ -280,15 +280,15 @@ data ReferenceDef = NoReference
 -- But it is only used for fieldReference
 -- so it only has data needed for embedding
 data EmbedEntityDef = EmbedEntityDef
-    { embeddedHaskell :: !EntityNameHS
-    , embeddedFields  :: ![EmbedFieldDef]
+    { embeddedHaskell :: EntityNameHS
+    , embeddedFields  :: [EmbedFieldDef]
     } deriving (Show, Eq, Read, Ord, Lift)
 
 -- | An EmbedFieldDef is the same as a FieldDef
 -- But it is only used for embeddedFields
 -- so it only has data needed for embedding
 data EmbedFieldDef = EmbedFieldDef
-    { emFieldDB    :: !FieldNameDB
+    { emFieldDB    :: FieldNameDB
     , emFieldEmbed :: Maybe EmbedEntityDef
     , emFieldCycle :: Maybe EntityNameHS
     -- ^ 'emFieldEmbed' can create a cycle (issue #311)
@@ -311,23 +311,26 @@ toEmbedEntityDef ent = embDef
   where
     embDef = EmbedEntityDef
         { embeddedHaskell = entityHaskell ent
-        , embeddedFields = map toEmbedFieldDef $ entityFields ent
+        , embeddedFields =
+            map toEmbedFieldDef
+            $ filter isHaskellField
+            $ entityFields ent
         }
     toEmbedFieldDef :: FieldDef -> EmbedFieldDef
     toEmbedFieldDef field =
         EmbedFieldDef
-          { emFieldDB =
-              fieldDB field
-          , emFieldEmbed =
-              case fieldReference field of
-                  EmbedRef em -> Just em
-                  SelfReference -> Just embDef
-                  _ -> Nothing
-          , emFieldCycle =
-              case fieldReference field of
-                  SelfReference -> Just $ entityHaskell ent
-                  _ -> Nothing
-          }
+            { emFieldDB =
+                fieldDB field
+            , emFieldEmbed =
+                case fieldReference field of
+                    EmbedRef em -> Just em
+                    SelfReference -> Just embDef
+                    _ -> Nothing
+            , emFieldCycle =
+                case fieldReference field of
+                    SelfReference -> Just $ entityHaskell ent
+                    _ -> Nothing
+            }
 
 -- | Type for storing the Uniqueness constraint in the Schema.  Assume you have
 -- the following schema with a uniqueness constraint:
diff --git a/persistent/test/Database/Persist/TH/EmbedSpec.hs b/persistent/test/Database/Persist/TH/EmbedSpec.hs
index adee56630..0411157ad 100644
--- a/persistent/test/Database/Persist/TH/EmbedSpec.hs
+++ b/persistent/test/Database/Persist/TH/EmbedSpec.hs
@@ -21,11 +21,15 @@ import Data.Text (Text)
 import Database.Persist.ImplicitIdDef
 import Database.Persist.ImplicitIdDef.Internal (fieldTypeFromTypeable)
 import Database.Persist.Types
+import Database.Persist.Types
+import Database.Persist.EntityDef
+import Database.Persist.EntityDef.Internal (toEmbedEntityDef)
 
 mkPersist sqlSettings [persistLowerCase|
 
 Thing
     name String
+    foo  String MigrationOnly
 
     deriving Eq Show
 
@@ -55,8 +59,42 @@ asIO = id
 
 spec :: Spec
 spec = describe "EmbedSpec" $ do
+    describe "SomeThing" $ do
+        let
+            edef =
+                entityDef $ Proxy @Thing
+        describe "toEmbedEntityDef" $ do
+            let
+                embedDef =
+                    toEmbedEntityDef edef
+            it "should have the same field count as Haskell fields" $ do
+                length (embeddedFields embedDef)
+                    `shouldBe`
+                        length (getEntityFields edef)
+
     describe "EmbedThing" $ do
-        it "generates" $ do
+        it "generates the right constructor" $ do
             let embedThing :: EmbedThing
                 embedThing = EmbedThing (Thing "asdf")
             pass
+
+    describe "SelfEmbed" $ do
+        let
+            edef =
+                entityDef $ Proxy @SelfEmbed
+        describe "fieldReference" $ do
+            let
+                [nameField, selfField] = getEntityFields edef
+            it "has self reference" $ do
+                fieldReference selfField
+                    `shouldBe`
+                        SelfReference
+        describe "toEmbedEntityDef" $ do
+            let
+                embedDef =
+                    toEmbedEntityDef edef
+            it "has the same field count as regular def" $ do
+                length (getEntityFields edef)
+                    `shouldBe`
+                        length (embeddedFields embedDef)
+

From e3725caaa669ae30281c86f59092282add4233e9 Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Tue, 27 Apr 2021 08:55:00 -0600
Subject: [PATCH 10/12] remove debug trace statements

---
 persistent/Database/Persist/TH.hs | 40 ++-----------------------------
 1 file changed, 2 insertions(+), 38 deletions(-)

diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
index 605840e14..5ead039f6 100644
--- a/persistent/Database/Persist/TH.hs
+++ b/persistent/Database/Persist/TH.hs
@@ -69,7 +69,6 @@ module Database.Persist.TH
 
 import Prelude hiding (concat, exp, splitAt, take, (++))
 
-import qualified Debug.Trace as Debug
 import Control.Monad
 import Data.Aeson
        ( FromJSON(parseJSON)
@@ -238,13 +237,11 @@ embedEntityDefsMap rawEnts = (embedEntityMap, noCycleEnts)
     breakCycleField entName f =
         case fieldReference f of
             EmbedRef em ->
-                Debug.trace "breakCycleField, hit embedRef" $
                 f { fieldReference = EmbedRef $ breakCycleEmbed [entName] em }
             _ ->
                 f
 
     breakCycleEmbed ancestors em =
-        Debug.trace ("Ancestors: " <> show ancestors) $
         em { embeddedFields = breakCycleEmField (emName : ancestors) <$> embeddedFields em
            }
         where
@@ -255,7 +252,6 @@ embedEntityDefsMap rawEnts = (embedEntityMap, noCycleEnts)
         Just embName ->
             if embName `elem` ancestors
             then
-                Debug.trace ("emFieldCycle: " <> show embName) $
                 emf { emFieldEmbed = Nothing, emFieldCycle = Just embName }
             else emf { emFieldEmbed = breakCycleEmbed ancestors <$> membed }
         where
@@ -328,7 +324,6 @@ instance Lift FieldSqlTypeExp where
 instance Lift EntityDefSqlTypeExp where
     lift (EntityDefSqlTypeExp ent sqlTypeExp sqlTypeExps) =
         [|ent { entityFields =
-                    Debug.trace "[Lift EntityDefSqlTypeExp]" $
                     $(lift $ FieldsSqlTypeExp (getEntityFieldsDatabase ent) sqlTypeExps)
               , entityId = $(lift $ FieldSqlTypeExp (entityId ent) sqlTypeExp)
               }
@@ -344,8 +339,7 @@ constructEmbedEntityMap =
     M.fromList . fmap
         (\ent ->
                 ( entityHaskell ent
-                , Debug.trace ("[constructEmbedEntityMap] demanding embedDefFor " <> show (entityHaskell ent))
-                $ toEmbedEntityDef ent
+                , toEmbedEntityDef ent
                 )
         )
 
@@ -373,80 +367,58 @@ mEmbedded
     -> FieldType
     -> Either (Maybe FTTypeConDescr) EmbedEntityDef
 mEmbedded _ (FTTypeCon Just{} _) =
-    Debug.trace "[mEmbedded] Hit a qualified type" $
     Left Nothing
 mEmbedded ents (FTTypeCon Nothing (EntityNameHS -> name)) =
-    Debug.trace ("[mEmbedded] Looking up " <> show name) $
     maybe (Left Nothing) Right $ M.lookup name ents
 mEmbedded ents (FTList x) =
-    Debug.trace "[mEmbedded] Hit FTList, recurring" $
     mEmbedded ents x
 mEmbedded ents (FTApp x y) =
-    Debug.trace "[mEmbedded] Hit FTApp" $
     -- 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
-            Debug.trace ("[mEmbedded] Got a key constructor") $
             Left $ Just FTKeyCon
         else
-            Debug.trace ("[mEmbedded] else branch, recurring on " <> show y) $
             mEmbedded ents y
 
 setEmbedField :: EntityNameHS -> EmbedEntityMap -> FieldDef -> FieldDef
 setEmbedField entName allEntities field = field
     { fieldReference =
-        Debug.trace ("[setEmbedField] for " <> show entName) $
-        Debug.trace ("[setEmbedField] field name: " <> show (fieldDB field)) $
-        -- Debug.trace ("field ref: " <> show (fieldReference field)) $
-        -- Debug.trace ("field typ: " <> show (fieldType field)) $
         case fieldReference field of
             NoReference ->
-                Debug.trace "[setEmbedField] On NoReference..." $
                 case mEmbedded allEntities (fieldType field) of
                     Left _ ->
-                        Debug.trace "[setEmbedField] On LeftNothing..." $
                         case stripId $ fieldType field of
                             Nothing ->
-                                Debug.trace "No ID on fieldType" $
                                 NoReference
                             Just name ->
-                                Debug.trace ("[setEmbedField] Found a name: " <> show name) $
                                 case M.lookup (EntityNameHS name) allEntities of
                                     Nothing ->
-                                        Debug.trace "[setEmbedField] Name not in allEntities" $
                                         NoReference
                                     Just _ ->
-                                        Debug.trace "[setEmbedField] Found it!" $
                                         ForeignRef
                                             (EntityNameHS name)
                                             -- This can get corrected in mkEntityDefSqlTypeExp
                                             (FTTypeCon (Just "Data.Int") "Int64")
                     Right em ->
-                        Debug.trace ("on Right em: ") $
-                        Debug.trace ("embedded Haskell: " ) $
                         if embeddedHaskell em /= entName
                              then EmbedRef em
                         else if maybeNullable field
-                             then Debug.trace "hiut maybeNullable" SelfReference
+                             then SelfReference
                         else
-                            Debug.trace "hit a self reference" $
                             case fieldType field of
                                  FTList _ -> SelfReference
                                  _ -> error $ unpack $ unEntityNameHS entName <> ": a self reference must be a Maybe"
             existing ->
-                Debug.trace "existing" $
                 existing
   }
 
 mkEntityDefSqlTypeExp :: EmbedEntityMap -> EntityMap -> EntityDef -> EntityDefSqlTypeExp
 mkEntityDefSqlTypeExp emEntities entityMap ent =
-    Debug.trace ("making " <> show (getEntityHaskellName ent)) $
     EntityDefSqlTypeExp ent (getSqlType $ entityId ent) (map getSqlType $ getEntityFieldsDatabase ent)
   where
     getSqlType field =
-        Debug.trace "[mkEntityDefSqlTypeExp] getSqlType" $
         maybe
             (defaultSqlTypeExp field)
             (SqlType' . SqlOther)
@@ -459,28 +431,20 @@ mkEntityDefSqlTypeExp emEntities entityMap ent =
     -- 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 =
-        Debug.trace ("on defaultSqlTypeExpr for field: " <> show (fieldDB field)) $
         case mEmbedded emEntities ftype of
             Right _ ->
-                Debug.trace ("Found Right, returning SqlType' SqlString") $
                 SqlType' SqlString
             Left (Just FTKeyCon) ->
-                Debug.trace ("Assuming SqlString for FTKeyCon") $
                 SqlType' SqlString
             Left Nothing ->
-                Debug.trace ("in defaultSqlTypeExp, got Left Nothing") $
                 case fieldReference field of
                     ForeignRef refName ft ->
-                        Debug.trace ("[defaultSqlTypeExp] got ForeignReif") $
                         case M.lookup refName entityMap of
                             Nothing  ->
-                                Debug.trace "refName not in entityMap, sqlTypeExp" $
-                                Debug.traceShowId $
                                 SqlTypeExp ft
                             -- A ForeignRef is blindly set to an Int64 in setEmbedField
                             -- correct that now
                             Just ent' ->
-                                Debug.trace "[defaultSqlTypeExp] Got Just ent'" $
                                 case entityPrimary ent' of
                                     Nothing -> SqlTypeExp ft
                                     Just pdef ->

From 0a25637ba8be3a043aaf8b125882d5375935ebe8 Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Tue, 27 Apr 2021 09:05:17 -0600
Subject: [PATCH 11/12] typo

---
 persistent/ChangeLog.md | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md
index 7d7c9e41d..d9fe2e4fd 100644
--- a/persistent/ChangeLog.md
+++ b/persistent/ChangeLog.md
@@ -9,7 +9,7 @@
       Please use `mkEntityDefList` instead.
     * `EntityDef` will now include fields marked `MigrationOnly` and
       `SafeToRemove`. Beforehand, those were filtered out, and `mkMigrate`
-      applied. The function `getEntityFields` wll only return fields defiend on
+      applied. The function `getEntityFields` wll only return fields defined on
       the Haskell type - for all columns, see `getEntityFieldsDatabase`.
 * [#1225](https://github.com/yesodweb/persistent/pull/1225)
     * The fields and constructor for `SqlBackend` are no longer exported by

From 4f50527320cf9a5f8512f7d39696804586feb35d Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Tue, 27 Apr 2021 09:08:21 -0600
Subject: [PATCH 12/12] what no put that back in

---
 persistent/Database/Persist/TH.hs | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
index 5ead039f6..3421b62df 100644
--- a/persistent/Database/Persist/TH.hs
+++ b/persistent/Database/Persist/TH.hs
@@ -607,6 +607,8 @@ data MkPersistSettings = MkPersistSettings
     -- @since 2.13.0.0
     }
 
+{-# DEPRECATED mpsGeneric "The mpsGeneric function adds a considerable amount of overhead and complexity to the library without bringing significant benefit. We would like to remove it. If you require this feature, please comment on the linked GitHub issue, and we'll either keep it around, or we can figure out a nicer way to solve your problem.\n\n Github: https://github.com/yesodweb/persistent/issues/1204" #-}
+
 -- |  Set the 'ImplicitIdDef' in the given 'MkPersistSettings'. The default
 -- value is 'autoIncrementingInteger'.
 --