Add "Redundant $ with block argument" hint

hints.md

@@ -74,6 +74,48 @@ foo . bar x <$> baz q
 <td>Suggestion</td>
 </tr>
 <tr>
+<td>Redundant $ with block argument</td>
+<td>
+Example: 
+<pre>
+{-# LANGUAGE BlockArguments #-} 
+a = f $ \case _ -> x
+</pre>
+Found:
+<code>
+f $ \case _ -> x
+</code>
+<br>
+Suggestion:
+<code>
+f \case _ -> x
+</code>
+<br>
+</td>
+<td>Suggestion</td>
+</tr>
+<tr>
+<td>Redundant $ with block argument</td>
+<td>
+Example: 
+<code>
+a = f $ \case _ -> x
+</code>
+<br>
+Found:
+<code>
+f $ \case _ -> x
+</code>
+<br>
+Suggestion:
+<code>
+f \case _ -> x
+</code>
+<br>
+</td>
+<td>Ignore</td>
+</tr>
+<tr>
 <td>Redundant $</td>
 <td>
 Example: 

src/GHC/All.hs

@@ -8,6 +8,7 @@ module GHC.All(
     ParseError(..), ModuleEx(..),
     parseModuleEx, createModuleEx, createModuleExWithFixities, ghcComments, modComments, firstDeclComments,
     parseExpGhcWithMode, parseImportDeclGhcWithMode, parseDeclGhcWithMode,
+    ghcExtensionsEnabledInModule,
     ) where
 
 import GHC.Driver.Ppr
@@ -18,6 +19,8 @@ import Data.Char
 import Data.List
 import Data.List.NonEmpty qualified as NE
 import Data.List.Extra
+import Data.Set (Set)
+import Data.Set qualified as Set
 import Timing
 import Language.Preprocessor.Cpphs
 import System.IO.Extra
@@ -108,6 +111,15 @@ firstDeclComments m =
         [] -> EpaCommentsBalanced [] []
         L ann _ : _ -> comments ann
 
+-- | The extensions enabled in pragmas at the top of a module.
+ghcExtensionsEnabledInModule :: ModuleEx -> Set Extension
+ghcExtensionsEnabledInModule modu =
+  -- Comments appearing without an empty line before the first
+  -- declaration in a module are now associated with the declaration
+  -- not the module so to be safe, look also at `firstDeclComments
+  -- modu` (https://gitlab.haskell.org/ghc/ghc/-/merge_requests/9517).
+  extensions (modComments modu) `Set.union` extensions (firstDeclComments modu)
+
 -- | The error handler invoked when GHC parsing has failed.
 ghcFailOpParseModuleEx :: String
                        -> FilePath

src/Hint/Bracket.hs

@@ -93,7 +93,7 @@ main = 1; {-# ANN module ("HLint: ignore Use camelCase" :: String) #-}
 main = 1; {-# ANN module (1 + (2)) #-} -- 2
 
 -- special case from esqueleto, see #224
-main = operate <$> (select $ from $ \user -> return $ user ^. UserEmail)
+main = operate <$> (select $ from $ \user -> return $ user ^. UserEmail) -- @Ignore ???
 -- unknown fixity, see #426
 bad x = x . (x +? x . x)
 -- special case people don't like to warn on
@@ -111,7 +111,7 @@ function (Ctor (Rec { field })) = Ctor (Rec {field = 1})
 no = f @($x)
 
 -- template haskell is harder
-issue1292 = [e| handleForeignCatch $ \ $(varP pylonExPtrVarName) -> $(quoteExp C.block modifiedStr) |]
+issue1292 = [e| handleForeignCatch $ \ $(varP pylonExPtrVarName) -> $(quoteExp C.block modifiedStr) |] -- @Ignore ???
 
 -- no warnings for single-argument constraint contexts
 foo :: (A) => ()
@@ -122,34 +122,52 @@ data Dict c where Dict :: (c) => Dict c
 data Dict' c a where Dict' :: (c a) => Dict' c a
 
 -- issue1501: Redundant bracket hint resulted in a parse error
-x = f $ \(Proxy @a) -> True
+x = f $ \(Proxy @a) -> True -- @Ignore ???
+
+-- dollar reduction tests with block arguments
+-- (keep these after any other tests that ignore this suggestion, so that
+-- hints.md is less confusing)
+{-# LANGUAGE BlockArguments #-} \
+a = f $ do x -- f do x
+a = f $ do x -- @Ignore f do x
+{-# LANGUAGE BlockArguments #-} \
+a = f $ \case _ -> x -- f \case _ -> x
+a = f $ \case _ -> x -- @Ignore f \case _ -> x
 </TEST>
 -}
 
 
 module Hint.Bracket(bracketHint) where
 
-import Hint.Type(DeclHint,Idea(..),rawIdea,warn,suggest,Severity(..),toRefactSrcSpan,toSSA)
+import Hint.Type(DeclHint,Idea(..),ghcExtensionsEnabledInModule,idea,rawIdea,warn,suggest,Severity(..),toRefactSrcSpan,toSSA)
 import Data.Data
 import Data.List.Extra
+import Data.Set (member)
 import Data.Generics.Uniplate.DataOnly
 import Refact.Types
 
 import GHC.Hs
-import GHC.Utils.Outputable
+import GHC.LanguageExtensions.Type (Extension(..))
+import GHC.Utils.Outputable hiding ((<>))
 import GHC.Types.SrcLoc
 import GHC.Util
 import Language.Haskell.GhclibParserEx.GHC.Hs.Expr
 import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
 import Language.Haskell.GhclibParserEx.GHC.Hs.Pat
 
 bracketHint :: DeclHint
-bracketHint _ _ x =
-  concatMap (\x -> bracket prettyExpr isPartialAtom True x ++ dollar x) (childrenBi (descendBi splices $ descendBi annotations x) :: [LHsExpr GhcPs]) ++
+bracketHint _ modu x =
+  concatMap (\x -> bracket prettyExpr isPartialAtom True x ++ dollar blockArgSev x) (childrenBi (descendBi splices $ descendBi annotations x) :: [LHsExpr GhcPs]) ++
   concatMap (bracket unsafePrettyPrint (\_ _ -> False) False) (childrenBi (preprocess x) :: [LHsType GhcPs]) ++
   concatMap (bracket unsafePrettyPrint (\_ _ -> False) False) (childrenBi x :: [LPat GhcPs]) ++
   concatMap fieldDecl (childrenBi x)
    where
+     exts = ghcExtensionsEnabledInModule modu
+     -- Ignore "Redundant $ with block argument" by default, unless we can see
+     -- that BlockArguments are enabled in this file.
+     blockArgSev
+       | BlockArguments `member` exts = Suggestion
+       | otherwise = Ignore
      preprocess = transformBi removeSingleAtomConstrCtxs
        where
          removeSingleAtomConstrCtxs :: LHsContext GhcPs -> LHsContext GhcPs
@@ -267,15 +285,21 @@ fieldDecl _ = []
 
 -- This function relies heavily on fixities having been applied to the
 -- raw parse tree.
-dollar :: LHsExpr GhcPs -> [Idea]
-dollar = concatMap f . universe
+-- `blockArgSev` is the default severity to use for dollars with a block
+-- argument (a lambda, `do`, etc.).
+dollar :: Severity -> LHsExpr GhcPs -> [Idea]
+dollar blockArgSev = concatMap f . universe
   where
-    f x = [ (suggest "Redundant $" (reLoc x) (reLoc y) [r]){ideaSpan = locA (getLoc d)} | L _ (OpApp _ a d b) <- [x], isDol d
+    f x = [ (idea sev ("Redundant $" <> suffix) (reLoc x) (reLoc y) [r]){ideaSpan = locA (getLoc d)} | L _ (OpApp _ a d b) <- [x], isDol d
             , let y = noLocA (HsApp noExtField a b) :: LHsExpr GhcPs
             , not $ needBracket 0 y a
-            , not $ needBracket 1 y b
             , not $ isPartialAtom (Just x) b
-            , let r = Replace Expr (toSSA x) [("a", toSSA a), ("b", toSSA b)] "a b"]
+            , let r = Replace Expr (toSSA x) [("a", toSSA a), ("b", toSSA b)] "a b"
+            , (sev, suffix) <-
+                if needBracket 1 y b
+                then [(blockArgSev, " with block argument") | isBlock (unLoc b)]
+                else [(Suggestion, "")]
+            ]
           ++
           [ suggest "Move brackets to avoid $" (reLoc x) (reLoc (t y)) [r]
             |(t, e@(L _ (HsPar _ (L _ (OpApp _ a1 op1 a2))))) <- splitInfix x
@@ -295,6 +319,14 @@ dollar = concatMap f . universe
           -- , error $ show (unsafePrettyPrint a, gshow b, unsafePrettyPrint c)
           , let y = noLocA $ OpApp noExtField a b c :: LHsExpr GhcPs
           , let r = Replace Expr (toSSA x) [("x", toSSA a), ("op", toSSA b), ("y", toSSA c)] "x op y"]
+    isBlock = \case
+      HsDo {} -> True
+      HsCase {} -> True
+      HsLam {} -> True
+      HsLet {} -> True
+      HsIf {} -> True
+      HsProc {} -> True
+      _ -> False
 
 splitInfix :: LHsExpr GhcPs -> [(LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)]
 splitInfix (L l (OpApp _ lhs op rhs)) =

src/Hint/Extensions.hs

@@ -262,7 +262,7 @@ data T = MkT -- @NoRefactor: refactor requires GHC >= 9.6.1
 
 module Hint.Extensions(extensionsHint) where
 
-import Hint.Type(ModuHint,rawIdea,Severity(Warning),Note(..),toSSAnc,ghcModule,modComments,firstDeclComments)
+import Hint.Type(ModuHint,rawIdea,Severity(Warning),Note(..),toSSAnc,ghcExtensionsEnabledInModule,ghcModule,modComments,firstDeclComments)
 import Extension
 
 import Data.Generics.Uniplate.DataOnly
@@ -334,16 +334,7 @@ extensionsHint _ x =
 
     -- All the extensions defined to be used.
     extensions :: Set.Set Extension
-    extensions = Set.fromList $
-      concatMap
-      (mapMaybe readExtension . snd)
-      (languagePragmas
-        (pragmas (modComments x) ++ pragmas (firstDeclComments x)))
-      -- Comments appearing without an empty line before the first
-      -- declaration in a module are now associated with the
-      -- declaration not the module so to be safe, look also at
-      -- `firstDeclComments x`
-      -- (https://gitlab.haskell.org/ghc/ghc/-/merge_requests/9517).
+    extensions = ghcExtensionsEnabledInModule x
 
     -- Those extensions we detect to be useful.
     useful :: Set.Set Extension

src/Hint/List.hs

@@ -47,14 +47,16 @@ import Data.Generics.Uniplate.DataOnly
 import Data.List.NonEmpty qualified as NE
 import Data.List.Extra
 import Data.Maybe
+import Data.Set (member)
 import Prelude
 
-import Hint.Type(DeclHint,Idea,suggest,ignore,substVars,toRefactSrcSpan,toSSA,modComments,firstDeclComments)
+import Hint.Type(DeclHint,Idea,suggest,ignore,substVars,toRefactSrcSpan,toSSA,ghcExtensionsEnabledInModule)
 
 import Refact.Types hiding (SrcSpan)
 import Refact.Types qualified as R
 
 import GHC.Hs
+import GHC.LanguageExtensions.Type (Extension(..))
 import GHC.Types.SrcLoc
 import GHC.Types.SourceText
 import GHC.Types.Name.Reader
@@ -73,12 +75,8 @@ import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
 listHint :: DeclHint
 listHint _ modu = listDecl overloadedListsOn
   where
-    -- Comments appearing without a line-break before the first
-    -- declaration in a module are now associated with the declaration
-    -- not the module so to be safe, look also at `firstDeclComments
-    -- modu` (https://gitlab.haskell.org/ghc/ghc/-/merge_requests/9517).
-    exts = concatMap snd (languagePragmas (pragmas (modComments modu) ++ pragmas (firstDeclComments modu)))
-    overloadedListsOn = "OverloadedLists" `elem` exts
+    exts = ghcExtensionsEnabledInModule modu
+    overloadedListsOn = OverloadedLists `member` exts
 
 listDecl :: Bool -> LHsDecl GhcPs -> [Idea]
 listDecl overloadedListsOn x =

src/Hint/NumLiteral.hs

@@ -26,24 +26,18 @@ import GHC.Data.FastString
 import GHC.LanguageExtensions.Type (Extension (..))
 import GHC.Types.SrcLoc
 import GHC.Types.SourceText
-import GHC.Util.ApiAnnotation (extensions)
 import Data.Char (isDigit, isOctDigit, isHexDigit)
 import Data.List (intercalate)
-import Data.Set (union)
+import Data.Set (member)
 import Data.Generics.Uniplate.DataOnly (universeBi)
 import Refact.Types
 
-import Hint.Type (DeclHint, toSSA, modComments, firstDeclComments)
+import Hint.Type (DeclHint, toSSA, ghcExtensionsEnabledInModule)
 import Idea (Idea, suggest)
 
 numLiteralHint :: DeclHint
 numLiteralHint _ modu =
-  -- Comments appearing without an empty line before the first
-  -- declaration in a module are now associated with the declaration
-  -- not the module so to be safe, look also at `firstDeclComments
-  -- modu` (https://gitlab.haskell.org/ghc/ghc/-/merge_requests/9517).
-  let exts = union (extensions (modComments modu)) (extensions (firstDeclComments modu)) in
-  if NumericUnderscores `elem` exts then
+  if NumericUnderscores `member` ghcExtensionsEnabledInModule modu then
      concatMap suggestUnderscore . universeBi
   else
      const []

src/Hint/Pattern.hs

@@ -59,24 +59,25 @@ otherwise = True
 
 module Hint.Pattern(patternHint) where
 
-import Hint.Type(DeclHint,Idea,modComments,firstDeclComments,ideaTo,toSSA,toRefactSrcSpan,suggest,suggestRemove,warn)
+import Hint.Type(DeclHint,Idea,ghcExtensionsEnabledInModule,ideaTo,toSSA,toRefactSrcSpan,suggest,suggestRemove,warn)
 import Data.Generics.Uniplate.DataOnly
 import Data.Function
 import Data.List.Extra
+import Data.Set (member)
 import Data.Tuple
 import Data.Maybe
 import Data.Either
 import Refact.Types hiding (RType(Pattern, Match), SrcSpan)
 import Refact.Types qualified as R (RType(Pattern, Match), SrcSpan)
 
 import GHC.Hs hiding(asPattern)
+import GHC.LanguageExtensions.Type (Extension(..))
 import GHC.Types.SrcLoc
 import GHC.Types.Name.Reader
 import GHC.Types.Name.Occurrence
 import GHC.Types.Basic hiding (Pattern)
 import GHC.Data.Strict qualified
 
-import GHC.Util
 import Language.Haskell.GhclibParserEx.GHC.Hs.Pat
 import Language.Haskell.GhclibParserEx.GHC.Hs.Expr
 import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
@@ -91,13 +92,7 @@ patternHint _scope modu x =
     concatMap (patHint strict True) (universeBi $ transformBi noPatBind x) ++
     concatMap expHint (universeBi x)
   where
-    -- Comments appearing without an empty line before the first
-    -- declaration in a module are now associated with the declaration
-    -- not the module so to be safe, look also at `firstDeclComments
-    -- modu`
-    -- (https://gitlab.haskell.org/ghc/ghc/-/merge_requests/9517).
-    exts = nubOrd $ concatMap snd (languagePragmas (pragmas (modComments modu) ++ pragmas (firstDeclComments modu))) -- language extensions enabled at source
-    strict = "Strict" `elem` exts
+    strict = Strict `member` ghcExtensionsEnabledInModule modu
 
     noPatBind :: LHsBind GhcPs -> LHsBind GhcPs
     noPatBind (L loc a@PatBind{}) = L loc a{pat_lhs=noLocA (WildPat noExtField)}