{-# LANGUAGE ViewPatterns, ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module Hint.Bracket(bracketHint) where
import Hint.Type(DeclHint',Idea(..),rawIdea',warn',suggest',suggestRemove,Severity(..),toSS')
import Data.Data
import Data.List.Extra
import Data.Generics.Uniplate.Operations
import Refact.Types
import GHC.Hs
import Outputable
import SrcLoc
import GHC.Util
import Language.Haskell.GhclibParserEx.GHC.Hs.Expr
bracketHint :: DeclHint'
bracketHint _ _ x =
concatMap (\x -> bracket prettyExpr isPartialAtom True x ++ dollar x) (childrenBi (descendBi annotations x) :: [LHsExpr GhcPs]) ++
concatMap (bracket unsafePrettyPrint (const False) False) (childrenBi x :: [LHsType GhcPs]) ++
concatMap (bracket unsafePrettyPrint (const False) False) (childrenBi x :: [LPat GhcPs]) ++
concatMap fieldDecl (childrenBi x)
where
annotations :: AnnDecl GhcPs -> AnnDecl GhcPs
annotations= descendBi $ \x -> case (x :: LHsExpr GhcPs) of
L l (HsPar _ x) -> x
x -> x
prettyExpr :: LHsExpr GhcPs -> String
prettyExpr s@(L _ SectionL{}) = unsafePrettyPrint (noLoc (HsPar noExtField s) :: LHsExpr GhcPs)
prettyExpr s@(L _ SectionR{}) = unsafePrettyPrint (noLoc (HsPar noExtField s) :: LHsExpr GhcPs)
prettyExpr x = unsafePrettyPrint x
tyConToRtype :: String -> RType
tyConToRtype "Exp" = Expr
tyConToRtype "Type" = Type
tyConToRtype "HsType" = 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)
isPartialAtom :: LHsExpr GhcPs -> Bool
isPartialAtom (L _ (HsSpliceE _ (HsTypedSplice _ HasDollar _ _) )) = True
isPartialAtom (L _ (HsSpliceE _ (HsUntypedSplice _ HasDollar _ _) )) = True
isPartialAtom x = isRecConstr x || isRecUpdate x
bracket :: forall a . (Data a, Data (SrcSpanLess a), HasSrcSpan a, Outputable a, Brackets' a) => (a -> String) -> (a -> Bool) -> Bool -> a -> [Idea]
bracket pretty isPartialAtom root = f Nothing
where
msg = "Redundant bracket"
f :: (HasSrcSpan a, Data a, Outputable a, Brackets' a) => Maybe (Int, a , a -> a) -> a -> [Idea]
f Nothing o@(remParens' -> Just x)
| root || isAtom' x
, not $ isPartialAtom x =
(if isAtom' x then bracketError else bracketWarning) msg o x : g x
f Just{} o@(remParens' -> Just x)
| isAtom' x
, not $ isPartialAtom x =
bracketError msg o x : g x
f (Just (i, o, gen)) v@(remParens' -> Just x)
| not $ needBracket' i o x, not $ isPartialAtom x =
rawIdea' Suggestion msg (getLoc o) (pretty o) (Just (pretty (gen x))) [] [r] : g x
where
typ = findType (unLoc v)
r = Replace typ (toSS' v) [("x", toSS' x)] "x"
f _ x = g x
g :: (HasSrcSpan a, Data a, Outputable a, Brackets' a) => a -> [Idea]
g o = concat [f (Just (i, o, gen)) x | (i, (x, gen)) <- zipFrom 0 $ holes o]
bracketWarning :: (HasSrcSpan a, HasSrcSpan b, Data (SrcSpanLess b), Outputable a, Outputable b) => String -> a -> b -> Idea
bracketWarning msg o x =
suggest' msg o x [Replace (findType (unLoc x)) (toSS' o) [("x", toSS' x)] "x"]
bracketError :: (HasSrcSpan a, HasSrcSpan b, Data (SrcSpanLess b), Outputable a, Outputable b ) => String -> a -> b -> Idea
bracketError msg o x =
warn' msg o x [Replace (findType (unLoc x)) (toSS' o) [("x", toSS' x)] "x"]
fieldDecl :: LConDeclField GhcPs -> [Idea]
fieldDecl o@(L loc f@ConDeclField{cd_fld_type=v@(L l (HsParTy _ c))}) =
let r = L loc (f{cd_fld_type=c}) :: LConDeclField GhcPs in
[rawIdea' Suggestion "Redundant bracket" loc
(showSDocUnsafe $ ppr_fld o)
(Just (showSDocUnsafe $ ppr_fld r))
[]
[Replace Type (toSS' v) [("x", toSS' c)] "x"]]
where
ppr_fld (L _ ConDeclField { cd_fld_names = ns, cd_fld_type = ty, cd_fld_doc = doc })
= ppr_names ns <+> dcolon <+> ppr ty <+> ppr_mbDoc doc
ppr_fld (L _ (XConDeclField x)) = ppr x
ppr_names [n] = ppr n
ppr_names ns = sep (punctuate comma (map ppr ns))
fieldDecl _ = []
dollar :: LHsExpr GhcPs -> [Idea]
dollar = concatMap f . universe
where
f x = [ suggestRemove "Redundant $" (getLoc d) "$" [r]| (L _ (OpApp _ a d b)) <- [x], isDol d
, let y = noLoc (HsApp noExtField a b) :: LHsExpr GhcPs
, 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@(L _ (HsPar _ (L _ (OpApp _ a1 op1 a2))))) <- splitInfix x
, isDol op1
, isVar a1 || isApp a1 || isPar a1, not $ isAtom' a2
, varToStr a1 /= "select"
, let y = noLoc $ HsApp noExtField a1 (noLoc (HsPar noExtField a2))
, let r = Replace Expr (toSS' e) [("a", toSS' a1), ("b", toSS' a2)] "a (b)" ]
++
[ suggest' "Redundant bracket" x y []
| L _ (OpApp _ (L _ (HsPar _ o1@(L _ (OpApp _ v1 (isDot -> True) v2)))) o2 v3) <- [x], varToStr o2 == "<$>"
, let y = noLoc (OpApp noExtField o1 o2 v3) :: LHsExpr GhcPs]
splitInfix :: LHsExpr GhcPs -> [(LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)]
splitInfix (L l (OpApp _ lhs op rhs)) =
[(L l . OpApp noExtField lhs op, rhs), (\lhs -> L l (OpApp noExtField lhs op rhs), lhs)]
splitInfix _ = []