diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,5 +1,14 @@ Changelog for HLint (* = breaking change) +3.3.5, released 2021-12-12 + #1304, support aeson-2.0 + #1309, suggest `either Left f x` becomes `f =<< x` + #1295, suggest TemplateHaskell to TemplateHaskellQuotes if it works + #1292, don't say redundant bracket around pattern splices + #1289, suggest expanding tuple sections in some cases + #1289, suggest length [1..n] ==> max 0 n + #1279, suggest using NumericUnderscores more if it is enabled + #1290, move reverse out of filter 3.3.4, released 2021-08-30 #1288, fix generation of Linux binaries 3.3.3, released 2021-08-29 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -20,6 +20,7 @@ * HLint can be configured with knowledge of C Pre Processor flags, but it can only see one conditional set of code at a time. * HLint turns on many language extensions so it can parse more documents, occasionally some break otherwise legal syntax - e.g. `{-#INLINE foo#-}` doesn't work with `MagicHash`, `foo $bar` means something different with `TemplateHaskell`. These extensions can be disabled with `-XNoMagicHash` or `-XNoTemplateHaskell` etc. * HLint doesn't run any custom preprocessors, e.g. [markdown-unlit](https://hackage.haskell.org/package/markdown-unlit) or [record-dot-preprocessor](https://hackage.haskell.org/package/record-dot-preprocessor), so code making use of them will usually fail to parse. +* Some hints, like `Use const`, don't work for non-lifted (i.e. unlifted and unboxed) types. ## Installing and running HLint diff --git a/data/hlint.yaml b/data/hlint.yaml --- a/data/hlint.yaml +++ b/data/hlint.yaml @@ -221,6 +221,7 @@ - warn: {lhs: "lookup b (zip l [0..])", rhs: elemIndex b l} - hint: {lhs: "elem x [y]", rhs: x == y, note: ValidInstance Eq a} - hint: {lhs: "notElem x [y]", rhs: x /= y, note: ValidInstance Eq a} + - hint: {lhs: "length [1..n]", rhs: max 0 n} - hint: {lhs: length x >= 0, rhs: "True", name: Length always non-negative} - hint: {lhs: 0 <= length x, rhs: "True", name: Length always non-negative} - hint: {lhs: length x > 0, rhs: not (null x), note: IncreasesLaziness, name: Use null} @@ -564,6 +565,8 @@ - warn: {lhs: snd (unzip x), rhs: map snd x} - hint: {lhs: "\\x y -> (x, y)", rhs: "(,)"} - hint: {lhs: "\\x y z -> (x, y, z)", rhs: "(,,)"} + - hint: {lhs: "(,b) a", rhs: "(a,b)", side: isAtom a, name: Evaluate} + - hint: {lhs: "(a,) b", rhs: "(a,b)", side: isAtom b, name: Evaluate} # MAYBE @@ -627,6 +630,7 @@ - warn: {lhs: catMaybes (nubOrd x), rhs: nubOrd (catMaybes x), name: Move nubOrd out} - warn: {lhs: lefts (nubOrd x), rhs: nubOrd (lefts x), name: Move nubOrd out} - warn: {lhs: rights (nubOrd x), rhs: nubOrd (rights x), name: Move nubOrd out} + - warn: {lhs: filter f (reverse x), rhs: reverse (filter f x), name: Move reverse out} # EITHER @@ -640,6 +644,7 @@ - warn: {lhs: fromRight x (fmap f y), rhs: either (const x) f y} - warn: {lhs: either (const x) id, rhs: fromRight x} - warn: {lhs: either id (const x), rhs: fromLeft x} + - warn: {lhs: either Left f x, rhs: f =<< x} # INFIX 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.3.4 +version: 3.3.5 license: BSD3 license-file: LICENSE category: Development @@ -160,10 +160,12 @@ Hint.Smell Hint.Type Hint.Unsafe + Hint.NumLiteral Test.All Test.Annotations Test.InputOutput Test.Util + ghc-options: -Wunused-binds -Wunused-imports -Worphans executable hlint diff --git a/src/Config/Yaml.hs b/src/Config/Yaml.hs --- a/src/Config/Yaml.hs +++ b/src/Config/Yaml.hs @@ -40,6 +40,9 @@ import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader import Data.Char +#if MIN_VERSION_aeson(2,0,0) +import Data.Aeson.KeyMap (toHashMapText) +#endif #ifdef HS_YAML @@ -68,6 +71,10 @@ #endif +#if !MIN_VERSION_aeson(2,0,0) +toHashMapText :: a -> a +toHashMapText = id +#endif -- | Read a config file in YAML format. Takes a filename, and optionally the contents. -- Fails if the YAML doesn't parse or isn't valid HLint YAML @@ -138,7 +145,7 @@ parseArray v = pure [v] parseObject :: Val -> Parser (Map.HashMap T.Text Value) -parseObject (getVal -> Object x) = pure x +parseObject (getVal -> Object x) = pure (toHashMapText x) parseObject v = parseFail v "Expected an Object" parseObject1 :: Val -> Parser (String, Val) diff --git a/src/GHC/Util/ApiAnnotation.hs b/src/GHC/Util/ApiAnnotation.hs --- a/src/GHC/Util/ApiAnnotation.hs +++ b/src/GHC/Util/ApiAnnotation.hs @@ -3,13 +3,19 @@ comment, commentText, isCommentMultiline , pragmas, flags, languagePragmas , mkFlags, mkLanguagePragmas + , extensions ) where +import GHC.LanguageExtensions.Type (Extension) import GHC.Parser.Annotation import GHC.Types.SrcLoc +import Language.Haskell.GhclibParserEx.GHC.Driver.Session + import Control.Applicative import Data.List.Extra +import Data.Maybe +import qualified Data.Set as Set trimCommentStart :: String -> String trimCommentStart s @@ -63,6 +69,11 @@ where realToLoc :: RealLocated a -> Located a realToLoc (L r x) = L (RealSrcSpan r Nothing) x + +-- All the extensions defined to be used. +extensions :: ApiAnns -> Set.Set Extension +extensions = Set.fromList . mapMaybe readExtension . + concatMap snd . languagePragmas . pragmas -- Utility for a case insensitive prefix strip. stripPrefixCI :: String -> String -> Maybe String diff --git a/src/GHC/Util/DynFlags.hs b/src/GHC/Util/DynFlags.hs --- a/src/GHC/Util/DynFlags.hs +++ b/src/GHC/Util/DynFlags.hs @@ -1,23 +1,14 @@ module GHC.Util.DynFlags (initGlobalDynFlags, baseDynFlags) where import GHC.Driver.Session -import GHC.LanguageExtensions.Type -import Data.List.Extra import Language.Haskell.GhclibParserEx.GHC.Settings.Config +-- The list of default enabled extensions is empty. This is because: +-- the extensions to enable/disable are set exclusively in +-- 'parsePragmasIntoDynFlags' based solely on the parse flags +-- (and source level annotations). baseDynFlags :: DynFlags -baseDynFlags = - -- The list of default enabled extensions is empty except for - -- 'TemplateHaskellQuotes'. This is because: - -- * The extensions to enable/disable are set exclusively in - -- 'parsePragmasIntoDynFlags' based solely on HSE parse flags - -- (and source level annotations); - -- * 'TemplateHaskellQuotes' is not a known HSE extension but IS - -- needed if the GHC parse is to succeed for the unit-test at - -- hlint.yaml:860 - let enable = [TemplateHaskellQuotes] - in foldl' xopt_set (defaultDynFlags fakeSettings fakeLlvmConfig) enable - +baseDynFlags = defaultDynFlags fakeSettings fakeLlvmConfig initGlobalDynFlags :: IO () initGlobalDynFlags = setUnsafeGlobalDynFlags baseDynFlags diff --git a/src/Hint/All.hs b/src/Hint/All.hs --- a/src/Hint/All.hs +++ b/src/Hint/All.hs @@ -32,6 +32,7 @@ import Hint.Unsafe import Hint.NewType import Hint.Smell +import Hint.NumLiteral -- | A list of the builtin hints wired into HLint. -- This list is likely to grow over time. @@ -39,7 +40,7 @@ HintList | HintListRec | HintMonad | HintLambda | HintFixities | HintBracket | HintNaming | HintPattern | HintImport | HintExport | HintPragma | HintExtensions | HintUnsafe | HintDuplicate | HintRestrict | - HintComment | HintNewType | HintSmell + HintComment | HintNewType | HintSmell | HintNumLiteral deriving (Show,Eq,Ord,Bounded,Enum) -- See https://github.com/ndmitchell/hlint/issues/1150 - Duplicate is too slow @@ -67,6 +68,7 @@ HintPattern -> decl patternHint HintMonad -> decl monadHint HintExtensions -> modu extensionsHint + HintNumLiteral -> decl numLiteralHint where wrap = timed "Hint" (drop 4 $ show x) . forceList decl f = mempty{hintDecl=const $ \a b c -> wrap $ f a b c} diff --git a/src/Hint/Bracket.hs b/src/Hint/Bracket.hs --- a/src/Hint/Bracket.hs +++ b/src/Hint/Bracket.hs @@ -101,6 +101,9 @@ -- type splices are a bit special no = f @($x) + +-- template haskell is harder +issue1292 = [e| handleForeignCatch $ \ $(varP pylonExPtrVarName) -> $(quoteExp C.block modifiedStr) |] -} @@ -189,8 +192,10 @@ -- In some context, removing parentheses from 'x' succeeds. Does -- 'x' actually need bracketing in this context? f (Just (i, o, gen)) v@(remParens' -> Just x) - | not $ needBracket i o x, not $ isPartialAtom (Just o) x = - rawIdea Suggestion msg (getLoc v) (pretty o) (Just (pretty (gen x))) [] [r] : g x + | not $ needBracket i o x + , not $ isPartialAtom (Just o) x + , not $ any isSplicePat $ universeBi o -- over-appoximate ,see #1292 + = rawIdea Suggestion msg (getLoc v) (pretty o) (Just (pretty (gen x))) [] [r] : g x where typ = findType v r = Replace typ (toSS v) [("x", toSS x)] "x" @@ -202,6 +207,10 @@ -- Enumerate over all the immediate children of 'o' looking for -- redundant parentheses in each. g o = concat [f (Just (i, o, gen)) x | (i, (x, gen)) <- zipFrom 0 $ holes o] + +isSplicePat :: Pat GhcPs -> Bool +isSplicePat SplicePat{} = True +isSplicePat _ = False bracketWarning :: (Outputable a, Outputable b, Brackets (Located b)) => String -> Located a -> Located b -> Idea bracketWarning msg o x = diff --git a/src/Hint/Extensions.hs b/src/Hint/Extensions.hs --- a/src/Hint/Extensions.hs +++ b/src/Hint/Extensions.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE LambdaCase, NamedFieldPuns #-} +{-# LANGUAGE LambdaCase, NamedFieldPuns, ScopedTypeVariables #-} {- Suggest removal of unnecessary extensions @@ -15,7 +15,9 @@ {-# LANGUAGE TemplateHaskell #-} \ $(deriveNewtypes typeInfo) {-# LANGUAGE TemplateHaskell #-} \ -main = foo ''Bar +main = foo ''Bar -- +{-# LANGUAGE QuasiQuotes, TemplateHaskell #-} \ +f x = x + [e| x + 1 |] + [foo| x + 1 |] -- {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE PatternGuards #-} \ test = case x of _ | y <- z -> w {-# LANGUAGE TemplateHaskell,EmptyDataDecls #-} \ @@ -290,7 +292,9 @@ ] where usedTH :: Bool - usedTH = used TemplateHaskell (ghcModule x) || used QuasiQuotes (ghcModule x) + usedTH = used TemplateHaskell (ghcModule x) + || used TemplateHaskellQuotes (ghcModule x) + || used QuasiQuotes (ghcModule x) -- If TH or QuasiQuotes is on, can use all other extensions -- programmatically. @@ -301,7 +305,10 @@ -- Those extensions we detect to be useful. useful :: Set.Set Extension - useful = if usedTH then extensions else Set.filter (`usedExt` ghcModule x) extensions + useful = + if usedTH + then Set.filter (\case TemplateHaskell -> usedExt TemplateHaskell (ghcModule x); _ -> True) extensions + else Set.filter (`usedExt` ghcModule x) extensions -- Those extensions which are useful, but implied by other useful -- extensions. implied :: Map.Map Extension Extension @@ -379,12 +386,8 @@ f _ = False used KindSignatures = hasT (un :: HsKind GhcPs) used BangPatterns = hasS isPBangPat ||^ hasS isStrictMatch' -used TemplateHaskell = hasT2' (un :: (HsBracket GhcPs, HsSplice GhcPs)) ||^ hasS f ||^ hasS isSpliceDecl - where - f :: HsBracket GhcPs -> Bool - f VarBr{} = True - f TypBr{} = True - f _ = False +used TemplateHaskell = hasS $ \case (HsQuasiQuote{} :: HsSplice GhcPs) -> False; _ -> True +used TemplateHaskellQuotes = hasT (un :: HsBracket GhcPs) used ForeignFunctionInterface = hasT (un :: CCallConv) used PatternGuards = hasS f where @@ -536,7 +539,6 @@ un = undefined hasT t x = not $ null (universeBi x `asTypeOf` [t]) -hasT2' ~(t1,t2) = hasT t1 ||^ hasT t2 hasS :: (Data x, Data a) => (a -> Bool) -> x -> Bool hasS test = any test . universeBi diff --git a/src/Hint/Naming.hs b/src/Hint/Naming.hs --- a/src/Hint/Naming.hs +++ b/src/Hint/Naming.hs @@ -124,7 +124,7 @@ any (`isPrefixOf` original) ["prop_","case_","unit_","test_","spec_","scprop_","hprop_"] = Nothing | otherwise = Just $ f original where - good = all isAlphaNum $ drp '_' $ drp '#' $ filter (/= '\'') $ reverse $ drp '_' original + good = all isAlphaNum $ drp '_' $ drp '#' $ reverse $ filter (/= '\'') $ drp '_' original drp x = dropWhile (== x) f xs = us ++ g ys diff --git a/src/Hint/NumLiteral.hs b/src/Hint/NumLiteral.hs new file mode 100644 --- /dev/null +++ b/src/Hint/NumLiteral.hs @@ -0,0 +1,106 @@ +{- + Suggest the usage of underscore when NumericUnderscores is enabled. + + +123456 +{-# LANGUAGE NumericUnderscores #-} \ +12345 -- @Suggestion 12_345 @NoRefactor +{-# LANGUAGE NumericUnderscores #-} \ +123456789.0441234e-123456 -- @Suggestion 123_456_789.044_123_4e-123_456 @NoRefactor +{-# LANGUAGE NumericUnderscores #-} \ +0x12abc.523defp+172345 -- @Suggestion 0x1_2abc.523d_efp+172_345 @NoRefactor +{-# LANGUAGE NumericUnderscores #-} \ +3.14159265359 -- @Suggestion 3.141_592_653_59 @NoRefactor +{-# LANGUAGE NumericUnderscores #-} \ +12_33574_56 + + +-} + +module Hint.NumLiteral (numLiteralHint) where + +import GHC.Hs +import GHC.LanguageExtensions.Type (Extension (..)) +import GHC.Types.SrcLoc +import GHC.Types.Basic (SourceText (..), IntegralLit (..), FractionalLit (..)) +import GHC.Util.ApiAnnotation (extensions) +import Data.Char (isDigit, isOctDigit, isHexDigit) +import Data.List (intercalate) +import Data.Generics.Uniplate.DataOnly (universeBi) +import Refact.Types + +import Hint.Type (DeclHint, toSS, ghcAnnotations) +import Idea (Idea, suggest) + +numLiteralHint :: DeclHint +numLiteralHint _ modu = + if NumericUnderscores `elem` extensions (ghcAnnotations modu) then + concatMap suggestUnderscore . universeBi + else + const [] + +suggestUnderscore :: LHsExpr GhcPs -> [Idea] +suggestUnderscore x@(L _ (HsOverLit _ ol@(OverLit _ (HsIntegral intLit@(IL (SourceText srcTxt) _ _)) _))) = + [ suggest "Use underscore" x y [r] | '_' `notElem` srcTxt, srcTxt /= underscoredSrcTxt ] + where + underscoredSrcTxt = addUnderscore srcTxt + y = noLoc $ HsOverLit noExtField $ ol{ol_val = HsIntegral intLit{il_text = SourceText underscoredSrcTxt}} + r = Replace Expr (toSS x) [("a", toSS y)] "a" +suggestUnderscore x@(L _ (HsOverLit _ ol@(OverLit _ (HsFractional fracLit@(FL (SourceText srcTxt) _ _)) _))) = + [ suggest "Use underscore" x y [r] | '_' `notElem` srcTxt, srcTxt /= underscoredSrcTxt ] + where + underscoredSrcTxt = addUnderscore srcTxt + y = noLoc $ HsOverLit noExtField $ ol{ol_val = HsFractional fracLit{fl_text = SourceText underscoredSrcTxt}} + r = Replace Expr (toSS x) [("a", toSS y)] "a" +suggestUnderscore _ = mempty + +addUnderscore :: String -> String +addUnderscore intStr = numLitToStr underscoredNumLit + where + numLit = toNumLiteral intStr + underscoredNumLit = numLit{ nl_intPart = underscoreFromRight chunkSize $ nl_intPart numLit + , nl_fracPart = underscore chunkSize $ nl_fracPart numLit + , nl_exp = underscoreFromRight 3 $ nl_exp numLit -- Exponential part is always decimal + } + chunkSize = if null (nl_prefix numLit) then 3 else 4 + + underscore chunkSize = intercalate "_" . chunk chunkSize + underscoreFromRight chunkSize = reverse . underscore chunkSize . reverse + chunk chunkSize [] = [] + chunk chunkSize xs = a:chunk chunkSize b where (a, b) = splitAt chunkSize xs + +data NumLiteral = NumLiteral + { nl_prefix :: String + , nl_intPart :: String + , nl_decSep :: String -- decimal separator + , nl_fracPart :: String + , nl_expSep :: String -- e, e+, e-, p, p+, p- + , nl_exp :: String + } deriving (Show, Eq) + +toNumLiteral :: String -> NumLiteral +toNumLiteral str = case str of + '0':'b':digits -> (afterPrefix isBinDigit digits){nl_prefix = "0b"} + '0':'B':digits -> (afterPrefix isBinDigit digits){nl_prefix = "0B"} + '0':'o':digits -> (afterPrefix isOctDigit digits){nl_prefix = "0o"} + '0':'O':digits -> (afterPrefix isOctDigit digits){nl_prefix = "0O"} + '0':'x':digits -> (afterPrefix isHexDigit digits){nl_prefix = "0x"} + '0':'X':digits -> (afterPrefix isHexDigit digits){nl_prefix = "0X"} + _ -> afterPrefix isDigit str + where + isBinDigit x = x == '0' || x == '1' + + afterPrefix isDigit str = (afterIntPart isDigit suffix){nl_intPart = intPart} + where (intPart, suffix) = span isDigit str + + afterIntPart isDigit ('.':suffix) = (afterDecSep isDigit suffix){nl_decSep = "."} + afterIntPart isDigit str = afterFracPart str + + afterDecSep isDigit str = (afterFracPart suffix){nl_fracPart = fracPart} + where (fracPart, suffix) = span isDigit str + + afterFracPart str = NumLiteral "" "" "" "" expSep exp + where (expSep, exp) = break isDigit str + +numLitToStr :: NumLiteral -> String +numLitToStr (NumLiteral p ip ds fp es e) = p ++ ip ++ ds ++ fp ++ es ++ e