packages feed

hlint 3.3.1 → 3.3.2

raw patch · 13 files changed

+218/−49 lines, 13 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

CHANGES.txt view
@@ -1,5 +1,19 @@ Changelog for HLint (* = breaking change) +3.3.2, released 2021-08-28+    #1244, add `only` restriction to modules+    #1278, make --ignore-glob patterns also ignore directories+    #1268, move nub/sort/reverse over catMaybes/lefts/rights+    #1276, fix some incorrect unused LANGUAGE warnings+    #1271, suggest foldr (<>) mempty ==> fold (not mconcat)+    #1274, make the (& f) ==> f hint apply more+    #1264, suggest eta reduction under a where+    #1266, suggest () <$ x ==> void x+    #1223, add some traverse laws+    #1254, suggest null [x] ==> False+    #1253, suggest reverse . init ==> tail . reverse+    #1253, suggest null . concat ==> all null+    #1255, suggest filter instead of list comprehension in teaching 3.3.1, released 2021-04-26     #1221, allow restrictions to use wildcards     #1225, treat A{} as not-atomic for bracket hints
README.md view
@@ -1,4 +1,4 @@-# HLint [![Hackage version](https://img.shields.io/hackage/v/hlint.svg?label=Hackage)](https://hackage.haskell.org/package/hlint) [![Stackage version](https://www.stackage.org/package/hlint/badge/nightly?label=Stackage)](https://www.stackage.org/package/hlint) [![Build status](https://img.shields.io/github/workflow/status/ndmitchell/hlint/ci.svg)](https://github.com/ndmitchell/hlint/actions)+# HLint [![Hackage version](https://img.shields.io/hackage/v/hlint.svg?label=Hackage)](https://hackage.haskell.org/package/hlint) [![Stackage version](https://www.stackage.org/package/hlint/badge/nightly?label=Stackage)](https://www.stackage.org/package/hlint) [![Build status](https://img.shields.io/github/workflow/status/ndmitchell/hlint/ci/master.svg)](https://github.com/ndmitchell/hlint/actions)  HLint is a tool for suggesting possible improvements to Haskell code. These suggestions include ideas such as using alternative functions, simplifying code and spotting redundancies. This document is structured as follows: @@ -281,7 +281,7 @@  * `{-# ANN module "HLint: ignore" #-}` or `{-# HLINT ignore #-}` or `{- HLINT ignore -}` - ignore all hints in this module (use `module` literally, not the name of the module). * `{-# ANN module "HLint: ignore Eta reduce" #-}` or `{-# HLINT ignore "Eta reduce" #-}` or `{- HLINT ignore "Eta reduce" -}` - ignore all eta reduction suggestions in this module.-* `{-# ANN myFunction "HLint: ignore" #-}` or `{-# HLINT ignore myFunction #-}` or `{- HLINT ignore myFunction -}` - don't give any hints in the function `myFunction`.+* `{-# ANN myFunction "HLint: ignore" #-}` or `{-# HLINT ignore myFunction #-}` or `{- HLINT ignore myFunction -}` - don't give any hints in the function `myFunction`. This may be combined with hint names, `{- HLINT ignore myFunction "Eta reduce" -}`, to only ignore that hint in that function. * `{-# ANN myFunction "HLint: error" #-}` or `{-# HLINT error myFunction #-}` or `{- HLINT error myFunction -}` - any hint in the function `myFunction` is an error. * `{-# ANN module "HLint: error Use concatMap" #-}` or `{-# HLINT error "Use concatMap" #-}` or `{- HLINT error "Use concatMap" -}` - the hint to use `concatMap` is an error (you may also use `warn` or `suggest` in place of `error` for other severity levels). @@ -361,9 +361,14 @@   - {name: [Data.Set, Data.HashSet], as: Set}   - {name: Control.Arrow, within: []}   - {name: Control.Monad.State, badidents: [modify, get, put], message: "Use Control.Monad.State.Class instead"}+  - {name: Control.Exception, only: [Exception], message: "Use UnliftIO.Exception instead"} ``` -This fragment requires that all imports of `Set` must be `qualified Data.Set as Set`, enforcing consistency. It also ensures the module `Control.Arrow` can't be used anywhere. It also prevents explicit imports of the `modify` identifier from `Control.Monad.State` (this is meant to allow you to prevent people from importing reexported identifiers).+This fragment adds the following hints:+* Requires that all imports of `Set` must be `qualified Data.Set as Set`, enforcing consistency+* Ensures the module `Control.Arrow` can't be used anywhere+* Prevents explicit imports of the given identifiers from `Control.Monad.State` (e.g. to prevent people from importing reexported identifiers).+* Prevents all imports from `Control.Exception`, except `Exception`  You can customize the `Note:` for restricted modules, functions and extensions, by providing a `message` field (default: `may break the code`).
data/hlint.yaml view
@@ -66,6 +66,8 @@     # I/O      - warn: {lhs: putStrLn (show x), rhs: print x}+    - warn: {lhs: putStr (x ++ "\n"), rhs: putStrLn x}+    - warn: {lhs: putStr (x ++ y ++ "\n"), rhs: putStrLn (x ++ y)}     - warn: {lhs: mapM_ putChar, rhs: putStr}     - warn: {lhs: hGetChar stdin, rhs: getChar}     - warn: {lhs: hGetLine stdin, rhs: getLine}@@ -137,6 +139,7 @@     - warn: {lhs: head (reverse x), rhs: last x}     - warn: {lhs: head (drop n x), rhs: x !! n, side: isNat n}     - warn: {lhs: head (drop n x), rhs: x !! max 0 n, side: not (isNat n) && not (isNeg n)}+    - warn: {lhs: reverse (init x), rhs: tail (reverse x)}     - warn: {lhs: reverse (tail (reverse x)), rhs: init x, note: IncreasesLaziness}     - warn: {lhs: reverse (reverse x), rhs: x, note: IncreasesLaziness, name: Avoid reverse}     - warn: {lhs: isPrefixOf (reverse x) (reverse y), rhs: isSuffixOf x y}@@ -191,6 +194,7 @@     - warn: {lhs: intercalate " ", rhs: unwords}     - hint: {lhs: concat (intersperse x y), rhs: intercalate x y, side: notEq x " "}     - hint: {lhs: concat (intersperse " " x), rhs: unwords x}+    - warn: {lhs: null (concat x), rhs: all null x}     - warn: {lhs: null (filter f x), rhs: not (any f x), name: Use any}     - warn: {lhs: "filter f x == []", rhs: not (any f x), name: Use any}     - warn: {lhs: "filter f x /= []", rhs: any f x}@@ -240,13 +244,15 @@     - warn: {lhs: mempty `mappend` x, rhs: x, name: "Monoid law, left identity"}     - warn: {lhs: x <> mempty, rhs: x, name: "Monoid law, right identity"}     - warn: {lhs: x `mappend` mempty, rhs: x, name: "Monoid law, right identity"}-    - warn: {lhs: foldr (<>) mempty, rhs: mconcat}-    - warn: {lhs: foldr mappend mempty, rhs: mconcat}+    - warn: {lhs: foldr (<>) mempty, rhs: Data.Foldable.fold}+    - warn: {lhs: foldr mappend mempty, rhs: Data.Foldable.fold}     - warn: {lhs: mempty x, rhs: mempty, name: Evaluate}     - warn: {lhs: x `mempty` y, rhs: mempty, name: Evaluate, note: "Make sure you didn't mean to use mappend instead of mempty"}      # TRAVERSABLES +    - warn: {lhs: traverse pure, rhs: pure, name: "Traversable law"}+    - warn: {lhs: traverse (pure . f) x, rhs: pure (fmap f x), name: "Traversable law"}     - warn: {lhs: sequenceA (map f x), rhs: traverse f x}     - warn: {lhs: sequenceA (fmap f x), rhs: traverse f x}     - warn: {lhs: sequenceA_ (map f x), rhs: traverse_ f x}@@ -313,7 +319,7 @@     - 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.&}+    - warn: {lhs: (& f), rhs: f, name: Redundant &}     - hint: {lhs: \x -> y, rhs: const y, side: isAtom y && not (isWildcard y)}         # If any isWildcard recursively then x may be used but not mentioned explicitly     - warn: {lhs: flip f x y, rhs: f y x, side: isApp original && isAtom y}@@ -465,6 +471,7 @@     - hint: {lhs: a >> return (), rhs: Control.Monad.void a, side: isAtom a || isApp a}     - warn: {lhs: fmap (const ()), rhs: Control.Monad.void}     - warn: {lhs: const () <$> x, rhs: Control.Monad.void x}+    - warn: {lhs: () <$ x, rhs: Control.Monad.void x}     - warn: {lhs: flip (>=>), rhs: (<=<)}     - warn: {lhs: flip (<=<), rhs: (>=>)}     - warn: {lhs: flip (>>=), rhs: (=<<)}@@ -608,6 +615,18 @@     - warn: {lhs: isNothing (fmap f x), rhs: isNothing x}     - warn: {lhs: fromJust (fmap f x), rhs: f (fromJust x), note: IncreasesLaziness}     - warn: {lhs: mapMaybe f (fmap g x), rhs: mapMaybe (f . g) x, name: Redundant fmap}+    - warn: {lhs: catMaybes (nub x), rhs: nub (catMaybes x), name: Move nub out}+    - warn: {lhs: lefts (nub x), rhs: nub (lefts x), name: Move nub out}+    - warn: {lhs: rights (nub x), rhs: nub (rights x), name: Move nub out}+    - warn: {lhs: catMaybes (reverse x), rhs: reverse (catMaybes x), name: Move reverse out}+    - warn: {lhs: lefts (reverse x), rhs: reverse (lefts x), name: Move reverse out}+    - warn: {lhs: rights (reverse x), rhs: reverse (rights x), name: Move reverse out}+    - warn: {lhs: catMaybes (sort x), rhs: sort (catMaybes x), name: Move sort out}+    - warn: {lhs: lefts (sort x), rhs: sort (lefts x), name: Move sort out}+    - warn: {lhs: rights (sort x), rhs: sort (rights x), name: Move sort out}+    - 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}      # EITHER @@ -735,6 +754,7 @@     - warn: {lhs: "fst (x,y)", rhs: x, name: Evaluate}     - warn: {lhs: "snd (x,y)", rhs: "y", name: Evaluate}     - warn: {lhs: "init [x]", rhs: "[]", name: Evaluate}+    - warn: {lhs: "null [x]", rhs: "False", name: Evaluate}     - warn: {lhs: "null []", rhs: "True", name: Evaluate}     - warn: {lhs: "length []", rhs: "0", name: Evaluate}     - warn: {lhs: "foldl f z []", rhs: z, name: Evaluate}@@ -1005,6 +1025,7 @@     - package base     - package codeworld-api     rules:+    - warn: {lhs: "pictures []", rhs: blank, name: Evaluate}     - warn: {lhs: "pictures [ p ]", rhs: p, name: Evaluate}     - warn: {lhs: "pictures [ p, q ]", rhs: p & q, name: Evaluate}     - hint: {lhs: foldl1 (&), rhs: pictures}@@ -1019,6 +1040,7 @@     - warn: {lhs: "lighter (- a)", rhs: "darker a"}     - warn: {lhs: "duller (- a)", rhs: "brighter a"}     - warn: {lhs: "darker (- a)", rhs: "lighter a"}+    - warn: {lhs: translated x y (translated u v p), rhs: translated (x + u) (y + v) p, name: Use translated once}  - group:     name: teaching@@ -1031,6 +1053,7 @@     - hint: {lhs: "not (x || y)", rhs: "not x && not y", name: Apply De Morgan law}     - hint: {lhs: "not (x && y)", rhs: "not x || not y", name: Apply De Morgan law}     - hint: {lhs: "[ f x | x <- l ]", rhs: map f l}+    - hint: {lhs: "[ x | x <- l, p x ]", rhs: filter p l}     - warn: {lhs: foldr f c (reverse x), rhs: foldl (flip f) c x, name: Use left fold instead of right fold}     - warn: {lhs: foldr1 f (reverse x), rhs: foldl1 (flip f) x, name: Use left fold instead of right fold}     - warn: {lhs: foldl f c (reverse x), rhs: foldr (flip f) c x, note: IncreasesLaziness, name: Use right fold instead of left fold}
data/test-restrict.yaml view
@@ -1,6 +1,8 @@ - modules:   - {name: Restricted.Module, within: []}   - {name: Restricted.Module.Message, within: [], message: "Custom message"}+  - {name: Restricted.Module.BadIdents, badidents: ['bad']}+  - {name: Restricted.Module.OnlyIdents, only: ['good']}  - functions:   - {name: restricted, within: []}
hlint.cabal view
@@ -1,7 +1,7 @@-cabal-version:      >= 1.18+cabal-version:      1.18 build-type:         Simple name:               hlint-version:            3.3.1+version:            3.3.2 license:            BSD3 license-file:       LICENSE category:           Development
src/CmdLine.hs view
@@ -163,7 +163,7 @@         ,cmdRefactor = nam_ "refactor" &= help "Automatically invoke `refactor` to apply hints"         ,cmdRefactorOptions = nam_ "refactor-options" &= typ "OPTIONS" &= help "Options to pass to the `refactor` executable"         ,cmdWithRefactor = nam_ "with-refactor" &= help "Give the path to refactor"-        ,cmdIgnoreGlob = nam_ "ignore-glob" &= help "Ignore paths matching glob pattern"+        ,cmdIgnoreGlob = nam_ "ignore-glob" &= help "Ignore paths matching glob pattern (e.g. foo/bar/*.hs)"         ,cmdGenerateSummary = nam_ "generate-summary" &= opt "hints.md" &= help "Generate a summary of built-in hints"         ,cmdTest = nam_ "test" &= help "Run the test suite"         } &= auto &= explicit &= name "lint"@@ -257,7 +257,7 @@     isDir <- doesDirectoryExist $ p <\> file     if isDir then do         let ignoredDirectories = ["dist", "dist-newstyle"]-            avoidDir x = let y = takeFileName x in "_" `isPrefixOf` y || ("." `isPrefixOf` y && not (all (== '.') y)) || y `elem` ignoredDirectories+            avoidDir x = let y = takeFileName x in "_" `isPrefixOf` y || ("." `isPrefixOf` y && not (all (== '.') y)) || y `elem` ignoredDirectories || ignore x             avoidFile x = let y = takeFileName x in "." `isPrefixOf` y || ignore x         xs <- listFilesInside (pure . not . avoidDir) $ p <\> file         pure [x | x <- xs, drop1 (takeExtension x) `elem` exts, not $ avoidFile x]
src/Config/Type.hs view
@@ -1,7 +1,7 @@  module Config.Type(     Severity(..), Classify(..), HintRule(..), Note(..), Setting(..),-    Restrict(..), RestrictType(..), SmellType(..),+    Restrict(..), RestrictType(..), RestrictIdents(..), SmellType(..),     defaultHintName, isUnifyVar, showNotes, getSeverity, getRestrictType, getSmellType     ) where @@ -106,13 +106,26 @@  data RestrictType = RestrictModule | RestrictExtension | RestrictFlag | RestrictFunction deriving (Show,Eq,Ord) +data RestrictIdents+    = NoRestrictIdents -- No restrictions on module imports+    | ForbidIdents [String] -- Forbid importing the given identifiers from this module+    | OnlyIdents [String] -- Forbid importing all identifiers from this module, except the given identifiers+    deriving Show++instance Semigroup RestrictIdents where+    NoRestrictIdents <> ri = ri+    ri <> NoRestrictIdents = ri+    ForbidIdents x1 <> ForbidIdents y1 = ForbidIdents $ x1 <> y1+    OnlyIdents x1 <> OnlyIdents x2 = OnlyIdents $ x1 <> x2+    ri1 <> ri2 = error $ "Incompatible restrictions: " ++ show (ri1, ri2)+ data Restrict = Restrict     {restrictType :: RestrictType     ,restrictDefault :: Bool     ,restrictName :: [String]     ,restrictAs :: [String] -- for RestrictModule only, what module names you can import it as     ,restrictWithin :: [(String, String)]-    ,restrictBadIdents :: [String]+    ,restrictIdents :: RestrictIdents -- for RestrictModule only, what identifiers can be imported from it     ,restrictMessage :: Maybe String     } deriving Show
src/Config/Yaml.hs view
@@ -292,14 +292,27 @@         Just def -> do             b <- parseBool def             allowFields v ["default"]-            pure $ Restrict restrictType b [] [] [] [] Nothing+            pure $ Restrict restrictType b [] [] [] NoRestrictIdents Nothing         Nothing -> do             restrictName <- parseFieldOpt "name" v >>= maybe (pure []) parseArrayString             restrictWithin <- parseFieldOpt "within" v >>= maybe (pure [("","")]) (parseArray >=> concatMapM parseWithin)             restrictAs <- parseFieldOpt "as" v >>= maybe (pure []) parseArrayString-            restrictBadIdents <- parseFieldOpt "badidents" v >>= maybe (pure []) parseArrayString++            restrictBadIdents <- parseFieldOpt "badidents" v+            restrictOnlyAllowedIdents <- parseFieldOpt "only" v+            restrictIdents <-+                case (restrictBadIdents, restrictOnlyAllowedIdents) of+                    (Just badIdents, Nothing) -> ForbidIdents <$> parseArrayString badIdents+                    (Nothing, Just onlyIdents) -> OnlyIdents <$> parseArrayString onlyIdents+                    (Nothing, Nothing) -> pure NoRestrictIdents+                    _ -> parseFail v "The following options are mutually exclusive: badidents, only"+             restrictMessage <- parseFieldOpt "message" v >>= maybeParse parseString-            allowFields v $ ["as" | restrictType == RestrictModule] ++ ["badidents", "name", "within", "message"]+            allowFields v $+                ["name", "within", "message"] +++                if restrictType == RestrictModule+                    then ["as", "badidents", "only"]+                    else []             pure Restrict{restrictDefault=True,..}  parseWithin :: Val -> Parser [(String, String)] -- (module, decl)
src/Extension.hs view
@@ -27,6 +27,7 @@   , NegativeLiterals -- Was not enabled by HSE and enabling breaks tests.   , StarIsType -- conflicts with TypeOperators. StarIsType is currently enabled by default,                -- so adding it here has no effect, but it may not be the case in future GHC releases.+  , MonadComprehensions -- Discussed in https://github.com/ndmitchell/hlint/issues/1261   ]  -- | Extensions we turn on by default when parsing. Aim to parse as
src/Hint/Extensions.hs view
@@ -95,6 +95,8 @@ deriving instance Show Bar -- {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-} \ newtype Micro = Micro Int deriving Generic -- {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveGeneric, TypeFamilies #-} \+data family Bar a; data instance Bar Foo = Foo deriving (Generic) {-# LANGUAGE GeneralizedNewtypeDeriving #-} \ instance Class Int where {newtype MyIO a = MyIO a deriving NewClass} {-# LANGUAGE UnboxedTuples #-} \@@ -510,8 +512,8 @@ derives :: Located HsModule -> Derives derives (L _ m) =  mconcat $ map decl (childrenBi m) ++ map idecl (childrenBi m)   where-    idecl :: Located (DataFamInstDecl GhcPs) -> Derives-    idecl (L _ (DataFamInstDecl (HsIB _ FamEqn {feqn_rhs=HsDataDefn {dd_ND=dn, dd_derivs=(L _ ds)}}))) = g dn ds+    idecl :: DataFamInstDecl GhcPs -> Derives+    idecl (DataFamInstDecl (HsIB _ FamEqn {feqn_rhs=HsDataDefn {dd_ND=dn, dd_derivs=(L _ ds)}})) = g dn ds      decl :: LHsDecl GhcPs -> Derives     decl (L _ (TyClD _ (DataDecl _ _ _ _ HsDataDefn {dd_ND=dn, dd_derivs=(L _ ds)}))) = g dn ds -- Data declaration.
src/Hint/Lambda.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE LambdaCase, PatternGuards, ViewPatterns #-}+{-# LANGUAGE LambdaCase, PatternGuards, TupleSections, ViewPatterns #-}  {-     Concept:@@ -32,6 +32,8 @@ fun x y z = f x x y z -- fun x = f x x fun x y z = f g z -- fun x y = f g fun x = f . g $ x -- fun = f . g+fun a b = f a b c where g x y = h x y -- g = h+fun a b = let g x y = h x y in f a b c -- g = h f = foo (\y -> g x . h $ y) -- g x . h f = foo (\y -> g x . h $ y) -- @Message Avoid lambda f = foo ((*) x) -- (x *)@@ -110,7 +112,7 @@ import Data.List.Extra import Data.Set (Set) import qualified Data.Set as Set-import Refact.Types hiding (RType(Match))+import Refact.Types hiding (Match) import Data.Generics.Uniplate.DataOnly (universe, universeBi, transformBi)  import GHC.Types.Basic@@ -129,14 +131,22 @@ lambdaHint :: DeclHint lambdaHint _ _ x     =  concatMap (uncurry lambdaExp) (universeParentBi x)-    ++ concatMap lambdaDecl (universe x)+    ++ concatMap (uncurry lambdaBind) binds+  where+    binds =+        ( case x of+            -- Turn a top-level HsBind under a ValD into an LHsBind.+            -- Also, its refact type needs to be Decl.+            L loc (ValD _ bind) -> ((L loc bind, Decl) :)+            _ -> id+        )+            ((,Bind) <$> universeBi x) -lambdaDecl :: LHsDecl GhcPs -> [Idea]-lambdaDecl-    o@(L _ (ValD _-        origBind@FunBind {fun_id = funName@(L loc1 _), fun_matches =-            MG {mg_alts =-                L _ [L _ (Match _ ctxt@(FunRhs _ Prefix _) pats (GRHSs _ [L _ (GRHS _ [] origBody@(L loc2 _))] bind))]}}))+lambdaBind :: LHsBind GhcPs -> RType -> [Idea]+lambdaBind+    o@(L _ origBind@FunBind {fun_id = funName@(L loc1 _), fun_matches =+        MG {mg_alts =+            L _ [L _ (Match _ ctxt@(FunRhs _ Prefix _) pats (GRHSs _ [L _ (GRHS _ [] origBody@(L loc2 _))] bind))]}}) rtype     | L _ (EmptyLocalBinds _) <- bind     , isLambda $ fromParen origBody     , null (universeBi pats :: [HsExpr GhcPs])@@ -147,14 +157,14 @@           refacts = case newBody of               -- https://github.com/alanz/ghc-exactprint/issues/97               L _ HsCase{} -> []-              _ -> [Replace Decl (toSS o) sub tpl]+              _ -> [Replace rtype (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     = let (sub, tpl) = mkSubtsAndTpl newPats newBody        in [warn "Eta reduce" (reform pats origBody) (reform newPats newBody)-            [Replace Decl (toSS $ reform pats origBody) sub tpl]+            [Replace rtype (toSS $ reform pats origBody) sub tpl]           ]     where reform :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs           reform ps b = L (combineSrcSpans loc1 loc2) $ ValD noExtField $@@ -167,8 +177,7 @@               sub = ("body", toSS newBody) : zip vars (map toSS newPats)               tpl = unsafePrettyPrint (reform origPats varBody) -lambdaDecl _ = []-+lambdaBind _ _ = []  etaReduce :: [LPat GhcPs] -> LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs) etaReduce (unsnoc -> Just (ps, view -> PVar_ p)) (L _ (HsApp _ x (view -> Var_ y)))
src/Hint/Restrict.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-}@@ -67,7 +66,7 @@ data RestrictItem = RestrictItem     {riAs :: [String]     ,riWithin :: [(String, String)]-    ,riBadIdents :: [String]+    ,riRestrictIdents :: RestrictIdents     ,riMessage :: Maybe String     } @@ -98,7 +97,7 @@          rOthers = Map.map f $ Map.fromListWith (++) (map (second pure) ros)         f rs = (all restrictDefault rs-               ,Map.fromListWith (<>) [(s, RestrictItem restrictAs restrictWithin restrictBadIdents restrictMessage) | Restrict{..} <- rs, s <- restrictName])+               ,Map.fromListWith (<>) [(s, RestrictItem restrictAs restrictWithin restrictIdents restrictMessage) | Restrict{..} <- rs, s <- restrictName])  ideaMessage :: Maybe String -> Idea -> Idea ideaMessage (Just message) w = w{ideaNote=[Note message]}@@ -135,24 +134,36 @@    isGood def mp x = maybe def (within modu "" . riWithin) $ Map.lookup x mp  checkImports :: String -> [LImportDecl GhcPs] -> (Bool, Map.Map String RestrictItem) -> [Idea]-checkImports modu imp (def, mp) =-    [ ideaMessage riMessage-      $ if | not allowImport -> ideaNoTo $ warn "Avoid restricted module" i i []-           | not allowIdent  -> ideaNoTo $ warn "Avoid restricted identifiers" i i []-           | 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{..} = getRestrictItem def ideclName mp-    , let allowImport = within modu "" riWithin-    , let allowIdent = Set.disjoint-                       (Set.fromList riBadIdents)-                       (Set.fromList (maybe [] (\(b, lxs) -> if b then [] else concatMap (importListToIdents . unLoc) (unLoc lxs)) ideclHiding))-    , let allowQual = maybe True (\x -> null riAs || moduleNameString (unLoc x) `elem` riAs) ideclAs-    , not allowImport || not allowQual || not allowIdent-    ]+checkImports modu lImportDecls (def, mp) = mapMaybe getImportHint lImportDecls+  where+    getImportHint :: LImportDecl GhcPs -> Maybe Idea+    getImportHint i@(L _ ImportDecl{..}) = do+      let RestrictItem{..} = getRestrictItem def ideclName mp+      either (Just . ideaMessage riMessage) (const Nothing) $ do+        unless (within modu "" riWithin) $+          Left $ ideaNoTo $ warn "Avoid restricted module" i i [] +        let importedIdents = Set.fromList $+              case ideclHiding of+                Just (False, lxs) -> concatMap (importListToIdents . unLoc) (unLoc lxs)+                _ -> []+            invalidIdents = case riRestrictIdents of+              NoRestrictIdents -> Set.empty+              ForbidIdents badIdents -> importedIdents `Set.intersection` Set.fromList badIdents+              OnlyIdents onlyIdents -> importedIdents `Set.difference` Set.fromList onlyIdents+        unless (Set.null invalidIdents) $+          Left $ ideaNoTo $ warn "Avoid restricted identifiers" i i []++        let qualAllowed = case (riAs, ideclAs) of+              ([], _) -> True+              (_, Nothing) -> True+              (_, Just (L _ modName)) -> moduleNameString modName `elem` riAs+        unless qualAllowed $ do+          let i' = noLoc $ (unLoc i){ ideclAs = noLoc . mkModuleName <$> listToMaybe riAs }+          Left $ warn "Avoid restricted qualification" i i' []+ getRestrictItem :: Bool -> Located ModuleName -> Map.Map String RestrictItem -> RestrictItem-getRestrictItem def ideclName = fromMaybe (RestrictItem [] [("","") | def] [] Nothing) . lookupRestrictItem ideclName+getRestrictItem def ideclName = fromMaybe (RestrictItem [] [("","") | def] NoRestrictIdents Nothing) . lookupRestrictItem ideclName  lookupRestrictItem :: Located ModuleName -> Map.Map String RestrictItem -> Maybe RestrictItem lookupRestrictItem ideclName mp =
tests/hint.test view
@@ -100,6 +100,82 @@ 1 hint  ---------------------------------------------------------------------+RUN tests/restricted-badidents-bad.lhs --hint=data/test-restrict.yaml+FILE tests/restricted-badidents-bad.lhs+> import Restricted.Module.BadIdents (bad)+OUTPUT+tests/restricted-badidents-bad.lhs:1:3-42: Warning: Avoid restricted identifiers+Found:+  import Restricted.Module.BadIdents ( bad )+Note: may break the code++1 hint++---------------------------------------------------------------------+RUN tests/restricted-badidents-multibad.lhs --hint=data/test-restrict.yaml+FILE tests/restricted-badidents-multibad.lhs+> import Restricted.Module.BadIdents (bad, good)+OUTPUT+tests/restricted-badidents-multibad.lhs:1:3-48: Warning: Avoid restricted identifiers+Found:+  import Restricted.Module.BadIdents ( bad, good )+Note: may break the code++1 hint++---------------------------------------------------------------------+RUN tests/restricted-badidents-valid.lhs --hint=data/test-restrict.yaml+FILE tests/restricted-badidents-valid.lhs+> import Restricted.Module.BadIdents (good)+OUTPUT+No hints++---------------------------------------------------------------------+RUN tests/restricted-badidents-universal.lhs --hint=data/test-restrict.yaml+FILE tests/restricted-badidents-universal.lhs+> import Restricted.Module.BadIdents+OUTPUT+No hints++---------------------------------------------------------------------+RUN tests/restricted-onlyidents-bad.lhs --hint=data/test-restrict.yaml+FILE tests/restricted-onlyidents-bad.lhs+> import Restricted.Module.OnlyIdents (bad)+OUTPUT+tests/restricted-onlyidents-bad.lhs:1:3-43: Warning: Avoid restricted identifiers+Found:+  import Restricted.Module.OnlyIdents ( bad )+Note: may break the code++1 hint++---------------------------------------------------------------------+RUN tests/restricted-onlyidents-multibad.lhs --hint=data/test-restrict.yaml+FILE tests/restricted-onlyidents-multibad.lhs+> import Restricted.Module.OnlyIdents (bad, good)+OUTPUT+tests/restricted-onlyidents-multibad.lhs:1:3-49: Warning: Avoid restricted identifiers+Found:+  import Restricted.Module.OnlyIdents ( bad, good )+Note: may break the code++1 hint++---------------------------------------------------------------------+RUN tests/restricted-onlyidents-valid.lhs --hint=data/test-restrict.yaml+FILE tests/restricted-onlyidents-valid.lhs+> import Restricted.Module.OnlyIdents (good)+OUTPUT+No hints++---------------------------------------------------------------------+RUN tests/restricted-onlyidents-universal.lhs --hint=data/test-restrict.yaml+FILE tests/restricted-onlyidents-universal.lhs+> import Restricted.Module.OnlyIdents+OUTPUT+No hints++--------------------------------------------------------------------- RUN tests/restricted-function.lhs --hint=data/test-restrict.yaml FILE tests/restricted-function.lhs > main = restricted ()