Fix a name shadowing warning (#1406) (#1407)

* Fix a name shadowing warning * stylish * changelog
yesodweb · Jun 10, 2022 · 4ae431b · 4ae431b
1 parent 86498a3
commit 4ae431b
Show file tree

Hide file tree

Showing 6 changed files with 41 additions and 24 deletions.
diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md
@@ -1,5 +1,10 @@
 # Changelog for persistent
 
+## 2.14.0.2
+
+* [#1407](https://github.com/yesodweb/persistent/pull/1407)
+    * Fix a name shadowing warning.
+
 ## 2.14.0.1
 
 * [#1392](https://github.com/yesodweb/persistent/pull/1392)

diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs
@@ -119,8 +119,8 @@ import Language.Haskell.TH.Syntax
 import Web.HttpApiData (FromHttpApiData(..), ToHttpApiData(..))
 import Web.PathPieces (PathPiece(..))
 
-import Database.Persist.Class.PersistEntity
 import Database.Persist
+import Database.Persist.Class.PersistEntity
 import Database.Persist.Quasi
 import Database.Persist.Quasi.Internal
 import Database.Persist.Sql
@@ -1462,9 +1462,15 @@ fieldUpd :: Name -- ^ constructor name
     -> Exp -- ^ record value
     -> Name -- ^ field name to update
     -> Exp -- ^ new value
-    -> Exp
-fieldUpd con names record name new = CaseE record
-    [ Match (RecP con pats) (NormalB body) []]
+    -> Q Exp
+fieldUpd con names record name new = do
+    pats <-
+        fmap mconcat $ forM names $ \k -> do
+            varName <- VarP <$> newName (nameBase k)
+            pure [(k, varName) | k /= name]
+
+    pure $ CaseE record
+        [ Match (RecP con pats) (NormalB body) []]
     where
         body = RecConE con
             [ if k == name then (name, new) else (k, VarE k)
@@ -1486,23 +1492,26 @@ mkLensClauses mps entDef genDataType = do
     let idClause = normalClause
             [conp (keyIdName entDef) []]
             (lens' `AppE` getId `AppE` setId)
-    return $ idClause : if unboundEntitySum entDef
-        then fmap (toSumClause lens' keyVar valName xName) (getUnboundFieldDefs entDef)
-        else zipWith (toClause lens' getVal dot keyVar valName xName) (getUnboundFieldDefs entDef) fieldNames
+    (idClause :) <$> if unboundEntitySum entDef
+        then pure $ fmap (toSumClause lens' keyVar valName xName) (getUnboundFieldDefs entDef)
+        else zipWithM (toClause lens' getVal dot keyVar valName xName) (getUnboundFieldDefs entDef) fieldNames
   where
     fieldNames = fieldDefToRecordName mps entDef <$> getUnboundFieldDefs entDef
-    toClause lens' getVal dot keyVar valName xName fieldDef fieldName = normalClause
-        [conp (filterConName mps entDef fieldDef) []]
-        (lens' `AppE` getter `AppE` setter)
+    toClause lens' getVal dot keyVar valName xName fieldDef fieldName = do
+        setter <- mkSetter
+        pure $ normalClause
+            [conp (filterConName mps entDef fieldDef) []]
+            (lens' `AppE` getter `AppE` setter)
       where
         defName = mkEntityDefName entDef
         getter = InfixE (Just $ fieldSel defName fieldName) dot (Just getVal)
-        setter = LamE
-            [ conp 'Entity [VarP keyVar, VarP valName]
-            , VarP xName
-            ]
-            $ ConE 'Entity `AppE` VarE keyVar
-                `AppE` fieldUpd defName fieldNames (VarE valName) fieldName (VarE xName)
+        mkSetter = do
+            updExpr <- fieldUpd defName fieldNames (VarE valName) fieldName (VarE xName)
+            pure $ LamE
+                [ conp 'Entity [VarP keyVar, VarP valName]
+                , VarP xName
+                ]
+                $ ConE 'Entity `AppE` VarE keyVar `AppE` updExpr
 
     toSumClause lens' keyVar valName xName fieldDef = normalClause
         [conp (filterConName mps entDef fieldDef) []]
@@ -2167,6 +2176,7 @@ mkLenses mps entityMap ent = fmap mconcat $ forM (getUnboundFieldDefs ent `zip`
         t1 `arrow` t2 = ArrowT `AppT` t1 `AppT` t2
         vars = mkForallTV fT
              : (if mpsGeneric mps then [mkForallTV backend1{-, PlainTV backend2-}] else [])
+    fieldUpdClause <- fieldUpd (mkEntityDefName ent) fieldNames a fieldName y
     return
         [ SigD lensName $ ForallT vars [mkClassP ''Functor [VarT fT]] $
             (aT `arrow` (VarT fT `AppT` bT)) `arrow`
@@ -2179,7 +2189,7 @@ mkLenses mps entityMap ent = fmap mconcat $ forM (getUnboundFieldDefs ent `zip`
             [ FunD needleN [normalClause [] (fieldSel (mkEntityDefName ent) fieldName `AppE` a)]
             , FunD setterN $ return $ normalClause
                 [VarP yN]
-                (fieldUpd (mkEntityDefName ent) fieldNames a fieldName y)
+                fieldUpdClause
             ]
         ]
     where

diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal
@@ -1,5 +1,5 @@
 name:            persistent
-version:         2.14.0.1
+version:         2.14.0.2
 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
@@ -32,9 +32,9 @@ spec = it "compiles" True
 
 #else
 
-spec :: Spec 
+spec :: Spec
 spec = do
     it "only works with GHC 9.2 or greater" $ do
-        pendingWith "only works with GHC 9.2 or greater"    
+        pendingWith "only works with GHC 9.2 or greater"
 
-#endif
+#endif
diff --git a/persistent/test/Database/Persist/TH/OverloadedLabelSpec.hs b/persistent/test/Database/Persist/TH/OverloadedLabelSpec.hs
@@ -13,6 +13,8 @@
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE UndecidableInstances       #-}
 
+{-# OPTIONS_GHC -Wname-shadowing -Werror=name-shadowing #-}
+
 module Database.Persist.TH.OverloadedLabelSpec where
 
 import           TemplateTestImports

diff --git a/stack.yaml b/stack.yaml
@@ -1,4 +1,4 @@
-resolver: nightly-2022-01-14
+resolver: nightly-2022-06-10
 
 packages:
   - ./persistent
@@ -14,7 +14,7 @@ extra-deps:
   - lift-type-0.1.0.0
   - mysql-0.2.1
   - mysql-simple-0.4.7
-  - aeson-2.0.2.0
+    # - aeson-2.0.2.0
   # https://github.com/yesodweb/shakespeare/pull/260
   # https://github.com/commercialhaskell/stackage/issues/6294
-  - happy-1.20.0
+  # - happy-1.20.0