{-# LANGUAGE ViewPatterns, ScopedTypeVariables #-}
module Hint.Bracket(bracketHint) where
import Hint.Type
import Data.Data
import Refact.Types
bracketHint :: DeclHint
bracketHint _ _ x =
concatMap (\x -> bracket isPartialAtom True x ++ dollar x) (childrenBi (descendBi annotations x) :: [Exp_]) ++
concatMap (bracket (const False) False) (childrenBi x :: [Type_]) ++
concatMap (bracket (const False) False) (childrenBi x :: [Pat_]) ++
concatMap fieldDecl (childrenBi x)
where
annotations :: Annotation S -> Annotation S
annotations = descendBi $ \x -> case (x :: Exp_) of
Paren _ x -> x
x -> x
isPartialAtom :: Exp_ -> Bool
isPartialAtom x = isRecConstr x || isRecUpdate x
tyConToRtype :: String -> RType
tyConToRtype "Exp" = Expr
tyConToRtype "Type" = Type
tyConToRtype "Pat" = Pattern
tyConToRtype _ = Expr
findType :: (Data a) => a -> RType
findType = tyConToRtype . dataTypeName . dataTypeOf
remParens :: Brackets a => a -> Maybe a
remParens = fmap go . remParen
where
go e = maybe e go (remParen e)
bracket :: forall a . (Data (a S), ExactP a, Pretty (a S), Brackets (a S)) => (a S -> Bool) -> Bool -> a S -> [Idea]
bracket isPartialAtom root = f Nothing
where
msg = "Redundant bracket"
f :: (Data (a S), ExactP a, Pretty (a S), Brackets (a S)) => Maybe (Int,a S,a S -> a S) -> a S -> [Idea]
f Just{} o@(remParens -> Just x) | isAtom x, not $ isPartialAtom x = bracketError msg o x : g x
f Nothing o@(remParens -> Just x) | root || isAtom x = (if isAtom x then bracketError else bracketWarning) msg o x : g x
f (Just (i,o,gen)) v@(remParens -> Just x) | not $ needBracket i o x, not $ isPartialAtom x =
suggest msg o (gen x) [r] : g x
where
typ = findType v
r = Replace typ (toSS v) [("x", toSS x)] "x"
f _ x = g x
g :: (Data (a S), ExactP a, Pretty (a S), Brackets (a S)) => a S -> [Idea]
g o = concat [f (Just (i,o,gen)) x | (i,(x,gen)) <- zip [0..] $ holes o]
bracketWarning msg o x =
suggest msg o x [Replace (findType x) (toSS o) [("x", toSS x)] "x"]
bracketError msg o x =
warn msg o x [Replace (findType x) (toSS o) [("x", toSS x)] "x"]
fieldDecl :: FieldDecl S -> [Idea]
fieldDecl o@(FieldDecl a b v@(TyParen _ c))
= [suggest "Redundant bracket" o (FieldDecl a b c) [Replace Type (toSS v) [("x", toSS c)] "x"]]
fieldDecl _ = []
dollar :: Exp_ -> [Idea]
dollar = concatMap f . universe
where
f x = [suggest "Redundant $" x y [r] | InfixApp _ a d b <- [x], opExp d ~= "$"
,let y = App an a b, not $ needBracket 0 y a, not $ needBracket 1 y b, not $ isPartialAtom b
,let r = Replace Expr (toSS x) [("a", toSS a), ("b", toSS b)] "a b"]
++
[suggest "Move brackets to avoid $" x (t y) [r] |(t, e@(Paren _ (InfixApp _ a1 op1 a2))) <- splitInfix x
,opExp op1 ~= "$", isVar a1 || isApp a1 || isParen a1, not $ isAtom a2
,not $ a1 ~= "select"
, let y = App an a1 (Paren an a2)
, let r = Replace Expr (toSS e) [("a", toSS a1), ("b", toSS a2)] "a (b)" ]
++
[suggest "Redundant bracket" x y []
| InfixApp _ (Paren _ o1@(InfixApp _ v1 (isDot -> True) v2)) o2 v3 <- [x], opExp o2 ~= "<$>"
, let y = InfixApp an o1 o2 v3]
splitInfix :: Exp_ -> [(Exp_ -> Exp_, Exp_)]
splitInfix (InfixApp s a b c) = [(InfixApp s a b, c), (\a -> InfixApp s a b c, a)]
splitInfix _ = []