Avoid parse error occurred when the field name generated by TH matche…

…s any of Haskell keywords (#1476) * Fix `mkRecordName` * Improve performance for looking up keywords Co-authored-by: Matt Parsons <parsonsmatt@gmail.com> * Fix code style * Update ChangeLog * Bump to 2.14.4.5 --------- Co-authored-by: Matt Parsons <parsonsmatt@gmail.com>
yesodweb · Mar 3, 2023 · 23773f2 · 23773f2
1 parent 4c6679e
commit 23773f2
Show file tree

Hide file tree

Showing 4 changed files with 17 additions and 3 deletions.
diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md
@@ -1,10 +1,12 @@
 # Changelog for persistent
 
-## unreleased
+## 2.14.4.5
 
 * [#1460] https://github.com/yesodweb/persistent/pull/1468
     * Remove extraneous `map toPersistValue` call in the `mkInsertValues`
       function, as it evaluates to `id`.
+* [#1476](https://github.com/yesodweb/persistent/pull/1476)
+    * Fix `mkRecordName` to suffix `_` if the field name matches any of Haskell keywords.
 
 ## 2.14.4.4
 

diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
@@ -3100,7 +3100,7 @@ mkEntityLensName mps entDef fieldDef =
 
 mkRecordName :: MkPersistSettings -> Maybe Text -> EntityNameHS -> FieldNameHS -> Name
 mkRecordName mps prefix entNameHS fieldNameHS =
-    mkName $ T.unpack $ fromMaybe "" prefix <> lowerFirst recName
+    mkName $ T.unpack . avoidKeyword $ fromMaybe "" prefix <> lowerFirst recName
   where
     recName :: Text
     recName
@@ -3115,6 +3115,17 @@ mkRecordName mps prefix entNameHS fieldNameHS =
     fieldNameText =
         unFieldNameHS fieldNameHS
 
+    avoidKeyword :: Text -> Text
+    avoidKeyword name = if name `Set.member` haskellKeywords then name ++ "_" else name
+
+haskellKeywords :: Set.Set Text
+haskellKeywords = Set.fromList
+    ["case","class","data","default","deriving","do","else"
+    ,"if","import","in","infix","infixl","infixr","instance","let","module"
+    ,"newtype","of","then","type","where","_"
+    ,"foreign"
+    ]
+
 -- | Construct a list of TH Names for the typeclasses of an EntityDef's `entityDerives`
 mkEntityDefDeriveNames :: MkPersistSettings -> UnboundEntityDef -> [Name]
 mkEntityDefDeriveNames mps entDef =

diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal
@@ -1,5 +1,5 @@
 name:            persistent
-version:         2.14.4.4
+version:         2.14.4.5
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>

diff --git a/persistent/test/Database/Persist/TH/NoFieldSelectorsSpec.hs b/persistent/test/Database/Persist/TH/NoFieldSelectorsSpec.hs
@@ -25,6 +25,7 @@ User
     name Text
     Primary ident
     team TeamId
+    type Text
 
 Team
     name Text