Merge branch 'master' into ghc-9.8.1

.gitignore

@@ -14,5 +14,5 @@ stack*.yaml.lock
 /TAGS
 \#*\#
 .\#*\#
-
+/.sl/
 *.dump-hi

CHANGES.txt

@@ -1,5 +1,6 @@
 Changelog for HLint (* = breaking change)
 
+    #1540, correct Functor law hint, was missing brackets
 3.6.1, released 2023-07-03
     Attempt to make a binary release
 3.6, released 2023-06-26

LICENSE

@@ -1,4 +1,4 @@
-Copyright Neil Mitchell 2006-2023.
+Copyright Neil Mitchell 2006-2024.
 All rights reserved.
 
 Redistribution and use in source and binary forms, with or without

data/hlint.yaml

@@ -472,11 +472,12 @@
     # FUNCTOR
 
     - warn: {lhs: fmap f (fmap g x), rhs: fmap (f . g) x, name: Functor law}
-    - warn: {lhs: f <$> g <$> x, rhs: f . g <$> x, name: Functor law}
+    - warn: {lhs: f <$> (g <$> x), rhs: f . g <$> x, name: Functor law}
     - warn: {lhs: x <&> g <&> f, rhs: x <&> f . g, name: Functor law}
     - warn: {lhs: fmap id, rhs: id, name: Functor law}
     - warn: {lhs: id <$> x, rhs: x, name: Functor law}
     - warn: {lhs: x <&> id, rhs: x, name: Functor law}
+    - warn: {lhs: f <$> g <$> x, rhs: f . g <$> x}
     - hint: {lhs: fmap f $ x, rhs: f <$> x, side: isApp x || isAtom x}
     - hint: {lhs: \x -> a <$> b x, rhs: fmap a . b}
     - hint: {lhs: \x -> b x <&> a, rhs: fmap a . b}

hints.md

@@ -972,33 +972,6 @@ do f . g <$> bar
 <td>Warning</td>
 </tr>
 <tr>
-<td>Unnecessarily monadic</td>
-<td>
-Example: 
-<pre>
-foo x = do 
-   let z = y - 2 
-   return $ z * 3 
-   where y = x + 1
-</pre>
-Found:
-<pre>
-foo x
-  = do let z = y - 2
-       return $ z * 3
-  where
-      y = x + 1
-</pre>
-Suggestion:
-<code>
-Demote `foo` to a pure function
-</code>
-<br>
-Does not support refactoring.
-</td>
-<td>Suggestion</td>
-</tr>
-<tr>
 <td>Redundant void</td>
 <td>
 Example: 
@@ -7226,7 +7199,7 @@ fmap (f . g) x
 <td>
 LHS:
 <code>
-f <$> g <$> x
+f <$> (g <$> x)
 </code>
 <br>
 RHS:
@@ -7302,6 +7275,22 @@ x
 <td>Warning</td>
 </tr>
 <tr>
+<td>Redundant <$></td>
+<td>
+LHS:
+<code>
+f <$> g <$> x
+</code>
+<br>
+RHS:
+<code>
+f . g <$> x
+</code>
+<br>
+</td>
+<td>Warning</td>
+</tr>
+<tr>
 <td>Use <$></td>
 <td>
 LHS:

hlint.cabal

@@ -7,7 +7,7 @@ license-file:       LICENSE
 category:           Development
 author:             Neil Mitchell <[email protected]>
 maintainer:         Neil Mitchell <[email protected]>
-copyright:          Neil Mitchell 2006-2023
+copyright:          Neil Mitchell 2006-2024
 synopsis:           Source code suggestions
 description:
     HLint gives suggestions on how to improve your source code.

src/CmdLine.hs

@@ -183,7 +183,7 @@ mode = cmdArgsMode $ modes
                    ,"To check all Haskell files in 'src' and generate a report type:"
                    ,"  hlint src --report"]
     ] &= program "hlint" &= verbosity
-    &=  summary ("HLint v" ++ showVersion version ++ ", (C) Neil Mitchell 2006-2023")
+    &=  summary ("HLint v" ++ showVersion version ++ ", (C) Neil Mitchell 2006-2024")
     where
         nam xs = nam_ xs &= name [NE.head $ NE.fromList xs]
         nam_ xs = def &= explicit &= name xs

src/GHC/All.hs

@@ -110,13 +110,13 @@ ghcFailOpParseModuleEx :: String
                        -> FilePath
                        -> String
                        -> (SrcSpan, SDoc)
-                       -> Either ParseError ModuleEx
+                       -> IO (Either ParseError ModuleEx)
 ghcFailOpParseModuleEx ppstr file str (loc, err) = do
    let pe = case loc of
             RealSrcSpan r _ -> context (srcSpanStartLine r) ppstr
             _ -> ""
        msg = GHC.Driver.Ppr.showSDoc baseDynFlags err
-   Left $ ParseError loc msg pe
+   pure $ Left $ ParseError loc msg pe
 
 -- GHC extensions to enable/disable given HSE parse flags.
 ghcExtensionsFromParseFlags :: ParseFlags -> ([Extension], [Extension])
@@ -194,12 +194,12 @@ parseModuleEx flags file str = timedIO "Parse" file $ runExceptT $ do
     POk s a -> do
       let errs = bagToList . getMessages $ GhcPsMessage <$> snd (getPsMessages s)
       if not $ null errs then
-        except $ parseFailureErr dynFlags str file str $ NE.fromList errs
+        ExceptT $ parseFailureErr dynFlags str file str $ NE.fromList errs
       else do
         let fixes = fixitiesFromModule a ++ ghcFixitiesFromParseFlags flags
         pure $ ModuleEx (applyFixities fixes a)
     PFailed s ->
-      except $ parseFailureErr dynFlags str file str $ NE.fromList . bagToList . getMessages  $ GhcPsMessage <$> snd (getPsMessages s)
+      ExceptT $ parseFailureErr dynFlags str file str $ NE.fromList . bagToList . getMessages  $ GhcPsMessage <$> snd (getPsMessages s)
   where
     -- If parsing pragmas fails, synthesize a parse error from the
     -- error message.

src/Hint/Monad.hs

@@ -63,39 +63,6 @@ issue978 = do \
    print "x" \
    if False then main else do \
    return ()
-
-foo x = return 7 -- Demote `foo` to a pure function
-foo x = pure 7 -- Demote `foo` to a pure function
-foo x y = pure $ x + y -- Demote `foo` to a pure function
-foo x = negate 7
-
-foo x = do \
-   let y = x + 7 \
-       z = y + 2 \
-   let w = z - 4 \
-   return w -- Demote `foo` to a pure function
-
-foo x = do \
-   let z = y - 2 \
-   return $ z * 3 \
-   where y = x + 1 -- Demote `foo` to a pure function
-
-foo x = do \
-  let y = pure x \
-  y
-
-{-# LANGUAGE BlockArguments #-} \
-x = \
-  (+) \
-    do 3 + 5 \
-    do 4 * 7
-
-y = do \
-  let z = 5 \
-  z
-
-f bla do \
-  g x y z
 </TEST>
 -}
 
@@ -112,7 +79,6 @@ import GHC.Types.Name.Reader
 import GHC.Types.Name.Occurrence
 import GHC.Data.Bag
 import GHC.Data.Strict qualified
-import Control.Monad ( guard )
 
 import Language.Haskell.GhclibParserEx.GHC.Hs.Pat
 import Language.Haskell.GhclibParserEx.GHC.Hs.Expr
@@ -134,56 +100,16 @@ unitFuncs :: [String]
 unitFuncs = ["when","unless","void"]
 
 monadHint :: DeclHint
-monadHint _ _ d =
-  baseHints <> gratuitousHints
+monadHint _ _ d = concatMap (f Nothing Nothing) $ childrenBi d
     where
-        baseHints = concatMap (f Nothing Nothing) $ childrenBi d
-        gratuitousHints = concatMap gratuitouslyMonadic $ universeBi d
         decl = declName d
         f parentDo parentExpr x =
             monadExp decl parentDo parentExpr x ++
-            concat [f (if isDo x then Just x else parentDo) (Just (i, x)) c | (i, c) <- zipFrom 0 $ children x]
-
-gratuitouslyMonadic :: LHsDecl GhcPs -> [Idea]
-gratuitouslyMonadic e@(L _ d) = case d of
-  ValD _ func@(FunBind _ (L _ n) (MG _ (L _ ms))) -> do
-    guard $ fname /= "main"  -- Account for "main = pure ()" test
-    guard $ all gratuitouslyMonadicExpr $ allMatchExprs ms
-    pure $ rawIdea
-      Suggestion
-      "Unnecessarily monadic"
-      (locA $ getLoc e)
-      (unsafePrettyPrint e)
-      (Just $ unwords ["Demote", "`" <> fname <> "`", "to a pure function"])
-      []
-      []
-    where
-      fname = occNameString $ rdrNameOcc n
-      -- Iterate over all of the patterns of the function, as well as all of the guards
-      allMatchExprs :: [LMatch GhcPs (LHsExpr GhcPs)] -> [LHsExpr GhcPs]
-      allMatchExprs ms = [expr | L _ (Match _ _ _ (GRHSs _ xs _)) <- ms, L _ (GRHS _ _ expr) <- xs]
-  _ -> []
-
--- | Handles expressions of both these forms:
---     pure x
---     pure $ f x
---
--- Also recurses into `do` blocks to check whether it consists entirely
--- (excluding any Let bindings) of "Body Statements" with
--- such expressions. This catches at least some real-world
--- sightings of the phenomenon.
-gratuitouslyMonadicExpr :: LHsExpr GhcPs -> Bool
-gratuitouslyMonadicExpr x =
-  case simplifyExp x of
-    L _ (HsApp _ (L _ (HsVar _ (L _ myFunc))) _) ->
-      occNameString (rdrNameOcc myFunc) `elem` ["pure", "return"]
-    L _ (HsDo _ _ (L _ statements)) -> all isGratuitouslyMonadicBodyStatement $
-      filter (not . isLetStmt . unLoc) statements
-    _ -> False
-  where
-    isGratuitouslyMonadicBodyStatement statement = case statement of
-      L _ (BodyStmt _ x _ _) -> gratuitouslyMonadicExpr x
-      _ -> False
+            concat [f (if isHsDo x then Just x else parentDo) (Just (i, x)) c | (i, c) <- zipFrom 0 $ children x]
+
+        isHsDo (L _ HsDo{}) = True
+        isHsDo _ = False
+
 
 -- | Call with the name of the declaration,
 --   the nearest enclosing `do` expression

src/Paths.hs

@@ -6,6 +6,5 @@ import Data.Version.Extra
 version :: Version
 version = makeVersion [0,0]
 
-{-# ANN module "HLint: ignore Unnecessarily monadic" #-}
 getDataDir :: IO FilePath
 getDataDir = pure "data"