packages feed

hlint 2.2.8 → 2.2.9

raw patch · 23 files changed

+202/−170 lines, 23 filesdep ~ghc-lib-parser-exPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: ghc-lib-parser-ex

API changes (from Hackage documentation)

Files

CHANGES.txt view
@@ -1,5 +1,13 @@ Changelog for HLint (* = breaking change) +2.2.9, released 2020-01-27+    Add any/map and all/map fusion hints+    #837, don't warn about redundant do for BlockArguments+    #842, fix parsing of <% operators in hlint.yaml files+    #839, match hints inside instances+    #833, UnboxedTuples can be necessary from newtype deriving+    #817, add the ability to blacklist identifiers from a module+    #834, move not out of any and all 2.2.8, released 2020-01-22     #802, suggest lambda instead of lambda-case for single alts     #811, add some foldMap/map hints
README.md view
@@ -325,9 +325,10 @@ - modules:   - {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"} ``` -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.+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).  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
@@ -154,6 +154,8 @@     - warn: {lhs: concatMap id, rhs: concat}     - warn: {lhs: or (map p x), rhs: any p x}     - warn: {lhs: and (map p x), rhs: all p x}+    - warn: {lhs: any f (map g x), rhs: any (f . g) x}+    - warn: {lhs: all f (map g x), rhs: all (f . g) x}     - warn: {lhs: "zipWith (,)", rhs: zip}     - warn: {lhs: "zipWith3 (,,)", rhs: zip3}     - hint: {lhs: length x == 0, rhs: null x, note: IncreasesLaziness}@@ -181,6 +183,8 @@     - warn: {lhs: "filter f x /= []", rhs: any f x}     - warn: {lhs: any id, rhs: or}     - warn: {lhs: all id, rhs: and}+    - warn: {lhs: any (not . f) x, rhs: not (all f x), name: Hoist not}+    - warn: {lhs: all (not . f) x, rhs: not (any f x), name: Hoist not}     - warn: {lhs: any ((==) a), rhs: elem a, note: ValidInstance Eq a}     - warn: {lhs: any (== a), rhs: elem a}     - warn: {lhs: any (a ==), rhs: elem a, note: ValidInstance Eq a}@@ -986,6 +990,7 @@ # no = sequenceA (pure a) # {-# LANGUAGE QuasiQuotes #-}; no = f (\url -> [hamlet|foo @{url}|]) # yes = f ((,) x) -- (x,)+# instance Class X where method = map f (map g x) -- map (f . g) x  # import Prelude \ # yes = flip mapM -- Control.Monad.forM
hlint.cabal view
@@ -1,7 +1,7 @@ cabal-version:      >= 1.18 build-type:         Simple name:               hlint-version:            2.2.8+version:            2.2.9 license:            BSD3 license-file:       LICENSE category:           Development@@ -68,7 +68,7 @@         refact >= 0.3,         aeson >= 1.1.2.0,         filepattern >= 0.1.1,-        ghc-lib-parser-ex == 8.8.2+        ghc-lib-parser-ex == 8.8.3.*     if !flag(ghc-lib) && impl(ghc >= 8.8.0) && impl(ghc < 8.9.0)         build-depends:           ghc == 8.8.*,@@ -121,7 +121,7 @@         GHC.Util.Module         GHC.Util.Outputable         GHC.Util.SrcLoc-        GHC.Util.W+        GHC.Util.HsExtendInstances         GHC.Util.DynFlags         GHC.Util.RdrName         GHC.Util.Scope
src/Config/Haskell.hs view
@@ -55,7 +55,7 @@         [SettingMatchExp $          HintRule severity (head $ snoc names defaultHintName) s (fromParen lhs) (fromParen rhs) a b         -- Todo : Replace these with "proper" GHC expressions.-         (wrap mempty) (wrap unit) (wrap unit) Nothing]+         (extendInstances' mempty) (extendInstances' unit) (extendInstances' unit) Nothing]     | otherwise = [SettingClassify $ Classify severity n a b | n <- names2, (a,b) <- readFuncs bod]     where         names = filter (not . null) $ getNames pats bod
src/Config/Type.hs view
@@ -98,11 +98,11 @@     ,hintRuleRHS :: Exp SrcSpanInfo -- ^ RHS     ,hintRuleSide :: Maybe (Exp SrcSpanInfo) -- ^ Side condition, typically specified with @where _ = ...@.     ,hintRuleNotes :: [Note] -- ^ Notes about application of the hint.-    -- We wrap these GHC elements in 'W' in order that we may derive 'Show'.-    ,hintRuleGhcScope :: W Scope' -- ^ Module scope in which the hint operates (GHC parse tree).-    ,hintRuleGhcLHS :: W (HsSyn.LHsExpr HsSyn.GhcPs) -- ^ LHS (GHC parse tree).-    ,hintRuleGhcRHS :: W (HsSyn.LHsExpr HsSyn.GhcPs) -- ^ RHS (GHC parse tree).-    ,hintRuleGhcSide :: Maybe (W (HsSyn.LHsExpr HsSyn.GhcPs))  -- ^ Side condition (GHC parse tree).+    -- We wrap these GHC elements in 'HsExtendInstances' in order that we may derive 'Show'.+    ,hintRuleGhcScope :: HsExtendInstances Scope' -- ^ Module scope in which the hint operates (GHC parse tree).+    ,hintRuleGhcLHS :: HsExtendInstances (HsSyn.LHsExpr HsSyn.GhcPs) -- ^ LHS (GHC parse tree).+    ,hintRuleGhcRHS :: HsExtendInstances (HsSyn.LHsExpr HsSyn.GhcPs) -- ^ RHS (GHC parse tree).+    ,hintRuleGhcSide :: Maybe (HsExtendInstances (HsSyn.LHsExpr HsSyn.GhcPs))  -- ^ Side condition (GHC parse tree).     }     deriving Show @@ -114,6 +114,7 @@     ,restrictName :: [String]     ,restrictAs :: [String] -- for RestrictModule only, what module names you can import it as     ,restrictWithin :: [(String, String)]+    ,restrictBadIdents :: [String]     ,restrictMessage :: Maybe String     } deriving Show
src/Config/Yaml.hs view
@@ -30,7 +30,7 @@ import qualified Outputable import qualified HsSyn import GHC.Util (baseDynFlags, Scope',scopeCreate')-import GHC.Util.W+import GHC.Util.HsExtendInstances  -- | 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@@ -58,14 +58,14 @@ data Package = Package     {packageName :: String     ,packageModules :: [ImportDecl S]-    ,packageGhcModules :: [W (HsSyn.LImportDecl HsSyn.GhcPs)]+    ,packageGhcModules :: [HsExtendInstances (HsSyn.LImportDecl HsSyn.GhcPs)]     } deriving Show  data Group = Group     {groupName :: String     ,groupEnabled :: Bool     ,groupImports :: [Either String (ImportDecl S)] -- Left for package imports-    ,groupGhcImports :: [Either String (W (HsSyn.LImportDecl HsSyn.GhcPs))]+    ,groupGhcImports :: [Either String (HsExtendInstances (HsSyn.LImportDecl HsSyn.GhcPs))]     ,groupRules :: [Either HintRule Classify] -- HintRule has scope set to mempty     } deriving Show @@ -198,7 +198,7 @@ parsePackage v = do     packageName <- parseField "name" v >>= parseString     packageModules <- parseField "modules" v >>= parseArray >>= mapM (parseHSE parseImportDeclWithMode)-    packageGhcModules <- parseField "modules" v >>= parseArray >>= mapM (fmap wrap <$> parseGHC parseImportDeclGhcWithMode)+    packageGhcModules <- parseField "modules" v >>= parseArray >>= mapM (fmap extendInstances' <$> parseGHC parseImportDeclGhcWithMode)     allowFields v ["name","modules"]     return Package{..} @@ -238,7 +238,7 @@             x <- parseString v             case word1 x of                  ("package", x) -> return $ Left x-                 _ -> Right . wrap <$> parseGHC parseImportDeclGhcWithMode v+                 _ -> Right . extendInstances' <$> parseGHC parseImportDeclGhcWithMode v  ruleToGroup :: [Either HintRule Classify] -> Group ruleToGroup = Group "" True [] []@@ -254,13 +254,13 @@         hintRuleName <- parseFieldOpt "name" v >>= maybe (return $ guessName hintRuleLHS hintRuleRHS) parseString         hintRuleSide <- parseFieldOpt "side" v >>= maybe (return Nothing) (fmap Just . parseHSE parseExpWithMode) -        hintRuleGhcLHS <- parseField "lhs" v >>= fmap wrap . parseGHC parseExpGhcWithMode-        hintRuleGhcRHS <- parseField "rhs" v >>= fmap wrap . parseGHC parseExpGhcWithMode-        hintRuleGhcSide <- parseFieldOpt "side" v >>= maybe (return Nothing) (fmap (Just . wrap) . parseGHC parseExpGhcWithMode)+        hintRuleGhcLHS <- parseField "lhs" v >>= fmap extendInstances' . parseGHC parseExpGhcWithMode+        hintRuleGhcRHS <- parseField "rhs" v >>= fmap extendInstances' . parseGHC parseExpGhcWithMode+        hintRuleGhcSide <- parseFieldOpt "side" v >>= maybe (return Nothing) (fmap (Just . extendInstances') . parseGHC parseExpGhcWithMode)          allowFields v ["lhs","rhs","note","name","side"]         let hintRuleScope = mempty :: Scope-        let hintRuleGhcScope = wrap mempty :: W Scope'+        let hintRuleGhcScope = extendInstances' mempty :: HsExtendInstances Scope'         return [Left HintRule{hintRuleSeverity=severity, ..}]      else do         names <- parseFieldOpt "name" v >>= maybe (return []) parseArrayString@@ -274,13 +274,14 @@         Just def -> do             b <- parseBool def             allowFields v ["default"]-            return $ Restrict restrictType b [] [] [] Nothing+            return $ Restrict restrictType b [] [] [] [] Nothing         Nothing -> do             restrictName <- parseFieldOpt "name" v >>= maybe (return []) parseArrayString             restrictWithin <- parseFieldOpt "within" v >>= maybe (return [("","")]) (parseArray >=> concatMapM parseWithin)             restrictAs <- parseFieldOpt "as" v >>= maybe (return []) parseArrayString+            restrictBadIdents <- parseFieldOpt "badidents" v >>= maybe (pure []) parseArrayString             restrictMessage <- parseFieldOpt "message" v >>= maybeParse parseString-            allowFields v $ ["as" | restrictType == RestrictModule] ++ ["name","within", "message"]+            allowFields v $ ["as" | restrictType == RestrictModule] ++ ["badidents", "name", "within", "message"]             return Restrict{restrictDefault=True,..}  parseWithin :: Val -> Parser [(String, String)] -- (module, decl)@@ -330,7 +331,7 @@         groups = [x | ConfigGroup x <- configs]         settings = concat [x | ConfigSetting x <- configs]         packageMap = Map.fromListWith (++) [(packageName, packageModules) | Package{..} <- packages]-        packageMap' = Map.fromListWith (++) [(packageName, fmap unwrap packageGhcModules) | Package{..} <- packages]+        packageMap' = Map.fromListWith (++) [(packageName, fmap unExtendInstances' packageGhcModules) | Package{..} <- packages]         groupMap = Map.fromListWith (\new old -> new) [(groupName, groupEnabled) | Group{..} <- groups]          f Group{..}@@ -338,7 +339,7 @@             | otherwise = map (either (\r -> SettingMatchExp r{hintRuleScope=scope,hintRuleGhcScope=scope'}) SettingClassify) groupRules             where               scope = asScope packageMap groupImports-              scope'= asScope' packageMap' (map (fmap unwrap) groupGhcImports)+              scope'= asScope' packageMap' (map (fmap unExtendInstances') groupGhcImports)  asScope :: Map.HashMap String [ImportDecl S] -> [Either String (ImportDecl S)] -> Scope asScope packages xs = scopeCreate $ Module an Nothing [] (concatMap f xs) []@@ -347,8 +348,8 @@         f (Left x) | Just pkg <- Map.lookup x packages = pkg                    | otherwise = error $ "asScope failed to do lookup, " ++ x -asScope' :: Map.HashMap String [HsSyn.LImportDecl HsSyn.GhcPs] -> [Either String (HsSyn.LImportDecl HsSyn.GhcPs)] -> W Scope'-asScope' packages xs = W $ scopeCreate' (HsSyn.HsModule Nothing Nothing (concatMap f xs) [] Nothing Nothing)+asScope' :: Map.HashMap String [HsSyn.LImportDecl HsSyn.GhcPs] -> [Either String (HsSyn.LImportDecl HsSyn.GhcPs)] -> HsExtendInstances Scope'+asScope' packages xs = HsExtendInstances $ scopeCreate' (HsSyn.HsModule Nothing Nothing (concatMap f xs) [] Nothing Nothing)     where         f (Right x) = [x]         f (Left x) | Just pkg <- Map.lookup x packages = pkg
src/GHC/Util.hs view
@@ -11,13 +11,14 @@   , module GHC.Util.Module   , module GHC.Util.Outputable   , module GHC.Util.SrcLoc-  , module GHC.Util.W+  , module GHC.Util.HsExtendInstances   , module GHC.Util.DynFlags   , module GHC.Util.Scope   , module GHC.Util.RdrName   , module GHC.Util.Unify -  , parsePragmasIntoDynFlags, parseFileGhcLib, parseExpGhcLib, parseImportGhcLib+  , parsePragmasIntoDynFlags+  , parseFileGhcLib, parseExpGhcLib, parseImportGhcLib   ) where  import GHC.Util.View@@ -31,56 +32,30 @@ import GHC.Util.Module import GHC.Util.Outputable import GHC.Util.SrcLoc-import GHC.Util.W+import GHC.Util.HsExtendInstances import GHC.Util.DynFlags import GHC.Util.RdrName import GHC.Util.Scope import GHC.Util.Unify  import qualified Language.Haskell.GhclibParserEx.Parse as GhclibParserEx+import Language.Haskell.GhclibParserEx.DynFlags (parsePragmasIntoDynFlags)  import HsSyn import Lexer-import Parser import SrcLoc-import FastString-import StringBuffer-import GHC.LanguageExtensions.Type import DynFlags -import Data.List.Extra import System.FilePath import Language.Preprocessor.Unlit  parseExpGhcLib :: String -> DynFlags -> ParseResult (LHsExpr GhcPs)-parseExpGhcLib = GhclibParserEx.parseExpr+parseExpGhcLib = GhclibParserEx.parseExpression  parseImportGhcLib :: String -> DynFlags -> ParseResult (LImportDecl GhcPs) parseImportGhcLib = GhclibParserEx.parseImport --- TODO(SF): GhclibParserEx.parseFile doesn't take 'unlit' into--- consideration yet. parseFileGhcLib :: FilePath -> String -> DynFlags -> ParseResult (Located (HsModule GhcPs)) parseFileGhcLib filename str flags =-  Lexer.unP Parser.parseModule parseState-  where-    location = mkRealSrcLoc (mkFastString filename) 1 1-    buffer = stringToStringBuffer $-              if takeExtension filename /= ".lhs" then str else unlit filename str-    parseState = mkPState flags buffer location---- TODO(SF): GhclibParserEx.parsePragmasIntoDynFlags doesn't take--- enabled/disabled extensions into consideration yet.-parsePragmasIntoDynFlags :: DynFlags-                         -> ([Extension], [Extension])-                         -> FilePath-                         -> String-                         -> IO (Either String DynFlags)-parsePragmasIntoDynFlags flags (enable, disable) filepath str = do-   flags <- GhclibParserEx.parsePragmasIntoDynFlags flags filepath str-   case flags of-     Right flags -> do-       let flags' =  foldl' xopt_set flags enable-       let flags'' = foldl' xopt_unset flags' disable-       return $ Right flags''-     err -> return err+  GhclibParserEx.parseFile filename flags+    (if takeExtension filename /= ".lhs" then str else unlit filename str)
src/GHC/Util/DynFlags.hs view
@@ -3,7 +3,7 @@ import DynFlags import GHC.LanguageExtensions.Type import Data.List.Extra-import Language.Haskell.GhclibParserEx.Parse+import Language.Haskell.GhclibParserEx.Config  baseDynFlags :: DynFlags baseDynFlags =
src/GHC/Util/HsDecl.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE NamedFieldPuns #-} -module GHC.Util.HsDecl (declName,isForD',isNewType',isDerivD',isClsDefSig')+module GHC.Util.HsDecl (declName,bindName,isForD',isNewType',isDerivD',isClsDefSig') where  import HsSyn@@ -37,6 +37,12 @@     ForD _ ForeignExport{fd_name} -> Just $ unLoc fd_name     _ -> Nothing declName _ = Nothing {- COMPLETE LL-}+++bindName :: LHsBind GhcPs -> Maybe String+bindName (LL _ FunBind{fun_id}) = Just $ occNameString $ occName $ unLoc fun_id+bindName (LL _ VarBind{var_id}) = Just $ occNameString $ occName var_id+bindName _ = Nothing  isClsDefSig' :: Sig GhcPs -> Bool isClsDefSig' (ClassOpSig _ True _ _) = True; isClsDefSig' _ = False
src/GHC/Util/HsExpr.hs view
@@ -35,7 +35,7 @@ import GHC.Util.Brackets import GHC.Util.View import GHC.Util.FreeVars-import GHC.Util.W+import GHC.Util.HsExtendInstances import GHC.Util.Pat  import Control.Applicative@@ -238,10 +238,10 @@     factor y@(LL _ (HsApp _ ini lst)) | view' lst == Var_' x = Just (ini, [ini])     factor y@(LL _ (HsApp _ ini lst)) | Just (z, ss) <- factor lst       = let r = niceDotApp' ini z-        in if eqLoc' r z then Just (r, ss) else Just (r, ini : ss)+        in if astEq' r z then Just (r, ss) else Just (r, ini : ss)     factor (LL _ (OpApp _ y op (factor -> Just (z, ss))))| isDol' op       = let r = niceDotApp' y z-        in if eqLoc' r z then Just (r, ss) else Just (r, y : ss)+        in if astEq' r z then Just (r, ss) else Just (r, y : ss)     factor (LL _ (HsPar _ y@(LL _ HsApp{}))) = factor y     factor _ = Nothing -- Rewrite '\x y -> x + y' as '(+)'.@@ -321,7 +321,7 @@ reduce1' (LL loc (HsApp _ len (LL _ (ExplicitList _ _ xs))))   | varToStr' len == "length" = cL loc $ HsLit noExt (HsInt noExt (IL NoSourceText False n))   where n = fromIntegral $ length xs-reduce1' (view' -> App2' op (LL _ (HsLit _ x)) (LL _ (HsLit _ y))) | varToStr' op == "==" = strToVar' (show (eqLoc' x y))+reduce1' (view' -> App2' op (LL _ (HsLit _ x)) (LL _ (HsLit _ y))) | varToStr' op == "==" = strToVar' (show (astEq' x y)) reduce1' (view' -> App2' op (LL _ (HsLit _ (HsInt _ x))) (LL _ (HsLit _ (HsInt _ y)))) | varToStr' op == ">=" = strToVar' $ show (x >= y) reduce1' (view' -> App2' op x y)     | varToStr' op == "&&" && varToStr' x == "True"  = y
+ src/GHC/Util/HsExtendInstances.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module GHC.Util.HsExtendInstances (+    HsExtendInstances(..)+  , extendInstances', unExtendInstances'+  , astEq', astListEq') where++import Outputable+import Data.Function++newtype HsExtendInstances a =+  HsExtendInstances a deriving Outputable -- Wrapper of terms.+-- The issue is that at times, terms we work with in this program are+-- not in `Eq` and `Ord` and we need them to be. This work-around+-- resorts to implementing `Eq` and `Ord` for the these types via+-- lexicographical comparisons of string representations. As long as+-- two different terms never map to the same string representation,+-- basing `Eq` and `Ord` on their string representations rather than+-- the term types themselves, leads to identical results.+toStr :: Outputable a => HsExtendInstances a -> String+toStr (HsExtendInstances e) = Outputable.showSDocUnsafe $ Outputable.ppr e+instance Outputable a => Eq (HsExtendInstances a) where (==) a b = toStr a == toStr b+instance Outputable a => Ord (HsExtendInstances a) where compare = compare `on` toStr+instance Outputable a => Show (HsExtendInstances a) where show = toStr++extendInstances' :: a -> HsExtendInstances a+extendInstances' = HsExtendInstances++unExtendInstances' :: HsExtendInstances a -> a+unExtendInstances' (HsExtendInstances x) = x++astEq' :: Outputable a => a -> a -> Bool+astEq' a b = extendInstances' a == extendInstances' b++astListEq' :: Outputable a => [a] -> [a] -> Bool+astListEq' as bs = length as == length bs && all (uncurry astEq') (zip as bs)
src/GHC/Util/Scope.hs view
@@ -19,6 +19,7 @@ import Outputable  import Data.List+import Data.List.Extra import Data.Maybe  -- A scope is a list of import declarations.@@ -66,10 +67,10 @@ -- scope that will refer to the same thing. If the resulting name is -- ambiguous, pick a plausible candidate. scopeMove' :: (Scope', Located RdrName) -> Scope' -> Located RdrName-scopeMove' (a, x@(fromQual' -> Just name)) (Scope' b)-  | null imps = head $ real ++ [x]-  | any (not . ideclQualified) imps = unqual' x-  | otherwise = noLoc $ mkRdrQual (unLoc $ head (mapMaybe ideclAs imps ++ map ideclName imps)) name+scopeMove' (a, x@(fromQual' -> Just name)) (Scope' b) = case imps of+  [] -> head $ real ++ [x]+  imp:_ | all ideclQualified imps -> noLoc $ mkRdrQual (unLoc . fromMaybe (ideclName imp) $ firstJust ideclAs imps) name+        | otherwise -> unqual' x   where     real :: [Located RdrName]     real = [noLoc $ mkRdrQual (mkModuleName m) name | m <- possModules' a x]
− src/GHC/Util/W.hs 
@@ -1,47 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module GHC.Util.W (-    W(..)-  , wrap, unwrap-  , eqLoc', eqNoLoc', eqNoLocLists') where--import Outputable-import SrcLoc--import GHC.Util.DynFlags-import GHC.Util.SrcLoc--import Data.Function-import Data.Data-import Data.Generics.Uniplate.Data ()--newtype W a = W a deriving Outputable -- Wrapper of terms.--- The issue is that at times, terms we work with in this program are--- not in `Eq` and `Ord` and we need them to be. This work-around--- resorts to implementing `Eq` and `Ord` for the these types via--- lexicographical comparisons of string representations. As long as--- two different terms never map to the same string representation,--- basing `Eq` and `Ord` on their string representations rather than--- the term types themselves, leads to identical results.-wToStr :: Outputable a => W a -> String-wToStr (W e) = showPpr baseDynFlags e-instance Outputable a => Eq (W a) where (==) a b = wToStr a == wToStr b-instance Outputable a => Ord (W a) where compare = compare `on` wToStr-instance Outputable a => Show (W a) where show = wToStr--wrap :: a -> W a-wrap = W--unwrap :: W a -> a-unwrap (W x) = x---- Compare two terms for absolute equality.-eqLoc' :: Outputable a => a -> a -> Bool-eqLoc' a b = wrap a == wrap b---- Compare two terms for equality modulo locs.-eqNoLoc' :: (Data a, Outputable a, HasSrcSpan a) => a -> a -> Bool-eqNoLoc' a b = wrap (stripLocs' a)  == wrap (stripLocs' b)--eqNoLocLists' :: (Data a, Outputable a, HasSrcSpan a) => [a] -> [a] -> Bool-eqNoLocLists' as bs = length as == length bs && all (uncurry eqNoLoc') (zip as bs)
src/Grep.hs view
@@ -27,7 +27,7 @@     let unit = GHC.noLoc $ GHC.ExplicitTuple GHC.noExt [] GHC.Boxed     let rule = hintRules [HintRule Suggestion "grep" scope exp (Tuple an Boxed []) Nothing []                          -- Todo : Replace these with "proper" GHC expressions.-                          (wrap mempty) (wrap unit) (wrap unit) Nothing]+                          (extendInstances' mempty) (extendInstances' unit) (extendInstances' unit) Nothing]     forM_ files $ \file -> do         res <- parseModuleEx flags file Nothing         case res of
src/Hint/Duplicate.hs view
@@ -67,7 +67,7 @@     | ((m1, d1, SrcSpanD p1), (m2, d2, SrcSpanD p2), xs) <- duplicateOrdered 3 $ map f ys]     where       f (m, d, xs) =-        [((m, d, SrcSpanD (getLoc x)), wrap (stripLocs' x)) | x <- xs]+        [((m, d, SrcSpanD (getLoc x)), extendInstances' (stripLocs' x)) | x <- xs]  --------------------------------------------------------------------- -- DUPLICATE FINDING
src/Hint/Extensions.hs view
@@ -76,6 +76,8 @@ f :: x -> (x, x); f x = (x, x) -- {-# LANGUAGE UnboxedTuples #-} \ f x = case x of (# a, b #) -> a+{-# LANGUAGE GeneralizedNewtypeDeriving,UnboxedTuples #-} \+newtype T m a = T (m a) deriving (PrimMonad) {-# LANGUAGE DefaultSignatures #-} \ class Val a where; val :: a -- {-# LANGUAGE DefaultSignatures #-} \@@ -285,7 +287,13 @@ used RecordWildCards = hasS hasFieldsDotDot' ||^ hasS hasPFieldsDotDot' used RecordPuns = hasS isPFieldPun' ||^ hasS isFieldPun' used NamedFieldPuns = hasS isPFieldPun' ||^ hasS isFieldPun'-used UnboxedTuples = has isUnboxedTuple' ||^ has (== Unboxed)+used UnboxedTuples = has isUnboxedTuple' ||^ has (== Unboxed) ||^ hasS isDeriving+    where+        -- detect if there are deriving declarations or data ... deriving stuff+        -- by looking for the deriving strategy both contain (even if its Nothing)+        -- see https://github.com/ndmitchell/hlint/issues/833 for why we care+        isDeriving :: Maybe (LDerivStrategy GhcPs) -> Bool+        isDeriving _ = True used PackageImports = hasS f     where         f :: ImportDecl GhcPs -> Bool
src/Hint/List.hs view
@@ -94,7 +94,7 @@     list_comp_aux e xs       | "False" `elem` cons =  [suggest' "Short-circuited list comprehension" o o' (suggestExpr o o')]       | "True" `elem` cons = [suggest' "Redundant True guards" o o2 (suggestExpr o o2)]-      | not (eqNoLocLists' xs ys) = [suggest' "Move guards forward" o o3 (suggestExpr o o3)]+      | not (astListEq' xs ys) = [suggest' "Move guards forward" o o3 (suggestExpr o o3)]       | otherwise = []       where         ys = moveGuardsForward xs@@ -258,6 +258,6 @@     g :: LHsType GhcPs -> [Idea]     g e@(fromTyParen' -> x) = [suggest' "Use String" x (transform f x)                               rs | not . null $ rs]-      where f x = if eqNoLoc' x typeListChar then typeString else x-            rs = [Replace Type (toSS' t) [] (unsafePrettyPrint typeString) | t <- universe x, eqNoLoc' t typeListChar]+      where f x = if astEq' x typeListChar then typeString else x+            rs = [Replace Type (toSS' t) [] (unsafePrettyPrint typeString) | t <- universe x, astEq' t typeListChar] stringType _ = [] -- {-# COMPLETE LL #-}
src/Hint/ListRec.hs view
@@ -98,25 +98,25 @@ matchListRec o@(ListCase vs nil (x, xs, cons))     -- Suggest 'map'?     | [] <- vs, varToStr' nil == "[]", (LL _ (OpApp _ lhs c rhs)) <- cons, varToStr' c == ":"-    , eqNoLoc' (fromParen' rhs) recursive, xs `notElem` vars' lhs+    , astEq' (fromParen' rhs) recursive, xs `notElem` vars' lhs     = Just $ (,,) "map" Hint.Type.Warning $       appsBracket' [ strToVar' "map", niceLambda' [x] lhs, strToVar' xs]     -- Suggest 'foldr'?     | [] <- vs, App2' op lhs rhs <- view' cons     , xs `notElem` (vars' op ++ vars' lhs) -- the meaning of xs changes, see #793-    , eqNoLoc' (fromParen' rhs) recursive+    , astEq' (fromParen' rhs) recursive     = Just $ (,,) "foldr" Suggestion $       appsBracket' [ strToVar' "foldr", niceLambda' [x] $ appsBracket' [op,lhs], nil, strToVar' xs]     -- Suggest 'foldl'?     | [v] <- vs, view' nil == Var_' v, (LL _ (HsApp _ r lhs)) <- cons-    , eqNoLoc' (fromParen' r) recursive+    , astEq' (fromParen' r) recursive     , xs `notElem` vars' lhs     = Just $ (,,) "foldl" Suggestion $       appsBracket' [ strToVar' "foldl", niceLambda' [v,x] lhs, strToVar' v, strToVar' xs]     -- Suggest 'foldM'?     | [v] <- vs, (LL _ (HsApp _ ret res)) <- nil, isReturn' ret, varToStr' res == "()" || view' res == Var_' v     , [LL _ (BindStmt _ (view' -> PVar_' b1) e _ _), LL _ (BodyStmt _ (fromParen' -> (LL _ (HsApp _ r (view' -> Var_' b2)))) _ _)] <- asDo cons-    , b1 == b2, eqNoLoc' r recursive, xs `notElem` vars' e+    , b1 == b2, astEq' r recursive, xs `notElem` vars' e     , name <- "foldM" ++ ['_' | varToStr' res == "()"]     = Just $ (,,) name Suggestion $       appsBracket' [strToVar' name, niceLambda' [v,x] e, strToVar' v, strToVar' xs]@@ -185,11 +185,11 @@ eliminateArgs :: [String] -> LHsExpr GhcPs -> ([String], LHsExpr GhcPs) eliminateArgs ps cons = (remove ps, transform f cons)   where-    args = [zs | z : zs <- map fromApps' $ universeApps' cons, eqNoLoc' z recursive]+    args = [zs | z : zs <- map fromApps' $ universeApps' cons, astEq' z recursive]     elim = [all (\xs -> length xs > i && view' (xs !! i) == Var_' p) args | (i, p) <- zip [0..] ps] ++ repeat False     remove = concat . zipWith (\b x -> [x | not b]) elim -    f (fromApps' -> x : xs) | eqNoLoc' x recursive = apps' $ x : remove xs+    f (fromApps' -> x : xs) | astEq' x recursive = apps' $ x : remove xs     f x = x
src/Hint/Match.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE PatternGuards, ViewPatterns, RecordWildCards, FlexibleContexts, ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-}+{-# LANGUAGE PatternGuards, ViewPatterns, FlexibleContexts, ScopedTypeVariables #-}  {- The matching does a fairly simple unification between the two terms, treating@@ -51,6 +52,7 @@ import Config.Type import Data.Generics.Uniplate.Operations +import Bag import HsSyn import SrcLoc import BasicTypes@@ -63,23 +65,23 @@ readMatch' settings = findIdeas' (concatMap readRule' settings)  readRule' :: HintRule -> [HintRule]-readRule' m@HintRule{ hintRuleGhcLHS=(stripLocs' . unwrap -> hintRuleGhcLHS)-                    , hintRuleGhcRHS=(stripLocs' . unwrap -> hintRuleGhcRHS)-                    , hintRuleGhcSide=((stripLocs' . unwrap <$>) -> hintRuleGhcSide)+readRule' m@HintRule{ hintRuleGhcLHS=(stripLocs' . unExtendInstances' -> hintRuleGhcLHS)+                    , hintRuleGhcRHS=(stripLocs' . unExtendInstances' -> hintRuleGhcRHS)+                    , hintRuleGhcSide=((stripLocs' . unExtendInstances' <$>) -> hintRuleGhcSide)                     } =-   (:) m{ hintRuleGhcLHS=wrap hintRuleGhcLHS-        , hintRuleGhcRHS=wrap hintRuleGhcRHS-        , hintRuleGhcSide=wrap <$> hintRuleGhcSide } $ do+   (:) m{ hintRuleGhcLHS=extendInstances' hintRuleGhcLHS+        , hintRuleGhcRHS=extendInstances' hintRuleGhcRHS+        , hintRuleGhcSide=extendInstances' <$> hintRuleGhcSide } $ do     (l, v1) <- dotVersion' hintRuleGhcLHS     (r, v2) <- dotVersion' hintRuleGhcRHS      guard $ v1 == v2 && not (null l) && (length l > 1 || length r > 1) && Set.notMember v1 (Set.map occNameString (freeVars' $ maybeToList hintRuleGhcSide ++ l ++ r))     if not (null r) then-      [ m{ hintRuleGhcLHS=wrap (dotApps' l), hintRuleGhcRHS=wrap (dotApps' r), hintRuleGhcSide=wrap <$> hintRuleGhcSide }-      , m{ hintRuleGhcLHS=wrap (dotApps' (l ++ [strToVar' v1])), hintRuleGhcRHS=wrap (dotApps' (r ++ [strToVar' v1])), hintRuleGhcSide=wrap <$> hintRuleGhcSide } ]+      [ m{ hintRuleGhcLHS=extendInstances' (dotApps' l), hintRuleGhcRHS=extendInstances' (dotApps' r), hintRuleGhcSide=extendInstances' <$> hintRuleGhcSide }+      , m{ hintRuleGhcLHS=extendInstances' (dotApps' (l ++ [strToVar' v1])), hintRuleGhcRHS=extendInstances' (dotApps' (r ++ [strToVar' v1])), hintRuleGhcSide=extendInstances' <$> hintRuleGhcSide } ]       else if length l > 1 then-            [ m{ hintRuleGhcLHS=wrap (dotApps' l), hintRuleGhcRHS=wrap (strToVar' "id"), hintRuleGhcSide=wrap <$> hintRuleGhcSide }-            , m{ hintRuleGhcLHS=wrap (dotApps' (l++[strToVar' v1])), hintRuleGhcRHS=wrap (strToVar' v1), hintRuleGhcSide=wrap <$> hintRuleGhcSide}]+            [ m{ hintRuleGhcLHS=extendInstances' (dotApps' l), hintRuleGhcRHS=extendInstances' (strToVar' "id"), hintRuleGhcSide=extendInstances' <$> hintRuleGhcSide }+            , m{ hintRuleGhcLHS=extendInstances' (dotApps' (l++[strToVar' v1])), hintRuleGhcRHS=extendInstances' (strToVar' v1), hintRuleGhcSide=extendInstances' <$> hintRuleGhcSide}]       else []  -- Find a dot version of this rule, return the sequence of app@@ -105,30 +107,32 @@ findIdeas' :: [HintRule] -> Scope' -> ModuleEx -> LHsDecl GhcPs -> [Idea] findIdeas' matches s _ decl = timed "Hint" "Match apply" $ forceList     [ (idea' (hintRuleSeverity m) (hintRuleName m) x y [r]){ideaNote=notes}-    | decl <- findDecls' decl-    , (parent,x) <- universeParentExp' decl-    , m <- matches, Just (y, notes, subst) <- [matchIdea' s decl m parent x]-    , let r = R.Replace R.Expr (toSS' x) subst (unsafePrettyPrint $ unwrap (hintRuleGhcRHS m))+    | (name, expr) <- findDecls' decl+    , (parent,x) <- universeParentExp' expr+    , m <- matches, Just (y, notes, subst) <- [matchIdea' s name m parent x]+    , let r = R.Replace R.Expr (toSS' x) subst (unsafePrettyPrint $ unExtendInstances' (hintRuleGhcRHS m))     ] -findDecls' :: LHsDecl GhcPs -> [LHsDecl GhcPs]-findDecls' x@(LL _ InstD{}) = children x+-- | A list of root expressions, with their associated names+findDecls' :: LHsDecl GhcPs -> [(String, LHsExpr GhcPs)]+findDecls' x@(LL _ (InstD _ (ClsInstD _ ClsInstDecl{cid_binds}))) =+    [(fromMaybe "" $ bindName xs, x) | xs <- bagToList cid_binds, x <- childrenBi xs] findDecls' (LL _ RuleD{}) = [] -- Often rules contain things that HLint would rewrite.-findDecls' x = [x]+findDecls' x = map (fromMaybe "" $ declName x,) $ childrenBi x  matchIdea' :: Scope'-           -> LHsDecl GhcPs+           -> String            -> HintRule            -> Maybe (Int, LHsExpr GhcPs)            -> LHsExpr GhcPs            -> Maybe (LHsExpr GhcPs, [Note], [(String, R.SrcSpan)])-matchIdea' sb decl HintRule{..} parent x = do-  let lhs = unwrap hintRuleGhcLHS-      rhs = unwrap hintRuleGhcRHS-      sa  = unwrap hintRuleGhcScope+matchIdea' sb declName HintRule{..} parent x = do+  let lhs = unExtendInstances' hintRuleGhcLHS+      rhs = unExtendInstances' hintRuleGhcRHS+      sa  = unExtendInstances' hintRuleGhcScope       nm a b = scopeMatch' (sa, a) (sb, b)   u <- unifyExp' nm True lhs x-  u <- validSubst' eqNoLoc' u+  u <- validSubst' astEq' u    -- Need to check free vars before unqualification, but after subst   -- (with 'e') need to unqualify before substitution (with 'res').@@ -143,8 +147,8 @@   -- what free vars they make use of.   guard $ not (any isLambda' $ universe lhs) || not (any isQuasiQuote' $ universe x) -  guard $ checkSide' (unwrap <$> hintRuleGhcSide) $ ("original", x) : ("result", res) : fromSubst' u-  guard $ checkDefine' decl parent res+  guard $ checkSide' (unExtendInstances' <$> hintRuleGhcSide) $ ("original", x) : ("result", res) : fromSubst' u+  guard $ checkDefine' declName parent res    return (res, hintRuleNotes, [(s, toSS' pos) | (s, pos) <- fromSubst' u, getLoc pos /= noSrcSpan]) @@ -158,15 +162,15 @@       bool (LL _ (OpApp _ x op y))         | varToStr' op == "&&" = bool x && bool y         | varToStr' op == "||" = bool x || bool y-        | varToStr' op == "==" = expr (fromParen1' x) `eqNoLoc'` expr (fromParen1' y)+        | varToStr' op == "==" = expr (fromParen1' x) `astEq'` expr (fromParen1' y)       bool (LL _ (HsApp _ x y)) | varToStr' x == "not" = not $ bool y       bool (LL _ (HsPar _ x)) = bool x        bool (LL _ (HsApp _ cond (sub -> y)))         | 'i' : 's' : typ <- varToStr' cond = isType typ y       bool (LL _ (HsApp _ (LL _ (HsApp _ cond (sub -> x))) (sub -> y)))-          | varToStr' cond == "notIn" = and [wrap (stripLocs' x) `notElem` map (wrap . stripLocs') (universe y) | x <- list x, y <- list y]-          | varToStr' cond == "notEq" = not (x `eqNoLoc'` y)+          | varToStr' cond == "notIn" = and [extendInstances' (stripLocs' x) `notElem` map (extendInstances' . stripLocs') (universe y) | x <- list x, y <- list y]+          | varToStr' cond == "notEq" = not (x `astEq'` y)       bool x | varToStr' x == "noTypeCheck" = True       bool x | varToStr' x == "noQuickCheck" = True       bool x = error $ "Hint.Match.checkSide', unknown side condition: " ++ unsafePrettyPrint x@@ -213,8 +217,8 @@               f x = x  -- Does the result look very much like the declaration?-checkDefine' :: LHsDecl GhcPs -> Maybe (Int, LHsExpr GhcPs) -> LHsExpr GhcPs -> Bool-checkDefine' x Nothing y = declName x /= Just (varToStr' (transformBi unqual' $ head $ fromApps' y))+checkDefine' :: String -> Maybe (Int, LHsExpr GhcPs) -> LHsExpr GhcPs -> Bool+checkDefine' declName Nothing y = declName /= varToStr' (transformBi unqual' $ head $ fromApps' y) checkDefine' _ _ _ = True  ---------------------------------------------------------------------
src/Hint/Monad.hs view
@@ -39,6 +39,8 @@ folder f a xs = foldM f a xs >>= \_ -> return () -- foldM_ f a xs yes = mapM async ds >>= mapM wait >> return () -- mapM async ds >>= mapM_ wait main = "wait" ~> do f a $ sleep 10+main = print do 17 + 25+main = print do 17 -- 17 main = f $ do g a $ sleep 10 -- g a $ sleep 10 main = do f a $ sleep 10 -- f a $ sleep 10 main = do foo x; return 3; bar z -- do foo x; bar z@@ -97,8 +99,10 @@     seenVoid wrap x = monadNoResult (fromMaybe "" decl) wrap x ++ [warn' "Redundant void" (wrap x) x [] | returnsUnit x]  -- Sometimes people write 'a * do a + b', to avoid brackets.+-- or using BlockArguments they can write 'a do a b' doOperator :: (Eq a, Num a) => Maybe (a, LHsExpr GhcPs) -> LHsExpr GhcPs -> Bool doOperator (Just (2, LL _ (OpApp _ _ op _ )))  (LL _ OpApp {}) | not $ isDol' op = True+doOperator (Just (1, LL _ HsApp{})) b | not $ isAtom' b = True doOperator _ _ = False  returnsUnit :: LHsExpr GhcPs -> Bool
src/Hint/Restrict.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} @@ -18,6 +20,7 @@ import Config.Type  import Data.Generics.Uniplate.Operations+import qualified Data.Set as Set import qualified Data.Map as Map import Data.List import Data.Maybe@@ -54,19 +57,20 @@ data RestrictItem = RestrictItem     {riAs :: [String]     ,riWithin :: [(String, String)]+    ,riBadIdents :: [String]     ,riMessage :: Maybe String     } instance Semigroup RestrictItem where-    RestrictItem x1 x2 x3 <> RestrictItem y1 y2 y3 = RestrictItem (x1<>y1) (x2<>y2) (x3<>y3)+    RestrictItem x1 x2 x3 x4 <> RestrictItem y1 y2 y3 y4 = RestrictItem (x1<>y1) (x2<>y2) (x3<>y3) (x4<>y4) instance Monoid RestrictItem where-    mempty = RestrictItem [] [] Nothing+    mempty = RestrictItem [] [] [] Nothing     mappend = (<>)  restrictions :: [Setting] -> Map.Map RestrictType (Bool, Map.Map String RestrictItem) restrictions settings = Map.map f $ Map.fromListWith (++) [(restrictType x, [x]) | SettingRestrict x <- settings]     where         f rs = (all restrictDefault rs-               ,Map.fromListWith (<>) [(s, RestrictItem restrictAs restrictWithin restrictMessage) | Restrict{..} <- rs, s <- restrictName])+               ,Map.fromListWith (<>) [(s, RestrictItem restrictAs restrictWithin restrictBadIdents restrictMessage) | Restrict{..} <- rs, s <- restrictName])   ideaMessage :: Maybe String -> Idea -> Idea@@ -105,22 +109,48 @@  checkImports :: String -> [LImportDecl GhcPs] -> (Bool, Map.Map String RestrictItem) -> [Idea] checkImports modu imp (def, mp) =-    [ ideaMessage riMessage $ if not allowImport-      then ideaNoTo $ warn' "Avoid restricted module" i i []-      else warn' "Avoid restricted qualification" i (noLoc $ (unLoc i){ ideclAs=noLoc . mkModuleName <$> listToMaybe riAs} :: Located (ImportDecl GhcPs)) []+    [ 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@(LL _ ImportDecl {..}) <- imp-    , let ri@RestrictItem{..} = Map.findWithDefault (RestrictItem [] [("","") | def] Nothing) (moduleNameString (unLoc ideclName)) mp+    , let ri@RestrictItem{..} = Map.findWithDefault (RestrictItem [] [("","") | def] [] Nothing) (moduleNameString (unLoc ideclName)) mp     , let allowImport = within modu "" ri+    , 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 allowImport || not allowQual || not allowIdent     ] +importListToIdents :: IE GhcPs -> [String]+importListToIdents =+  catMaybes .+  \case (IEVar _ n)              -> [fromName n]+        (IEThingAbs _ n)         -> [fromName n]+        (IEThingAll _ n)         -> [fromName n]+        (IEThingWith _ n _ ns _) -> fromName n : map fromName ns+        _                        -> []+  where+    fromName :: LIEWrappedName (IdP GhcPs) -> Maybe String+    fromName wrapped = case unLoc wrapped of+                         IEName    n -> fromId (unLoc n)+                         IEPattern n -> ("pattern " ++) <$> fromId (unLoc n)+                         IEType    n -> ("type " ++) <$> fromId (unLoc n)++    fromId :: IdP GhcPs -> Maybe String+    fromId (Unqual n) = Just $ occNameString n+    fromId (Qual _ n) = Just $ occNameString n+    fromId (Orig _ n) = Just $ occNameString n+    fromId (Exact _)  = Nothing+ checkFunctions :: String -> [LHsDecl GhcPs] -> (Bool, Map.Map String RestrictItem) -> [Idea] checkFunctions modu decls (def, mp) =     [ (ideaMessage riMessage $ ideaNoTo $ warn' "Avoid restricted function" x x []){ideaDecl = [dname]}     | d <- decls     , let dname = fromMaybe "" (declName d)     , x <- universeBi d :: [Located RdrName]-    , let ri@RestrictItem{..} = Map.findWithDefault (RestrictItem [] [("","") | def] Nothing) (occNameString (rdrNameOcc (unLoc x))) mp+    , let ri@RestrictItem{..} = Map.findWithDefault (RestrictItem [] [("","") | def] [] Nothing) (occNameString (rdrNameOcc (unLoc x))) mp     , not $ within modu dname ri     ]
src/Util.hs view
@@ -82,10 +82,8 @@ configExtensions :: [Extension] configExtensions = [e | e@EnableExtension{} <- knownExtensions] \\ map EnableExtension reallyBadExtensions -badExtensions =+badExtensions = reallyBadExtensions ++     [Arrows -- steals proc-    ,TransformListComp -- steals the group keyword-    ,XmlSyntax, RegularPatterns -- steals a-b     ,UnboxedTuples, UnboxedSums -- breaks (#) lens operator     ,QuasiQuotes -- breaks [x| ...], making whitespace free list comps break     ,DoRec, RecursiveDo -- breaks rec@@ -94,4 +92,5 @@  reallyBadExtensions =     [TransformListComp -- steals the group keyword+    ,XmlSyntax, RegularPatterns -- steals a-b and < operators     ]