diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,5 +1,11 @@ Changelog for HLint (* = breaking change) +3.2.3, released 2020-11-23 + #1160, never consult the .hscolour file for color preferences + #1171, do not refactor redundant lambda with case + #1169, default to -A32 (doubles speed for 4 CPU) + #1169, make -j actually use parallelism + #1167, enable refactoring for "Use lambda" 3.2.2, released 2020-11-15 #1166, detect more unboxed data to avoid suggesting newtype #1153, fix incorrect redundant bracket with @($foo) diff --git a/hlint.cabal b/hlint.cabal --- a/hlint.cabal +++ b/hlint.cabal @@ -1,7 +1,7 @@ cabal-version: >= 1.18 build-type: Simple name: hlint -version: 3.2.2 +version: 3.2.3 license: BSD3 license-file: LICENSE category: Development @@ -165,6 +165,8 @@ build-depends: base, hlint main-is: src/Main.hs - ghc-options: -rtsopts + -- See https://github.com/ndmitchell/hlint/pull/1169 for benchmarks + -- that indicate -A32 is a good idea + ghc-options: -rtsopts -with-rtsopts=-A32m if flag(threaded) ghc-options: -threaded diff --git a/src/HLint.hs b/src/HLint.hs --- a/src/HLint.hs +++ b/src/HLint.hs @@ -134,6 +134,8 @@ cmd@CmdMain{..} <- if null args2 then pure cmd else getCmd $ args2 ++ args1 -- command line arguments are passed last settings2 <- concatMapM (fmap snd . computeSettings (cmdParseFlags cmd)) cmdFindHints let settings3 = [SettingClassify $ Classify Ignore x "" "" | x <- cmdIgnore] + cmdThreads <- if cmdThreads == 0 then getNumProcessors else pure cmdThreads + cmd <- pure CmdMain {..} pure (cmd, settings1 ++ settings2 ++ settings3) where enableGroup groupName = @@ -144,9 +146,8 @@ ] runHints :: [String] -> [Setting] -> Cmd -> IO [Idea] -runHints args settings cmd@CmdMain{..} = do - j <- if cmdThreads == 0 then getNumProcessors else pure cmdThreads - withNumCapabilities j $ do +runHints args settings cmd@CmdMain{..} = + withNumCapabilities cmdThreads $ do let outStrLn = whenNormal . putStrLn ideas <- getIdeas cmd settings ideas <- pure $ if cmdShowAll then ideas else filter (\i -> ideaSeverity i /= Ignore) ideas @@ -161,7 +162,7 @@ handleRefactoring ideas cmdFiles cmd else do usecolour <- cmdUseColour cmd - showItem <- if usecolour then showANSI else pure show + let showItem = if usecolour then showIdeaANSI else show mapM_ (outStrLn . showItem) ideas handleReporting ideas cmd pure ideas diff --git a/src/Hint/Lambda.hs b/src/Hint/Lambda.hs --- a/src/Hint/Lambda.hs +++ b/src/Hint/Lambda.hs @@ -80,10 +80,11 @@ baz = bar (\x -> (x +)) -- (+) xs `withArgsFrom` args = f args foo = bar (\x -> case x of Y z -> z) -- \(Y z) -> z -foo = bar (\x -> case x of Y z | z > 0 -> z) -- \case Y z | z > 0 -> z +foo = bar (\x -> case x of [y, z] -> z) -- \[y, z] -> z yes = blah (\ x -> case x of A -> a; B -> b) -- \ case A -> a; B -> b yes = blah (\ x -> case x of A -> a; B -> b) -- @Note may require `{-# LANGUAGE LambdaCase #-}` adding to the top of the file no = blah (\ x -> case x of A -> a x; B -> b x) +foo = bar (\x -> case x of Y z | z > 0 -> z) -- \case Y z | z > 0 -> z yes = blah (\ x -> (y, x)) -- (y,) yes = blah (\ x -> (y, x, z+q)) -- (y, , z+q) yes = blah (\ x -> (y, x, y, u, v)) -- (y, , y, u, v) @@ -103,7 +104,7 @@ module Hint.Lambda(lambdaHint) where -import Hint.Type (DeclHint, Idea, Note(RequiresExtension), suggest, warn, toSS, suggestN, ideaNote, substVars) +import Hint.Type (DeclHint, Idea, Note(RequiresExtension), suggest, warn, toSS, suggestN, ideaNote, substVars, toRefactSrcSpan) import Util import Data.List.Extra import Data.Set (Set) @@ -142,7 +143,11 @@ (sub, tpl) = mkSubtsAndTpl newPats newBody gen :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs gen ps = uncurry reform . fromLambda . lambda ps - in [warn "Redundant lambda" o (gen pats origBody) [Replace Decl (toSS o) sub tpl]] + refacts = case newBody of + -- https://github.com/alanz/ghc-exactprint/issues/97 + L _ HsCase{} -> [] + _ -> [Replace Decl (toSS o) sub tpl] + in [warn "Redundant lambda" o (gen pats origBody) refacts] | let (newPats, newBody) = etaReduce pats origBody , length newPats < length pats, pvars (drop (length newPats) pats) `disjoint` varss bind @@ -252,14 +257,30 @@ -- * mark match as being in a lambda context so that it's printed properly oldMG@(MG _ (L _ [L _ oldmatch]) _) | all (\(L _ (GRHS _ stmts _)) -> null stmts) (grhssGRHSs (m_grhss oldmatch)) -> - [suggestN "Use lambda" o $ noLoc $ HsLam noExtField oldMG - { mg_alts = noLoc - [noLoc oldmatch - { m_pats = map mkParPat $ m_pats oldmatch - , m_ctxt = LambdaExpr + let patLocs = fmap getLoc (m_pats oldmatch) + bodyLocs = concatMap (\case L _ (GRHS _ _ body) -> [getLoc body]; _ -> []) + $ grhssGRHSs (m_grhss oldmatch) + r | notNull patLocs && notNull bodyLocs = + let xloc = foldl1' combineSrcSpans patLocs + yloc = foldl1' combineSrcSpans bodyLocs + in [ Replace Expr (toSS o) [("x", toRefactSrcSpan xloc), ("y", toRefactSrcSpan yloc)] + ((if needParens then "\\(x)" else "\\x") ++ " -> y") + ] + | otherwise = [] + needParens = any (patNeedsParens appPrec . unLoc) (m_pats oldmatch) + in [ suggest "Use lambda" o + ( noLoc $ HsLam noExtField oldMG + { mg_alts = noLoc + [ noLoc oldmatch + { m_pats = map mkParPat $ m_pats oldmatch + , m_ctxt = LambdaExpr + } + ] } - ] } - ] + :: LHsExpr GhcPs + ) + r + ] -- otherwise we should use @LambdaCase@ MG _ (L _ _) _ -> diff --git a/src/Hint/Restrict.hs b/src/Hint/Restrict.hs --- a/src/Hint/Restrict.hs +++ b/src/Hint/Restrict.hs @@ -178,16 +178,20 @@ , let dname = fromMaybe "" (declName d) , x <- universeBi d :: [Located RdrName] , let xMods = possModules scope x - , let (withins, message) = fromMaybe ([("","") | def], Nothing) (findFunction x xMods) + , let (withins, message) = fromMaybe ([("","") | def], Nothing) (findFunction mp x xMods) , not $ within modu dname withins ] - where - -- Returns Just iff there are rules for x, which are either unqualified, or qualified with a module that is - -- one of x's possible modules. - -- If there are multiple matching rules (e.g., there's both an unqualified version and a qualified version), their - -- withins and messages are concatenated with (<>). - findFunction :: Located RdrName -> [ModuleName] -> Maybe ([(String, String)], Maybe String) - findFunction (rdrNameStr -> x) (map moduleNameString -> possMods) - | Just (RestrictFun mp) <- Map.lookup x mp = - fmap sconcat . NonEmpty.nonEmpty . Map.elems $ Map.filterWithKey (const . maybe True (`elem` possMods)) mp - | otherwise = Nothing + +-- Returns Just iff there are rules for x, which are either unqualified, or qualified with a module that is +-- one of x's possible modules. +-- If there are multiple matching rules (e.g., there's both an unqualified version and a qualified version), their +-- withins and messages are concatenated with (<>). +findFunction + :: Map.Map String RestrictFunction + -> Located RdrName + -> [ModuleName] + -> Maybe ([(String, String)], Maybe String) +findFunction restrictMap (rdrNameStr -> x) (map moduleNameString -> possMods) = do + (RestrictFun mp) <- Map.lookup x restrictMap + n <- NonEmpty.nonEmpty . Map.elems $ Map.filterWithKey (const . maybe True (`elem` possMods)) mp + pure (sconcat n) diff --git a/src/HsColour.hs b/src/HsColour.hs --- a/src/HsColour.hs +++ b/src/HsColour.hs @@ -1,32 +1,24 @@ {-# LANGUAGE CPP #-} -module HsColour(hsColourHTML, hsColourConsole, hsColourConsolePure) where +module HsColour(hsColourHTML, hsColourConsole) where #ifdef GPL_SCARES_ME -hsColourConsole :: IO (String -> String) -hsColourConsole = pure id - -hsColourConsolePure :: String -> String -hsColourConsolePure = id +hsColourConsole :: String -> String +hsColourConsole = id hsColourHTML :: String -> String hsColourHTML = id #else -import Data.Functor import Prelude import Language.Haskell.HsColour.TTY as TTY import Language.Haskell.HsColour.Colourise import Language.Haskell.HsColour.CSS as CSS - -hsColourConsole :: IO (String -> String) -hsColourConsole = TTY.hscolour <$> readColourPrefs - -hsColourConsolePure :: String -> String -hsColourConsolePure = TTY.hscolour defaultColourPrefs +hsColourConsole :: String -> String +hsColourConsole = TTY.hscolour defaultColourPrefs hsColourHTML :: String -> String hsColourHTML = CSS.hscolour False 1 diff --git a/src/Idea.hs b/src/Idea.hs --- a/src/Idea.hs +++ b/src/Idea.hs @@ -4,12 +4,11 @@ Idea(..), rawIdea, idea, suggest, suggestRemove, ideaRemove, warn, ignore, rawIdeaN, suggestN, ignoreNoSuggestion, - showIdeasJson, showANSI, showIdeaANSI, + showIdeasJson, showIdeaANSI, Note(..), showNotes, Severity(..), ) where -import Data.Functor import Data.List.Extra import Config.Type import HsColour @@ -68,13 +67,9 @@ show = showEx id --- | Show an 'Idea' with ANSI color, using the hscolour preferences file. -showANSI :: IO (Idea -> String) -showANSI = showEx <$> hsColourConsole - -- | Show an 'Idea' with ANSI color codes to give syntax coloring to the Haskell code. showIdeaANSI :: Idea -> String -showIdeaANSI = showEx hsColourConsolePure +showIdeaANSI = showEx hsColourConsole showEx :: (String -> String) -> Idea -> String showEx tt Idea{..} = unlines $