diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,5 +1,13 @@ Changelog for HLint (* = breaking change) +3.3.1, released 2021-04-26 + #1221, allow restrictions to use wildcards + #1225, treat A{} as not-atomic for bracket hints + #1233, -XHaskell98 and -XHaskell2010 now disable extensions too + #1226, don't warn on top-level splices with brackets + #1230, disable LexicalNegation by default + #1219, suggest uncurry f (a, b) ==> f a b + #1227, remove some excess brackets generated by refactoring 3.3, released 2021-03-14 #1212, don't suggest redundant brackets on $(x) #1215, suggest varE 'foo ==> [|foo|] diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -13,7 +13,7 @@ * HLint operates on each module at a time in isolation, as a result HLint does not know about types or which names are in scope. This decision is deliberate, allowing HLint to parallelise and be used incrementally on code that may not type-check. If fixities are required to parse the code properly, they [can be supplied](./README.md#why-doesnt-hlint-know-the-fixity-for-my-custom--operator). * The presence of `seq` may cause some hints (i.e. eta-reduction) to change the semantics of a program. -* Some transformed programs may require additional type signatures, particularly if the transformations trigger the monomorphism restriction or involve rank-2 types. +* Some transformed programs may require [additional type signatures](https://stackoverflow.com/questions/16402942/how-can-eta-reduction-of-a-well-typed-function-result-in-a-type-error/), particularly if the transformations trigger the monomorphism restriction or involve rank-2 types. In rare cases, there might be [nowhere to write](https://stackoverflow.com/questions/19758828/eta-reduce-is-not-always-held-in-haskell) the required type signature. * Sometimes HLint will change the code in a way that causes values to default to different types, which may change the behaviour. * HLint assumes duplicate identical expressions within in a single expression are used at the same type. * The `RebindableSyntax` extension can cause HLint to suggest incorrect changes. @@ -367,6 +367,14 @@ You can customize the `Note:` for restricted modules, functions and extensions, by providing a `message` field (default: `may break the code`). +You can use [glob](https://en.wikipedia.org/wiki/Glob_(programming))-style wildcards to match on module names. + +```yaml +- modules: + - {name: [Data.Map, Data.Map.*], as: Map} + - {name: Test.Hspec, within: **.*Spec } +``` + ## Hacking HLint Contributions to HLint are most welcome, following [my standard contribution guidelines](https://github.com/ndmitchell/neil/blob/master/README.md#contributions). @@ -398,6 +406,10 @@ Getting started on problems in HLint often means wanting to inspect a GHC parse tree to get a sense of what it looks like (to see how to match on it for example). Given a source program `Foo.hs` (say), you can get GHC to print a textual representation of `Foo`'s AST via the `-ddump-parsed-ast` flag e.g. `ghc -fforce-recomp -ddump-parsed-ast -c Foo.hs`. When you have an [`HsSyn`](https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/hs-syn-type) term in your program, it's quite common to want to print it (e.g. via `Debug.Trace.trace`). Types in `HsSyn` aren't in [`Show`](https://hoogle.haskell.org/?hoogle=Show). Not all types in `HsSyn` are [`Outputable`](https://hoogle.haskell.org/?hoogle=Outputable) but when they are you can call `ppr` to get `SDoc`s. This idiom is common enough that there exists [`unsafePrettyPrint`](https://hackage.haskell.org/package/ghc-lib-parser-ex-8.10.0.16/docs/Language-Haskell-GhclibParserEx-GHC-Utils-Outputable.html#v:unsafePrettyPrint). The function [`showAstData`](https://hoogle.haskell.org/?hoogle=showAstData) can be called on any `HsSyn` term to get output like with the `dump-parsed-ast` flag. The `showAstData` approach is preferable to `ppr` when both choices exist in that two ASTs that differ only in fixity arrangements will render differently with the former. + +### Generating the hints summary + +The hints summary is an auto-generated list of hlint's builtin hints. This can be generated with `hlint --generate-summary`, which will output the summary to `hints.md`. ### Acknowledgements diff --git a/data/hlint.yaml b/data/hlint.yaml --- a/data/hlint.yaml +++ b/data/hlint.yaml @@ -310,6 +310,7 @@ - warn: {lhs: "curry (\\(x,y) -> z)", rhs: "\\x y -> z"} - warn: {lhs: uncurry (curry f), rhs: f} - warn: {lhs: curry (uncurry f), rhs: f} + - warn: {lhs: "uncurry f (a, b)", rhs: f a b} - warn: {lhs: ($) (f x), rhs: f x, name: Redundant $} - warn: {lhs: (f $), rhs: f, name: Redundant $} - warn: {lhs: (Data.Function.& f), rhs: f, name: Redundant Data.Function.&} @@ -1194,7 +1195,7 @@ # f condition tChar tBool = if condition then _monoField tChar else _monoField tBool # foo = maybe Bar{..} id -- Data.Maybe.fromMaybe Bar{..} # foo = (\a -> Foo {..}) 1 -# foo = zipWith SymInfo [0 ..] (repeat ty) -- map (`SymInfo` ty) [0 ..] @NoRefactor +# foo = zipWith SymInfo [0 ..] (repeat ty) -- map (`SymInfo` ty) [0 ..] # foo = zipWith (SymInfo q) [0 ..] (repeat ty) -- map (( \ x_ -> SymInfo q x_ ty)) [0 .. ] @NoRefactor # f rec = rec # mean x = fst $ foldl (\(m, n) x' -> (m+(x'-m)/(n+1),n+1)) (0,0) x @@ -1221,6 +1222,7 @@ # issue1058 n = [] ++ issue1058 (n+1) -- issue1058 (n+1) # issue1183 = (a >= 'a') && a <= 'z' -- isAsciiLower a # issue1183 = (a >= 'a') && (a <= 'z') -- isAsciiLower a +# issue1218 = uncurry (zipWith g) $ (a, b) -- zipWith g a b # import Language.Haskell.TH\ # yes = varE 'foo -- [|foo|] diff --git a/data/wildcard-import.yaml b/data/wildcard-import.yaml new file mode 100644 --- /dev/null +++ b/data/wildcard-import.yaml @@ -0,0 +1,1 @@ +[ { modules: [ { name: Data.Map.*, as: Map } ] } ] 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 +version: 3.3.1 license: BSD3 license-file: LICENSE category: Development diff --git a/src/Apply.hs b/src/Apply.hs --- a/src/Apply.hs +++ b/src/Apply.hs @@ -20,7 +20,7 @@ import Language.Haskell.GhclibParserEx.GHC.Hs import qualified Data.HashSet as Set import Prelude -import System.FilePattern (FilePattern, (?==)) +import Util -- | Apply hints to a single file, you may have the contents of the file. @@ -116,19 +116,3 @@ | otherwise = r x ~= y = x == "" || any (wildcardMatch x) y x ~~= y = x == "" || x == y || ((x ++ ":") `isPrefixOf` y) - --- | Returns true if the pattern matches the string. For example: --- --- >>> let isSpec = wildcardMatch "**.*Spec" --- >>> isSpec "Example" --- False --- >>> isSpec "ExampleSpec" --- True --- >>> isSpec "Namespaced.ExampleSpec" --- True --- >>> isSpec "Deeply.Nested.ExampleSpec" --- True --- --- See this issue for details: . -wildcardMatch :: FilePattern -> String -> Bool -wildcardMatch p m = let f = replace "." "/" in f p ?== f m diff --git a/src/CmdLine.hs b/src/CmdLine.hs --- a/src/CmdLine.hs +++ b/src/CmdLine.hs @@ -288,23 +288,41 @@ getExtensions :: [String] -> (Maybe Language, ([Extension], [Extension])) -getExtensions args = - (lang, foldl f (if null langs then (defaultExtensions, []) else ([], [])) exts) - where - lang = if null langs then Nothing else Just $ fromJust $ lookup (last langs) ls +getExtensions args = (lang, foldl f (startExts, []) exts) + where + -- If a language specifier is provided e.g. Haskell98 or + -- Haskell2010 (and soon GHC2021), then it represents a + -- specific set of extensions which we default enable. + + -- If no language specifier is provided we construct our own + -- set of extensions to default enable. The set that we + -- construct default enables more extensions than GHC would + -- default enable were it to be invoked without an explicit + -- language specifier given. + startExts :: [Extension] + startExts = case lang of + Nothing -> defaultExtensions + Just _ -> GHC.Driver.Session.languageExtensions lang + + -- If multiple languages are given, the last language "wins". + lang :: Maybe Language + lang = fromJust . flip lookup ls . snd <$> unsnoc langs + + langs, exts :: [String] (langs, exts) = partition (isJust . flip lookup ls) args - ls = [(show x, x) | x <- [Haskell98, Haskell2010]] + ls = [ (show x, x) | x <- [Haskell98, Haskell2010 {-, GHC2021-}] ] - f (a, e) "Haskell98" = ([], []) - f (a, e) ('N':'o':x) | Just x <- GhclibParserEx.readExtension x, let xs = expandDisable x = - (deletes xs a, xs ++ deletes xs e) + f :: ([Extension], [Extension]) -> String -> ([Extension], [Extension]) + f (a, e) ('N':'o':x) | Just x <- GhclibParserEx.readExtension x, let xs = expandDisable x = (deletes xs a, xs ++ deletes xs e) f (a, e) x | Just x <- GhclibParserEx.readExtension x = (x : delete x a, delete x e) f (a, e) x = error $ "Unknown extension: '" ++ x ++ "'" + deletes :: [Extension] -> [Extension] -> [Extension] deletes [] ys = ys - deletes (x:xs) ys = deletes xs $ delete x ys + deletes (x : xs) ys = deletes xs $ delete x ys -- if you disable a feature that implies another feature, sometimes we should disable both -- e.g. no one knows what TemplateHaskellQuotes is https://github.com/ndmitchell/hlint/issues/1038 + expandDisable :: Extension -> [Extension] expandDisable TemplateHaskell = [TemplateHaskell, TemplateHaskellQuotes] expandDisable x = [x] diff --git a/src/Extension.hs b/src/Extension.hs --- a/src/Extension.hs +++ b/src/Extension.hs @@ -16,6 +16,7 @@ , UnboxedTuples, UnboxedSums -- breaks (#) lens operator , QuasiQuotes -- breaks [x| ...], making whitespace free list comps break , {- DoRec , -} RecursiveDo -- breaks rec + , LexicalNegation -- changes '-', see https://github.com/ndmitchell/hlint/issues/1230 ] reallyBadExtensions = diff --git a/src/GHC/Util/Brackets.hs b/src/GHC/Util/Brackets.hs --- a/src/GHC/Util/Brackets.hs +++ b/src/GHC/Util/Brackets.hs @@ -36,7 +36,8 @@ isAtom (L _ x) = case x of HsVar{} -> True HsUnboundVar{} -> True - HsRecFld{} -> True + -- Technically atomic, but lots of people think it shouldn't be + HsRecFld{} -> False HsOverLabel{} -> True HsIPVar{} -> True -- Note that sections aren't atoms (but parenthesized sections are). @@ -111,7 +112,8 @@ ParPat{} -> True TuplePat{} -> True ListPat{} -> True - ConPat _ _ RecCon{} -> True + -- This is technically atomic, but lots of people think it shouldn't be + ConPat _ _ RecCon{} -> False ConPat _ _ (PrefixCon []) -> True VarPat{} -> True WildPat{} -> True diff --git a/src/GHC/Util/FreeVars.hs b/src/GHC/Util/FreeVars.hs --- a/src/GHC/Util/FreeVars.hs +++ b/src/GHC/Util/FreeVars.hs @@ -200,6 +200,7 @@ allVars (L _ (HsValBinds _ (ValBinds _ binds _))) = allVars (bagToList binds) -- Value bindings. allVars (L _ (HsIPBinds _ (IPBinds _ binds))) = allVars binds -- Implicit parameter bindings. allVars (L _ EmptyLocalBinds{}) = mempty -- The case of no local bindings (signals the empty `let` or `where` clause). + allVars _ = mempty -- extension points instance AllVars (LIPBind GhcPs) where allVars (L _ (IPBind _ _ e)) = freeVars_ e @@ -225,6 +226,7 @@ allVars (PatGuard FunRhs{mc_fun=n}) = allVars (noLoc $ VarPat noExtField n :: LPat GhcPs) allVars ParStmtCtxt{} = mempty -- Come back to it. allVars TransStmtCtxt{} = mempty -- Come back to it. + allVars _ = mempty instance AllVars (GRHSs GhcPs (LHsExpr GhcPs)) where allVars (GRHSs _ grhss binds) = inVars binds (mconcatMap allVars grhss) @@ -234,6 +236,7 @@ instance AllVars (LHsDecl GhcPs) where allVars (L l (ValD _ bind)) = allVars (L l bind :: LHsBind GhcPs) + allVars _ = mempty vars :: FreeVars a => a -> [String] diff --git a/src/GHC/Util/HsExpr.hs b/src/GHC/Util/HsExpr.hs --- a/src/GHC/Util/HsExpr.hs +++ b/src/GHC/Util/HsExpr.hs @@ -27,7 +27,9 @@ import GHC.Util.View import Control.Applicative +import Control.Monad.Trans.Class import Control.Monad.Trans.State +import Control.Monad.Trans.Writer.CPS import Data.Data import Data.Generics.Uniplate.DataOnly @@ -91,10 +93,13 @@ transformAppsM f x = f =<< descendAppsM (transformAppsM f) x descendIndex :: Data a => (Int -> a -> a) -> a -> a -descendIndex f x = flip evalState 0 $ flip descendM x $ \y -> do +descendIndex f = fst . descendIndex' (\x a -> writer (f x a, ())) + +descendIndex' :: (Data a, Monoid w) => (Int -> a -> Writer w a) -> a -> (a, w) +descendIndex' f x = runWriter $ flip evalStateT 0 $ flip descendM x $ \y -> do i <- get modify (+1) - pure $ f i y + lift $ f i y -- There are differences in pretty-printing between GHC and HSE. This -- version never removes brackets. @@ -114,7 +119,6 @@ appsBracket = foldl1 mkApp where mkApp x y = rebracket1 (noLoc $ HsApp noExtField x y) - simplifyExp :: LHsExpr GhcPs -> LHsExpr GhcPs -- Replace appliciations 'f $ x' with 'f (x)'. simplifyExp (L l (OpApp _ x op y)) | isDol op = L l (HsApp noExtField x (noLoc (HsPar noExtField y))) @@ -136,7 +140,6 @@ niceDotApp (L _ (HsVar _ (L _ r))) b | occNameStr r == "$" = b niceDotApp a b = dotApp a b - -- Generate a lambda expression but prettier if possible. niceLambda :: [String] -> LHsExpr GhcPs -> LHsExpr GhcPs niceLambda ss e = fst (niceLambdaR ss e)-- We don't support refactorings yet. @@ -271,37 +274,45 @@ | isDotApp parent, isDotApp child, i == 2 = False | otherwise = needBracket i parent child -transformBracketOld :: (LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)) -> LHsExpr GhcPs -> (LHsExpr GhcPs, LHsExpr GhcPs) +transformBracketOld :: (LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)) + -> LHsExpr GhcPs + -> (LHsExpr GhcPs, (LHsExpr GhcPs, [String])) transformBracketOld op = first snd . g where g = first f . descendBracketOld g f x = maybe (False, x) (True, ) (op x) -- Descend, and if something changes then add/remove brackets --- appropriately. Returns (suggested replacement, refactor template). --- Whenever a bracket is added to the suggested replacement, a --- corresponding bracket is added to the refactor template. -descendBracketOld :: (LHsExpr GhcPs -> ((Bool, LHsExpr GhcPs), LHsExpr GhcPs)) - -> LHsExpr GhcPs - -> (LHsExpr GhcPs, LHsExpr GhcPs) -descendBracketOld op x = (descendIndex g1 x, descendIndex g2 x) +-- appropriately. Returns (suggested replacement, (refactor template, no bracket vars)), +-- where "no bracket vars" is a list of substitution variables which, when expanded, +-- should have the brackets stripped. +descendBracketOld :: (LHsExpr GhcPs -> ((Bool, LHsExpr GhcPs), (LHsExpr GhcPs, [String]))) + -> LHsExpr GhcPs + -> (LHsExpr GhcPs, (LHsExpr GhcPs, [String])) +descendBracketOld op x = (descendIndex g1 x, descendIndex' g2 x) where - g i y = if a then (f1 i b z, f2 i b z) else (b, z) - where ((a, b), z) = op y + g i y = if a then (f1 i b z w, f2 i b z w) else (b, (z, w)) + where ((a, b), (z, w)) = op y - g1 = (fst .) . g - g2 = (snd .) . g + g1 a b = fst (g a b) + g2 a b = writer $ snd (g a b) - f i (L _ (HsPar _ y)) z - | not $ needBracketOld i x y = (y, z) - f i y z - | needBracketOld i x y = (addParen y, addParen z) + f i (L _ (HsPar _ y)) z w + | not $ needBracketOld i x y = (y, removeBracket z) + where + -- If the template expr is a Var, record it so that we can remove the brackets + -- later when expanding it. Otherwise, remove the enclosing brackets (if any). + removeBracket = \case + var@(L _ HsVar{}) -> (z, varToStr var : w) + other -> (fromParen z, w) + f i y z w + | needBracketOld i x y = (addParen y, (addParen z, w)) -- https://github.com/mpickering/apply-refact/issues/7 - | isOp y = (y, addParen z) - f _ y z = (y, z) + | isOp y = (y, (addParen z, w)) + f _ y z w = (y, (z, w)) - f1 = ((fst .) .) . f - f2 = ((snd .) .) . f + f1 a b c d = fst (f a b c d) + f2 a b c d = snd (f a b c d) isOp = \case L _ (HsVar _ (L _ name)) -> isSymbolRdrName name diff --git a/src/GHC/Util/Unify.hs b/src/GHC/Util/Unify.hs --- a/src/GHC/Util/Unify.hs +++ b/src/GHC/Util/Unify.hs @@ -62,10 +62,14 @@ map (\(x, y) -> if x `elem` noParens then (x, fromParen y) else (x, y)) xs -- Peform a substition. --- Returns (suggested replacement, refactor template), both with brackets added --- as needed. --- Example: (traverse foo (bar baz), traverse f (x)) -substitute :: Subst (LHsExpr GhcPs) -> LHsExpr GhcPs -> (LHsExpr GhcPs, LHsExpr GhcPs) +-- Returns (suggested replacement, (refactor template, no bracket vars)). It adds/removes brackets +-- for both the suggested replacement and the refactor template appropriately. The "no bracket vars" +-- is a list of substituation variables which, when expanded, should have the brackets stripped. +-- +-- Examples: +-- (traverse foo (bar baz), (traverse f (x), [])) +-- (zipWith foo bar baz, (f a b, [f])) +substitute :: Subst (LHsExpr GhcPs) -> LHsExpr GhcPs -> (LHsExpr GhcPs, (LHsExpr GhcPs, [String])) substitute (Subst bind) = transformBracketOld exp . transformBi pat . transformBi typ where exp :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs) @@ -183,6 +187,7 @@ isAmp :: LHsExpr GhcPs -> Bool isAmp (L _ (HsVar _ x)) = rdrNameStr x == "&" +isAmp _ = False -- | If we "throw away" the extra than we have no where to put it, and the substitution is wrong noExtra :: Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs)) -> Maybe (Subst (LHsExpr GhcPs)) diff --git a/src/Hint/Bracket.hs b/src/Hint/Bracket.hs --- a/src/Hint/Bracket.hs +++ b/src/Hint/Bracket.hs @@ -55,7 +55,6 @@ foo (x:xs) = 1 foo (True) = 1 -- @Warning True foo ((True)) = 1 -- @Warning True -foo (A{}) = True -- A{} f x = case x of (Nothing) -> 1; _ -> 2 -- Nothing -- dollar reduction tests @@ -94,6 +93,11 @@ special = foo $ Rec{x=1} special = foo (f{x=1}) loadCradleOnlyonce = skipManyTill anyMessage (message @PublishDiagnosticsNotification) +-- These used to require a bracket +$(pure []) +$(x) +-- People aren't a fan of the record constructors being secretly atomic +function (Ctor (Rec { field })) = Ctor (Rec {field = 1}) -- type splices are a bit special no = f @($x) @@ -118,7 +122,7 @@ bracketHint :: DeclHint bracketHint _ _ x = - concatMap (\x -> bracket prettyExpr isPartialAtom True x ++ dollar x) (childrenBi (descendBi annotations x) :: [LHsExpr GhcPs]) ++ + concatMap (\x -> bracket prettyExpr isPartialAtom True x ++ dollar x) (childrenBi (descendBi splices $ descendBi annotations x) :: [LHsExpr GhcPs]) ++ concatMap (bracket unsafePrettyPrint (\_ _ -> False) False) (childrenBi x :: [LHsType GhcPs]) ++ concatMap (bracket unsafePrettyPrint (\_ _ -> False) False) (childrenBi x :: [LPat GhcPs]) ++ concatMap fieldDecl (childrenBi x) @@ -128,6 +132,13 @@ annotations= descendBi $ \x -> case (x :: LHsExpr GhcPs) of L _ (HsPar _ x) -> x x -> x + + -- Brackets at the root of splices used to be required, but now they aren't + splices :: HsDecl GhcPs -> HsDecl GhcPs + splices (SpliceD a x) = SpliceD a $ flip descendBi x $ \x -> case (x :: LHsExpr GhcPs) of + L _ (HsPar _ x) -> x + x -> x + splices x = x -- If we find ourselves in the context of a section and we want to -- issue a warning that a child therein has unneccessary brackets, diff --git a/src/Hint/Match.hs b/src/Hint/Match.hs --- a/src/Hint/Match.hs +++ b/src/Hint/Match.hs @@ -146,7 +146,7 @@ -- (with 'e') need to unqualify before substitution (with 'res'). let rhs' | Just fun <- extra = rebracket1 $ noLoc (HsApp noExtField fun rhs) | otherwise = rhs - (e, tpl) = substitute u rhs' + (e, (tpl, substNoParens)) = substitute u rhs' noParens = [varToStr $ fromParen x | L _ (HsApp _ (varToStr -> "_noParen_") x) <- universe tpl] u <- pure (removeParens noParens u) @@ -167,7 +167,11 @@ (u, tpl) <- pure $ if any ((== noSrcSpan) . getLoc . snd) (fromSubst u) then (mempty, res) else (u, tpl) tpl <- pure $ unqualify sa sb (performSpecial tpl) - pure (res, tpl, hintRuleNotes, [(s, toSS pos) | (s, pos) <- fromSubst u, getLoc pos /= noSrcSpan]) + pure ( res, tpl, hintRuleNotes, + [ (s, toSS pos') | (s, pos) <- fromSubst u, getLoc pos /= noSrcSpan + , let pos' = if s `elem` substNoParens then fromParen pos else pos + ] + ) --------------------------------------------------------------------- -- SIDE CONDITIONS diff --git a/src/Hint/Naming.hs b/src/Hint/Naming.hs --- a/src/Hint/Naming.hs +++ b/src/Hint/Naming.hs @@ -110,6 +110,7 @@ where getConNames' ConDeclH98 {con_name = name} = [name] getConNames' ConDeclGADT {con_names = names} = names + getConNames' XConDecl{} = [] getConstructorNames _ = [] diff --git a/src/Hint/NewType.hs b/src/Hint/NewType.hs --- a/src/Hint/NewType.hs +++ b/src/Hint/NewType.hs @@ -168,6 +168,7 @@ removeConDeclFieldUnpacks :: ConDeclField GhcPs -> ConDeclField GhcPs removeConDeclFieldUnpacks conDeclField@(ConDeclField _ _ fieldType _) = conDeclField {cd_fld_type = getBangType fieldType} +dropConsBang x = x isUnboxedTuple :: HsType GhcPs -> Bool isUnboxedTuple (HsTupleTy _ HsUnboxedTuple _) = True diff --git a/src/Hint/Restrict.hs b/src/Hint/Restrict.hs --- a/src/Hint/Restrict.hs +++ b/src/Hint/Restrict.hs @@ -23,6 +23,7 @@ import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),warn,rawIdea) import Config.Type +import Util import Data.Generics.Uniplate.DataOnly import qualified Data.List.NonEmpty as NonEmpty @@ -141,7 +142,7 @@ | not allowQual -> warn "Avoid restricted qualification" i (noLoc $ (unLoc i){ ideclAs=noLoc . mkModuleName <$> listToMaybe riAs} :: Located (ImportDecl GhcPs)) [] | otherwise -> error "checkImports: unexpected case" | i@(L _ ImportDecl {..}) <- imp - , let RestrictItem{..} = Map.findWithDefault (RestrictItem [] [("","") | def] [] Nothing) (moduleNameString (unLoc ideclName)) mp + , let RestrictItem{..} = getRestrictItem def ideclName mp , let allowImport = within modu "" riWithin , let allowIdent = Set.disjoint (Set.fromList riBadIdents) @@ -149,6 +150,19 @@ , let allowQual = maybe True (\x -> null riAs || moduleNameString (unLoc x) `elem` riAs) ideclAs , not allowImport || not allowQual || not allowIdent ] + +getRestrictItem :: Bool -> Located ModuleName -> Map.Map String RestrictItem -> RestrictItem +getRestrictItem def ideclName = fromMaybe (RestrictItem [] [("","") | def] [] Nothing) . lookupRestrictItem ideclName + +lookupRestrictItem :: Located ModuleName -> Map.Map String RestrictItem -> Maybe RestrictItem +lookupRestrictItem ideclName mp = + let moduleName = moduleNameString $ unLoc ideclName + exact = Map.lookup moduleName mp + wildcard = fmap snd + . find (flip wildcardMatch moduleName . fst) + . filter (elem '*' . fst) + $ Map.toList mp + in exact <|> wildcard importListToIdents :: IE GhcPs -> [String] importListToIdents = diff --git a/src/Util.hs b/src/Util.hs --- a/src/Util.hs +++ b/src/Util.hs @@ -4,7 +4,7 @@ forceList, gzip, universeParentBi, exitMessage, exitMessageImpure, - getContentsUTF8 + getContentsUTF8, wildcardMatch ) where import System.Exit @@ -13,6 +13,8 @@ import Unsafe.Coerce import Data.Data import Data.Generics.Uniplate.DataOnly +import System.FilePattern +import Data.List.Extra --------------------------------------------------------------------- @@ -64,3 +66,23 @@ universeParentBi :: (Data a, Data b) => a -> [(Maybe b, b)] universeParentBi = concatMap universeParent . childrenBi + + +--------------------------------------------------------------------- +-- SYSTEM.FILEPATTERN + +-- | Returns true if the pattern matches the string. For example: +-- +-- >>> let isSpec = wildcardMatch "**.*Spec" +-- >>> isSpec "Example" +-- False +-- >>> isSpec "ExampleSpec" +-- True +-- >>> isSpec "Namespaced.ExampleSpec" +-- True +-- >>> isSpec "Deeply.Nested.ExampleSpec" +-- True +-- +-- See this issue for details: . +wildcardMatch :: FilePattern -> String -> Bool +wildcardMatch p m = let f = replace "." "/" in f p ?== f m diff --git a/tests/hint.test b/tests/hint.test --- a/tests/hint.test +++ b/tests/hint.test @@ -45,9 +45,9 @@ OUTPUT tests/brackets.hs:1:8-49: Warning: Use fromMaybe Found: - if isNothing x then (-1.0) else fromJust x + if isNothing x then (- 1.0) else fromJust x Perhaps: - fromMaybe (-1.0) x + fromMaybe (- 1.0) x 1 hint diff --git a/tests/wildcard-import.test b/tests/wildcard-import.test new file mode 100644 --- /dev/null +++ b/tests/wildcard-import.test @@ -0,0 +1,27 @@ +--------------------------------------------------------------------- +RUN tests/wildcard-import-1.hs --hint=data/wildcard-import.yaml +FILE tests/wildcard-import-1.hs +import Data.Map.Lazy as Foo +OUTPUT +tests/wildcard-import-1.hs:1:1-27: Warning: Avoid restricted qualification +Found: + import Data.Map.Lazy as Foo +Perhaps: + import Data.Map.Lazy as Map +Note: may break the code + +1 hint + +--------------------------------------------------------------------- +RUN tests/wildcard-import-2.hs --hint=data/wildcard-import.yaml +FILE tests/wildcard-import-2.hs +import Data.Map.Strict as Foo +OUTPUT +tests/wildcard-import-2.hs:1:1-29: Warning: Avoid restricted qualification +Found: + import Data.Map.Strict as Foo +Perhaps: + import Data.Map.Strict as Map +Note: may break the code + +1 hint