From 25e536127979dd4f3f45b93348326378d83ce772 Mon Sep 17 00:00:00 2001
From: Dan Brooks <danbroooks@users.noreply.github.com>
Date: Wed, 24 Mar 2021 16:26:14 +0000
Subject: [PATCH 01/28] Extract name function for ToJSON instance

---
 persistent/Database/Persist/TH.hs | 28 ++++++++++++++++------------
 1 file changed, 16 insertions(+), 12 deletions(-)

diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
index 9968527ae..c2fc9a62c 100644
--- a/persistent/Database/Persist/TH.hs
+++ b/persistent/Database/Persist/TH.hs
@@ -104,16 +104,6 @@ import Database.Persist
 import Database.Persist.Sql (Migration, PersistFieldSql, SqlBackend, migrate, sqlType)
 import Database.Persist.Quasi
 
--- | This special-cases "type_" and strips out its underscore. When
--- used for JSON serialization and deserialization, it works around
--- <https://github.com/yesodweb/persistent/issues/412>
-unFieldNameHSForJSON :: FieldNameHS -> Text
-unFieldNameHSForJSON = fixTypeUnderscore . unFieldNameHS
-  where
-    fixTypeUnderscore = \case
-        "type" -> "type_"
-        name -> name
-
 -- | Converts a quasi-quoted syntax into a list of entity definitions, to be
 -- used as input to the template haskell generation code (mkPersist).
 persistWith :: PersistSettings -> QuasiQuoter
@@ -1846,8 +1836,7 @@ mkJSON mps def = do
     obj <- newName "obj"
     mzeroE <- [|mzero|]
 
-    xs <- mapM (newName . unpack . unFieldNameHSForJSON . fieldHaskell)
-        $ entityFields def
+    xs <- mapM fieldToJSONValName (entityFields def)
 
     let conName = mkName $ unpack $ unEntityNameHS $ entityHaskell def
         typ = genericDataType mps (entityHaskell def) backendT
@@ -2012,3 +2001,18 @@ requireExtensions requiredExtensions = do
 
   where
     extensionToPragma ext = "{-# LANGUAGE " <> show ext <> " #-}"
+
+-- | creates a TH Name for use in the ToJSON instance
+fieldToJSONValName :: FieldDef -> Q Name
+fieldToJSONValName =
+    newName . T.unpack . unFieldNameHSForJSON . fieldHaskell
+
+-- | This special-cases "type_" and strips out its underscore. When
+-- used for JSON serialization and deserialization, it works around
+-- <https://github.com/yesodweb/persistent/issues/412>
+unFieldNameHSForJSON :: FieldNameHS -> Text
+unFieldNameHSForJSON = fixTypeUnderscore . unFieldNameHS
+  where
+    fixTypeUnderscore = \case
+        "type" -> "type_"
+        name -> name

From a3e344806661a0d43f6378a4473f2616e0c2e6d0 Mon Sep 17 00:00:00 2001
From: Dan Brooks <danbroooks@users.noreply.github.com>
Date: Wed, 24 Mar 2021 16:33:36 +0000
Subject: [PATCH 02/28] Extract mkRecName

---
 persistent/Database/Persist/TH.hs | 18 ++++++++++++++----
 1 file changed, 14 insertions(+), 4 deletions(-)

diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
index c2fc9a62c..bc8a539ef 100644
--- a/persistent/Database/Persist/TH.hs
+++ b/persistent/Database/Persist/TH.hs
@@ -605,7 +605,7 @@ dataTypeDec mps entDef = do
         ]
         )
     mkCol x fd@FieldDef {..} =
-        (mkName $ unpack $ recNameF mps x fieldHaskell,
+        (mkRecName mps x fieldHaskell,
          if fieldStrict then isStrict else notStrict,
          maybeIdType mps fd Nothing Nothing
         )
@@ -848,7 +848,7 @@ mkLensClauses mps entDef = do
         [ConP (filterConName mps entDef f) []]
         (lens' `AppE` getter `AppE` setter)
       where
-        fieldName = mkName $ unpack $ recNameF mps (entityHaskell entDef) (fieldHaskell f)
+        fieldName = mkRecName mps (entityHaskell entDef) (fieldHaskell f)
         getter = InfixE (Just $ VarE fieldName) dot (Just getVal)
         setter = LamE
             [ ConP 'Entity [VarP keyVar, VarP valName]
@@ -1166,7 +1166,7 @@ mkEntity entityMap mps entDef = do
                 recordName <- newName "record"
                 let keyCon = keyConName entDef
                     keyFields' =
-                        map (mkName . T.unpack . recNameF mps entName . fieldHaskell)
+                        map (mkRecName mps entName . fieldHaskell)
                             (compositeFields prim)
                     constr =
                         foldl'
@@ -1368,7 +1368,7 @@ mkLenses mps ent = fmap mconcat $ forM (entityFields ent) $ \field -> do
 mkForeignKeysComposite :: MkPersistSettings -> EntityDef -> ForeignDef -> Q [Dec]
 mkForeignKeysComposite mps entDef ForeignDef {..} =
     if not foreignToPrimary then return [] else do
-    let fieldName f = mkName $ unpack $ recNameF mps (entityHaskell entDef) f
+    let fieldName f = mkRecName mps (entityHaskell entDef) f
     let fname = fieldName (constraintToField foreignConstraintNameHaskell)
     let reftableString = unpack $ unEntityNameHS foreignRefTableHaskell
     let reftableKeyName = mkName $ reftableString `mappend` "Key"
@@ -2016,3 +2016,13 @@ unFieldNameHSForJSON = fixTypeUnderscore . unFieldNameHS
     fixTypeUnderscore = \case
         "type" -> "type_"
         name -> name
+
+-- | creates a TH Name for an entity's field, based on the entity
+-- name and the field name, so for example:
+--
+-- Customer
+--   name Text
+--
+-- This would generate `customerName` as a TH Name
+mkRecName :: MkPersistSettings -> EntityNameHS -> FieldNameHS -> Name
+mkRecName mps entName fieldName = mkName $ T.unpack $ recNameF mps entName fieldName

From c51c72183026adacb88306dcf2497f932a033dc8 Mon Sep 17 00:00:00 2001
From: Dan Brooks <danbroooks@users.noreply.github.com>
Date: Wed, 24 Mar 2021 16:44:17 +0000
Subject: [PATCH 03/28] Extract `mkEntityDefDeriveNames`

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

diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
index bc8a539ef..b563fa42b 100644
--- a/persistent/Database/Persist/TH.hs
+++ b/persistent/Database/Persist/TH.hs
@@ -574,7 +574,7 @@ upperFirst t =
 
 dataTypeDec :: MkPersistSettings -> EntityDef -> Q Dec
 dataTypeDec mps entDef = do
-    let entityInstances     = map (mkName . unpack) $ entityDerives entDef
+    let entityInstances     = mkEntityDefDeriveNames entDef
         additionalInstances = filter (`notElem` entityInstances) $ mpsDeriveInstances mps
         names               = entityInstances <> additionalInstances
 
@@ -2026,3 +2026,7 @@ unFieldNameHSForJSON = fixTypeUnderscore . unFieldNameHS
 -- This would generate `customerName` as a TH Name
 mkRecName :: MkPersistSettings -> EntityNameHS -> FieldNameHS -> Name
 mkRecName mps entName fieldName = mkName $ T.unpack $ recNameF mps entName fieldName
+
+-- | Take an EntityDef's `entityDerives` and turn them into TH Names
+mkEntityDefDeriveNames :: EntityDef -> [Name]
+mkEntityDefDeriveNames = fmap (mkName . T.unpack) . entityDerives

From 3cc9b8d12b2659d65f02e86b1070574ffcb0f9a7 Mon Sep 17 00:00:00 2001
From: Dan Brooks <danbroooks@users.noreply.github.com>
Date: Wed, 24 Mar 2021 16:48:25 +0000
Subject: [PATCH 04/28] Extract mkEntityDefName* functions

---
 persistent/Database/Persist/TH.hs | 17 +++++++++++------
 1 file changed, 11 insertions(+), 6 deletions(-)

diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
index b563fa42b..c8de57df1 100644
--- a/persistent/Database/Persist/TH.hs
+++ b/persistent/Database/Persist/TH.hs
@@ -610,16 +610,13 @@ dataTypeDec mps entDef = do
          maybeIdType mps fd Nothing Nothing
         )
     (nameFinal, paramsFinal)
-        | mpsGeneric mps = (nameG, [PlainTV backend])
-        | otherwise = (name, [])
-    nameG = mkName $ unpack $ unEntityNameHS (entityHaskell entDef) ++ "Generic"
-    name = mkName $ unpack $ unEntityNameHS $ entityHaskell entDef
+        | mpsGeneric mps = (mkEntityDefGenericName entDef, [PlainTV backendName])
+        | otherwise = (mkEntityDefName entDef, [])
     cols = map (mkCol $ entityHaskell entDef) $ entityFields entDef
-    backend = backendName
 
     constrs
         | entitySum entDef = map sumCon $ entityFields entDef
-        | otherwise = [RecC name cols]
+        | otherwise = [RecC (mkEntityDefName entDef) cols]
 
     sumCon fieldDef = NormalC
         (sumConstrName mps entDef fieldDef)
@@ -2030,3 +2027,11 @@ mkRecName mps entName fieldName = mkName $ T.unpack $ recNameF mps entName field
 -- | Take an EntityDef's `entityDerives` and turn them into TH Names
 mkEntityDefDeriveNames :: EntityDef -> [Name]
 mkEntityDefDeriveNames = fmap (mkName . T.unpack) . entityDerives
+
+mkEntityDefGenericName :: EntityDef -> Name
+mkEntityDefGenericName entDef =
+    mkName $ T.unpack $ unEntityNameHS (entityHaskell entDef) <> "Generic"
+
+mkEntityDefName :: EntityDef -> Name
+mkEntityDefName entDef =
+    mkName $ T.unpack $ unEntityNameHS (entityHaskell entDef)

From 4ee4c53baf30a1215db028cb4b8aba2c0ccaea29 Mon Sep 17 00:00:00 2001
From: Dan Brooks <danbroooks@users.noreply.github.com>
Date: Wed, 24 Mar 2021 16:56:19 +0000
Subject: [PATCH 05/28] Move sumConstrName

---
 persistent/Database/Persist/TH.hs | 28 +++++++++++++++-------------
 1 file changed, 15 insertions(+), 13 deletions(-)

diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
index c8de57df1..63a0fcac6 100644
--- a/persistent/Database/Persist/TH.hs
+++ b/persistent/Database/Persist/TH.hs
@@ -622,16 +622,6 @@ dataTypeDec mps entDef = do
         (sumConstrName mps entDef fieldDef)
         [(notStrict, maybeIdType mps fieldDef Nothing Nothing)]
 
-sumConstrName :: MkPersistSettings -> EntityDef -> FieldDef -> Name
-sumConstrName mps entDef FieldDef {..} = mkName $ unpack name
-    where
-        name
-            | mpsPrefixFields mps = modifiedName ++ "Sum"
-            | otherwise           = fieldName ++ "Sum"
-        modifiedName = mpsConstraintLabelModifier mps entityName fieldName
-        entityName   = unEntityNameHS $ entityHaskell entDef
-        fieldName    = upperFirst $ unFieldNameHS fieldHaskell
-
 uniqueTypeDec :: MkPersistSettings -> EntityDef -> Dec
 uniqueTypeDec mps entDef =
 #if MIN_VERSION_template_haskell(2,15,0)
@@ -2028,10 +2018,22 @@ mkRecName mps entName fieldName = mkName $ T.unpack $ recNameF mps entName field
 mkEntityDefDeriveNames :: EntityDef -> [Name]
 mkEntityDefDeriveNames = fmap (mkName . T.unpack) . entityDerives
 
+-- | Make a TH Name for the EntityDef's Haskell type
+mkEntityDefName :: EntityDef -> Name
+mkEntityDefName entDef =
+    mkName $ T.unpack $ unEntityNameHS (entityHaskell entDef)
+
+-- | Make a TH Name for the EntityDef's Haskell type, when using mpsGeneric
 mkEntityDefGenericName :: EntityDef -> Name
 mkEntityDefGenericName entDef =
     mkName $ T.unpack $ unEntityNameHS (entityHaskell entDef) <> "Generic"
 
-mkEntityDefName :: EntityDef -> Name
-mkEntityDefName entDef =
-    mkName $ T.unpack $ unEntityNameHS (entityHaskell entDef)
+sumConstrName :: MkPersistSettings -> EntityDef -> FieldDef -> Name
+sumConstrName mps entDef FieldDef {..} = mkName $ T.unpack name
+    where
+        name
+            | mpsPrefixFields mps = modifiedName ++ "Sum"
+            | otherwise           = fieldName ++ "Sum"
+        modifiedName = mpsConstraintLabelModifier mps entityName fieldName
+        entityName   = unEntityNameHS $ entityHaskell entDef
+        fieldName    = upperFirst $ unFieldNameHS fieldHaskell

From 39859a15d9e9ec76a5e5a5ec096330a5cc7458ad Mon Sep 17 00:00:00 2001
From: Dan Brooks <danbroooks@users.noreply.github.com>
Date: Wed, 24 Mar 2021 16:59:53 +0000
Subject: [PATCH 06/28] Extract mkConstraintName

---
 persistent/Database/Persist/TH.hs | 11 ++++++++---
 1 file changed, 8 insertions(+), 3 deletions(-)

diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
index 63a0fcac6..742bd70bc 100644
--- a/persistent/Database/Persist/TH.hs
+++ b/persistent/Database/Persist/TH.hs
@@ -639,8 +639,8 @@ uniqueTypeDec mps entDef =
 #endif
 
 mkUnique :: MkPersistSettings -> EntityDef -> UniqueDef -> Con
-mkUnique mps entDef (UniqueDef (ConstraintNameHS constr) _ fields attrs) =
-    NormalC (mkName $ unpack constr) types
+mkUnique mps entDef (UniqueDef constr _ fields attrs) =
+    NormalC (mkConstraintName constr) types
   where
     types =
       map (go . flip lookup3 (entityFields entDef) . unFieldNameHS . fst) fields
@@ -653,7 +653,7 @@ mkUnique mps entDef (UniqueDef (ConstraintNameHS constr) _ fields attrs) =
 
     lookup3 :: Text -> [FieldDef] -> (FieldDef, IsNullable)
     lookup3 s [] =
-        error $ unpack $ "Column not found: " ++ s ++ " in unique " ++ constr
+        error $ unpack $ "Column not found: " ++ s ++ " in unique " ++ unConstraintNameHS constr
     lookup3 x (fd@FieldDef {..}:rest)
         | x == unFieldNameHS fieldHaskell = (fd, nullable fieldAttrs)
         | otherwise = lookup3 x rest
@@ -2037,3 +2037,8 @@ sumConstrName mps entDef FieldDef {..} = mkName $ T.unpack name
         modifiedName = mpsConstraintLabelModifier mps entityName fieldName
         entityName   = unEntityNameHS $ entityHaskell entDef
         fieldName    = upperFirst $ unFieldNameHS fieldHaskell
+
+-- | Turn a ConstraintName into a TH Name
+mkConstraintName :: ConstraintNameHS -> Name
+mkConstraintName (ConstraintNameHS name) =
+    mkName (T.unpack name)

From 44f0063f32e08ffdae39a272c223221804f182ca Mon Sep 17 00:00:00 2001
From: Dan Brooks <danbroooks@users.noreply.github.com>
Date: Wed, 24 Mar 2021 17:30:56 +0000
Subject: [PATCH 07/28] Extract `mkEntityNameHS*` functions

---
 persistent/Database/Persist/TH.hs | 32 +++++++++++++++++++------------
 1 file changed, 20 insertions(+), 12 deletions(-)

diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
index 742bd70bc..4c82d5d50 100644
--- a/persistent/Database/Persist/TH.hs
+++ b/persistent/Database/Persist/TH.hs
@@ -246,7 +246,6 @@ foreignReference field = case fieldReference field of
     ForeignRef ref _ -> Just ref
     _              -> Nothing
 
-
 -- fieldSqlType at parse time can be an Exp
 -- This helps delay setting fieldSqlType until lift time
 data EntityDefSqlTypeExp
@@ -685,13 +684,14 @@ backendDataType mps
     | mpsGeneric mps = backendT
     | otherwise = mpsBackend mps
 
-genericDataType :: MkPersistSettings
-                -> EntityNameHS
-                -> Type -- ^ backend
-                -> Type
-genericDataType mps (EntityNameHS typ') backend
-    | mpsGeneric mps = ConT (mkName $ unpack $ typ' ++ "Generic") `AppT` backend
-    | otherwise = ConT $ mkName $ unpack typ'
+genericDataType
+    :: MkPersistSettings
+    -> EntityNameHS
+    -> Type -- ^ backend
+    -> Type
+genericDataType mps name backend
+    | mpsGeneric mps = ConT (mkEntityNameHSGenericName name) `AppT` backend
+    | otherwise = ConT $ mkEntityNameHSName name
 
 idType :: MkPersistSettings -> FieldDef -> Maybe Name -> Type
 idType mps fieldDef mbackend =
@@ -2020,13 +2020,21 @@ mkEntityDefDeriveNames = fmap (mkName . T.unpack) . entityDerives
 
 -- | Make a TH Name for the EntityDef's Haskell type
 mkEntityDefName :: EntityDef -> Name
-mkEntityDefName entDef =
-    mkName $ T.unpack $ unEntityNameHS (entityHaskell entDef)
+mkEntityDefName =
+    mkEntityNameHSName . entityHaskell
+
+mkEntityNameHSName :: EntityNameHS -> Name
+mkEntityNameHSName =
+    mkName . T.unpack . unEntityNameHS
 
 -- | Make a TH Name for the EntityDef's Haskell type, when using mpsGeneric
 mkEntityDefGenericName :: EntityDef -> Name
-mkEntityDefGenericName entDef =
-    mkName $ T.unpack $ unEntityNameHS (entityHaskell entDef) <> "Generic"
+mkEntityDefGenericName =
+    mkEntityNameHSGenericName . entityHaskell
+
+mkEntityNameHSGenericName :: EntityNameHS -> Name
+mkEntityNameHSGenericName name =
+    mkName $ T.unpack (unEntityNameHS name <> "Generic")
 
 sumConstrName :: MkPersistSettings -> EntityDef -> FieldDef -> Name
 sumConstrName mps entDef FieldDef {..} = mkName $ T.unpack name

From 7ba298e04ff1d93b1376319da845a106f42f44d3 Mon Sep 17 00:00:00 2001
From: Dan Brooks <danbroooks@users.noreply.github.com>
Date: Wed, 24 Mar 2021 17:44:57 +0000
Subject: [PATCH 08/28] Refactor using new functions

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

diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
index 4c82d5d50..b24377f03 100644
--- a/persistent/Database/Persist/TH.hs
+++ b/persistent/Database/Persist/TH.hs
@@ -708,8 +708,8 @@ degen [] =
      in [normalClause [WildP] err]
 degen x = x
 
-mkToPersistFields :: MkPersistSettings -> String -> EntityDef -> Q Dec
-mkToPersistFields mps constr ed@EntityDef { entitySum = isSum, entityFields = fields } = do
+mkToPersistFields :: MkPersistSettings -> EntityDef -> Q Dec
+mkToPersistFields mps ed@EntityDef { entitySum = isSum, entityFields = fields } = do
     clauses <-
         if isSum
             then sequence $ zipWith goSum fields [1..]
@@ -719,7 +719,8 @@ mkToPersistFields mps constr ed@EntityDef { entitySum = isSum, entityFields = fi
     go :: Q Clause
     go = do
         xs <- sequence $ replicate fieldCount $ newName "x"
-        let pat = ConP (mkName constr) $ map VarP xs
+        let name = mkEntityDefName ed
+            pat = ConP name $ map VarP xs
         sp <- [|SomePersistField|]
         let bod = ListE $ map (AppE sp . VarE) xs
         return $ normalClause [pat] bod
@@ -1118,10 +1119,9 @@ mkEntity entityMap mps entDef = do
         if mpsGeneric mps
            then liftAndFixKeys entityMap entDef
            else makePersistEntityDefExp mps entityMap entDef
-    let nameT = unEntityNameHS entName
-    let nameS = unpack nameT
+    let name = mkEntityDefName entDef
     let clazz = ConT ''PersistEntity `AppT` genDataType
-    tpf <- mkToPersistFields mps nameS entDef
+    tpf <- mkToPersistFields mps entDef
     fpv <- mkFromPersistValues mps entDef
     utv <- mkUniqueToValues $ entityUniques entDef
     puk <- mkUniqueKeys entDef
@@ -1137,7 +1137,7 @@ mkEntity entityMap mps entDef = do
 
     let addSyn -- FIXME maybe remove this
             | mpsGeneric mps = (:) $
-                TySynD (mkName nameS) [] $
+                TySynD name [] $
                     genericDataType mps entName $ mpsBackend mps
             | otherwise = id
 
@@ -1175,7 +1175,7 @@ mkEntity entityMap mps entDef = do
     return $ addSyn $
        dtd : mconcat fkc `mappend`
       ([ TySynD (keyIdName entDef) [] $
-            ConT ''Key `AppT` ConT (mkName nameS)
+            ConT ''Key `AppT` ConT name
       , instanceD instanceConstraint clazz
         [ uniqueTypeDec mps entDef
         , keyTypeDec

From ee0889795313b918a24ca06f30e1581e51cfe64e Mon Sep 17 00:00:00 2001
From: Dan Brooks <danbroooks@users.noreply.github.com>
Date: Wed, 24 Mar 2021 17:46:22 +0000
Subject: [PATCH 09/28] Absorb more functions

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

diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
index b24377f03..78960b56c 100644
--- a/persistent/Database/Persist/TH.hs
+++ b/persistent/Database/Persist/TH.hs
@@ -754,7 +754,7 @@ mkToFieldNames pairs = do
         names' <- lift names
         return $
             normalClause
-                [RecP (mkName $ unpack $ unConstraintNameHS constr) []]
+                [RecP (mkConstraintName constr) []]
                 names'
 
 mkUniqueToValues :: [UniqueDef] -> Q Dec
@@ -765,7 +765,7 @@ mkUniqueToValues pairs = do
     go :: UniqueDef -> Q Clause
     go (UniqueDef constr _ names _) = do
         xs <- mapM (const $ newName "x") names
-        let pat = ConP (mkName $ unpack $ unConstraintNameHS constr) $ map VarP xs
+        let pat = ConP (mkConstraintName constr) $ map VarP xs
         tpv <- [|toPersistValue|]
         let bod = ListE $ map (AppE tpv . VarE) xs
         return $ normalClause [pat] bod
@@ -1572,7 +1572,7 @@ mkUniqueKeys def = do
 
     go :: [(FieldNameHS, Name)] -> UniqueDef -> Exp
     go xs (UniqueDef name _ cols _) =
-        foldl' (go' xs) (ConE (mkName $ unpack $ unConstraintNameHS name)) (map fst cols)
+        foldl' (go' xs) (ConE (mkConstraintName name)) (map fst cols)
 
     go' :: [(FieldNameHS, Name)] -> Exp -> FieldNameHS -> Exp
     go' xs front col =

From e943f2b3f5c94a98448028ab77e443012b386584 Mon Sep 17 00:00:00 2001
From: Dan Brooks <danbroooks@users.noreply.github.com>
Date: Wed, 24 Mar 2021 17:53:32 +0000
Subject: [PATCH 10/28] Another extraction

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

diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
index 78960b56c..ba2a052a0 100644
--- a/persistent/Database/Persist/TH.hs
+++ b/persistent/Database/Persist/TH.hs
@@ -782,8 +782,7 @@ mkFromPersistValues :: MkPersistSettings -> EntityDef -> Q [Clause]
 mkFromPersistValues _ entDef@(EntityDef { entitySum = False }) =
     fromValues entDef "fromPersistValues" entE $ entityFields entDef
   where
-    entE = ConE $ mkName $ unpack entName
-    entName = unEntityNameHS $ entityHaskell entDef
+    entE = ConE $ mkEntityDefName entDef
 
 mkFromPersistValues mps entDef@(EntityDef { entitySum = True }) = do
     nothing <- [|Left ("Invalid fromPersistValues input: sum type with all nulls. Entity: " `mappend` entName)|]

From 5811d15e23f27dd36cca29b1256e5515a3721eef Mon Sep 17 00:00:00 2001
From: Dan Brooks <danbroooks@users.noreply.github.com>
Date: Wed, 24 Mar 2021 18:01:58 +0000
Subject: [PATCH 11/28] Move already extracted functions for key names

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

diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
index ba2a052a0..91db1bfaf 100644
--- a/persistent/Database/Persist/TH.hs
+++ b/persistent/Database/Persist/TH.hs
@@ -966,39 +966,6 @@ mkKeyTypeDec mps entDef = do
     supplement :: [Name] -> [Name]
     supplement names = names <> (filter (`notElem` names) $ mpsDeriveInstances mps)
 
-keyIdName :: EntityDef -> Name
-keyIdName = mkName . unpack . keyIdText
-
-keyIdText :: EntityDef -> Text
-keyIdText entDef = unEntityNameHS (entityHaskell entDef) `mappend` "Id"
-
-unKeyName :: EntityDef -> Name
-unKeyName entDef = mkName $ "un" `mappend` keyString entDef
-
-unKeyExp :: EntityDef -> Exp
-unKeyExp = VarE . unKeyName
-
-backendT :: Type
-backendT = VarT backendName
-
-backendName :: Name
-backendName = mkName "backend"
-
-keyConName :: EntityDef -> Name
-keyConName entDef = mkName $ resolveConflict $ keyString entDef
-  where
-    resolveConflict kn = if conflict then kn `mappend` "'" else kn
-    conflict = any ((== FieldNameHS "key") . fieldHaskell) $ entityFields entDef
-
-keyConExp :: EntityDef -> Exp
-keyConExp = ConE . keyConName
-
-keyString :: EntityDef -> String
-keyString = unpack . keyText
-
-keyText :: EntityDef -> Text
-keyText entDef = unEntityNameHS (entityHaskell entDef) ++ "Key"
-
 -- | Returns 'True' if the key definition has more than 1 field.
 --
 -- @since 2.11.0.0
@@ -1024,11 +991,6 @@ keyFields mps entDef = case entityPrimary entDef of
                        , ftToType $ fieldType fieldDef
                        )
 
-keyFieldName :: MkPersistSettings -> EntityDef -> FieldDef -> Name
-keyFieldName mps entDef fieldDef
-  | pkNewtype mps entDef = unKeyName entDef
-  | otherwise = mkName $ unpack $ lowerFirst (keyText entDef) `mappend` unFieldNameHS (fieldHaskell fieldDef)
-
 mkKeyToValues :: MkPersistSettings -> EntityDef -> Q Dec
 mkKeyToValues mps entDef = do
     (p, e) <- case entityPrimary entDef of
@@ -2049,3 +2011,38 @@ sumConstrName mps entDef FieldDef {..} = mkName $ T.unpack name
 mkConstraintName :: ConstraintNameHS -> Name
 mkConstraintName (ConstraintNameHS name) =
     mkName (T.unpack name)
+
+keyIdName :: EntityDef -> Name
+keyIdName = mkName . T.unpack . keyIdText
+
+keyIdText :: EntityDef -> Text
+keyIdText entDef = unEntityNameHS (entityHaskell entDef) `mappend` "Id"
+
+unKeyName :: EntityDef -> Name
+unKeyName entDef = mkName $ T.unpack $ "un" `mappend` keyText entDef
+
+unKeyExp :: EntityDef -> Exp
+unKeyExp = VarE . unKeyName
+
+backendT :: Type
+backendT = VarT backendName
+
+backendName :: Name
+backendName = mkName "backend"
+
+keyConName :: EntityDef -> Name
+keyConName entDef = mkName $ T.unpack $ resolveConflict $ keyText entDef
+  where
+    resolveConflict kn = if conflict then kn `mappend` "'" else kn
+    conflict = any ((== FieldNameHS "key") . fieldHaskell) $ entityFields entDef
+
+keyConExp :: EntityDef -> Exp
+keyConExp = ConE . keyConName
+
+keyText :: EntityDef -> Text
+keyText entDef = unEntityNameHS (entityHaskell entDef) ++ "Key"
+
+keyFieldName :: MkPersistSettings -> EntityDef -> FieldDef -> Name
+keyFieldName mps entDef fieldDef
+  | pkNewtype mps entDef = unKeyName entDef
+  | otherwise = mkName $ T.unpack $ lowerFirst (keyText entDef) `mappend` unFieldNameHS (fieldHaskell fieldDef)

From a14202ce9a36cd1f1f6f70cbe2b82e99fbe7ae95 Mon Sep 17 00:00:00 2001
From: Dan Brooks <danbroooks@users.noreply.github.com>
Date: Wed, 24 Mar 2021 18:02:50 +0000
Subject: [PATCH 12/28] Refactor to reuse functions

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

diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
index 91db1bfaf..fc0aafc31 100644
--- a/persistent/Database/Persist/TH.hs
+++ b/persistent/Database/Persist/TH.hs
@@ -1268,9 +1268,8 @@ mkLenses :: MkPersistSettings -> EntityDef -> Q [Dec]
 mkLenses mps _ | not (mpsGenerateLenses mps) = return []
 mkLenses _ ent | entitySum ent = return []
 mkLenses mps ent = fmap mconcat $ forM (entityFields ent) $ \field -> do
-    let lensName' = recNameNoUnderscore mps (entityHaskell ent) (fieldHaskell field)
-        lensName = mkName $ unpack lensName'
-        fieldName = mkName $ unpack $ "_" ++ lensName'
+    let lensName = mkName $ T.unpack $ recNameNoUnderscore mps (entityHaskell ent) (fieldHaskell field)
+        fieldName = mkRecName mps (entityHaskell ent) (fieldHaskell field)
     needleN <- newName "needle"
     setterN <- newName "setter"
     fN <- newName "f"

From 22970efd4bae7dec7445a64bfb3be94d402eff0d Mon Sep 17 00:00:00 2001
From: Dan Brooks <danbroooks@users.noreply.github.com>
Date: Wed, 24 Mar 2021 18:05:43 +0000
Subject: [PATCH 13/28] More reuse

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

diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
index fc0aafc31..334f11faf 100644
--- a/persistent/Database/Persist/TH.hs
+++ b/persistent/Database/Persist/TH.hs
@@ -1319,7 +1319,7 @@ mkForeignKeysComposite mps entDef ForeignDef {..} =
     let fname = fieldName (constraintToField foreignConstraintNameHaskell)
     let reftableString = unpack $ unEntityNameHS foreignRefTableHaskell
     let reftableKeyName = mkName $ reftableString `mappend` "Key"
-    let tablename = mkName $ unpack $ entityText entDef
+    let tablename = mkEntityDefName entDef
     recordName <- newName "record"
 
     let mkFldE ((foreignName, _),ff) = case ff of

From 955fb6cbad5453b041add652660bec45893024ab Mon Sep 17 00:00:00 2001
From: Dan Brooks <danbroooks@users.noreply.github.com>
Date: Wed, 24 Mar 2021 18:10:02 +0000
Subject: [PATCH 14/28] More reuse

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

diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
index 334f11faf..3807237a5 100644
--- a/persistent/Database/Persist/TH.hs
+++ b/persistent/Database/Persist/TH.hs
@@ -1503,8 +1503,8 @@ mkEntityDefList entityList entityDefs = do
     let entityListName = mkName entityList
     edefs <- fmap ListE
         . forM entityDefs
-        $ \(EntityDef { entityHaskell = EntityNameHS haskellName }) ->
-            let entityType = conT (mkName (T.unpack haskellName))
+        $ \entityDef ->
+            let entityType = conT (mkEntityDefName entityDef)
              in [|entityDef (Proxy :: Proxy $(entityType))|]
     typ <- [t|[EntityDef]|]
     pure
@@ -1526,7 +1526,7 @@ mkUniqueKeys def = do
             return (x, x')
         let pcs = map (go xs) $ entityUniques def
         let pat = ConP
-                (mkName $ unpack $ unEntityNameHS $ entityHaskell def)
+                (mkEntityDefName def)
                 (map (VarP . snd) xs)
         return $ normalClause [pat] (ListE pcs)
 
@@ -1896,13 +1896,13 @@ mkSymbolToFieldInstances mps ed = do
                 litT $ strTyLit $ T.unpack $ unFieldNameHS $ fieldHaskell fieldDef
                     :: Q Type
 
-            nameG = mkName $ unpack $ unEntityNameHS (entityHaskell ed) ++ "Generic"
+            nameG = mkEntityDefGenericName ed
 
             recordNameT
                 | mpsGeneric mps =
                     conT nameG `appT` varT backendName
                 | otherwise =
-                    conT $ mkName $ T.unpack $ unEntityNameHS $ entityHaskell ed
+                    conT $ mkEntityDefName ed
 
             fieldTypeT =
                 maybeIdType mps fieldDef Nothing Nothing

From 09a481bb88ff4b19b528c6c90ccfcc8e55b7067d Mon Sep 17 00:00:00 2001
From: Dan Brooks <danbroooks@users.noreply.github.com>
Date: Wed, 24 Mar 2021 18:10:30 +0000
Subject: [PATCH 15/28] Move filterConName

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

diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
index 3807237a5..67aa0a62e 100644
--- a/persistent/Database/Persist/TH.hs
+++ b/persistent/Database/Persist/TH.hs
@@ -1736,26 +1736,6 @@ mkField mps et cd = do
 maybeNullable :: FieldDef -> Bool
 maybeNullable fd = nullable (fieldAttrs fd) == Nullable ByMaybeAttr
 
-filterConName :: MkPersistSettings
-              -> EntityDef
-              -> FieldDef
-              -> Name
-filterConName mps entity field = filterConName' mps (entityHaskell entity) (fieldHaskell field)
-
-filterConName' :: MkPersistSettings
-               -> EntityNameHS
-               -> FieldNameHS
-               -> Name
-filterConName' mps entity field = mkName $ unpack name
-    where
-        name
-            | field == FieldNameHS "Id" = entityName ++ fieldName
-            | mpsPrefixFields mps       = modifiedName
-            | otherwise                 = fieldName
-        modifiedName = mpsConstraintLabelModifier mps entityName fieldName
-        entityName   = unEntityNameHS entity
-        fieldName    = upperFirst $ unFieldNameHS field
-
 ftToType :: FieldType -> Type
 ftToType (FTTypeCon Nothing t) = ConT $ mkName $ unpack t
 -- This type is generated from the Quasi-Quoter.
@@ -2045,3 +2025,23 @@ keyFieldName :: MkPersistSettings -> EntityDef -> FieldDef -> Name
 keyFieldName mps entDef fieldDef
   | pkNewtype mps entDef = unKeyName entDef
   | otherwise = mkName $ T.unpack $ lowerFirst (keyText entDef) `mappend` unFieldNameHS (fieldHaskell fieldDef)
+
+filterConName :: MkPersistSettings
+              -> EntityDef
+              -> FieldDef
+              -> Name
+filterConName mps entity field = filterConName' mps (entityHaskell entity) (fieldHaskell field)
+
+filterConName' :: MkPersistSettings
+               -> EntityNameHS
+               -> FieldNameHS
+               -> Name
+filterConName' mps entity field = mkName $ unpack name
+    where
+        name
+            | field == FieldNameHS "Id" = entityName ++ fieldName
+            | mpsPrefixFields mps       = modifiedName
+            | otherwise                 = fieldName
+        modifiedName = mpsConstraintLabelModifier mps entityName fieldName
+        entityName   = unEntityNameHS entity
+        fieldName    = upperFirst $ unFieldNameHS field

From 3cfeab68102547d0a1fb9a43a38110f6ff38288d Mon Sep 17 00:00:00 2001
From: Dan Brooks <danbroooks@users.noreply.github.com>
Date: Wed, 24 Mar 2021 18:13:46 +0000
Subject: [PATCH 16/28] Consistent unpack

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

diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
index 67aa0a62e..9a483c325 100644
--- a/persistent/Database/Persist/TH.hs
+++ b/persistent/Database/Persist/TH.hs
@@ -2036,7 +2036,7 @@ filterConName' :: MkPersistSettings
                -> EntityNameHS
                -> FieldNameHS
                -> Name
-filterConName' mps entity field = mkName $ unpack name
+filterConName' mps entity field = mkName $ T.unpack name
     where
         name
             | field == FieldNameHS "Id" = entityName ++ fieldName

From 855008dfd7d6bbc93718cac5fb4d6f2c7ad7acbf Mon Sep 17 00:00:00 2001
From: Dan Brooks <danbroooks@users.noreply.github.com>
Date: Wed, 24 Mar 2021 18:16:56 +0000
Subject: [PATCH 17/28] Dont shaddow name

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

diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
index 9a483c325..ba3255aa7 100644
--- a/persistent/Database/Persist/TH.hs
+++ b/persistent/Database/Persist/TH.hs
@@ -1503,8 +1503,8 @@ mkEntityDefList entityList entityDefs = do
     let entityListName = mkName entityList
     edefs <- fmap ListE
         . forM entityDefs
-        $ \entityDef ->
-            let entityType = conT (mkEntityDefName entityDef)
+        $ \entDef ->
+            let entityType = conT (mkEntityDefName entDef)
              in [|entityDef (Proxy :: Proxy $(entityType))|]
     typ <- [t|[EntityDef]|]
     pure

From 6b95316dac0c2b305765c602ce101c4f865a3332 Mon Sep 17 00:00:00 2001
From: Dan Brooks <danbroooks@users.noreply.github.com>
Date: Wed, 24 Mar 2021 20:35:34 +0000
Subject: [PATCH 18/28] Extracting helpers

---
 persistent/Database/Persist/TH.hs | 17 +++++++++++++----
 1 file changed, 13 insertions(+), 4 deletions(-)

diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
index ba3255aa7..8a706ab55 100644
--- a/persistent/Database/Persist/TH.hs
+++ b/persistent/Database/Persist/TH.hs
@@ -93,7 +93,7 @@ import GHC.TypeLits
 import Instances.TH.Lift ()
     -- Bring `Lift (Map k v)` instance into scope, as well as `Lift Text`
     -- instance on pre-1.2.4 versions of `text`
-import Language.Haskell.TH.Lib (appT, varT, conT, varE, varP, conE, litT, strTyLit)
+import Language.Haskell.TH.Lib (appT, varT, conK, conT, varE, varP, conE, litT, strTyLit)
 import Language.Haskell.TH.Quote
 import Language.Haskell.TH.Syntax
 import Web.PathPieces (PathPiece(..))
@@ -782,7 +782,7 @@ mkFromPersistValues :: MkPersistSettings -> EntityDef -> Q [Clause]
 mkFromPersistValues _ entDef@(EntityDef { entitySum = False }) =
     fromValues entDef "fromPersistValues" entE $ entityFields entDef
   where
-    entE = ConE $ mkEntityDefName entDef
+    entE = entityDefConE entDef
 
 mkFromPersistValues mps entDef@(EntityDef { entitySum = True }) = do
     nothing <- [|Left ("Invalid fromPersistValues input: sum type with all nulls. Entity: " `mappend` entName)|]
@@ -1504,7 +1504,7 @@ mkEntityDefList entityList entityDefs = do
     edefs <- fmap ListE
         . forM entityDefs
         $ \entDef ->
-            let entityType = conT (mkEntityDefName entDef)
+            let entityType = entityDefConT entDef
              in [|entityDef (Proxy :: Proxy $(entityType))|]
     typ <- [t|[EntityDef]|]
     pure
@@ -1882,7 +1882,7 @@ mkSymbolToFieldInstances mps ed = do
                 | mpsGeneric mps =
                     conT nameG `appT` varT backendName
                 | otherwise =
-                    conT $ mkEntityDefName ed
+                    entityDefConT ed
 
             fieldTypeT =
                 maybeIdType mps fieldDef Nothing Nothing
@@ -1944,6 +1944,15 @@ unFieldNameHSForJSON = fixTypeUnderscore . unFieldNameHS
         "type" -> "type_"
         name -> name
 
+entityDefConK :: EntityDef -> Kind
+entityDefConK = conK . mkEntityDefName
+
+entityDefConT :: EntityDef -> Q Type
+entityDefConT = pure . entityDefConK
+
+entityDefConE :: EntityDef -> Exp
+entityDefConE = ConE . mkEntityDefName
+
 -- | creates a TH Name for an entity's field, based on the entity
 -- name and the field name, so for example:
 --

From e4ff6888b8dfd22e67a993a1c5f3b4f4196890f4 Mon Sep 17 00:00:00 2001
From: Dan Brooks <danbroooks@users.noreply.github.com>
Date: Mon, 29 Mar 2021 19:18:31 +0100
Subject: [PATCH 19/28] Change mkRecName to take EntityDef

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

diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
index 8a706ab55..61ccc31d9 100644
--- a/persistent/Database/Persist/TH.hs
+++ b/persistent/Database/Persist/TH.hs
@@ -611,7 +611,7 @@ dataTypeDec mps entDef = do
     (nameFinal, paramsFinal)
         | mpsGeneric mps = (mkEntityDefGenericName entDef, [PlainTV backendName])
         | otherwise = (mkEntityDefName entDef, [])
-    cols = map (mkCol $ entityHaskell entDef) $ entityFields entDef
+    cols = map (mkCol entDef) $ entityFields entDef
 
     constrs
         | entitySum entDef = map sumCon $ entityFields entDef
@@ -835,7 +835,7 @@ mkLensClauses mps entDef = do
         [ConP (filterConName mps entDef f) []]
         (lens' `AppE` getter `AppE` setter)
       where
-        fieldName = mkRecName mps (entityHaskell entDef) (fieldHaskell f)
+        fieldName = mkRecName mps entDef (fieldHaskell f)
         getter = InfixE (Just $ VarE fieldName) dot (Just getVal)
         setter = LamE
             [ ConP 'Entity [VarP keyVar, VarP valName]
@@ -1114,7 +1114,7 @@ mkEntity entityMap mps entDef = do
                 recordName <- newName "record"
                 let keyCon = keyConName entDef
                     keyFields' =
-                        map (mkRecName mps entName . fieldHaskell)
+                        map (mkRecName mps entDef . fieldHaskell)
                             (compositeFields prim)
                     constr =
                         foldl'
@@ -1269,7 +1269,7 @@ mkLenses mps _ | not (mpsGenerateLenses mps) = return []
 mkLenses _ ent | entitySum ent = return []
 mkLenses mps ent = fmap mconcat $ forM (entityFields ent) $ \field -> do
     let lensName = mkName $ T.unpack $ recNameNoUnderscore mps (entityHaskell ent) (fieldHaskell field)
-        fieldName = mkRecName mps (entityHaskell ent) (fieldHaskell field)
+        fieldName = mkRecName mps ent (fieldHaskell field)
     needleN <- newName "needle"
     setterN <- newName "setter"
     fN <- newName "f"
@@ -1315,7 +1315,7 @@ mkLenses mps ent = fmap mconcat $ forM (entityFields ent) $ \field -> do
 mkForeignKeysComposite :: MkPersistSettings -> EntityDef -> ForeignDef -> Q [Dec]
 mkForeignKeysComposite mps entDef ForeignDef {..} =
     if not foreignToPrimary then return [] else do
-    let fieldName f = mkRecName mps (entityHaskell entDef) f
+    let fieldName f = mkRecName mps entDef f
     let fname = fieldName (constraintToField foreignConstraintNameHaskell)
     let reftableString = unpack $ unEntityNameHS foreignRefTableHaskell
     let reftableKeyName = mkName $ reftableString `mappend` "Key"
@@ -1960,8 +1960,8 @@ entityDefConE = ConE . mkEntityDefName
 --   name Text
 --
 -- This would generate `customerName` as a TH Name
-mkRecName :: MkPersistSettings -> EntityNameHS -> FieldNameHS -> Name
-mkRecName mps entName fieldName = mkName $ T.unpack $ recNameF mps entName fieldName
+mkRecName :: MkPersistSettings -> EntityDef -> FieldNameHS -> Name
+mkRecName mps entDef fieldName = mkName $ T.unpack $ recNameF mps (entityHaskell entDef) fieldName
 
 -- | Take an EntityDef's `entityDerives` and turn them into TH Names
 mkEntityDefDeriveNames :: EntityDef -> [Name]

From f690488d12494ddf5606de046e2ff3fca364616c Mon Sep 17 00:00:00 2001
From: Dan Brooks <danbroooks@users.noreply.github.com>
Date: Mon, 29 Mar 2021 19:31:45 +0100
Subject: [PATCH 20/28] Move entity derives logic out into name creation
 function

---
 persistent/Database/Persist/TH.hs | 13 +++++++------
 1 file changed, 7 insertions(+), 6 deletions(-)

diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
index 61ccc31d9..16b6af176 100644
--- a/persistent/Database/Persist/TH.hs
+++ b/persistent/Database/Persist/TH.hs
@@ -573,9 +573,7 @@ upperFirst t =
 
 dataTypeDec :: MkPersistSettings -> EntityDef -> Q Dec
 dataTypeDec mps entDef = do
-    let entityInstances     = mkEntityDefDeriveNames entDef
-        additionalInstances = filter (`notElem` entityInstances) $ mpsDeriveInstances mps
-        names               = entityInstances <> additionalInstances
+    let names = mkEntityDefDeriveNames mps entDef
 
     let (stocks, anyclasses) = partitionEithers (map stratFor names)
     let stockDerives = do
@@ -1963,9 +1961,12 @@ entityDefConE = ConE . mkEntityDefName
 mkRecName :: MkPersistSettings -> EntityDef -> FieldNameHS -> Name
 mkRecName mps entDef fieldName = mkName $ T.unpack $ recNameF mps (entityHaskell entDef) fieldName
 
--- | Take an EntityDef's `entityDerives` and turn them into TH Names
-mkEntityDefDeriveNames :: EntityDef -> [Name]
-mkEntityDefDeriveNames = fmap (mkName . T.unpack) . entityDerives
+-- | Construct a list of TH Names for the typeclasses of an EntityDef's `entityDerives`
+mkEntityDefDeriveNames :: MkPersistSettings -> EntityDef -> [Name]
+mkEntityDefDeriveNames mps entDef =
+    let entityInstances = mkName . T.unpack <$> entityDerives entDef
+        additionalInstances = filter (`notElem` entityInstances) $ mpsDeriveInstances mps
+     in entityInstances <> additionalInstances
 
 -- | Make a TH Name for the EntityDef's Haskell type
 mkEntityDefName :: EntityDef -> Name

From c6fea20f0794fa45f1f4697749598156a03a42b7 Mon Sep 17 00:00:00 2001
From: Dan Brooks <danbroooks@users.noreply.github.com>
Date: Mon, 29 Mar 2021 19:36:24 +0100
Subject: [PATCH 21/28] DRY up `backendT`

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

diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
index 16b6af176..4fa692d65 100644
--- a/persistent/Database/Persist/TH.hs
+++ b/persistent/Database/Persist/TH.hs
@@ -1204,7 +1204,7 @@ mkUniqueKeyInstances mps entDef = do
     withPersistStoreWriteCxt =
         if mpsGeneric mps
             then do
-                write <- [t|PersistStoreWrite $(pure (VarT $ mkName "backend")) |]
+                write <- [t|PersistStoreWrite $(pure backendT) |]
                 pure [write]
             else do
                 pure []

From e298145b8e42c2b51278b865bb162163cc9591ff Mon Sep 17 00:00:00 2001
From: Dan Brooks <danbroooks@users.noreply.github.com>
Date: Mon, 29 Mar 2021 19:46:52 +0100
Subject: [PATCH 22/28] Rename function

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

diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
index 4fa692d65..c03213132 100644
--- a/persistent/Database/Persist/TH.hs
+++ b/persistent/Database/Persist/TH.hs
@@ -602,7 +602,7 @@ dataTypeDec mps entDef = do
         ]
         )
     mkCol x fd@FieldDef {..} =
-        (mkRecName mps x fieldHaskell,
+        (mkFieldDefRecordName mps x fieldHaskell,
          if fieldStrict then isStrict else notStrict,
          maybeIdType mps fd Nothing Nothing
         )
@@ -833,7 +833,7 @@ mkLensClauses mps entDef = do
         [ConP (filterConName mps entDef f) []]
         (lens' `AppE` getter `AppE` setter)
       where
-        fieldName = mkRecName mps entDef (fieldHaskell f)
+        fieldName = mkFieldDefRecordName mps entDef (fieldHaskell f)
         getter = InfixE (Just $ VarE fieldName) dot (Just getVal)
         setter = LamE
             [ ConP 'Entity [VarP keyVar, VarP valName]
@@ -1112,7 +1112,7 @@ mkEntity entityMap mps entDef = do
                 recordName <- newName "record"
                 let keyCon = keyConName entDef
                     keyFields' =
-                        map (mkRecName mps entDef . fieldHaskell)
+                        map (mkFieldDefRecordName mps entDef . fieldHaskell)
                             (compositeFields prim)
                     constr =
                         foldl'
@@ -1267,7 +1267,7 @@ mkLenses mps _ | not (mpsGenerateLenses mps) = return []
 mkLenses _ ent | entitySum ent = return []
 mkLenses mps ent = fmap mconcat $ forM (entityFields ent) $ \field -> do
     let lensName = mkName $ T.unpack $ recNameNoUnderscore mps (entityHaskell ent) (fieldHaskell field)
-        fieldName = mkRecName mps ent (fieldHaskell field)
+        fieldName = mkFieldDefRecordName mps ent (fieldHaskell field)
     needleN <- newName "needle"
     setterN <- newName "setter"
     fN <- newName "f"
@@ -1313,7 +1313,7 @@ mkLenses mps ent = fmap mconcat $ forM (entityFields ent) $ \field -> do
 mkForeignKeysComposite :: MkPersistSettings -> EntityDef -> ForeignDef -> Q [Dec]
 mkForeignKeysComposite mps entDef ForeignDef {..} =
     if not foreignToPrimary then return [] else do
-    let fieldName f = mkRecName mps entDef f
+    let fieldName f = mkFieldDefRecordName mps entDef f
     let fname = fieldName (constraintToField foreignConstraintNameHaskell)
     let reftableString = unpack $ unEntityNameHS foreignRefTableHaskell
     let reftableKeyName = mkName $ reftableString `mappend` "Key"
@@ -1958,8 +1958,8 @@ entityDefConE = ConE . mkEntityDefName
 --   name Text
 --
 -- This would generate `customerName` as a TH Name
-mkRecName :: MkPersistSettings -> EntityDef -> FieldNameHS -> Name
-mkRecName mps entDef fieldName = mkName $ T.unpack $ recNameF mps (entityHaskell entDef) fieldName
+mkFieldDefRecordName :: MkPersistSettings -> EntityDef -> FieldNameHS -> Name
+mkFieldDefRecordName mps entDef fieldName = mkName $ T.unpack $ recNameF mps (entityHaskell entDef) fieldName
 
 -- | Construct a list of TH Names for the typeclasses of an EntityDef's `entityDerives`
 mkEntityDefDeriveNames :: MkPersistSettings -> EntityDef -> [Name]

From 0d3bfca44588435e3b6858f68893a11c18fddfc5 Mon Sep 17 00:00:00 2001
From: Dan Brooks <danbroooks@users.noreply.github.com>
Date: Mon, 29 Mar 2021 19:52:23 +0100
Subject: [PATCH 23/28] Refactor cols value

---
 persistent/Database/Persist/TH.hs | 15 +++++++++------
 1 file changed, 9 insertions(+), 6 deletions(-)

diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
index c03213132..a67e67692 100644
--- a/persistent/Database/Persist/TH.hs
+++ b/persistent/Database/Persist/TH.hs
@@ -601,15 +601,18 @@ dataTypeDec mps entDef = do
         ] <> [''Eq, ''Ord, ''Show, ''Read, ''Bounded, ''Enum, ''Ix, ''Generic, ''Data, ''Typeable
         ]
         )
-    mkCol x fd@FieldDef {..} =
-        (mkFieldDefRecordName mps x fieldHaskell,
-         if fieldStrict then isStrict else notStrict,
-         maybeIdType mps fd Nothing Nothing
-        )
+
     (nameFinal, paramsFinal)
         | mpsGeneric mps = (mkEntityDefGenericName entDef, [PlainTV backendName])
         | otherwise = (mkEntityDefName entDef, [])
-    cols = map (mkCol entDef) $ entityFields entDef
+
+    cols :: [VarBangType]
+    cols = do
+        fd@FieldDef{..} <- entityFields entDef
+        let recordName = mkFieldDefRecordName mps entDef fieldHaskell
+            strictness = if fieldStrict then isStrict else notStrict
+            fieldIdType = maybeIdType mps fd Nothing Nothing
+         in pure (recordName, strictness, fieldIdType)
 
     constrs
         | entitySum entDef = map sumCon $ entityFields entDef

From 808d457f26a2309ff3bf291d5309d1b7a99e635f Mon Sep 17 00:00:00 2001
From: Dan Brooks <danbroooks@users.noreply.github.com>
Date: Mon, 29 Mar 2021 19:54:11 +0100
Subject: [PATCH 24/28] More renaming

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

diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
index a67e67692..51a9b5875 100644
--- a/persistent/Database/Persist/TH.hs
+++ b/persistent/Database/Persist/TH.hs
@@ -609,7 +609,7 @@ dataTypeDec mps entDef = do
     cols :: [VarBangType]
     cols = do
         fd@FieldDef{..} <- entityFields entDef
-        let recordName = mkFieldDefRecordName mps entDef fieldHaskell
+        let recordName = fieldNameToRecordName mps entDef fieldHaskell
             strictness = if fieldStrict then isStrict else notStrict
             fieldIdType = maybeIdType mps fd Nothing Nothing
          in pure (recordName, strictness, fieldIdType)
@@ -836,7 +836,7 @@ mkLensClauses mps entDef = do
         [ConP (filterConName mps entDef f) []]
         (lens' `AppE` getter `AppE` setter)
       where
-        fieldName = mkFieldDefRecordName mps entDef (fieldHaskell f)
+        fieldName = fieldNameToRecordName mps entDef (fieldHaskell f)
         getter = InfixE (Just $ VarE fieldName) dot (Just getVal)
         setter = LamE
             [ ConP 'Entity [VarP keyVar, VarP valName]
@@ -1115,7 +1115,7 @@ mkEntity entityMap mps entDef = do
                 recordName <- newName "record"
                 let keyCon = keyConName entDef
                     keyFields' =
-                        map (mkFieldDefRecordName mps entDef . fieldHaskell)
+                        map (fieldNameToRecordName mps entDef . fieldHaskell)
                             (compositeFields prim)
                     constr =
                         foldl'
@@ -1270,7 +1270,7 @@ mkLenses mps _ | not (mpsGenerateLenses mps) = return []
 mkLenses _ ent | entitySum ent = return []
 mkLenses mps ent = fmap mconcat $ forM (entityFields ent) $ \field -> do
     let lensName = mkName $ T.unpack $ recNameNoUnderscore mps (entityHaskell ent) (fieldHaskell field)
-        fieldName = mkFieldDefRecordName mps ent (fieldHaskell field)
+        fieldName = fieldNameToRecordName mps ent (fieldHaskell field)
     needleN <- newName "needle"
     setterN <- newName "setter"
     fN <- newName "f"
@@ -1316,7 +1316,7 @@ mkLenses mps ent = fmap mconcat $ forM (entityFields ent) $ \field -> do
 mkForeignKeysComposite :: MkPersistSettings -> EntityDef -> ForeignDef -> Q [Dec]
 mkForeignKeysComposite mps entDef ForeignDef {..} =
     if not foreignToPrimary then return [] else do
-    let fieldName f = mkFieldDefRecordName mps entDef f
+    let fieldName f = fieldNameToRecordName mps entDef f
     let fname = fieldName (constraintToField foreignConstraintNameHaskell)
     let reftableString = unpack $ unEntityNameHS foreignRefTableHaskell
     let reftableKeyName = mkName $ reftableString `mappend` "Key"
@@ -1961,8 +1961,8 @@ entityDefConE = ConE . mkEntityDefName
 --   name Text
 --
 -- This would generate `customerName` as a TH Name
-mkFieldDefRecordName :: MkPersistSettings -> EntityDef -> FieldNameHS -> Name
-mkFieldDefRecordName mps entDef fieldName = mkName $ T.unpack $ recNameF mps (entityHaskell entDef) fieldName
+fieldNameToRecordName :: MkPersistSettings -> EntityDef -> FieldNameHS -> Name
+fieldNameToRecordName mps entDef fieldName = mkName $ T.unpack $ recNameF mps (entityHaskell entDef) fieldName
 
 -- | Construct a list of TH Names for the typeclasses of an EntityDef's `entityDerives`
 mkEntityDefDeriveNames :: MkPersistSettings -> EntityDef -> [Name]

From 399e7f69bc378babe3488810ff9cb656a289f5f3 Mon Sep 17 00:00:00 2001
From: Dan Brooks <danbroooks@users.noreply.github.com>
Date: Mon, 29 Mar 2021 20:00:27 +0100
Subject: [PATCH 25/28] More shifting around

---
 persistent/Database/Persist/TH.hs | 35 +++++++++++++++++--------------
 1 file changed, 19 insertions(+), 16 deletions(-)

diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
index 51a9b5875..7224f95db 100644
--- a/persistent/Database/Persist/TH.hs
+++ b/persistent/Database/Persist/TH.hs
@@ -608,10 +608,10 @@ dataTypeDec mps entDef = do
 
     cols :: [VarBangType]
     cols = do
-        fd@FieldDef{..} <- entityFields entDef
-        let recordName = fieldNameToRecordName mps entDef fieldHaskell
-            strictness = if fieldStrict then isStrict else notStrict
-            fieldIdType = maybeIdType mps fd Nothing Nothing
+        fieldDef <- entityFields entDef
+        let recordName = fieldDefToRecordName mps entDef fieldDef
+            strictness = if fieldStrict fieldDef then isStrict else notStrict
+            fieldIdType = maybeIdType mps fieldDef Nothing Nothing
          in pure (recordName, strictness, fieldIdType)
 
     constrs
@@ -832,11 +832,11 @@ mkLensClauses mps entDef = do
         then return $ idClause : map (toSumClause lens' keyVar valName xName) (entityFields entDef)
         else return $ idClause : map (toClause lens' getVal dot keyVar valName xName) (entityFields entDef)
   where
-    toClause lens' getVal dot keyVar valName xName f = normalClause
-        [ConP (filterConName mps entDef f) []]
+    toClause lens' getVal dot keyVar valName xName fieldDef = normalClause
+        [ConP (filterConName mps entDef fieldDef) []]
         (lens' `AppE` getter `AppE` setter)
       where
-        fieldName = fieldNameToRecordName mps entDef (fieldHaskell f)
+        fieldName = fieldDefToRecordName mps entDef fieldDef
         getter = InfixE (Just $ VarE fieldName) dot (Just getVal)
         setter = LamE
             [ ConP 'Entity [VarP keyVar, VarP valName]
@@ -1114,9 +1114,7 @@ mkEntity entityMap mps entDef = do
             Just prim -> do
                 recordName <- newName "record"
                 let keyCon = keyConName entDef
-                    keyFields' =
-                        map (fieldNameToRecordName mps entDef . fieldHaskell)
-                            (compositeFields prim)
+                    keyFields' = fieldDefToRecordName mps entDef <$> compositeFields prim
                     constr =
                         foldl'
                             AppE
@@ -1270,7 +1268,7 @@ mkLenses mps _ | not (mpsGenerateLenses mps) = return []
 mkLenses _ ent | entitySum ent = return []
 mkLenses mps ent = fmap mconcat $ forM (entityFields ent) $ \field -> do
     let lensName = mkName $ T.unpack $ recNameNoUnderscore mps (entityHaskell ent) (fieldHaskell field)
-        fieldName = fieldNameToRecordName mps ent (fieldHaskell field)
+        fieldName = fieldDefToRecordName mps ent field
     needleN <- newName "needle"
     setterN <- newName "setter"
     fN <- newName "f"
@@ -1316,7 +1314,7 @@ mkLenses mps ent = fmap mconcat $ forM (entityFields ent) $ \field -> do
 mkForeignKeysComposite :: MkPersistSettings -> EntityDef -> ForeignDef -> Q [Dec]
 mkForeignKeysComposite mps entDef ForeignDef {..} =
     if not foreignToPrimary then return [] else do
-    let fieldName f = fieldNameToRecordName mps entDef f
+    let fieldName = fieldNameToRecordName mps entDef
     let fname = fieldName (constraintToField foreignConstraintNameHaskell)
     let reftableString = unpack $ unEntityNameHS foreignRefTableHaskell
     let reftableKeyName = mkName $ reftableString `mappend` "Key"
@@ -1964,6 +1962,10 @@ entityDefConE = ConE . mkEntityDefName
 fieldNameToRecordName :: MkPersistSettings -> EntityDef -> FieldNameHS -> Name
 fieldNameToRecordName mps entDef fieldName = mkName $ T.unpack $ recNameF mps (entityHaskell entDef) fieldName
 
+-- | as above, only takes a `FieldDef`
+fieldDefToRecordName :: MkPersistSettings -> EntityDef -> FieldDef -> Name
+fieldDefToRecordName mps entDef fieldDef = fieldNameToRecordName mps entDef (fieldHaskell fieldDef)
+
 -- | Construct a list of TH Names for the typeclasses of an EntityDef's `entityDerives`
 mkEntityDefDeriveNames :: MkPersistSettings -> EntityDef -> [Name]
 mkEntityDefDeriveNames mps entDef =
@@ -1972,14 +1974,15 @@ mkEntityDefDeriveNames mps entDef =
      in entityInstances <> additionalInstances
 
 -- | Make a TH Name for the EntityDef's Haskell type
-mkEntityDefName :: EntityDef -> Name
-mkEntityDefName =
-    mkEntityNameHSName . entityHaskell
-
 mkEntityNameHSName :: EntityNameHS -> Name
 mkEntityNameHSName =
     mkName . T.unpack . unEntityNameHS
 
+-- | As above only taking an `EntityDef`
+mkEntityDefName :: EntityDef -> Name
+mkEntityDefName =
+    mkEntityNameHSName . entityHaskell
+
 -- | Make a TH Name for the EntityDef's Haskell type, when using mpsGeneric
 mkEntityDefGenericName :: EntityDef -> Name
 mkEntityDefGenericName =

From d0a41bb76a3654f7f90654f87c3f70c6bb1e82b6 Mon Sep 17 00:00:00 2001
From: Dan Brooks <danbroooks@users.noreply.github.com>
Date: Tue, 20 Apr 2021 07:59:55 +0100
Subject: [PATCH 26/28] Update changelog

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

diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md
index 4d1b76097..abf6d3d1b 100644
--- a/persistent/ChangeLog.md
+++ b/persistent/ChangeLog.md
@@ -2,7 +2,8 @@
 
 ## 2.12.1.0
 
-*  [#1226](https://github.com/yesodweb/persistent/pull/1226)
+* [#1218](https://github.com/yesodweb/persistent/pull/1218) Refactoring name generating functions in TH
+* [#1226](https://github.com/yesodweb/persistent/pull/1226)
     * Expose the `filterClause` and `filterClauseWithValues` functions to support
       the `upsertWhere` functionality in `persistent-postgresql`.
 

From d9895854eeb84cb94d8ea34783f4e7086e59742c Mon Sep 17 00:00:00 2001
From: Dan Brooks <danbroooks@users.noreply.github.com>
Date: Tue, 20 Apr 2021 08:01:26 +0100
Subject: [PATCH 27/28] Flip changelog formatting

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

diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md
index abf6d3d1b..e71b26a98 100644
--- a/persistent/ChangeLog.md
+++ b/persistent/ChangeLog.md
@@ -2,7 +2,7 @@
 
 ## 2.12.1.0
 
-* [#1218](https://github.com/yesodweb/persistent/pull/1218) Refactoring name generating functions in TH
+* Refactoring name generating functions in TH [#1218](https://github.com/yesodweb/persistent/pull/1218)
 * [#1226](https://github.com/yesodweb/persistent/pull/1226)
     * Expose the `filterClause` and `filterClauseWithValues` functions to support
       the `upsertWhere` functionality in `persistent-postgresql`.

From 49eebea0bbde4504d8869b3c942cffcd0e07b424 Mon Sep 17 00:00:00 2001
From: Dan Brooks <danbroooks@users.noreply.github.com>
Date: Tue, 20 Apr 2021 08:02:40 +0100
Subject: [PATCH 28/28] Tweaking changlog format again

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

diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md
index e71b26a98..71405bbeb 100644
--- a/persistent/ChangeLog.md
+++ b/persistent/ChangeLog.md
@@ -2,7 +2,8 @@
 
 ## 2.12.1.0
 
-* Refactoring name generating functions in TH [#1218](https://github.com/yesodweb/persistent/pull/1218)
+* [#1218](https://github.com/yesodweb/persistent/pull/1218)
+    * Refactoring name generating functions in TH 
 * [#1226](https://github.com/yesodweb/persistent/pull/1226)
     * Expose the `filterClause` and `filterClauseWithValues` functions to support
       the `upsertWhere` functionality in `persistent-postgresql`.