{-# LANGUAGE ViewPatterns, PatternGuards #-}
module Hint.Pattern(patternHint) where
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), SrcSpan)
import qualified Refact.Types as R (RType(Pattern, Match), SrcSpan)
import HsSyn
import SrcLoc
import RdrName
import OccName
import Bag
import BasicTypes
import GHC.Util
patternHint :: DeclHint'
patternHint _scope modu x =
concatMap (uncurry hints . swap) (asPattern x) ++
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
located ps = [p | p@XPat{} <- ps]
exts = nubOrd $ concatMap snd (langExts (pragmas (ghcAnnotations modu)))
strict = "Strict" `elem` exts
noPatBind :: LHsBind GhcPs -> LHsBind GhcPs
noPatBind (LL loc a@PatBind{}) = cL loc a{pat_lhs=noLoc (WildPat noExt)}
noPatBind x = x
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
mkGuard :: LHsExpr GhcPs -> (LHsExpr GhcPs -> GRHS GhcPs (LHsExpr GhcPs))
mkGuard a = GRHS noExt [noLoc $ BodyStmt noExt a noSyntaxExpr' noSyntaxExpr']
guards :: [LGRHS GhcPs (LHsExpr GhcPs)]
guards = map (noLoc . uncurry mkGuard) rawGuards
(lhs, rhs) = unzip rawGuards
mkTemplate c ps =
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
patSubts =
case pat of
[p] -> [Left p]
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
template = fromMaybe "" $ ideaTo (gen "" (Pattern l rtype (map toString' patSubts) (GRHSs noExt templateGuards 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)]
data Pattern = Pattern SrcSpan R.RType [Pat GhcPs] (GRHSs GhcPs (LHsExpr GhcPs))
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
asPattern _ = []
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
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
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]
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 _ = []