fix a problem preventing use of Primary with NoFieldselectors (#1460)

* fix a problem preventing use of Primary with NoFieldselectors * bump the version to 2.14.4.4 and update ChangeLog.md
yesodweb · Jan 5, 2023 · bea2018 · bea2018
1 parent 7222127
commit bea2018
Show file tree

Hide file tree

Showing 4 changed files with 16 additions and 10 deletions.
diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md
@@ -1,5 +1,11 @@
 # Changelog for persistent
 
+## 2.14.4.4
+
+* [#1460] https://github.com/yesodweb/persistent/pull/1460
+    * Fix a problem where a `Primary` key causes `mkPersist` to generate code
+      that doesn't compile under `NoFieldSelectors`
+
 ## 2.14.4.3
 
 * [#1452](https://github.com/yesodweb/persistent/pull/1452)

diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
@@ -1847,8 +1847,10 @@ mkKeyToValues mps entDef = do
         ListE <$> mapM (f recName) (toList $ unboundCompositeCols ucd)
     f recName fieldNameHS =
         [|
-        toPersistValue ($(varE $ keyFieldName mps entDef fieldNameHS) $(varE recName))
+        toPersistValue ($(pure $ keyFieldSel fieldNameHS) $(varE recName))
         |]
+    keyFieldSel name
+        = fieldSel (keyConName entDef) (keyFieldName mps entDef name)
 
 normalClause :: [Pat] -> Exp -> Clause
 normalClause p e = Clause p (NormalB e) []
@@ -1992,7 +1994,6 @@ mkEntity embedEntityMap entityMap mps preDef = do
     [keyFromRecordM'] <-
         case unboundPrimarySpec entDef of
             NaturalKey ucd -> do
-                recordVarName <- newName "record"
                 let
                     keyCon =
                         keyConName entDef
@@ -2002,15 +2003,11 @@ mkEntity embedEntityMap entityMap mps preDef = do
                         foldl'
                             AppE
                             (ConE keyCon)
-                            (toList $ fmap
-                                (\n ->
-                                    VarE n `AppE` VarE recordVarName
-                                )
-                                keyFields'
-                            )
+                            (VarE <$> keyFields')
                     keyFromRec = varP 'keyFromRecordM
+                    lam = LamE [RecP name [(n, VarP n) | n <- toList keyFields']] constr
                 [d|
-                    $(keyFromRec) = Just ( \ $(varP recordVarName) -> $(pure constr))
+                    $(keyFromRec) = Just $(pure lam)
                     |]
 
             _ ->

diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal
@@ -1,5 +1,5 @@
 name:            persistent
-version:         2.14.4.3
+version:         2.14.4.4
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <[email protected]>

diff --git a/persistent/test/Database/Persist/TH/NoFieldSelectorsSpec.hs b/persistent/test/Database/Persist/TH/NoFieldSelectorsSpec.hs
@@ -21,7 +21,10 @@ import TemplateTestImports
 
 mkPersist sqlSettings {mpsFieldLabelModifier = const id} [persistLowerCase|
 User
+    ident Text
     name Text
+    Primary ident
+    team TeamId
 
 Team
     name Text