blob: 1b249047d58a8123044cdbe56c192797c5b76798 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
|
{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# LANGUAGE ImportQualifiedPost #-}
module Main where
import GHC.Driver.Env
import GHC.Unit.Module
import GHC.Driver.Session
import GHC.Driver.Main
import GHC
import Control.Monad
import Control.Monad.IO.Class
import System.Environment
import GHC.Unit.Module.Deps
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
-- Example invocation:
-- inplace/bin/count-deps `inplace/bin/ghc-stage2 --print-libdir` "GHC.Parser"
main :: IO ()
main = do
args <- getArgs
case args of
[libdir, modName, "--dot"] -> printDeps libdir modName True
[libdir, modName] -> printDeps libdir modName False
_ -> fail "usage: count-deps libdir module [--dot]"
dotSpec :: String -> Map.Map String [String] -> String
dotSpec name g =
"digraph \"" ++ name ++ "\" {\n" ++
Map.foldlWithKey' f "" g ++ "}\n"
where
f acc k ns = acc ++ concat [" " ++ show k ++ " -> " ++ show n ++ ";\n" | n <- ns]
printDeps :: String -> String -> Bool -> IO ()
printDeps libdir modName dot = do
modGraph <-
Map.map (map moduleNameString) .
Map.mapKeys moduleNameString <$> calcDeps modName libdir
if not dot then
do
let modules = Map.keys modGraph
putStrLn $ "Found " ++ modName ++ " module dependencies"
forM_ modules putStrLn
else
-- * Copy the digraph output to a file ('deps.dot' say)
-- * To render it, use a command along the lines of
-- 'tred deps.dot > deps-tred.dot && dot -Tpdf -o deps.pdf deps-tred.dot'
putStr $ dotSpec modName modGraph
calcDeps :: String -> FilePath -> IO (Map.Map ModuleName [ModuleName])
calcDeps modName libdir =
defaultErrorHandler defaultFatalMessager defaultFlushOut $ do
runGhc (Just libdir) $ do
df <- getSessionDynFlags
logger <- getLogger
(df, _, _) <- parseDynamicFlags logger df [noLoc "-package=ghc"]
setSessionDynFlags df
case lookup "Project Unit Id" (compilerInfo df) of
Nothing -> fail "failed to find ghc's unit-id in the compiler info"
Just ghcUnitId -> do
env <- getSession
loop ghcUnitId env Map.empty [mkModuleName modName]
where
-- Source imports are only guaranteed to show up in the 'mi_deps'
-- of modules that import them directly and don’t propagate
-- transitively so we loop.
loop :: String -> HscEnv -> Map.Map ModuleName [ModuleName] -> [ModuleName] -> Ghc (Map.Map ModuleName [ModuleName])
loop ghcUnitId env modules (m : ms) =
if m `Map.member` modules
then loop ghcUnitId env modules ms
else do
mi <- liftIO $ hscGetModuleInterface env (mkModule ghcUnitId m)
let deps = modDeps mi
modules <- return $ Map.insert m [] modules
loop ghcUnitId env (Map.insert m deps modules) $ ms ++ filter (not . (`Map.member` modules)) deps
loop _ _ modules [] = return modules
mkModule :: String -> ModuleName -> Module
mkModule ghcUnitId = Module (stringToUnit ghcUnitId)
modDeps :: ModIface -> [ModuleName]
modDeps mi = map (gwib_mod . snd) $ Set.toList $ dep_direct_mods (mi_deps mi)
|
