summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorNeilMitchell <>2019-04-15 09:23:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-04-15 09:23:00 (GMT)
commit5b456378c446e6ac3c015c0a4c4256f1488d64fd (patch)
tree1f48c38c8ab2aeeef15da9d50b949bf8ed1a14bc
parent264f7c62046e80bffdaf162db4e1edce4b66fcac (diff)
version 2.1.162.1.16
-rw-r--r--CHANGES.txt12
-rw-r--r--README.md4
-rw-r--r--data/hlint.yaml26
-rw-r--r--hlint.cabal7
-rw-r--r--src/Config/Type.hs15
-rw-r--r--src/Config/Yaml.hs17
-rw-r--r--src/HLint.hs2
-rw-r--r--src/HSE/Util.hs4
-rw-r--r--src/Hint/All.hs4
-rw-r--r--src/Hint/Extensions.hs5
-rw-r--r--src/Hint/List.hs18
-rw-r--r--src/Hint/Match.hs33
-rw-r--r--src/Hint/Naming.hs9
-rw-r--r--src/Hint/Smell.hs148
-rw-r--r--src/Test/Annotations.hs36
15 files changed, 293 insertions, 47 deletions
diff --git a/CHANGES.txt b/CHANGES.txt
index 011d04c..b7f1da4 100644
--- a/CHANGES.txt
+++ b/CHANGES.txt
@@ -1,5 +1,17 @@
Changelog for HLint (* = breaking change)
+2.1.16, released 2019-04-15
+ Make `seq` and `rem` hints apply to prefix functions
+ #604, suggest rnf x `seq` () ==> rnf x
+ #619, require haskell-src-exts-util-0.2.5
+ #619, fix move guards forward with record puns
+ #618, add pure x <*> y ==> x <$> y
+ #611, add == and subst for more advanced match conditions
+ #612, add: Suggest f =<< instead of maybe Nothing f
+ #609, add code smells
+ #614, adds refactorings for camelCase and some list suggestions
+ #605, make command line arguments override the .yaml file
+ #603, QuasiQuotes can programatically use any extension
2.1.15, released 2019-02-27
#593, reorder guards in list comps where possible
#597, suggest pushing a map over a list comp inside
diff --git a/README.md b/README.md
index 81c32b7..8b453a8 100644
--- a/README.md
+++ b/README.md
@@ -1,4 +1,4 @@
-# HLint [![Hackage version](https://img.shields.io/hackage/v/hlint.svg?label=Hackage)](https://hackage.haskell.org/package/hlint) [![Stackage version](https://www.stackage.org/package/hlint/badge/nightly?label=Stackage)](https://www.stackage.org/package/hlint) [![Linux Build Status](https://img.shields.io/travis/ndmitchell/hlint/master.svg?label=Linux%20build)](https://travis-ci.org/ndmitchell/hlint) [![Windows Build Status](https://img.shields.io/appveyor/ci/ndmitchell/hlint/master.svg?label=Windows%20build)](https://ci.appveyor.com/project/ndmitchell/hlint)
+# HLint [![Hackage version](https://img.shields.io/hackage/v/hlint.svg?label=Hackage)](https://hackage.haskell.org/package/hlint) [![Stackage version](https://www.stackage.org/package/hlint/badge/nightly?label=Stackage)](https://www.stackage.org/package/hlint) [![Linux build status](https://img.shields.io/travis/ndmitchell/hlint/master.svg?label=Linux%20build)](https://travis-ci.org/ndmitchell/hlint) [![Windows build status](https://img.shields.io/appveyor/ci/ndmitchell/hlint/master.svg?label=Windows%20build)](https://ci.appveyor.com/project/ndmitchell/hlint)
HLint is a tool for suggesting possible improvements to Haskell code. These suggestions include ideas such as using alternative functions, simplifying code and spotting redundancies. You can try HLint online at [lpaste.net](http://lpaste.net/) - suggestions are shown at the bottom. This document is structured as follows:
@@ -171,7 +171,7 @@ HLint doesn't suggest optimisations, it suggests code improvements - the intenti
### Why doesn't HLint know the fixity for my custom !@%$ operator?
-HLint knows the fixities for all the operators in the base library, but no others. HLint works on a single file at a time, and does not resolve imports, so cannot see fixity declarations from imported modules. You can tell HLint about fixities by putting them in a hint file, or passing them on the command line. For example, pass `--with=infixr 5 !@%$`, or put all the fixity declarations in a file and pass `--hint=fixities.hs`. You can also use [--find](https://rawgithub.com/ndmitchell/hlint/master/hlint.htm#find) to automatically produce a list of fixity declarations in a file.
+HLint knows the fixities for all the operators in the base library, but no others. HLint works on a single file at a time, and does not resolve imports, so cannot see fixity declarations from imported modules. You can tell HLint about fixities by putting them in a hint file, or passing them on the command line. For example, pass `--with=infixr 5 !@%$`, or put all the fixity declarations in a `.hlint.yaml` file as `- fixity: "infixr 5 !@%$"`. You can also use [--find](https://rawgithub.com/ndmitchell/hlint/master/hlint.htm#find) to automatically produce a list of fixity declarations in a file.
### Which hints are used?
diff --git a/data/hlint.yaml b/data/hlint.yaml
index 0c9d4ee..1dd8308 100644
--- a/data/hlint.yaml
+++ b/data/hlint.yaml
@@ -338,6 +338,11 @@
- hint: {lhs: x <&> pure y, rhs: x Data.Functor.$> y}
- hint: {lhs: x <&> return y, rhs: x Data.Functor.$> y}
+ # APPLICATIVE
+
+ - hint: {lhs: return x <*> y, rhs: x <$> y}
+ - hint: {lhs: pure x <*> y, rhs: x <$> y}
+
# MONAD
- warn: {lhs: return a >>= f, rhs: f a, name: "Monad law, left identity"}
@@ -425,12 +430,13 @@
# SEQ
- - warn: {lhs: x `seq` x, rhs: x, name: Redundant seq}
+ - warn: {lhs: seq x x, rhs: x, name: Redundant seq}
- warn: {lhs: join seq, rhs: id, name: Redundant seq}
- warn: {lhs: id $! x, rhs: x, name: Redundant $!}
- - warn: {lhs: x `seq` y, rhs: "y", side: isWHNF x, name: Redundant seq}
+ - warn: {lhs: seq x y, rhs: "y", side: isWHNF x, name: Redundant seq}
- warn: {lhs: f $! x, rhs: f x, side: isWHNF x, name: Redundant $!}
- warn: {lhs: evaluate x, rhs: return x, side: isWHNF x, name: Redundant evaluate}
+ - warn: {lhs: seq (rnf x) (), rhs: rhs x, name: Redundant seq}
# TUPLE
@@ -472,6 +478,7 @@
- hint: {lhs: "[x | Just x <- a]", rhs: Data.Maybe.catMaybes a}
- hint: {lhs: case m of Nothing -> Nothing; Just x -> x, rhs: Control.Monad.join m}
- hint: {lhs: maybe Nothing id, rhs: join}
+ - hint: {lhs: maybe Nothing f x, rhs: f =<< x}
- hint: {lhs: maybe (f x) (f . g), rhs: f . maybe x g, note: IncreasesLaziness, name: Too strict maybe}
# EITHER
@@ -499,8 +506,8 @@
- warn: {lhs: negate (negate x), rhs: x, name: Redundant negate}
- hint: {lhs: log y / log x, rhs: logBase x y}
- hint: {lhs: sin x / cos x, rhs: tan x}
- - hint: {lhs: n `rem` 2 == 0, rhs: even n}
- - hint: {lhs: n `rem` 2 /= 0, rhs: odd n}
+ - hint: {lhs: rem n 2 == 0, rhs: even n}
+ - hint: {lhs: rem n 2 /= 0, rhs: odd n}
- hint: {lhs: not (even x), rhs: odd x}
- hint: {lhs: not (odd x), rhs: even x}
- hint: {lhs: x ** 0.5, rhs: sqrt x}
@@ -665,6 +672,16 @@
- error: {lhs: "Control.Lens.nullOf (a . Control.Lens.at b)", rhs: "Control.Lens.nullOf a"}
- group:
+ name: use-lens
+ enabled: false
+ imports:
+ - package base
+ - package lens
+ rules:
+ - warn: {lhs: "either Just (const Nothing)", rhs: preview _Left}
+ - warn: {lhs: "either (const Nothing) Just", rhs: preview _Right}
+
+- group:
name: attoparsec
enabled: true
imports:
@@ -694,6 +711,7 @@
- warn: {lhs: either (const mempty), rhs: foldMap}
- warn: {lhs: Data.Maybe.fromMaybe mempty, rhs: Data.Foldable.fold}
- warn: {lhs: Data.Either.fromRight mempty, rhs: Data.Foldable.fold}
+ - warn: {lhs: if f x then Just x else Nothing, rhs: mfilter f (Just x)}
- group:
name: dollar
diff --git a/hlint.cabal b/hlint.cabal
index fd4f6c1..1299e31 100644
--- a/hlint.cabal
+++ b/hlint.cabal
@@ -1,7 +1,7 @@
cabal-version: >= 1.18
build-type: Simple
name: hlint
-version: 2.1.15
+version: 2.1.16
license: BSD3
license-file: LICENSE
category: Development
@@ -27,7 +27,7 @@ data-files:
extra-doc-files:
README.md
CHANGES.txt
-tested-with: GHC==8.6.3, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3
+tested-with: GHC==8.6.4, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3
source-repository head
type: git
@@ -54,7 +54,7 @@ library
cmdargs >= 0.10,
yaml >= 0.5.0,
haskell-src-exts >= 1.21 && < 1.22,
- haskell-src-exts-util >= 0.2.1.2,
+ haskell-src-exts-util >= 0.2.5,
uniplate >= 1.5,
ansi-terminal >= 0.6.2,
extra >= 1.6.6,
@@ -115,6 +115,7 @@ library
Hint.Pattern
Hint.Pragma
Hint.Restrict
+ Hint.Smell
Hint.Type
Hint.Unsafe
Hint.Util
diff --git a/src/Config/Type.hs b/src/Config/Type.hs
index 6a6a6e5..e7bd018 100644
--- a/src/Config/Type.hs
+++ b/src/Config/Type.hs
@@ -1,8 +1,8 @@
module Config.Type(
Severity(..), Classify(..), HintRule(..), Note(..), Setting(..),
- Restrict(..), RestrictType(..),
- defaultHintName, isUnifyVar, showNotes, getSeverity, getRestrictType
+ Restrict(..), RestrictType(..), SmellType(..),
+ defaultHintName, isUnifyVar, showNotes, getSeverity, getRestrictType, getSmellType
) where
import HSE.All
@@ -106,11 +106,22 @@ data Restrict = Restrict
,restrictWithin :: [(String, String)]
} deriving Show
+data SmellType = SmellLongFunctions | SmellLongTypeLists | SmellManyArgFunctions | SmellManyImports
+ deriving (Show,Eq,Ord)
+
+getSmellType :: String -> Maybe SmellType
+getSmellType "long functions" = Just SmellLongFunctions
+getSmellType "long type lists" = Just SmellLongTypeLists
+getSmellType "many arg functions" = Just SmellManyArgFunctions
+getSmellType "many imports" = Just SmellManyImports
+getSmellType _ = Nothing
+
data Setting
= SettingClassify Classify
| SettingMatchExp HintRule
| SettingRestrict Restrict
| SettingArgument String -- ^ Extra command-line argument
+ | SettingSmell SmellType Int
| Builtin String -- use a builtin hint set
| Infix Fixity
deriving Show
diff --git a/src/Config/Yaml.hs b/src/Config/Yaml.hs
index 1ddc27a..eaa8327 100644
--- a/src/Config/Yaml.hs
+++ b/src/Config/Yaml.hs
@@ -109,6 +109,10 @@ parseString :: Val -> Parser String
parseString (getVal -> String x) = return $ T.unpack x
parseString v = parseFail v "Expected a String"
+parseInt :: Val -> Parser Int
+parseInt (getVal -> s@Number{}) = parseJSON s
+parseInt v = parseFail v "Expected an Int"
+
parseArrayString :: Val -> Parser [String]
parseArrayString = parseArray >=> mapM parseString
@@ -162,10 +166,12 @@ parseConfigYaml v = do
"group" -> ConfigGroup <$> parseGroup v
"arguments" -> ConfigSetting . map SettingArgument <$> parseArrayString v
"fixity" -> ConfigSetting <$> parseFixity v
+ "smell" -> ConfigSetting <$> parseSmell v
_ | isJust $ getSeverity s -> ConfigGroup . ruleToGroup <$> parseRule o
_ | Just r <- getRestrictType s -> ConfigSetting . map SettingRestrict <$> (parseArray v >>= mapM (parseRestrict r))
_ -> parseFail v "Expecting an object with a 'package' or 'group' key, a hint or a restriction"
+
parsePackage :: Val -> Parser Package
parsePackage v = do
packageName <- parseField "name" v >>= parseString
@@ -179,6 +185,17 @@ parseFixity v = parseArray v >>= concatMapM (parseHSE parseDeclWithMode >=> f)
f x@InfixDecl{} = return $ map Infix $ getFixity x
f _ = parseFail v "Expected fixity declaration"
+parseSmell :: Val -> Parser [Setting]
+parseSmell v = do
+ smellName <- parseField "type" v >>= parseString
+ smellType <- require v "Expected SmellType" $ getSmellType smellName
+ smellLimit <- parseField "limit" v >>= parseInt
+ return [SettingSmell smellType smellLimit]
+ where
+ require :: Val -> String -> Maybe a -> Parser a
+ require _ _ (Just a) = return a
+ require val err Nothing = parseFail val err
+
parseGroup :: Val -> Parser Group
parseGroup v = do
groupName <- parseField "name" v >>= parseString
diff --git a/src/HLint.hs b/src/HLint.hs
index fb2a0fc..b092a69 100644
--- a/src/HLint.hs
+++ b/src/HLint.hs
@@ -158,7 +158,7 @@ readAllSettings args1 cmd@CmdMain{..} = do
++ [("CommandLine.hs",Just x) | x <- cmdWithHints]
++ [("CommandLine.yaml",Just (enableGroup x)) | x <- cmdWithGroups]
let args2 = [x | SettingArgument x <- settings1]
- cmd@CmdMain{..} <- if null args2 then return cmd else getCmd $ args1 ++ args2
+ cmd@CmdMain{..} <- if null args2 then return cmd else getCmd $ args2 ++ args1 -- command line arguments are passed last
settings2 <- concatMapM (fmap snd . computeSettings (cmdParseFlags cmd)) cmdFindHints
settings3 <- return [SettingClassify $ Classify Ignore x "" "" | x <- cmdIgnore]
return (cmd, settings1 ++ settings2 ++ settings3)
diff --git a/src/HSE/Util.hs b/src/HSE/Util.hs
index 3beecbc..9ed26b4 100644
--- a/src/HSE/Util.hs
+++ b/src/HSE/Util.hs
@@ -71,6 +71,10 @@ fromPString :: Pat_ -> Maybe String
fromPString (PLit _ _ (String _ x _)) = Just x
fromPString _ = Nothing
+fromParen1 :: Exp_ -> Exp_
+fromParen1 (Paren _ x) = x
+fromParen1 x = x
+
fromParen :: Exp_ -> Exp_
fromParen (Paren _ x) = fromParen x
fromParen x = x
diff --git a/src/Hint/All.hs b/src/Hint/All.hs
index a0a64dc..e000d59 100644
--- a/src/Hint/All.hs
+++ b/src/Hint/All.hs
@@ -30,6 +30,7 @@ import Hint.Duplicate
import Hint.Comment
import Hint.Unsafe
import Hint.NewType
+import Hint.Smell
-- | A list of the builtin hints wired into HLint.
-- This list is likely to grow over time.
@@ -37,7 +38,7 @@ data HintBuiltin =
HintList | HintListRec | HintMonad | HintLambda |
HintBracket | HintNaming | HintPattern | HintImport | HintExport |
HintPragma | HintExtensions | HintUnsafe | HintDuplicate | HintRestrict |
- HintComment | HintNewType
+ HintComment | HintNewType | HintSmell
deriving (Show,Eq,Ord,Bounded,Enum)
@@ -59,6 +60,7 @@ builtin x = case x of
HintComment -> comm commentHint
HintNewType -> decl newtypeHint
HintRestrict -> mempty{hintModule=restrictHint}
+ HintSmell -> mempty{hintDecl=smellHint,hintModule=smellModuleHint}
where
wrap = timed "Hint" (drop 4 $ show x) . forceList
decl f = mempty{hintDecl=const $ \a b c -> wrap $ f a b c}
diff --git a/src/Hint/Extensions.hs b/src/Hint/Extensions.hs
index 5e42398..7f5b860 100644
--- a/src/Hint/Extensions.hs
+++ b/src/Hint/Extensions.hs
@@ -125,6 +125,8 @@ main = case () of x -> x --
{-# LANGUAGE PolyKinds, KindSignatures #-} -- {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE PolyKinds, KindSignatures #-} \
data Set (cxt :: * -> *) a = Set [a] -- @Note Extension KindSignatures is implied by PolyKinds
+{-# LANGUAGE QuasiQuotes, OverloadedStrings #-} \
+main = putStrLn [f|{T.intercalate "blah" []}|]
</TEST>
-}
@@ -164,7 +166,8 @@ extensionsHint _ x =
, let newPragma = if null after then "" else prettyPrint $ LanguagePragma sl $ map (toNamed . prettyExtension) after
]
where
- usedTH = used TemplateHaskell x -- if TH is on, can use all other extensions programmatically
+ usedTH = used TemplateHaskell x || used QuasiQuotes x
+ -- if TH or QuasiQuotes is on, can use all other extensions programmatically
-- all the extensions defined to be used
extensions = Set.fromList [parseExtension $ fromNamed e | LanguagePragma _ exts <- modulePragmas x, e <- exts]
diff --git a/src/Hint/List.hs b/src/Hint/List.hs
index 7211e41..e9077b0 100644
--- a/src/Hint/List.hs
+++ b/src/Hint/List.hs
@@ -30,6 +30,7 @@ foo = [x + 1 | x <- [1..10], even x, dont_reoder_guards]
foo = [x + 1 | x <- [1..10], let y = even x, y]
foo = [x + 1 | x <- [1..10], let q = even 1, q] -- [x + 1 | let q = even 1, q, x <- [1..10]]
foo = [fooValue | Foo{..} <- y, fooField]
+issue619 = [pkgJobs | Pkg{pkgGpd, pkgJobs} <- pkgs, not $ null $ C.condTestSuites pkgGpd]
</TEST>
-}
@@ -40,7 +41,8 @@ import Hint.Type
import Data.List.Extra
import Data.Maybe
import Prelude
-import Refact.Types
+import Refact.Types hiding (SrcSpan)
+import qualified Refact.Types as R
listHint :: DeclHint
@@ -55,19 +57,25 @@ listDecl x =
listComp :: Exp_ -> [Idea]
listComp o@(ListComp a e xs)
- | "False" `elem` cons = [suggest "Short-circuited list comprehension" o (List an []) []]
- | "True" `elem` cons = [suggest "Redundant True guards" o o2 []]
- | let ys = moveGuardsForward xs, xs /= ys = [suggest "Move guards forward" o (ListComp a e ys) []]
+ | "False" `elem` cons = [suggest "Short-circuited list comprehension" o o' (suggestExpr o o')]
+ | "True" `elem` cons = [suggest "Redundant True guards" o o2 (suggestExpr o o2)]
+ | xs /= ys = [suggest "Move guards forward" o o3 (suggestExpr o o3)]
where
+ ys = moveGuardsForward xs
+ o' = List an []
o2 = ListComp a e $ filter ((/= Just "True") . qualCon) xs
+ o3 = ListComp a e ys
cons = mapMaybe qualCon xs
qualCon (QualStmt _ (Qualifier _ (Con _ x))) = Just $ fromNamed x
qualCon _ = Nothing
listComp o@(view -> App2 mp f (ListComp a e xs)) | mp ~= "map" =
- [suggest "Move map inside list comprehension" o o2 []]
+ [suggest "Move map inside list comprehension" o o2 (suggestExpr o o2)]
where o2 = ListComp a (App an (paren f) (paren e)) xs
listComp _ = []
+suggestExpr :: Exp_ -> Exp_ -> [Refactoring R.SrcSpan]
+suggestExpr o o2 = [Replace Expr (toSS o) [] (prettyPrint o2)]
+
-- Move all the list comp guards as far forward as they can go
moveGuardsForward :: [QualStmt S] -> [QualStmt S]
moveGuardsForward = reverse . f [] . reverse
diff --git a/src/Hint/Match.hs b/src/Hint/Match.hs
index 6256b17..fdce82e 100644
--- a/src/Hint/Match.hs
+++ b/src/Hint/Match.hs
@@ -126,23 +126,28 @@ matchIdea s decl HintRule{..} parent x = do
-- SIDE CONDITIONS
checkSide :: Maybe Exp_ -> [(String, Exp_)] -> Bool
-checkSide x bind = maybe True f x
+checkSide x bind = maybe True bool x
where
- f (InfixApp _ x op y)
- | opExp op ~= "&&" = f x && f y
- | opExp op ~= "||" = f x || f y
- f (App _ x y) | x ~= "not" = not $ f y
- f (Paren _ x) = f x
-
- f (App _ cond (sub -> y))
- | 'i':'s':typ <- fromNamed cond
- = isType typ y
- f (App _ (App _ cond (sub -> x)) (sub -> y))
+ bool :: Exp_ -> Bool
+ bool (InfixApp _ x op y)
+ | opExp op ~= "&&" = bool x && bool y
+ | opExp op ~= "||" = bool x || bool y
+ | opExp op ~= "==" = expr (fromParen1 x) =~= expr (fromParen1 y)
+ bool (App _ x y) | x ~= "not" = not $ bool y
+ bool (Paren _ x) = bool x
+
+ bool (App _ cond (sub -> y))
+ | 'i':'s':typ <- fromNamed cond = isType typ y
+ bool (App _ (App _ cond (sub -> x)) (sub -> y))
| cond ~= "notIn" = and [x `notElem` universe y | x <- list x, y <- list y]
| cond ~= "notEq" = x /=~= y
- f x | x ~= "noTypeCheck" = True
- f x | x ~= "noQuickCheck" = True
- f x = error $ "Hint.Match.checkSide, unknown side condition: " ++ prettyPrint x
+ bool x | x ~= "noTypeCheck" = True
+ bool x | x ~= "noQuickCheck" = True
+ bool x = error $ "Hint.Match.checkSide, unknown side condition: " ++ prettyPrint x
+
+ expr :: Exp_ -> Exp_
+ expr (App _ (fromNamed -> "subst") x) = sub $ fromParen1 x
+ expr x = x
isType "Compare" x = True -- just a hint for proof stuff
isType "Atom" x = isAtom x
diff --git a/src/Hint/Naming.hs b/src/Hint/Naming.hs
index ff48d0d..42c2a98 100644
--- a/src/Hint/Naming.hs
+++ b/src/Hint/Naming.hs
@@ -42,6 +42,7 @@ import Data.List.Extra
import Data.Data
import Data.Char
import Data.Maybe
+import Refact.Types hiding (RType(Match))
import qualified Data.Set as Set
@@ -49,9 +50,11 @@ namingHint :: DeclHint
namingHint _ modu = naming $ Set.fromList $ concatMap getNames $ moduleDecls modu
naming :: Set.Set String -> Decl_ -> [Idea]
-naming seen x = [suggestN "Use camelCase" x2 (replaceNames res x2) | not $ null res]
+naming seen x = [suggest "Use camelCase" x' x2' [Replace Bind (toSS x) [] (prettyPrint x2)] | not $ null res]
where res = [(n,y) | n <- nubOrd $ getNames x, Just y <- [suggestName n], not $ y `Set.member` seen]
- x2 = shorten x
+ x2 = replaceNames res x
+ x' = shorten x
+ x2' = shorten x2
shorten :: Decl_ -> Decl_
@@ -104,6 +107,6 @@ suggestName x
replaceNames :: Data a => [(String,String)] -> a -> a
-replaceNames rep = descendBi f
+replaceNames rep = transformBi f
where f (Ident _ x) = Ident an $ fromMaybe x $ lookup x rep
f x = x
diff --git a/src/Hint/Smell.hs b/src/Hint/Smell.hs
new file mode 100644
index 0000000..bcff744
--- /dev/null
+++ b/src/Hint/Smell.hs
@@ -0,0 +1,148 @@
+{-# LANGUAGE ViewPatterns #-}
+
+module Hint.Smell (
+ smellModuleHint,
+ smellHint
+ ) where
+
+{-
+<TEST> [{smell: { type: many arg functions, limit: 2 }}]
+f :: Int -> Int \
+f = undefined
+
+f :: Int -> Int -> Int \
+f = undefined --
+</TEST>
+
+<TEST>
+f :: Int -> Int \
+f = undefined
+
+f :: Int -> Int -> Int \
+f = undefined
+</TEST>
+
+<TEST> [{smell: { type: long functions, limit: 3}}]
+f = do \
+ x <- y \
+ return x --
+
+f = do \
+ return z \
+\
+ where \
+ z = do \
+ a \
+ b --
+
+f = do \
+ return z \
+\
+ where \
+ z = a
+
+f = Con \
+ { a = x \
+ , b = y \
+ , c = z \
+ }
+
+f = return x
+</TEST>
+
+<TEST>
+f = do \
+ x <- y \
+ return x
+
+f = return x
+</TEST>
+
+<TEST> [{smell: { type: long type lists, limit: 2}}]
+f :: Bool -> Int -> (Int -> Proxy '[a, b]) --
+f :: Proxy '[a]
+</TEST>
+
+<TEST>
+f :: Proxy '[a, b]
+f :: Proxy '[a]
+</TEST>
+
+<TEST> [{smell: { type: many imports, limit: 2}}]
+import A; import B --
+import A
+</TEST>
+
+<TEST>
+import A; import B
+import A
+</TEST>
+-}
+
+import Hint.Type
+import Config.Type
+import Data.List.Extra
+import qualified Data.Map as Map
+
+smellModuleHint :: [Setting] -> ModuHint
+smellModuleHint settings scope m@(moduleImports -> imports) = case Map.lookup SmellManyImports (smells settings) of
+ Just n | length imports >= n ->
+ let span = foldl1 mergeSrcSpan $ srcInfoSpan . ann <$> imports
+ displayImports = unlines $ f <$> imports
+ in [rawIdea Warning "Many imports" span displayImports Nothing [] [] ]
+ where
+ f = trimStart . prettyPrint
+ _ -> []
+
+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 :: Decl_ -> Int -> [Idea]
+smellLongFunctions d n = [ idea
+ | (span, idea) <- declSpans d
+ , spanLength span >= n
+ ]
+
+declSpans :: Decl_ -> [(SrcSpanInfo, Idea)]
+declSpans (FunBind _ [Match _ _ _ rhs where_]) = rhsSpans rhs ++ whereSpans where_
+declSpans f@(FunBind l match) = [(l, warn "Long function" f f [])] -- count where clauses
+declSpans (PatBind _ _ rhs where_) = rhsSpans rhs ++ whereSpans where_
+declSpans _ = []
+
+whereSpans :: Maybe (Binds SrcSpanInfo) -> [(SrcSpanInfo, Idea)]
+whereSpans (Just (BDecls _ decls)) = concatMap declSpans decls
+whereSpans _ = []
+
+rhsSpans :: Rhs SrcSpanInfo -> [(SrcSpanInfo, Idea)]
+rhsSpans (UnGuardedRhs l RecConstr{}) = [] --- record constructors get a pass
+rhsSpans r@(UnGuardedRhs l _) = [(l, warn "Long function" r r [])]
+rhsSpans r@(GuardedRhss l _) = [(l, warn "Long function" r r [])]
+
+spanLength :: SrcSpanInfo -> Int
+spanLength (SrcSpanInfo span _) = srcSpanEndLine span - srcSpanStartLine span + 1
+
+smellLongTypeLists :: Decl_ -> Int -> [Idea]
+smellLongTypeLists d@(TypeSig _ _ t) n = warn "Long type list" d d [] <$ filter longTypeList (universe t)
+ where
+ longTypeList (TyPromoted _ (PromotedList _ _ x)) = length x >= n
+ longTypeList _ = False
+smellLongTypeLists _ _ = []
+
+smellManyArgFunctions :: Decl_ -> Int -> [Idea]
+smellManyArgFunctions d@(TypeSig _ _ t) n = warn "Many arg function" d d [] <$ filter manyArgFunction (universe t)
+ where
+ manyArgFunction x = countFunctionArgs x >= n
+smellManyArgFunctions _ _ = []
+
+countFunctionArgs :: Type l -> Int
+countFunctionArgs (TyFun _ _ b) = 1 + countFunctionArgs b
+countFunctionArgs (TyParen _ t) = countFunctionArgs t
+countFunctionArgs _ = 0
+
+smells :: [Setting] -> Map.Map SmellType Int
+smells settings = Map.fromList [ (smellType, smellLimit) | SettingSmell smellType smellLimit <- settings]
diff --git a/src/Test/Annotations.hs b/src/Test/Annotations.hs
index ae22498..fc9704c 100644
--- a/src/Test/Annotations.hs
+++ b/src/Test/Annotations.hs
@@ -10,6 +10,8 @@ import Data.Either.Extra
import Data.List.Extra
import Data.Maybe
import Data.Function
+import Data.Yaml
+import qualified Data.ByteString.Char8 as BS
import Config.Type
import Idea
@@ -18,21 +20,22 @@ import HSE.All
import Test.Util
import Data.Functor
import Prelude
+import Config.Yaml
-- Input, Output
-- Output = Nothing, should not match
-- Output = Just xs, should match xs
-data Test = Test SrcLoc String (Maybe String)
+data Test = Test SrcLoc String (Maybe String) [Setting] deriving (Show)
testAnnotations :: [Setting] -> FilePath -> IO ()
testAnnotations setting file = do
tests <- parseTestFile file
mapM_ f tests
where
- f (Test loc inp out) = do
+ f (Test loc inp out additionalSettings) = do
ideas <- try_ $ do
- res <- applyHintFile defaultParseFlags setting file $ Just inp
+ res <- applyHintFile defaultParseFlags (setting ++ additionalSettings) file $ Just inp
evaluate $ length $ show res
return res
let good = case (out, ideas) of
@@ -69,17 +72,28 @@ testAnnotations setting file = do
parseTestFile :: FilePath -> IO [Test]
parseTestFile file =
-- we remove all leading # symbols since Yaml only lets us do comments that way
- f False . zip [1..] . map (\x -> fromMaybe x $ stripPrefix "# " x) . lines <$> readFile file
+ f Nothing . zip [1..] . map (\x -> fromMaybe x $ stripPrefix "# " x) . lines <$> readFile file
where
- open = isPrefixOf "<TEST>"
+ open :: String -> Maybe [Setting]
+ open line
+ | "<TEST>" `isPrefixOf` line =
+ let suffix = dropPrefix "<TEST>" line
+ config = decodeEither' $ BS.pack suffix
+ in case config of
+ Left err -> Just []
+ Right config -> Just $ settingsFromConfigYaml [config]
+ | otherwise = Nothing
+
+ shut :: String -> Bool
shut = isPrefixOf "</TEST>"
- f False ((i,x):xs) = f (open x) xs
- f True ((i,x):xs)
- | shut x = f False xs
- | null x || "-- " `isPrefixOf` x = f True xs
- | "\\" `isSuffixOf` x, (_,y):ys <- xs = f True $ (i,init x++"\n"++y):ys
- | otherwise = parseTest file i x : f True xs
+ f :: Maybe [Setting] -> [(Int, String)] -> [Test]
+ f Nothing ((i,x):xs) = f (open x) xs
+ f (Just s) ((i,x):xs)
+ | shut x = f Nothing xs
+ | null x || "-- " `isPrefixOf` x = f (Just s) xs
+ | "\\" `isSuffixOf` x, (_,y):ys <- xs = f (Just s) $ (i,init x++"\n"++y):ys
+ | otherwise = parseTest file i x s : f (Just s) xs
f _ [] = []