Add new command to GetModuleGraph for a session and propate changes to

modules

exe/Main.hs

@@ -358,7 +358,7 @@ loadSession dir = liftIO $ do
         modifyVar_ fileToFlags $ \var -> do
             pure $ Map.insert hieYaml (HM.fromList (cs ++ cached_targets)) var
 
-        return res
+        return (cs, res)
 
     lock <- newLock
 
@@ -382,7 +382,7 @@ loadSession dir = liftIO $ do
         case HM.lookup (toNormalizedFilePath' cfp) v of
             Just opts -> do
                 --putStrLn $ "Cached component of " <> show file
-                pure (fst opts)
+                pure ([], fst opts)
             Nothing-> do
                 finished_barrier <- newBarrier
                 -- fork a new thread here which won't be killed by shake
@@ -392,8 +392,8 @@ loadSession dir = liftIO $ do
                   cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle hieYaml
                   opts <- cradleToSessionOpts cradle cfp
                   print opts
-                  res <- fst <$> session (hieYaml, toNormalizedFilePath' cfp, opts)
-                  signalBarrier finished_barrier res
+                  (cs, res)<- session (hieYaml, toNormalizedFilePath' cfp, opts)
+                  signalBarrier finished_barrier (cs, fst res)
                 waitBarrier finished_barrier
 
     dummyAs <- async $ return (error "Uninitialised")
@@ -404,18 +404,30 @@ loadSession dir = liftIO $ do
             hieYaml <- cradleLoc file
             sessionOpts (hieYaml, file)
     -- The lock is on the `runningCradle` resource
-    return $ \file -> liftIO $ withLock lock $ do
-        as <- readIORef runningCradle
-        finished <- poll as
-        case finished of
-            Just {} -> do
-                as <- async $ getOptions file
-                writeIORef runningCradle as
-                wait as
-             -- If it's not finished then wait and then get options, this could of course be killed still
-            Nothing -> do
-                _ <- wait as
-                getOptions file
+    return $ \file -> do
+      (cs, opts) <-
+        liftIO $ withLock lock $ do
+          as <- readIORef runningCradle
+          finished <- poll as
+          case finished of
+              Just {} -> do
+                  as <- async $ getOptions file
+                  writeIORef runningCradle as
+                  wait as
+              -- If it's not finished then wait and then get options, this could of course be killed still
+              Nothing -> do
+                  _ <- wait as
+                  getOptions file
+      let cfps = map fst cs
+      -- Delayed to avoid recursion and only run if something changed.
+      unless (null cs) (
+        delay "InitialLoad" $ void $ do
+          cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) cfps
+          mmt <- uses GetModificationTime cfps'
+          let cs_exist = catMaybes (zipWith (<$) cfps' mmt)
+          uses GetModIface cs_exist)
+      return opts
+
 
 
 

src/Development/IDE/Core/FileStore.hs

@@ -29,10 +29,12 @@ import           GHC.Generics
 import Data.Either.Extra
 import System.IO.Error
 import qualified Data.ByteString.Char8 as BS
+import Data.HashSet as HS
 import Development.IDE.Types.Diagnostics
 import Development.IDE.Types.Location
 import Development.IDE.Core.RuleTypes
 import qualified Data.Rope.UTF16 as Rope
+import Development.IDE.Import.DependencyInformation
 
 #ifdef mingw32_HOST_OS
 import Data.Time
@@ -187,7 +189,14 @@ setFileModified state nfp = do
     VFSHandle{..} <- getIdeGlobalState state
     when (isJust setVirtualFileContents) $
         fail "setSomethingModified can't be called on this type of VFSHandle"
-    shakeRunInternalKill "FileStoreTC" state [void (use TypeCheck nfp)] --, void (useNoFile GetModuleGraph)]
+    shakeRunInternalKill "FileStoreTC" state [void (use TypeCheck nfp)
+                                             , delay "Propagate" (typecheckParents nfp) ]
+
+typecheckParents :: NormalizedFilePath -> Action ()
+typecheckParents nfp = do
+    revs <- reverseDependencies nfp <$> useNoFile_ GetModuleGraph
+    liftIO $ print (length revs)
+    void $ uses GetModIface revs
 
 -- | Note that some buffer somewhere has been modified, but don't say what.
 --   Only valid if the virtual file system was initialised by LSP, as that

src/Development/IDE/Core/RuleTypes.hs

@@ -45,6 +45,8 @@ type instance RuleResult GetDependencyInformation = DependencyInformation
 -- This rule is also responsible for calling ReportImportCycles for each file in the transitive closure.
 type instance RuleResult GetDependencies = TransitiveDependencies
 
+type instance RuleResult GetModuleGraph = DependencyInformation
+
 -- | Contains the typechecked module and the OrigNameCache entry for
 -- that module.
 data TcModuleResult = TcModuleResult
@@ -92,7 +94,6 @@ type instance RuleResult GhcSession = HscEnvEq
 -- in the same package or the package id of another package.
 type instance RuleResult GetLocatedImports = ([(Located ModuleName, Maybe ArtifactsLocation)], S.Set InstalledUnitId)
 
--- | This rule is used to report import cycles. It depends on GetDependencyInformation.
 -- We cannot report the cycles directly from GetDependencyInformation since
 -- we can only report diagnostics for the current file.
 type instance RuleResult ReportImportCycles = ()
@@ -127,6 +128,12 @@ instance Hashable GetDependencyInformation
 instance NFData   GetDependencyInformation
 instance Binary   GetDependencyInformation
 
+data GetModuleGraph = GetModuleGraph
+    deriving (Eq, Show, Typeable, Generic)
+instance Hashable GetModuleGraph
+instance NFData   GetModuleGraph
+instance Binary   GetModuleGraph
+
 data ReportImportCycles = ReportImportCycles
     deriving (Eq, Show, Typeable, Generic)
 instance Hashable ReportImportCycles

src/Development/IDE/Core/Rules.hs

@@ -30,6 +30,7 @@ module Development.IDE.Core.Rules(
 import Fingerprint
 
 import Data.Binary
+import Util
 import Data.Bifunctor (second)
 import Control.Monad.Extra
 import Control.Monad.Trans.Class
@@ -55,8 +56,10 @@ import qualified Data.IntMap.Strict as IntMap
 import Data.IntMap.Strict (IntMap)
 import qualified Data.IntSet as IntSet
 import Data.List
+import Data.List.NonEmpty (NonEmpty(..))
 import Data.Ord
 import qualified Data.Set                                 as Set
+import qualified Data.HashSet                             as HS
 import qualified Data.Text                                as T
 import           Development.IDE.GHC.Error
 import           Development.Shake                        hiding (Diagnostic)
@@ -278,51 +281,53 @@ getLocatedImportsRule =
 
 -- | Given a target file path, construct the raw dependency results by following
 -- imports recursively.
-rawDependencyInformation :: NormalizedFilePath -> Action RawDependencyInformation
-rawDependencyInformation f = do
-    let initialArtifact = ArtifactsLocation f (ModLocation (Just $ fromNormalizedFilePath f) "" "") False
-        (initialId, initialMap) = getPathId initialArtifact emptyPathIdMap
-    (rdi, ss) <- go (IntSet.singleton $ getFilePathId initialId)
-                    (RawDependencyInformation IntMap.empty initialMap IntMap.empty, IntMap.empty)
+rawDependencyInformation :: [NormalizedFilePath] -> Action RawDependencyInformation
+rawDependencyInformation fs = do
+--    let initialArtifact = ArtifactsLocation f (ModLocation (Just $ fromNormalizedFilePath f) "" "") False
+--        (initialId, initialMap) = getPathId initialArtifact emptyPathIdMap
+    (_, rdi, ss) <- go fs
+                    ((RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty), IntMap.empty)
     let bm = IntMap.foldrWithKey (updateBootMap rdi) IntMap.empty ss
     return (rdi { rawBootMap = bm })
   where
-    go fs (rawDepInfo, ss) =
-        case IntSet.minView fs of
-            -- Queue is empty
-            Nothing -> pure (rawDepInfo, ss)
-            -- Pop f from the queue and process it
-            Just (f, fs) -> do
-                let fId = FilePathId f
-                importsOrErr <- use GetLocatedImports $ idToPath (rawPathIdMap rawDepInfo) fId
-                case importsOrErr of
-                  Nothing ->
-                    -- File doesn’t parse
-                    let rawDepInfo' = insertImport fId (Left ModuleParseError) rawDepInfo
-                    in go fs (rawDepInfo', ss)
-                  Just (modImports, pkgImports) -> do
-                    let f :: (PathIdMap, IntMap ArtifactsLocation)
-                          -> (a, Maybe ArtifactsLocation)
-                          -> ((PathIdMap, IntMap ArtifactsLocation), (a, Maybe FilePathId))
-                        f (pathMap, ss) (imp, mbPath) = case mbPath of
-                            Nothing -> ((pathMap, ss), (imp, Nothing))
-                            Just path ->
-                                let (pathId, pathMap') = getPathId path pathMap
-                                    ss' = if isBootLocation path
-                                            then IntMap.insert (getFilePathId pathId) path ss
-                                            else ss
-                                in ((pathMap', ss'), (imp, Just pathId))
-                    -- Convert paths in imports to ids and update the path map
-                    let ((pathIdMap, ss'), modImports') = mapAccumL f (rawPathIdMap rawDepInfo, ss) modImports
-                    -- Files that we haven’t seen before are added to the queue.
-                    let newFiles =
-                            IntSet.fromList (coerce $ mapMaybe snd modImports')
-                            IntSet.\\ IntMap.keysSet (rawImports rawDepInfo)
-                    let rawDepInfo' = insertImport fId (Right $ ModuleImports modImports' pkgImports) rawDepInfo
-                    go (newFiles `IntSet.union` fs)
-                       (rawDepInfo' { rawPathIdMap = pathIdMap }, ss')
-
-
+    go :: [NormalizedFilePath] -> (RawDependencyInformation, IntMap ArtifactsLocation)
+                               -> Action ([FilePathId], RawDependencyInformation, IntMap ArtifactsLocation)
+    go [] (r, i) = pure ([], r, i)
+    go (f:fs) a@(rawDepInfo, ss)
+      | Just fid <- lookupPathToId (rawPathIdMap rawDepInfo) f = do
+          (fids, r, bms) <- go fs a
+          return (fid: fids, r, bms)
+      | otherwise = do
+          al <- modSummaryToArtifactsLocation f <$> use_ GetModSummary f
+          importsOrErr <- use GetLocatedImports f
+          let (fId, path_map) = getPathId al (rawPathIdMap rawDepInfo)
+          let ss' = if isBootLocation al
+                      then IntMap.insert (getFilePathId fId) al ss
+                      else ss
+          let rawDepInfo' = rawDepInfo { rawPathIdMap = path_map }
+          case importsOrErr of
+            Nothing -> do
+            -- File doesn’t parse
+              let rawDepInfo'' = insertImport fId (Left ModuleParseError) rawDepInfo'
+              (fids, r1, r2) <- go fs (rawDepInfo'', ss)
+              return (fId: fids, r1, r2)
+            Just (modImports, pkgImports) -> do
+              -- Get NFPs of the imports which have corresponding files
+              let (no_file, with_file) = splitImports modImports
+                  (mns, ls) = unzip with_file
+              (fids, d', ss'') <- go (map artifactFilePath ls) (rawDepInfo', ss')
+              let moduleImports' = map (,Nothing) no_file ++ zipEqual "raw_dep" mns (map Just fids)
+              let rawDepInfo'' = insertImport fId (Right $ ModuleImports moduleImports' pkgImports) d'
+              (fids, r1, r2) <- go fs (rawDepInfo'', ss'')
+              return (fId : fids, r1, r2)
+
+    splitImports :: [(Located ModuleName, Maybe ArtifactsLocation)]
+                 -> ([Located (ModuleName)], [(Located ModuleName, ArtifactsLocation)])
+    splitImports [] = ([], [])
+    splitImports ((m, k):is) = let (ns, ls) = splitImports is
+                               in case k of
+                                    Nothing -> (m:ns, ls)
+                                    Just a  -> (ns, (m, a):ls)
 
     updateBootMap pm boot_mod_id ArtifactsLocation{..} bm =
       if not artifactIsSource
@@ -340,7 +345,7 @@ rawDependencyInformation f = do
 getDependencyInformationRule :: Rules ()
 getDependencyInformationRule =
     define $ \GetDependencyInformation file -> do
-       rawDepInfo <- rawDependencyInformation file
+       rawDepInfo <- rawDependencyInformation [file]
        pure ([], Just $ processDependencyInformation rawDepInfo)
 
 reportImportCyclesRule :: Rules ()
@@ -420,6 +425,13 @@ typeCheckRule = define $ \TypeCheck file -> do
     -- for files of interest on every keystroke
     typeCheckRuleDefinition file pm SkipGenerationOfInterfaceFiles
 
+getModuleGraphRule :: Rules ()
+getModuleGraphRule = defineNoFile $ \GetModuleGraph -> do
+  fs <- knownFiles
+  rawDepInfo <- rawDependencyInformation (HS.toList fs)
+  pure (processDependencyInformation rawDepInfo)
+
+
 data GenerateInterfaceFiles
     = DoGenerateInterfaceFiles
     | SkipGenerationOfInterfaceFiles
@@ -556,7 +568,9 @@ getHiFileRule = defineEarlyCutoff $ \GetHiFile f -> do
         else do
           hiVersion  <- use_ GetModificationTime hiFile
           modVersion <- use_ GetModificationTime f
-          let sourceModified = modificationTime hiVersion < modificationTime modVersion
+          -- This used to not detect changes to unsaved files correct so it's
+          -- important to use newerFileVersion
+          let sourceModified = newerFileVersion modVersion hiVersion
           if sourceModified
             then do
               let d = mkInterfaceFilesGenerationDiag f "Stale interface file"
@@ -645,3 +659,4 @@ mainRule = do
     getModIfaceRule
     isFileOfInterestRule
     getModSummaryRule
+    getModuleGraphRule