@@ -28,8 +28,8 @@ module Development.IDE.Core.Rules(
2828
2929import Fingerprint
3030
31−import Data.Binary
32−import Data.Bifunctor (second)
31+import Data.Binary hiding (get, put)
32+import Data.Bifunctor (first, second)
3333import Control.Monad.Extra
3434import Control.Monad.Trans.Class
3535import Control.Monad.Trans.Maybe
@@ -46,13 +46,11 @@ import Development.IDE.Types.Location
4646import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule)
4747import Development.IDE.GHC.Util
4848import Development.IDE.GHC.WithDynFlags
49−import Data.Coerce
5049import Data.Either.Extra
5150import Data.Maybe
5251import Data.Foldable
5352import qualified Data.IntMap.Strict as IntMap
5453import Data.IntMap.Strict (IntMap)
55−import qualified Data.IntSet as IntSet
5654import Data.List
5755import Data.Ord
5856import qualified Data.Set as Set
@@ -70,11 +68,13 @@ import GHC.Generics(Generic)
7068import qualified Development.IDE.Spans.AtPoint as AtPoint
7169import Development.IDE.Core.Service
7270import Development.IDE.Core.Shake
73−import Development.Shake.Classes
71+import Development.Shake.Classes hiding (get, put)
7472import Control.Monad.Trans.Except (runExceptT)
7573import Data.ByteString (ByteString)
7674import Control.Concurrent.Async (concurrently)
7775
76+import Control.Monad.State
77+
7878-- | This is useful for rules to convert rules that can only produce errors or
7979-- a result into the more general IdeResult type that supports producing
8080-- warnings while also producing a result.
@@ -251,53 +251,91 @@ getLocatedImportsRule =
251251 Nothing -> pure (concat diags, Nothing)
252252 Just pkgImports -> pure (concat diags, Just (moduleImports, Set.fromList $ concat pkgImports))
253253
254+type RawDepM a = StateT (RawDependencyInformation, IntMap ArtifactsLocation) Action a
255+
256+execRawDepM :: Monad m => StateT (RawDependencyInformation, IntMap a1) m a2 -> m (RawDependencyInformation, IntMap a1)
257+execRawDepM act =
258+ execStateT act
259+ ( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty
260+ , IntMap.empty
261+ )
262+
254263-- | Given a target file path, construct the raw dependency results by following
255264-- imports recursively.
256−rawDependencyInformation :: NormalizedFilePath -> Action RawDependencyInformation
257−rawDependencyInformation f = do
258− let initialArtifact = ArtifactsLocation f (ModLocation (Just $ fromNormalizedFilePath f) "" "") False
259− (initialId, initialMap) = getPathId initialArtifact emptyPathIdMap
260− (rdi, ss) <- go (IntSet.singleton $ getFilePathId initialId)
261− (RawDependencyInformation IntMap.empty initialMap IntMap.empty, IntMap.empty)
265+rawDependencyInformation :: [NormalizedFilePath] -> Action RawDependencyInformation
266+rawDependencyInformation fs = do
267+ (rdi, ss) <- execRawDepM (mapM_ go fs)
262268 let bm = IntMap.foldrWithKey (updateBootMap rdi) IntMap.empty ss
263269 return (rdi { rawBootMap = bm })
264270 where
265− go fs (rawDepInfo, ss) =
266− case IntSet.minView fs of
267− -- Queue is empty
268− Nothing -> pure (rawDepInfo, ss)
269− -- Pop f from the queue and process it
270− Just (f, fs) -> do
271− let fId = FilePathId f
272− importsOrErr <- use GetLocatedImports $ idToPath (rawPathIdMap rawDepInfo) fId
273− case importsOrErr of
274− Nothing ->
275− -- File doesn’t parse
276− let rawDepInfo' = insertImport fId (Left ModuleParseError) rawDepInfo
277− in go fs (rawDepInfo', ss)
278− Just (modImports, pkgImports) -> do
279− let f :: (PathIdMap, IntMap ArtifactsLocation)
280− -> (a, Maybe ArtifactsLocation)
281− -> ((PathIdMap, IntMap ArtifactsLocation), (a, Maybe FilePathId))
282− f (pathMap, ss) (imp, mbPath) = case mbPath of
283− Nothing -> ((pathMap, ss), (imp, Nothing))
284− Just path ->
285− let (pathId, pathMap') = getPathId path pathMap
286− ss' = if isBootLocation path
287− then IntMap.insert (getFilePathId pathId) path ss
288− else ss
289− in ((pathMap', ss'), (imp, Just pathId))
290− -- Convert paths in imports to ids and update the path map
291− let ((pathIdMap, ss'), modImports') = mapAccumL f (rawPathIdMap rawDepInfo, ss) modImports
292− -- Files that we haven’t seen before are added to the queue.
293− let newFiles =
294− IntSet.fromList (coerce $ mapMaybe snd modImports')
295− IntSet.\\ IntMap.keysSet (rawImports rawDepInfo)
296− let rawDepInfo' = insertImport fId (Right $ ModuleImports modImports' pkgImports) rawDepInfo
297− go (newFiles `IntSet.union` fs)
298− (rawDepInfo' { rawPathIdMap = pathIdMap }, ss')
299−
300−
271+ go :: NormalizedFilePath -- ^ Current module being processed
272+ -> StateT (RawDependencyInformation, IntMap ArtifactsLocation) Action FilePathId
273+ go f = do
274+ -- First check to see if we have already processed the FilePath
275+ -- If we have, just return its Id but don't update any of the state.
276+ -- Otherwise, we need to process its imports.
277+ checkAlreadyProcessed f $ do
278+ al <- lift $ modSummaryToArtifactsLocation f <$> use_ GetModSummary f
279+ -- Get a fresh FilePathId for the new file
280+ fId <- getFreshFid al
281+ -- Adding an edge to the bootmap so we can make sure to
282+ -- insert boot nodes before the real files.
283+ addBootMap al fId
284+ -- Try to parse the imports of the file
285+ importsOrErr <- lift $ use GetLocatedImports f
286+ case importsOrErr of
287+ Nothing -> do
288+ -- File doesn't parse so add the module as a failure into the
289+ -- dependency information, continue processing the other
290+ -- elements in the queue
291+ modifyRawDepInfo (insertImport fId (Left ModuleParseError))
292+ return fId
293+ Just (modImports, pkgImports) -> do
294+ -- Get NFPs of the imports which have corresponding files
295+ -- Imports either come locally from a file or from a package.
296+ let (no_file, with_file) = splitImports modImports
297+ (mns, ls) = unzip with_file
298+ -- Recursively process all the imports we just learnt about
299+ -- and get back a list of their FilePathIds
300+ fids <- mapM (go . artifactFilePath) ls
301+ -- Associate together the ModuleName with the FilePathId
302+ let moduleImports' = map (,Nothing) no_file ++ zip mns (map Just fids)
303+ -- Insert into the map the information about this modules
304+ -- imports.
305+ modifyRawDepInfo $ insertImport fId (Right $ ModuleImports moduleImports' pkgImports)
306+ return fId
307+
308+
309+ checkAlreadyProcessed :: NormalizedFilePath -> RawDepM FilePathId -> RawDepM FilePathId
310+ checkAlreadyProcessed nfp k = do
311+ (rawDepInfo, _) <- get
312+ maybe k return (lookupPathToId (rawPathIdMap rawDepInfo) nfp)
313+
314+ modifyRawDepInfo :: (RawDependencyInformation -> RawDependencyInformation) -> RawDepM ()
315+ modifyRawDepInfo f = modify (first f)
316+
317+ addBootMap :: ArtifactsLocation -> FilePathId -> RawDepM ()
318+ addBootMap al fId =
319+ modify (\(rd, ss) -> (rd, if isBootLocation al
320+ then IntMap.insert (getFilePathId fId) al ss
321+ else ss))
322+
323+ getFreshFid :: ArtifactsLocation -> RawDepM FilePathId
324+ getFreshFid al = do
325+ (rawDepInfo, ss) <- get
326+ let (fId, path_map) = getPathId al (rawPathIdMap rawDepInfo)
327+ -- Insert the File into the bootmap if it's a boot module
328+ let rawDepInfo' = rawDepInfo { rawPathIdMap = path_map }
329+ put (rawDepInfo', ss)
330+ return fId
331+
332+ -- Split in (package imports, local imports)
333+ splitImports :: [(Located ModuleName, Maybe ArtifactsLocation)]
334+ -> ([Located ModuleName], [(Located ModuleName, ArtifactsLocation)])
335+ splitImports = foldr splitImportsLoop ([],[])
336+
337+ splitImportsLoop (imp, Nothing) (ns, ls) = (imp:ns, ls)
338+ splitImportsLoop (imp, Just artifact) (ns, ls) = (ns, (imp,artifact) : ls)
301339
302340 updateBootMap pm boot_mod_id ArtifactsLocation{..} bm =
303341 if not artifactIsSource
@@ -315,7 +353,7 @@ rawDependencyInformation f = do
315353getDependencyInformationRule :: Rules ()
316354getDependencyInformationRule =
317355 define $ \GetDependencyInformation file -> do
318− rawDepInfo <- rawDependencyInformation file
356+ rawDepInfo <- rawDependencyInformation [file]
319357 pure ([], Just $ processDependencyInformation rawDepInfo)
320358
321359reportImportCyclesRule :: Rules ()