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 GHC.Types.SrcLoc
73import GHC.Types.Name.Reader
74import GHC.Types.Name.Occurrence
75import GHC.Data.Bag
76import GHC.Types.Basic
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) Nothing
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
193-- First Bool is if 'Strict' is a language extension. Second Bool is
194-- if this pattern in this context is going to be evaluated strictly.
195patHint :: Bool -> Bool -> LPat GhcPs -> [Idea]
196patHint _ _ o@(L _ (ConPat _ name (PrefixCon args)))
197  | length args >= 3 && all isPWildcard args =
198  let rec_fields = HsRecFields [] Nothing :: HsRecFields GhcPs (LPat GhcPs)
199      new        = noLoc $ ConPat noExtField name (RecCon rec_fields) :: LPat GhcPs
200  in
201  [suggest "Use record patterns" o new [Replace R.Pattern (toSS o) [] (unsafePrettyPrint new)]]
202patHint _ _ o@(L _ (VarPat _ (L _ name)))
203  | occNameString (rdrNameOcc name) == "otherwise" =
204    [warn "Used otherwise as a pattern" o (noLoc (WildPat noExtField) :: LPat GhcPs) []]
205patHint lang strict o@(L _ (BangPat _ pat@(L _ x)))
206  | strict, f x = [warn "Redundant bang pattern" o (noLoc x :: LPat GhcPs) [r]]
207  where
208    f :: Pat GhcPs -> Bool
209    f (ParPat _ (L _ x)) = f x
210    f (AsPat _ _ (L _ x)) = f x
211    f LitPat {} = True
212    f NPat {} = True
213    f ConPat {} = True
214    f TuplePat {} = True
215    f ListPat {} = True
216    f (SigPat _ (L _ p) _) = f p
217    f _ = False
218    r = Replace R.Pattern (toSS o) [("x", toSS pat)] "x"
219patHint False _ o@(L _ (LazyPat _ pat@(L _ x)))
220  | f x = [warn "Redundant irrefutable pattern" o (noLoc x :: LPat GhcPs) [r]]
221  where
222    f :: Pat GhcPs -> Bool
223    f (ParPat _ (L _ x)) = f x
224    f (AsPat _ _ (L _ x)) = f x
225    f WildPat{} = True
226    f VarPat{} = True
227    f _ = False
228    r = Replace R.Pattern (toSS o) [("x", toSS pat)] "x"
229patHint _ _ o@(L _ (AsPat _ v (L _ (WildPat _)))) =
230  [warn "Redundant as-pattern" o v [Replace R.Pattern (toSS o) [] (rdrNameStr v)]]
231patHint _ _ _ = []
232
233expHint :: LHsExpr GhcPs -> [Idea]
234 -- Note the 'FromSource' in these equations (don't warn on generated match groups).
235expHint o@(L _ (HsCase _ _ (MG _ (L _ [L _ (Match _ CaseAlt [L _ (WildPat _)] (GRHSs _ [L _ (GRHS _ [] e)] (L  _ (EmptyLocalBinds _)))) ]) FromSource ))) =
236  [suggest "Redundant case" o e [r]]
237  where
238    r = Replace Expr (toSS o) [("x", toSS e)] "x"
239expHint o@(L _ (HsCase _ (L _ (HsVar _ (L _ x))) (MG _ (L _ [L _ (Match _ CaseAlt [L _ (VarPat _ (L _ y))] (GRHSs _ [L _ (GRHS _ [] e)] (L  _ (EmptyLocalBinds _)))) ]) FromSource )))
240  | occNameStr x == occNameStr y =
241      [suggest "Redundant case" o e [r]]
242  where
243    r = Replace Expr (toSS o) [("x", toSS e)] "x"
244expHint _ = []
245