@@ -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,89 @@ 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 = execStateT act
258+ (RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty
259+ , IntMap.empty)
260+
254261-- | Given a target file path, construct the raw dependency results by following
255262-- 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)
263+rawDependencyInformation :: [NormalizedFilePath] -> Action RawDependencyInformation
264+rawDependencyInformation fs = do
265+ (rdi, ss) <- execRawDepM (mapM_ go fs)
262266 let bm = IntMap.foldrWithKey (updateBootMap rdi) IntMap.empty ss
263267 return (rdi { rawBootMap = bm })
264268 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−
269+ go :: NormalizedFilePath -- ^ Current module being processed
270+ -> StateT (RawDependencyInformation, IntMap ArtifactsLocation) Action FilePathId
271+ go f = do
272+ -- First check to see if we have already processed the FilePath
273+ -- If we have, just return its Id but don't update any of the state.
274+ -- Otherwise, we need to process its imports.
275+ checkAlreadyProcessed f $ do
276+ al <- lift $ modSummaryToArtifactsLocation f <$> use_ GetModSummary f
277+ -- Get a fresh FilePathId for the new file
278+ fId <- getFreshFid al
279+ -- Adding an edge to the bootmap so we can make sure to
280+ -- insert boot nodes before the real files.
281+ addBootMap al fId
282+ -- Try to parse the imports of the file
283+ importsOrErr <- lift $ use GetLocatedImports f
284+ case importsOrErr of
285+ Nothing -> do
286+ -- File doesn't parse so add the module as a failure into the
287+ -- dependency information, continue processing the other
288+ -- elements in the queue
289+ modifyRawDepInfo (insertImport fId (Left ModuleParseError))
290+ return fId
291+ Just (modImports, pkgImports) -> do
292+ -- Get NFPs of the imports which have corresponding files
293+ -- Imports either come locally from a file or from a package.
294+ let (no_file, with_file) = splitImports modImports
295+ (mns, ls) = unzip with_file
296+ -- Recursively process all the imports we just learnt about
297+ -- and get back a list of their FilePathIds
298+ fids <- mapM (go . artifactFilePath) ls
299+ -- Associate together the ModuleName with the FilePathId
300+ let moduleImports' = map (,Nothing) no_file ++ zip mns (map Just fids)
301+ -- Insert into the map the information about this modules
302+ -- imports.
303+ modifyRawDepInfo $ insertImport fId (Right $ ModuleImports moduleImports' pkgImports)
304+ return fId
305+
306+
307+ checkAlreadyProcessed :: NormalizedFilePath -> RawDepM FilePathId -> RawDepM FilePathId
308+ checkAlreadyProcessed nfp k = do
309+ (rawDepInfo, _) <- get
310+ maybe k return (lookupPathToId (rawPathIdMap rawDepInfo) nfp)
311+
312+ modifyRawDepInfo :: (RawDependencyInformation -> RawDependencyInformation) -> RawDepM ()
313+ modifyRawDepInfo f = modify (first f)
314+
315+ addBootMap :: ArtifactsLocation -> FilePathId -> RawDepM ()
316+ addBootMap al fId =
317+ modify (\(rd, ss) -> (rd, if isBootLocation al
318+ then IntMap.insert (getFilePathId fId) al ss
319+ else ss))
320+
321+ getFreshFid :: ArtifactsLocation -> RawDepM FilePathId
322+ getFreshFid al = do
323+ (rawDepInfo, ss) <- get
324+ let (fId, path_map) = getPathId al (rawPathIdMap rawDepInfo)
325+ -- Insert the File into the bootmap if it's a boot module
326+ let rawDepInfo' = rawDepInfo { rawPathIdMap = path_map }
327+ put (rawDepInfo', ss)
328+ return fId
329+
330+ -- Split in (package imports, local imports)
331+ splitImports :: [(Located ModuleName, Maybe ArtifactsLocation)]
332+ -> ([Located ModuleName], [(Located ModuleName, ArtifactsLocation)])
333+ splitImports = foldr splitImportsLoop ([],[])
334+
335+ splitImportsLoop (imp, Nothing) (ns, ls) = (imp:ns, ls)
336+ splitImportsLoop (imp, Just artifact) (ns, ls) = (ns, (imp,artifact) : ls)
301337
302338 updateBootMap pm boot_mod_id ArtifactsLocation{..} bm =
303339 if not artifactIsSource
@@ -315,7 +351,7 @@ rawDependencyInformation f = do
315351getDependencyInformationRule :: Rules ()
316352getDependencyInformationRule =
317353 define $ \GetDependencyInformation file -> do
318− rawDepInfo <- rawDependencyInformation file
354+ rawDepInfo <- rawDependencyInformation [file]
319355 pure ([], Just $ processDependencyInformation rawDepInfo)
320356
321357reportImportCyclesRule :: Rules ()