module Hint.Smell (
smellModuleHint,
smellHint
) where
import Hint.Type(ModuHint,ModuleEx(..),DeclHint',Idea(..),rawIdea',warn')
import Config.Type
import Data.Generics.Uniplate.Operations
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 settings scope m =
let (L _ mod) = ghcModule m
imports = hsmodImports mod in
case Map.lookup SmellManyImports (smells settings) of
Just n | length imports >= n ->
let span = foldl1 combineSrcSpans $ getLoc <$> imports
displayImports = unlines $ f <$> imports
in [rawIdea' Config.Type.Warning "Many imports" span displayImports Nothing [] [] ]
where
f :: LImportDecl GhcPs -> String
f = trimStart . unsafePrettyPrint
_ -> []
smellHint :: [Setting] -> DeclHint'
smellHint settings scope m d =
sniff smellLongFunctions SmellLongFunctions ++
sniff smellLongTypeLists SmellLongTypeLists ++
sniff smellManyArgFunctions SmellManyArgFunctions
where
sniff f t = fmap (\i -> i {ideaTo = Nothing }) . take 1 $ maybe [] (f d) $ Map.lookup t (smells settings)
smellLongFunctions :: LHsDecl GhcPs -> Int -> [Idea]
smellLongFunctions d n = [ idea
| (span, idea) <- declSpans d
, spanLength span >= n
]
declSpans :: LHsDecl GhcPs -> [(SrcSpan, Idea)]
declSpans
(L _ (ValD _
FunBind {fun_matches=MG {
mg_origin=FromSource
, mg_alts=(L _ [L _ Match {
m_ctxt=ctx
, m_grhss=GRHSs{grhssGRHSs=[locGrhs]
, grhssLocalBinds=where_}}])}})) =
rhsSpans ctx locGrhs ++ whereSpans where_
declSpans f@(L l (ValD _ FunBind {})) = [(l, warn' "Long function" f f [])]
declSpans _ = []
rhsSpans :: HsMatchContext RdrName -> LGRHS GhcPs (LHsExpr GhcPs) -> [(SrcSpan, Idea)]
rhsSpans _ (L _ (GRHS _ _ (L _ RecordCon {}))) = []
rhsSpans ctx (L _ r@(GRHS _ _ (L l _))) =
[(l, rawIdea' Config.Type.Warning "Long function" l (showSDocUnsafe (pprGRHS ctx r)) Nothing [] [])]
rhsSpans _ _ = []
whereSpans :: LHsLocalBinds GhcPs -> [(SrcSpan, Idea)]
whereSpans (L l (HsValBinds _ (ValBinds _ bs _))) =
concatMap (declSpans . (\(L loc bind) -> L loc (ValD noExtField bind))) (bagToList bs)
whereSpans _ = []
spanLength :: SrcSpan -> Int
spanLength (RealSrcSpan span) = srcSpanEndLine span - srcSpanStartLine span + 1
spanLength (UnhelpfulSpan _) = -1
smellLongTypeLists :: LHsDecl GhcPs -> Int -> [Idea]
smellLongTypeLists d@(L _ (SigD _ (TypeSig _ _ (HsWC _ (HsIB _ (L _ t)))))) n =
warn' "Long type list" d d [] <$ filter longTypeList (universe t)
where
longTypeList (HsExplicitListTy _ IsPromoted x) = length x >= n
longTypeList _ = False
smellLongTypeLists _ _ = []
smellManyArgFunctions :: LHsDecl GhcPs -> Int -> [Idea]
smellManyArgFunctions d@(L _ (SigD _ (TypeSig _ _ (HsWC _ (HsIB _ (L _ t)))))) n =
warn' "Many arg function" d d [] <$ filter manyArgFunction (universe t)
where
manyArgFunction t = countFunctionArgs t >= n
smellManyArgFunctions _ _ = []
countFunctionArgs :: HsType GhcPs -> Int
countFunctionArgs (HsFunTy _ _ t) = 1 + countFunctionArgs (unLoc t)
countFunctionArgs (HsParTy _ t) = countFunctionArgs (unLoc t)
countFunctionArgs _ = 0
smells :: [Setting] -> Map.Map SmellType Int
smells settings = Map.fromList [ (smellType, smellLimit) | SettingSmell smellType smellLimit <- settings]