module Hint.Smell (
smellModuleHint,
smellHint
) where
import Hint.Type(ModuHint,ModuleEx(..),DeclHint,Idea(..),rawIdea,warn)
import Config.Type
import Data.Generics.Uniplate.DataOnly
import Data.List.Extra
import qualified Data.Map as Map
import BasicTypes
import GHC.Hs
import RdrName
import Outputable
import Bag
import SrcLoc
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
smellModuleHint :: [Setting] -> ModuHint
smellModuleHint :: [Setting] -> ModuHint
smellModuleHint [Setting]
settings Scope
scope ModuleEx
m =
let (L SrcSpan
_ HsModule GhcPs
mod) = ModuleEx -> GenLocated SrcSpan (HsModule GhcPs)
ghcModule ModuleEx
m
imports :: [LImportDecl GhcPs]
imports = HsModule GhcPs -> [LImportDecl GhcPs]
forall pass. HsModule pass -> [LImportDecl pass]
hsmodImports HsModule GhcPs
mod in
case SmellType -> Map SmellType Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup SmellType
SmellManyImports ([Setting] -> Map SmellType Int
smells [Setting]
settings) of
Just Int
n | [LImportDecl GhcPs] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LImportDecl GhcPs]
imports Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n ->
let span :: SrcSpan
span = (SrcSpan -> SrcSpan -> SrcSpan) -> [SrcSpan] -> SrcSpan
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans ([SrcSpan] -> SrcSpan) -> [SrcSpan] -> SrcSpan
forall a b. (a -> b) -> a -> b
$ LImportDecl GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc (LImportDecl GhcPs -> SrcSpan) -> [LImportDecl GhcPs] -> [SrcSpan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LImportDecl GhcPs]
imports
displayImports :: String
displayImports = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ LImportDecl GhcPs -> String
f (LImportDecl GhcPs -> String) -> [LImportDecl GhcPs] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LImportDecl GhcPs]
imports
in [Severity
-> String
-> SrcSpan
-> String
-> Maybe String
-> [Note]
-> [Refactoring SrcSpan]
-> Idea
rawIdea Severity
Config.Type.Warning String
"Many imports" SrcSpan
span String
displayImports Maybe String
forall a. Maybe a
Nothing [] [] ]
where
f :: LImportDecl GhcPs -> String
f :: LImportDecl GhcPs -> String
f = String -> String
trimStart (String -> String)
-> (LImportDecl GhcPs -> String) -> LImportDecl GhcPs -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LImportDecl GhcPs -> String
forall a. Outputable a => a -> String
unsafePrettyPrint
Maybe Int
_ -> []
smellHint :: [Setting] -> DeclHint
smellHint :: [Setting] -> DeclHint
smellHint [Setting]
settings Scope
scope ModuleEx
m LHsDecl GhcPs
d =
(LHsDecl GhcPs -> Int -> [Idea]) -> SmellType -> [Idea]
sniff LHsDecl GhcPs -> Int -> [Idea]
smellLongFunctions SmellType
SmellLongFunctions [Idea] -> [Idea] -> [Idea]
forall a. [a] -> [a] -> [a]
++
(LHsDecl GhcPs -> Int -> [Idea]) -> SmellType -> [Idea]
sniff LHsDecl GhcPs -> Int -> [Idea]
smellLongTypeLists SmellType
SmellLongTypeLists [Idea] -> [Idea] -> [Idea]
forall a. [a] -> [a] -> [a]
++
(LHsDecl GhcPs -> Int -> [Idea]) -> SmellType -> [Idea]
sniff LHsDecl GhcPs -> Int -> [Idea]
smellManyArgFunctions SmellType
SmellManyArgFunctions
where
sniff :: (LHsDecl GhcPs -> Int -> [Idea]) -> SmellType -> [Idea]
sniff LHsDecl GhcPs -> Int -> [Idea]
f SmellType
t = (Idea -> Idea) -> [Idea] -> [Idea]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Idea
i -> Idea
i {ideaTo :: Maybe String
ideaTo = Maybe String
forall a. Maybe a
Nothing }) ([Idea] -> [Idea]) -> ([Idea] -> [Idea]) -> [Idea] -> [Idea]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Idea] -> [Idea]
forall a. Int -> [a] -> [a]
take Int
1 ([Idea] -> [Idea]) -> [Idea] -> [Idea]
forall a b. (a -> b) -> a -> b
$ [Idea] -> (Int -> [Idea]) -> Maybe Int -> [Idea]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (LHsDecl GhcPs -> Int -> [Idea]
f LHsDecl GhcPs
d) (Maybe Int -> [Idea]) -> Maybe Int -> [Idea]
forall a b. (a -> b) -> a -> b
$ SmellType -> Map SmellType Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup SmellType
t ([Setting] -> Map SmellType Int
smells [Setting]
settings)
smellLongFunctions :: LHsDecl GhcPs -> Int -> [Idea]
smellLongFunctions :: LHsDecl GhcPs -> Int -> [Idea]
smellLongFunctions LHsDecl GhcPs
d Int
n = [ Idea
idea
| (SrcSpan
span, Idea
idea) <- LHsDecl GhcPs -> [(SrcSpan, Idea)]
declSpans LHsDecl GhcPs
d
, SrcSpan -> Int
spanLength SrcSpan
span Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n
]
declSpans :: LHsDecl GhcPs -> [(SrcSpan, Idea)]
declSpans :: LHsDecl GhcPs -> [(SrcSpan, Idea)]
declSpans
(L SrcSpan
_ (ValD XValD GhcPs
_
FunBind {fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches=MG {
mg_origin :: forall p body. MatchGroup p body -> Origin
mg_origin=Origin
FromSource
, mg_alts :: forall p body. MatchGroup p body -> Located [LMatch p body]
mg_alts=(L SrcSpan
_ [L SrcSpan
_ Match {
m_ctxt :: forall p body.
Match p body -> HsMatchContext (NameOrRdrName (IdP p))
m_ctxt=HsMatchContext (NameOrRdrName (IdP GhcPs))
ctx
, m_grhss :: forall p body. Match p body -> GRHSs p body
m_grhss=GRHSs{grhssGRHSs :: forall p body. GRHSs p body -> [LGRHS p body]
grhssGRHSs=[LGRHS GhcPs (LHsExpr GhcPs)
locGrhs]
, grhssLocalBinds :: forall p body. GRHSs p body -> LHsLocalBinds p
grhssLocalBinds=LHsLocalBinds GhcPs
where_}}])}})) =
HsMatchContext RdrName
-> LGRHS GhcPs (LHsExpr GhcPs) -> [(SrcSpan, Idea)]
rhsSpans HsMatchContext (NameOrRdrName (IdP GhcPs))
HsMatchContext RdrName
ctx LGRHS GhcPs (LHsExpr GhcPs)
locGrhs [(SrcSpan, Idea)] -> [(SrcSpan, Idea)] -> [(SrcSpan, Idea)]
forall a. [a] -> [a] -> [a]
++ LHsLocalBinds GhcPs -> [(SrcSpan, Idea)]
whereSpans LHsLocalBinds GhcPs
where_
declSpans f :: LHsDecl GhcPs
f@(L SrcSpan
l (ValD XValD GhcPs
_ FunBind {})) = [(SrcSpan
l, String
-> LHsDecl GhcPs -> LHsDecl GhcPs -> [Refactoring SrcSpan] -> Idea
forall a b.
(HasSrcSpan a, Outputable a, HasSrcSpan b, Outputable b) =>
String -> a -> b -> [Refactoring SrcSpan] -> Idea
warn String
"Long function" LHsDecl GhcPs
f LHsDecl GhcPs
f [])]
declSpans LHsDecl GhcPs
_ = []
rhsSpans :: HsMatchContext RdrName -> LGRHS GhcPs (LHsExpr GhcPs) -> [(SrcSpan, Idea)]
rhsSpans :: HsMatchContext RdrName
-> LGRHS GhcPs (LHsExpr GhcPs) -> [(SrcSpan, Idea)]
rhsSpans HsMatchContext RdrName
_ (L SrcSpan
_ (GRHS XCGRHS GhcPs (LHsExpr GhcPs)
_ [GuardLStmt GhcPs]
_ (L SrcSpan
_ RecordCon {}))) = []
rhsSpans HsMatchContext RdrName
ctx (L SrcSpan
_ r :: GRHS GhcPs (LHsExpr GhcPs)
r@(GRHS XCGRHS GhcPs (LHsExpr GhcPs)
_ [GuardLStmt GhcPs]
_ (L SrcSpan
l HsExpr GhcPs
_))) =
[(SrcSpan
l, Severity
-> String
-> SrcSpan
-> String
-> Maybe String
-> [Note]
-> [Refactoring SrcSpan]
-> Idea
rawIdea Severity
Config.Type.Warning String
"Long function" SrcSpan
l (SDoc -> String
showSDocUnsafe (HsMatchContext RdrName -> GRHS GhcPs (LHsExpr GhcPs) -> SDoc
forall (idR :: Pass) body idL.
(OutputableBndrId idR, Outputable body) =>
HsMatchContext idL -> GRHS (GhcPass idR) body -> SDoc
pprGRHS HsMatchContext RdrName
ctx GRHS GhcPs (LHsExpr GhcPs)
r)) Maybe String
forall a. Maybe a
Nothing [] [])]
rhsSpans HsMatchContext RdrName
_ LGRHS GhcPs (LHsExpr GhcPs)
_ = []
whereSpans :: LHsLocalBinds GhcPs -> [(SrcSpan, Idea)]
whereSpans :: LHsLocalBinds GhcPs -> [(SrcSpan, Idea)]
whereSpans (L SrcSpan
l (HsValBinds XHsValBinds GhcPs GhcPs
_ (ValBinds XValBinds GhcPs GhcPs
_ LHsBindsLR GhcPs GhcPs
bs [LSig GhcPs]
_))) =
(GenLocated SrcSpan (HsBindLR GhcPs GhcPs) -> [(SrcSpan, Idea)])
-> [GenLocated SrcSpan (HsBindLR GhcPs GhcPs)] -> [(SrcSpan, Idea)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (LHsDecl GhcPs -> [(SrcSpan, Idea)]
declSpans (LHsDecl GhcPs -> [(SrcSpan, Idea)])
-> (GenLocated SrcSpan (HsBindLR GhcPs GhcPs) -> LHsDecl GhcPs)
-> GenLocated SrcSpan (HsBindLR GhcPs GhcPs)
-> [(SrcSpan, Idea)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(L SrcSpan
loc HsBindLR GhcPs GhcPs
bind) -> SrcSpan -> HsDecl GhcPs -> LHsDecl GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XValD GhcPs -> HsBindLR GhcPs GhcPs -> HsDecl GhcPs
forall p. XValD p -> HsBind p -> HsDecl p
ValD NoExtField
XValD GhcPs
noExtField HsBindLR GhcPs GhcPs
bind))) (LHsBindsLR GhcPs GhcPs
-> [GenLocated SrcSpan (HsBindLR GhcPs GhcPs)]
forall a. Bag a -> [a]
bagToList LHsBindsLR GhcPs GhcPs
bs)
whereSpans LHsLocalBinds GhcPs
_ = []
spanLength :: SrcSpan -> Int
spanLength :: SrcSpan -> Int
spanLength (RealSrcSpan RealSrcSpan
span) = RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
span Int -> Int -> Int
forall a. Num a => a -> a -> a
- RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
span Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
spanLength (UnhelpfulSpan FastString
_) = -Int
1
smellLongTypeLists :: LHsDecl GhcPs -> Int -> [Idea]
smellLongTypeLists :: LHsDecl GhcPs -> Int -> [Idea]
smellLongTypeLists d :: LHsDecl GhcPs
d@(L SrcSpan
_ (SigD XSigD GhcPs
_ (TypeSig XTypeSig GhcPs
_ [Located (IdP GhcPs)]
_ (HsWC XHsWC GhcPs (LHsSigType GhcPs)
_ (HsIB XHsIB GhcPs (LHsType GhcPs)
_ (L SrcSpan
_ HsType GhcPs
t)))))) Int
n =
String
-> LHsDecl GhcPs -> LHsDecl GhcPs -> [Refactoring SrcSpan] -> Idea
forall a b.
(HasSrcSpan a, Outputable a, HasSrcSpan b, Outputable b) =>
String -> a -> b -> [Refactoring SrcSpan] -> Idea
warn String
"Long type list" LHsDecl GhcPs
d LHsDecl GhcPs
d [] Idea -> [HsType GhcPs] -> [Idea]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (HsType GhcPs -> Bool) -> [HsType GhcPs] -> [HsType GhcPs]
forall a. (a -> Bool) -> [a] -> [a]
filter HsType GhcPs -> Bool
forall pass. HsType pass -> Bool
longTypeList (HsType GhcPs -> [HsType GhcPs]
forall on. Uniplate on => on -> [on]
universe HsType GhcPs
t)
where
longTypeList :: HsType pass -> Bool
longTypeList (HsExplicitListTy XExplicitListTy pass
_ PromotionFlag
IsPromoted [LHsType pass]
x) = [LHsType pass] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LHsType pass]
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n
longTypeList HsType pass
_ = Bool
False
smellLongTypeLists LHsDecl GhcPs
_ Int
_ = []
smellManyArgFunctions :: LHsDecl GhcPs -> Int -> [Idea]
smellManyArgFunctions :: LHsDecl GhcPs -> Int -> [Idea]
smellManyArgFunctions d :: LHsDecl GhcPs
d@(L SrcSpan
_ (SigD XSigD GhcPs
_ (TypeSig XTypeSig GhcPs
_ [Located (IdP GhcPs)]
_ (HsWC XHsWC GhcPs (LHsSigType GhcPs)
_ (HsIB XHsIB GhcPs (LHsType GhcPs)
_ (L SrcSpan
_ HsType GhcPs
t)))))) Int
n =
String
-> LHsDecl GhcPs -> LHsDecl GhcPs -> [Refactoring SrcSpan] -> Idea
forall a b.
(HasSrcSpan a, Outputable a, HasSrcSpan b, Outputable b) =>
String -> a -> b -> [Refactoring SrcSpan] -> Idea
warn String
"Many arg function" LHsDecl GhcPs
d LHsDecl GhcPs
d [] Idea -> [HsType GhcPs] -> [Idea]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (HsType GhcPs -> Bool) -> [HsType GhcPs] -> [HsType GhcPs]
forall a. (a -> Bool) -> [a] -> [a]
filter HsType GhcPs -> Bool
manyArgFunction (HsType GhcPs -> [HsType GhcPs]
forall on. Uniplate on => on -> [on]
universe HsType GhcPs
t)
where
manyArgFunction :: HsType GhcPs -> Bool
manyArgFunction HsType GhcPs
t = HsType GhcPs -> Int
countFunctionArgs HsType GhcPs
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n
smellManyArgFunctions LHsDecl GhcPs
_ Int
_ = []
countFunctionArgs :: HsType GhcPs -> Int
countFunctionArgs :: HsType GhcPs -> Int
countFunctionArgs (HsFunTy XFunTy GhcPs
_ LHsType GhcPs
_ LHsType GhcPs
t) = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ HsType GhcPs -> Int
countFunctionArgs (LHsType GhcPs -> SrcSpanLess (LHsType GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsType GhcPs
t)
countFunctionArgs (HsParTy XParTy GhcPs
_ LHsType GhcPs
t) = HsType GhcPs -> Int
countFunctionArgs (LHsType GhcPs -> SrcSpanLess (LHsType GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsType GhcPs
t)
countFunctionArgs HsType GhcPs
_ = Int
0
smells :: [Setting] -> Map.Map SmellType Int
smells :: [Setting] -> Map SmellType Int
smells [Setting]
settings = [(SmellType, Int)] -> Map SmellType Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (SmellType
smellType, Int
smellLimit) | SettingSmell SmellType
smellType Int
smellLimit <- [Setting]
settings]