packages feed

hlint 2.2.3 → 2.2.4

raw patch · 19 files changed

+371/−254 lines, 19 filesdep +filepatterndep ~haskell-src-extsPVP ok

version bump matches the API change (PVP)

Dependencies added: filepattern

Dependency ranges changed: haskell-src-exts

API changes (from Hackage documentation)

Files

CHANGES.txt view
@@ -1,5 +1,9 @@ Changelog for HLint (* = breaking change) +2.2.4, released 2019-11-02+    Allow haskell-src-exts-1.22+    #788, give less redundant context on unused variable capture+    #334, add --ignore=glob flag 2.2.3, released 2019-09-29     #766, turn on more extensions when parsing config files     #255, don't match variables with type application
hlint.cabal view
@@ -1,7 +1,7 @@ cabal-version:      >= 1.18 build-type:         Simple name:               hlint-version:            2.2.3+version:            2.2.4 license:            BSD3 license-file:       LICENSE category:           Development@@ -58,13 +58,14 @@         cpphs >= 1.20.1,         cmdargs >= 0.10,         yaml >= 0.5.0,-        haskell-src-exts >= 1.21 && < 1.22,+        haskell-src-exts >= 1.21 && < 1.23,         haskell-src-exts-util >= 0.2.5,         uniplate >= 1.5,         ansi-terminal >= 0.6.2,         extra >= 1.6.6,         refact >= 0.3,         aeson >= 1.1.2.0,+        filepattern >= 0.1.1,         syb >= 0.7,         mtl >= 2.2.2     if !flag(ghc-lib) && impl(ghc >= 8.8.0) && impl(ghc < 8.9.0)
src/Apply.hs view
@@ -51,7 +51,7 @@     [ map (classify classifiers . removeRequiresExtensionNotes (hseModule m)) $         order [] (hintModule hints settings nm m) `merge`         concat [order [fromNamed d] $ decHints d | d <- moduleDecls (hseModule m)] `merge`-        concat [order (maybeToList $ declName $ GHC.unLoc d) $ decHints' d | d <- hsmodDecls $ GHC.unLoc $ ghcModule m]+        concat [order (maybeToList $ declName d) $ decHints' d | d <- hsmodDecls $ GHC.unLoc $ ghcModule m]     | (nm, m) <- mns     , let classifiers = cls ++ mapMaybe readPragma (universeBi (hseModule m)) ++ concatMap readComment (ghcComments m)     , seq (length classifiers) True -- to force any errors from readPragma or readComment
src/CmdLine.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE PatternGuards, DeriveDataTypeable #-}+{-# LANGUAGE PatternGuards, DeriveDataTypeable, TupleSections #-} {-# OPTIONS_GHC -fno-warn-missing-fields -fno-cse -O0 #-}  module CmdLine(@@ -28,6 +28,7 @@ import System.IO.Error import System.Info.Extra import System.Process+import System.FilePattern  import Util import Paths_hlint@@ -122,6 +123,7 @@         ,cmdRefactor :: Bool            -- ^ Run the `refactor` executable to automatically perform hints         ,cmdRefactorOptions :: String   -- ^ Options to pass to the `refactor` executable.         ,cmdWithRefactor :: FilePath    -- ^ Path to refactor tool+        ,cmdIgnoreGlob :: [FilePattern]         }     | CmdGrep         {cmdFiles :: [FilePath]    -- ^ which files to run it on, nothing = none given@@ -185,6 +187,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"         } &= auto &= explicit &= name "lint"     ,CmdGrep         {cmdFiles = def &= args &= typ "FILE/DIR"@@ -265,20 +268,29 @@     -> Maybe FilePath -- ^ Temporary file     -> FilePath       -- ^ File to resolve, may be "-" for stdin     -> IO [FilePath]-resolveFile cmd = getFile (cmdPath cmd) (cmdExtension cmd)+resolveFile cmd = getFile (toPredicate $ cmdIgnoreGlob cmd) (cmdPath cmd) (cmdExtension cmd)+    where+        toPredicate :: [FilePattern] -> FilePath -> Bool+        toPredicate [] = const False+        toPredicate globs = \x -> not $ null $ m [((), cleanup x)]+            where m = matchMany (map ((),) globs) +        cleanup :: FilePath -> FilePath+        cleanup ('.':x:xs) | isPathSeparator x, not $ null xs = xs+        cleanup x = x -getFile :: [FilePath] -> [String] -> Maybe FilePath -> FilePath -> IO [FilePath]-getFile path _ (Just tmpfile) "-" =++getFile :: (FilePath -> Bool) -> [FilePath] -> [String] -> Maybe FilePath -> FilePath -> IO [FilePath]+getFile _ path _ (Just tmpfile) "-" =     -- make sure we don't reencode any Unicode     BS.getContents >>= BS.writeFile tmpfile >> return [tmpfile]-getFile path _ Nothing "-" = return ["-"]-getFile [] exts _ file = exitMessage $ "Couldn't find file: " ++ file-getFile (p:ath) exts t file = do+getFile _ path _ Nothing "-" = return ["-"]+getFile _ [] exts _ file = exitMessage $ "Couldn't find file: " ++ file+getFile ignore (p:ath) exts t file = do     isDir <- doesDirectoryExist $ p <\> file     if isDir then do         let avoidDir x = let y = takeFileName x in "_" `isPrefixOf` y || ("." `isPrefixOf` y && not (all (== '.') y))-            avoidFile x = let y = takeFileName x in "." `isPrefixOf` y+            avoidFile x = let y = takeFileName x in "." `isPrefixOf` y || ignore x         xs <- listFilesInside (return . not . avoidDir) $ p <\> file         return [x | x <- xs, drop 1 (takeExtension x) `elem` exts, not $ avoidFile x]      else do@@ -288,7 +300,7 @@             res <- getModule p exts file             case res of                 Just x -> return [x]-                Nothing -> getFile ath exts t file+                Nothing -> getFile ignore ath exts t file   getModule :: FilePath -> [String] -> FilePath -> IO (Maybe FilePath)
src/GHC/Util/HsDecl.hs view
@@ -15,8 +15,8 @@ -- 'Nothing' is returned instead.  This is useful because we don't -- want to tell users to rename binders that they aren't creating -- right now and therefore usually cannot change.-declName :: HsDecl GhcPs -> Maybe String-declName x = occNameString . occName <$> case x of+declName :: LHsDecl GhcPs -> Maybe String+declName (LL _ x) = occNameString . occName <$> case x of     TyClD _ FamDecl{tcdFam=FamilyDecl{fdLName}} -> Just $ unLoc fdLName     TyClD _ SynDecl{tcdLName} -> Just $ unLoc tcdLName     TyClD _ DataDecl{tcdLName} -> Just $ unLoc tcdLName@@ -30,3 +30,4 @@     ForD _ ForeignImport{fd_name} -> Just $ unLoc fd_name     ForD _ ForeignExport{fd_name} -> Just $ unLoc fd_name     _ -> Nothing+declName _ = Nothing {- COMPLETE LL-}
src/GHC/Util/HsExpr.hs view
@@ -8,13 +8,14 @@  module GHC.Util.HsExpr (     noSyntaxExpr'-  , isDol', isDot', isSection', isRecConstr', isRecUpdate', isVar', isPar', isApp', isAnyApp', isLexeme', isReturn'+  , isTag', isDol', isDot', isSection', isRecConstr', isRecUpdate', isVar', isPar', isApp', isAnyApp', isLexeme', isReturn'   , dotApp'   , simplifyExp', niceLambda', niceDotApp'   , Brackets'(..)-  , rebracket1', appsBracket', transformAppsM', fromApps', apps', universeApps'+  , rebracket1', appsBracket', transformAppsM', fromApps', apps', universeApps', universeParentExp'   , varToStr', strToVar'   , paren', fromChar'+  , replaceBranches' ) where  import HsSyn@@ -63,20 +64,30 @@   | isAtom' x  = x   | otherwise = addParen' x -isVar',isReturn',isLexeme',isDotApp',isRecUpdate',isRecConstr',isDol', isDot' :: LHsExpr GhcPs -> Bool+-- 'True' if the provided expression is a variable with name 'tag'.+isTag' :: LHsExpr GhcPs -> String -> Bool+isTag' (LL _ (HsVar _ (L _ s))) tag = occNameString (rdrNameOcc s) == tag+isTag' _ _ = False++isVar',isReturn',isLexeme',isDotApp',isRecUpdate',isRecConstr',isDol',isDot' :: LHsExpr GhcPs -> Bool isPar' (LL _ HsPar{}) = True; isPar' _ = False isVar' (LL _ HsVar{}) = True; isVar' _ = False-isDot' (LL _ (HsVar _ (LL _ ident))) = occNameString (rdrNameOcc ident) == "."; isDot' _ = False-isDol' (LL _ (HsVar _ (L _ ident))) = occNameString (rdrNameOcc ident) == "$"; isDol' _ = False+isDot' x = isTag' x "."+isDol' x = isTag' x "$"+isReturn' x = isTag' x "return" || isTag' x "pure" -- Allow both 'pure' and 'return' as they have the same semantics. isRecConstr' (LL _ RecordCon{}) = True; isRecConstr' _ = False isRecUpdate' (LL _ RecordUpd{}) = True; isRecUpdate' _ = False isDotApp' (LL _ (OpApp _ _ op _)) = isDot' op; isDotApp' _ = False isLexeme' (LL _ HsVar{}) = True;isLexeme' (LL _ HsOverLit{}) = True;isLexeme' (LL _ HsLit{}) = True;isLexeme' _ = False--- Allow both 'pure' and 'return' as they have the same semantics.-isReturn' (LL _ (HsVar _ (LL _ (Unqual x)))) = occNameString x == "return" || occNameString x == "pure"; isReturn' _ = False  -- +universeParentExp' :: Data a => a -> [(Maybe (Int, LHsExpr GhcPs), LHsExpr GhcPs)]+universeParentExp' xs = concat [(Nothing, x) : f x | x <- childrenBi xs]+    where f p = concat [(Just (i,p), c) : f c | (i,c) <- zip [0..] $ children p]++--+ apps' :: [LHsExpr GhcPs] -> LHsExpr GhcPs apps' = foldl1' mkApp where mkApp x y = noLoc (HsApp noExt x y) @@ -222,3 +233,26 @@ fromChar' :: LHsExpr GhcPs -> Maybe Char fromChar' (LL _ (HsLit _ (HsChar _ x))) = Just x fromChar' _ = Nothing++--++-- 'case' and 'if' expressions have branches, nothing else does (this+-- doesn't consider 'HsMultiIf' perhaps it should?).+replaceBranches' :: LHsExpr GhcPs -> ([LHsExpr GhcPs], [LHsExpr GhcPs] -> LHsExpr GhcPs)+replaceBranches' (LL l (HsIf _ _ a b c)) = ([b, c], \[b, c] -> cL l (HsIf noExt Nothing a b c))++replaceBranches' (LL s (HsCase _ a (MG _ (L l bs) FromSource))) =+  (concatMap f bs, \xs -> cL s (HsCase noExt a (MG noExt (cL l (g bs xs)) Generated)))+  where+    f :: LMatch GhcPs (LHsExpr GhcPs) -> [LHsExpr GhcPs]+    f (LL _ (Match _ CaseAlt _ (GRHSs _ xs _))) = [x | (LL _ (GRHS _ _ x)) <- xs]+    f _ = undefined -- {-# COMPLETE LL #-}++    g :: [LMatch GhcPs (LHsExpr GhcPs)] -> [LHsExpr GhcPs] -> [LMatch GhcPs (LHsExpr GhcPs)]+    g (LL s1 (Match _ CaseAlt a (GRHSs _ ns b)) : rest) xs =+      cL s1 (Match noExt CaseAlt a (GRHSs noExt [cL a (GRHS noExt gs x) | (LL a (GRHS _ gs _), x) <- zip ns as] b)) : g rest bs+      where  (as, bs) = splitAt (length ns) xs+    g [] [] = []+    g _ _ = error "GHC.Util.HsExpr.replaceBranches': internal invariant failed, lists are of differing lengths"++replaceBranches' x = ([], \[] -> x)
src/GHC/Util/Pat.hs view
@@ -3,7 +3,7 @@ module GHC.Util.Pat (     strToPat', patToStr'   , Brackets'(..)-  , fromPChar', isPFieldWildcard', hasPFieldsDotDot'+  , fromPChar', isPFieldWildcard', hasPFieldsDotDot', isPWildCard'   ) where  import HsSyn@@ -42,3 +42,7 @@ isPFieldWildcard' (LL _ HsRecField {hsRecPun=True}) = True isPFieldWildcard' (LL _ HsRecField {}) = False isPFieldWildcard' _ = False -- {-# COMPLETE LL #-}++isPWildCard' :: Pat GhcPs -> Bool+isPWildCard' (LL _ (WildPat _)) = True+isPWildCard' _ = False
src/GHC/Util/View.hs view
@@ -3,13 +3,14 @@ module GHC.Util.View (    fromParen', fromPParen'   , View'(..)-  , Var_'(Var_'), PVar_'(PVar_'), PApp_'(PApp_'), App2'(App2')+  , Var_'(Var_'), PVar_'(PVar_'), PApp_'(PApp_'), App2'(App2'),LamConst1'(LamConst1') ) where  import HsSyn import SrcLoc import RdrName import OccName+import BasicTypes  fromParen' :: LHsExpr GhcPs -> LHsExpr GhcPs fromParen' (LL _ (HsPar _ x)) = fromParen' x@@ -26,6 +27,12 @@ data PVar_' = NoPVar_' | PVar_' String data PApp_' = NoPApp_' | PApp_' String [Pat GhcPs] data App2'  = NoApp2'  | App2' (LHsExpr GhcPs) (LHsExpr GhcPs) (LHsExpr GhcPs)+data LamConst1' = NoLamConst1' | LamConst1' (LHsExpr GhcPs)++instance View' (LHsExpr GhcPs) LamConst1' where+  view' (fromParen' -> (LL _ (HsLam _ (MG _ (L _ [LL _ (Match _ LambdaExpr [LL _ WildPat {}]+    (GRHSs _ [LL _ (GRHS _ [] x)] (LL _ (EmptyLocalBinds _))))]) FromSource)))) = LamConst1' x+  view' _ = NoLamConst1'  instance View' (LHsExpr GhcPs) Var_' where     view' (fromParen' -> (LL _ (HsVar _ (LL _ (Unqual x))))) = Var_' $ occNameString x
src/HSE/Match.hs view
@@ -3,7 +3,7 @@ module HSE.Match(     View(..), Named(..),     (~=), isSym,-    App2(App2), LamConst1(LamConst1), PVar_(PVar_), Var_(Var_)+    App2(App2), PVar_(PVar_), Var_(Var_)     ) where  import Data.Char@@ -28,13 +28,6 @@ instance View Exp_ App1 where     view (fromParen -> App _ f x) = App1 f x     view _ = NoApp1---- \_ -> body-data LamConst1 = NoLamConst1 | LamConst1 Exp_ deriving Show--instance View Exp_ LamConst1 where-    view (fromParen -> Lambda _ [PWildCard _] x) = LamConst1 x-    view _ = NoLamConst1  data PVar_ = NoPVar_ | PVar_ String
src/Hint/All.hs view
@@ -46,9 +46,7 @@ builtin x = case x of     -- Hse.     HintExtensions -> modu extensionsHint-    HintMonad      -> decl monadHint     HintLambda     -> decl lambdaHint-    HintPattern    -> decl patternHint      -- Ghc.     HintImport     -> modu importHint@@ -64,6 +62,8 @@     HintNaming     -> decl' namingHint     HintBracket    -> decl' bracketHint     HintSmell      -> mempty{hintDecl'=smellHint,hintModule=smellModuleHint}+    HintPattern    -> decl' patternHint+    HintMonad      -> decl' monadHint     where         wrap = timed "Hint" (drop 4 $ show x) . forceList         decl f = mempty{hintDecl=const $ \a b c -> wrap $ f a b c}
src/Hint/Duplicate.hs view
@@ -51,9 +51,9 @@          , let y = bagToList b          ]     where-      ds = [(modName m, fromMaybe "" (declName d), d)+      ds = [(modName m, fromMaybe "" (declName d), unLoc d)            | ModuleEx _ _ m _ <- map snd ms-           , d <- map unLoc (hsmodDecls (unLoc m))]+           , d <- hsmodDecls (unLoc m)]  dupes :: (Outputable e, Data e) => [(String, String, [Located e])] -> [Idea] dupes ys =
src/Hint/Export.hs view
@@ -25,7 +25,7 @@ exportHint _ (ModuleEx _ _ (LL s m@HsModule {hsmodName = Just name, hsmodExports = exports}) _)   | Nothing <- exports =       let r = o{ hsmodExports = Just (noLoc [noLoc (IEModuleContents noExt name)] )} in-      [(ignore' "Use module export list" (L s o) (noLoc r) []){ideaNote = [Note "an explicit list is usally better"]}]+      [(ignore' "Use module export list" (L s o) (noLoc r) []){ideaNote = [Note "an explicit list is usually better"]}]   | Just (L _ xs) <- exports   , mods <- [x | x <- xs, isMod x]   , modName <- moduleNameString (unLoc name)
src/Hint/ListRec.hs view
@@ -127,7 +127,8 @@ asDo (view' ->        App2' bind lhs          (LL _ (HsLam _ MG {-             mg_alts=LL _ [+              mg_origin=FromSource+            , mg_alts=LL _ [                  LL _ Match {  m_ctxt=LambdaExpr                             , m_pats=[LL _ v@VarPat{}]                             , m_grhss=GRHSs _@@ -148,7 +149,7 @@ findCase x = do   -- Match a function binding with two alternatives.   (LL _ (ValD _ FunBind {fun_matches=-              MG{mg_alts=+              MG{mg_origin=FromSource, mg_alts=                      (LL _                             [ x1@(LL _ Match{..}) -- Match fields.                             , x2]), ..} -- Match group fields.
src/Hint/Monad.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE ViewPatterns, PatternGuards, FlexibleContexts #-}- {-     Find and match: @@ -45,7 +44,7 @@ main = do foo x; return 3; bar z -- do foo x; bar z main = void $ forM_ f xs -- forM_ f xs main = void $ forM f xs -- void $ forM_ f xs-main = do _ <- forM_ f xs; bar -- do forM_ f xs; bar+main = do _ <- forM_ f xs; bar -- forM_ f xs main = do bar; forM_ f xs; return () -- do bar; forM_ f xs main = do a; when b c; return () -- do a; when b c </TEST>@@ -54,149 +53,172 @@  module Hint.Monad(monadHint) where -import Control.Applicative+import Hint.Type(DeclHint',Idea,ideaNote,warn',toSS',suggest',Note(Note))++import HsSyn+import SrcLoc+import BasicTypes+import TcEvidence+import RdrName+import OccName+import Bag+import GHC.Util+ import Data.Tuple.Extra import Data.Maybe import Data.List.Extra-import Hint.Type-import Refact.Types+import Refact.Types hiding (Match) import qualified Refact.Types as R-import Prelude - badFuncs :: [String] badFuncs = ["mapM","foldM","forM","replicateM","sequence","zipWithM","traverse","for","sequenceA"] unitFuncs :: [String] unitFuncs = ["when","unless","void"] --monadHint :: DeclHint-monadHint _ _ d = concatMap (monadExp d) $ universeParentExp d--monadExp :: Decl_ -> (Maybe (Int, Exp_), Exp_) -> [Idea]-monadExp (fromNamed -> decl) (parent, x) = case x of-        (view -> App2 op x1 x2) | op ~= ">>" -> f x1-        (view -> App2 op x1 (view -> LamConst1 _)) | op ~= ">>=" -> f x1-        App an op x | op ~= "void" -> seenVoid (App an op) x-        InfixApp an op dol x | op ~= "void", isDol dol -> seenVoid (InfixApp an op dol) x-        Do an [Qualifier _ y] -> [warn "Redundant do" x y [Replace Expr (toSS x) [("y", toSS y)] "y"] | not $ doOperator parent y]-        Do an xs ->-            monadSteps (Do an) xs ++-            [suggest "Use let" x (Do an y) rs | Just (y, rs) <- [monadLet xs]] ++-            concat [f x | Qualifier _ x <- init xs] ++-            concat [f x | Generator _ (PWildCard _) x <- init xs]-        _ -> []-    where-        f = monadNoResult decl id-        seenVoid wrap x = monadNoResult decl wrap x ++ [warn "Redundant void" (wrap x) x [] | returnsUnit x]-+monadHint :: DeclHint'+monadHint _ _ d = concatMap (monadExp d) $ universeParentExp' d +monadExp :: LHsDecl GhcPs -> (Maybe (Int, LHsExpr GhcPs), LHsExpr GhcPs) -> [Idea]+monadExp (declName -> decl) (parent, x) =+  case x of+    (view' -> App2' op x1 x2) | isTag' op ">>" -> f x1+    (view' -> App2' op x1 (view' -> LamConst1' _)) | isTag' op ">>=" -> f x1+    (LL l (HsApp _ op x)) | isTag' op "void" -> seenVoid (cL l . HsApp noExt op) x+    (LL l (OpApp _ op dol x)) | isTag' op "void", isDol' dol -> seenVoid (cL l . OpApp noExt op dol) x+    (LL loc (HsDo _ _ (LL _ [LL _ (BodyStmt _ y _ _ )]))) -> [warn' "Redundant do" x y [Replace Expr (toSS' x) [("y", toSS' y)] "y"] | not $ doOperator parent y]+    (LL loc (HsDo _ DoExpr (L _ xs))) ->+      monadSteps (cL loc . HsDo noExt DoExpr . noLoc) xs +++      [suggest' "Use let" x (cL loc (HsDo noExt DoExpr (noLoc y)) :: LHsExpr GhcPs) rs | Just (y, rs) <- [monadLet xs]] +++      concat [f x | (LL _ (BodyStmt _ x _ _)) <- init xs] +++      concat [f x | (LL _ (BindStmt _ (LL _ WildPat{}) x _ _)) <- init xs]+    _ -> []+  where+    f = monadNoResult (fromMaybe "" decl) id+    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-doOperator :: (Eq a, Num a) => Maybe (a, Exp S) -> Exp l -> Bool-doOperator (Just (1, InfixApp _ _ op _)) InfixApp{} | not $ isDol op = True+-- Sometimes people write 'a * do a + b', to avoid brackets.+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 _ _ = False --returnsUnit :: Exp_ -> Bool-returnsUnit (Paren _ x) = returnsUnit x-returnsUnit (App _ x _) = returnsUnit x-returnsUnit (InfixApp _ x op _) | isDol op = returnsUnit x-returnsUnit (Var _ x) = any (x ~=) $ map (++ "_") badFuncs ++ unitFuncs+returnsUnit :: LHsExpr GhcPs -> Bool+returnsUnit (LL _ (HsPar _ x)) = returnsUnit x+returnsUnit (LL _ (HsApp _ x _)) = returnsUnit x+returnsUnit (LL _ (OpApp _ x op _)) | isDol' op = returnsUnit x+returnsUnit (LL _ (HsVar _ (L _ x))) = occNameString (rdrNameOcc x) `elem` map (++ "_") badFuncs ++ unitFuncs returnsUnit _ = False ---- see through Paren and down if/case etc--- return the name to use in the hint, and the revised expression-monadNoResult :: String -> (Exp_ -> Exp_) -> Exp_ -> [Idea]-monadNoResult inside wrap (Paren l x) = monadNoResult inside (wrap . Paren l) x-monadNoResult inside wrap (App l x y) = monadNoResult inside (\x -> wrap $ App l x y) x-monadNoResult inside wrap (InfixApp l x op y)-    | isDol op = monadNoResult inside (\x -> wrap $ InfixApp l x op y) x-    | op ~= ">>=" = monadNoResult inside (wrap . InfixApp l x op) y+-- See through HsPar, and down HsIf/HsCase, return the name to use in+-- the hint, and the revised expression.+monadNoResult :: String -> (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea]+monadNoResult inside wrap (LL l (HsPar _ x)) = monadNoResult inside (wrap . cL l . HsPar noExt) x+monadNoResult inside wrap (LL l (HsApp _ x y)) = monadNoResult inside (\x -> wrap $ cL l (HsApp noExt x y)) x+monadNoResult inside wrap (LL l (OpApp _ x tag@(LL _ (HsVar _ (L _ op))) y))+    | isDol' tag = monadNoResult inside (\x -> wrap $ cL l (OpApp noExt x tag y)) x+    | occNameString (rdrNameOcc op) == ">>=" = monadNoResult inside (wrap . cL l . OpApp noExt x tag) y monadNoResult inside wrap x-    | x2:_ <- filter (x ~=) badFuncs+    | x2 : _ <- filter (isTag' x) badFuncs     , let x3 = x2 ++ "_"-    = [warn ("Use " ++ x3) (wrap x) (wrap $ toNamed x3) [Replace Expr (toSS x) [] x3] | inside /= x3]-monadNoResult inside wrap (replaceBranches -> (bs, rewrap)) =+    = [warn' ("Use " ++ x3) (wrap x) (wrap $ strToVar' x3) [Replace Expr (toSS' x) [] x3] | inside /= x3]+monadNoResult inside wrap (replaceBranches' -> (bs, rewrap)) =     map (\x -> x{ideaNote=nubOrd $ Note "May require adding void to other branches" : ideaNote x}) $ concat         [monadNoResult inside id b | b <- bs] --monadStep :: ([Stmt S] -> Exp_) -> [Stmt S] -> [Idea]+monadStep :: ([ExprLStmt GhcPs] -> LHsExpr GhcPs)+           -> [ExprLStmt GhcPs] -> [Idea] --- do return x; $2 ==> do $2-monadStep wrap o@(Qualifier _ (fromRet -> Just (ret, _)):x:xs) =-    [warn ("Redundant " ++ ret) (wrap o) (wrap $ x:xs) [Delete Stmt (toSS (head o))]]+-- Rewrite 'do return x; $2' as 'do $2'.+monadStep wrap o@(LL _ (BodyStmt _ (fromRet -> Just (ret, _)) _ _ ) : x : xs)+  = [warn' ("Redundant " ++ ret) (wrap o) (wrap $ x:xs) [Delete Stmt (toSS' (head o))]] --- do a <- $1; return a ==> do $1-monadStep wrap o@[g@(Generator _ (PVar _ p) x), q@(Qualifier _ (fromRet -> Just (ret, Var _ v)))]-    | fromNamed v == fromNamed p-    = [warn ("Redundant " ++ ret) (wrap o) (wrap [Qualifier an x])-            [Replace Stmt (toSS g) [("x", toSS x)] "x", Delete Stmt (toSS q)]]+-- Rewrite 'do a <- $1; return a' as 'do $1'.+monadStep wrap o@[ g@(LL _ (BindStmt _ (LL _ (VarPat _ (L _ p))) x _ _ ))+                  , q@(LL _ (BodyStmt _ (fromRet -> Just (ret, LL _ (HsVar _ (L _ v)))) _ _))]+  | occNameString (rdrNameOcc p) == occNameString (rdrNameOcc v)+  = [warn' ("Redundant " ++ ret) (wrap o) (wrap [noLoc $ BodyStmt noExt x noSyntaxExpr' noSyntaxExpr'])+      [Replace Stmt (toSS' g) [("x", toSS' x)] "x", Delete Stmt (toSS' q)]] --- do x <- $1; x; $2  ==> do join $1; $2-monadStep wrap o@(g@(Generator _ (view -> PVar_ p) x):q@(Qualifier _ (view -> Var_ v)):xs)-    | p == v && v `notElem` varss xs-    = [warn "Use join" (wrap o) (wrap $ Qualifier an (rebracket1 $ App an (toNamed "join") x):xs) r]-    where r = [Replace Stmt (toSS g) [("x", toSS x)] "join x", Delete Stmt (toSS q)]+-- Suggest to use join. Rewrite 'do x <- $1; x; $2' as 'do join $1; $2'.+monadStep wrap o@(g@(LL _ (BindStmt _ (view' -> PVar_' p) x _ _)):q@(LL _ (BodyStmt _ (view' -> Var_' v) _ _)):xs)+  | p == v && v `notElem` varss' xs+  = let app = noLoc $ HsApp noExt (strToVar' "join") x+        body = noLoc $ BodyStmt noExt (rebracket1' app) noSyntaxExpr' noSyntaxExpr'+        stmts = body : xs+    in [warn' "Use join" (wrap o) (wrap stmts) r]+  where r = [Replace Stmt (toSS' g) [("x", toSS' x)] "join x", Delete Stmt (toSS' q)] --- do _ <- <return ()>; $1 ==> do <return ()>; $1-monadStep wrap o@(Generator an PWildCard{} x:rest)-    | returnsUnit x-    = [warn "Redundant variable capture" (wrap o) (wrap $ Qualifier an x : rest) []]+-- Redundant variable capture. Rewrite 'do _ <- <return ()>; $1' as+-- 'do <return ()>; $1'.+monadStep wrap (o@(LL loc (BindStmt _ p x _ _)) : rest)+    | isPWildCard' p, returnsUnit x+    = let body = cL loc $ BodyStmt noExt x noSyntaxExpr' noSyntaxExpr' :: ExprLStmt GhcPs+      in [warn' "Redundant variable capture" o body []] --- do <return ()>; return ()-monadStep wrap o@[Qualifier an x, Qualifier _ (fromRet -> Just (ret, unit))]-    | returnsUnit x, unit ~= "()"-    = [warn ("Redundant " ++ ret) (wrap o) (wrap $ take 1 o) []]+-- Redundant unit return : 'do <return ()>; return ()'.+monadStep+  wrap o@[ LL _ (BodyStmt _ x _ _)+         , LL _ (BodyStmt _ (fromRet -> Just (ret, LL _ (HsVar _ (L _ unit)))) _ _)]+     | returnsUnit x, occNameString (rdrNameOcc unit) == "()"+  = [warn' ("Redundant " ++ ret) (wrap o) (wrap $ take 1 o) []] --- do x <- $1; return $ f $ g x ==> f . g <$> x+-- Rewrite 'do x <- $1; return $ f $ g x' as 'f . g <$> x' monadStep wrap-    o@[g@(Generator _ (view -> PVar_ u) x)-      ,q@(Qualifier _ (fromApplies -> (ret:f:fs, view -> Var_ v)))]-        | isReturn ret, notDol x, u == v, length fs < 3, all isSimple (f:fs), v `notElem` vars (f:fs)-        = [warn "Use <$>" (wrap o) (wrap [Qualifier an (InfixApp an (foldl' (flip (InfixApp an) (toNamed ".")) f fs) (toNamed "<$>") x)])-            [Replace Stmt (toSS g) (("x", toSS x):zip vs (toSS <$> f:fs)) (intercalate " . " (take (length fs + 1) vs) ++ " <$> x"), Delete Stmt (toSS q)]]-    where-        isSimple (fromApps -> xs) = all isAtom (x:xs)-        vs = ('f':) . show <$> [0..]-        notDol (InfixApp _ _ op _) = not $ isDol op-        notDol _ = True+  o@[g@(LL _ (BindStmt _ (view' -> PVar_' u) x _ _))+    , q@(LL _ (BodyStmt _ (fromApplies -> (ret:f:fs, view' -> Var_' v)) _ _))]+  | isReturn' ret, notDol x, u == v, length fs < 3, all isSimple (f : fs), v `notElem` vars' (f : fs)+  =+      [warn' "Use <$>" (wrap o) (wrap [noLoc $ BodyStmt noExt (noLoc $ OpApp noExt (foldl' (\acc e -> noLoc $ OpApp noExt acc (strToVar' ".") e) f fs) (strToVar' "<$>") x) noSyntaxExpr' noSyntaxExpr'])+      [Replace Stmt (toSS' g) (("x", toSS' x):zip vs (toSS' <$> f:fs)) (intercalate " . " (take (length fs + 1) vs) ++ " <$> x"), Delete Stmt (toSS' q)]]+  where+    isSimple (fromApps' -> xs) = all isAtom' (x : xs)+    vs = ('f':) . show <$> [0..] +    notDol :: LHsExpr GhcPs -> Bool+    notDol (LL _ (OpApp _ _ op _)) = not $ isDol' op+    notDol _ = True+ monadStep _ _ = []  -- Suggest removing a return-monadSteps :: ([Stmt S] -> Exp_) -> [Stmt S] -> [Idea]-monadSteps wrap (x:xs) = monadStep wrap (x:xs) ++ monadSteps (wrap . (x :)) xs+monadSteps :: ([ExprLStmt GhcPs] -> LHsExpr GhcPs) -> [ExprLStmt GhcPs] -> [Idea]+monadSteps wrap (x : xs) = monadStep wrap (x : xs) ++ monadSteps (wrap . (x :)) xs monadSteps _ _ = [] ---- | do ...; x <- return y; ... ==> do ...; let x = y; ...-monadLet :: [Stmt S] -> Maybe ([Stmt S], [Refactoring R.SrcSpan])+-- | Rewrite 'do ...; x <- return y; ...' as 'do ...; let x = y; ...'.+monadLet :: [ExprLStmt GhcPs] -> Maybe ([ExprLStmt GhcPs], [Refactoring R.SrcSpan]) monadLet xs = if null rs then Nothing else Just (ys, rs)-    where-        (ys, catMaybes -> rs) = unzip $ map mkLet xs-        vs = concatMap pvars [p | Generator _ p _ <- xs]-        mkLet g@(Generator _ v@(view -> PVar_ p) (fromRet -> Just (_, y)))-            | p `notElem` vars y, p `notElem` delete p vs-            = (template (toNamed p) y, Just refact)-         where-            refact = Replace Stmt (toSS g) [("lhs", toSS v), ("rhs", toSS y)]-                      (prettyPrint $ template (toNamed "lhs") (toNamed "rhs"))-        mkLet x = (x, Nothing)-        template lhs rhs = LetStmt an $ BDecls an [PatBind an lhs (UnGuardedRhs an rhs) Nothing]+  where+    (ys, catMaybes -> rs) = unzip $ map mkLet xs+    vs = concatMap pvars' [p | (LL _ (BindStmt _ p _ _ _)) <- xs] +    mkLet :: ExprLStmt GhcPs -> (ExprLStmt GhcPs, Maybe (Refactoring R.SrcSpan))+    mkLet g@(LL _ (BindStmt _ v@(view' -> PVar_' p) (fromRet -> Just (_, y)) _ _ ))+      | p `notElem` vars' y, p `notElem` delete p vs+      = (template p y, Just refact)+      where+        refact = Replace Stmt (toSS' g) [("lhs", toSS' v), ("rhs", toSS' y)]+                      (unsafePrettyPrint $ template "lhs" (strToVar' "rhs"))+    mkLet x = (x, Nothing) -fromApplies :: Exp_ -> ([Exp_], Exp_)-fromApplies (App _ f x) = first (f:) $ fromApplies (fromParen x)-fromApplies (InfixApp _ f (isDol -> True) x) = first (f:) $ fromApplies x-fromApplies x = ([], x)+    template :: String -> LHsExpr GhcPs -> ExprLStmt GhcPs+    template lhs rhs =+        let p = noLoc $ mkRdrUnqual (mkVarOcc lhs)+            grhs = noLoc (GRHS noExt [] rhs)+            grhss = GRHSs noExt [grhs] (noLoc (EmptyLocalBinds noExt))+            match = noLoc $ Match noExt (FunRhs p Prefix NoSrcStrict) [] grhss+            fb = noLoc $ FunBind noExt p (MG noExt (noLoc [match]) Generated) WpHole []+            binds = unitBag fb+            valBinds = ValBinds noExt binds []+            localBinds = noLoc $ HsValBinds noExt valBinds+         in noLoc $ LetStmt noExt localBinds +fromApplies :: LHsExpr GhcPs -> ([LHsExpr GhcPs], LHsExpr GhcPs)+fromApplies (LL _ (HsApp _ f x)) = first (f:) $ fromApplies (fromParen' x)+fromApplies (LL _ (OpApp _ f (isDol' -> True) x)) = first (f:) $ fromApplies x+fromApplies x = ([], x) --- | Match @return x@ to @Just x@.-fromRet :: Exp_ -> Maybe (String, Exp_)-fromRet (Paren _ x) = fromRet x-fromRet (InfixApp _ x y z) | opExp y ~= "$" = fromRet $ App an x z-fromRet (App _ x y) | isReturn x = Just (prettyPrint x, y)+fromRet :: LHsExpr GhcPs -> Maybe (String, LHsExpr GhcPs)+fromRet (LL _ (HsPar _ x)) = fromRet x+fromRet (LL _ (OpApp _ x (LL _ (HsVar _ (L _ y))) z)) | occNameString (rdrNameOcc y) == "$" = fromRet $ noLoc (HsApp noExt x z)+fromRet (LL _ (HsApp _ x y)) | isReturn' x = Just (unsafePrettyPrint x, y) fromRet _ = Nothing
src/Hint/Naming.hs view
@@ -82,7 +82,7 @@         replacedDecl = replaceNames suggestedNames originalDecl  shorten :: LHsDecl GhcPs -> LHsDecl GhcPs-shorten (LL locDecl (ValD ttg0 bind@(FunBind _ _ matchGroup@(MG _ (LL locMatches matches) _) _ _))) =+shorten (LL locDecl (ValD ttg0 bind@(FunBind _ _ matchGroup@(MG _ (LL locMatches matches) FromSource) _ _))) =     LL locDecl (ValD ttg0 bind {fun_matches = matchGroup {mg_alts = LL locMatches $ map shortenMatch matches}}) shorten (LL locDecl (ValD ttg0 bind@(PatBind _ _ grhss@(GRHSs _ rhss _) _))) =     LL locDecl (ValD ttg0 bind {pat_rhs = grhss {grhssGRHSs = map shortenLGRHS rhss}})@@ -102,8 +102,7 @@ shortenLGRHS x = x  getNames :: LHsDecl GhcPs -> [String]-getNames (LL _ decl) = maybeToList (declName decl) ++ getConstructorNames decl-getNames _ = [] -- {-# COMPLETE LL #-}+getNames decl = maybeToList (declName decl) ++ getConstructorNames (unLoc decl)  getConstructorNames :: HsDecl GhcPs -> [String] getConstructorNames (TyClD _ (DataDecl _ _ _ _ (HsDataDefn _ _ _ _ _ cons _))) =
src/Hint/Pattern.hs view
@@ -55,56 +55,41 @@  module Hint.Pattern(patternHint) where -import Hint.Type+import Hint.Type(DeclHint',Idea,ghcAnnotations,ideaTo,toSS',toRefactSrcSpan,ghcSpanToHSE,suggest',warn')+import Data.Generics.Uniplate.Operations import Data.Function import Data.List.Extra import Data.Tuple import Data.Maybe import Data.Either-import Refact.Types hiding (RType(Pattern, Match))+import Refact.Types hiding (RType(Pattern, Match), SrcSpan) import qualified Refact.Types as R (RType(Pattern, Match), SrcSpan) +import HsSyn+import SrcLoc+import RdrName+import OccName+import Bag+import BasicTypes -patternHint :: DeclHint-patternHint _ modu x =+import GHC.Util++patternHint :: DeclHint'+patternHint _scope modu x =     concatMap (uncurry hints . swap) (asPattern x) ++-    -- PatBind (used in Let and Where) contains lazy-by-default patterns, everything else is strict-    concatMap (patHint strict False) (universeBi [p | PatBind _ p _ _ <- universe x]) ++-    concatMap (patHint strict True) (universeBi $ transform noPatBind x) +++    -- PatBind (used in 'let' and 'where') contains lazy-by-default+    -- patterns, everything else is strict.+    concatMap (patHint strict False) (located [p | PatBind _ p _ _ <- universeBi x :: [HsBind GhcPs]]) +++    concatMap (patHint strict True) (located (universeBi $ transformBi noPatBind x)) ++     concatMap expHint (universeBi x)-    where-        noPatBind (PatBind a _ b c) = PatBind a (PWildCard a) b c-        noPatBind x = x--        strict = "Strict" `elem` [n | LanguagePragma _ ns <- modulePragmas (hseModule modu), Ident _ n <- ns]-+  where+    located ps = [p | p@XPat{} <- ps]  -- restrict attention to patterns with locs+    exts = nubOrd $ concatMap snd (langExts (pragmas (ghcAnnotations modu))) -- language extensions enabled at source+    strict = "Strict" `elem` exts -hints :: (String -> Pattern -> [Refactoring R.SrcSpan] -> Idea) -> Pattern -> [Idea]-hints gen (Pattern l rtype pat (UnGuardedRhs d bod) bind)-    | length guards > 2 = [gen "Use guards" (Pattern l rtype pat (GuardedRhss d guards) bind) [refactoring]]-    where rawGuards = asGuards bod-          mkGuard a = GuardedRhs an [Qualifier an a]-          guards = map (uncurry mkGuard) rawGuards-          (lhs, rhs) = unzip rawGuards-          mkTemplate c ps =-            -- Check if the expression has been injected or is natural-            let checkAn p v = if ann p == an then Left p else Right ( c ++ [v], toSS p)-            in zipWith checkAn ps ['1' .. '9']-          patSubts = case pat of-                       [p] -> [Left p] -- Substitution doesn't work properly for PatBinds-                                       -- This will probably produce-                                       -- unexpected results if the pattern-                                       -- contains any template variables-                       ps  -> mkTemplate "p100" ps-          guardSubts = mkTemplate "g100" lhs-          exprSubts  = mkTemplate "e100" rhs-          templateGuards = zipWith (mkGuard `on` toString) guardSubts exprSubts-          toString (Left e) = e-          toString (Right (v, _)) = toNamed v-          template = fromMaybe "" $ ideaTo (gen "" (Pattern l rtype (map toString patSubts) (GuardedRhss d templateGuards) bind) [])-          f :: [Either a (String, R.SrcSpan)] -> [(String, R.SrcSpan)]-          f = rights-          refactoring = Replace rtype (toRefactSrcSpan $ srcInfoSpan l) (f patSubts ++ f guardSubts ++ f exprSubts) template+    noPatBind :: LHsBind GhcPs -> LHsBind GhcPs+    noPatBind (LL loc a@PatBind{}) = cL loc a{pat_lhs=noLoc (WildPat noExt)}+    noPatBind x = x  {- -- Do not suggest view patterns, they aren't something everyone likes sufficiently@@ -118,81 +103,134 @@         decsBind = nub $ concatMap declBind $ childrenBi bind -} -hints gen (Pattern l t pats (GuardedRhss _ [GuardedRhs _ [test] bod]) bind)-    | prettyPrint test `elem` ["otherwise","True"]-    = [gen "Redundant guard" (Pattern l t pats (UnGuardedRhs an bod) bind) [Delete Stmt (toSS test)]]+hints :: (String -> Pattern -> [Refactoring R.SrcSpan] -> Idea) -> Pattern -> [Idea]+hints gen (Pattern l rtype pat (GRHSs _ [LL _ (GRHS _ [] bod)] bind))+  | length guards > 2 = [gen "Use guards" (Pattern l rtype pat (GRHSs noExt guards bind)) [refactoring]]+  where+    rawGuards :: [(LHsExpr GhcPs, LHsExpr GhcPs)]+    rawGuards = asGuards bod -hints gen (Pattern l t pats bod (Just bind)) | f bind-    = [gen "Redundant where" (Pattern l t pats bod Nothing) []]-    where-        f (BDecls _ x) = null x-        f (IPBinds _ x) = null x+    mkGuard :: LHsExpr GhcPs -> (LHsExpr GhcPs -> GRHS GhcPs (LHsExpr GhcPs))+    mkGuard a = GRHS noExt [noLoc $ BodyStmt noExt a noSyntaxExpr' noSyntaxExpr'] -hints gen (Pattern l t pats (GuardedRhss _ (unsnoc -> Just (gs, GuardedRhs _ [test] bod))) bind)-    | prettyPrint test == "True"-    = [gen "Use otherwise" (Pattern l t pats (GuardedRhss an $ gs ++ [GuardedRhs an [Qualifier an $ toNamed "otherwise"] bod]) bind) [Replace Expr (toSS test) [] "otherwise"]]+    guards :: [LGRHS GhcPs (LHsExpr GhcPs)]+    guards = map (noLoc . uncurry mkGuard) rawGuards -hints _ _ = []+    (lhs, rhs) = unzip rawGuards +    mkTemplate c ps =+      -- Check if the expression has been injected or is natural.+      zipWith checkLoc ps ['1' .. '9']+      where+        checkLoc p@(LL l _) v = if l == noSrcSpan then Left p else Right (c ++ [v], toSS' p)+        checkLoc _ v = undefined -- {-# COMPLETE LL #-} -asGuards :: Exp_ -> [(Exp S, Exp S)]-asGuards (Paren _ x) = asGuards x-asGuards (If _ a b c) = (a, b) : asGuards c-asGuards x = [(toNamed "otherwise", x)]+    patSubts =+      case pat of+        [p] -> [Left p] -- Substitution doesn't work properly for PatBinds.+                        -- This will probably produce unexpected results if the pattern contains any template variables.+        ps  -> mkTemplate "p100" ps+    guardSubts = mkTemplate "g100" lhs+    exprSubts  = mkTemplate "e100" rhs+    templateGuards = map noLoc (zipWith (mkGuard `on` toString) guardSubts exprSubts) +    toString (Left e) = e+    toString (Right (v, _)) = strToVar' v+    toString' (Left e) = e+    toString' (Right (v, _)) = strToPat' v -data Pattern = Pattern S R.RType [Pat_] (Rhs S) (Maybe (Binds S))+    template = fromMaybe "" $ ideaTo (gen "" (Pattern l rtype (map toString' patSubts) (GRHSs noExt templateGuards bind)) []) --- Invariant: Number of patterns may not change-asPattern :: Decl_ -> [(Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)]-asPattern x = concatMap decl (universeBi x) ++ concatMap alt (universeBi x)-    where-        decl o@(PatBind a pat rhs bind) = [(Pattern a Bind [pat] rhs bind, \msg (Pattern _ _ [pat] rhs bind) rs -> suggest msg o (PatBind a pat rhs bind) rs)]-        decl (FunBind _ xs) = map match xs-        decl _ = []-        match o@(Match a b pat rhs bind) = (Pattern a R.Match pat rhs bind, \msg (Pattern _ _ pat rhs bind) rs -> suggest msg o (Match a b pat rhs bind) rs)-        match o@(InfixMatch a p b ps rhs bind) = (Pattern a R.Match (p:ps) rhs bind, \msg (Pattern _ _ (p:ps) rhs bind) rs -> suggest msg o (InfixMatch a p b ps rhs bind) rs)-        alt o@(Alt a pat rhs bind) = [(Pattern a R.Match [pat] rhs bind, \msg (Pattern _ _ [pat] rhs bind) rs -> suggest msg o (Alt a pat rhs bind) [])]+    f :: [Either a (String, R.SrcSpan)] -> [(String, R.SrcSpan)]+    f = rights+    refactoring = Replace rtype (toRefactSrcSpan$ ghcSpanToHSE l) (f patSubts ++ f guardSubts ++ f exprSubts) template+hints gen (Pattern l t pats o@(GRHSs _ [LL _ (GRHS _ [test] bod)] bind))+  | unsafePrettyPrint test `elem` ["otherwise", "True"]+  = [gen "Redundant guard" (Pattern l t pats o{grhssGRHSs=[noLoc (GRHS noExt [] bod)]}) [Delete Stmt (toSS' test)]]+hints gen (Pattern l t pats bod@(GRHSs _ _ binds)) | f binds+  = [gen "Redundant where" (Pattern l t pats bod{grhssLocalBinds=noLoc (EmptyLocalBinds noExt)}) []]+  where+    f :: LHsLocalBinds GhcPs -> Bool+    f (LL _ (HsValBinds _ (ValBinds _ bag _))) = isEmptyBag bag+    f (LL _ (HsIPBinds _ (IPBinds _ l))) = null l+    f _ = False+hints gen (Pattern l t pats o@(GRHSs _ (unsnoc -> Just (gs, LL _ (GRHS _ [test] bod))) binds))+  | unsafePrettyPrint test == "True"+  = let tag = noLoc (mkRdrUnqual $ mkVarOcc "otherwise")+        otherwise_ = noLoc $ BodyStmt noExt (noLoc (HsVar noExt tag)) noSyntaxExpr' noSyntaxExpr' in+      [gen "Use otherwise" (Pattern l t pats o{grhssGRHSs = gs ++ [noLoc (GRHS noExt [otherwise_] bod)]}) [Replace Expr (toSS' test) [] "otherwise"]]+hints _ _ = [] +asGuards :: LHsExpr GhcPs -> [(LHsExpr GhcPs, LHsExpr GhcPs)]+asGuards (LL _ (HsPar _ x)) = asGuards x+asGuards (LL _ (HsIf _ _ a b c)) = (a, b) : asGuards c+asGuards x = [(noLoc (HsVar noExt (noLoc (mkRdrUnqual $ mkVarOcc "otherwise"))), x)] --- First Bool is if Strict is a language extension--- Second Bool is if this pattern in this context is going to be evaluated strictly-patHint :: Bool -> Bool -> Pat_ -> [Idea]-patHint lang strict o@(PApp _ name args) | length args >= 3 && all isPWildCard args =-  [suggest "Use record patterns" o (PRec an name []) [Replace R.Pattern (toSS o) [] (prettyPrint $ PRec an name [])] ]-patHint lang strict o@(PVar _ v) | prettyPrint v == "otherwise" = [warn "Used otherwise as a pattern" o (PWildCard an) []]+data Pattern = Pattern SrcSpan R.RType [Pat GhcPs] (GRHSs GhcPs (LHsExpr GhcPs)) -patHint lang strict o@(PBangPat _ x) | strict, f x = [warn "Redundant bang pattern" o x [r]]-    where f (PParen _ x) = f x-          f (PAsPat _ _ x) = f x-          f PLit{} = True-          f PApp{} = True-          f PInfixApp{} = True-          f PTuple{} = True-          f PList{} = True-          f PRec{} = True-          f (PatTypeSig _ x _) = f x-          f _ = False-          r = Replace R.Pattern (toSS o) [("x", toSS x)] "x"-patHint False strict o@(PIrrPat _ x) | f x = [warn "Redundant irrefutable pattern" o x [r]]-    where f (PParen _ x) = f x-          f (PAsPat _ _ x) = f x-          f PWildCard{} = True-          f PVar{} = True-          f _ = False-          r = Replace R.Pattern (toSS o) [("x", toSS x)] "x"-patHint lang strict o@(PAsPat u v PWildCard{}) = [warn "Redundant as-pattern" o v []]-patHint _ _ _ = []+-- Invariant: Number of patterns may not change+asPattern :: LHsDecl GhcPs  -> [(Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)]+asPattern (LL loc x) = concatMap decl (universeBi x)+  where+    decl :: HsBind GhcPs -> [(Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)]+    decl o@(PatBind _ pat rhs _) = [(Pattern loc Bind [pat] rhs, \msg (Pattern _ _ [pat] rhs) rs -> suggest' msg (cL loc o :: LHsBind GhcPs) (noLoc (PatBind noExt pat rhs ([], [])) :: LHsBind GhcPs) rs)]+    decl (FunBind _ _ (MG _ (LL _ xs) _) _ _) = map match xs+    decl _ = [] +    match :: LMatch GhcPs (LHsExpr GhcPs) -> (Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)+    match o@(LL loc (Match _ ctx pats grhss)) = (Pattern loc R.Match pats grhss, \msg (Pattern _ _ pats grhss) rs -> suggest' msg o (noLoc (Match noExt ctx  pats grhss) :: LMatch GhcPs (LHsExpr GhcPs)) rs)+    match _ = undefined -- {-# COMPLETE LL #-}+asPattern _ = [] -- {-# COMPLETE LL #-} -expHint :: Exp_ -> [Idea]-expHint o@(Case _ _ [Alt _ PWildCard{} (UnGuardedRhs _ e) Nothing]) =-  [suggest "Redundant case" o e [r]]+-- First Bool is if 'Strict' is a language extension. Second Bool is+-- if this pattern in this context is going to be evaluated strictly.+patHint :: Bool -> Bool -> Pat GhcPs -> [Idea]+patHint _ _ o@(LL _ (ConPatIn name (PrefixCon args)))+  | length args >= 3 && all isPWildCard' args =+  let rec_fields = HsRecFields [] Nothing :: HsRecFields GhcPs (Pat GhcPs)+      new        = ConPatIn name (RecCon rec_fields) :: Pat GhcPs+  in+  [suggest' "Use record patterns" o new [Replace R.Pattern (toSS' o) [] (unsafePrettyPrint new)]]+patHint _ _ o@(LL _ (VarPat _ (L _ name)))+  | occNameString (rdrNameOcc name) == "otherwise" =+    [warn' "Used otherwise as a pattern" o (noLoc (WildPat noExt) :: Pat GhcPs) []]+patHint lang strict o@(LL _ (BangPat _ (LL _ x)))+  | strict, f x = [warn' "Redundant bang pattern" o x [r]]   where-    r = Replace Expr (toSS o) [("x", toSS e)] "x"-expHint o@(Case _ (Var _ x) [Alt _ (PVar _ y) (UnGuardedRhs _ e) Nothing])-    | x =~= UnQual an y =-      [suggest "Redundant case" o e [r]]+    f :: Pat GhcPs -> Bool+    f (ParPat _ (LL _ x)) = f x+    f (AsPat _ _ (LL _ x)) = f x+    f LitPat {} = True+    f NPat {} = True+    f ConPatIn {} = True+    f TuplePat {} = True+    f ListPat {} = True+    f (SigPat _ (LL _ p) _) = f p+    f _ = False+    r = Replace R.Pattern (toSS' o) [("x", toSS' x)] "x"+patHint False _ o@(LL _ (LazyPat _ (LL _ x)))+  | f x = [warn' "Redundant irrefutable pattern" o x [r]]   where-    r = Replace Expr (toSS o) [("x", toSS e)] "x"+    f :: Pat GhcPs -> Bool+    f (ParPat _ (LL _ x)) = f x+    f (AsPat _ _ (LL _ x)) = f x+    f WildPat{} = True+    f VarPat{} = True+    f _ = False+    r = Replace R.Pattern (toSS' o) [("x", toSS' x)] "x"+patHint _ _ o@(LL _ (AsPat _ v (LL _ (WildPat _)))) =+  [warn' "Redundant as-pattern" o v []]+patHint _ _ _ = []++expHint :: LHsExpr GhcPs -> [Idea]+ -- Note the 'FromSource' in these equations (don't warn on generated match groups).+expHint o@(LL _ (HsCase _ _ (MG _ (L _ [LL _ (Match _ CaseAlt [LL _ (WildPat _)] (GRHSs _ [LL _ (GRHS _ [] e)] (LL  _ (EmptyLocalBinds _)))) ]) FromSource ))) =+  [suggest' "Redundant case" o e [r]]+  where+    r = Replace Expr (toSS' o) [("x", toSS' e)] "x"+expHint o@(LL _ (HsCase _ (LL _ (HsVar _ (L _ x))) (MG _ (L _ [LL _ (Match _ CaseAlt [LL _ (VarPat _ (L _ y))] (GRHSs _ [LL _ (GRHS _ [] e)] (LL  _ (EmptyLocalBinds _)))) ]) FromSource )))+  | occNameString (rdrNameOcc x) == occNameString (rdrNameOcc y) =+      [suggest' "Redundant case" o e [r]]+  where+    r = Replace Expr (toSS' o) [("x", toSS' e)] "x" expHint _ = []
src/Hint/Restrict.hs view
@@ -119,7 +119,7 @@ checkFunctions modu decls (def, mp) =     [ (ideaMessage riMessage $ ideaNoTo $ warn' "Avoid restricted function" x x []){ideaDecl = [dname]}     | d <- decls-    , let dname = fromMaybe "" (declName (unLoc d))+    , let dname = fromMaybe "" (declName d)     , x <- universeBi d :: [Located RdrName]     , let ri@RestrictItem{..} = Map.findWithDefault (RestrictItem [] [("","") | def] Nothing) (occNameString (rdrNameOcc (unLoc x))) mp     , not $ within modu dname ri
src/Hint/Smell.hs view
@@ -132,7 +132,8 @@ declSpans    (LL _ (ValD _      FunBind {fun_matches=MG {-                  mg_alts=(LL _ [LL _ Match {+                   mg_origin=FromSource+                 , mg_alts=(LL _ [LL _ Match {                        m_ctxt=ctx                      , m_grhss=GRHSs{grhssGRHSs=[locGrhs]                                  , grhssLocalBinds=where_}}])}})) =
src/Hint/Unsafe.hs view
@@ -52,7 +52,7 @@      -- 'x' does not declare a new function.      | d@(ValD _            FunBind {fun_id=L _ (Unqual x)-                      , fun_matches=MG{mg_alts=L _ [L _ Match {m_pats=[]}]}}) <- [d]+                      , fun_matches=MG{mg_origin=FromSource,mg_alts=L _ [L _ Match {m_pats=[]}]}}) <- [d]      -- 'x' is a synonym for an appliciation involing 'unsafePerformIO'      , isUnsafeDecl d      -- 'x' is not marked 'NOINLINE'.@@ -68,7 +68,7 @@         ) <- hsmodDecls m]  isUnsafeDecl :: HsDecl GhcPs -> Bool-isUnsafeDecl (ValD _ FunBind {fun_matches=MG {mg_alts=LL _ alts}}) =+isUnsafeDecl (ValD _ FunBind {fun_matches=MG {mg_origin=FromSource,mg_alts=LL _ alts}}) =   any isUnsafeApp (childrenBi alts) || any isUnsafeDecl (childrenBi alts) isUnsafeDecl _ = False