-
Notifications
You must be signed in to change notification settings - Fork 0
/
CabalAudit.hs
180 lines (150 loc) · 6.25 KB
/
CabalAudit.hs
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
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
module CabalAudit where
-- base
import Control.Monad
import Data.Coerce (coerce)
import Data.Foldable
import Data.List (intersperse)
import Data.Maybe
-- containers
import Data.Map.Strict qualified as Map
import Data.Set (Set)
import Data.Set qualified as Set
-- generic-lens
import Data.Generics.Labels ()
-- lens
import Control.Lens ((%=))
-- transformers
import Control.Monad.Trans.Class
import Control.Monad.Trans.State.Strict
-- algebraic-graphs
import Algebra.Graph (Graph, edge, overlay)
import Algebra.Graph.ToGraph qualified as Graph
-- ghc
import GHC.Generics (Generic)
import GHC.Iface.Ext.Types
import GHC.Types.Name
import GHC.Unit.Module
import GHC.Utils.Outputable hiding ((<>))
-- cabal-audit
import HieLoader
-- | A symbol that is imported
data Declaration = Declaration
{ declModule :: Module
, declOccName :: OccName
}
deriving (Ord, Eq)
-- | A symbol that is defined
newtype TopLevelDeclaration = TopLevelDeclaration Declaration
deriving newtype (Ord, Eq, Show)
data Analysis = Analysis
{ dependencyGraph :: Graph Declaration
, roots :: Set TopLevelDeclaration
}
deriving (Generic)
main :: IO ()
main = do
let hieLocations = ["./dist-newstyle"]
exposedModule = mkModuleName <$> ["CabalAudit.Test.Simple", "CabalAudit.Test.User", "CabalAudit.Test.Instance"]
analysis <- doAnalyze hieLocations exposedModule
printExternalNames analysis
-- | A helper to dump the analysis.
printExternalNames :: Analysis -> IO ()
printExternalNames analysis = evalStateT go mempty
where
go :: StateT (Set Declaration) IO ()
go = traverse_ goRoot analysis.roots
goRoot :: TopLevelDeclaration -> StateT (Set Declaration) IO ()
goRoot decl = do
let reachables :: [Declaration]
reachables = Graph.reachable (coerce decl) analysis.dependencyGraph
known <- get
case filter (`notElem` known) (filter (/= coerce decl) reachables) of
[] -> lift $ putStrLn (show decl <> " does not have any dependencies")
decls -> do
lift $ putStr (show decl <> ": ")
traverse_ (lift . putStr) (intersperse ", " (show <$> decls))
-- Reduce the output by registering the declarations that have been reported
-- put $ Set.union known (Set.fromList decls)
lift $ putStr "\n"
-- | Perform the analysis
doAnalyze :: [FilePath] -> [ModuleName] -> IO Analysis
doAnalyze hiePaths rootModules = do
hieState <- newHieState hiePaths
let analysis = Analysis mempty mempty
flip execStateT analysis do
forM_ rootModules \rootModule -> do
lift (lookupOrLoadHieFile hieState rootModule) >>= \case
Nothing -> lift (putStrLn $ "No hie file for " <> show rootModule)
Just hieFile -> do
forM_ (getDependencies hieFile) \(topLevelDecl, decl) -> do
#roots %= Set.insert (coerce topLevelDecl)
#dependencyGraph %= overlay (edge (coerce topLevelDecl) decl)
-- todo: load external hie file and dive in the dependency tree
pure ()
data DeclarationInfo = DeclarationInfo
{ decl :: Declaration
, ctxInfo :: Set ContextInfo
}
instance Show DeclarationInfo where
show extName = showPpr $ hcat $ [ppr extName.decl, " ", ppr extName.ctxInfo]
showPpr :: SDoc -> String
showPpr = showSDocOneLine defaultSDocContext
instance Outputable Declaration where
ppr decl = hcat [ppr decl.declModule, ".", ppr decl.declOccName]
instance Show Declaration where
show decl = showPpr (ppr decl)
-- | Check if a declaration is a top level bind
isToplevelDeclaration :: DeclarationInfo -> Maybe TopLevelDeclaration
isToplevelDeclaration extName =
Set.foldr
( \ctx acc -> case acc of
Nothing -> isTopDecl ctx
_ -> acc
)
Nothing
extName.ctxInfo
where
isTopDecl :: ContextInfo -> Maybe TopLevelDeclaration
isTopDecl = \case
ValBind _bindType ModuleScope _span -> Just (TopLevelDeclaration extName.decl)
MatchBind -> Just (TopLevelDeclaration extName.decl)
_ -> Nothing
isUsage :: DeclarationInfo -> Bool
isUsage extName = Use `Set.member` extName.ctxInfo
-- | Returns all the edges between a top level declaration and its dependency.
getDependencies :: HieFile -> [(TopLevelDeclaration, Declaration)]
getDependencies hieFile =
map (fmap (.decl)) $ filter (isUsage . snd) $ concatMap doGet (Map.elems hieFile.hie_asts.getAsts)
where
doGet :: HieAST TypeIndex -> [(TopLevelDeclaration, DeclarationInfo)]
doGet cur = case isTopLevel of
Nothing -> concatMap doGet cur.nodeChildren
Just decl -> (\di -> (decl, di)) <$> doGetDependencies cur
where
-- Is the current node a left-hand-side binder?
isTopLevel :: Maybe TopLevelDeclaration
isTopLevel = listToMaybe $ mapMaybe isToplevelDeclaration curNodeInfo
curNodeInfo =
-- Note: this is a bit suspicious. It seems like top level declaration are defined like this:
-- node.children = lhsDeclaration : rhsDeclarations...
case cur.nodeChildren of
(lhs : _) -> doGetNode lhs.sourcedNodeInfo
_ -> []
doGetDependencies :: HieAST TypeIndex -> [DeclarationInfo]
doGetDependencies cur = doGetNode cur.sourcedNodeInfo <> concatMap doGetDependencies cur.nodeChildren
doGetNode :: SourcedNodeInfo TypeIndex -> [DeclarationInfo]
doGetNode node = concatMap doGetNodeInfo (Map.elems node.getSourcedNodeInfo)
doGetNodeInfo :: NodeInfo TypeIndex -> [DeclarationInfo]
doGetNodeInfo nodeInfo = concatMap doGetNodeIdentifiers (Map.toList nodeInfo.nodeIdentifiers)
doGetNodeIdentifiers :: (Identifier, IdentifierDetails TypeIndex) -> [DeclarationInfo]
doGetNodeIdentifiers (identifier, identifierDetails) = case identifierToDeclaration identifier of
Just decl -> [DeclarationInfo decl identifierDetails.identInfo]
Nothing -> []
identifierToDeclaration :: Identifier -> Maybe Declaration
identifierToDeclaration = \case
Left _moduleName -> Nothing
Right name -> nameToDeclaration name
nameToDeclaration :: Name -> Maybe Declaration
nameToDeclaration name = do
m <- nameModule_maybe name
pure Declaration{declModule = m, declOccName = nameOccName name}