{-

Raise a warning if you have redundant brackets in nested infix expressions.

<TEST>
yes = 1 + (2 * 3) -- @Ignore 1 + 2 * 3
yes = (2 * 3) + 1 -- @Ignore 2 * 3 + 1
no = (1 + 2) * 3
no = 3 * (1 + 2)
no = 1 + 2 * 3
no = 2 * 3 + 1
yes = (a >>= f) >>= g -- @Ignore a >>= f >>= g
no = (a >>= \x -> b) >>= g
</TEST>
-}

module Hint.Fixities(fixitiesHint) where

import Hint.Type(DeclHint,Idea(..),rawIdea,toSS)
import Config.Type
import Control.Monad
import Data.List.Extra
import Data.Map
import Data.Generics.Uniplate.DataOnly
import Refact.Types

import GHC.Types.Basic (compareFixity)
import Fixity
import GHC.Hs
import GHC.Util
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
import GHC.Types.SrcLoc
import GHC.Types.Name.Reader
import GHC.Types.Name.Occurrence

fixitiesHint :: [Setting] -> DeclHint
fixitiesHint :: [Setting] -> DeclHint
fixitiesHint [Setting]
settings Scope
_ ModuleEx
_ LHsDecl GhcPs
x =
  (LHsExpr GhcPs -> [Idea]) -> [LHsExpr GhcPs] -> [Idea]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Map String Fixity -> LHsExpr GhcPs -> [Idea]
infixBracket Map String Fixity
fixities) (LHsDecl GhcPs -> [LHsExpr GhcPs]
forall from to. Biplate from to => from -> [to]
childrenBi LHsDecl GhcPs
x :: [LHsExpr GhcPs])
   where
     fixities :: Map String Fixity
fixities = (Setting -> Map String Fixity) -> [Setting] -> Map String Fixity
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Setting -> Map String Fixity
getFixity [Setting]
settings Map String Fixity -> Map String Fixity -> Map String Fixity
forall a. Monoid a => a -> a -> a
`mappend` [(String, Fixity)] -> Map String Fixity
forall k a. Ord k => [(k, a)] -> Map k a
fromList (FixityInfo -> (String, Fixity)
toFixity (FixityInfo -> (String, Fixity))
-> [FixityInfo] -> [(String, Fixity)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FixityInfo]
defaultFixities)
     getFixity :: Setting -> Map String Fixity
getFixity (Infix FixityInfo
x) = (String -> Fixity -> Map String Fixity)
-> (String, Fixity) -> Map String Fixity
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> Fixity -> Map String Fixity
forall k a. k -> a -> Map k a
Data.Map.singleton (FixityInfo -> (String, Fixity)
toFixity FixityInfo
x)
     getFixity Setting
_ = Map String Fixity
forall a. Monoid a => a
mempty

infixBracket :: Map String Fixity -> LHsExpr GhcPs -> [Idea]
infixBracket :: Map String Fixity -> LHsExpr GhcPs -> [Idea]
infixBracket Map String Fixity
fixities = Maybe (Int, LHsExpr GhcPs, LHsExpr GhcPs -> LHsExpr GhcPs)
-> LHsExpr GhcPs -> [Idea]
f Maybe (Int, LHsExpr GhcPs, LHsExpr GhcPs -> LHsExpr GhcPs)
forall a. Maybe a
Nothing
  where
    msg :: String
msg = String
"Redundant bracket due to operator fixities"
    f :: Maybe (Int, LHsExpr GhcPs, LHsExpr GhcPs -> LHsExpr GhcPs)
-> LHsExpr GhcPs -> [Idea]
f Maybe (Int, LHsExpr GhcPs, LHsExpr GhcPs -> LHsExpr GhcPs)
p LHsExpr GhcPs
o = Maybe (Int, LHsExpr GhcPs, LHsExpr GhcPs -> LHsExpr GhcPs)
-> LHsExpr GhcPs -> [Idea]
forall a.
Outputable a =>
Maybe (Int, LHsExpr GhcPs, LHsExpr GhcPs -> a)
-> LHsExpr GhcPs -> [Idea]
cur Maybe (Int, LHsExpr GhcPs, LHsExpr GhcPs -> LHsExpr GhcPs)
p LHsExpr GhcPs
o [Idea] -> [Idea] -> [Idea]
forall a. Semigroup a => a -> a -> a
<> [[Idea]] -> [Idea]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Maybe (Int, LHsExpr GhcPs, LHsExpr GhcPs -> LHsExpr GhcPs)
-> LHsExpr GhcPs -> [Idea]
f ((Int, LHsExpr GhcPs, LHsExpr GhcPs -> LHsExpr GhcPs)
-> Maybe (Int, LHsExpr GhcPs, LHsExpr GhcPs -> LHsExpr GhcPs)
forall a. a -> Maybe a
Just (Int
i, LHsExpr GhcPs
o, LHsExpr GhcPs -> LHsExpr GhcPs
gen)) LHsExpr GhcPs
x | (Int
i, (LHsExpr GhcPs
x, LHsExpr GhcPs -> LHsExpr GhcPs
gen)) <- Int
-> [(LHsExpr GhcPs, LHsExpr GhcPs -> LHsExpr GhcPs)]
-> [(Int, (LHsExpr GhcPs, LHsExpr GhcPs -> LHsExpr GhcPs))]
forall a b. Enum a => a -> [b] -> [(a, b)]
zipFrom Int
0 ([(LHsExpr GhcPs, LHsExpr GhcPs -> LHsExpr GhcPs)]
 -> [(Int, (LHsExpr GhcPs, LHsExpr GhcPs -> LHsExpr GhcPs))])
-> [(LHsExpr GhcPs, LHsExpr GhcPs -> LHsExpr GhcPs)]
-> [(Int, (LHsExpr GhcPs, LHsExpr GhcPs -> LHsExpr GhcPs))]
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> [(LHsExpr GhcPs, LHsExpr GhcPs -> LHsExpr GhcPs)]
forall on. Uniplate on => on -> [(on, on -> on)]
holes LHsExpr GhcPs
o]
    cur :: Maybe (Int, LHsExpr GhcPs, LHsExpr GhcPs -> a)
-> LHsExpr GhcPs -> [Idea]
cur Maybe (Int, LHsExpr GhcPs, LHsExpr GhcPs -> a)
p LHsExpr GhcPs
v = do
      Just (Int
i, LHsExpr GhcPs
o, LHsExpr GhcPs -> a
gen) <- [Maybe (Int, LHsExpr GhcPs, LHsExpr GhcPs -> a)
p]
      Just LHsExpr GhcPs
x <- [LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
forall a. Brackets a => a -> Maybe a
remParen LHsExpr GhcPs
v]
      Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Map String Fixity -> Int -> LHsExpr GhcPs -> LHsExpr GhcPs -> Bool
redundantInfixBracket Map String Fixity
fixities Int
i LHsExpr GhcPs
o LHsExpr GhcPs
x
      Idea -> [Idea]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Idea -> [Idea]) -> Idea -> [Idea]
forall a b. (a -> b) -> a -> b
$
        Severity
-> String
-> SrcSpan
-> String
-> Maybe String
-> [Note]
-> [Refactoring SrcSpan]
-> Idea
rawIdea Severity
Ignore String
msg (LHsExpr GhcPs -> SrcSpan
forall l e. GenLocated l e -> l
getLoc LHsExpr GhcPs
v) (LHsExpr GhcPs -> String
forall a. Outputable a => a -> String
unsafePrettyPrint LHsExpr GhcPs
o)
        (String -> Maybe String
forall a. a -> Maybe a
Just (a -> String
forall a. Outputable a => a -> String
unsafePrettyPrint (LHsExpr GhcPs -> a
gen LHsExpr GhcPs
x))) [] [RType
-> SrcSpan -> [(String, SrcSpan)] -> String -> Refactoring SrcSpan
forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace (LHsExpr GhcPs -> RType
forall a. Brackets a => a -> RType
findType LHsExpr GhcPs
v) (LHsExpr GhcPs -> SrcSpan
forall a. Located a -> SrcSpan
toSS LHsExpr GhcPs
v) [(String
"x", LHsExpr GhcPs -> SrcSpan
forall a. Located a -> SrcSpan
toSS LHsExpr GhcPs
x)] String
"x"]

redundantInfixBracket :: Map String Fixity -> Int -> LHsExpr GhcPs -> LHsExpr GhcPs -> Bool
redundantInfixBracket :: Map String Fixity -> Int -> LHsExpr GhcPs -> LHsExpr GhcPs -> Bool
redundantInfixBracket Map String Fixity
fixities Int
i LHsExpr GhcPs
parent LHsExpr GhcPs
child
    | L SrcSpan
_ (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
_ (L SrcSpan
_ (HsVar XVar GhcPs
_ (L SrcSpan
_ (Unqual p)))) LHsExpr GhcPs
_) <- LHsExpr GhcPs
parent
    , L SrcSpan
_ (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
_ (L SrcSpan
_ (HsVar XVar GhcPs
_ (L SrcSpan
_ (Unqual c)))) (L SrcSpan
_ HsExpr GhcPs
cr)) <- LHsExpr GhcPs
child =
    let (OccName
lop, OccName
rop)
            | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = (OccName
c, OccName
p)
            | Bool
otherwise = (OccName
p, OccName
c)
    in
    case Fixity -> Fixity -> (Bool, Bool)
compareFixity (Fixity -> Fixity -> (Bool, Bool))
-> Maybe Fixity -> Maybe (Fixity -> (Bool, Bool))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Map String Fixity
fixities Map String Fixity -> String -> Maybe Fixity
forall k a. Ord k => Map k a -> k -> Maybe a
Data.Map.!? OccName -> String
occNameString OccName
lop) Maybe (Fixity -> (Bool, Bool))
-> Maybe Fixity -> Maybe (Bool, Bool)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Map String Fixity
fixities Map String Fixity -> String -> Maybe Fixity
forall k a. Ord k => Map k a -> k -> Maybe a
Data.Map.!? OccName -> String
occNameString OccName
rop) of
    Just (Bool
False, Bool
r)
        | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 -> Bool -> Bool
not (HsExpr GhcPs -> Bool
forall p. HsExpr p -> Bool
needParenAsChild HsExpr GhcPs
cr Bool -> Bool -> Bool
|| Bool
r)
        | Bool
otherwise -> Bool
r
    Maybe (Bool, Bool)
_ -> Bool
False
    | Bool
otherwise = Bool
False

needParenAsChild :: HsExpr p -> Bool
needParenAsChild :: HsExpr p -> Bool
needParenAsChild HsLet{} = Bool
True
needParenAsChild HsDo{} = Bool
True
needParenAsChild HsLam{} = Bool
True
needParenAsChild HsLamCase{} = Bool
True
needParenAsChild HsCase{} = Bool
True
needParenAsChild HsIf{} = Bool
True
needParenAsChild HsExpr p
_ = Bool
False