1 2module Hint.Smell ( 3 smellModuleHint, 4 smellHint 5 ) where 6 7{- 8<TEST> [{smell: { type: many arg functions, limit: 2 }}] 9f :: Int -> Int \ 10f = undefined 11 12f :: Int -> Int -> Int \ 13f = undefined -- 14</TEST> 15 16<TEST> 17f :: Int -> Int \ 18f = undefined 19 20f :: Int -> Int -> Int \ 21f = undefined 22</TEST> 23 24<TEST> [{smell: { type: long functions, limit: 3}}] 25f = do \ 26 x <- y \ 27 return x -- 28 29f = do \ 30 return z \ 31\ 32 where \ 33 z = do \ 34 a \ 35 b -- 36 37f = do \ 38 return z \ 39\ 40 where \ 41 z = a 42 43f = Con \ 44 { a = x \ 45 , b = y \ 46 , c = z \ 47 } 48 49f = return x 50</TEST> 51 52<TEST> 53f = do \ 54 x <- y \ 55 return x 56 57f = return x 58</TEST> 59 60<TEST> [{smell: { type: long type lists, limit: 2}}] 61f :: Bool -> Int -> (Int -> Proxy '[a, b]) -- 62f :: Proxy '[a] 63</TEST> 64 65<TEST> 66f :: Proxy '[a, b] 67f :: Proxy '[a] 68</TEST> 69 70<TEST> [{smell: { type: many imports, limit: 2}}] 71import A; import B -- 72import A 73</TEST> 74 75<TEST> 76import A; import B 77import A 78</TEST> 79-} 80 81import Hint.Type(ModuHint,ModuleEx(..),DeclHint,Idea(..),rawIdea,warn) 82import Config.Type 83 84import Data.Generics.Uniplate.DataOnly 85import Data.List.Extra 86import qualified Data.Map as Map 87 88import BasicTypes 89import GHC.Hs 90import RdrName 91import Outputable 92import Bag 93import SrcLoc 94import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable 95 96smellModuleHint :: [Setting] -> ModuHint 97smellModuleHint settings scope m = 98 let (L _ mod) = ghcModule m 99 imports = hsmodImports mod in 100 case Map.lookup SmellManyImports (smells settings) of 101 Just n | length imports >= n -> 102 let span = foldl1 combineSrcSpans $ getLoc <$> imports 103 displayImports = unlines $ f <$> imports 104 in [rawIdea Config.Type.Warning "Many imports" span displayImports Nothing [] [] ] 105 where 106 f :: LImportDecl GhcPs -> String 107 f = trimStart . unsafePrettyPrint 108 _ -> [] 109 110smellHint :: [Setting] -> DeclHint 111smellHint settings scope m d = 112 sniff smellLongFunctions SmellLongFunctions ++ 113 sniff smellLongTypeLists SmellLongTypeLists ++ 114 sniff smellManyArgFunctions SmellManyArgFunctions 115 where 116 sniff f t = fmap (\i -> i {ideaTo = Nothing }) . take 1 $ maybe [] (f d) $ Map.lookup t (smells settings) 117 118smellLongFunctions :: LHsDecl GhcPs -> Int -> [Idea] 119smellLongFunctions d n = [ idea 120 | (span, idea) <- declSpans d 121 , spanLength span >= n 122 ] 123 124-- I've tried to be faithful to the original here but I'm doubtful 125-- about it. I think I've replicated the behavior of the original but 126-- is the original correctly honoring the intent? 127 128-- A function with with one alternative, one rhs and its 'where' 129-- clause (perhaps we should be looping over alts and all guarded 130-- right hand sides?) 131declSpans :: LHsDecl GhcPs -> [(SrcSpan, Idea)] 132declSpans 133 (L _ (ValD _ 134 FunBind {fun_matches=MG { 135 mg_origin=FromSource 136 , mg_alts=(L _ [L _ Match { 137 m_ctxt=ctx 138 , m_grhss=GRHSs{grhssGRHSs=[locGrhs] 139 , grhssLocalBinds=where_}}])}})) = 140 -- The span of the right hand side and the spans of each binding in 141 -- the where clause. 142 rhsSpans ctx locGrhs ++ whereSpans where_ 143-- Any other kind of function. 144declSpans f@(L l (ValD _ FunBind {})) = [(l, warn "Long function" f f [])] 145declSpans _ = [] 146 147-- The span of a guarded right hand side. 148rhsSpans :: HsMatchContext RdrName -> LGRHS GhcPs (LHsExpr GhcPs) -> [(SrcSpan, Idea)] 149rhsSpans _ (L _ (GRHS _ _ (L _ RecordCon {}))) = [] -- record constructors get a pass 150rhsSpans ctx (L _ r@(GRHS _ _ (L l _))) = 151 [(l, rawIdea Config.Type.Warning "Long function" l (showSDocUnsafe (pprGRHS ctx r)) Nothing [] [])] 152rhsSpans _ _ = [] 153 154-- The spans of a 'where' clause are the spans of its bindings. 155whereSpans :: LHsLocalBinds GhcPs -> [(SrcSpan, Idea)] 156whereSpans (L l (HsValBinds _ (ValBinds _ bs _))) = 157 concatMap (declSpans . (\(L loc bind) -> L loc (ValD noExtField bind))) (bagToList bs) 158whereSpans _ = [] 159 160spanLength :: SrcSpan -> Int 161spanLength (RealSrcSpan span) = srcSpanEndLine span - srcSpanStartLine span + 1 162spanLength (UnhelpfulSpan _) = -1 163 164smellLongTypeLists :: LHsDecl GhcPs -> Int -> [Idea] 165smellLongTypeLists d@(L _ (SigD _ (TypeSig _ _ (HsWC _ (HsIB _ (L _ t)))))) n = 166 warn "Long type list" d d [] <$ filter longTypeList (universe t) 167 where 168 longTypeList (HsExplicitListTy _ IsPromoted x) = length x >= n 169 longTypeList _ = False 170smellLongTypeLists _ _ = [] 171 172smellManyArgFunctions :: LHsDecl GhcPs -> Int -> [Idea] 173smellManyArgFunctions d@(L _ (SigD _ (TypeSig _ _ (HsWC _ (HsIB _ (L _ t)))))) n = 174 warn "Many arg function" d d [] <$ filter manyArgFunction (universe t) 175 where 176 manyArgFunction t = countFunctionArgs t >= n 177smellManyArgFunctions _ _ = [] 178 179countFunctionArgs :: HsType GhcPs -> Int 180countFunctionArgs (HsFunTy _ _ t) = 1 + countFunctionArgs (unLoc t) 181countFunctionArgs (HsParTy _ t) = countFunctionArgs (unLoc t) 182countFunctionArgs _ = 0 183 184smells :: [Setting] -> Map.Map SmellType Int 185smells settings = Map.fromList [ (smellType, smellLimit) | SettingSmell smellType smellLimit <- settings] 186