diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,5 +1,13 @@ Changelog for HLint +1.9.41 + #299, warn in some cases when NumDecimals extension is unused + #300, warn when LambdaCase extension is unused + #301, when suggesting newtype remove strictness annotations + #297, better testing that there isn't a performance regression + #167, add -j flag for number of threads + #292, add fst/snd . unzip ==> map fst/snd + Don't suggest module export trick, breaks Haddock 1.9.40 #293, fix the JSON format of the output 1.9.39 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -17,7 +17,7 @@ * HLint operates on each module at a time in isolation, as a result HLint does not know about types or which names are in scope. * The presence of `seq` may cause some hints (i.e. eta-reduction) to change the semantics of a program. -* Either the monomorphism restriction, or rank-2 types, may cause transformed programs to require type signatures to be manually inserted. +* Some transformed programs may require additional type signatures, particularly if the transformations trigger the monomorphism restriction or involve rank-2 types. * The `RebindableSyntax` extension can cause HLint to suggest incorrect changes. * HLint turns on many language extensions so it can parse more documents, occasionally some break otherwise legal syntax - e.g. `{-#INLINE foo#-}` doesn't work with `MagicHash`. These extensions can be disabled with `-XNoMagicHash`. @@ -102,7 +102,7 @@ ### Parallel Operation -To run HLint on n processors append the flags `+RTS -Nn`, as described in the [GHC user manual](http://www.haskell.org/ghc/docs/latest/html/users_guide/runtime-control.html). HLint will usually perform fastest if n is equal to the number of physical processors. +To run HLint on 4 processors append the flags `-j4`. HLint will usually perform fastest if n is equal to the number of physical processors, which can be done with `-j` alone. If your version of GHC does not support the GHC threaded runtime then install with the command: `cabal install --flags="-threaded"` diff --git a/data/Default.hs b/data/Default.hs --- a/data/Default.hs +++ b/data/Default.hs @@ -226,6 +226,7 @@ warn "Redundant $" = (($) . f) ==> f warn "Redundant $" = (f $) ==> f hint = (\x -> y) ==> const y where _ = isAtom y && not (isWildcard y) + -- isWildcard because some people like to put brackets round them even though they are atomic warn "Redundant flip" = flip f x y ==> f y x where _ = isApp original warn "Evaluate" = id x ==> x where _ = not (isTypeApp x) @@ -383,6 +384,11 @@ warn "Redundant $!" = f $! x ==> f x where _ = isWHNF x warn "Redundant evaluate" = evaluate x ==> return x where _ = isWHNF x +-- TUPLE + +warn = fst (unzip x) ==> map fst x +warn = snd (unzip x) ==> map snd x + -- MAYBE warn = maybe x id ==> Data.Maybe.fromMaybe x @@ -646,6 +652,8 @@ no = x `elem` y no = elem 1 [] : [] test a = foo (\x -> True) -- const True +test a = foo (\_ -> True) -- const True +test a = foo (\x -> x) -- id h a = flip f x (y z) -- f (y z) x h a = flip f x $ y z yes x = case x of {True -> a ; False -> b} -- if x then a else b diff --git a/data/Test.hs b/data/Test.hs --- a/data/Test.hs +++ b/data/Test.hs @@ -105,10 +105,6 @@ {-# ANN module "HLint: ignore Unused LANGUAGE pragma" #-} \ {-# LANGUAGE RecordWildCards #-} -- @Ignore ??? -{-# ANN module "HLint: ignore Use import/export shortcut" #-} \ -module ABCD(module A, module B, module C) where \ -import A; import B; import C -- @Ignore ??? - {-# ANN lam "HLint: ignore Redundant lambda" #-} \ lam = \x -> x x x -- @Ignore ??? 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: 1.9.40 +version: 1.9.41 license: BSD3 license-file: LICENSE category: Development @@ -29,7 +29,7 @@ extra-doc-files: README.md CHANGES.txt -tested-with: GHC==8.0.1, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 +tested-with: GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 source-repository head type: git @@ -76,16 +76,17 @@ HLint HsColour Idea - Settings Report Util Parallel Refact + Config.Haskell + Config.Type HSE.All HSE.Bracket - HSE.Evaluate HSE.FreeVars HSE.Match + HSE.Reduce HSE.Scope HSE.Type HSE.Util diff --git a/src/Apply.hs b/src/Apply.hs --- a/src/Apply.hs +++ b/src/Apply.hs @@ -10,7 +10,8 @@ import Data.List.Extra import Data.Maybe import Data.Ord -import Settings +import Config.Type +import Config.Haskell import Idea import Prelude @@ -38,7 +39,7 @@ -- 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 :: [Classify] -> Hint -> [(Module_, [Comment])] -> [Idea] applyHints cls hints_ ms = concat $ [ map (classify $ cls ++ mapMaybe readPragma (universeBi m)) $ order "" (hintModule hints nm m) `merge` diff --git a/src/CmdLine.hs b/src/CmdLine.hs --- a/src/CmdLine.hs +++ b/src/CmdLine.hs @@ -76,6 +76,7 @@ ,cmdGivenHints :: [FilePath] -- ^ which settignsfiles were explicitly given ,cmdWithHints :: [String] -- ^ hints that are given on the command line ,cmdColor :: ColorMode -- ^ color the result + ,cmdThreads :: Int -- ^ Numbmer of threads to use, 0 = whatever GHC has ,cmdIgnore :: [String] -- ^ the hints to ignore ,cmdShowAll :: Bool -- ^ display all skipped items ,cmdExtension :: [String] -- ^ extensions @@ -137,6 +138,7 @@ ,cmdGivenHints = nam "hint" &= typFile &= help "Hint/ignore file to use" ,cmdWithHints = nam "with" &= typ "HINT" &= help "Extra hints to use" ,cmdColor = nam "colour" &= name "color" &= opt Always &= typ "always/never/auto" &= help "Color output (requires ANSI terminal; auto means on when $TERM is supported; by itself, selects always)" + ,cmdThreads = 1 &= name "threads" &= name "j" &= opt (0 :: Int) &= help "Number of threads to use (-j for all)" ,cmdIgnore = nam "ignore" &= typ "HINT" &= help "Ignore a particular hint" ,cmdShowAll = nam "show" &= help "Show all ignored ideas" ,cmdExtension = nam "extension" &= typ "EXT" &= help "File extensions to search (default hs/lhs)" diff --git a/src/Config/Haskell.hs b/src/Config/Haskell.hs new file mode 100644 --- /dev/null +++ b/src/Config/Haskell.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE PatternGuards, ViewPatterns #-} + +module Config.Haskell( + findSettings, readSettings, + readSettings2, readPragma, findSettings2, addInfix + ) where + +import Data.Monoid +import HSE.All +import Control.Monad.Extra +import Data.Char +import Data.Either +import Data.List.Extra +import System.FilePath +import Config.Type +import Util +import Prelude + + +getSeverity :: String -> Maybe Severity +getSeverity "ignore" = Just Ignore +getSeverity "warn" = Just Warning +getSeverity "warning" = Just Warning +getSeverity "suggest" = Just Suggestion +getSeverity "suggestion" = Just Suggestion +getSeverity "error" = Just Error +getSeverity "hint" = Just Suggestion +getSeverity _ = Nothing + + +addInfix = parseFlagsAddFixities $ infix_ (-1) ["==>"] + + +--------------------------------------------------------------------- +-- READ A SETTINGS FILE + +-- Given a list of hint files to start from +-- Return the list of settings commands +readSettings2 :: FilePath -> [FilePath] -> [String] -> IO [Setting] +readSettings2 dataDir files hints = do + (builtin,mods) <- fmap partitionEithers $ concatMapM (readHints dataDir) $ map Right files ++ map Left hints + return $ map Builtin builtin ++ concatMap moduleSettings_ mods + +moduleSettings_ :: Module_ -> [Setting] +moduleSettings_ m = concatMap (readSetting $ scopeCreate m) $ concatMap getEquations $ + [AnnPragma l x | AnnModulePragma l x <- modulePragmas m] ++ moduleDecls m + +-- | Given a module containing HLint settings information return the 'Classify' rules and the 'HintRule' expressions. +-- Any fixity declarations will be discarded, but any other unrecognised elements will result in an exception. +readSettings :: Module_ -> ([Classify], [HintRule]) +readSettings m = ([x | SettingClassify x <- xs], [x | SettingMatchExp x <- xs]) + where xs = moduleSettings_ m + + +readHints :: FilePath -> Either String FilePath -> IO [Either String Module_] +readHints datadir x = do + (builtin,ms) <- case x of + Left src -> findSettings datadir "CommandLine" (Just src) + Right file -> findSettings datadir file Nothing + return $ map Left builtin ++ map Right ms + + +-- | Given the data directory (where the @hlint@ data files reside, see 'getHLintDataDir'), +-- and a filename to read, and optionally that file's contents, produce a pair containing: +-- +-- 1. Builtin hints to use, e.g. @"List"@, which should be resolved using 'builtinHints'. +-- +-- 1. A list of modules containing hints, suitable for processing with 'readSettings'. +-- +-- Any parse failures will result in an exception. +findSettings :: FilePath -> FilePath -> Maybe String -> IO ([String], [Module_]) +findSettings dataDir file contents = do + let flags = addInfix defaultParseFlags + res <- parseModuleEx flags file contents + case res of + Left (ParseError sl msg err) -> exitMessage $ "Parse failure at " ++ showSrcLoc sl ++ ": " ++ msg ++ "\n" ++ err + Right (m, _) -> do + ys <- sequence [f $ fromNamed $ importModule i | i <- moduleImports m, importPkg i `elem` [Just "hint", Just "hlint"]] + return $ concatUnzip $ ([],[m]) : ys + where + f x | Just x <- "HLint.Builtin." `stripPrefix` x = return ([x],[]) + | Just x <- "HLint." `stripPrefix` x = findSettings dataDir (dataDir x <.> "hs") Nothing + | otherwise = findSettings dataDir (x <.> "hs") Nothing + + +readSetting :: Scope -> Decl_ -> [Setting] +readSetting s (FunBind _ [Match _ (Ident _ (getSeverity -> Just severity)) pats (UnGuardedRhs _ bod) bind]) + | InfixApp _ lhs op rhs <- bod, opExp op ~= "==>" = + let (a,b) = readSide $ childrenBi bind in + [SettingMatchExp $ HintRule severity (head $ snoc names defaultHintName) s (fromParen lhs) (fromParen rhs) a b] + | otherwise = [SettingClassify $ Classify severity n a b | n <- names2, (a,b) <- readFuncs bod] + where + names = filter (not . null) $ getNames pats bod + names2 = ["" | null names] ++ names + +readSetting s x | "test" `isPrefixOf` map toLower (fromNamed x) = [] +readSetting s (AnnPragma _ x) | Just y <- readPragma x = [SettingClassify y] +readSetting s (PatBind an (PVar _ name) bod bind) = readSetting s $ FunBind an [Match an name [] bod bind] +readSetting s (FunBind an xs) | length xs /= 1 = concatMap (readSetting s . FunBind an . return) xs +readSetting s (SpliceDecl an (App _ (Var _ x) (Lit _ y))) = readSetting s $ FunBind an [Match an (toNamed $ fromNamed x) [PLit an (Signless an) y] (UnGuardedRhs an $ Lit an $ String an "" "") Nothing] +readSetting s x@InfixDecl{} = map Infix $ getFixity x +readSetting s x = errorOn x "bad hint" + + +-- return Nothing if it is not an HLint pragma, otherwise all the settings +readPragma :: Annotation S -> Maybe Classify +readPragma o = case o of + Ann _ name x -> f (fromNamed name) x + TypeAnn _ name x -> f (fromNamed name) x + ModuleAnn _ x -> f "" x + where + f name (Lit _ (String _ s _)) | "hlint:" `isPrefixOf` map toLower s = + case getSeverity a of + Nothing -> errorOn o "bad classify pragma" + Just severity -> Just $ Classify severity (trimStart b) "" name + where (a,b) = break isSpace $ trimStart $ drop 6 s + f name (Paren _ x) = f name x + f name (ExpTypeSig _ x _) = f name x + f _ _ = Nothing + + +readSide :: [Decl_] -> (Maybe Exp_, [Note]) +readSide = foldl f (Nothing,[]) + where f (Nothing,notes) (PatBind _ PWildCard{} (UnGuardedRhs _ side) Nothing) = (Just side, notes) + f (Nothing,notes) (PatBind _ (fromNamed -> "side") (UnGuardedRhs _ side) Nothing) = (Just side, notes) + f (side,[]) (PatBind _ (fromNamed -> "note") (UnGuardedRhs _ note) Nothing) = (side,g note) + f _ x = errorOn x "bad side condition" + + g (Lit _ (String _ x _)) = [Note x] + g (List _ xs) = concatMap g xs + g x = case fromApps x of + [con -> Just "IncreasesLaziness"] -> [IncreasesLaziness] + [con -> Just "DecreasesLaziness"] -> [DecreasesLaziness] + [con -> Just "RemovesError",fromString -> Just a] -> [RemovesError a] + [con -> Just "ValidInstance",fromString -> Just a,var -> Just b] -> [ValidInstance a b] + _ -> errorOn x "bad note" + + con :: Exp_ -> Maybe String + con c@Con{} = Just $ prettyPrint c; con _ = Nothing + var c@Var{} = Just $ prettyPrint c; var _ = Nothing + + +-- Note: Foo may be ("","Foo") or ("Foo",""), return both +readFuncs :: Exp_ -> [(String, String)] +readFuncs (App _ x y) = readFuncs x ++ readFuncs y +readFuncs (Lit _ (String _ "" _)) = [("","")] +readFuncs (Var _ (UnQual _ name)) = [("",fromNamed name)] +readFuncs (Var _ (Qual _ (ModuleName _ mod) name)) = [(mod, fromNamed name)] +readFuncs (Con _ (UnQual _ name)) = [(fromNamed name,""),("",fromNamed name)] +readFuncs (Con _ (Qual _ (ModuleName _ mod) name)) = [(mod ++ "." ++ fromNamed name,""),(mod,fromNamed name)] +readFuncs x = errorOn x "bad classification rule" + + +getNames :: [Pat_] -> Exp_ -> [String] +getNames ps _ | ps /= [], Just ps <- mapM fromPString ps = ps +getNames [] (InfixApp _ lhs op rhs) | opExp op ~= "==>" = map ("Use "++) names + where + lnames = map f $ childrenS lhs + rnames = map f $ childrenS rhs + names = filter (not . isUnifyVar) $ (rnames \\ lnames) ++ rnames + f (Ident _ x) = x + f (Symbol _ x) = x +getNames _ _ = [] + + +errorOn :: (Annotated ast, Pretty (ast S)) => ast S -> String -> b +errorOn val msg = exitMessage $ + showSrcLoc (getPointLoc $ ann val) ++ + ": Error while reading hint file, " ++ msg ++ "\n" ++ + prettyPrint val + + +--------------------------------------------------------------------- +-- FIND SETTINGS IN A SOURCE FILE + +-- find definitions in a source file +findSettings2 :: ParseFlags -> FilePath -> IO (String, [Setting]) +findSettings2 flags file = do + x <- parseModuleEx flags file Nothing + case x of + Left (ParseError sl msg _) -> + return ("-- Parse error " ++ showSrcLoc sl ++ ": " ++ msg, []) + Right (m, _) -> do + let xs = concatMap (findSetting $ UnQual an) (moduleDecls m) + s = unlines $ ["-- hints found in " ++ file] ++ map prettyPrint xs ++ ["-- no hints found" | null xs] + r = concatMap (readSetting mempty) xs + return (s,r) + + +findSetting :: (Name S -> QName S) -> Decl_ -> [Decl_] +findSetting qual (InstDecl _ _ _ (Just xs)) = concatMap (findSetting qual) [x | InsDecl _ x <- xs] +findSetting qual (PatBind _ (PVar _ name) (UnGuardedRhs _ bod) Nothing) = findExp (qual name) [] bod +findSetting qual (FunBind _ [InfixMatch _ p1 name ps rhs bind]) = findSetting qual $ FunBind an [Match an name (p1:ps) rhs bind] +findSetting qual (FunBind _ [Match _ name ps (UnGuardedRhs _ bod) Nothing]) = findExp (qual name) [] $ Lambda an ps bod +findSetting _ x@InfixDecl{} = [x] +findSetting _ _ = [] + + +-- given a result function name, a list of variables, a body expression, give some hints +findExp :: QName S -> [String] -> Exp_ -> [Decl_] +findExp name vs (Lambda _ ps bod) | length ps2 == length ps = findExp name (vs++ps2) bod + | otherwise = [] + where ps2 = [x | PVar_ x <- map view ps] +findExp name vs Var{} = [] +findExp name vs (InfixApp _ x dot y) | isDot dot = findExp name (vs++["_hlint"]) $ App an x $ Paren an $ App an y (toNamed "_hlint") + +findExp name vs bod = [PatBind an (toNamed "warn") (UnGuardedRhs an $ InfixApp an lhs (toNamed "==>") rhs) Nothing] + where + lhs = g $ transform f bod + rhs = apps $ Var an name : map snd rep + + rep = zip vs $ map (toNamed . return) ['a'..] + f xx | Var_ x <- view xx, Just y <- lookup x rep = y + f (InfixApp _ x dol y) | isDol dol = App an x (paren y) + f x = x + + g o@(InfixApp _ _ _ x) | isAnyApp x || isAtom x = o + g o@App{} = o + g o = paren o diff --git a/src/Config/Type.hs b/src/Config/Type.hs new file mode 100644 --- /dev/null +++ b/src/Config/Type.hs @@ -0,0 +1,85 @@ + +module Config.Type( + Severity(..), Classify(..), HintRule(..), Note(..), Setting(..), + defaultHintName, isUnifyVar, showNotes, + ) where + +import HSE.All +import Data.Char +import Data.List.Extra +import Prelude + + +defaultHintName :: String +defaultHintName = "Use alternative" + + +-- | How severe an issue is. +data Severity + = Ignore -- ^ The issue has been explicitly ignored and will usually be hidden (pass @--show@ on the command line to see ignored ideas). + | Suggestion -- ^ Suggestions are things that some people may consider improvements, but some may not. + | Warning -- ^ Warnings are suggestions that are nearly always a good idea to apply. + | Error -- ^ Available as a setting for the user. + deriving (Eq,Ord,Show,Read,Bounded,Enum) + + +-- Any 1-letter variable names are assumed to be unification variables +isUnifyVar :: String -> Bool +isUnifyVar [x] = x == '?' || isAlpha x +isUnifyVar _ = False + + +--------------------------------------------------------------------- +-- TYPE + +-- | A note describing the impact of the replacement. +data Note + = IncreasesLaziness -- ^ The replacement is increases laziness, for example replacing @reverse (reverse x)@ with @x@ makes the code lazier. + | DecreasesLaziness -- ^ The replacement is decreases laziness, for example replacing @(fst x, snd x)@ with @x@ makes the code stricter. + | RemovesError String -- ^ The replacement removes errors, for example replacing @foldr1 (+)@ with @sum@ removes an error on @[]@, and might contain the text @\"on []\"@. + | ValidInstance String String -- ^ The replacement assumes standard type class lemmas, a hint with the note @ValidInstance \"Eq\" \"x\"@ might only be valid if + -- the @x@ variable has a reflexive @Eq@ instance. + | Note String -- ^ An arbitrary note. + deriving (Eq,Ord) + +instance Show Note where + show IncreasesLaziness = "increases laziness" + show DecreasesLaziness = "decreases laziness" + show (RemovesError x) = "removes error " ++ x + show (ValidInstance x y) = "requires a valid " ++ x ++ " instance for " ++ y + show (Note x) = x + + +showNotes :: [Note] -> String +showNotes = intercalate ", " . map show . filter use + where use ValidInstance{} = False -- Not important enough to tell an end user + use _ = True + +-- | How to classify an 'Idea'. If any matching field is @\"\"@ then it matches everything. +data Classify = Classify + {classifySeverity :: Severity -- ^ Severity to set the 'Idea' to. + ,classifyHint :: String -- ^ Match on 'Idea' field 'ideaHint'. + ,classifyModule :: String -- ^ Match on 'Idea' field 'ideaModule'. + ,classifyDecl :: String -- ^ Match on 'Idea' field 'ideaDecl'. + } + deriving Show + +-- | A @LHS ==> RHS@ style hint rule. +data HintRule = HintRule + {hintRuleSeverity :: Severity -- ^ Default severity for the hint. + ,hintRuleName :: String -- ^ Name for the hint. + ,hintRuleScope :: Scope -- ^ Module scope in which the hint operates. + ,hintRuleLHS :: Exp_ -- ^ LHS + ,hintRuleRHS :: Exp_ -- ^ RHS + ,hintRuleSide :: Maybe Exp_ -- ^ Side condition, typically specified with @where _ = ...@. + ,hintRuleNotes :: [Note] -- ^ Notes about application of the hint. + } + deriving Show + +data Setting + = SettingClassify Classify + | SettingMatchExp HintRule + | Builtin String -- use a builtin hint set + | Infix Fixity + deriving Show + diff --git a/src/HLint.hs b/src/HLint.hs --- a/src/HLint.hs +++ b/src/HLint.hs @@ -6,8 +6,10 @@ import Control.Applicative import Control.Monad.Extra import Control.Exception +import Control.Concurrent.Extra import System.Console.CmdArgs.Verbosity import Data.List +import GHC.Conc import System.Exit import System.IO.Extra import Data.Tuple.Extra @@ -20,7 +22,8 @@ import Text.ParserCombinators.ReadP import CmdLine -import Settings +import Config.Type +import Config.Haskell import Report import Idea import Apply @@ -111,8 +114,8 @@ 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 + then error "No files found" + else runHints cmd{cmdFiles=files} flags {-# ANN readAllSettings "HLint: ignore Use let" #-} readAllSettings :: Cmd -> ParseFlags -> IO [Setting] @@ -126,86 +129,88 @@ runHints :: Cmd -> ParseFlags -> IO [Idea] runHints cmd@CmdMain{..} flags = do - let outStrLn = whenNormal . putStrLn - settings <- readAllSettings cmd flags - ideas <- getIdeas cmd settings flags - let (showideas,hideideas) = partition (\i -> cmdShowAll || ideaSeverity i /= Ignore) ideas - if cmdJson then - putStrLn $ showIdeasJson showideas - else if cmdSerialise then do - hSetBuffering stdout NoBuffering - print $ map (show &&& ideaRefactoring) showideas - else if cmdRefactor then - handleRefactoring showideas cmdFiles cmd - else do - usecolour <- cmdUseColour cmd - showItem <- if usecolour then showANSI else return show - mapM_ (outStrLn . showItem) showideas - handleReporting showideas hideideas cmd - return showideas + j <- if cmdThreads == 0 then getNumProcessors else return cmdThreads + withNumCapabilities j $ do + let outStrLn = whenNormal . putStrLn + settings <- readAllSettings cmd flags + ideas <- getIdeas cmd settings flags + let (showideas,hideideas) = partition (\i -> cmdShowAll || ideaSeverity i /= Ignore) ideas + if cmdJson then + putStrLn $ showIdeasJson showideas + else if cmdSerialise then do + hSetBuffering stdout NoBuffering + print $ map (show &&& ideaRefactoring) showideas + else if cmdRefactor then + handleRefactoring showideas cmdFiles cmd + else do + usecolour <- cmdUseColour cmd + showItem <- if usecolour then showANSI else return show + mapM_ (outStrLn . showItem) showideas + handleReporting showideas hideideas cmd + return showideas getIdeas :: Cmd -> [Setting] -> ParseFlags -> IO [Idea] getIdeas cmd@CmdMain{..} settings flags = do - ideas <- if cmdCross - then applyHintFiles flags settings cmdFiles - else concat <$> parallel [evaluateList =<< applyHintFile flags settings x Nothing | x <- cmdFiles] - return $ if not (null cmdOnly) - then [i | i <- ideas, ideaHint i `elem` cmdOnly] - else ideas + ideas <- if cmdCross + then applyHintFiles flags settings cmdFiles + else concat <$> parallel cmdThreads [evaluateList =<< applyHintFile flags settings x Nothing | x <- cmdFiles] + return $ if not (null cmdOnly) + then [i | i <- ideas, ideaHint i `elem` cmdOnly] + else ideas handleRefactoring :: [Idea] -> [String] -> Cmd -> IO () handleRefactoring showideas files cmd@CmdMain{..} = - 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 (show &&& ideaRefactoring) showideas - withTempFile $ \f -> do - writeFile f hints - runRefactoring path file f cmdRefactorOptions - -- Exit with the exit code from 'refactor' - >>= exitWith - _ -> error "Refactor flag can only be used with an individual file" + 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 (show &&& ideaRefactoring) showideas + withTempFile $ \f -> do + writeFile f hints + exitWith =<< runRefactoring path file f cmdRefactorOptions + _ -> error "Refactor flag can only be used with an individual file" handleReporting :: [Idea] -> [Idea] -> Cmd -> IO () handleReporting showideas hideideas cmd@CmdMain{..} = do - let outStrLn = whenNormal . putStrLn - if null showideas then - when (cmdReports /= []) $ outStrLn "Skipping writing reports" - else - forM_ cmdReports $ \x -> do - outStrLn $ "Writing report to " ++ x ++ " ..." - writeReport cmdDataDir x showideas - unless cmdNoSummary $ - outStrLn $ - (let i = length showideas in if i == 0 then "No hints" else show i ++ " hint" ++ ['s' | i/=1]) ++ - (let i = length hideideas in if i == 0 then "" else " (" ++ show i ++ " ignored)") + let outStrLn = whenNormal . putStrLn + if null showideas then + when (cmdReports /= []) $ outStrLn "Skipping writing reports" + else + forM_ cmdReports $ \x -> do + outStrLn $ "Writing report to " ++ x ++ " ..." + writeReport cmdDataDir x showideas + unless cmdNoSummary $ + outStrLn $ + (let i = length showideas in if i == 0 then "No hints" else show i ++ " hint" ++ ['s' | i/=1]) ++ + (let i = length hideideas in if i == 0 then "" else " (" ++ show i ++ " ignored)") runRefactoring :: FilePath -> FilePath -> FilePath -> String -> IO ExitCode runRefactoring rpath fin hints opts = do - let args = [fin, "-v0"] ++ words opts ++ ["--refact-file", hints] - (_, _, _, phand) <- createProcess $ proc rpath args - try $ hSetBuffering stdin LineBuffering :: IO (Either IOException ()) - hSetBuffering stdout LineBuffering - -- Propagate the exit code from the spawn process - waitForProcess phand + let args = [fin, "-v0"] ++ words opts ++ ["--refact-file", hints] + (_, _, _, phand) <- createProcess $ proc rpath args + try $ hSetBuffering stdin LineBuffering :: IO (Either IOException ()) + hSetBuffering stdout LineBuffering + -- Propagate the exit code from the spawn process + waitForProcess phand checkRefactor :: Maybe FilePath -> IO FilePath checkRefactor rpath = do - let excPath = fromMaybe "refactor" rpath - mexc <- findExecutable excPath - case mexc of - Just exc -> do - vers <- readP_to_S parseVersion . tail <$> readProcess exc ["--version"] "" - case vers of - [] -> 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" - , "Tried with: " ++ excPath ] + let excPath = fromMaybe "refactor" rpath + mexc <- findExecutable excPath + case mexc of + Just exc -> do + vers <- readP_to_S parseVersion . tail <$> readProcess exc ["--version"] "" + case vers of + [] -> 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", "Tried with: " ++ excPath ] evaluateList :: [a] -> IO [a] -evaluateList xs = length xs `seq` return xs +evaluateList xs = do + evaluate $ length xs + return xs diff --git a/src/HSE/All.hs b/src/HSE/All.hs --- a/src/HSE/All.hs +++ b/src/HSE/All.hs @@ -8,7 +8,7 @@ ) where import HSE.Util as X -import HSE.Evaluate as X +import HSE.Reduce as X import HSE.Type as X import HSE.Bracket as X import HSE.Match as X @@ -73,7 +73,7 @@ -- | Parse a Haskell module. Applies the C pre processor, and uses best-guess fixity resolution if there are ambiguities. -- The filename @-@ is treated as @stdin@. Requires some flags (often 'defaultParseFlags'), the filename, and optionally the contents of that file. -parseModuleEx :: ParseFlags -> FilePath -> Maybe String -> IO (Either ParseError (Module SrcSpanInfo, [Comment])) +parseModuleEx :: ParseFlags -> FilePath -> Maybe String -> IO (Either ParseError (Module_, [Comment])) parseModuleEx flags file str = do str <- maybe (readFileEncoding' (encoding flags) file) return str str <- return $ fromMaybe str $ stripPrefix "\65279" str -- remove the BOM if it exists, see #130 diff --git a/src/HSE/Evaluate.hs b/src/HSE/Evaluate.hs deleted file mode 100644 --- a/src/HSE/Evaluate.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE ViewPatterns #-} - --- Evaluate a HSE Exp as much as possible -module HSE.Evaluate(evaluate) where - -import HSE.Match -import HSE.Util -import HSE.Type -import HSE.Bracket - - -evaluate :: Exp_ -> Exp_ -evaluate = fromParen . transform evaluate1 - - -evaluate1 :: Exp_ -> Exp_ -evaluate1 (App s len (Lit _ (String _ xs _))) | len ~= "length" = Lit s $ Int s n (show n) - where n = fromIntegral $ length xs -evaluate1 (App s len (List _ xs)) | len ~= "length" = Lit s $ Int s n (show n) - where n = fromIntegral $ length xs -evaluate1 (view -> App2 op (Lit _ x) (Lit _ y)) | op ~= "==" = toNamed $ show $ x =~= y -evaluate1 (view -> App2 op (Lit _ (Int _ x _)) (Lit _ (Int _ y _))) - | op ~= ">=" = toNamed $ show $ x >= y -evaluate1 (view -> App2 op x y) - | op ~= "&&" && x ~= "True" = y - | op ~= "&&" && x ~= "False" = x -evaluate1 (Paren _ x) | isAtom x = x -evaluate1 x = x diff --git a/src/HSE/Reduce.hs b/src/HSE/Reduce.hs new file mode 100644 --- /dev/null +++ b/src/HSE/Reduce.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE ViewPatterns #-} + +-- Evaluate/reduce a HSE Exp as much as possible +module HSE.Reduce(reduce) where + +import HSE.Match +import HSE.Util +import HSE.Type +import HSE.Bracket + + +reduce :: Exp_ -> Exp_ +reduce = fromParen . transform reduce1 + + +reduce1 :: Exp_ -> Exp_ +reduce1 (App s len (Lit _ (String _ xs _))) | len ~= "length" = Lit s $ Int s n (show n) + where n = fromIntegral $ length xs +reduce1 (App s len (List _ xs)) | len ~= "length" = Lit s $ Int s n (show n) + where n = fromIntegral $ length xs +reduce1 (view -> App2 op (Lit _ x) (Lit _ y)) | op ~= "==" = toNamed $ show $ x =~= y +reduce1 (view -> App2 op (Lit _ (Int _ x _)) (Lit _ (Int _ y _))) + | op ~= ">=" = toNamed $ show $ x >= y +reduce1 (view -> App2 op x y) + | op ~= "&&" && x ~= "True" = y + | op ~= "&&" && x ~= "False" = x +reduce1 (Paren _ x) | isAtom x = x +reduce1 x = x diff --git a/src/HSE/Scope.hs b/src/HSE/Scope.hs --- a/src/HSE/Scope.hs +++ b/src/HSE/Scope.hs @@ -40,7 +40,7 @@ mappend (Scope xs) (Scope ys) = Scope $ xs ++ ys -- | Create a 'Scope' value from a module, based on the modules imports. -scopeCreate :: Module SrcSpanInfo -> Scope +scopeCreate :: Module_ -> Scope scopeCreate xs = Scope $ [prelude | not $ any isPrelude res] ++ res where res = [x | x <- moduleImports xs, importPkg x /= Just "hint"] @@ -55,7 +55,7 @@ -- | Given a two names in scopes, could they possibly refer to the same thing. -- This property is reflexive. -scopeMatch :: (Scope, QName SrcSpanInfo) -> (Scope, QName SrcSpanInfo) -> Bool +scopeMatch :: (Scope, QName S) -> (Scope, QName S) -> Bool scopeMatch (a, x@Special{}) (b, y@Special{}) = x =~= y scopeMatch (a, x) (b, y) | isSpecial x || isSpecial y = False scopeMatch (a, x) (b, y) = unqual x =~= unqual y && not (null $ possModules a x `intersect` possModules b y) @@ -63,7 +63,7 @@ -- | Given a name in a scope, and a new scope, create a name for the new scope that will refer -- to the same thing. If the resulting name is ambiguous, it picks a plausible candidate. -scopeMove :: (Scope, QName SrcSpanInfo) -> Scope -> QName SrcSpanInfo +scopeMove :: (Scope, QName S) -> Scope -> QName S scopeMove (a, x) (Scope b) | isSpecial x = x | null imps = head $ real ++ [x] diff --git a/src/HSE/Util.hs b/src/HSE/Util.hs --- a/src/HSE/Util.hs +++ b/src/HSE/Util.hs @@ -70,6 +70,10 @@ fromTyParen (TyParen _ x) = fromTyParen x fromTyParen x = x +fromTyBang :: Type s -> Type s +fromTyBang (TyBang _ _ _ x) = x +fromTyBang x = x + fromDeriving :: Deriving s -> [InstRule s] fromDeriving (Deriving _ x) = x @@ -103,6 +107,8 @@ isNewType NewType{} = True; isNewType _ = False isRecStmt RecStmt{} = True; isRecStmt _ = False isClsDefSig ClsDefSig{} = True; isClsDefSig _ = False +isTyBang TyBang{} = True; isTyBang _ = False +isLCase LCase{} = True; isLCase _ = False isSection LeftSection{} = True isSection RightSection{} = True diff --git a/src/Hint/All.hs b/src/Hint/All.hs --- a/src/Hint/All.hs +++ b/src/Hint/All.hs @@ -5,7 +5,7 @@ ) where import Data.Monoid -import Settings +import Config.Type import Data.Either import Data.List import Hint.Type diff --git a/src/Hint/Extensions.hs b/src/Hint/Extensions.hs --- a/src/Hint/Extensions.hs +++ b/src/Hint/Extensions.hs @@ -73,6 +73,16 @@ foo = id -- {-# LANGUAGE TypeApplications #-} \ foo = id @Int +{-# LANGUAGE LambdaCase #-} \ +foo = id -- +{-# LANGUAGE LambdaCase #-} \ +foo = \case () -> () +{-# LANGUAGE NumDecimals #-} \ +foo = 12.3e2 +{-# LANGUAGE NumDecimals #-} \ +foo = id -- +{-# LANGUAGE NumDecimals #-} \ +foo = 12.345e2 -- -} @@ -82,6 +92,7 @@ import Hint.Type import Data.Maybe import Data.List.Extra +import Data.Ratio import Refact.Types @@ -116,6 +127,7 @@ usedExt :: Extension -> Module_ -> Bool usedExt (EnableExtension x) = used x +usedExt (UnknownExtension "NumDecimals") = hasS isWholeFrac usedExt _ = const True @@ -156,6 +168,7 @@ used DeriveTraversable = hasDerive ["Traversable"] used DeriveGeneric = hasDerive ["Generic","Generic1"] used GeneralizedNewtypeDeriving = any (`notElem` noNewtypeDeriving) . fst . derives +used LambdaCase = hasS isLCase used Arrows = hasS f where f Proc{} = True f LeftArrApp{} = True @@ -218,3 +231,8 @@ has f = any f . universeBi +-- Only whole number fractions are permitted by NumDecimals extension. +-- Anything not-whole raises an error. +isWholeFrac :: Literal S -> Bool +isWholeFrac (Frac _ v _) = denominator v == 1 +isWholeFrac _ = False diff --git a/src/Hint/Import.hs b/src/Hint/Import.hs --- a/src/Hint/Import.hs +++ b/src/Hint/Import.hs @@ -33,10 +33,6 @@ import Char(foo) -- import Data.Char(foo) import IO(foo) import IO as X -- import System.IO as X; import System.IO.Error as X; import Control.Exception as X (bracket,bracket_) -module Foo(module A, baz, module B, module C) where; import A; import D; import B(map,filter); import C \ - -- module Foo(baz, module X) where; import A as X; import B as X(map, filter); import C as X -module Foo(module A, baz, module B, module X) where; import A; import B; import X \ - -- module Foo(baz, module Y) where; import A as Y; import B as Y; import X as Y -} @@ -56,8 +52,7 @@ importHint :: ModuHint importHint _ x = concatMap (wrap . snd) (groupSort [((fromNamed $ importModule i,importPkg i),i) | i <- universeBi x, not $ importSrc i]) ++ - concatMap (\x -> hierarchy x ++ reduce1 x) (universeBi x) ++ - multiExport x + concatMap (\x -> hierarchy x ++ combine1 x) (universeBi x) wrap :: [ImportDecl S] -> [Idea] @@ -75,13 +70,13 @@ simplifyHead :: ImportDecl S -> [ImportDecl S] -> Maybe ([ImportDecl S], [Refactoring R.SrcSpan]) simplifyHead x [] = Nothing -simplifyHead x (y:ys) = case reduce x y of +simplifyHead x (y:ys) = case combine x y of Nothing -> first (y:) <$> simplifyHead x ys Just (xy, rs) -> Just (xy : ys, rs) -reduce :: ImportDecl S -> ImportDecl S -> Maybe (ImportDecl S, [Refactoring R.SrcSpan]) -reduce x y | qual, as, specs = Just (x, [Delete Import (toSS y)]) +combine :: ImportDecl S -> ImportDecl S -> Maybe (ImportDecl S, [Refactoring R.SrcSpan]) +combine 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) , Delete Import (toSS y) ] ) @@ -99,14 +94,14 @@ ass = mapMaybe importAs [x,y] specs = importSpecs x `eqMaybe` importSpecs y -reduce _ _ = Nothing +combine _ _ = Nothing -reduce1 :: ImportDecl S -> [Idea] -reduce1 i@ImportDecl{..} +combine1 :: ImportDecl S -> [Idea] +combine1 i@ImportDecl{..} | Just (dropAnn importModule) == fmap dropAnn importAs = [suggest "Redundant as" i i{importAs=Nothing} [RemoveAsKeyword (toSS i)]] -reduce1 _ = [] +combine1 _ = [] newNames = let (*) = flip (,) in @@ -149,24 +144,3 @@ desugarQual :: ImportDecl S -> ImportDecl S desugarQual x | importQualified x && isNothing (importAs x) = x{importAs=Just (importModule x)} | otherwise = x - - -multiExport :: Module S -> [Idea] -multiExport x = - [ rawIdeaN Suggestion "Use import/export shortcut" (toSrcSpan $ ann hd) - (unlines $ prettyPrint hd : map prettyPrint imps) - (Just $ unlines $ prettyPrint newhd : map prettyPrint newimps) - [] - | Module l (Just hd) _ imp _ <- [x] - , let asNames = mapMaybe importAs imp - , let expNames = [x | EModuleContents _ x <- childrenBi hd] - , let imps = [i | i@ImportDecl{importAs=Nothing,importQualified=False,importModule=name} <- imp - ,name `notElem_` asNames, name `elem_` expNames] - , length imps >= 3 - , let newname = ModuleName an $ head $ map return ("XYZ" ++ ['A'..]) \\ - [x | ModuleName (_ :: S) x <- universeBi hd ++ universeBi imp] - , let reexport (EModuleContents _ x) = x `notElem_` map importModule imps - reexport x = True - , let newhd = descendBi (\xs -> filter reexport xs ++ [EModuleContents an newname]) hd - , let newimps = [i{importAs=Just newname} | i <- imps] - ] diff --git a/src/Hint/Match.hs b/src/Hint/Match.hs --- a/src/Hint/Match.hs +++ b/src/Hint/Match.hs @@ -44,7 +44,7 @@ import Data.Maybe import Data.Data import Unsafe.Coerce -import Settings +import Config.Type import Hint.Type import Control.Monad import Data.Tuple.Extra @@ -165,7 +165,7 @@ unify :: Data a => NameMatch -> Bool -> a -> a -> Maybe [(String,Exp_)] unify nm root x y | Just x <- cast x = unifyExp nm root x (unsafeCoerce y) | Just x <- cast x = unifyPat nm x (unsafeCoerce y) - | Just (x :: SrcSpanInfo) <- cast x = Just [] + | Just (x :: S) <- cast x = Just [] | otherwise = unifyDef nm x y @@ -292,7 +292,7 @@ -- if it has _eval_ do evaluation on it performEval :: Exp_ -> Exp_ -performEval (App _ e x) | e ~= "_eval_" = evaluate x +performEval (App _ e x) | e ~= "_eval_" = reduce x performEval x = x diff --git a/src/Hint/NewType.hs b/src/Hint/NewType.hs --- a/src/Hint/NewType.hs +++ b/src/Hint/NewType.hs @@ -13,6 +13,8 @@ data Color a = Red a | Green a | Blue a data Pair a b = Pair a b data Foo = Bar +data X = Y {-# UNPACK #-} !Int -- newtype X = Y Int +data A = A {b :: !C} -- newtype A = A {b :: C} -} module Hint.NewType (newtypeHint) where @@ -23,14 +25,18 @@ newtypeHint _ _ = newtypeHintDecl newtypeHintDecl :: Decl_ -> [Idea] -newtypeHintDecl d@(DataDecl sp (DataType dtA) ctx dclH - [qcD@(QualConDecl _ tvb _ cd)] der) = - case tvb of - Just _ -> [] - Nothing -> case cd of - ConDecl _ _ [_] -> wrn - RecDecl _ _ [FieldDecl _ [_] _] -> wrn - _ -> [] - where suggestion = DataDecl sp (NewType dtA) ctx dclH [qcD] der - wrn = [(suggestN "Use newtype instead of data" d suggestion){ideaNote = [DecreasesLaziness]}] +newtypeHintDecl x + | Just (DataType s, t, f) <- singleSimpleField x + = [(suggestN "Use newtype instead of data" x $ f (NewType s) $ fromTyBang t) + {ideaNote = [DecreasesLaziness | not $ isTyBang t]}] newtypeHintDecl _ = [] + + +singleSimpleField :: Decl_ -> Maybe (DataOrNew S, Type_, DataOrNew S -> Type_ -> Decl_) +singleSimpleField (DataDecl x1 dt x2 x3 [QualConDecl y1 Nothing y2 ctor] x4) + | Just (t, ft) <- f ctor = Just (dt, t, \dt t -> DataDecl x1 dt x2 x3 [QualConDecl y1 Nothing y2 $ ft t] x4) + where + f (ConDecl x1 x2 [t]) = Just (t, \t -> ConDecl x1 x2 [t]) + f (RecDecl x1 x2 [FieldDecl y1 [y2] t]) = Just (t, \t -> RecDecl x1 x2 [FieldDecl y1 [y2] t]) + f _ = Nothing +singleSimpleField _ = Nothing diff --git a/src/Hint/Pattern.hs b/src/Hint/Pattern.hs --- a/src/Hint/Pattern.hs +++ b/src/Hint/Pattern.hs @@ -139,7 +139,7 @@ asGuards x = [(toNamed "otherwise", x)] -data Pattern = Pattern SrcSpanInfo R.RType [Pat_] (Rhs S) (Maybe (Binds S)) +data Pattern = Pattern S R.RType [Pat_] (Rhs S) (Maybe (Binds S)) -- Invariant: Number of patterns may not change asPattern :: Decl_ -> [(Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)] diff --git a/src/Hint/Type.hs b/src/Hint/Type.hs --- a/src/Hint/Type.hs +++ b/src/Hint/Type.hs @@ -13,9 +13,9 @@ -- | Functions to generate hints, combined using the 'Monoid' instance. data Hint = Hint - {hintModules :: [(Scope, Module SrcSpanInfo)] -> [Idea] -- ^ Given a list of modules (and their scope information) generate some 'Idea's. - ,hintModule :: Scope -> Module SrcSpanInfo -> [Idea] -- ^ Given a single module and its scope information generate some 'Idea's. - ,hintDecl :: Scope -> Module SrcSpanInfo -> Decl SrcSpanInfo -> [Idea] + {hintModules :: [(Scope, Module_)] -> [Idea] -- ^ Given a list of modules (and their scope information) generate some 'Idea's. + ,hintModule :: Scope -> Module_ -> [Idea] -- ^ Given a single module and its scope information generate some 'Idea's. + ,hintDecl :: Scope -> Module_ -> Decl_ -> [Idea] -- ^ Given a declaration (with a module and scope) generate some 'Idea's. -- This function will be partially applied with one module/scope, then used on multiple 'Decl' values. ,hintComment :: Comment -> [Idea] -- ^ Given a comment generate some 'Idea's. diff --git a/src/Idea.hs b/src/Idea.hs --- a/src/Idea.hs +++ b/src/Idea.hs @@ -6,7 +6,7 @@ import Data.Char import Numeric import HSE.All -import Settings +import Config.Type import HsColour import Refact.Types hiding (SrcSpan) import qualified Refact.Types as R diff --git a/src/Language/Haskell/HLint.hs b/src/Language/Haskell/HLint.hs --- a/src/Language/Haskell/HLint.hs +++ b/src/Language/Haskell/HLint.hs @@ -8,7 +8,7 @@ module Language.Haskell.HLint(hlint, Suggestion, suggestionLocation, suggestionSeverity, Severity(..)) where import qualified HLint -import Settings +import Config.Type import Idea import HSE.All diff --git a/src/Language/Haskell/HLint2.hs b/src/Language/Haskell/HLint2.hs --- a/src/Language/Haskell/HLint2.hs +++ b/src/Language/Haskell/HLint2.hs @@ -28,7 +28,8 @@ Encoding, defaultEncoding, readEncoding, useEncoding ) where -import Settings +import Config.Type +import Config.Haskell import Idea import Apply import Hint.Type 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 @@ -29,7 +29,8 @@ parseModuleEx, defaultParseFlags, parseFlagsAddFixities, ParseError(..), ParseFlags(..), CppFlags(..) ) where -import Settings hiding (findSettings) +import Config.Type +import Config.Haskell as Settings hiding (findSettings) import Idea import Apply import HLint diff --git a/src/Parallel.hs b/src/Parallel.hs --- a/src/Parallel.hs +++ b/src/Parallel.hs @@ -11,14 +11,13 @@ module Parallel(parallel) where import System.IO.Unsafe -import GHC.Conc(numCapabilities) import Control.Concurrent import Control.Exception import Control.Monad -parallel :: [IO a] -> IO [a] -parallel = if numCapabilities <= 1 then parallel1 else parallelN +parallel :: Int -> [IO a] -> IO [a] +parallel j = if j <= 1 then parallel1 else parallelN j parallel1 :: [IO a] -> IO [a] @@ -29,12 +28,12 @@ return $ x2:xs2 -parallelN :: [IO a] -> IO [a] -parallelN xs = do +parallelN :: Int -> [IO a] -> IO [a] +parallelN j xs = do ms <- mapM (const newEmptyMVar) xs chan <- newChan mapM_ (writeChan chan . Just) $ zip ms xs - replicateM_ numCapabilities (writeChan chan Nothing >> forkIO (f chan)) + replicateM_ j (writeChan chan Nothing >> forkIO (f chan)) let throwE x = throw (x :: SomeException) parallel1 $ map (fmap (either throwE id) . takeMVar) ms where diff --git a/src/Settings.hs b/src/Settings.hs deleted file mode 100644 --- a/src/Settings.hs +++ /dev/null @@ -1,293 +0,0 @@ -{-# LANGUAGE PatternGuards, ViewPatterns #-} - -module Settings( - Severity(..), Classify(..), HintRule(..), Note(..), showNotes, Setting(..), - defaultHintName, isUnifyVar, - findSettings, readSettings, - readSettings2, readPragma, findSettings2, addInfix - ) where - -import Data.Monoid -import HSE.All -import Control.Monad.Extra -import Data.Char -import Data.Either -import Data.List.Extra -import System.FilePath -import Util -import Prelude - - -defaultHintName :: String -defaultHintName = "Use alternative" - - --- | How severe an issue is. -data Severity - = Ignore -- ^ The issue has been explicitly ignored and will usually be hidden (pass @--show@ on the command line to see ignored ideas). - | Suggestion -- ^ Suggestions are things that some people may consider improvements, but some may not. - | Warning -- ^ Warnings are suggestions that are nearly always a good idea to apply. - | Error -- ^ Available as a setting for the user. - deriving (Eq,Ord,Show,Read,Bounded,Enum) - -getSeverity :: String -> Maybe Severity -getSeverity "ignore" = Just Ignore -getSeverity "warn" = Just Warning -getSeverity "warning" = Just Warning -getSeverity "suggest" = Just Suggestion -getSeverity "suggestion" = Just Suggestion -getSeverity "error" = Just Error -getSeverity "hint" = Just Suggestion -getSeverity _ = Nothing - - --- Any 1-letter variable names are assumed to be unification variables -isUnifyVar :: String -> Bool -isUnifyVar [x] = x == '?' || isAlpha x -isUnifyVar _ = False - - -addInfix = parseFlagsAddFixities $ infix_ (-1) ["==>"] - - ---------------------------------------------------------------------- --- TYPE - --- | A note describing the impact of the replacement. -data Note - = IncreasesLaziness -- ^ The replacement is increases laziness, for example replacing @reverse (reverse x)@ with @x@ makes the code lazier. - | DecreasesLaziness -- ^ The replacement is decreases laziness, for example replacing @(fst x, snd x)@ with @x@ makes the code stricter. - | RemovesError String -- ^ The replacement removes errors, for example replacing @foldr1 (+)@ with @sum@ removes an error on @[]@, and might contain the text @\"on []\"@. - | ValidInstance String String -- ^ The replacement assumes standard type class lemmas, a hint with the note @ValidInstance \"Eq\" \"x\"@ might only be valid if - -- the @x@ variable has a reflexive @Eq@ instance. - | Note String -- ^ An arbitrary note. - deriving (Eq,Ord) - -instance Show Note where - show IncreasesLaziness = "increases laziness" - show DecreasesLaziness = "decreases laziness" - show (RemovesError x) = "removes error " ++ x - show (ValidInstance x y) = "requires a valid " ++ x ++ " instance for " ++ y - show (Note x) = x - - -showNotes :: [Note] -> String -showNotes = intercalate ", " . map show . filter use - where use ValidInstance{} = False -- Not important enough to tell an end user - use _ = True - --- | How to classify an 'Idea'. If any matching field is @\"\"@ then it matches everything. -data Classify = Classify - {classifySeverity :: Severity -- ^ Severity to set the 'Idea' to. - ,classifyHint :: String -- ^ Match on 'Idea' field 'ideaHint'. - ,classifyModule :: String -- ^ Match on 'Idea' field 'ideaModule'. - ,classifyDecl :: String -- ^ Match on 'Idea' field 'ideaDecl'. - } - deriving Show - --- | A @LHS ==> RHS@ style hint rule. -data HintRule = HintRule - {hintRuleSeverity :: Severity -- ^ Default severity for the hint. - ,hintRuleName :: String -- ^ Name for the hint. - ,hintRuleScope :: Scope -- ^ Module scope in which the hint operates. - ,hintRuleLHS :: Exp SrcSpanInfo -- ^ LHS - ,hintRuleRHS :: Exp SrcSpanInfo -- ^ RHS - ,hintRuleSide :: Maybe (Exp SrcSpanInfo) -- ^ Side condition, typically specified with @where _ = ...@. - ,hintRuleNotes :: [Note] -- ^ Notes about application of the hint. - } - deriving Show - -data Setting - = SettingClassify Classify - | SettingMatchExp HintRule - | Builtin String -- use a builtin hint set - | Infix Fixity - deriving Show - - ---------------------------------------------------------------------- --- READ A SETTINGS FILE - --- Given a list of hint files to start from --- Return the list of settings commands -readSettings2 :: FilePath -> [FilePath] -> [String] -> IO [Setting] -readSettings2 dataDir files hints = do - (builtin,mods) <- fmap partitionEithers $ concatMapM (readHints dataDir) $ map Right files ++ map Left hints - return $ map Builtin builtin ++ concatMap moduleSettings_ mods - -moduleSettings_ :: Module SrcSpanInfo -> [Setting] -moduleSettings_ m = concatMap (readSetting $ scopeCreate m) $ concatMap getEquations $ - [AnnPragma l x | AnnModulePragma l x <- modulePragmas m] ++ moduleDecls m - --- | Given a module containing HLint settings information return the 'Classify' rules and the 'HintRule' expressions. --- Any fixity declarations will be discarded, but any other unrecognised elements will result in an exception. -readSettings :: Module SrcSpanInfo -> ([Classify], [HintRule]) -readSettings m = ([x | SettingClassify x <- xs], [x | SettingMatchExp x <- xs]) - where xs = moduleSettings_ m - - -readHints :: FilePath -> Either String FilePath -> IO [Either String Module_] -readHints datadir x = do - (builtin,ms) <- case x of - Left src -> findSettings datadir "CommandLine" (Just src) - Right file -> findSettings datadir file Nothing - return $ map Left builtin ++ map Right ms - - --- | Given the data directory (where the @hlint@ data files reside, see 'getHLintDataDir'), --- and a filename to read, and optionally that file's contents, produce a pair containing: --- --- 1. Builtin hints to use, e.g. @"List"@, which should be resolved using 'builtinHints'. --- --- 1. A list of modules containing hints, suitable for processing with 'readSettings'. --- --- Any parse failures will result in an exception. -findSettings :: FilePath -> FilePath -> Maybe String -> IO ([String], [Module SrcSpanInfo]) -findSettings dataDir file contents = do - let flags = addInfix defaultParseFlags - res <- parseModuleEx flags file contents - case res of - Left (ParseError sl msg err) -> exitMessage $ "Parse failure at " ++ showSrcLoc sl ++ ": " ++ msg ++ "\n" ++ err - Right (m, _) -> do - ys <- sequence [f $ fromNamed $ importModule i | i <- moduleImports m, importPkg i `elem` [Just "hint", Just "hlint"]] - return $ concatUnzip $ ([],[m]) : ys - where - f x | Just x <- "HLint.Builtin." `stripPrefix` x = return ([x],[]) - | Just x <- "HLint." `stripPrefix` x = findSettings dataDir (dataDir x <.> "hs") Nothing - | otherwise = findSettings dataDir (x <.> "hs") Nothing - - -readSetting :: Scope -> Decl_ -> [Setting] -readSetting s (FunBind _ [Match _ (Ident _ (getSeverity -> Just severity)) pats (UnGuardedRhs _ bod) bind]) - | InfixApp _ lhs op rhs <- bod, opExp op ~= "==>" = - let (a,b) = readSide $ childrenBi bind in - [SettingMatchExp $ HintRule severity (head $ snoc names defaultHintName) s (fromParen lhs) (fromParen rhs) a b] - | otherwise = [SettingClassify $ Classify severity n a b | n <- names2, (a,b) <- readFuncs bod] - where - names = filter (not . null) $ getNames pats bod - names2 = ["" | null names] ++ names - -readSetting s x | "test" `isPrefixOf` map toLower (fromNamed x) = [] -readSetting s (AnnPragma _ x) | Just y <- readPragma x = [SettingClassify y] -readSetting s (PatBind an (PVar _ name) bod bind) = readSetting s $ FunBind an [Match an name [] bod bind] -readSetting s (FunBind an xs) | length xs /= 1 = concatMap (readSetting s . FunBind an . return) xs -readSetting s (SpliceDecl an (App _ (Var _ x) (Lit _ y))) = readSetting s $ FunBind an [Match an (toNamed $ fromNamed x) [PLit an (Signless an) y] (UnGuardedRhs an $ Lit an $ String an "" "") Nothing] -readSetting s x@InfixDecl{} = map Infix $ getFixity x -readSetting s x = errorOn x "bad hint" - - --- return Nothing if it is not an HLint pragma, otherwise all the settings -readPragma :: Annotation S -> Maybe Classify -readPragma o = case o of - Ann _ name x -> f (fromNamed name) x - TypeAnn _ name x -> f (fromNamed name) x - ModuleAnn _ x -> f "" x - where - f name (Lit _ (String _ s _)) | "hlint:" `isPrefixOf` map toLower s = - case getSeverity a of - Nothing -> errorOn o "bad classify pragma" - Just severity -> Just $ Classify severity (trimStart b) "" name - where (a,b) = break isSpace $ trimStart $ drop 6 s - f name (Paren _ x) = f name x - f name (ExpTypeSig _ x _) = f name x - f _ _ = Nothing - - -readSide :: [Decl_] -> (Maybe Exp_, [Note]) -readSide = foldl f (Nothing,[]) - where f (Nothing,notes) (PatBind _ PWildCard{} (UnGuardedRhs _ side) Nothing) = (Just side, notes) - f (Nothing,notes) (PatBind _ (fromNamed -> "side") (UnGuardedRhs _ side) Nothing) = (Just side, notes) - f (side,[]) (PatBind _ (fromNamed -> "note") (UnGuardedRhs _ note) Nothing) = (side,g note) - f _ x = errorOn x "bad side condition" - - g (Lit _ (String _ x _)) = [Note x] - g (List _ xs) = concatMap g xs - g x = case fromApps x of - [con -> Just "IncreasesLaziness"] -> [IncreasesLaziness] - [con -> Just "DecreasesLaziness"] -> [DecreasesLaziness] - [con -> Just "RemovesError",fromString -> Just a] -> [RemovesError a] - [con -> Just "ValidInstance",fromString -> Just a,var -> Just b] -> [ValidInstance a b] - _ -> errorOn x "bad note" - - con :: Exp_ -> Maybe String - con c@Con{} = Just $ prettyPrint c; con _ = Nothing - var c@Var{} = Just $ prettyPrint c; var _ = Nothing - - --- Note: Foo may be ("","Foo") or ("Foo",""), return both -readFuncs :: Exp_ -> [(String, String)] -readFuncs (App _ x y) = readFuncs x ++ readFuncs y -readFuncs (Lit _ (String _ "" _)) = [("","")] -readFuncs (Var _ (UnQual _ name)) = [("",fromNamed name)] -readFuncs (Var _ (Qual _ (ModuleName _ mod) name)) = [(mod, fromNamed name)] -readFuncs (Con _ (UnQual _ name)) = [(fromNamed name,""),("",fromNamed name)] -readFuncs (Con _ (Qual _ (ModuleName _ mod) name)) = [(mod ++ "." ++ fromNamed name,""),(mod,fromNamed name)] -readFuncs x = errorOn x "bad classification rule" - - -getNames :: [Pat_] -> Exp_ -> [String] -getNames ps _ | ps /= [], Just ps <- mapM fromPString ps = ps -getNames [] (InfixApp _ lhs op rhs) | opExp op ~= "==>" = map ("Use "++) names - where - lnames = map f $ childrenS lhs - rnames = map f $ childrenS rhs - names = filter (not . isUnifyVar) $ (rnames \\ lnames) ++ rnames - f (Ident _ x) = x - f (Symbol _ x) = x -getNames _ _ = [] - - -errorOn :: (Annotated ast, Pretty (ast S)) => ast S -> String -> b -errorOn val msg = exitMessage $ - showSrcLoc (getPointLoc $ ann val) ++ - ": Error while reading hint file, " ++ msg ++ "\n" ++ - prettyPrint val - - ---------------------------------------------------------------------- --- FIND SETTINGS IN A SOURCE FILE - --- find definitions in a source file -findSettings2 :: ParseFlags -> FilePath -> IO (String, [Setting]) -findSettings2 flags file = do - x <- parseModuleEx flags file Nothing - case x of - Left (ParseError sl msg _) -> - return ("-- Parse error " ++ showSrcLoc sl ++ ": " ++ msg, []) - Right (m, _) -> do - let xs = concatMap (findSetting $ UnQual an) (moduleDecls m) - s = unlines $ ["-- hints found in " ++ file] ++ map prettyPrint xs ++ ["-- no hints found" | null xs] - r = concatMap (readSetting mempty) xs - return (s,r) - - -findSetting :: (Name S -> QName S) -> Decl_ -> [Decl_] -findSetting qual (InstDecl _ _ _ (Just xs)) = concatMap (findSetting qual) [x | InsDecl _ x <- xs] -findSetting qual (PatBind _ (PVar _ name) (UnGuardedRhs _ bod) Nothing) = findExp (qual name) [] bod -findSetting qual (FunBind _ [InfixMatch _ p1 name ps rhs bind]) = findSetting qual $ FunBind an [Match an name (p1:ps) rhs bind] -findSetting qual (FunBind _ [Match _ name ps (UnGuardedRhs _ bod) Nothing]) = findExp (qual name) [] $ Lambda an ps bod -findSetting _ x@InfixDecl{} = [x] -findSetting _ _ = [] - - --- given a result function name, a list of variables, a body expression, give some hints -findExp :: QName S -> [String] -> Exp_ -> [Decl_] -findExp name vs (Lambda _ ps bod) | length ps2 == length ps = findExp name (vs++ps2) bod - | otherwise = [] - where ps2 = [x | PVar_ x <- map view ps] -findExp name vs Var{} = [] -findExp name vs (InfixApp _ x dot y) | isDot dot = findExp name (vs++["_hlint"]) $ App an x $ Paren an $ App an y (toNamed "_hlint") - -findExp name vs bod = [PatBind an (toNamed "warn") (UnGuardedRhs an $ InfixApp an lhs (toNamed "==>") rhs) Nothing] - where - lhs = g $ transform f bod - rhs = apps $ Var an name : map snd rep - - rep = zip vs $ map (toNamed . return) ['a'..] - f xx | Var_ x <- view xx, Just y <- lookup x rep = y - f (InfixApp _ x dol y) | isDol dol = App an x (paren y) - f x = x - - g o@(InfixApp _ _ _ x) | isAnyApp x || isAtom x = o - g o@App{} = o - g o = paren o diff --git a/src/Test/All.hs b/src/Test/All.hs --- a/src/Test/All.hs +++ b/src/Test/All.hs @@ -10,7 +10,8 @@ import Data.Functor import Prelude -import Settings +import Config.Type +import Config.Haskell import CmdLine import HSE.All import Hint.All diff --git a/src/Test/Annotations.hs b/src/Test/Annotations.hs --- a/src/Test/Annotations.hs +++ b/src/Test/Annotations.hs @@ -9,7 +9,7 @@ import Data.Maybe import Data.Function -import Settings +import Config.Type import Idea import Apply import HSE.All diff --git a/src/Test/Proof.hs b/src/Test/Proof.hs --- a/src/Test/Proof.hs +++ b/src/Test/Proof.hs @@ -12,7 +12,7 @@ import Data.Maybe import Data.Function import System.FilePath -import Settings +import Config.Type import HSE.All import Prelude @@ -79,7 +79,7 @@ classifyMissing Theorem{original = Just HintRule{..}} | _:_ <- [v :: Exp_ | v@Case{} <- universeBi (hintRuleLHS,hintRuleRHS)] = "case" | _:_ <- [v :: Exp_ | v@ListComp{} <- universeBi (hintRuleLHS,hintRuleRHS)] = "list-comp" - | v:_ <- mapMaybe (`lookup` missingFuncs) [prettyPrint (v :: Name SrcSpanInfo) | v <- universeBi (hintRuleLHS,hintRuleRHS)] = v + | v:_ <- mapMaybe (`lookup` missingFuncs) [prettyPrint (v :: Name S) | v <- universeBi (hintRuleLHS,hintRuleRHS)] = v classifyMissing _ = "?unknown" diff --git a/src/Test/Translate.hs b/src/Test/Translate.hs --- a/src/Test/Translate.hs +++ b/src/Test/Translate.hs @@ -11,7 +11,7 @@ import System.FilePath import Paths_hlint -import Settings +import Config.Type import HSE.All import Test.Util