Dont suggest const when NamedFieldPuns are used (#1521)

ndmitchell · Jun 12, 2023 · 1911d44 · 1911d44
1 parent 291caeb
commit 1911d44
Show file tree

Hide file tree

Showing 3 changed files with 4 additions and 1 deletion.
diff --git a/data/hlint.yaml b/data/hlint.yaml
@@ -1500,6 +1500,8 @@
 # yes = a & (mapped . b) %~ c -- a <&> b %~ c
 # test a = foo (\x -> True) -- const True
 # test a = foo (\_ -> True) -- const True
+# {-# LANGUAGE NamedFieldPuns #-}; data Foo = Foo {foo :: Int}; issue1430_ctor x = f (\foo-> Foo{foo})
+# {-# LANGUAGE NamedFieldPuns #-}; data Foo = Foo {foo :: Int}; issue1430_update x = f (\foo -> x{foo})
 # test a = foo (\x -> x) -- id
 # h a = flip f x (y z) -- f (y z) x
 # h a = flip f x $ y z

diff --git a/src/GHC/Util/FreeVars.hs b/src/GHC/Util/FreeVars.hs
@@ -174,6 +174,7 @@ instance FreeVars (LocatedA (HsFieldBind (LocatedAn NoEpAnns (FieldOcc GhcPs)) (
    freeVars o@(L _ (HsFieldBind _ _ x _)) = freeVars x
 
 instance FreeVars (LocatedA (HsFieldBind (LocatedAn NoEpAnns (AmbiguousFieldOcc GhcPs)) (LocatedA (HsExpr GhcPs)))) where
+  freeVars (L _ (HsFieldBind _ x _ True)) = Set.singleton $ rdrNameOcc $ rdrNameAmbiguousFieldOcc $ unLoc x -- a pun
   freeVars (L _ (HsFieldBind _ _ x _)) = freeVars x
 
 instance FreeVars (LocatedA (HsFieldBind (LocatedAn NoEpAnns (FieldLabelStrings GhcPs)) (LocatedA (HsExpr GhcPs)))) where

diff --git a/src/Hint/Match.hs b/src/Hint/Match.hs
@@ -201,7 +201,7 @@ checkSide x bind = maybe True bool x
       isType "Compare" x = True -- Just a hint for proof stuff
       isType "Atom" x = isAtom x
       isType "WHNF" x = isWHNF x
-      isType "Wildcard" x = any isFieldPun (universeBi x) || any hasFieldsDotDot (universeBi x)
+      isType "Wildcard" x = any hasFieldsDotDot (universeBi x)
       isType "Nat" (asInt -> Just x) | x >= 0 = True
       isType "Pos" (asInt -> Just x) | x >  0 = True
       isType "Neg" (asInt -> Just x) | x <  0 = True