diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Sönke Hahn + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Sönke Hahn nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/dead-code-detection.cabal b/dead-code-detection.cabal new file mode 100644 --- /dev/null +++ b/dead-code-detection.cabal @@ -0,0 +1,83 @@ +-- This file has been generated from package.yaml by hpack version 0.5.4. +-- +-- see: https://github.com/sol/hpack + +name: dead-code-detection +version: 0.1 +synopsis: detect dead code in haskell projects +description: detect dead code in haskell projects +category: Development +homepage: https://github.com/soenkehahn/dead-code-detection#readme +bug-reports: https://github.com/soenkehahn/dead-code-detection/issues +maintainer: Sönke Hahn +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 + +source-repository head + type: git + location: https://github.com/soenkehahn/dead-code-detection + +executable dead-code-detection + main-is: Main.hs + hs-source-dirs: + src + , driver + ghc-options: -Wall -fno-warn-name-shadowing + build-depends: + base == 4.* + , silently + , getopt-generics + , ghc + , Glob + , string-conversions + , graph-wrapper + , containers + , uniplate + , ghc-paths + , gitrev + other-modules: + Ast + Files + GHC.Show + Graph + Run + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: + test + , src + ghc-options: -Wall -fno-warn-name-shadowing + build-depends: + base == 4.* + , silently + , getopt-generics + , ghc + , Glob + , string-conversions + , graph-wrapper + , containers + , uniplate + , ghc-paths + , gitrev + , hspec + , mockery + , interpolate + , filepath + , directory + other-modules: + AstSpec + FilesSpec + GraphSpec + Helper + RunSpec + Ast + Files + GHC.Show + Graph + Run + default-language: Haskell2010 diff --git a/driver/Main.hs b/driver/Main.hs new file mode 100644 --- /dev/null +++ b/driver/Main.hs @@ -0,0 +1,7 @@ + +module Main where + +import Run + +main :: IO () +main = run diff --git a/src/Ast.hs b/src/Ast.hs new file mode 100644 --- /dev/null +++ b/src/Ast.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ViewPatterns #-} + +module Ast ( + Ast, + findExports, + parse, + usedTopLevelNames, + ) where + +import Bag +import Control.Arrow ((>>>), second) +import Control.Monad +import Data.Data +import Data.Generics.Uniplate.Data +import Data.List +import qualified GHC +import GHC hiding (Module, moduleName) +import GHC.Paths (libdir) +import Name +import Outputable +import System.IO +import System.IO.Silently + +import GHC.Show +import Graph + +type Ast = [Module] + +data Module + = Module { + moduleName :: ModuleName, + moduleExports :: Maybe [LIE Name], + moduleDeclarations :: HsGroup Name + } + deriving (Data) + +instance Outputable Module where + ppr m = + text "Module" <+> + ppr (moduleName m) <+> + ppr (moduleExports m) <+> + brackets (ppr (moduleDeclarations m)) + +toModule :: TypecheckedModule -> Module +toModule m = case tm_renamed_source m of + Just (hsGroup, _, exports, _) -> + Module + (GHC.moduleName $ ms_mod $ pm_mod_summary $ tm_parsed_module m) + exports + hsGroup + Nothing -> error "tm_renamed_source should point to a renamed source after renaming" + +parse :: [FilePath] -> IO (Either String Ast) +parse files = + errorHandler $ + runGhc (Just libdir) $ do + dynFlags <- getSessionDynFlags + void $ setSessionDynFlags $ dynFlags { + hscTarget = HscNothing, + ghcLink = NoLink + } + targets <- forM files $ \ file -> guessTarget file Nothing + setTargets targets + modSummaries <- depanal [] False + r <- load LoadAllTargets + case r of + Failed -> return Nothing + Succeeded -> do + let isModuleFromFile m = case ml_hs_file $ ms_location m of + Nothing -> error ("parse: module without file") + Just file -> file `elem` files + mods = filter isModuleFromFile modSummaries + typecheckedModules <- forM mods $ \ mod -> + (parseModule mod >>= typecheckModule) + return $ Just $ map toModule typecheckedModules + +errorHandler :: IO (Maybe a) -> IO (Either String a) +errorHandler action = do + (errs, a) <- hCapture [stderr] action + return $ maybe (Left errs) Right a + +findExports :: Ast -> [ModuleName] -> Either String [Name] +findExports ast names = concat <$> mapM inner names + where + inner name = + case filter (\ m -> moduleName m == name) ast of + [Module _ Nothing declarations] -> + return $ boundNames declarations + [Module _ (Just exports) _] -> + return $ concatMap (ieNames . unLoc) exports + [] -> Left ("cannot find module: " ++ moduleNameString name) + _ -> Left ("found module multiple times: " ++ moduleNameString name) + +-- * name usage graph + +usedTopLevelNames :: Ast -> Graph Name +usedTopLevelNames ast = + Graph + (removeLocalNames (nameGraph ast)) + (getClassMethodUsedNames ast) + where + isTopLevelName :: Name -> Bool + isTopLevelName = maybe False (const True) . nameModule_maybe + + removeLocalNames :: [(Name, [Name])] -> [(Name, [Name])] + removeLocalNames = + filter (isTopLevelName . fst) >>> + map (second (filter isTopLevelName)) + +-- | extracts the name usage graph from ASTs +class NameGraph ast where + nameGraph :: ast -> [(Name, [Name])] + +instance NameGraph a => NameGraph [a] where + nameGraph = concatMap nameGraph + +instance NameGraph a => NameGraph (Bag a) where + nameGraph = concatMap nameGraph . bagToList + +instance NameGraph a => NameGraph (Located a) where + nameGraph = nameGraph . unLoc + +instance NameGraph Module where + nameGraph = nameGraph . moduleDeclarations + +instance NameGraph (HsGroup Name) where + nameGraph group = + nameGraph (hs_valds group) ++ + map (, []) (boundNames (hs_tyclds group)) + +instance NameGraph (HsValBinds Name) where + nameGraph = \ case + ValBindsOut (map snd -> binds) _signatures -> nameGraph binds + ValBindsIn _ _ -> error "ValBindsIn shouldn't exist after renaming" + +instance NameGraph (HsBindLR Name Name) where + nameGraph binding = + map (, nub $ usedNames bn binding) bn + where + bn = boundNames binding + +-- | extracts the bound names from ASTs +class BoundNames ast where + boundNames :: ast -> [Name] + +instance (BoundNames a) => BoundNames (Located a) where + boundNames = boundNames . unLoc + +instance (BoundNames a) => BoundNames [a] where + boundNames = concatMap boundNames + +instance BoundNames (HsGroup Name) where + boundNames group = boundNames (universeBi group :: [HsBindLR Name Name]) + +instance BoundNames (HsBindLR Name Name) where + boundNames = \ case + FunBind id _ _ _ _ _ -> [unLoc id] + PatBind pat _ _ _ _ -> boundNames pat + bind -> nyi bind + +instance BoundNames (Pat Name) where + boundNames = \ case + ParPat p -> boundNames p + ConPatIn _ p -> boundNames p + VarPat p -> [p] + TuplePat pats _ _ -> boundNames pats + pat -> nyi pat + +instance BoundNames (HsConPatDetails Name) where + boundNames = \ case + PrefixCon args -> boundNames args + _ -> error "Not yet implemented: HsConPatDetails" + +instance BoundNames (TyClGroup Name) where + boundNames g = boundNames (universeBi g :: [ConDecl Name]) + +instance BoundNames (ConDecl Name) where + boundNames conDecl = + filter (not . isHidden) $ + concatMap (map unLoc . cd_fld_names) (universeBi conDecl :: [ConDeclField Name]) + where + isHidden :: Name -> Bool + isHidden name = "_" `isPrefixOf` occNameString (getOccName name) + +-- | extracts names used in instance declarations +getClassMethodUsedNames :: Ast -> [Name] +getClassMethodUsedNames ast = + concatMap fromInstanceDecl (universeBi ast) ++ + concatMap fromClassDecl (universeBi ast) + where + fromInstanceDecl :: InstDecl Name -> [Name] + fromInstanceDecl = concatMap usedNamesBind . universeBi + + fromClassDecl :: TyClDecl Name -> [Name] + fromClassDecl = \ case + ClassDecl{tcdMeths} -> + concatMap usedNamesBind $ map unLoc $ bagToList tcdMeths + _ -> [] + + usedNamesBind :: HsBindLR Name Name -> [Name] + usedNamesBind bind = usedNames (boundNames bind) bind + +-- | extracts all used names from ASTs +usedNames :: [Name] -> HsBindLR Name Name -> [Name] +usedNames ids = filter (`notElem` ids) . universeBi diff --git a/src/Files.hs b/src/Files.hs new file mode 100644 --- /dev/null +++ b/src/Files.hs @@ -0,0 +1,15 @@ + +module Files where + +import System.FilePath.Glob + +findHaskellFiles :: [FilePath] -> IO [FilePath] +findHaskellFiles sourceDirs = concat <$> mapM inner sourceDirs + where + inner sourceDir = + concat <$> fst <$> + globDir patterns sourceDir + patterns = map compile $ + "**/*.hs" : + "**/*.lhs" : + [] diff --git a/src/GHC/Show.hs b/src/GHC/Show.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Show.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE LambdaCase #-} + +module GHC.Show where + +import Data.String.Conversions +import FastString +import GHC +import Name +import Outputable + +formatName :: Name -> String +formatName name = + srcLocS ++ ": " ++ showSDocUnsafe (ppr name) + where + srcLocS = case nameSrcLoc name of + RealSrcLoc loc -> + cs (fs_bs (srcLocFile loc)) ++ ":" ++ + show (srcLocLine loc) ++ ":" ++ + show (srcLocCol loc) + UnhelpfulLoc s -> cs (fs_bs s) + +-- * development utils + +nyi :: Outputable doc => doc -> a +nyi = error . ("Not yet implemented: " ++) . showSDocUnsafe . ppr diff --git a/src/Graph.hs b/src/Graph.hs new file mode 100644 --- /dev/null +++ b/src/Graph.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE ViewPatterns #-} + +module Graph where + +import qualified Data.Graph.Wrapper as Wrapper +import Data.Graph.Wrapper hiding (Graph, toList) +import Data.List +import qualified Data.Set as Set +import Name + +data Graph a = Graph { + _usageGraph :: [(a, [a])], + classMethodsUsedNames :: [a] +} deriving (Show, Functor) + +instance (Ord a) => Eq (Graph a) where + Graph a aUseds == Graph b bUseds = + a === b && + aUseds === bUseds + where + x === y = sort (nub x) == sort (nub y) + +toWrapperGraph :: Ord a => Graph a -> Wrapper.Graph a () +toWrapperGraph (Graph g _) = fromListLenient $ + map (\ (v, outs) -> (v, (), outs)) g + +deadNames :: Graph Name -> [Name] -> [Name] +deadNames g@(toWrapperGraph -> graph) roots = + sortTopologically graph $ + case map (deadNamesSingle graph) (roots ++ classMethodsUsedNames g) of + (x : xs) -> foldl Set.intersection x xs + [] -> Set.fromList $ vertices graph + +deadNamesSingle :: Wrapper.Graph Name () -> Name -> Set.Set Name +deadNamesSingle graph root = + let reachable = Set.fromList $ reachableVertices graph root + allTopLevelDecls = Set.fromList $ vertices graph + in allTopLevelDecls Set.\\ reachable + +sortTopologically :: Ord a => Wrapper.Graph a () -> Set.Set a -> [a] +sortTopologically graph set = + filter (`Set.member` set) (topologicalSort graph) diff --git a/src/Run.hs b/src/Run.hs new file mode 100644 --- /dev/null +++ b/src/Run.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} + +module Run where + +import Control.Exception +import Control.Monad +import Data.Version +import Development.GitRev +import GHC +import qualified GHC.Generics +import System.Console.GetOpt.Generics +import System.Exit + +import Ast +import Files +import GHC.Show +import Graph +import qualified Paths_dead_code_detection as Paths + +data Options + = Options { + sourceDirs :: [FilePath], + root :: [String], + version :: Bool + } + deriving (Show, Eq, GHC.Generics.Generic) + +instance Generic Options +instance HasDatatypeInfo Options + +run :: IO () +run = do + options <- modifiedGetArguments $ + AddShortOption "sourceDirs" 'i' : + -- UseForPositionalArguments "root" "ROOT" : + [] + when (options == Options [] [] False) $ + die "missing option: --root=STRING" + when (version options) $ do + putStrLn versionOutput + throwIO ExitSuccess + files <- findHaskellFiles (sourceDirs options) + deadNames <- deadNamesFromFiles files (map mkModuleName (root options)) + case deadNames of + [] -> return () + _ -> do + forM_ deadNames putStrLn + exitWith $ ExitFailure 1 + +versionOutput :: String +versionOutput = + "version: " ++ full + where + isInGit = $(gitHash) /= "UNKNOWN" + full = if isInGit + then "version: " ++ showVersion Paths.version ++ "\n" ++ + "rev: " ++ $(gitHash) ++ (if $(gitDirty) then " (dirty)" else "") ++ "\n" ++ + "branch: " ++ $(gitBranch) + else "version: " ++ showVersion Paths.version + +deadNamesFromFiles :: [FilePath] -> [ModuleName] -> IO [String] +deadNamesFromFiles files roots = do + ast <- parse files + case ast of + Left err -> die err + Right ast -> case findExports ast roots of + Left err -> die err + Right rootExports -> do + let graph = usedTopLevelNames ast + return $ fmap formatName $ deadNames graph rootExports diff --git a/test/AstSpec.hs b/test/AstSpec.hs new file mode 100644 --- /dev/null +++ b/test/AstSpec.hs @@ -0,0 +1,168 @@ +{-# language QuasiQuotes #-} + +module AstSpec where + +import Control.Monad +import Data.String.Interpolate +import GHC +import Outputable +import System.Directory +import System.IO +import System.IO.Silently +import Test.Hspec + +import Ast +import Graph +import Helper + +showAst :: Ast -> String +showAst = showSDocUnsafe . ppr + +spec :: Spec +spec = do + describe "parse" $ do + it "parses a simple module" $ do + withFooHeader "foo = 3 -- bar" $ do + ast <- parse ["Foo.hs"] + fmap showAst ast `shouldBe` Right "[Module Foo Nothing [foo = 3]]" + + it "handles an invalid module gracefully" $ do + withFooHeader "foo = bar" $ do + result <- parse ["Foo.hs"] + void result `shouldBe` Left "\nFoo.hs:2:7: Not in scope: ‘bar’\n" + + it "doesn't output error messages" $ do + withFoo "foo = bar" $ do + output <- hCapture_ [stdout, stderr] $ parse ["Foo.hs"] + output `shouldBe` "" + + it "doesn't follow imports" $ do + let a = ("A", [i| + module A where + foo = () + |]) + b = ("B", [i| + module B where + import A + bar = foo + |]) + withModules [a, b] $ do + parseStringGraph ["B.hs"] `shouldReturn` + Graph [("B.bar", ["A.foo"])] [] + + it "can be used to parse multiple files" $ do + let a = ("A", [i| + module A where + foo = foo + |]) + b = ("B", [i| + module B where + bar = bar + |]) + withModules [a, b] $ do + parseStringGraph ["A.hs", "B.hs"] `shouldReturn` + Graph [("A.foo", []), ("B.bar", [])] [] + + it "does not create any files" $ do + withFooHeader [i| + foo = () + bar = () + |] $ do + _ <- parse ["Foo.hs"] + files <- getDirectoryContents "." + files `shouldMatchList` (words ". .. Foo.hs") + + describe "findExports" $ do + let find moduleFile moduleName = do + Right ast <- parse [moduleFile] + let Right exports = findExports ast moduleName + return $ map showName exports + it "finds the names exported by a given module" $ do + withFooHeader [i| + foo = () + bar = () + |] $ do + exports <- find "Foo.hs" [mkModuleName "Foo"] + exports `shouldMatchList` ["Foo.foo", "Foo.bar"] + + context "when given a module with an export list" $ do + it "returns the explicit exports" $ do + let a = ("A", [i| + module A (foo) where + foo = () + bar = () + |]) + withModules [a] $ do + exports <- find "A.hs" [mkModuleName "A"] + exports `shouldBe` ["A.foo"] + + describe "usedTopLevelNames" $ do + it "returns the graph of identifier usage" $ do + withFooHeader [i| + foo = bar + bar = () + |] $ do + g <- usageGraph <$> parseStringGraph ["Foo.hs"] + g `shouldMatchList` [("Foo.foo", ["Foo.bar"]), ("Foo.bar", ["GHC.Tuple.()"])] + + it "detects usage in ViewPatterns" $ do + withFoo [i| + {-# LANGUAGE ViewPatterns #-} + module Foo where + x y = () + bar (x -> y) = () + |] $ do + g <- usageGraph <$> parseStringGraph ["Foo.hs"] + let Just used = lookup "Foo.bar" g + used `shouldContain` ["Foo.x"] + + it "doesn't return local variables" $ do + withFooHeader [i| + foo = let x = x in x + |] $ do + parseStringGraph ["Foo.hs"] `shouldReturn` + Graph [("Foo.foo", [])] [] + + context "data type declarations" $ do + it "does not include constructor names" $ do + withFooHeader [i| + data A = A + |] $ do + parseStringGraph ["Foo.hs"] `shouldReturn` + Graph [] [] + + it "does detect selectors" $ do + withFooHeader [i| + data A = A { foo :: () } + |] $ do + boundNames <- map fst <$> usageGraph <$> parseStringGraph ["Foo.hs"] + boundNames `shouldContain` ["Foo.foo"] + + it "does not detect selectors starting with _" $ do + withFooHeader [i| + data A = A { _foo :: () } + |] $ do + boundNames <- map fst <$> usageGraph <$> parseStringGraph ["Foo.hs"] + boundNames `shouldNotContain` ["Foo._foo"] + + it "doesn't return bound names for instance methods" $ do + withFooHeader [i| + instance Show (a -> b) where + show _ = "" + |] $ do + (usageGraph <$> parseStringGraph ["Foo.hs"]) `shouldReturn` [] + + context "PatBind" $ do + it "can parse pattern binding" $ do + withFooHeader [i| + (Just foo) = let x = x in x + |] $ do + parseStringGraph ["Foo.hs"] `shouldReturn` + Graph [("Foo.foo", ["GHC.Base.Just"])] [] + + it "can parse tuple pattern binding" $ do + withFooHeader [i| + (a, b) = let x = x in x + |] $ do + parseStringGraph ["Foo.hs"] `shouldReturn` + Graph [("Foo.a", []), ("Foo.b", [])] [] diff --git a/test/FilesSpec.hs b/test/FilesSpec.hs new file mode 100644 --- /dev/null +++ b/test/FilesSpec.hs @@ -0,0 +1,23 @@ + +module FilesSpec where + +import Test.Hspec +import Test.Mockery.Directory + +import Files + +spec :: Spec +spec = do + describe "findHaskellFiles" $ do + it "returns haskell files in the directory recursively" $ do + inTempDirectory $ do + touch "somewhere/Makefile" + touch "Main.hs" + touch "somewhere/src/Foo.hs" + touch "somewhere/Main.hs" + touch "somewhere/src/Bar.lhs" + touch "somewhere/assets/baz.png" + touch "other/Foo.hs" + actual <- findHaskellFiles ["somewhere", "other"] + actual `shouldMatchList` + ["somewhere/src/Foo.hs", "somewhere/Main.hs", "somewhere/src/Bar.lhs", "other/Foo.hs"] diff --git a/test/GraphSpec.hs b/test/GraphSpec.hs new file mode 100644 --- /dev/null +++ b/test/GraphSpec.hs @@ -0,0 +1,70 @@ +{-# language QuasiQuotes #-} + +module GraphSpec where + +import Data.String.Interpolate +import GHC +import Test.Hspec + +import Graph +import Helper +import Ast + +getDeadNames :: IO [String] +getDeadNames = do + ast <- eitherToError $ parse ["Foo.hs"] + let graph = usedTopLevelNames ast + roots <- eitherToError $ return $ + findExports ast [mkModuleName "Foo"] + return $ fmap showName $ deadNames graph roots + +spec :: Spec +spec = do + describe "deadNames" $ do + it "detects unused top-level names" $ do + withFoo [i| + module Foo (foo) where + foo = () + bar = () + |] $ do + getDeadNames `shouldReturn` ["Foo.bar"] + + it "allows to specify multiple roots" $ do + withFoo [i| + module Foo (r1, r2) where + r1 = foo + r2 = bar + foo = () + bar = () + baz = () + |] $ do + getDeadNames `shouldReturn` ["Foo.baz"] + + it "detects usage of names in instance methods" $ do + withFoo [i| + module Foo () where + data A = A + instance Show A where + show A = foo + foo = "foo" + |] $ do + getDeadNames `shouldReturn` [] + + it "returns dead names in topological order" $ do + withFoo [i| + module Foo () where + b = c + a = b + c = () + |] $ do + getDeadNames `shouldReturn` (words "Foo.a Foo.b Foo.c") + + it "finds used names in default implementations of methods in class declarations" $ do + withFoo [i| + module Foo () where + class A a where + a :: a -> String + a _ = foo + foo = "foo" + |] $ do + getDeadNames `shouldReturn` [] diff --git a/test/Helper.hs b/test/Helper.hs new file mode 100644 --- /dev/null +++ b/test/Helper.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Helper where + +import Control.Exception +import Control.Monad +import Data.String.Interpolate.Util +import GHC +import Name +import Outputable +import System.Exit +import System.FilePath +import Test.Mockery.Directory + +import Ast +import Graph + +withFoo :: String -> IO () -> IO () +withFoo code = + withModules [("Foo", unindent code)] + +withFooHeader :: String -> IO () -> IO () +withFooHeader code = + withFoo ("module Foo where\n" ++ code) + +withModules :: [(String, String)] -> IO () -> IO () +withModules modules action = do + inTempDirectory $ do + forM_ modules $ \ (name, code) -> do + writeFile (name <.> "hs") (unindent code) + action + +parseStringGraph :: [FilePath] -> IO (Graph String) +parseStringGraph files = do + result <- parse files + case result of + Left e -> die e + Right r -> return $ fmap showName $ usedTopLevelNames r + +showName :: Name -> String +showName name = mod ++ "." ++ id + where + mod = maybe "" (showSDocUnsafe . ppr) $ + nameModule_maybe name + id = showSDocUnsafe $ ppr name + +swallowExceptions :: IO () -> IO () +swallowExceptions = handle (\ (_ :: SomeException) -> return ()) + +usageGraph :: Graph a -> [(a, [a])] +usageGraph = _usageGraph + +eitherToError :: IO (Either String a) -> IO a +eitherToError action = do + either die return =<< action diff --git a/test/RunSpec.hs b/test/RunSpec.hs new file mode 100644 --- /dev/null +++ b/test/RunSpec.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE QuasiQuotes #-} + +module RunSpec where + +import Control.Exception +import Data.String.Interpolate +import GHC +import System.Environment +import System.Exit +import System.IO +import System.IO.Silently +import Test.Hspec + +import Helper +import Run + +spec :: Spec +spec = do + describe "run" $ around_ (hSilence [stdout, stderr]) $ do + context "when given a module containing dead code" $ do + let main = ("Main", [i| + module Main (main) where + main = used + used = return () + unused = () + |]) + run' = withArgs (words "-i. --root Main") run + it "works" $ do + withModules [main] $ do + output <- capture_ $ swallowExceptions run' + output `shouldBe` "./Main.hs:4:1: unused\n" + + it "exits with a non-zero exit-code" $ do + withModules [main] $ do + run' `shouldThrow` (== ExitFailure 1) + + it "allows to set multiple roots" $ do + let a = ("A", [i| + module A (a) where + a = () + |]) + b = ("B", [i| + module B (b) where + b = () + |]) + withModules [a, b] $ do + output <- hCapture_ [stdout, stderr] $ swallowExceptions $ + withArgs (words "-i. --root A --root B") run + output `shouldBe` "" + + it "complains when it's invoked with no arguments" $ do + withArgs [] run `shouldThrow` (== ExitFailure 1) + + it "has a version option" $ do + output <- capture_ $ + handle (\ ExitSuccess -> return ()) $ + withArgs ["--version"] run + output `shouldContain` "version: " + + describe "deadNamesFromFiles" $ do + it "can be run on multiple modules" $ do + let a = ("A", [i| + module A where + foo = () + |]) + b = ("B", [i| + module B where + bar = () + |]) + withModules [a, b] $ do + deadNamesFromFiles ["A.hs", "B.hs"] [mkModuleName "A"] + `shouldReturn` ["B.hs:2:1: bar"] + + it "only considers exported top-level declarations as roots" $ do + let a = ("A", [i| + module A (foo) where + import B + foo = () + bar = B.baz + |]) + b = ("B", [i| + module B where + baz = () + |]) + withModules [a, b] $ do + dead <- deadNamesFromFiles ["A.hs", "B.hs"] [mkModuleName "A"] + dead `shouldMatchList` ["A.hs:4:1: bar", "B.hs:2:1: baz"] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}