packages feed

dead-code-detection (empty) → 0.1

raw patch · 15 files changed

+892/−0 lines, 15 filesdep +Globdep +basedep +containerssetup-changed

Dependencies added: Glob, base, containers, directory, filepath, getopt-generics, ghc, ghc-paths, gitrev, graph-wrapper, hspec, interpolate, mockery, silently, string-conversions, uniplate

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ dead-code-detection.cabal view
@@ -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 <soenkehahn@gmail.com>+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
+ driver/Main.hs view
@@ -0,0 +1,7 @@++module Main where++import           Run++main :: IO ()+main = run
+ src/Ast.hs view
@@ -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
+ src/Files.hs view
@@ -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" :+      []
+ src/GHC/Show.hs view
@@ -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
+ src/Graph.hs view
@@ -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)
+ src/Run.hs view
@@ -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
+ test/AstSpec.hs view
@@ -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", [])] []
+ test/FilesSpec.hs view
@@ -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"]
+ test/GraphSpec.hs view
@@ -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` []
+ test/Helper.hs view
@@ -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 "<unknown module>" (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
+ test/RunSpec.hs view
@@ -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"]
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}