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