1{-# LANGUAGE ViewPatterns, ScopedTypeVariables #-} 2{-# LANGUAGE FlexibleContexts #-} 3{-# LANGUAGE TypeFamilies #-} 4{- 5 6Raise an error if you are bracketing an atom, or are enclosed by a 7list bracket. 8 9<TEST> 10-- expression bracket reduction 11yes = (f x) x -- @Suggestion f x x 12no = f (x x) 13yes = (foo) -- foo 14yes = (foo bar) -- @Suggestion foo bar 15yes = foo (bar) -- @Warning bar 16yes = foo ((x x)) -- @Suggestion (x x) 17yes = (f x) ||| y -- @Suggestion f x ||| y 18yes = if (f x) then y else z -- @Suggestion if f x then y else z 19yes = if x then (f y) else z -- @Suggestion if x then f y else z 20yes = (a foo) :: Int -- @Suggestion a foo :: Int 21yes = [(foo bar)] -- @Suggestion [foo bar] 22yes = foo ((x y), z) -- @Suggestion (x y, z) 23yes = C { f = (e h) } -- @Suggestion C {f = e h} 24yes = \ x -> (x && x) -- @Suggestion \x -> x && x 25no = \(x -> y) -> z 26yes = (`foo` (bar baz)) -- @Suggestion (`foo` bar baz) 27yes = f ((x)) -- @Warning x 28main = do f; (print x) -- @Suggestion do f print x 29yes = f (x) y -- @Warning x 30no = f (+x) y 31no = f ($x) y 32no = ($x) 33yes = (($x)) 34no = ($1) 35yes = (($1)) -- @Warning ($1) 36no = (+5) 37yes = ((+5)) -- @Warning (+5) 38issue909 = case 0 of { _ | n <- (0 :: Int) -> n } 39issue909 = foo (\((x :: z) -> y) -> 9 + x * 7) 40issue909 = foo (\((x : z) -> y) -> 9 + x * 7) -- \(x : z -> y) -> 9 + x * 7 41issue909 = let ((x:: y) -> z) = q in q 42issue909 = do {((x :: y) -> z) <- e; return 1} 43issue970 = (f x +) (g x) -- f x + (g x) 44issue969 = (Just \x -> x || x) *> Just True 45 46-- type bracket reduction 47foo :: (Int -> Int) -> Int 48foo :: (Maybe Int) -> a -- @Suggestion Maybe Int -> a 49instance Named (DeclHead S) 50data Foo = Foo {foo :: (Maybe Foo)} -- @Suggestion foo :: Maybe Foo 51 52-- pattern bracket reduction 53foo (x:xs) = 1 54foo (True) = 1 -- @Warning True 55foo ((True)) = 1 -- @Warning True 56foo (A{}) = True -- A{} 57f x = case x of (Nothing) -> 1; _ -> 2 -- Nothing 58 59-- dollar reduction tests 60no = groupFsts . sortFst $ mr 61yes = split "to" $ names -- split "to" names 62yes = white $ keysymbol -- white keysymbol 63yes = operator foo $ operator -- operator foo operator 64no = operator foo $ operator bar 65yes = return $ Record{a=b} 66no = f $ [1,2..5] -- f [1,2..5] 67 68-- $/bracket rotation tests 69yes = (b $ c d) ++ e -- b (c d) ++ e 70yes = (a b $ c d) ++ e -- a b (c d) ++ e 71no = (f . g $ a) ++ e 72no = quickCheck ((\h -> cySucc h == succ h) :: Hygiene -> Bool) 73foo = (case x of y -> z; q -> w) :: Int 74 75-- backup fixity resolution 76main = do a += b . c; return $ a . b 77 78-- <$> bracket tests 79yes = (foo . bar x) <$> baz q -- foo . bar x <$> baz q 80no = foo . bar x <$> baz q 81 82-- annotations 83main = 1; {-# ANN module ("HLint: ignore Use camelCase" :: String) #-} 84main = 1; {-# ANN module (1 + (2)) #-} -- 2 85 86-- special case from esqueleto, see #224 87main = operate <$> (select $ from $ \user -> return $ user ^. UserEmail) 88-- unknown fixity, see #426 89bad x = x . (x +? x . x) 90-- special case people don't like to warn on 91special = foo $ f{x=1} 92special = foo $ Rec{x=1} 93special = foo (f{x=1}) 94loadCradleOnlyonce = skipManyTill anyMessage (message @PublishDiagnosticsNotification) 95 96-- type splices are a bit special 97no = f @($x) 98</TEST> 99-} 100 101 102module Hint.Bracket(bracketHint) where 103 104import Hint.Type(DeclHint,Idea(..),rawIdea,warn,suggest,Severity(..),toRefactSrcSpan,toSS) 105import Data.Data 106import Data.List.Extra 107import Data.Generics.Uniplate.DataOnly 108import Refact.Types 109 110import GHC.Hs 111import Outputable 112import SrcLoc 113import GHC.Util 114import Language.Haskell.GhclibParserEx.GHC.Hs.Expr 115import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable 116 117bracketHint :: DeclHint 118bracketHint _ _ x = 119 concatMap (\x -> bracket prettyExpr isPartialAtom True x ++ dollar x) (childrenBi (descendBi annotations x) :: [LHsExpr GhcPs]) ++ 120 concatMap (bracket unsafePrettyPrint (const False) False) (childrenBi x :: [LHsType GhcPs]) ++ 121 concatMap (bracket unsafePrettyPrint (const False) False) (childrenBi x :: [LPat GhcPs]) ++ 122 concatMap fieldDecl (childrenBi x) 123 where 124 -- Brackets the roots of annotations are fine, so we strip them. 125 annotations :: AnnDecl GhcPs -> AnnDecl GhcPs 126 annotations= descendBi $ \x -> case (x :: LHsExpr GhcPs) of 127 L _ (HsPar _ x) -> x 128 x -> x 129 130-- If we find ourselves in the context of a section and we want to 131-- issue a warning that a child therein has unneccessary brackets, 132-- we'd rather report 'Found : (`Foo` (Bar Baz))' rather than 'Found : 133-- `Foo` (Bar Baz)'. If left to 'unsafePrettyPrint' we'd get the 134-- latter (in contrast to the HSE pretty printer). This patches things 135-- up. 136prettyExpr :: LHsExpr GhcPs -> String 137prettyExpr s@(L _ SectionL{}) = unsafePrettyPrint (noLoc (HsPar noExtField s) :: LHsExpr GhcPs) 138prettyExpr s@(L _ SectionR{}) = unsafePrettyPrint (noLoc (HsPar noExtField s) :: LHsExpr GhcPs) 139prettyExpr x = unsafePrettyPrint x 140 141-- 'Just _' if at least one set of parens were removed. 'Nothing' if 142-- zero parens were removed. 143remParens' :: Brackets a => a -> Maybe a 144remParens' = fmap go . remParen 145 where 146 go e = maybe e go (remParen e) 147 148isPartialAtom :: LHsExpr GhcPs -> Bool 149-- Might be '$x', which was really '$ x', but TH enabled misparsed it. 150isPartialAtom (L _ (HsSpliceE _ (HsTypedSplice _ HasDollar _ _) )) = True 151isPartialAtom (L _ (HsSpliceE _ (HsUntypedSplice _ HasDollar _ _) )) = True 152isPartialAtom x = isRecConstr x || isRecUpdate x 153 154bracket :: forall a . (Data a, HasSrcSpan a, Outputable a, Brackets a) => (a -> String) -> (a -> Bool) -> Bool -> a -> [Idea] 155bracket pretty isPartialAtom root = f Nothing 156 where 157 msg = "Redundant bracket" 158 -- 'f' is a (generic) function over types in 'Brackets 159 -- (expressions, patterns and types). Arguments are, 'f (Maybe 160 -- (index, parent, gen)) child'. 161 f :: (HasSrcSpan a, Data a, Outputable a, Brackets a) => Maybe (Int, a , a -> a) -> a -> [Idea] 162 -- No context. Removing parentheses from 'x' succeeds? 163 f Nothing o@(remParens' -> Just x) 164 -- If at the root, or 'x' is an atom, 'x' parens are redundant. 165 | root || isAtom x 166 , not $ isPartialAtom x = 167 (if isAtom x then bracketError else bracketWarning) msg o x : g x 168 -- In some context, removing parentheses from 'x' succeeds and 'x' 169 -- is atomic? 170 f Just{} o@(remParens' -> Just x) 171 | isAtom x 172 , not $ isPartialAtom x = 173 bracketError msg o x : g x 174 -- In some context, removing parentheses from 'x' succeeds. Does 175 -- 'x' actually need bracketing in this context? 176 f (Just (i, o, gen)) v@(remParens' -> Just x) 177 | not $ needBracket i o x, not $ isPartialAtom x = 178 rawIdea Suggestion msg (getLoc v) (pretty o) (Just (pretty (gen x))) [] [r] : g x 179 where 180 typ = findType v 181 r = Replace typ (toSS v) [("x", toSS x)] "x" 182 -- Regardless of the context, there are no parentheses to remove 183 -- from 'x'. 184 f _ x = g x 185 186 g :: (HasSrcSpan a, Data a, Outputable a, Brackets a) => a -> [Idea] 187 -- Enumerate over all the immediate children of 'o' looking for 188 -- redundant parentheses in each. 189 g o = concat [f (Just (i, o, gen)) x | (i, (x, gen)) <- zipFrom 0 $ holes o] 190 191bracketWarning :: (HasSrcSpan a, HasSrcSpan b, Outputable a, Outputable b, Brackets b) => String -> a -> b -> Idea 192bracketWarning msg o x = 193 suggest msg o x [Replace (findType x) (toSS o) [("x", toSS x)] "x"] 194 195bracketError :: (HasSrcSpan a, HasSrcSpan b, Outputable a, Outputable b, Brackets b) => String -> a -> b -> Idea 196bracketError msg o x = 197 warn msg o x [Replace (findType x) (toSS o) [("x", toSS x)] "x"] 198 199fieldDecl :: LConDeclField GhcPs -> [Idea] 200fieldDecl o@(L loc f@ConDeclField{cd_fld_type=v@(L l (HsParTy _ c))}) = 201 let r = L loc (f{cd_fld_type=c}) :: LConDeclField GhcPs in 202 [rawIdea Suggestion "Redundant bracket" l 203 (showSDocUnsafe $ ppr_fld o) -- Note this custom printer! 204 (Just (showSDocUnsafe $ ppr_fld r)) 205 [] 206 [Replace Type (toSS v) [("x", toSS c)] "x"]] 207 where 208 -- If we call 'unsafePrettyPrint' on a field decl, we won't like 209 -- the output (e.g. "[foo, bar] :: T"). Here we use a custom 210 -- printer to work around (snarfed from 211 -- https://hackage.haskell.org/package/ghc-lib-parser-8.8.1/docs/src/HsTypes.html#pprConDeclFields). 212 ppr_fld (L _ ConDeclField { cd_fld_names = ns, cd_fld_type = ty, cd_fld_doc = doc }) 213 = ppr_names ns <+> dcolon <+> ppr ty <+> ppr_mbDoc doc 214 ppr_fld (L _ (XConDeclField x)) = ppr x 215 216 ppr_names [n] = ppr n 217 ppr_names ns = sep (punctuate comma (map ppr ns)) 218fieldDecl _ = [] 219 220-- This function relies heavily on fixities having been applied to the 221-- raw parse tree. 222dollar :: LHsExpr GhcPs -> [Idea] 223dollar = concatMap f . universe 224 where 225 f x = [ (suggest "Redundant $" x y [r]){ideaSpan = getLoc d} | L _ (OpApp _ a d b) <- [x], isDol d 226 , let y = noLoc (HsApp noExtField a b) :: LHsExpr GhcPs 227 , not $ needBracket 0 y a 228 , not $ needBracket 1 y b 229 , not $ isPartialAtom b 230 , let r = Replace Expr (toSS x) [("a", toSS a), ("b", toSS b)] "a b"] 231 ++ 232 [ suggest "Move brackets to avoid $" x (t y) [r] 233 |(t, e@(L _ (HsPar _ (L _ (OpApp _ a1 op1 a2))))) <- splitInfix x 234 , isDol op1 235 , isVar a1 || isApp a1 || isPar a1, not $ isAtom a2 236 , varToStr a1 /= "select" -- special case for esqueleto, see #224 237 , let y = noLoc $ HsApp noExtField a1 (noLoc (HsPar noExtField a2)) 238 , let r = Replace Expr (toSS e) [("a", toSS a1), ("b", toSS a2)] "a (b)" ] 239 ++ -- Special case of (v1 . v2) <$> v3 240 [ (suggest "Redundant bracket" x y [r]){ideaSpan = locPar} 241 | L _ (OpApp _ (L locPar (HsPar _ o1@(L locNoPar (OpApp _ _ (isDot -> True) _)))) o2 v3) <- [x], varToStr o2 == "<$>" 242 , let y = noLoc (OpApp noExtField o1 o2 v3) :: LHsExpr GhcPs 243 , let r = Replace Expr (toRefactSrcSpan locPar) [("a", toRefactSrcSpan locNoPar)] "a"] 244 ++ 245 [ suggest "Redundant section" x y [r] 246 | L _ (HsApp _ (L _ (HsPar _ (L _ (SectionL _ a b)))) c) <- [x] 247 -- , error $ show (unsafePrettyPrint a, gshow b, unsafePrettyPrint c) 248 , let y = noLoc $ OpApp noExtField a b c :: LHsExpr GhcPs 249 , let r = Replace Expr (toSS x) [("x", toSS a), ("op", toSS b), ("y", toSS c)] "x op y"] 250 251splitInfix :: LHsExpr GhcPs -> [(LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)] 252splitInfix (L l (OpApp _ lhs op rhs)) = 253 [(L l . OpApp noExtField lhs op, rhs), (\lhs -> L l (OpApp noExtField lhs op rhs), lhs)] 254splitInfix _ = [] 255