git.iko.soy/ghcide
on 116a5ba help sign in
ghcide/src/Development/IDE/Import/DependencyInformation.hs
372 lines 15 kB history raw
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
2-- SPDX-License-Identifier: Apache-2.0
4module Development.IDE.Import.DependencyInformation
5 ( DependencyInformation(..)
6 , ModuleImports(..)
7 , RawDependencyInformation(..)
8 , NodeError(..)
9 , ModuleParseError(..)
10 , TransitiveDependencies(..)
11 , FilePathId(..)
12 , NamedModuleDep(..)
14 , PathIdMap
15 , emptyPathIdMap
16 , getPathId
17 , lookupPathToId
18 , insertImport
19 , pathToId
20 , idToPath
21 , reachableModules
22 , processDependencyInformation
23 , transitiveDeps
25 , BootIdMap
26 , insertBootId
27 ) where
29import Control.DeepSeq
30import Data.Bifunctor
31import Data.Coerce
32import Data.List
33import Data.Tuple.Extra hiding (first, second)
34import Development.IDE.GHC.Orphans()
35import Data.Either
36import Data.Graph
37import Data.HashMap.Strict (HashMap)
38import qualified Data.HashMap.Strict as HMS
39import Data.List.NonEmpty (NonEmpty(..), nonEmpty)
40import qualified Data.List.NonEmpty as NonEmpty
41import Data.IntMap (IntMap)
42import qualified Data.IntMap.Strict as IntMap
43import qualified Data.IntMap.Lazy as IntMapLazy
44import Data.IntSet (IntSet)
45import qualified Data.IntSet as IntSet
46import Data.Maybe
47import Data.Set (Set)
48import qualified Data.Set as Set
49import GHC.Generics (Generic)
51import Development.IDE.Types.Diagnostics
52import Development.IDE.Types.Location
53import Development.IDE.Import.FindImports (ArtifactsLocation(..))
55import GHC
56import Module
58-- | The imports for a given module.
59data ModuleImports = ModuleImports
60 { moduleImports :: ![(Located ModuleName, Maybe FilePathId)]
61 -- ^ Imports of a module in the current package and the file path of
62 -- that module on disk (if we found it)
63 , packageImports :: !(Set InstalledUnitId)
64 -- ^ Transitive package dependencies unioned for all imports.
65 }
67-- | For processing dependency information, we need lots of maps and sets
68-- of filepaths. Comparing Strings is really slow, so we work with IntMap/IntSet
69-- instead and only convert at the edges
70-- and
71newtype FilePathId = FilePathId { getFilePathId :: Int }
72 deriving (Show, NFData, Eq, Ord)
74data PathIdMap = PathIdMap
75 { idToPathMap :: !(IntMap ArtifactsLocation)
76 , pathToIdMap :: !(HashMap NormalizedFilePath FilePathId)
77 }
78 deriving (Show, Generic)
80instance NFData PathIdMap
82emptyPathIdMap :: PathIdMap
83emptyPathIdMap = PathIdMap IntMap.empty HMS.empty
85getPathId :: ArtifactsLocation -> PathIdMap -> (FilePathId, PathIdMap)
86getPathId path m@PathIdMap{..} =
87 case HMS.lookup (artifactFilePath path) pathToIdMap of
88 Nothing ->
89 let !newId = FilePathId $ HMS.size pathToIdMap
90 in (newId, insertPathId path newId m)
91 Just id -> (id, m)
93insertPathId :: ArtifactsLocation -> FilePathId -> PathIdMap -> PathIdMap
94insertPathId path id PathIdMap{..} =
95 PathIdMap (IntMap.insert (getFilePathId id) path idToPathMap) (HMS.insert (artifactFilePath path) id pathToIdMap)
97insertImport :: FilePathId -> Either ModuleParseError ModuleImports -> RawDependencyInformation -> RawDependencyInformation
98insertImport (FilePathId k) v rawDepInfo = rawDepInfo { rawImports = IntMap.insert k v (rawImports rawDepInfo) }
100pathToId :: PathIdMap -> NormalizedFilePath -> FilePathId
101pathToId PathIdMap{pathToIdMap} path = pathToIdMap HMS.! path
103lookupPathToId :: PathIdMap -> NormalizedFilePath -> Maybe FilePathId
104lookupPathToId PathIdMap{pathToIdMap} path = HMS.lookup path pathToIdMap
106idToPath :: PathIdMap -> FilePathId -> NormalizedFilePath
107idToPath pathIdMap filePathId = artifactFilePath $ idToModLocation pathIdMap filePathId
109idToModLocation :: PathIdMap -> FilePathId -> ArtifactsLocation
110idToModLocation PathIdMap{idToPathMap} (FilePathId id) = idToPathMap IntMap.! id
113type BootIdMap = IntMap FilePathId
115insertBootId :: FilePathId -> FilePathId -> BootIdMap -> BootIdMap
116insertBootId k = IntMap.insert (getFilePathId k)
119-- | Unprocessed results that we find by following imports recursively.
120data RawDependencyInformation = RawDependencyInformation
121 { rawImports :: !(IntMap (Either ModuleParseError ModuleImports))
122 , rawPathIdMap :: !PathIdMap
123 -- The rawBootMap maps the FilePathId of a hs-boot file to its
124 -- corresponding hs file. It is used when topologically sorting as we
125 -- need to add edges between .hs-boot and .hs so that the .hs files
126 -- appear later in the sort.
127 , rawBootMap :: !BootIdMap
128 }
130pkgDependencies :: RawDependencyInformation -> IntMap (Set InstalledUnitId)
131pkgDependencies RawDependencyInformation{..} =
132 IntMap.map (either (const Set.empty) packageImports) rawImports
134data DependencyInformation =
135 DependencyInformation
136 { depErrorNodes :: !(IntMap (NonEmpty NodeError))
137 -- ^ Nodes that cannot be processed correctly.
138 , depModuleNames :: !(IntMap ShowableModuleName)
139 , depModuleDeps :: !(IntMap IntSet)
140 -- ^ For a non-error node, this contains the set of module immediate dependencies
141 -- in the same package.
142 , depPkgDeps :: !(IntMap (Set InstalledUnitId))
143 -- ^ For a non-error node, this contains the set of immediate pkg deps.
144 , depPathIdMap :: !PathIdMap
145 -- ^ Map from hs-boot file to the corresponding hs file
146 , depBootMap :: !BootIdMap
147 } deriving (Show, Generic)
149newtype ShowableModuleName =
150 ShowableModuleName {showableModuleName :: ModuleName}
151 deriving NFData
153instance Show ShowableModuleName where show = moduleNameString . showableModuleName
155reachableModules :: DependencyInformation -> [NormalizedFilePath]
156reachableModules DependencyInformation{..} =
157 map (idToPath depPathIdMap . FilePathId) $ IntMap.keys depErrorNodes <> IntMap.keys depModuleDeps
159instance NFData DependencyInformation
161-- | This does not contain the actual parse error as that is already reported by GetParsedModule.
162data ModuleParseError = ModuleParseError
163 deriving (Show, Generic)
165instance NFData ModuleParseError
167-- | Error when trying to locate a module.
168data LocateError = LocateError [Diagnostic]
169 deriving (Eq, Show, Generic)
171instance NFData LocateError
173-- | An error attached to a node in the dependency graph.
174data NodeError
175 = PartOfCycle (Located ModuleName) [FilePathId]
176 -- ^ This module is part of an import cycle. The module name corresponds
177 -- to the import that enters the cycle starting from this module.
178 -- The list of filepaths represents the elements
179 -- in the cycle in unspecified order.
180 | FailedToLocateImport (Located ModuleName)
181 -- ^ This module has an import that couldn’t be located.
182 | ParseError ModuleParseError
183 | ParentOfErrorNode (Located ModuleName)
184 -- ^ This module is the parent of a module that cannot be
185 -- processed (either it cannot be parsed, is part of a cycle
186 -- or the parent of another error node).
187 deriving (Show, Generic)
189instance NFData NodeError where
190 rnf (PartOfCycle m fs) = m `seq` rnf fs
191 rnf (FailedToLocateImport m) = m `seq` ()
192 rnf (ParseError e) = rnf e
193 rnf (ParentOfErrorNode m) = m `seq` ()
195-- | A processed node in the dependency graph. If there was any error
196-- during processing the node or any of its dependencies, this is an
197-- `ErrorNode`. Otherwise it is a `SuccessNode`.
198data NodeResult
199 = ErrorNode (NonEmpty NodeError)
200 | SuccessNode [(Located ModuleName, FilePathId)]
201 deriving Show
203partitionNodeResults
204 :: [(a, NodeResult)]
205 -> ([(a, NonEmpty NodeError)], [(a, [(Located ModuleName, FilePathId)])])
206partitionNodeResults = partitionEithers . map f
207 where f (a, ErrorNode errs) = Left (a, errs)
208 f (a, SuccessNode imps) = Right (a, imps)
210instance Semigroup NodeResult where
211 ErrorNode errs <> ErrorNode errs' = ErrorNode (errs <> errs')
212 ErrorNode errs <> SuccessNode _ = ErrorNode errs
213 SuccessNode _ <> ErrorNode errs = ErrorNode errs
214 SuccessNode a <> SuccessNode _ = SuccessNode a
216processDependencyInformation :: RawDependencyInformation -> DependencyInformation
217processDependencyInformation rawDepInfo@RawDependencyInformation{..} =
218 DependencyInformation
219 { depErrorNodes = IntMap.fromList errorNodes
220 , depModuleDeps = moduleDeps
221 , depModuleNames = IntMap.fromList $ coerce moduleNames
222 , depPkgDeps = pkgDependencies rawDepInfo
223 , depPathIdMap = rawPathIdMap
224 , depBootMap = rawBootMap
225 }
226 where resultGraph = buildResultGraph rawImports
227 (errorNodes, successNodes) = partitionNodeResults $ IntMap.toList resultGraph
228 moduleNames :: [(FilePathId, ModuleName)]
229 moduleNames =
230 [ (fId, modName) | (_, imports) <- successNodes, (L _ modName, fId) <- imports]
231 successEdges :: [(FilePathId, FilePathId, [FilePathId])]
232 successEdges =
233 map
234 (\(file, imports) -> (FilePathId file, FilePathId file, map snd imports))
235 successNodes
236 moduleDeps =
237 IntMap.fromList $
238 map (\(_, FilePathId v, vs) -> (v, IntSet.fromList $ coerce vs))
239 successEdges
241-- | Given a dependency graph, buildResultGraph detects and propagates errors in that graph as follows:
242-- 1. Mark each node that is part of an import cycle as an error node.
243-- 2. Mark each node that has a parse error as an error node.
244-- 3. Mark each node whose immediate children could not be located as an error.
245-- 4. Recursively propagate errors to parents if they are not already error nodes.
246buildResultGraph :: IntMap (Either ModuleParseError ModuleImports) -> IntMap NodeResult
247buildResultGraph g = propagatedErrors
248 where
249 sccs = stronglyConnComp (graphEdges g)
250 (_, cycles) = partitionSCC sccs
251 cycleErrors :: IntMap NodeResult
252 cycleErrors = IntMap.unionsWith (<>) $ map errorsForCycle cycles
253 errorsForCycle :: [FilePathId] -> IntMap NodeResult
254 errorsForCycle files =
255 IntMap.fromListWith (<>) $ coerce $ concatMap (cycleErrorsForFile files) files
256 cycleErrorsForFile :: [FilePathId] -> FilePathId -> [(FilePathId,NodeResult)]
257 cycleErrorsForFile cycle f =
258 let entryPoints = mapMaybe (findImport f) cycle
259 in map (\imp -> (f, ErrorNode (PartOfCycle imp cycle :| []))) entryPoints
260 otherErrors = IntMap.map otherErrorsForFile g
261 otherErrorsForFile :: Either ModuleParseError ModuleImports -> NodeResult
262 otherErrorsForFile (Left err) = ErrorNode (ParseError err :| [])
263 otherErrorsForFile (Right ModuleImports{moduleImports}) =
264 let toEither (imp, Nothing) = Left imp
265 toEither (imp, Just path) = Right (imp, path)
266 (errs, imports') = partitionEithers (map toEither moduleImports)
267 in case nonEmpty errs of
268 Nothing -> SuccessNode imports'
269 Just errs' -> ErrorNode (NonEmpty.map FailedToLocateImport errs')
271 unpropagatedErrors = IntMap.unionWith (<>) cycleErrors otherErrors
272 -- The recursion here is fine since we use a lazy map and
273 -- we only recurse on SuccessNodes. In particular, we do not recurse
274 -- on nodes that are part of a cycle as they are already marked as
275 -- error nodes.
276 propagatedErrors =
277 IntMapLazy.map propagate unpropagatedErrors
278 propagate :: NodeResult -> NodeResult
279 propagate n@(ErrorNode _) = n
280 propagate n@(SuccessNode imps) =
281 let results = map (\(imp, FilePathId dep) -> (imp, propagatedErrors IntMap.! dep)) imps
282 (errs, _) = partitionNodeResults results
283 in case nonEmpty errs of
284 Nothing -> n
285 Just errs' -> ErrorNode (NonEmpty.map (ParentOfErrorNode . fst) errs')
286 findImport :: FilePathId -> FilePathId -> Maybe (Located ModuleName)
287 findImport (FilePathId file) importedFile =
288 case g IntMap.! file of
289 Left _ -> error "Tried to call findImport on a module with a parse error"
290 Right ModuleImports{moduleImports} ->
291 fmap fst $ find (\(_, resolvedImp) -> resolvedImp == Just importedFile) moduleImports
293graphEdges :: IntMap (Either ModuleParseError ModuleImports) -> [(FilePathId, FilePathId, [FilePathId])]
294graphEdges g =
295 map (\(k, v) -> (FilePathId k, FilePathId k, deps v)) $ IntMap.toList g
296 where deps :: Either e ModuleImports -> [FilePathId]
297 deps (Left _) = []
298 deps (Right ModuleImports{moduleImports}) = mapMaybe snd moduleImports
300partitionSCC :: [SCC a] -> ([a], [[a]])
301partitionSCC (CyclicSCC xs:rest) = second (xs:) $ partitionSCC rest
302partitionSCC (AcyclicSCC x:rest) = first (x:) $ partitionSCC rest
303partitionSCC [] = ([], [])
306transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies
307transitiveDeps DependencyInformation{..} file = do
308 let !fileId = pathToId depPathIdMap file
309 reachableVs <-
310 -- Delete the starting node
311 IntSet.delete (getFilePathId fileId) .
312 IntSet.fromList . map (fst3 . fromVertex) .
313 reachable g <$> toVertex (getFilePathId fileId)
314 let transitiveModuleDepIds =
315 filter (\v -> v `IntSet.member` reachableVs) $ map (fst3 . fromVertex) vs
316 let transitivePkgDeps =
317 Set.toList $ Set.unions $
318 map (\f -> IntMap.findWithDefault Set.empty f depPkgDeps) $
319 getFilePathId fileId : transitiveModuleDepIds
320 let transitiveModuleDeps =
321 map (idToPath depPathIdMap . FilePathId) transitiveModuleDepIds
322 let transitiveNamedModuleDeps =
323 [ NamedModuleDep (idToPath depPathIdMap (FilePathId fid)) mn artifactModLocation
324 | (fid, ShowableModuleName mn) <- IntMap.toList depModuleNames
325 , let ArtifactsLocation{artifactModLocation} = idToPathMap depPathIdMap IntMap.! fid
326 ]
327 pure TransitiveDependencies {..}
328 where
329 (g, fromVertex, toVertex) = graphFromEdges edges
330 edges = map (\(f, fs) -> (f, f, IntSet.toList fs ++ boot_edge f)) $ IntMap.toList depModuleDeps
332 -- Need to add an edge between the .hs and .hs-boot file if it exists
333 -- so the .hs file gets loaded after the .hs-boot file and the right
334 -- stuff ends up in the HPT. If you don't have this check then GHC will
335 -- fail to work with ghcide.
336 boot_edge f = [getFilePathId f' | Just f' <- [IntMap.lookup f depBootMap]]
338 vs = topSort g
340data TransitiveDependencies = TransitiveDependencies
341 { transitiveModuleDeps :: [NormalizedFilePath]
342 -- ^ Transitive module dependencies in topological order.
343 -- The module itself is not included.
344 , transitiveNamedModuleDeps :: [NamedModuleDep]
345 -- ^ Transitive module dependencies in topological order.
346 -- The module itself is not included.
347 , transitivePkgDeps :: [InstalledUnitId]
348 -- ^ Transitive pkg dependencies in unspecified order.
349 } deriving (Eq, Show, Generic)
351instance NFData TransitiveDependencies
353data NamedModuleDep = NamedModuleDep {
354 nmdFilePath :: !NormalizedFilePath,
355 nmdModuleName :: !ModuleName,
356 nmdModLocation :: !ModLocation
357 }
358 deriving Generic
360instance Eq NamedModuleDep where
361 a == b = nmdFilePath a == nmdFilePath b
363instance NFData NamedModuleDep where
364 rnf NamedModuleDep{..} =
365 rnf nmdFilePath `seq`
366 rnf nmdModuleName `seq`
367 -- 'ModLocation' lacks an 'NFData' instance
368 rwhnf nmdModLocation
370instance Show NamedModuleDep where
371 show NamedModuleDep{..} = show nmdFilePath