From db6e4b117d88906df82c18b002a70bc8fe65e5f0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Fri, 3 Jun 2016 18:39:21 +0800 Subject: [PATCH] Warn on missing ignored files and detect ignored files better --- dead-code-detection.cabal | 5 ++-- package.yaml | 2 +- src/Run.hs | 29 +++++++++++++++++++-- test/RunSpec.hs | 53 +++++++++++++++++++++++++++++++-------- 4 files changed, 74 insertions(+), 15 deletions(-) diff --git a/dead-code-detection.cabal b/dead-code-detection.cabal index 5a859d4..58a53a1 100644 --- a/dead-code-detection.cabal +++ b/dead-code-detection.cabal @@ -1,4 +1,4 @@ --- This file has been generated from package.yaml by hpack version 0.13.0. +-- This file has been generated from package.yaml by hpack version 0.14.0. -- -- see: https://github.com/sol/hpack @@ -40,6 +40,7 @@ executable dead-code-detection , uniplate , ghc-paths , gitrev + , directory other-modules: Ast Ast.UsedNames @@ -69,11 +70,11 @@ test-suite spec , uniplate , ghc-paths , gitrev + , directory , hspec , mockery , interpolate , filepath - , directory other-modules: Ast.UsedNamesSpec AstSpec diff --git a/package.yaml b/package.yaml index 56be1d9..0998f5a 100644 --- a/package.yaml +++ b/package.yaml @@ -24,6 +24,7 @@ dependencies: - uniplate - ghc-paths - gitrev + - directory executables: dead-code-detection: @@ -43,4 +44,3 @@ tests: - mockery - interpolate - filepath - - directory diff --git a/src/Run.hs b/src/Run.hs index 72ec9b0..2d37a36 100644 --- a/src/Run.hs +++ b/src/Run.hs @@ -11,6 +11,7 @@ import Development.GitRev import FastString import GHC import OccName +import System.Directory import System.Exit import WithCli @@ -43,8 +44,8 @@ run = do throwIO ExitSuccess when (null $ root options) $ die "missing option: --root=STRING" - files <- filter (`notElem` ignore options) <$> - findHaskellFiles (sourceDirs options) + files <- findHaskellFiles (sourceDirs options) + >>= filterNotIgnored (ignore options) deadNames <- deadNamesFromFiles files (map mkModuleName (root options)) @@ -66,6 +67,30 @@ versionOutput = "branch: " ++ $(gitBranch) else "version: " ++ showVersion Paths.version +filterNotIgnored :: [FilePath] -> [FilePath] -> IO [FilePath] +filterNotIgnored ignored files = do + ignoredCanonicalized <- mapM safeCanonicalize ignored + forFilterM files $ \ file -> do + canonicalized <- safeCanonicalize file + return $ not (canonicalized `elem` ignoredCanonicalized) + +safeCanonicalize :: FilePath -> IO FilePath +safeCanonicalize file = do + exists <- doesFileExist file + when (not exists) $ do + die ("file not found: " ++ file) + canonicalizePath file + +forFilterM :: Monad m => [a] -> (a -> m Bool) -> m [a] +forFilterM list pred = case list of + (a : r) -> do + cond <- pred a + rest <- forFilterM r pred + if cond + then return (a : rest) + else return rest + [] -> return [] + deadNamesFromFiles :: [FilePath] -> [ModuleName] -> Bool -> IO [String] deadNamesFromFiles files roots includeUnderscoreNames = do ast <- parse files diff --git a/test/RunSpec.hs b/test/RunSpec.hs index 6af5313..036872d 100644 --- a/test/RunSpec.hs +++ b/test/RunSpec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} module RunSpec where @@ -32,7 +33,7 @@ spec = do it "exits with a non-zero exit-code" $ do withModules [main] $ do - run' `shouldThrow` (== ExitFailure 1) + run' `shouldDie` "" it "allows to set multiple roots" $ do let a = ("A", [i| @@ -57,16 +58,37 @@ spec = do withArgs ["--version"] run output `shouldContain` "version: " - it "ignores files if told to do so" $ do - let main = ("Main", [i| - module Main where - main = return () - |]) - b = ("B", [i| - This is some arbitrary text that is not Haskell. + context "--ignore" $ do + + it "ignores files if told to do so" $ do + let main = ("Main", [i| + module Main where + main = return () |]) - run' = withArgs (words "-i. -e./B.hs --root Main") run - withModules [main, b] $ run' `shouldReturn` () + b = ("B", [i| + This is some arbitrary text that is not Haskell. + |]) + run' = withArgs (words "-i. -e./B.hs --root Main") run + withModules [main, b] $ run' `shouldReturn` () + + it "errors out on missing ignored files" $ do + let main = ("Main", [i| + module Main where + main = return () + |]) + run' = withArgs (words "-i. -e./B.hs --root Main") run + withModules [main] $ run' `shouldDie` "file not found: ./B.hs\n" + + it "ignores files if referenced differently" $ do + let main = ("Main", [i| + module Main where + main = return () + |]) + b = ("B", [i| + This is some arbitrary text that is not Haskell. + |]) + run' = withArgs (words "-i. -e B.hs --root Main") run + withModules [main, b] $ run' `shouldReturn` () describe "deadNamesFromFiles" $ do it "should clearly mark ghc's output as such" $ do @@ -137,3 +159,14 @@ spec = do withModules [a, b] $ do dead <- deadNamesFromFiles ["A.hs", "B.hs"] [mkModuleName "A"] False dead `shouldMatchList` ["A.hs:4:1: bar", "B.hs:2:1: baz"] + +shouldDie :: IO a -> String -> IO () +shouldDie action err = do + (output, exception) <- hCapture [stderr] $ catch + (action >> return Nothing) + (\ (e :: ExitCode) -> return $ Just e) + case exception of + Nothing -> throwIO $ ErrorCall "shouldDie: didn't receive ExitCode exception" + Just ExitSuccess -> throwIO $ ErrorCall "shouldDie: received ExitSuccess exception" + Just (ExitFailure _) -> + output `shouldBe` err