diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,7 +1,10 @@ Changelog for HLint +1.9.26 + #200, fix all lint warnings + #143, expose argsSettings 1.9.25 - #192, fix stdin output and --refactor on Windows + #192, fix stdin output and --refactor 1.9.24 #188, improve spotting redundant brackets around patterns #138, reenable redundant where hint diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Neil Mitchell 2006-2015. +Copyright Neil Mitchell 2006-2016. All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/data/Default.hs b/data/Default.hs --- a/data/Default.hs +++ b/data/Default.hs @@ -635,7 +635,7 @@ foo = return $! (a,b) -- return (a,b) foo = return $! 1 foo = return $! "test" -bar = [x| (x,_) <- pts] +bar = [x | (x,_) <- pts] return' x = x `seq` return x foo = last (sortBy (compare `on` fst) xs) -- maximumBy (compare `on` fst) xs g = \ f -> parseFile f >>= (\ cu -> return (f, cu)) diff --git a/hlint.cabal b/hlint.cabal --- a/hlint.cabal +++ b/hlint.cabal @@ -1,13 +1,13 @@ cabal-version: >= 1.6 build-type: Simple name: hlint -version: 1.9.25 +version: 1.9.26 license: BSD3 license-file: LICENSE category: Development author: Neil Mitchell maintainer: Neil Mitchell -copyright: Neil Mitchell 2006-2015 +copyright: Neil Mitchell 2006-2016 synopsis: Source code suggestions description: HLint gives suggestions on how to improve your source code. diff --git a/src/Apply.hs b/src/Apply.hs --- a/src/Apply.hs +++ b/src/Apply.hs @@ -33,6 +33,11 @@ -- | Given a way of classifying results, and a 'Hint', apply to a set of modules generating a list of 'Idea's. -- The 'Idea' values will be ordered within a file. +-- +-- Given a set of modules, it may be faster pass each to 'applyHints' in a singleton list. +-- When given multiple modules at once this function attempts to find hints between modules, +-- which is slower and often pointless (by default HLint passes modules singularly, using +-- @--cross@ to pass all modules together). applyHints :: [Classify] -> Hint -> [(Module SrcSpanInfo, [Comment])] -> [Idea] applyHints cls hints_ ms = concat $ [ map (classify $ cls ++ mapMaybe readPragma (universeBi m)) $ diff --git a/src/CmdLine.hs b/src/CmdLine.hs --- a/src/CmdLine.hs +++ b/src/CmdLine.hs @@ -174,7 +174,7 @@ ,CmdHSE {} &= explicit &= name "hse" ] &= program "hlint" &= verbosity - &= summary ("HLint v" ++ showVersion version ++ ", (C) Neil Mitchell 2006-2015") + &= summary ("HLint v" ++ showVersion version ++ ", (C) Neil Mitchell 2006-2016") where nam xs = nam_ xs &= name [head xs] nam_ xs = def &= explicit &= name xs diff --git a/src/Grep.hs b/src/Grep.hs --- a/src/Grep.hs +++ b/src/Grep.hs @@ -10,12 +10,12 @@ runGrep :: String -> ParseFlags -> [FilePath] -> IO () -runGrep pattern flags files = do - exp <- case parseExp pattern of +runGrep patt flags files = do + exp <- case parseExp patt of ParseOk x -> return x ParseFailed sl msg -> exitMessage $ (if "Parse error" `isPrefixOf` msg then msg else "Parse error in pattern: " ++ msg) ++ "\n" ++ - pattern ++ "\n" ++ + patt ++ "\n" ++ replicate (srcColumn sl - 1) ' ' ++ "^" let scope = scopeCreate $ Module an Nothing [] [] [] let rule = hintRules [HintRule Warning "grep" scope exp (Tuple an Boxed []) Nothing []] diff --git a/src/HLint.hs b/src/HLint.hs --- a/src/HLint.hs +++ b/src/HLint.hs @@ -9,8 +9,8 @@ import System.Console.CmdArgs.Verbosity import Data.List import System.Exit -import System.IO import System.IO.Extra +import Data.Tuple.Extra import Prelude import Data.Version @@ -31,6 +31,7 @@ import Parallel import HSE.All + -- | A suggestion - the @Show@ instance is of particular use. newtype Suggestion = Suggestion {fromSuggestion :: Idea} deriving (Eq,Ord) @@ -110,20 +111,21 @@ let flags = parseFlagsSetExtensions (cmdExtensions cmd) $ defaultParseFlags{cppFlags=cmdCpp cmd, encoding=encoding} if null cmdFiles && not (null cmdFindHints) then do hints <- concatMapM (resolveFile cmd Nothing) cmdFindHints - mapM_ (\x -> putStrLn . fst =<< findSettings2 flags x) hints >> return [] + mapM_ (putStrLn . fst <=< findSettings2 flags) hints >> return [] else if null cmdFiles then exitWithHelp - else if cmdRefactor then do + else if cmdRefactor then withTempFile (\t -> runHlintMain cmd (Just t) flags) else runHlintMain cmd Nothing flags runHlintMain :: Cmd -> Maybe FilePath -> ParseFlags -> IO [Suggestion] -runHlintMain cmd@(CmdMain{..}) fp flags = do +runHlintMain cmd@CmdMain{..} fp flags = do files <- concatMapM (resolveFile cmd fp) cmdFiles if null files then error "No files found" else runHints cmd{cmdFiles=files} flags +{-# ANN readAllSettings "HLint: ignore Use let" #-} readAllSettings :: Cmd -> ParseFlags -> IO [Setting] readAllSettings cmd@CmdMain{..} flags = do files <- cmdHintFiles cmd @@ -148,14 +150,14 @@ then putStrLn . showIdeasJson $ showideas else if cmdSerialise then do hSetBuffering stdout NoBuffering - print $ map (\i -> (show i, ideaRefactoring i)) showideas - else if cmdRefactor then do + print $ map (show &&& ideaRefactoring) showideas + else if cmdRefactor then case cmdFiles of [file] -> do -- Ensure that we can find the executable path <- checkRefactor (if cmdWithRefactor == "" then Nothing else Just cmdWithRefactor) -- writeFile "hlint.refact" - let hints = show $ map (\i -> (show i, ideaRefactoring i)) showideas + let hints = show $ map (show &&& ideaRefactoring) showideas withTempFile $ \f -> do writeFile f hints runRefactoring path file f cmdRefactorOptions @@ -188,17 +190,17 @@ checkRefactor :: Maybe FilePath -> IO FilePath checkRefactor rpath = do - let excPath = (fromMaybe "refactor" rpath) + let excPath = fromMaybe "refactor" rpath mexc <- findExecutable excPath case mexc of Just exc -> do - vers <- readP_to_S parseVersion . tail <$> (readProcess exc ["--version"] "") + vers <- readP_to_S parseVersion . tail <$> readProcess exc ["--version"] "" case vers of - [] -> putStrLn "Unabled to determine version of refactor" >> (return exc) + [] -> putStrLn "Unabled to determine version of refactor" >> return exc (last -> (version, _)) -> if versionBranch version >= [0,1,0,0] then return exc else error "Your version of refactor is too old, please upgrade to the latest version" - Nothing -> error $ unlines ["Could not find refactor" + Nothing -> error $ unlines [ "Could not find refactor" , "Tried with: " ++ excPath ] evaluateList :: [a] -> IO [a] diff --git a/src/HSE/All.hs b/src/HSE/All.hs --- a/src/HSE/All.hs +++ b/src/HSE/All.hs @@ -75,9 +75,9 @@ -- figure out the best line number to grab context from, by reparsing flags <- return $ parseFlagsNoLocations flags ppstr2 <- runCpp (cppFlags flags) file str - pe <- return $ case parseFileContentsWithMode (mode flags) ppstr2 of - ParseFailed sl2 _ -> context (srcLine sl2) ppstr2 - _ -> context (srcLine sl) ppstr + let pe = case parseFileContentsWithMode (mode flags) ppstr2 of + ParseFailed sl2 _ -> context (srcLine sl2) ppstr2 + _ -> context (srcLine sl) ppstr Control.Exception.evaluate $ length pe -- if we fail to parse, we may be keeping the file handle alive return $ Left $ ParseError sl msg pe where diff --git a/src/HSE/FreeVars.hs b/src/HSE/FreeVars.hs --- a/src/HSE/FreeVars.hs +++ b/src/HSE/FreeVars.hs @@ -11,7 +11,7 @@ -- which names are bound by a declaration declBind :: Decl_ -> [String] -declBind x = pvars x +declBind = pvars vars x = Set.toList $ freeVars x diff --git a/src/HSE/Util.hs b/src/HSE/Util.hs --- a/src/HSE/Util.hs +++ b/src/HSE/Util.hs @@ -2,7 +2,6 @@ module HSE.Util where -import Control.Applicative import Control.Monad import Data.List import Data.Maybe @@ -223,7 +222,7 @@ descendApps f x = descend f x -descendAppsM :: (Applicative m, Monad m) => (Exp_ -> m Exp_) -> Exp_ -> m Exp_ +descendAppsM :: Monad m => (Exp_ -> m Exp_) -> Exp_ -> m Exp_ descendAppsM f (App s x y) = liftM2 (App s) (descendAppsM f x) (f y) descendAppsM f x = descendM f x @@ -234,7 +233,7 @@ transformApps :: (Exp_ -> Exp_) -> Exp_ -> Exp_ transformApps f = f . descendApps (transformApps f) -transformAppsM :: (Applicative m, Monad m) => (Exp_ -> m Exp_) -> Exp_ -> m Exp_ +transformAppsM :: Monad m => (Exp_ -> m Exp_) -> Exp_ -> m Exp_ transformAppsM f x = f =<< descendAppsM (transformAppsM f) x diff --git a/src/Hint/Bracket.hs b/src/Hint/Bracket.hs --- a/src/Hint/Bracket.hs +++ b/src/Hint/Bracket.hs @@ -1,5 +1,4 @@ {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE RecordWildCards #-} {- Raise an error if you are bracketing an atom, or are enclosed be a list bracket @@ -94,13 +93,13 @@ -bracket :: (Data (a S), Annotated a, Uniplate (a S), ExactP a, Pretty (a S), Brackets (a S)) => Bool -> a S -> [Idea] +bracket :: (Data (a S), Uniplate (a S), ExactP a, Pretty (a S), Brackets (a S)) => Bool -> a S -> [Idea] bracket bad = f Nothing where msg = "Redundant bracket" -- f (Maybe (index, parent, gen)) child - f :: (Data (a S), Annotated a, Uniplate (a S), ExactP a, Pretty (a S), Brackets (a S)) => Maybe (Int,a S,a S -> a S) -> a S -> [Idea] + f :: (Data (a S), Uniplate (a S), ExactP a, Pretty (a S), Brackets (a S)) => Maybe (Int,a S,a S -> a S) -> a S -> [Idea] f Just{} o@(remParen -> Just x) | isAtom x = bracketError msg o x : g x f Nothing o@(remParen -> Just x) | bad || isAtom x = (if isAtom x then bracketError else bracketWarning) msg o x : g x f (Just (i,o,gen)) v@(remParen -> Just x) | not $ needBracket i o x = @@ -110,7 +109,7 @@ r = Replace typ (toSS v) [("x", toSS x)] "x" f _ x = g x - g :: (Data (a S), Annotated a, Uniplate (a S), ExactP a, Pretty (a S), Brackets (a S)) => a S -> [Idea] + g :: (Data (a S), Uniplate (a S), ExactP a, Pretty (a S), Brackets (a S)) => a S -> [Idea] g o = concat [f (Just (i,o,gen)) x | (i,(x,gen)) <- zip [0..] $ holes o] bracketWarning msg o x = diff --git a/src/Hint/Import.hs b/src/Hint/Import.hs --- a/src/Hint/Import.hs +++ b/src/Hint/Import.hs @@ -70,17 +70,17 @@ simplify [] = Nothing simplify (x:xs) = case simplifyHead x xs of Nothing -> first (x:) <$> simplify xs - Just (xs, rs) -> Just $ fromMaybe (xs, rs) $ (second (++ rs) <$> simplify xs) + Just (xs, rs) -> Just $ fromMaybe (xs, rs) (second (++ rs) <$> simplify xs) simplifyHead :: ImportDecl S -> [ImportDecl S] -> Maybe ([ImportDecl S], [Refactoring R.SrcSpan]) simplifyHead x [] = Nothing simplifyHead x (y:ys) = case reduce x y of Nothing -> first (y:) <$> simplifyHead x ys - Just (xy, rs) -> Just $ (xy : ys, rs) + Just (xy, rs) -> Just (xy : ys, rs) -reduce :: ImportDecl S -> ImportDecl S -> Maybe ((ImportDecl S), [Refactoring R.SrcSpan]) +reduce :: ImportDecl S -> ImportDecl S -> Maybe (ImportDecl S, [Refactoring R.SrcSpan]) reduce x y | qual, as, specs = Just (x, [Delete Import (toSS y)]) | qual, as, Just (ImportSpecList _ False xs) <- importSpecs x, Just (ImportSpecList _ False ys) <- importSpecs y = let newImp = x{importSpecs = Just $ ImportSpecList an False $ nub_ $ xs ++ ys} in Just (newImp, [ Replace Import (toSS x) [] (prettyPrint newImp) @@ -131,7 +131,7 @@ = let newModuleName = y ++ "." ++ x r = [Replace R.ModuleName (toSS m) [] newModuleName] in - [warn "Use hierarchical imports" i (desugarQual i){importModule=ModuleName an $ newModuleName} r] + [warn "Use hierarchical imports" i (desugarQual i){importModule=ModuleName an newModuleName} r] -- import IO is equivalent to -- import System.IO, import System.IO.Error, import Control.Exception(bracket, bracket_) diff --git a/src/Hint/List.hs b/src/Hint/List.hs --- a/src/Hint/List.hs +++ b/src/Hint/List.hs @@ -76,8 +76,11 @@ in Just (literal, [], prettyPrint literal) usePString _ = Nothing -usePList = fmap (\(e, s) -> (PList an e, map (fmap toSS) s, prettyPrint (PList an (map snd s)))) - . fmap unzip . f True ['a'..'z'] +usePList = + fmap ( (\(e, s) -> (PList an e, map (fmap toSS) s, prettyPrint (PList an (map snd s)))) + . unzip + ) + . f True ['a'..'z'] where f first _ x | x ~= "[]" = if first then Nothing else Just [] f first (ident: cs) (view -> PApp_ ":" [a,b]) = @@ -92,8 +95,11 @@ in Just (literal , [], prettyPrint literal) useString b _ = Nothing -useList b = fmap (\(e, s) -> (List an e, map (fmap toSS) s, prettyPrint (List an (map snd s)))) - . fmap unzip . f True ['a'..'z'] +useList b = + fmap ( (\(e, s) -> (List an e, map (fmap toSS) s, prettyPrint (List an (map snd s)))) + . unzip + ) + . f True ['a'..'z'] where f first _ x | x ~= "[]" = if first then Nothing else Just [] f first (ident:cs) (view -> App2 c a b) | c ~= ":" = @@ -110,11 +116,11 @@ , [("x", toSS x2), ("xs", toSS y)] , prettyPrint $ gen (build $ toNamed "x") (toNamed "xs")) where - f (List _ [x]) = Just $ (x, \v -> if isApp x then v else paren v) + f (List _ [x]) = Just (x, \v -> if isApp x then v else paren v) f _ = Nothing - gen x xs = InfixApp an x (QConOp an $ list_cons_name an) xs + gen x = InfixApp an x (QConOp an $ list_cons_name an) useCons _ _ = Nothing diff --git a/src/Hint/ListRec.hs b/src/Hint/ListRec.hs --- a/src/Hint/ListRec.hs +++ b/src/Hint/ListRec.hs @@ -48,7 +48,7 @@ let y = addCase x guard $ recursiveStr `notElem` varss y -- Maybe we can do better here maintaining source formatting? - return $ (idea severity ("Use " ++ use) o y [Replace Decl (toSS o) [] (prettyPrint y)]) + return $ idea severity ("Use " ++ use) o y [Replace Decl (toSS o) [] (prettyPrint y)] recursiveStr = "_recursive_" diff --git a/src/Hint/Match.hs b/src/Hint/Match.hs --- a/src/Hint/Match.hs +++ b/src/Hint/Match.hs @@ -82,7 +82,7 @@ -- find a dot version of this rule, return the sequence of app prefixes, and the var dotVersion :: Exp_ -> [([Exp_], String)] dotVersion (view -> Var_ v) | isUnifyVar v = [([], v)] -dotVersion (App l ls rs) = first (ls :) <$> dotVersion (fromParen $ rs) +dotVersion (App l ls rs) = first (ls :) <$> dotVersion (fromParen rs) dotVersion (InfixApp l x op y) = (first (LeftSection l x op :) <$> dotVersion y) ++ (first (RightSection l op y:) <$> dotVersion x) dotVersion _ = [] @@ -120,8 +120,8 @@ descendBracketTemplate :: (Exp_ -> (Bool, (Exp_, Exp_))) -> Exp_ -> Exp_ descendBracketTemplate op x = descendIndex g x where - g i y = if a then f i b else (fst b) - where (a,b) = op y + g i y = if a then f i b else fst b + where (a, b) = op y f i (v, y) | needBracket i x y = addParen v f i (v, y) = v @@ -176,7 +176,7 @@ -- do not expand out a dot at the root, since otherwise you get two matches because of readRule (Bug #570) unifyExp :: NameMatch -> Bool -> Exp_ -> Exp_ -> Maybe [(String,Exp_)] unifyExp nm root x y | isParen x || isParen y = - map (rebracket y) <$> (unifyExp nm root (fromParen x) (fromParen y)) + map (rebracket y) <$> unifyExp nm root (fromParen x) (fromParen y) unifyExp nm root (Var _ (fromNamed -> v)) y | isUnifyVar v = Just [(v,y)] unifyExp nm root (Var _ x) (Var _ y) | nm x y = Just [] unifyExp nm root x@(App _ x1 x2) (App _ y1 y2) = diff --git a/src/Hint/Monad.hs b/src/Hint/Monad.hs --- a/src/Hint/Monad.hs +++ b/src/Hint/Monad.hs @@ -75,7 +75,7 @@ monadCall (App l x y) = middle (\x -> App l x y) <$> monadCall x monadCall (InfixApp l x op y) | isDol op = middle (\x -> InfixApp l x op y) <$> monadCall x - | op ~= ">>=" = middle (\y -> InfixApp l x op y) <$> monadCall y + | op ~= ">>=" = middle (InfixApp l x op) <$> monadCall y monadCall (replaceBranches -> (bs@(_:_), gen)) | all isJust res = Just ("Use simple functions", gen $ map (\(Just (a,b,c)) -> b) res, rs) where res = map monadCall bs @@ -90,7 +90,7 @@ [Replace Stmt (toSS g) [("x", toSS x)] "x", Delete Stmt (toSS q)]) monadReturn _ = Nothing -monadJoin :: [Stmt S] -> [Char] -> Maybe ([Stmt S], [Refactoring R.SrcSpan]) +monadJoin :: [Stmt S] -> String -> Maybe ([Stmt S], [Refactoring R.SrcSpan]) monadJoin (g@(Generator _ (view -> PVar_ p) x):q@(Qualifier _ (view -> Var_ v)):xs) (c:cs) | p == v && v `notElem` varss xs = Just . f $ fromMaybe def (monadJoin xs cs) diff --git a/src/Hint/Naming.hs b/src/Hint/Naming.hs --- a/src/Hint/Naming.hs +++ b/src/Hint/Naming.hs @@ -48,7 +48,7 @@ namingHint _ modu = naming $ Set.fromList [x | Ident _ x <- universeS modu] naming :: Set.Set String -> Decl_ -> [Idea] -naming seen x = [(warnN "Use camelCase" x2 (replaceNames res x2)) | not $ null res] +naming seen x = [warnN "Use camelCase" x2 (replaceNames res x2) | not $ null res] where res = [(n,y) | n <- nub $ getNames x, Just y <- [suggestName n], not $ y `Set.member` seen] x2 = shorten x diff --git a/src/Hint/Structure.hs b/src/Hint/Structure.hs --- a/src/Hint/Structure.hs +++ b/src/Hint/Structure.hs @@ -39,6 +39,7 @@ module Hint.Structure(structureHint) where import Hint.Type +import Data.Function import Data.List.Extra import Data.Tuple import Data.Maybe @@ -58,7 +59,7 @@ hints gen (Pattern l rtype pat (UnGuardedRhs d bod) bind) | length guards > 2 = [gen "Use guards" (Pattern l rtype pat (GuardedRhss d guards) bind) [refactoring]] where rawGuards = asGuards bod - mkGuard a b = GuardedRhs an [Qualifier an a] b + mkGuard a = GuardedRhs an [Qualifier an a] guards = map (uncurry mkGuard) rawGuards (lhs, rhs) = unzip rawGuards mkTemplate c ps = @@ -73,7 +74,7 @@ ps -> mkTemplate "p100" ps guardSubts = mkTemplate "g100" lhs exprSubts = mkTemplate "e100" rhs - templateGuards = zipWith (\a b -> mkGuard (toString a) (toString b)) guardSubts exprSubts + templateGuards = zipWith (mkGuard `on` toString) guardSubts exprSubts toString (Left e) = e toString (Right (v, _)) = toNamed v template = fromMaybe "" $ ideaTo (gen "" (Pattern l rtype (map toString patSubts) (GuardedRhss d templateGuards) bind) []) diff --git a/src/Hint/Type.hs b/src/Hint/Type.hs --- a/src/Hint/Type.hs +++ b/src/Hint/Type.hs @@ -1,11 +1,10 @@ - -module Hint.Type(module Hint.Type, module Idea, module HSE.All, module Refact) where +module Hint.Type(module Hint.Type, module Export) where import Data.Monoid -import HSE.All -import Idea +import HSE.All as Export +import Idea as Export import Prelude -import Refact +import Refact as Export type DeclHint = Scope -> Module_ -> Decl_ -> [Idea] diff --git a/src/Hint/Util.hs b/src/Hint/Util.hs --- a/src/Hint/Util.hs +++ b/src/Hint/Util.hs @@ -48,14 +48,14 @@ niceLambdaR [x,y] (view -> App2 op (view -> Var_ y1) (view -> Var_ x1)) | x == x1, y == y1, vars op `disjoint` [x,y] = (gen op, \s -> [Replace Expr s [("x", toSS op)] (prettyPrint $ gen (toNamed "x"))]) where - gen x = App an (toNamed "flip") x + gen = App an (toNamed "flip") -- \x -> f (b x) ==> f . b -- \x -> f $ b x ==> f . b niceLambdaR [x] y | Just (z, subts) <- factor y, x `notElem` vars z = (z, \s -> [mkRefact subts s]) where -- factor the expression with respect to x - factor y@(App _ ini lst) | view lst == Var_ x = Just $ (ini, [ann ini]) + factor y@(App _ ini lst) | view lst == Var_ x = Just (ini, [ann ini]) factor y@(App _ ini lst) | Just (z, ss) <- factor lst = let r = niceDotApp ini z in if r == z then Just (r, ss) else Just (r, ann ini : ss) diff --git a/src/Idea.hs b/src/Idea.hs --- a/src/Idea.hs +++ b/src/Idea.hs @@ -70,7 +70,7 @@ rawIdea = Idea "" "" rawIdeaN a b c d e f = Idea "" "" a b c d e f [] -idea severity hint from to rs = rawIdea severity hint (toSrcSpan $ ann from) (f from) (Just $ f to) [] rs +idea severity hint from to = rawIdea severity hint (toSrcSpan $ ann from) (f from) (Just $ f to) [] where f = trimStart . prettyPrint warn = idea Warning err = idea Error @@ -81,4 +81,3 @@ warnN = ideaN Warning errN = ideaN Error - diff --git a/src/Language/Haskell/HLint3.hs b/src/Language/Haskell/HLint3.hs --- a/src/Language/Haskell/HLint3.hs +++ b/src/Language/Haskell/HLint3.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TupleSections, PatternGuards #-} +{-# LANGUAGE TupleSections, PatternGuards, RecordWildCards #-} -- | /WARNING: This module represents the evolving second version of the HLint API./ -- /It will be renamed to drop the "3" in the next major version./ @@ -16,7 +16,7 @@ Idea(..), Severity(..), Note(..), -- * Settings Classify(..), - getHLintDataDir, autoSettings, + getHLintDataDir, autoSettings, argsSettings, findSettings, readSettingsFile, -- * Hints HintBuiltin(..), HintRule(..), @@ -33,6 +33,8 @@ import Hint.Type import Hint.All import CmdLine +import Util +import System.IO import Paths_hlint import Data.List.Extra @@ -61,7 +63,25 @@ return (parseFlagsAddFixities fixities defaultParseFlags, classify, resolveHints hints) --- | Given a directory (or 'Nothing' to imply 'getHLintDataDir'), and a mdoule name +-- | A version of 'autoSettings' which respects some of the arguments supported by HLint. +-- If arguments unrecognised by HLint are used it will result in an error. +-- Arugments which have no representation in the return type are silently ignored. +argsSettings :: [String] -> IO (ParseFlags, [Classify], Hint) +argsSettings args = do + cmd <- getCmd args + case cmd of + CmdMain{..} -> do + -- FIXME: Two things that could be supported (but aren't) are 'cmdGivenHints' and 'cmdWithHints'. + (fixities, classify, hints) <- findSettings (readSettingsFile $ Just cmdDataDir) Nothing + encoding <- if cmdUtf8 then return utf8 else readEncoding cmdEncoding + let flags = parseFlagsSetExtensions (cmdExtensions cmd) $ parseFlagsAddFixities fixities $ + defaultParseFlags{cppFlags = cmdCpp cmd, encoding = encoding} + let ignore = [Classify Ignore x "" "" | x <- cmdIgnore] + return (flags, classify ++ ignore, resolveHints hints) + _ -> error "Can only invoke autoSettingsArgs with the root process" + + +-- | Given a directory (or 'Nothing' to imply 'getHLintDataDir'), and a module name -- (e.g. @HLint.Default@), find the settings file associated with it, returning the -- name of the file, and (optionally) the contents. -- diff --git a/src/Test/All.hs b/src/Test/All.hs --- a/src/Test/All.hs +++ b/src/Test/All.hs @@ -7,6 +7,8 @@ import Data.List import System.Directory import System.FilePath +import Data.Functor +import Prelude import Settings import CmdLine @@ -19,6 +21,7 @@ import System.IO.Extra +{-# ANN test "HLint: ignore Use let" #-} test :: Cmd -> ([String] -> IO ()) -> FilePath -> [FilePath] -> IO Int test CmdTest{..} main dataDir files = withBuffering stdout NoBuffering $ withTests $ do hasSrc <- doesFileExist "hlint.cabal" @@ -26,7 +29,7 @@ testFiles <- if files /= [] then return files else do xs <- getDirectoryContents dataDir return [dataDir x | x <- xs, takeExtension x == ".hs", not $ "HLint" `isPrefixOf` takeBaseName x] - testFiles <- forM testFiles $ \file -> fmap ((,) file) $ readSettings2 dataDir [file] [] + testFiles <- forM testFiles $ \file -> (,) file <$> readSettings2 dataDir [file] [] let wrap msg act = putStr (msg ++ " ") >> act >> putStrLn "" putStrLn "Testing" diff --git a/src/Test/InputOutput.hs b/src/Test/InputOutput.hs --- a/src/Test/InputOutput.hs +++ b/src/Test/InputOutput.hs @@ -67,7 +67,7 @@ code <- newIORef ExitSuccess got <- fmap (reverse . dropWhile null . reverse . map trimEnd . lines . fst) $ captureOutput $ handle (\(e::SomeException) -> print e) $ - handle (\(e::ExitCode) -> writeIORef code e) $ do + handle (\(e::ExitCode) -> writeIORef code e) $ bracket getVerbosity setVerbosity $ const $ setVerbosity Normal >> main run code <- readIORef code (want,got) <- return $ matchStarStar (lines output) got diff --git a/src/Test/Util.hs b/src/Test/Util.hs --- a/src/Test/Util.hs +++ b/src/Test/Util.hs @@ -33,8 +33,7 @@ progress = putChar '.' passed :: IO () -passed = do - atomicModifyIORef ref $ \(r:rs) -> (r{total=total r+1}:rs, ()) +passed = atomicModifyIORef ref $ \(r:rs) -> (r{total=total r+1}:rs, ()) failed :: [String] -> IO () failed xs = do