1{-# LANGUAGE ViewPatterns, PatternGuards, TypeFamilies #-} 2 3{- 4 Improve the structure of code 5 6<TEST> 7yes x y = if a then b else if c then d else e -- yes x y ; | a = b ; | c = d ; | otherwise = e 8x `yes` y = if a then b else if c then d else e -- x `yes` y ; | a = b ; | c = d ; | otherwise = e 9no x y = if a then b else c 10-- foo b | c <- f b = c -- foo (f -> c) = c 11-- foo x y b z | c:cs <- f g b = c -- foo x y (f g -> c:cs) z = c 12foo b | c <- f b = c + b 13foo b | c <- f b = c where f = here 14foo b | c <- f b = c where foo = b 15foo b | c <- f b = c \ 16 | c <- f b = c 17foo x = yes x x where yes x y = if a then b else if c then d else e -- yes x y ; | a = b ; | c = d ; | otherwise = e 18foo x | otherwise = y -- foo x = y 19foo x = x + x where -- 20foo x | a = b | True = d -- foo x | a = b ; | otherwise = d 21foo (Bar _ _ _ _) = x -- Bar{} 22foo (Bar _ x _ _) = x 23foo (Bar _ _) = x 24foo = case f v of _ -> x -- x 25foo = case v of v -> x -- x 26foo = case v of z -> z 27foo = case v of _ | False -> x 28foo x | x < -2 * 3 = 4 29foo = case v of !True -> x -- True 30{-# LANGUAGE BangPatterns #-}; foo = case v of !True -> x -- True 31{-# LANGUAGE BangPatterns #-}; foo = case v of !(Just x) -> x -- (Just x) 32{-# LANGUAGE BangPatterns #-}; foo = case v of !(x : xs) -> x -- (x:xs) 33{-# LANGUAGE BangPatterns #-}; foo = case v of !1 -> x -- 1 34{-# LANGUAGE BangPatterns #-}; foo = case v of !x -> x 35{-# LANGUAGE BangPatterns #-}; foo = case v of !(I# x) -> y -- (I# x) 36foo = let ~x = 1 in y -- x 37foo = let ~(x:xs) = y in z 38{-# LANGUAGE BangPatterns #-}; foo = let !x = undefined in y 39{-# LANGUAGE BangPatterns #-}; foo = let !(I# x) = 4 in x 40{-# LANGUAGE BangPatterns #-}; foo = let !(Just x) = Nothing in 3 41{-# LANGUAGE BangPatterns #-}; foo = 1 where f !False = 2 -- False 42{-# LANGUAGE BangPatterns #-}; foo = 1 where !False = True 43{-# LANGUAGE BangPatterns #-}; foo = 1 where g (Just !True) = Nothing -- True 44{-# LANGUAGE BangPatterns #-}; foo = 1 where Just !True = Nothing 45foo otherwise = 1 -- _ 46foo ~x = y -- x 47{-# LANGUAGE Strict #-} foo ~x = y 48{-# LANGUAGE BangPatterns #-}; foo !(x, y) = x -- (x, y) 49{-# LANGUAGE BangPatterns #-}; foo ![x] = x -- [x] 50foo !Bar { bar = x } = x -- Bar { bar = x } 51{-# LANGUAGE BangPatterns #-}; l !(() :: ()) = x -- (() :: ()) 52foo x@_ = x -- x 53foo x@Foo = x 54otherwise = True 55</TEST> 56-} 57 58 59module Hint.Pattern(patternHint) where 60 61import Hint.Type(DeclHint,Idea,ghcAnnotations,ideaTo,toSS,toRefactSrcSpan,suggest,suggestRemove,warn) 62import Data.Generics.Uniplate.DataOnly 63import Data.Function 64import Data.List.Extra 65import Data.Tuple 66import Data.Maybe 67import Data.Either 68import Refact.Types hiding (RType(Pattern, Match), SrcSpan) 69import qualified Refact.Types as R (RType(Pattern, Match), SrcSpan) 70 71import GHC.Hs 72import SrcLoc 73import RdrName 74import OccName 75import Bag 76import BasicTypes 77 78import GHC.Util 79import Language.Haskell.GhclibParserEx.GHC.Hs.Pat 80import Language.Haskell.GhclibParserEx.GHC.Hs.Expr 81import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable 82import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader 83 84patternHint :: DeclHint 85patternHint _scope modu x = 86 concatMap (uncurry hints . swap) (asPattern x) ++ 87 -- PatBind (used in 'let' and 'where') contains lazy-by-default 88 -- patterns, everything else is strict. 89 concatMap (patHint strict False) [p | PatBind _ p _ _ <- universeBi x :: [HsBind GhcPs]] ++ 90 concatMap (patHint strict True) (universeBi $ transformBi noPatBind x) ++ 91 concatMap expHint (universeBi x) 92 where 93 exts = nubOrd $ concatMap snd (languagePragmas (pragmas (ghcAnnotations modu))) -- language extensions enabled at source 94 strict = "Strict" `elem` exts 95 96 noPatBind :: LHsBind GhcPs -> LHsBind GhcPs 97 noPatBind (L loc a@PatBind{}) = L loc a{pat_lhs=noLoc (WildPat noExtField)} 98 noPatBind x = x 99 100{- 101-- Do not suggest view patterns, they aren't something everyone likes sufficiently 102hints gen (Pattern pats (GuardedRhss _ [GuardedRhs _ [Generator _ pat (App _ op (view -> Var_ p))] bod]) bind) 103 | Just i <- findIndex (=~= (toNamed p :: Pat_)) pats 104 , p `notElem` (vars bod ++ vars bind) 105 , vars op `disjoint` decsBind, pvars pats `disjoint` vars op, pvars pat `disjoint` pvars pats 106 = [gen "Use view patterns" $ 107 Pattern (take i pats ++ [PParen an $ PViewPat an op pat] ++ drop (i+1) pats) (UnGuardedRhs an bod) bind] 108 where 109 decsBind = nub $ concatMap declBind $ childrenBi bind 110-} 111 112hints :: (String -> Pattern -> [Refactoring R.SrcSpan] -> Idea) -> Pattern -> [Idea] 113hints gen (Pattern l rtype pat (GRHSs _ [L _ (GRHS _ [] bod)] bind)) 114 | length guards > 2 = [gen "Use guards" (Pattern l rtype pat (GRHSs noExtField guards bind)) [refactoring]] 115 where 116 rawGuards :: [(LHsExpr GhcPs, LHsExpr GhcPs)] 117 rawGuards = asGuards bod 118 119 mkGuard :: LHsExpr GhcPs -> (LHsExpr GhcPs -> GRHS GhcPs (LHsExpr GhcPs)) 120 mkGuard a = GRHS noExtField [noLoc $ BodyStmt noExtField a noSyntaxExpr noSyntaxExpr] 121 122 guards :: [LGRHS GhcPs (LHsExpr GhcPs)] 123 guards = map (noLoc . uncurry mkGuard) rawGuards 124 125 (lhs, rhs) = unzip rawGuards 126 127 mkTemplate c ps = 128 -- Check if the expression has been injected or is natural. 129 zipWith checkLoc ps ['1' .. '9'] 130 where 131 checkLoc p@(L l _) v = if l == noSrcSpan then Left p else Right (c ++ [v], toSS p) 132 133 patSubts = 134 case pat of 135 [p] -> [Left p] -- Substitution doesn't work properly for PatBinds. 136 -- This will probably produce unexpected results if the pattern contains any template variables. 137 ps -> mkTemplate "p100" ps 138 guardSubts = mkTemplate "g100" lhs 139 exprSubts = mkTemplate "e100" rhs 140 templateGuards = map noLoc (zipWith (mkGuard `on` toString) guardSubts exprSubts) 141 142 toString (Left e) = e 143 toString (Right (v, _)) = strToVar v 144 toString' (Left e) = e 145 toString' (Right (v, _)) = strToPat v 146 147 template = fromMaybe "" $ ideaTo (gen "" (Pattern l rtype (map toString' patSubts) (GRHSs noExtField templateGuards bind)) []) 148 149 f :: [Either a (String, R.SrcSpan)] -> [(String, R.SrcSpan)] 150 f = rights 151 refactoring = Replace rtype (toRefactSrcSpan l) (f patSubts ++ f guardSubts ++ f exprSubts) template 152hints gen (Pattern l t pats o@(GRHSs _ [L _ (GRHS _ [test] bod)] bind)) 153 | unsafePrettyPrint test `elem` ["otherwise", "True"] 154 = [gen "Redundant guard" (Pattern l t pats o{grhssGRHSs=[noLoc (GRHS noExtField [] bod)]}) [Delete Stmt (toSS test)]] 155hints _ (Pattern l t pats bod@(GRHSs _ _ binds)) | f binds 156 = [suggestRemove "Redundant where" whereSpan "where" [ {- TODO refactoring for redundant where -} ]] 157 where 158 f :: LHsLocalBinds GhcPs -> Bool 159 f (L _ (HsValBinds _ (ValBinds _ bag _))) = isEmptyBag bag 160 f (L _ (HsIPBinds _ (IPBinds _ l))) = null l 161 f _ = False 162 whereSpan = case l of 163 UnhelpfulSpan s -> UnhelpfulSpan s 164 RealSrcSpan s -> 165 let end = realSrcSpanEnd s 166 start = mkRealSrcLoc (srcSpanFile s) (srcLocLine end) (srcLocCol end - 5) 167 in RealSrcSpan (mkRealSrcSpan start end) 168hints gen (Pattern l t pats o@(GRHSs _ (unsnoc -> Just (gs, L _ (GRHS _ [test] bod))) binds)) 169 | unsafePrettyPrint test == "True" 170 = let otherwise_ = noLoc $ BodyStmt noExtField (strToVar "otherwise") noSyntaxExpr noSyntaxExpr in 171 [gen "Use otherwise" (Pattern l t pats o{grhssGRHSs = gs ++ [noLoc (GRHS noExtField [otherwise_] bod)]}) [Replace Expr (toSS test) [] "otherwise"]] 172hints _ _ = [] 173 174asGuards :: LHsExpr GhcPs -> [(LHsExpr GhcPs, LHsExpr GhcPs)] 175asGuards (L _ (HsPar _ x)) = asGuards x 176asGuards (L _ (HsIf _ _ a b c)) = (a, b) : asGuards c 177asGuards x = [(strToVar "otherwise", x)] 178 179data Pattern = Pattern SrcSpan R.RType [LPat GhcPs] (GRHSs GhcPs (LHsExpr GhcPs)) 180 181-- Invariant: Number of patterns may not change 182asPattern :: LHsDecl GhcPs -> [(Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)] 183asPattern (L loc x) = concatMap decl (universeBi x) 184 where 185 decl :: HsBind GhcPs -> [(Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)] 186 decl o@(PatBind _ pat rhs _) = [(Pattern loc Bind [pat] rhs, \msg (Pattern _ _ [pat] rhs) rs -> suggest msg (L loc o :: LHsBind GhcPs) (noLoc (PatBind noExtField pat rhs ([], [])) :: LHsBind GhcPs) rs)] 187 decl (FunBind _ _ (MG _ (L _ xs) _) _ _) = map match xs 188 decl _ = [] 189 190 match :: LMatch GhcPs (LHsExpr GhcPs) -> (Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea) 191 match o@(L loc (Match _ ctx pats grhss)) = (Pattern loc R.Match pats grhss, \msg (Pattern _ _ pats grhss) rs -> suggest msg o (noLoc (Match noExtField ctx pats grhss) :: LMatch GhcPs (LHsExpr GhcPs)) rs) 192 match _ = undefined -- {-# COMPLETE L #-} 193 194-- First Bool is if 'Strict' is a language extension. Second Bool is 195-- if this pattern in this context is going to be evaluated strictly. 196patHint :: Bool -> Bool -> LPat GhcPs -> [Idea] 197patHint _ _ o@(L _ (ConPatIn name (PrefixCon args))) 198 | length args >= 3 && all isPWildcard args = 199 let rec_fields = HsRecFields [] Nothing :: HsRecFields GhcPs (LPat GhcPs) 200 new = noLoc $ ConPatIn name (RecCon rec_fields) :: LPat GhcPs 201 in 202 [suggest "Use record patterns" o new [Replace R.Pattern (toSS o) [] (unsafePrettyPrint new)]] 203patHint _ _ o@(L _ (VarPat _ (L _ name))) 204 | occNameString (rdrNameOcc name) == "otherwise" = 205 [warn "Used otherwise as a pattern" o (noLoc (WildPat noExtField) :: LPat GhcPs) []] 206patHint lang strict o@(L _ (BangPat _ pat@(L _ x))) 207 | strict, f x = [warn "Redundant bang pattern" o (noLoc x :: LPat GhcPs) [r]] 208 where 209 f :: Pat GhcPs -> Bool 210 f (ParPat _ (L _ x)) = f x 211 f (AsPat _ _ (L _ x)) = f x 212 f LitPat {} = True 213 f NPat {} = True 214 f ConPatIn {} = True 215 f TuplePat {} = True 216 f ListPat {} = True 217 f (SigPat _ (L _ p) _) = f p 218 f _ = False 219 r = Replace R.Pattern (toSS o) [("x", toSS pat)] "x" 220patHint False _ o@(L _ (LazyPat _ pat@(L _ x))) 221 | f x = [warn "Redundant irrefutable pattern" o (noLoc x :: LPat GhcPs) [r]] 222 where 223 f :: Pat GhcPs -> Bool 224 f (ParPat _ (L _ x)) = f x 225 f (AsPat _ _ (L _ x)) = f x 226 f WildPat{} = True 227 f VarPat{} = True 228 f _ = False 229 r = Replace R.Pattern (toSS o) [("x", toSS pat)] "x" 230patHint _ _ o@(L _ (AsPat _ v (L _ (WildPat _)))) = 231 [warn "Redundant as-pattern" o v [Replace R.Pattern (toSS o) [] (rdrNameStr v)]] 232patHint _ _ _ = [] 233 234expHint :: LHsExpr GhcPs -> [Idea] 235 -- Note the 'FromSource' in these equations (don't warn on generated match groups). 236expHint o@(L _ (HsCase _ _ (MG _ (L _ [L _ (Match _ CaseAlt [L _ (WildPat _)] (GRHSs _ [L _ (GRHS _ [] e)] (L _ (EmptyLocalBinds _)))) ]) FromSource ))) = 237 [suggest "Redundant case" o e [r]] 238 where 239 r = Replace Expr (toSS o) [("x", toSS e)] "x" 240expHint o@(L _ (HsCase _ (L _ (HsVar _ (L _ x))) (MG _ (L _ [L _ (Match _ CaseAlt [L _ (VarPat _ (L _ y))] (GRHSs _ [L _ (GRHS _ [] e)] (L _ (EmptyLocalBinds _)))) ]) FromSource ))) 241 | occNameStr x == occNameStr y = 242 [suggest "Redundant case" o e [r]] 243 where 244 r = Replace Expr (toSS o) [("x", toSS e)] "x" 245expHint _ = [] 246