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