{-# LANGUAGE ViewPatterns, PatternGuards, TypeFamilies #-}
module Hint.Pattern(patternHint) where
import Hint.Type(DeclHint,Idea,ghcAnnotations,ideaTo,toSS,toRefactSrcSpan,suggest,suggestRemove,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 GHC.Hs
import SrcLoc
import RdrName
import OccName
import Bag
import BasicTypes
import GHC.Util
import Language.Haskell.GhclibParserEx.GHC.Hs.Pat
import Language.Haskell.GhclibParserEx.GHC.Hs.Expr
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
patternHint :: DeclHint
patternHint _scope modu x =
concatMap (uncurry hints . swap) (asPattern x) ++
concatMap (patHint strict False) [p | PatBind _ p _ _ <- universeBi x :: [HsBind GhcPs]] ++
concatMap (patHint strict True) (universeBi $ transformBi noPatBind x) ++
concatMap expHint (universeBi x)
where
exts = nubOrd $ concatMap snd (languagePragmas (pragmas (ghcAnnotations modu)))
strict = "Strict" `elem` exts
noPatBind :: LHsBind GhcPs -> LHsBind GhcPs
noPatBind (L loc a@PatBind{}) = L loc a{pat_lhs=noLoc (WildPat noExtField)}
noPatBind x = x
hints :: (String -> Pattern -> [Refactoring R.SrcSpan] -> Idea) -> Pattern -> [Idea]
hints gen (Pattern l rtype pat (GRHSs _ [L _ (GRHS _ [] bod)] bind))
| length guards > 2 = [gen "Use guards" (Pattern l rtype pat (GRHSs noExtField guards bind)) [refactoring]]
where
rawGuards :: [(LHsExpr GhcPs, LHsExpr GhcPs)]
rawGuards = asGuards bod
mkGuard :: LHsExpr GhcPs -> (LHsExpr GhcPs -> GRHS GhcPs (LHsExpr GhcPs))
mkGuard a = GRHS noExtField [noLoc $ BodyStmt noExtField 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@(L l _) v = if l == noSrcSpan then Left p else Right (c ++ [v], toSS p)
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 noExtField templateGuards bind)) [])
f :: [Either a (String, R.SrcSpan)] -> [(String, R.SrcSpan)]
f = rights
refactoring = Replace rtype (toRefactSrcSpan l) (f patSubts ++ f guardSubts ++ f exprSubts) template
hints gen (Pattern l t pats o@(GRHSs _ [L _ (GRHS _ [test] bod)] bind))
| unsafePrettyPrint test `elem` ["otherwise", "True"]
= [gen "Redundant guard" (Pattern l t pats o{grhssGRHSs=[noLoc (GRHS noExtField [] bod)]}) [Delete Stmt (toSS test)]]
hints _ (Pattern l t pats bod@(GRHSs _ _ binds)) | f binds
= [suggestRemove "Redundant where" whereSpan "where" [ ]]
where
f :: LHsLocalBinds GhcPs -> Bool
f (L _ (HsValBinds _ (ValBinds _ bag _))) = isEmptyBag bag
f (L _ (HsIPBinds _ (IPBinds _ l))) = null l
f _ = False
whereSpan = case l of
UnhelpfulSpan s -> UnhelpfulSpan s
RealSrcSpan s ->
let end = realSrcSpanEnd s
start = mkRealSrcLoc (srcSpanFile s) (srcLocLine end) (srcLocCol end - 5)
in RealSrcSpan (mkRealSrcSpan start end)
hints gen (Pattern l t pats o@(GRHSs _ (unsnoc -> Just (gs, L _ (GRHS _ [test] bod))) binds))
| unsafePrettyPrint test == "True"
= let otherwise_ = noLoc $ BodyStmt noExtField (strToVar "otherwise") noSyntaxExpr noSyntaxExpr in
[gen "Use otherwise" (Pattern l t pats o{grhssGRHSs = gs ++ [noLoc (GRHS noExtField [otherwise_] bod)]}) [Replace Expr (toSS test) [] "otherwise"]]
hints _ _ = []
asGuards :: LHsExpr GhcPs -> [(LHsExpr GhcPs, LHsExpr GhcPs)]
asGuards (L _ (HsPar _ x)) = asGuards x
asGuards (L _ (HsIf _ _ a b c)) = (a, b) : asGuards c
asGuards x = [(strToVar "otherwise", x)]
data Pattern = Pattern SrcSpan R.RType [LPat GhcPs] (GRHSs GhcPs (LHsExpr GhcPs))
asPattern :: LHsDecl GhcPs -> [(Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)]
asPattern (L 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 (L loc o :: LHsBind GhcPs) (noLoc (PatBind noExtField pat rhs ([], [])) :: LHsBind GhcPs) rs)]
decl (FunBind _ _ (MG _ (L _ xs) _) _ _) = map match xs
decl _ = []
match :: LMatch GhcPs (LHsExpr GhcPs) -> (Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)
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)
match _ = undefined
patHint :: Bool -> Bool -> LPat GhcPs -> [Idea]
patHint _ _ o@(L _ (ConPatIn name (PrefixCon args)))
| length args >= 3 && all isPWildcard args =
let rec_fields = HsRecFields [] Nothing :: HsRecFields GhcPs (LPat GhcPs)
new = noLoc $ ConPatIn name (RecCon rec_fields) :: LPat GhcPs
in
[suggest "Use record patterns" o new [Replace R.Pattern (toSS o) [] (unsafePrettyPrint new)]]
patHint _ _ o@(L _ (VarPat _ (L _ name)))
| occNameString (rdrNameOcc name) == "otherwise" =
[warn "Used otherwise as a pattern" o (noLoc (WildPat noExtField) :: LPat GhcPs) []]
patHint lang strict o@(L _ (BangPat _ pat@(L _ x)))
| strict, f x = [warn "Redundant bang pattern" o (noLoc x :: LPat GhcPs) [r]]
where
f :: Pat GhcPs -> Bool
f (ParPat _ (L _ x)) = f x
f (AsPat _ _ (L _ x)) = f x
f LitPat {} = True
f NPat {} = True
f ConPatIn {} = True
f TuplePat {} = True
f ListPat {} = True
f (SigPat _ (L _ p) _) = f p
f _ = False
r = Replace R.Pattern (toSS o) [("x", toSS pat)] "x"
patHint False _ o@(L _ (LazyPat _ pat@(L _ x)))
| f x = [warn "Redundant irrefutable pattern" o (noLoc x :: LPat GhcPs) [r]]
where
f :: Pat GhcPs -> Bool
f (ParPat _ (L _ x)) = f x
f (AsPat _ _ (L _ x)) = f x
f WildPat{} = True
f VarPat{} = True
f _ = False
r = Replace R.Pattern (toSS o) [("x", toSS pat)] "x"
patHint _ _ o@(L _ (AsPat _ v (L _ (WildPat _)))) =
[warn "Redundant as-pattern" o v []]
patHint _ _ _ = []
expHint :: LHsExpr GhcPs -> [Idea]
expHint o@(L _ (HsCase _ _ (MG _ (L _ [L _ (Match _ CaseAlt [L _ (WildPat _)] (GRHSs _ [L _ (GRHS _ [] e)] (L _ (EmptyLocalBinds _)))) ]) FromSource ))) =
[suggest "Redundant case" o e [r]]
where
r = Replace Expr (toSS o) [("x", toSS e)] "x"
expHint o@(L _ (HsCase _ (L _ (HsVar _ (L _ x))) (MG _ (L _ [L _ (Match _ CaseAlt [L _ (VarPat _ (L _ y))] (GRHSs _ [L _ (GRHS _ [] e)] (L _ (EmptyLocalBinds _)))) ]) FromSource )))
| occNameStr x == occNameStr y =
[suggest "Redundant case" o e [r]]
where
r = Replace Expr (toSS o) [("x", toSS e)] "x"
expHint _ = []