├── Setup.hs ├── AnotherModule.hs ├── Test.hs ├── type-search.cabal ├── LICENSE ├── Reachability.hs ├── Utils.hs ├── Usage.hs └── Main.hs /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /AnotherModule.hs: -------------------------------------------------------------------------------- 1 | module AnotherModule where 2 | 3 | data ThisIsAType = ThisIsAType 4 | -------------------------------------------------------------------------------- /Test.hs: -------------------------------------------------------------------------------- 1 | module Test where 2 | 3 | import AnotherModule 4 | 5 | data TestType = TestType Int 6 | data Ident a = Ident a 7 | 8 | mapIdent :: (a -> b) -> Ident a -> Ident b 9 | mapIdent f (Ident a) = Ident (f a) 10 | 11 | hello :: TestType -> TestType 12 | hello (TestType x) = TestType (x+1) 13 | 14 | aValue :: TestType 15 | aValue = TestType 5 16 | 17 | anotherValue = ThisIsAType 18 | -------------------------------------------------------------------------------- /type-search.cabal: -------------------------------------------------------------------------------- 1 | name: type-search 2 | version: 0.1.0.0 3 | synopsis: Search 4 | -- description: 5 | homepage: http://github.com/bgamari/type-search 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Ben Gamari 9 | maintainer: ben@smart-cactus.org 10 | copyright: (c) 2015 Ben gamari 11 | category: Development 12 | build-type: Simple 13 | cabal-version: >=1.10 14 | 15 | executable type-search 16 | main-is: Main.hs 17 | -- other-modules: 18 | -- other-extensions: 19 | build-depends: base >=4.7 && <4.9, 20 | ghc-paths >=0.1 && <0.2, 21 | ghc >=7.8, 22 | transformers, 23 | syb, 24 | optparse-applicative, 25 | Cabal, 26 | cabal-ghc-dynflags 27 | default-language: Haskell2010 28 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Ben Gamari 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 Ben Gamari 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 | -------------------------------------------------------------------------------- /Reachability.hs: -------------------------------------------------------------------------------- 1 | module Reachability (unreachableBinders) where 2 | 3 | import Data.Maybe (mapMaybe) 4 | import Data.Foldable 5 | 6 | import qualified GHC 7 | import GHC (GenLocated(L)) 8 | import qualified Digraph 9 | import VarEnv 10 | import VarSet 11 | 12 | import Utils 13 | 14 | usageGraph :: [GHC.TypecheckedSource] -> Digraph.Graph (Digraph.Node GHC.Id ()) 15 | usageGraph = Digraph.graphFromEdgedVertices . foldMap (foldMap doBind) 16 | where 17 | doBind :: GHC.LHsBind GHC.Id -> [Digraph.Node GHC.Id ()] 18 | doBind bind@(L _ (GHC.FunBind { GHC.fun_id=L _ ident 19 | , GHC.fun_matches=matches 20 | })) = 21 | [((), ident, usedBinders)] 22 | where 23 | usedBinders = everythingM binderList matches 24 | binderList :: GHC.HsExpr GHC.Id -> [GHC.Id] 25 | binderList (GHC.HsVar x) = [x] 26 | binderList _ = [] 27 | doBind (L _ (GHC.AbsBinds { GHC.abs_binds = binds })) = 28 | foldMap doBind binds 29 | doBind _ = mempty 30 | 31 | unreachableBinders :: String -- ^ root module 32 | -> [GHC.TypecheckedModule] -> GHC.Ghc () 33 | unreachableBinders root tcms = do 34 | rootBinders <- return [] -- TODO 35 | let graph = usageGraph $ toList $ fmap (GHC.tm_typechecked_source) tcms 36 | getId :: Digraph.Node GHC.Id () -> GHC.Id 37 | getId (_,ident,_) = ident 38 | reachable = foldMap (foldMap (unitVarSet . getId) . Digraph.reachableG graph) rootBinders 39 | all = mkVarSet $ map getId $ Digraph.verticesG graph 40 | unreachable = all `minusVarSet` reachable 41 | binders = definedBinders $ toList $ fmap (GHC.tm_typechecked_source) tcms 42 | printBindings $ mapMaybe (binders `lookupVarEnv`) $ varSetElems unreachable 43 | -------------------------------------------------------------------------------- /Utils.hs: -------------------------------------------------------------------------------- 1 | module Utils where 2 | 3 | import Data.Generics 4 | import Control.Monad.IO.Class 5 | 6 | import DynFlags 7 | import qualified GHC 8 | import GHC (GenLocated(L)) 9 | import TypeRep (Type(..)) 10 | import Outputable hiding ((<>)) 11 | import VarEnv 12 | import Bag 13 | 14 | printBindings :: [GHC.LHsBind GHC.Id] -> GHC.Ghc () 15 | printBindings binds = do 16 | dflags <- getDynFlags 17 | let printSDoc = liftIO . putStrLn . showSDoc dflags 18 | printSDoc $ vcat $ map pprLocated binds 19 | 20 | pprLocated :: (Outputable l, Outputable e) => GHC.GenLocated l e -> SDoc 21 | pprLocated (L l e) = braces (ppr l) $$ nest 4 (ppr e) 22 | 23 | -- | Thows error if not in scope 24 | lookupType :: String -> GHC.Ghc GHC.Type 25 | lookupType tyName = fst <$> GHC.typeKind False tyName 26 | 27 | -- | Lookup a type constructor 28 | lookupTyCon :: String -> GHC.Ghc GHC.TyCon 29 | lookupTyCon tyConName = getTyCon <$> lookupType tyConName 30 | where 31 | getTyCon (TyConApp tyCon _) = tyCon 32 | getTyCon _ = 33 | error "lookupTyCon: Expected type constructor application" 34 | 35 | -- | Recursive top-down query 36 | everythingM :: (Monoid r, Typeable b, Data a) => (b -> r) -> a -> r 37 | everythingM f = everything mappend (mempty `mkQ` f) 38 | 39 | -- | Construct a 'VarEnv' mapping top-level binders to their bindings. 40 | definedBinders :: [GHC.TypecheckedSource] -> VarEnv (GHC.LHsBind GHC.Id) 41 | definedBinders = foldMap (foldMap doBind) 42 | where 43 | doBind :: GHC.LHsBind GHC.Id -> VarEnv (GHC.LHsBind GHC.Id) 44 | doBind bind@(L _ (GHC.FunBind { GHC.fun_id=L _ id })) = 45 | unitVarEnv id bind 46 | doBind (L _ (GHC.AbsBinds { GHC.abs_binds = binds })) = 47 | foldMap doBind binds 48 | doBind _ = mempty 49 | 50 | instance Foldable Bag where 51 | foldr = foldrBag 52 | -------------------------------------------------------------------------------- /Usage.hs: -------------------------------------------------------------------------------- 1 | module Usage where 2 | 3 | import Data.Monoid 4 | import Data.Generics 5 | import Data.List (isSuffixOf) 6 | 7 | import qualified GHC 8 | import GHC (GenLocated(L)) 9 | import qualified TypeRep 10 | import TypeRep (Type(..)) 11 | import qualified Unify 12 | import qualified OccName 13 | import qualified Var 14 | import qualified Type 15 | import VarEnv 16 | import VarSet 17 | 18 | foldBindsOfType :: (Monoid r) 19 | => GHC.Type -> (GHC.LHsBind GHC.Id -> r) 20 | -> GHC.LHsBinds GHC.Id -> r 21 | foldBindsOfType ty f = everything mappend (mempty `mkQ` go) 22 | where 23 | go bind@(L _ (GHC.FunBind {GHC.fun_id=L _ fid})) 24 | | GHC.idType fid `Type.eqType` ty = f bind 25 | go _ = mempty 26 | 27 | foldBindsContainingType :: Monoid r 28 | => GHC.Type -> (GHC.LHsBind GHC.Id -> r) 29 | -> GHC.LHsBinds GHC.Id -> r 30 | foldBindsContainingType ty f = everything mappend (mempty `mkQ` go) 31 | where 32 | go bind@(L _ (GHC.FunBind {GHC.fun_id=L _ fid})) 33 | | getAny $ everything mappend (mempty `mkQ` containsType) (GHC.idType fid) = f bind 34 | where 35 | -- a type variable will unify with anything 36 | --containsType (TyVarTy _) = mempty 37 | 38 | -- We first check whether the types match, allowing all type variables to vary. 39 | -- This, however, is too lenient: the matcher is free to introduce equalities 40 | -- between our template variables. So, if this matches we then take the 41 | -- resulting substitution 42 | containsType ty' 43 | | Just subst <- Unify.tcMatchTy tyVars strippedTy ty' 44 | , bijectiveSubst subst 45 | = --trace (showSDoc unsafeGlobalDynFlags $ ppr (strippedTy, ty', Type.tyVarsOfType ty', subst, tyVars)) $ 46 | Any True 47 | | otherwise = --trace (showSDoc unsafeGlobalDynFlags $ ppr 48 | -- $ let subst = Unify.tcMatchTy tyVars strippedTy ty' 49 | -- in (subst, Type.tyVarsOfType ty')) 50 | mempty 51 | where 52 | bijectiveSubst :: Type.TvSubst -> Bool 53 | bijectiveSubst (Type.TvSubst _ subst) = iter emptyVarSet (varEnvElts subst) 54 | where 55 | iter :: VarSet -> [Type] -> Bool 56 | iter _ [] = True 57 | iter claimedTyVars (TypeRep.TyVarTy tyVar:rest) 58 | | tyVar `elemVarSet` claimedTyVars = False 59 | | otherwise = iter (extendVarSet claimedTyVars tyVar) rest 60 | iter claimedTyVars (_:rest) = iter claimedTyVars rest 61 | go _ = mempty 62 | 63 | -- We don't necessarily want to match on the foralls the user needed to 64 | -- merely bring type variables into scope 65 | stripForAlls :: VarSet -> Type -> (Type, VarSet) 66 | stripForAlls vars (ForAllTy var ty) = stripForAlls (VarSet.extendVarSet vars var) ty 67 | stripForAlls vars ty = (ty, vars) 68 | (strippedTy, tyVars) = stripForAlls VarSet.emptyVarSet ty 69 | 70 | isPrimed var = "'" `isSuffixOf` OccName.occNameString (OccName.occName $ Var.varName var) 71 | templVars = VarSet.filterVarSet (not . isPrimed) tyVars 72 | 73 | foldBindsContainingTyCon :: Monoid r 74 | => GHC.TyCon -> (GHC.LHsBind GHC.Id -> r) 75 | -> GHC.LHsBinds GHC.Id -> r 76 | foldBindsContainingTyCon tyCon f = everything mappend (mempty `mkQ` go) 77 | where 78 | go bind@(L _ (GHC.FunBind {GHC.fun_id=L _ fid})) 79 | | getAny $ everything mappend (mempty `mkQ` containsTyCon) (GHC.idType fid) = f bind 80 | where 81 | containsTyCon tyCon' | tyCon == tyCon' = Any True 82 | containsTyCon _ = mempty 83 | go _ = mempty 84 | 85 | foldBindsContainingIdent :: Monoid r 86 | => GHC.Id -> (GHC.LHsBind GHC.Id -> r) 87 | -> GHC.LHsBinds GHC.Id -> r 88 | foldBindsContainingIdent ident f = everything mappend (mempty `mkQ` go) 89 | where 90 | go bind 91 | | getAny $ everything mappend (mempty `mkQ` containsId) bind = f bind 92 | where 93 | containsId ident' | ident == ident' = Any True 94 | containsId _ = mempty 95 | go _ = mempty 96 | -------------------------------------------------------------------------------- /Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE TypeSynonymInstances #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE CPP #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | 7 | #if !MIN_VERSION_base(4,8,0) 8 | import Prelude hiding (mapM, concat) 9 | import Data.Traversable (traverse, mapM) 10 | #endif 11 | 12 | import Data.Monoid 13 | import Data.Foldable 14 | import Control.Monad (mzero) 15 | import Control.Monad.IO.Class 16 | 17 | import DynFlags 18 | import GhcMonad (withTempSession) 19 | import qualified GHC 20 | import qualified GHC.Paths 21 | import Digraph (flattenSCCs) -- this should be expected from GHC 22 | import Outputable hiding ((<>)) 23 | import qualified HscTypes 24 | 25 | import Options.Applicative hiding ((<>)) 26 | 27 | import qualified Distribution.Verbosity as Verbosity 28 | import qualified Distribution.Simple.Utils as Utils 29 | import GHC.Cabal 30 | 31 | import Usage 32 | import Reachability 33 | import Utils 34 | 35 | data Opts = Opts { mode :: [GHC.TypecheckedModule] -> GHC.Ghc () 36 | , distDir :: Maybe String 37 | , sourceFiles :: [FilePath] 38 | , verbose :: Verbosity.Verbosity 39 | } 40 | 41 | newtype Matcher = Matcher 42 | { runMatcher :: forall r. Monoid r => (GHC.LHsBind GHC.Id -> r) -> GHC.LHsBinds GHC.Id -> GHC.Ghc r } 43 | 44 | pureMatcher :: (a -> GHC.Ghc b) 45 | -> (forall r. Monoid r => b -> (GHC.LHsBind GHC.Id -> r) -> GHC.LHsBinds GHC.Id -> r) 46 | -> a -> Matcher 47 | pureMatcher prepare match x = 48 | Matcher $ \f binds -> prepare x >>= \y -> pure $ match y f binds 49 | 50 | opts :: Parser Opts 51 | opts = Opts 52 | <$> (matchMode <|> deadCodeMode) 53 | <*> optional (strOption $ long "builddir" <> metavar "DIR" <> help "cabal dist/ directory") 54 | <*> many (strArgument $ metavar "MODULE.hs" <> help "Haskell source modules to search within") 55 | <*> option (maybe mzero pure . Verbosity.intToVerbosity =<< auto) 56 | (short 'v' <> long "verbose" <> metavar "N" <> help "Verbosity level" 57 | <> value Verbosity.normal) 58 | where 59 | matchMode = fmap printMatchingBindings 60 | $ typeContains <|> typeContainsCon <|> ofType 61 | typeContains = pureMatcher (withExplicitForAll . lookupType) foldBindsContainingType 62 | <$> strOption ( long "containing" 63 | <> help "Find bindings whose type mentions the given type" 64 | <> metavar "TYPE") 65 | typeContainsCon = pureMatcher lookupTyCon foldBindsContainingTyCon 66 | <$> strOption ( long "containing-con" 67 | <> help "Find bindings whose type mentions the given type constructor" 68 | <> metavar "TYPECON") 69 | ofType = pureMatcher (withExplicitForAll . lookupType) foldBindsOfType 70 | <$> strOption ( long "of-type" 71 | <> help "Find bindings of the given type" 72 | <> metavar "TYPE") 73 | 74 | deadCodeMode = unreachableBinders 75 | <$> strOption ( long "dead-code" 76 | <> help "Find unreachable code") 77 | 78 | setupDynFlags :: Opts -> GHC.Ghc GHC.DynFlags 79 | setupDynFlags args = session >> GHC.getSessionDynFlags 80 | where 81 | session = do 82 | -- Note that this initial {get,set}SessionDynFlags is not idempotent 83 | dflags <- GHC.getSessionDynFlags 84 | (dflags', cd) <- maybe (dflags, Nothing) (\(a,b)->(a, Just b)) 85 | <$> liftIO (initCabalDynFlags (verbose args) (distDir args) dflags) 86 | _ <- GHC.setSessionDynFlags dflags' { hscTarget = HscNothing } 87 | 88 | let targets = fmap (componentTargets . cdComponent) cd 89 | liftIO $ Utils.debug (verbose args) $ showSDoc dflags 90 | $ text "Targets" <+> ppr targets 91 | traverse GHC.setTargets targets 92 | 93 | -- | Run a 'Ghc' action in a modified environment with 'Opt_ExplicitForAll' 94 | -- enabled in the interactive 'DynFlags' 95 | withExplicitForAll :: GHC.Ghc a -> GHC.Ghc a 96 | withExplicitForAll = 97 | withTempSession $ modifyIC (modifyDynFlags $ flip xopt_set Opt_ExplicitForAll) 98 | where 99 | modifyIC f env = env { HscTypes.hsc_IC = f (HscTypes.hsc_IC env) } 100 | 101 | modifyDynFlags :: ContainsDynFlags t => (DynFlags -> DynFlags) -> t -> t 102 | modifyDynFlags f env = replaceDynFlags env (f $ extractDynFlags env) 103 | 104 | instance ContainsDynFlags HscTypes.InteractiveContext where 105 | extractDynFlags = HscTypes.ic_dflags 106 | replaceDynFlags ic dflags = ic {HscTypes.ic_dflags = dflags} 107 | 108 | main :: IO () 109 | main = do 110 | args <- execParser $ info (helper <*> opts) mempty 111 | GHC.runGhc (Just GHC.Paths.libdir) (ghcMain args) 112 | 113 | ghcMain :: Opts -> GHC.Ghc () 114 | ghcMain args = GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $ do 115 | dflags <- setupDynFlags args 116 | let debugSDoc :: SDoc -> GHC.Ghc () 117 | debugSDoc = liftIO . Utils.debug (verbose args) . showSDoc dflags 118 | 119 | targets <- mapM (\s -> GHC.guessTarget s Nothing) (sourceFiles args) 120 | GHC.getTargets >>= GHC.setTargets . (++targets) 121 | 122 | summaries <- GHC.depanal [] True 123 | let graph = flattenSCCs $ GHC.topSortModuleGraph True summaries Nothing 124 | let processModule :: GHC.ModSummary -> GHC.Ghc GHC.TypecheckedModule 125 | processModule ms = do 126 | GHC.parseModule ms >>= GHC.typecheckModule >>= GHC.loadModule 127 | typechecked <- mapM processModule graph 128 | let modNames = map (GHC.moduleName . GHC.ms_mod) graph 129 | _ <- GHC.setContext $ map GHC.IIModule modNames 130 | 131 | debugSDoc $ vcat $ map (ppr . GHC.tm_typechecked_source) (toList typechecked) 132 | --printSDoc $ ppr $ usageGraph (map GHC.tm_typechecked_source (toList typechecked)) 133 | 134 | (mode args) (toList typechecked) 135 | 136 | printMatchingBindings :: Matcher -> [GHC.TypecheckedModule] -> GHC.Ghc () 137 | printMatchingBindings matcher tcms = do 138 | matches <- concat <$> mapM (runMatcher matcher (\a->[a]) 139 | . GHC.tm_typechecked_source) 140 | tcms 141 | printBindings matches 142 | 143 | 144 | -- TODO: 145 | -- Construction/destruction queries 146 | --------------------------------------------------------------------------------