diff --git a/CHANGES.txt b/CHANGES.txt --- 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 --- 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 @@ ### 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 --- 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 --- 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 @@ 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 @@ 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 @@ 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 --- 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 @@ ,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 --- a/src/Config/Yaml.hs +++ b/src/Config/Yaml.hs @@ -109,6 +109,10 @@ 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 @@ "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 @@ -178,6 +184,17 @@ where 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 diff --git a/src/HLint.hs b/src/HLint.hs --- a/src/HLint.hs +++ b/src/HLint.hs @@ -158,7 +158,7 @@ ++ [("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 --- a/src/HSE/Util.hs +++ b/src/HSE/Util.hs @@ -71,6 +71,10 @@ 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 --- a/src/Hint/All.hs +++ b/src/Hint/All.hs @@ -30,6 +30,7 @@ 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 @@ 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 @@ 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 --- a/src/Hint/Extensions.hs +++ b/src/Hint/Extensions.hs @@ -125,6 +125,8 @@ {-# 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" []}|] -} @@ -164,7 +166,8 @@ , 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 --- a/src/Hint/List.hs +++ b/src/Hint/List.hs @@ -30,6 +30,7 @@ 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] -} @@ -40,7 +41,8 @@ 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,18 +57,24 @@ 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] diff --git a/src/Hint/Match.hs b/src/Hint/Match.hs --- a/src/Hint/Match.hs +++ b/src/Hint/Match.hs @@ -126,23 +126,28 @@ -- 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 + 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 - f (App _ cond (sub -> y)) - | 'i':'s':typ <- fromNamed cond - = isType typ y - f (App _ (App _ cond (sub -> x)) (sub -> y)) + 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 --- a/src/Hint/Naming.hs +++ b/src/Hint/Naming.hs @@ -42,6 +42,7 @@ 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 _ 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 @@ 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 --- /dev/null +++ b/src/Hint/Smell.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE ViewPatterns #-} + +module Hint.Smell ( + smellModuleHint, + smellHint + ) where + +{- + [{smell: { type: many arg functions, limit: 2 }}] +f :: Int -> Int \ +f = undefined + +f :: Int -> Int -> Int \ +f = undefined -- + + + +f :: Int -> Int \ +f = undefined + +f :: Int -> Int -> Int \ +f = undefined + + + [{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 + + + +f = do \ + x <- y \ + return x + +f = return x + + + [{smell: { type: long type lists, limit: 2}}] +f :: Bool -> Int -> (Int -> Proxy '[a, b]) -- +f :: Proxy '[a] + + + +f :: Proxy '[a, b] +f :: Proxy '[a] + + + [{smell: { type: many imports, limit: 2}}] +import A; import B -- +import A + + + +import A; import B +import A + +-} + +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 --- a/src/Test/Annotations.hs +++ b/src/Test/Annotations.hs @@ -10,6 +10,8 @@ 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 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 @@ 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 "" + open :: String -> Maybe [Setting] + open line + | "" `isPrefixOf` line = + let suffix = dropPrefix "" 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 "" - 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 _ [] = []