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