diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,5 +1,9 @@ Changelog for HLint (* = breaking change) +2.1.3, released 2018-04-18 + Improve the performance of the camelCase hint + Don't suggest camelCase for record fields + Add a --timing flag to detect what is slow 2.1.2, released 2018-04-16 #407, don't error on unknown extensions on the command line Require extra-1.6.6 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.2 +version: 2.1.3 license: BSD3 license-file: LICENSE category: Development @@ -84,6 +84,7 @@ Util Parallel Refact + Timing CC Config.Compute Config.Haskell diff --git a/src/Apply.hs b/src/Apply.hs --- a/src/Apply.hs +++ b/src/Apply.hs @@ -87,7 +87,7 @@ -- | Find which hints a list of settings implies. allHints :: [Setting] -> Hint allHints xs = mconcat $ hintRules [x | SettingMatchExp x <- xs] : map f builtin - where builtin = nub $ concat [if x == "All" then map fst builtinHints else [x] | Builtin x <- xs] + where builtin = nubOrd $ concat [if x == "All" then map fst builtinHints else [x] | Builtin x <- xs] f x = fromMaybe (error $ "Unknown builtin hints: HLint.Builtin." ++ x) $ lookup x builtinHints diff --git a/src/CmdLine.hs b/src/CmdLine.hs --- a/src/CmdLine.hs +++ b/src/CmdLine.hs @@ -116,6 +116,7 @@ ,cmdNoSummary :: Bool -- ^ do not show the summary info ,cmdOnly :: [String] -- ^ specify which hints explicitly ,cmdNoExitCode :: Bool + ,cmdTiming :: Bool ,cmdSerialise :: Bool -- ^ Display hints in serialisation format ,cmdRefactor :: Bool -- ^ Run the `refactor` executable to automatically perform hints ,cmdRefactorOptions :: String -- ^ Options to pass to the `refactor` executable. @@ -178,10 +179,11 @@ ,cmdNoSummary = nam_ "no-summary" &= help "Do not show summary information" ,cmdOnly = nam "only" &= typ "HINT" &= help "Specify which hints explicitly" ,cmdNoExitCode = nam_ "no-exit-code" &= help "Do not give a negative exit if hints" + ,cmdTiming = nam_ "timing" &= help "Display timing information" ,cmdSerialise = nam_ "serialise" &= help "Serialise hint data for consumption by apply-refact" ,cmdRefactor = nam_ "refactor" &= help "Automatically invoke `refactor` to apply hints" ,cmdRefactorOptions = nam_ "refactor-options" &= typ "OPTIONS" &= help "Options to pass to the `refactor` executable" - , cmdWithRefactor = nam_ "with-refactor" &= help "Give the path to refactor" + ,cmdWithRefactor = nam_ "with-refactor" &= help "Give the path to refactor" } &= auto &= explicit &= name "lint" ,CmdGrep {cmdFiles = def &= args &= typ "FILE/DIR" diff --git a/src/Config/Yaml.hs b/src/Config/Yaml.hs --- a/src/Config/Yaml.hs +++ b/src/Config/Yaml.hs @@ -21,6 +21,7 @@ import HSE.All hiding (Rule, String) import Data.Functor import Data.Semigroup +import Timing import Util import Prelude @@ -28,7 +29,7 @@ -- | Read a config file in YAML format. Takes a filename, and optionally the contents. -- Fails if the YAML doesn't parse or isn't valid HLint YAML readFileConfigYaml :: FilePath -> Maybe String -> IO ConfigYaml -readFileConfigYaml file contents = do +readFileConfigYaml file contents = timedIO "Config" file $ do val <- case contents of Nothing -> decodeFileEither file Just src -> return $ decodeEither' $ BS.pack src diff --git a/src/HLint.hs b/src/HLint.hs --- a/src/HLint.hs +++ b/src/HLint.hs @@ -12,6 +12,7 @@ import GHC.Conc import System.Exit import System.IO.Extra +import System.Time.Extra import Data.Tuple.Extra import Prelude @@ -31,6 +32,7 @@ import Test.All import Hint.All import Grep +import Timing import Test.Proof import Parallel import HSE.All @@ -53,7 +55,13 @@ hlint args = do cmd <- getCmd args case cmd of - CmdMain{} -> do xs <- hlintMain args cmd; return $ if cmdNoExitCode cmd then [] else xs + CmdMain{} -> do + startTimings + (time, xs) <- duration $ hlintMain args cmd + when (cmdTiming cmd) $ do + printTimings + putStrLn $ "Took " ++ showDuration time + return $ if cmdNoExitCode cmd then [] else xs CmdGrep{} -> hlintGrep cmd >> return [] CmdHSE{} -> hlintHSE cmd >> return [] CmdTest{} -> hlintTest cmd >> return [] diff --git a/src/HSE/All.hs b/src/HSE/All.hs --- a/src/HSE/All.hs +++ b/src/HSE/All.hs @@ -20,6 +20,7 @@ import Data.Char import Data.List.Extra import Data.Maybe +import Timing import Language.Preprocessor.Cpphs import Data.Set (Set) import qualified Data.Map as Map @@ -143,7 +144,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 flags file str = do +parseModuleEx flags file str = timedIO "Parse" file $ do str <- case str of Just x -> return x Nothing | file == "-" -> getContents diff --git a/src/Hint/All.hs b/src/Hint/All.hs --- a/src/Hint/All.hs +++ b/src/Hint/All.hs @@ -7,8 +7,10 @@ import Data.Monoid import Config.Type import Data.Either -import Data.List +import Data.List.Extra import Hint.Type +import Timing +import Util import Prelude import Hint.Match @@ -58,11 +60,11 @@ HintNewType -> decl newtypeHint HintRestrict -> mempty{hintModule=restrictHint} where - decl x = mempty{hintDecl=const x} - modu x = mempty{hintModule=const x} - mods x = mempty{hintModules=const x} - comm x = mempty{hintComment=const x} - + wrap = timed "Hint" (drop 4 $ show x) . forceList + decl f = mempty{hintDecl=const $ \a b c -> wrap $ f a b c} + modu f = mempty{hintModule=const $ \a b -> wrap $ f a b} + mods f = mempty{hintModules=const $ \a -> wrap $ f a} + comm f = mempty{hintComment=const $ \a -> wrap $ f a} -- | A list of builtin hints, currently including entries such as @\"List\"@ and @\"Bracket\"@. builtinHints :: [(String, Hint)] @@ -70,7 +72,7 @@ -- | Transform a list of 'HintBuiltin' or 'HintRule' into a 'Hint'. resolveHints :: [Either HintBuiltin HintRule] -> Hint -resolveHints xs = mconcat $ mempty{hintDecl=const $ readMatch rights} : map builtin (nub lefts) +resolveHints xs = mconcat $ mempty{hintDecl=const $ readMatch rights} : map builtin (nubOrd lefts) where (lefts,rights) = partitionEithers xs -- | Transform a list of 'HintRule' into a 'Hint'. diff --git a/src/Hint/Extensions.hs b/src/Hint/Extensions.hs --- a/src/Hint/Extensions.hs +++ b/src/Hint/Extensions.hs @@ -144,7 +144,7 @@ minimalExtensions :: Module_ -> [Extension] -> [Extension] -minimalExtensions x es = nub $ concatMap f es +minimalExtensions x es = nubOrd $ concatMap f es where f e = [e | usedExt e x] diff --git a/src/Hint/Match.hs b/src/Hint/Match.hs --- a/src/Hint/Match.hs +++ b/src/Hint/Match.hs @@ -47,6 +47,8 @@ import Control.Monad import Data.Tuple.Extra import HSE.Unify +import Util +import Timing import qualified Data.Set as Set import Prelude import qualified Refact.Types as R @@ -90,7 +92,7 @@ -- PERFORM THE MATCHING findIdeas :: [HintRule] -> Scope -> Module S -> Decl_ -> [Idea] -findIdeas matches s _ decl = +findIdeas matches s _ decl = timed "Hint" "Match apply" $ forceList [ (idea (hintRuleSeverity m) (hintRuleName m) x y [r]){ideaNote=notes} | decl <- case decl of InstDecl{} -> children decl; _ -> [decl] , (parent,x) <- universeParentExp decl, not $ isParen x diff --git a/src/Hint/Naming.hs b/src/Hint/Naming.hs --- a/src/Hint/Naming.hs +++ b/src/Hint/Naming.hs @@ -16,7 +16,7 @@ data Yes = Foo | Bar'Test -- data Yes = Foo | BarTest data Yes = Bar | Test_Bar -- data Yes = Bar | TestBar data No = a :::: b -data Yes = Foo {bar_cap :: Int} -- data Yes = Foo{barCap :: Int} +data Yes = Foo {bar_cap :: Int} data No = FOO | BarBAR | BarBBar yes_foo = yes_foo + yes_foo -- yesFoo = ... no = 1 where yes_foo = 2 @@ -38,7 +38,7 @@ module Hint.Naming(namingHint) where import Hint.Type -import Data.List +import Data.List.Extra import Data.Data import Data.Char import Data.Maybe @@ -46,11 +46,11 @@ namingHint :: DeclHint -namingHint _ modu = naming $ Set.fromList [x | Ident _ x <- universeS modu] +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] - where res = [(n,y) | n <- nub $ getNames x, Just y <- [suggestName n], not $ y `Set.member` seen] + where res = [(n,y) | n <- nubOrd $ getNames x, Just y <- [suggestName n], not $ y `Set.member` seen] x2 = shorten x @@ -81,7 +81,7 @@ f (ConDecl _ x _) = [x] f (InfixConDecl _ _ x _) = [x] - f (RecDecl _ x ys) = x : concat [y | FieldDecl _ y _ <- ys] + f (RecDecl _ x _) = [x] suggestName :: String -> Maybe String diff --git a/src/Hint/Pragma.hs b/src/Hint/Pragma.hs --- a/src/Hint/Pragma.hs +++ b/src/Hint/Pragma.hs @@ -29,7 +29,7 @@ module Hint.Pragma(pragmaHint) where import Hint.Type -import Data.List +import Data.List.Extra import Data.Maybe import Refact.Types import qualified Refact.Types as R @@ -50,7 +50,7 @@ , let r = mkRefact old new ns] ls = concat [map fromNamed n | LanguagePragma _ n <- lang] - ns2 = nub (concat ns) \\ ls + ns2 = nubOrd (concat ns) \\ ls ys = [LanguagePragma an (map toNamed ns2) | ns2 /= []] ++ catMaybes new mkRefact :: ModulePragma S -> Maybe (ModulePragma S) -> [String] -> Refactoring R.SrcSpan diff --git a/src/Report.hs b/src/Report.hs --- a/src/Report.hs +++ b/src/Report.hs @@ -10,6 +10,7 @@ import System.FilePath import System.IO.Extra import HSE.All +import Timing import Paths_hlint import HsColour @@ -24,7 +25,7 @@ writeReport :: FilePath -> FilePath -> [Idea] -> IO () -writeReport dataDir file ideas = writeTemplate dataDir inner file +writeReport dataDir file ideas = timedIO "Report" file $ writeTemplate dataDir inner file where generateIds :: [String] -> [(String,Int)] -- sorted by name generateIds = map (head &&& length) . group -- must be already sorted diff --git a/src/Test/Proof.hs b/src/Test/Proof.hs --- a/src/Test/Proof.hs +++ b/src/Test/Proof.hs @@ -8,7 +8,7 @@ import Control.Monad import Control.Monad.Trans.State import Data.Char -import Data.List +import Data.List.Extra import Data.Maybe import Data.Function import System.FilePath @@ -26,6 +26,9 @@ instance Eq Theorem where t1 == t2 = lemma t1 == lemma t2 +instance Ord Theorem where + compare t1 t2 = compare (lemma t1) (lemma t2) + instance Show Theorem where show Theorem{..} = location ++ ":\n" ++ maybe "" f original ++ lemma ++ "\n" where f HintRule{..} = "(* " ++ prettyPrint hintRuleLHS ++ " ==> " ++ prettyPrint hintRuleRHS ++ " *)\n" @@ -33,7 +36,7 @@ proof :: [FilePath] -> [Setting] -> FilePath -> IO () proof reports hints thy = do got <- isabelleTheorems (takeFileName thy) <$> readFile thy - let want = nub $ hintTheorems hints + let want = nubOrd $ hintTheorems hints let unused = got \\ want let missing = want \\ got let reasons = map (\x -> (fst $ head x, map snd x)) $ groupBy ((==) `on` fst) $ diff --git a/src/Test/Translate.hs b/src/Test/Translate.hs --- a/src/Test/Translate.hs +++ b/src/Test/Translate.hs @@ -63,7 +63,7 @@ ["{-# LINE " ++ show (startLine $ ann rhs) ++ " " ++ show (fileName $ ann rhs) ++ " #-}\n" ++ prettyPrint (PatBind an (toNamed $ "test" ++ show i) bod Nothing) | (i, HintRule _ _ _ lhs rhs side _) <- zip [1..] hints, "noTypeCheck" `notElem` vars (maybeToList side) - , let vs = map toNamed $ nub $ filter isUnifyVar $ vars lhs ++ vars rhs + , let vs = map toNamed $ nubOrd $ filter isUnifyVar $ vars lhs ++ vars rhs , let inner = InfixApp an (Paren an lhs) (toNamed "==>") (Paren an rhs) , let bod = UnGuardedRhs an $ if null vs then inner else Lambda an vs inner] @@ -87,7 +87,7 @@ (toNamed "test" `app` str (fileName $ ann rhs) `app` int (startLine $ ann rhs) `app` str (prettyPrint lhs ++ " ==> " ++ prettyPrint rhs)) `app` toNamed "t" | (i, HintRule _ _ _ lhs rhs side note) <- zip [1..] hints, "noQuickCheck" `notElem` vars (maybeToList side) - , let vs = map (restrict side) $ nub $ filter isUnifyVar $ vars lhs ++ vars rhs + , let vs = map (restrict side) $ nubOrd $ filter isUnifyVar $ vars lhs ++ vars rhs , let op = if any isRemovesError note then "?==>" else "==>" , let inner = InfixApp an (Paren an lhs) (toNamed op) (Paren an rhs) , let bod = if null vs then Paren an inner else Lambda an vs inner] diff --git a/src/Timing.hs b/src/Timing.hs new file mode 100644 --- /dev/null +++ b/src/Timing.hs @@ -0,0 +1,65 @@ + +module Timing( + timed, timedIO, + startTimings, + printTimings + ) where + +import qualified Data.HashMap.Strict as Map +import Control.Exception +import Data.IORef.Extra +import Data.Tuple.Extra +import Data.List.Extra +import System.Time.Extra +import System.IO.Unsafe + + +type Category = String +type Item = String + +{-# NOINLINE useTimingsRef #-} +useTimingsRef :: IORef Bool +useTimingsRef = unsafePerformIO $ newIORef False + +{-# NOINLINE useTimings #-} +useTimings :: Bool +useTimings = unsafePerformIO $ readIORef useTimingsRef + +{-# NOINLINE timings #-} +timings :: IORef (Map.HashMap (Category, Item) Seconds) +timings = unsafePerformIO $ newIORef Map.empty + +{-# NOINLINE timed #-} +timed :: Category -> Item -> a -> a +timed c i x = if not useTimings then x else unsafePerformIO $ timedIO c i $ evaluate x + + +timedIO :: Category -> Item -> IO a -> IO a +timedIO c i x = if not useTimings then x else do + (time, x) <- duration x + atomicModifyIORef' timings $ \mp -> (Map.insertWith (+) (c, i) time mp, ()) + return x + +startTimings :: IO () +startTimings = do + writeIORef useTimingsRef True + writeIORef timings Map.empty + +printTimings :: IO () +printTimings = do + mp <- readIORef timings + let items = sortOn (sumSnd . snd) $ + groupSort $ map (\((a,b),c) -> (a,(b,c))) $ Map.toList mp + putStrLn $ unlines $ intercalate [""] $ map disp $ items ++ [("TOTAL", map (second sumSnd) items)] + where + sumSnd = sum . map snd + + disp (cat,xs) = + ("Timing " ++ cat) : + [" " ++ showDuration b ++ " " ++ a | (a,b) <- xs2] ++ + [" " ++ showDuration (sumSnd xs2) ++ " TOTAL"] + where + xs2 = f $ splitAt 9 $ sortOn (negate . snd) xs + f (xs,ys) + | length ys <= 1 = xs ++ ys + | otherwise = xs ++ [("Other items (" ++ show (length ys) ++ ")", sumSnd ys)] diff --git a/src/Util.hs b/src/Util.hs --- a/src/Util.hs +++ b/src/Util.hs @@ -2,6 +2,7 @@ module Util( defaultExtensions, + forceList, gzip, universeParentBi, exitMessage, exitMessageImpure ) where @@ -14,6 +15,13 @@ import Data.Data import Data.Generics.Uniplate.Operations import Language.Haskell.Exts.Extension + + +--------------------------------------------------------------------- +-- CONTROL.DEEPSEQ + +forceList :: [a] -> [a] +forceList xs = length xs `seq` xs ---------------------------------------------------------------------