packages feed

hlint 2.1.2 → 2.1.3

raw patch · 17 files changed

+125/−27 lines, 17 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

CHANGES.txt view
@@ -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
hlint.cabal view
@@ -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
src/Apply.hs view
@@ -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
src/CmdLine.hs view
@@ -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"
src/Config/Yaml.hs view
@@ -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
src/HLint.hs view
@@ -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 []
src/HSE/All.hs view
@@ -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
src/Hint/All.hs view
@@ -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'.
src/Hint/Extensions.hs view
@@ -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]
src/Hint/Match.hs view
@@ -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
src/Hint/Naming.hs view
@@ -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
src/Hint/Pragma.hs view
@@ -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
src/Report.hs view
@@ -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
src/Test/Proof.hs view
@@ -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) $
src/Test/Translate.hs view
@@ -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]
+ src/Timing.hs view
@@ -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)]
src/Util.hs view
@@ -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   ---------------------------------------------------------------------