├── .gitignore ├── test ├── Spec.hs ├── Main.hs ├── FilesSpec.hs ├── Ast │ └── UsedNamesSpec.hs ├── Helper.hs ├── GraphSpec.hs ├── RunSpec.hs └── AstSpec.hs ├── Setup.hs ├── stack.yaml ├── driver └── Main.hs ├── .ghci ├── src ├── Files.hs ├── GHC │ └── Show.hs ├── Utils.hs ├── Graph.hs ├── Run.hs ├── Ast │ └── UsedNames.hs └── Ast.hs ├── README.md ├── .travis.yml ├── package.yaml ├── LICENSE └── dead-code-detection.cabal /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} 2 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | import Distribution.Simple 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | packages: 3 | - '.' 4 | extra-deps: [] 5 | resolver: lts-5.8 6 | -------------------------------------------------------------------------------- /driver/Main.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main where 3 | 4 | import Run 5 | 6 | main :: IO () 7 | main = run 8 | -------------------------------------------------------------------------------- /.ghci: -------------------------------------------------------------------------------- 1 | :set -itest -isrc 2 | :set -i.stack-work/dist/x86_64-linux/Cabal-1.22.5.0/build/autogen 3 | :set -package ghc 4 | :set -Wall -fno-warn-name-shadowing 5 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main where 3 | 4 | import GHC (runGhc) 5 | import GHC.Paths (libdir) 6 | 7 | import qualified Spec 8 | 9 | main :: IO () 10 | main = do 11 | runGhc (Just libdir) (return ()) 12 | Spec.main 13 | -------------------------------------------------------------------------------- /src/Files.hs: -------------------------------------------------------------------------------- 1 | 2 | module Files where 3 | 4 | import System.FilePath.Glob 5 | 6 | findHaskellFiles :: [FilePath] -> IO [FilePath] 7 | findHaskellFiles sourceDirs = concat <$> mapM inner sourceDirs 8 | where 9 | inner sourceDir = 10 | concat <$> fst <$> 11 | globDir patterns sourceDir 12 | patterns = map compile $ 13 | "**/*.hs" : 14 | "**/*.lhs" : 15 | [] 16 | -------------------------------------------------------------------------------- /src/GHC/Show.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | module GHC.Show where 4 | 5 | import Data.String.Conversions 6 | import FastString 7 | import GHC 8 | import Name 9 | import Outputable 10 | 11 | formatName :: Name -> String 12 | formatName name = 13 | srcLocS ++ ": " ++ showSDocUnsafe (ppr name) 14 | where 15 | srcLocS = case nameSrcLoc name of 16 | RealSrcLoc loc -> 17 | cs (fs_bs (srcLocFile loc)) ++ ":" ++ 18 | show (srcLocLine loc) ++ ":" ++ 19 | show (srcLocCol loc) 20 | UnhelpfulLoc s -> cs (fs_bs s) 21 | -------------------------------------------------------------------------------- /test/FilesSpec.hs: -------------------------------------------------------------------------------- 1 | 2 | module FilesSpec where 3 | 4 | import Test.Hspec 5 | import Test.Mockery.Directory 6 | 7 | import Files 8 | 9 | spec :: Spec 10 | spec = do 11 | describe "findHaskellFiles" $ do 12 | it "returns haskell files in the directory recursively" $ do 13 | inTempDirectory $ do 14 | touch "somewhere/Makefile" 15 | touch "Main.hs" 16 | touch "somewhere/src/Foo.hs" 17 | touch "somewhere/Main.hs" 18 | touch "somewhere/src/Bar.lhs" 19 | touch "somewhere/assets/baz.png" 20 | touch "other/Foo.hs" 21 | actual <- findHaskellFiles ["somewhere", "other"] 22 | actual `shouldMatchList` 23 | ["somewhere/src/Foo.hs", "somewhere/Main.hs", "somewhere/src/Bar.lhs", "other/Foo.hs"] 24 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## *status: experimental* 2 | 3 | `dead-code-detection` detects dead code in haskell projects. 4 | 5 | This project is still in an early stage. Currently only those language 6 | constructs have been implemented that I have stumbled across in projects I used 7 | it on. If the tool encounters a language construct that it doesn't understand 8 | yet, it will crash. (I *think* this is the best behavior since ignoring 9 | unimplemented language constructs would easily result in false positives and 10 | false negatives.) If you use `dead-code-detection` on any project and it 11 | doesn't work due to a not implemented language construct, please consider 12 | opening an issue on github. 13 | 14 | ``` shell 15 | $ dead-code-detection --root Main -isrc 16 | src/Example/Module.hs:42:23: unusedName 17 | ``` 18 | -------------------------------------------------------------------------------- /test/Ast/UsedNamesSpec.hs: -------------------------------------------------------------------------------- 1 | 2 | module Ast.UsedNamesSpec where 3 | 4 | import Control.Exception 5 | import Data.Foldable 6 | import Data.List 7 | import Test.Hspec 8 | 9 | import Ast.UsedNames 10 | 11 | spec :: Spec 12 | spec = do 13 | let errs :: [(String, ())] 14 | errs = 15 | ("errorNyiData", errorNyiData ()) : 16 | ("errorNyiOutputable", errorNyiOutputable ()) : 17 | [] 18 | forM_ errs $ \ (name, err) -> do 19 | describe name $ do 20 | it "explains that this is not yet implemented" $ do 21 | seq err (return ()) `shouldThrow` \ (ErrorCall message) -> 22 | "not yet implemented" `isInfixOf` message 23 | 24 | it "points to the issue tracker" $ do 25 | seq err (return ()) `shouldThrow` \ (ErrorCall message) -> 26 | "https://github.com/soenkehahn/dead-code-detection/issues" `isInfixOf` 27 | message 28 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | sudo: false 2 | 3 | addons: 4 | apt: 5 | packages: 6 | - libgmp-dev 7 | 8 | install: 9 | # stack 10 | - mkdir -p ~/.local/bin 11 | - export PATH=~/.local/bin:$PATH 12 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 13 | - stack --version 14 | 15 | script: 16 | - stack setup --no-terminal 17 | - stack build --ghc-options=-Werror --no-terminal 18 | - stack test --ghc-options=-Werror --no-terminal 19 | 20 | # detecting dead code in this project 21 | - stack exec ghc-pkg expose ghc 22 | - "! (stack exec -- dead-code-detection --root Main -isrc -idriver -i .stack-work/dist/x86_64-linux/Cabal-1.22.4.0/build/autogen/ | grep -v Paths_dead_code_detection)" 23 | - "! (stack exec -- dead-code-detection --root Main -isrc -itest -i .stack-work/dist/x86_64-linux/Cabal-1.22.4.0/build/autogen/ | grep -v Paths_dead_code_detection)" 24 | 25 | cache: 26 | directories: 27 | - $HOME/.stack 28 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: dead-code-detection 2 | version: '0.8.1' 3 | synopsis: detect dead code in haskell projects 4 | description: detect dead code in haskell projects 5 | category: Development 6 | maintainer: Sönke Hahn 7 | license: BSD3 8 | github: soenkehahn/dead-code-detection 9 | source-dirs: src 10 | extra-source-files: 11 | - README.md 12 | ghc-options: 13 | - -Wall 14 | - -fno-warn-name-shadowing 15 | - -fwarn-incomplete-record-updates 16 | - -fwarn-incomplete-uni-patterns 17 | dependencies: 18 | - base ==4.* 19 | - silently 20 | - getopt-generics ==0.12.* || ==0.13.* 21 | - ghc 22 | - Glob 23 | - string-conversions 24 | - graph-wrapper 25 | - containers 26 | - uniplate 27 | - ghc-paths 28 | - gitrev 29 | - directory 30 | executables: 31 | dead-code-detection: 32 | main: Main.hs 33 | source-dirs: 34 | - driver 35 | tests: 36 | spec: 37 | main: Main.hs 38 | source-dirs: 39 | - test 40 | dependencies: 41 | - hspec 42 | - mockery 43 | - interpolate 44 | - filepath 45 | -------------------------------------------------------------------------------- /src/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Utils where 5 | 6 | import Data.Char 7 | import Data.Set 8 | 9 | nubOrd :: forall a . Ord a => [a] -> [a] 10 | nubOrd = inner empty 11 | where 12 | inner :: Set a -> [a] -> [a] 13 | inner acc (a : r) 14 | | a `member` acc = inner acc r 15 | | otherwise = a : inner (insert a acc) r 16 | inner _ [] = [] 17 | 18 | errorNyi :: String -> a 19 | errorNyi message = error $ stripSpaces $ unlines $ 20 | "Encountered a language construct that is" : 21 | "not yet implemented. Please consider opening a bug report about" : 22 | "this here: https://github.com/soenkehahn/dead-code-detection/issues" : 23 | "" : 24 | "Here's some debugging output that will probably help to solve this problem:" : 25 | message : 26 | [] 27 | 28 | stripSpaces :: String -> String 29 | stripSpaces = 30 | reverse . dropWhile isSpace . 31 | reverse . dropWhile isSpace 32 | 33 | mapLeft :: (a -> b) -> Either a c -> Either b c 34 | mapLeft f = \ case 35 | Left a -> Left $ f a 36 | Right x -> Right x 37 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, Sönke Hahn 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Sönke Hahn nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /test/Helper.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Helper where 4 | 5 | import Control.Exception 6 | import Control.Monad 7 | import Data.String.Interpolate.Util 8 | import GHC 9 | import Name 10 | import Outputable 11 | import System.Exit 12 | import System.FilePath 13 | import Test.Mockery.Directory 14 | 15 | import Ast 16 | import Graph 17 | 18 | withFoo :: String -> IO () -> IO () 19 | withFoo code = 20 | withModules [("Foo", unindent code)] 21 | 22 | withFooHeader :: String -> IO () -> IO () 23 | withFooHeader code = 24 | withFoo ("module Foo where\n" ++ unindent code) 25 | 26 | withModules :: [(String, String)] -> IO () -> IO () 27 | withModules modules action = do 28 | inTempDirectory $ do 29 | forM_ modules $ \ (name, code) -> do 30 | writeFile (name <.> "hs") (unindent code) 31 | action 32 | 33 | parseStringGraph :: [FilePath] -> IO (Graph String) 34 | parseStringGraph files = do 35 | result <- parse files 36 | case result of 37 | Left e -> die e 38 | Right r -> return $ fmap showName $ usedTopLevelNames r 39 | 40 | showName :: Name -> String 41 | showName name = mod ++ "." ++ id 42 | where 43 | mod = maybe "" (showSDocUnsafe . ppr) $ 44 | nameModule_maybe name 45 | id = showSDocUnsafe $ ppr name 46 | 47 | swallowExceptions :: IO () -> IO () 48 | swallowExceptions = handle (\ (_ :: SomeException) -> return ()) 49 | 50 | usageGraph :: Graph a -> [(a, [a])] 51 | usageGraph = _usageGraph 52 | 53 | eitherToError :: IO (Either String a) -> IO a 54 | eitherToError action = do 55 | either die return =<< action 56 | -------------------------------------------------------------------------------- /src/Graph.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE TupleSections #-} 3 | {-# LANGUAGE ViewPatterns #-} 4 | 5 | module Graph where 6 | 7 | import Control.Arrow 8 | import qualified Data.Graph.Wrapper as Wrapper 9 | import Data.Graph.Wrapper hiding (Graph, toList) 10 | import Data.List 11 | import qualified Data.Set as Set 12 | import Name 13 | 14 | import Utils 15 | 16 | data Graph a = Graph { 17 | _usageGraph :: [(a, [a])], 18 | classMethodsUsedNames :: [a] 19 | } deriving (Show, Functor) 20 | 21 | instance (Ord a) => Eq (Graph a) where 22 | Graph a aUseds == Graph b bUseds = 23 | a === b && 24 | aUseds === bUseds 25 | where 26 | x === y = sort (nubOrd x) == sort (nubOrd y) 27 | 28 | toWrapperGraph :: Ord a => Graph a -> Wrapper.Graph a () 29 | toWrapperGraph (Graph g _) = fromListLenient $ 30 | map (\ (v, outs) -> (v, (), outs)) g 31 | 32 | deadNames :: Graph Name -> [Name] -> [Name] 33 | deadNames g@(toWrapperGraph -> graph) roots = 34 | sortTopologically graph $ 35 | case map (deadNamesSingle graph) (roots ++ classMethodsUsedNames g) of 36 | (x : xs) -> foldl Set.intersection x xs 37 | [] -> Set.fromList $ vertices graph 38 | 39 | deadNamesSingle :: Wrapper.Graph Name () -> Name -> Set.Set Name 40 | deadNamesSingle graph root = 41 | let reachable = Set.fromList $ reachableVertices graph root 42 | allTopLevelDecls = Set.fromList $ vertices graph 43 | in allTopLevelDecls Set.\\ reachable 44 | 45 | sortTopologically :: Ord a => Wrapper.Graph a () -> Set.Set a -> [a] 46 | sortTopologically graph set = 47 | filter (`Set.member` set) (topologicalSort graph) 48 | 49 | addUsedNames :: Ord a => [a] -> [(a, [a])] -> [(a, [a])] 50 | addUsedNames used = map (second (nubOrd . (++ used))) 51 | 52 | withoutUsedNames :: [a] -> [(a, [a])] 53 | withoutUsedNames = map (, []) 54 | -------------------------------------------------------------------------------- /test/GraphSpec.hs: -------------------------------------------------------------------------------- 1 | {-# language QuasiQuotes #-} 2 | 3 | module GraphSpec where 4 | 5 | import Data.String.Interpolate 6 | import GHC 7 | import Test.Hspec 8 | 9 | import Graph 10 | import Helper 11 | import Ast 12 | 13 | getDeadNames :: IO [String] 14 | getDeadNames = do 15 | ast <- eitherToError $ parse ["Foo.hs"] 16 | let graph = usedTopLevelNames ast 17 | roots <- eitherToError $ return $ 18 | findExports ast [mkModuleName "Foo"] 19 | return $ fmap showName $ deadNames graph roots 20 | 21 | spec :: Spec 22 | spec = do 23 | describe "deadNames" $ do 24 | it "detects unused top-level names" $ do 25 | withFoo [i| 26 | module Foo (foo) where 27 | foo = () 28 | bar = () 29 | |] $ do 30 | getDeadNames `shouldReturn` ["Foo.bar"] 31 | 32 | it "allows to specify multiple roots" $ do 33 | withFoo [i| 34 | module Foo (r1, r2) where 35 | r1 = foo 36 | r2 = bar 37 | foo = () 38 | bar = () 39 | baz = () 40 | |] $ do 41 | getDeadNames `shouldReturn` ["Foo.baz"] 42 | 43 | it "detects usage of names in instance methods" $ do 44 | withFoo [i| 45 | module Foo () where 46 | data A = A 47 | instance Show A where 48 | show A = foo 49 | foo = "foo" 50 | |] $ do 51 | getDeadNames `shouldReturn` [] 52 | 53 | it "returns dead names in topological order" $ do 54 | withFoo [i| 55 | module Foo () where 56 | b = c 57 | a = b 58 | c = () 59 | |] $ do 60 | getDeadNames `shouldReturn` (words "Foo.a Foo.b Foo.c") 61 | 62 | it "finds used names in default implementations of methods in class declarations" $ do 63 | withFoo [i| 64 | module Foo () where 65 | class A a where 66 | a :: a -> String 67 | a _ = foo 68 | foo = "foo" 69 | |] $ do 70 | getDeadNames `shouldReturn` [] 71 | -------------------------------------------------------------------------------- /dead-code-detection.cabal: -------------------------------------------------------------------------------- 1 | -- This file has been generated from package.yaml by hpack version 0.14.1. 2 | -- 3 | -- see: https://github.com/sol/hpack 4 | 5 | name: dead-code-detection 6 | version: 0.8.1 7 | synopsis: detect dead code in haskell projects 8 | description: detect dead code in haskell projects 9 | category: Development 10 | homepage: https://github.com/soenkehahn/dead-code-detection#readme 11 | bug-reports: https://github.com/soenkehahn/dead-code-detection/issues 12 | maintainer: Sönke Hahn 13 | license: BSD3 14 | license-file: LICENSE 15 | build-type: Simple 16 | cabal-version: >= 1.10 17 | 18 | extra-source-files: 19 | README.md 20 | 21 | source-repository head 22 | type: git 23 | location: https://github.com/soenkehahn/dead-code-detection 24 | 25 | executable dead-code-detection 26 | main-is: Main.hs 27 | hs-source-dirs: 28 | src 29 | , driver 30 | ghc-options: -Wall -fno-warn-name-shadowing -fwarn-incomplete-record-updates -fwarn-incomplete-uni-patterns 31 | build-depends: 32 | base ==4.* 33 | , silently 34 | , getopt-generics ==0.12.* || ==0.13.* 35 | , ghc 36 | , Glob 37 | , string-conversions 38 | , graph-wrapper 39 | , containers 40 | , uniplate 41 | , ghc-paths 42 | , gitrev 43 | , directory 44 | other-modules: 45 | Ast 46 | Ast.UsedNames 47 | Files 48 | GHC.Show 49 | Graph 50 | Run 51 | Utils 52 | default-language: Haskell2010 53 | 54 | test-suite spec 55 | type: exitcode-stdio-1.0 56 | main-is: Main.hs 57 | hs-source-dirs: 58 | src 59 | , test 60 | ghc-options: -Wall -fno-warn-name-shadowing -fwarn-incomplete-record-updates 61 | build-depends: 62 | base ==4.* 63 | , silently 64 | , getopt-generics ==0.12.* || ==0.13.* 65 | , ghc 66 | , Glob 67 | , string-conversions 68 | , graph-wrapper 69 | , containers 70 | , uniplate 71 | , ghc-paths 72 | , gitrev 73 | , directory 74 | , hspec 75 | , mockery 76 | , interpolate 77 | , filepath 78 | other-modules: 79 | Ast 80 | Ast.UsedNames 81 | Files 82 | GHC.Show 83 | Graph 84 | Run 85 | Utils 86 | Ast.UsedNamesSpec 87 | AstSpec 88 | FilesSpec 89 | GraphSpec 90 | Helper 91 | RunSpec 92 | Spec 93 | default-language: Haskell2010 94 | -------------------------------------------------------------------------------- /src/Run.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module Run where 5 | 6 | import Control.Exception 7 | import Control.Monad 8 | import Data.Char 9 | import Data.Version 10 | import Development.GitRev 11 | import FastString 12 | import GHC 13 | import OccName 14 | import System.Directory 15 | import System.Exit 16 | import WithCli 17 | 18 | import Ast 19 | import Files 20 | import GHC.Show 21 | import Graph 22 | import qualified Paths_dead_code_detection as Paths 23 | import Utils 24 | 25 | data Options 26 | = Options { 27 | sourceDirs :: [FilePath], 28 | ignore :: [FilePath], 29 | root :: [String], 30 | version :: Bool, 31 | includeUnderscoreNames :: Bool 32 | } 33 | deriving (Show, Eq, Generic) 34 | 35 | instance HasArguments Options 36 | 37 | run :: IO () 38 | run = do 39 | let mods = [AddShortOption "sourceDirs" 'i', 40 | AddShortOption "ignore" 'e'] 41 | withCliModified mods $ \ options -> do 42 | when (version options) $ do 43 | putStrLn versionOutput 44 | throwIO ExitSuccess 45 | when (null $ root options) $ 46 | die "missing option: --root=STRING" 47 | files <- findHaskellFiles (sourceDirs options) 48 | >>= filterNotIgnored (ignore options) 49 | deadNames <- deadNamesFromFiles 50 | files 51 | (map mkModuleName (root options)) 52 | (includeUnderscoreNames options) 53 | case deadNames of 54 | [] -> return () 55 | _ -> do 56 | forM_ deadNames putStrLn 57 | exitWith $ ExitFailure 1 58 | 59 | versionOutput :: String 60 | versionOutput = 61 | "version: " ++ full 62 | where 63 | isInGit = $(gitHash) /= "UNKNOWN" 64 | full = if isInGit 65 | then "version: " ++ showVersion Paths.version ++ "\n" ++ 66 | "rev: " ++ $(gitHash) ++ (if $(gitDirty) then " (dirty)" else "") ++ "\n" ++ 67 | "branch: " ++ $(gitBranch) 68 | else "version: " ++ showVersion Paths.version 69 | 70 | filterNotIgnored :: [FilePath] -> [FilePath] -> IO [FilePath] 71 | filterNotIgnored ignored files = do 72 | ignoredCanonicalized <- mapM safeCanonicalize ignored 73 | forFilterM files $ \ file -> do 74 | canonicalized <- safeCanonicalize file 75 | return $ not (canonicalized `elem` ignoredCanonicalized) 76 | 77 | safeCanonicalize :: FilePath -> IO FilePath 78 | safeCanonicalize file = do 79 | exists <- doesFileExist file 80 | when (not exists) $ do 81 | die ("file not found: " ++ file) 82 | canonicalizePath file 83 | 84 | forFilterM :: Monad m => [a] -> (a -> m Bool) -> m [a] 85 | forFilterM list pred = case list of 86 | (a : r) -> do 87 | cond <- pred a 88 | rest <- forFilterM r pred 89 | if cond 90 | then return (a : rest) 91 | else return rest 92 | [] -> return [] 93 | 94 | deadNamesFromFiles :: [FilePath] -> [ModuleName] -> Bool -> IO [String] 95 | deadNamesFromFiles files roots includeUnderscoreNames = do 96 | ast <- parse files 97 | case ast of 98 | Left err -> die $ ghcError err 99 | Right ast -> case findExports ast roots of 100 | Left err -> die err 101 | Right rootExports -> do 102 | let graph = usedTopLevelNames ast 103 | return $ fmap formatName $ 104 | removeConstructorNames $ 105 | filterUnderScoreNames includeUnderscoreNames $ 106 | deadNames graph rootExports 107 | where 108 | ghcError message = stripSpaces $ unlines $ 109 | "Some of the input files produce compile errors." : 110 | "ghc says:" : 111 | map (" " ++) (lines message) ++ 112 | [] 113 | 114 | filterUnderScoreNames :: Bool -> [Name] -> [Name] 115 | filterUnderScoreNames include = if include then id else 116 | filter (not . startsWith (== '_')) 117 | 118 | startsWith :: (Char -> Bool) -> Name -> Bool 119 | startsWith p name = 120 | case unpackFS $ occNameFS $ occName name of 121 | (a : _) -> p a 122 | [] -> False 123 | 124 | removeConstructorNames :: [Name] -> [Name] 125 | removeConstructorNames = filter (not . isConstructorName) 126 | 127 | isConstructorName :: Name -> Bool 128 | isConstructorName name = 129 | startsWith isUpper name || 130 | startsWith (== ':') name 131 | -------------------------------------------------------------------------------- /src/Ast/UsedNames.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE ViewPatterns #-} 4 | 5 | module Ast.UsedNames where 6 | 7 | import Bag 8 | import Data.Data 9 | import GHC 10 | import Outputable 11 | import Utils 12 | 13 | class UsedNames ast where 14 | -- | extracts all used names from ASTs 15 | usedNames :: ast -> [Name] 16 | 17 | instance UsedNames a => UsedNames [a] where 18 | usedNames = concatMap usedNames 19 | 20 | instance UsedNames a => UsedNames (Bag a) where 21 | usedNames = concatMap usedNames . bagToList 22 | 23 | instance UsedNames a => UsedNames (Located a) where 24 | usedNames = usedNames . unLoc 25 | 26 | instance UsedNames (HsBindLR Name Name) where 27 | usedNames = \ case 28 | FunBind _ _ matches _ _ _ -> usedNames matches 29 | PatBind lhs rhs _ _ _ -> 30 | usedNames lhs ++ usedNames rhs 31 | x -> errorNyiOutputable x 32 | 33 | instance UsedNames (MatchGroup Name (LHsExpr Name)) where 34 | usedNames = usedNames . mg_alts 35 | 36 | instance UsedNames (Match Name (LHsExpr Name)) where 37 | usedNames = \ case 38 | Match _ pats _ rhs -> 39 | usedNames pats ++ usedNames rhs 40 | 41 | instance UsedNames (Pat Name) where 42 | usedNames = \ case 43 | ParPat e -> usedNames e 44 | ViewPat function expr _ -> 45 | usedNames function ++ usedNames expr 46 | ConPatIn a b -> unLoc a : usedNames b 47 | VarPat{} -> [] 48 | TuplePat exprs _ _ -> usedNames exprs 49 | WildPat _ -> [] 50 | AsPat _as pat -> usedNames pat 51 | ListPat pats _ _ -> usedNames pats 52 | SigPatIn pat _sig -> usedNames pat 53 | BangPat pat -> usedNames pat 54 | NPat{} -> [] 55 | LitPat{} -> [] 56 | LazyPat pat -> usedNames pat 57 | x -> errorNyiOutputable x 58 | 59 | instance UsedNames (HsConDetails (LPat Name) (HsRecFields Name (LPat Name))) where 60 | usedNames = \ case 61 | PrefixCon args -> usedNames args 62 | InfixCon a b -> 63 | usedNames a ++ usedNames b 64 | RecCon x -> usedNames x 65 | 66 | instance UsedNames (GRHSs Name (LHsExpr Name)) where 67 | usedNames (GRHSs rhss whereClause) = 68 | usedNames rhss ++ usedNames whereClause 69 | 70 | instance UsedNames (GRHS Name (LHsExpr Name)) where 71 | usedNames (GRHS guards body) = 72 | usedNames guards ++ usedNames body 73 | 74 | instance UsedNames (StmtLR Name Name (LHsExpr Name)) where 75 | usedNames = \ case 76 | BindStmt pat expr _ _ -> 77 | usedNames pat ++ usedNames expr 78 | LastStmt expr _ -> usedNames expr 79 | BodyStmt expr _ _ _ -> usedNames expr 80 | LetStmt x -> usedNames x 81 | x -> errorNyiOutputable x 82 | 83 | instance UsedNames (HsExpr Name) where 84 | usedNames = \ case 85 | HsVar n -> [n] 86 | HsLet binds expr -> 87 | usedNames binds ++ usedNames expr 88 | HsLit _ -> [] 89 | HsApp f x -> usedNames f ++ usedNames x 90 | OpApp a op _ b -> 91 | usedNames a ++ usedNames op ++ usedNames b 92 | HsPar x -> usedNames x 93 | ExplicitList _ Nothing list -> usedNames list 94 | ExplicitTuple exprs _ -> usedNames exprs 95 | HsOverLit{} -> [] 96 | HsLam x -> usedNames x 97 | HsDo context stmts _ -> 98 | usedNames context ++ usedNames stmts 99 | SectionL a b -> 100 | usedNames a ++ usedNames b 101 | SectionR a b -> 102 | usedNames a ++ usedNames b 103 | HsCase on matchGroup -> 104 | usedNames on ++ usedNames matchGroup 105 | RecordUpd expr recordBinds [] _ _ -> 106 | usedNames expr ++ usedNames recordBinds 107 | HsLamCase _ matchGroup -> usedNames matchGroup 108 | HsIf _ c t e -> 109 | usedNames c ++ usedNames t ++ usedNames e 110 | ExprWithTySig expr _ _ -> usedNames expr 111 | NegApp expr _ -> usedNames expr 112 | ArithSeq _ _ info -> usedNames info 113 | RecordCon constructor _ binds -> 114 | unLoc constructor : usedNames binds 115 | x -> errorNyiOutputable x 116 | 117 | instance UsedNames (ArithSeqInfo Name) where 118 | usedNames = \ case 119 | From f -> usedNames f 120 | FromThen f t -> usedNames f ++ usedNames t 121 | FromTo f t -> usedNames f ++ usedNames t 122 | FromThenTo f t to 123 | -> usedNames f ++ usedNames t ++ usedNames to 124 | 125 | instance UsedNames (HsStmtContext Name) where 126 | usedNames = \ case 127 | ListComp -> [] 128 | MonadComp -> [] 129 | PArrComp -> [] 130 | DoExpr -> [] 131 | MDoExpr -> [] 132 | ArrowExpr -> [] 133 | GhciStmtCtxt -> [] 134 | x -> errorNyiData x 135 | 136 | instance UsedNames (HsLocalBinds Name) where 137 | usedNames = \ case 138 | EmptyLocalBinds -> [] 139 | HsValBinds binds -> usedNames binds 140 | x -> errorNyiOutputable x 141 | 142 | instance UsedNames (HsValBindsLR Name Name) where 143 | usedNames = \ case 144 | ValBindsOut (map snd -> binds) _sig -> 145 | usedNames binds 146 | x -> errorNyiOutputable x 147 | 148 | instance UsedNames (HsTupArg Name) where 149 | usedNames = \ case 150 | Present x -> usedNames x 151 | Missing _ -> [] 152 | 153 | instance UsedNames arg => UsedNames (HsRecFields Name arg) where 154 | usedNames = \ case 155 | HsRecFields fields _ -> usedNames fields 156 | 157 | instance UsedNames arg => UsedNames (HsRecField Name arg) where 158 | usedNames (HsRecField assigned expr _) = 159 | unLoc assigned : usedNames expr 160 | 161 | errorNyiData :: (Data a) => a -> b 162 | errorNyiData x = errorNyi $ ("errorNyiData: " ++ ) $ unlines $ 163 | dataTypeName (dataTypeOf x) : 164 | show (toConstr x) : 165 | [] 166 | 167 | errorNyiOutputable :: (Outputable a, Data a) => a -> b 168 | errorNyiOutputable x = errorNyi $ ("errorNyiOutputable: " ++) $ unlines $ 169 | dataTypeName (dataTypeOf x) : 170 | show (toConstr x) : 171 | showSDocUnsafe (ppr x) : 172 | [] 173 | -------------------------------------------------------------------------------- /test/RunSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module RunSpec where 5 | 6 | import Control.Exception 7 | import Data.String.Interpolate 8 | import GHC 9 | import System.Environment 10 | import System.Exit 11 | import System.IO 12 | import System.IO.Silently 13 | import Test.Hspec 14 | 15 | import Helper 16 | import Run 17 | 18 | spec :: Spec 19 | spec = do 20 | describe "run" $ around_ (hSilence [stdout, stderr]) $ do 21 | context "when given a module containing dead code" $ do 22 | let main = ("Main", [i| 23 | module Main (main) where 24 | main = used 25 | used = return () 26 | unused = () 27 | |]) 28 | run' = withArgs (words "-i. --root Main") run 29 | it "works" $ do 30 | withModules [main] $ do 31 | output <- capture_ $ swallowExceptions run' 32 | output `shouldBe` "./Main.hs:4:1: unused\n" 33 | 34 | it "exits with a non-zero exit-code" $ do 35 | withModules [main] $ do 36 | run' `shouldDie` "" 37 | 38 | it "allows to set multiple roots" $ do 39 | let a = ("A", [i| 40 | module A (a) where 41 | a = () 42 | |]) 43 | b = ("B", [i| 44 | module B (b) where 45 | b = () 46 | |]) 47 | withModules [a, b] $ do 48 | output <- hCapture_ [stdout, stderr] $ swallowExceptions $ 49 | withArgs (words "-i. --root A --root B") run 50 | output `shouldBe` "" 51 | 52 | it "complains when it's invoked with no arguments" $ do 53 | withArgs [] run `shouldThrow` (== ExitFailure 1) 54 | 55 | it "has a version option" $ do 56 | output <- capture_ $ 57 | handle (\ ExitSuccess -> return ()) $ 58 | withArgs ["--version"] run 59 | output `shouldContain` "version: " 60 | 61 | context "--ignore" $ do 62 | 63 | it "ignores files if told to do so" $ do 64 | let main = ("Main", [i| 65 | module Main where 66 | main = return () 67 | |]) 68 | b = ("B", [i| 69 | This is some arbitrary text that is not Haskell. 70 | |]) 71 | run' = withArgs (words "-i. -e./B.hs --root Main") run 72 | withModules [main, b] $ run' `shouldReturn` () 73 | 74 | it "errors out on missing ignored files" $ do 75 | let main = ("Main", [i| 76 | module Main where 77 | main = return () 78 | |]) 79 | run' = withArgs (words "-i. -e./B.hs --root Main") run 80 | withModules [main] $ run' `shouldDie` "file not found: ./B.hs\n" 81 | 82 | it "ignores files if referenced differently" $ do 83 | let main = ("Main", [i| 84 | module Main where 85 | main = return () 86 | |]) 87 | b = ("B", [i| 88 | This is some arbitrary text that is not Haskell. 89 | |]) 90 | run' = withArgs (words "-i. -e B.hs --root Main") run 91 | withModules [main, b] $ run' `shouldReturn` () 92 | 93 | describe "deadNamesFromFiles" $ do 94 | it "should clearly mark ghc's output as such" $ do 95 | let a = ("A", [i| 96 | module A where 97 | import B 98 | |]) 99 | withModules [a] $ do 100 | output <- hCapture_ [stderr] $ 101 | deadNamesFromFiles ["A.hs"] [mkModuleName "A"] False 102 | `shouldThrow` (== ExitFailure 1) 103 | output `shouldContain` "ghc says:" 104 | 105 | it "can be run on multiple modules" $ do 106 | let a = ("A", [i| 107 | module A where 108 | foo = () 109 | |]) 110 | b = ("B", [i| 111 | module B where 112 | bar = () 113 | |]) 114 | withModules [a, b] $ do 115 | deadNamesFromFiles ["A.hs", "B.hs"] [mkModuleName "A"] False 116 | `shouldReturn` ["B.hs:2:1: bar"] 117 | 118 | context "names starting with an underscore" $ do 119 | it "excludes them by default" $ do 120 | let a = ("A", [i| 121 | module A (foo) where 122 | foo = () 123 | _bar = () 124 | |]) 125 | withModules [a] $ do 126 | dead <- deadNamesFromFiles ["A.hs"] [mkModuleName "A"] False 127 | dead `shouldMatchList` [] 128 | 129 | it "includes them if asked to" $ do 130 | let a = ("A", [i| 131 | module A (foo) where 132 | foo = () 133 | _bar = () 134 | |]) 135 | withModules [a] $ do 136 | dead <- deadNamesFromFiles ["A.hs"] [mkModuleName "A"] True 137 | dead `shouldMatchList` ["A.hs:3:1: _bar"] 138 | 139 | it "excludes constructor names" $ do 140 | let a = ("A", [i| 141 | module A () where 142 | data A = A 143 | |]) 144 | withModules [a] $ do 145 | dead <- deadNamesFromFiles ["A.hs"] [mkModuleName "A"] True 146 | dead `shouldMatchList` [] 147 | 148 | it "only considers exported top-level declarations as roots" $ do 149 | let a = ("A", [i| 150 | module A (foo) where 151 | import B 152 | foo = () 153 | bar = B.baz 154 | |]) 155 | b = ("B", [i| 156 | module B where 157 | baz = () 158 | |]) 159 | withModules [a, b] $ do 160 | dead <- deadNamesFromFiles ["A.hs", "B.hs"] [mkModuleName "A"] False 161 | dead `shouldMatchList` ["A.hs:4:1: bar", "B.hs:2:1: baz"] 162 | 163 | shouldDie :: IO a -> String -> IO () 164 | shouldDie action err = do 165 | (output, exception) <- hCapture [stderr] $ catch 166 | (action >> return Nothing) 167 | (\ (e :: ExitCode) -> return $ Just e) 168 | case exception of 169 | Nothing -> throwIO $ ErrorCall "shouldDie: didn't receive ExitCode exception" 170 | Just ExitSuccess -> throwIO $ ErrorCall "shouldDie: received ExitSuccess exception" 171 | Just (ExitFailure _) -> 172 | output `shouldBe` err 173 | -------------------------------------------------------------------------------- /test/AstSpec.hs: -------------------------------------------------------------------------------- 1 | {-# language QuasiQuotes #-} 2 | 3 | module AstSpec where 4 | 5 | import Control.Monad 6 | import Data.String.Interpolate 7 | import GHC 8 | import Outputable 9 | import System.Directory 10 | import System.IO 11 | import System.IO.Silently 12 | import Test.Hspec 13 | 14 | import Ast 15 | import Graph 16 | import Helper 17 | 18 | showAst :: Ast -> String 19 | showAst = showSDocUnsafe . ppr 20 | 21 | spec :: Spec 22 | spec = do 23 | describe "parse" $ do 24 | it "parses a simple module" $ do 25 | withFooHeader "foo = 3 -- bar" $ do 26 | ast <- parse ["Foo.hs"] 27 | fmap showAst ast `shouldBe` Right "[Module Foo Nothing [foo = 3]]" 28 | 29 | it "handles an invalid module gracefully" $ do 30 | withFooHeader "foo = bar" $ do 31 | result <- parse ["Foo.hs"] 32 | void result `shouldBe` Left "\nFoo.hs:2:7: Not in scope: ‘bar’\n" 33 | 34 | context "preprocessor errors" $ do 35 | it "gives Lefts, not Exceptions" $ do 36 | withFoo "{-# LANGUAGE CPP #-}\n#invalid" $ do 37 | Left err <- parse ["Foo.hs"] 38 | err `shouldContain` "lexical error" 39 | 40 | it "includes source locations" $ do 41 | withFoo "{-# LANGUAGE CPP #-}\n#invalid" $ do 42 | Left err <- parse ["Foo.hs"] 43 | err `shouldContain` "Foo.hs:2:2:" 44 | 45 | it "handles missing modules gracefully" $ do 46 | withFooHeader "import Bar" $ do 47 | Left message <- parse ["Foo.hs"] 48 | message `shouldContain` "Could not find module ‘Bar’" 49 | 50 | it "doesn't output error messages" $ do 51 | withFoo "foo = bar" $ do 52 | output <- hCapture_ [stdout, stderr] $ parse ["Foo.hs"] 53 | output `shouldBe` "" 54 | 55 | it "doesn't follow imports" $ do 56 | let a = ("A", [i| 57 | module A where 58 | foo = () 59 | |]) 60 | b = ("B", [i| 61 | module B where 62 | import A 63 | bar = foo 64 | |]) 65 | withModules [a, b] $ do 66 | parseStringGraph ["B.hs"] `shouldReturn` 67 | Graph [("B.bar", ["A.foo"])] [] 68 | 69 | it "can be used to parse multiple files" $ do 70 | let a = ("A", [i| 71 | module A where 72 | foo = foo 73 | |]) 74 | b = ("B", [i| 75 | module B where 76 | bar = bar 77 | |]) 78 | withModules [a, b] $ do 79 | parseStringGraph ["A.hs", "B.hs"] `shouldReturn` 80 | Graph [("A.foo", ["A.foo"]), ("B.bar", ["B.bar"])] [] 81 | 82 | it "does not create any files" $ do 83 | withFooHeader [i| 84 | foo = () 85 | bar = () 86 | |] $ do 87 | _ <- parse ["Foo.hs"] 88 | files <- getDirectoryContents "." 89 | files `shouldMatchList` (words ". .. Foo.hs") 90 | 91 | describe "findExports" $ do 92 | let find moduleFiles moduleName = do 93 | ast <- either error id <$> parse moduleFiles 94 | let exports = either error id $ 95 | findExports ast moduleName 96 | return $ map showName exports 97 | it "finds the names exported by a given module" $ do 98 | withFooHeader [i| 99 | foo = () 100 | bar = () 101 | |] $ do 102 | exports <- find ["Foo.hs"] [mkModuleName "Foo"] 103 | exports `shouldMatchList` ["Foo.foo", "Foo.bar"] 104 | 105 | it "does not include local variables" $ do 106 | withFooHeader [i| 107 | foo = let bar = () in bar 108 | |] $ do 109 | exports <- find ["Foo.hs"] [mkModuleName "Foo"] 110 | exports `shouldMatchList` ["Foo.foo"] 111 | 112 | context "when given a module with an export list" $ do 113 | it "returns the explicit exports" $ do 114 | let a = ("A", [i| 115 | module A (foo) where 116 | foo = () 117 | bar = () 118 | |]) 119 | withModules [a] $ do 120 | exports <- find ["A.hs"] [mkModuleName "A"] 121 | exports `shouldBe` ["A.foo"] 122 | 123 | it "includes identifiers exported by module" $ do 124 | let a = ("A", [i| 125 | module A (module B) where 126 | import B 127 | |]) 128 | b = ("B", [i| 129 | module B where 130 | b = () 131 | |]) 132 | withModules [a, b] $ do 133 | exports <- find ["A.hs", "B.hs"] [mkModuleName "A"] 134 | exports `shouldBe` ["B.b"] 135 | 136 | describe "usedTopLevelNames" $ do 137 | it "returns the graph of identifier usage" $ do 138 | withFooHeader [i| 139 | foo = bar 140 | bar = () 141 | |] $ do 142 | g <- usageGraph <$> parseStringGraph ["Foo.hs"] 143 | g `shouldMatchList` [("Foo.foo", ["Foo.bar"]), ("Foo.bar", ["GHC.Tuple.()"])] 144 | 145 | it "detects usage in ViewPatterns" $ do 146 | withFoo [i| 147 | {-# LANGUAGE ViewPatterns #-} 148 | module Foo where 149 | x y = () 150 | bar (x -> y) = () 151 | |] $ do 152 | g <- usageGraph <$> parseStringGraph ["Foo.hs"] 153 | let Just used = lookup "Foo.bar" g 154 | used `shouldContain` ["Foo.x"] 155 | 156 | it "doesn't return local variables" $ do 157 | withFooHeader [i| 158 | foo = let x = x in x 159 | |] $ do 160 | parseStringGraph ["Foo.hs"] `shouldReturn` 161 | Graph [("Foo.foo", [])] [] 162 | 163 | context "data type declarations" $ do 164 | it "does not include constructor names" $ do 165 | withFooHeader [i| 166 | data A = A 167 | |] $ do 168 | parseStringGraph ["Foo.hs"] `shouldReturn` 169 | Graph [("Foo.A", [])] [] 170 | 171 | it "ignores selectors" $ do 172 | withFooHeader [i| 173 | data A = A { foo :: () } 174 | |] $ do 175 | boundNames <- map fst <$> usageGraph <$> parseStringGraph ["Foo.hs"] 176 | boundNames `shouldBe` ["Foo.A", "Foo.foo"] 177 | 178 | it "doesn't return bound names for instance methods" $ do 179 | withFooHeader [i| 180 | instance Show (a -> b) where 181 | show _ = "" 182 | |] $ do 183 | (usageGraph <$> parseStringGraph ["Foo.hs"]) `shouldReturn` [] 184 | 185 | it "ignores standalone deriving instances" $ do 186 | withFoo [i| 187 | {-# LANGUAGE StandaloneDeriving #-} 188 | module Foo where 189 | data Foo = Foo 190 | deriving instance Show Foo 191 | |] $ do 192 | (usageGraph <$> parseStringGraph ["Foo.hs"]) `shouldReturn` [("Foo.Foo", [])] 193 | 194 | it "ignores annotations" $ do 195 | withFooHeader [i| 196 | {-# ANN foo "annotation" #-} 197 | foo = 42 198 | |] $ do 199 | (usageGraph <$> parseStringGraph ["Foo.hs"]) `shouldReturn` [("Foo.foo",[])] 200 | 201 | context "PatBind" $ do 202 | it "can parse pattern binding" $ do 203 | withFooHeader [i| 204 | (Just foo) = let x = x in x 205 | |] $ do 206 | parseStringGraph ["Foo.hs"] `shouldReturn` 207 | Graph [("Foo.foo", ["GHC.Base.Just"])] [] 208 | 209 | it "can parse tuple pattern binding" $ do 210 | withFooHeader [i| 211 | (a, b) = let x = x in x 212 | |] $ do 213 | parseStringGraph ["Foo.hs"] `shouldReturn` 214 | Graph [("Foo.a", []), ("Foo.b", [])] [] 215 | 216 | it "can parse lazy patterns" $ do 217 | withFooHeader [i| 218 | ~(a, b) = let x = x in x 219 | |] $ do 220 | parseStringGraph ["Foo.hs"] `shouldReturn` 221 | Graph [("Foo.a", []), ("Foo.b", [])] [] 222 | 223 | context "local variables" $ do 224 | it "recognizes recursive definitions" $ do 225 | withFooHeader [i| 226 | foo = foo 227 | bar = () 228 | |] $ do 229 | parseStringGraph ["Foo.hs"] `shouldReturn` 230 | Graph [("Foo.bar", ["GHC.Tuple.()"]), ("Foo.foo", ["Foo.foo"])] [] 231 | -------------------------------------------------------------------------------- /src/Ast.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE NamedFieldPuns #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TupleSections #-} 7 | {-# LANGUAGE TypeSynonymInstances #-} 8 | {-# LANGUAGE ViewPatterns #-} 9 | 10 | module Ast ( 11 | Ast, 12 | findExports, 13 | parse, 14 | usedTopLevelNames, 15 | ) where 16 | 17 | import Bag 18 | import Control.Arrow ((>>>), second) 19 | import Control.Monad 20 | import Data.Data 21 | import Data.Generics.Uniplate.Data 22 | import ErrUtils 23 | import Exception 24 | import qualified GHC 25 | import GHC hiding (Module, moduleName) 26 | import GHC.Paths (libdir) 27 | import HscTypes 28 | import Name 29 | import Outputable 30 | import System.IO 31 | import System.IO.Silently 32 | 33 | import Ast.UsedNames 34 | import Graph 35 | import Utils 36 | 37 | type Ast = [Module] 38 | 39 | data Module 40 | = Module { 41 | moduleName :: ModuleName, 42 | moduleExports :: Maybe [LIE Name], 43 | moduleDeclarations :: HsGroup Name 44 | } 45 | deriving (Data) 46 | 47 | instance Outputable Module where 48 | ppr m = 49 | text "Module" <+> 50 | ppr (moduleName m) <+> 51 | ppr (moduleExports m) <+> 52 | brackets (ppr (moduleDeclarations m)) 53 | 54 | toModule :: TypecheckedModule -> Module 55 | toModule m = case tm_renamed_source m of 56 | Just (hsGroup, _, exports, _) -> 57 | Module 58 | (GHC.moduleName $ ms_mod $ pm_mod_summary $ tm_parsed_module m) 59 | exports 60 | hsGroup 61 | Nothing -> error "tm_renamed_source should point to a renamed source after renaming" 62 | 63 | parse :: [FilePath] -> IO (Either String Ast) 64 | parse files = 65 | runGhcPureExceptions $ do 66 | dynFlags <- getSessionDynFlags 67 | void $ setSessionDynFlags $ dynFlags { 68 | hscTarget = HscNothing, 69 | ghcLink = NoLink 70 | } 71 | targets <- forM files $ \ file -> guessTarget file Nothing 72 | setTargets targets 73 | modSummaries <- depanal [] False 74 | r <- load LoadAllTargets 75 | case r of 76 | Failed -> return Nothing 77 | Succeeded -> do 78 | let isModuleFromFile m = case ml_hs_file $ ms_location m of 79 | Nothing -> error ("parse: module without file") 80 | Just file -> file `elem` files 81 | mods = filter isModuleFromFile modSummaries 82 | typecheckedModules <- forM mods $ \ mod -> 83 | (parseModule mod >>= typecheckModule) 84 | return $ Just $ map toModule typecheckedModules 85 | 86 | runGhcPureExceptions :: Ghc (Maybe a) -> IO (Either String a) 87 | runGhcPureExceptions action = 88 | fmap (mapLeft (unlines . map stripSpaces)) $ 89 | captureStderr $ 90 | runGhc (Just libdir) $ 91 | catchSourceError $ 92 | fmap (maybe (Left []) Right) $ 93 | action 94 | 95 | where 96 | captureStderr :: IO (Either [String] a) -> IO (Either [String] a) 97 | captureStderr action = do 98 | (errs, a) <- hCapture [stderr] action 99 | return $ either (\ outerErrs -> Left (outerErrs ++ lines errs)) Right a 100 | 101 | catchSourceError :: Ghc (Either [String] a) -> Ghc (Either [String] a) 102 | catchSourceError = ghandle $ \ (e :: SourceError) -> do 103 | dynFlags <- getSessionDynFlags 104 | return $ Left [formatSourceError dynFlags e] 105 | 106 | formatSourceError :: DynFlags -> SourceError -> String 107 | formatSourceError dynFlags sourceError = 108 | unlines $ 109 | map (showSDoc dynFlags) $ 110 | pprErrMsgBagWithLoc $ 111 | srcErrorMessages $ 112 | sourceError 113 | 114 | findExports :: Ast -> [ModuleName] -> Either String [Name] 115 | findExports ast names = concat <$> mapM inner names 116 | where 117 | inner name = 118 | case filter (\ m -> moduleName m == name) ast of 119 | [Module _ Nothing declarations] -> 120 | return $ map fst $ nameGraph declarations 121 | [Module _ (Just exports) _] -> 122 | concat <$> mapM (extractExportedNames ast . unLoc) exports 123 | [] -> Left ("cannot find module: " ++ moduleNameString name) 124 | _ -> Left ("found module multiple times: " ++ moduleNameString name) 125 | 126 | extractExportedNames :: Ast -> IE Name -> Either String [Name] 127 | extractExportedNames ast = \ case 128 | IEModuleContents (unLoc -> moduleName) -> 129 | findExports ast [moduleName] 130 | x -> return $ ieNames x 131 | 132 | -- * name usage graph 133 | 134 | usedTopLevelNames :: Ast -> Graph Name 135 | usedTopLevelNames ast = 136 | Graph 137 | (removeLocalNames (nameGraph ast)) 138 | (getClassMethodUsedNames ast) 139 | where 140 | isTopLevelName :: Name -> Bool 141 | isTopLevelName = maybe False (const True) . nameModule_maybe 142 | 143 | removeLocalNames :: [(Name, [Name])] -> [(Name, [Name])] 144 | removeLocalNames = 145 | filter (isTopLevelName . fst) >>> 146 | map (second (filter isTopLevelName)) 147 | 148 | -- | extracts the name usage graph from ASTs (only value level) 149 | class NameGraph ast where 150 | nameGraph :: ast -> [(Name, [Name])] 151 | 152 | instance NameGraph a => NameGraph [a] where 153 | nameGraph = concatMap nameGraph 154 | 155 | instance NameGraph a => NameGraph (Bag a) where 156 | nameGraph = concatMap nameGraph . bagToList 157 | 158 | instance NameGraph a => NameGraph (Located a) where 159 | nameGraph = nameGraph . unLoc 160 | 161 | instance NameGraph Module where 162 | nameGraph = nameGraph . moduleDeclarations 163 | 164 | instance NameGraph (HsGroup Name) where 165 | nameGraph = \ case 166 | HsGroup valBinds [] tyclds _instances _standaloneInstances [] [] foreign_decls [] _annotations [] [] [] -> 167 | nameGraph valBinds ++ 168 | nameGraph tyclds ++ 169 | nameGraph foreign_decls 170 | x -> errorNyiOutputable x 171 | 172 | instance NameGraph (ForeignDecl Name) where 173 | nameGraph = \ case 174 | ForeignImport name _ _ _ -> [(unLoc name, [])] 175 | x -> errorNyiOutputable x 176 | 177 | instance NameGraph (HsValBinds Name) where 178 | nameGraph = \ case 179 | ValBindsOut (map snd -> binds) _signatures -> nameGraph binds 180 | ValBindsIn _ _ -> error "ValBindsIn shouldn't exist after renaming" 181 | 182 | instance NameGraph (HsBindLR Name Name) where 183 | nameGraph bind = addUsedNames (usedNames bind) $ case bind of 184 | FunBind id _ _ _ _ _ -> withoutUsedNames [unLoc id] 185 | PatBind pat _ _ _ _ -> nameGraph pat 186 | x -> errorNyiOutputable x 187 | 188 | instance NameGraph (Pat Name) where 189 | nameGraph = \ case 190 | ParPat p -> nameGraph p 191 | ConPatIn _ p -> nameGraph p 192 | VarPat p -> withoutUsedNames [p] 193 | TuplePat pats _ _ -> nameGraph pats 194 | WildPat _ -> [] 195 | LazyPat p -> nameGraph p 196 | pat -> errorNyiOutputable pat 197 | 198 | instance NameGraph (TyClGroup Name) where 199 | nameGraph = \ case 200 | TyClGroup decls [] -> nameGraph decls 201 | x -> errorNyiOutputable x 202 | 203 | instance NameGraph (TyClDecl Name) where 204 | nameGraph = \ case 205 | DataDecl _typeCon _ def _ -> nameGraph def 206 | ClassDecl{} -> [] 207 | SynDecl{} -> [] 208 | x -> errorNyiOutputable x 209 | 210 | instance NameGraph (HsDataDefn Name) where 211 | nameGraph = \ case 212 | (HsDataDefn _ _ _ _ constructors _) -> nameGraph constructors 213 | 214 | instance NameGraph (ConDecl Name) where 215 | nameGraph = \ case 216 | ConDecl names _ _ _ details _ _ _ -> 217 | withoutUsedNames (map unLoc names) ++ 218 | nameGraph details 219 | 220 | instance NameGraph (HsConDetails (LBangType Name) (Located [LConDeclField Name])) where 221 | nameGraph = \ case 222 | RecCon rec -> nameGraph rec 223 | PrefixCon _ -> [] 224 | x -> errorNyiData x 225 | 226 | instance NameGraph (ConDeclField Name) where 227 | nameGraph = \ case 228 | ConDeclField names _typ _docs -> 229 | withoutUsedNames $ map unLoc names 230 | 231 | instance NameGraph (HsConPatDetails Name) where 232 | nameGraph = \ case 233 | PrefixCon args -> nameGraph args 234 | InfixCon a b -> nameGraph a ++ nameGraph b 235 | x -> errorNyiData x 236 | 237 | -- | extracts names used in instance declarations 238 | getClassMethodUsedNames :: Ast -> [Name] 239 | getClassMethodUsedNames ast = 240 | concatMap fromInstanceDecl (universeBi ast) ++ 241 | concatMap fromClassDecl (universeBi ast) 242 | where 243 | fromInstanceDecl :: InstDecl Name -> [Name] 244 | fromInstanceDecl decl = 245 | usedNames (universeBi decl :: [HsBindLR Name Name]) 246 | 247 | fromClassDecl :: TyClDecl Name -> [Name] 248 | fromClassDecl = \ case 249 | ClassDecl{tcdMeths} -> 250 | usedNames $ map unLoc $ bagToList tcdMeths 251 | _ -> [] 252 | --------------------------------------------------------------------------------