Finer dependencies for GhcSessionFun (#643)

* Cache the results of loadSession until the components change

* Track the cradle dependencies

* hlint

* Add cradle to watched files test

* Add comment on sessionVersion field

Author: pepeiborra

Diff for: exe/Main.hs

@@ -18,6 +18,7 @@ import Control.Concurrent.Extra
 import Control.Exception.Safe
 import Control.Monad.Extra
 import Control.Monad.IO.Class
+import Data.Bifunctor (Bifunctor(second))
 import Data.Default
 import Data.Either
 import Data.Foldable (for_)
@@ -122,7 +123,8 @@ main = do
         runLanguageServer options (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps wProg wIndefProg -> do
             t <- t
             hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
-            let options = (defaultIdeOptions $ loadSessionShake dir)
+            sessionLoader <- loadSession dir
+            let options = (defaultIdeOptions sessionLoader)
                     { optReportProgress = clientSupportsProgress caps
                     , optShakeProfiling = argsShakeProfiling
                     , optTesting        = IdeTesting argsTesting
@@ -154,7 +156,8 @@ main = do
         vfs <- makeVFSHandle
         debouncer <- newAsyncDebouncer
         let dummyWithProg _ _ f = f (const (pure ()))
-        ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) dummyWithProg (const (const id)) (logger minBound) debouncer (defaultIdeOptions $ loadSessionShake dir) vfs
+        sessionLoader <- loadSession dir
+        ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) dummyWithProg (const (const id)) (logger minBound) debouncer (defaultIdeOptions sessionLoader)  vfs
 
         putStrLn "\nStep 4/4: Type checking the files"
         setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath' files
@@ -223,40 +226,43 @@ targetToFile _ (TargetFile f _) = do
 setNameCache :: IORef NameCache -> HscEnv -> HscEnv
 setNameCache nc hsc = hsc { hsc_NC = nc }
 
-loadSessionShake :: FilePath -> Action (FilePath -> Action (IdeResult HscEnvEq))
-loadSessionShake fp = do
-  se <- getShakeExtras
-  IdeOptions{optTesting = IdeTesting ideTesting} <- getIdeOptions
-  res <- liftIO $ loadSession ideTesting se fp
-  return (fmap liftIO res)
-
 -- | This is the key function which implements multi-component support. All
 -- components mapping to the same hie.yaml file are mapped to the same
 -- HscEnv which is updated as new components are discovered.
-loadSession :: Bool -> ShakeExtras -> FilePath -> IO (FilePath -> IO (IdeResult HscEnvEq))
-loadSession optTesting ShakeExtras{logger, eventer, restartShakeSession, withIndefiniteProgress} dir = do
+loadSession :: FilePath -> IO (Action IdeGhcSession)
+loadSession dir = do
   -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file
   hscEnvs <- newVar Map.empty :: IO (Var HieMap)
   -- Mapping from a Filepath to HscEnv
   fileToFlags <- newVar Map.empty :: IO (Var FlagsMap)
+  -- Version of the mappings above
+  version <- newVar 0
+  let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar version)
+  let invalidateShakeCache = do
+        modifyVar_ version (return . succ)
+  -- This caches the mapping from Mod.hs -> hie.yaml
+  cradleLoc <- liftIO $ memoIO $ \v -> do
+      res <- findCradle v
+      -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path
+      -- try and normalise that
+      -- e.g. see https://github.com/digital-asset/ghcide/issues/126
+      res' <- traverse IO.makeAbsolute res
+      return $ normalise <$> res'
 
   libdir <- getLibdir
   installationCheck <- ghcVersionChecker libdir
 
+  dummyAs <- async $ return (error "Uninitialised")
+  runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq,[FilePath])))
+
   case installationCheck of
     InstallationNotFound{..} ->
         error $ "GHC installation not found in libdir: " <> libdir
     InstallationMismatch{..} ->
-        return $ \fp -> return ([renderPackageSetupException compileTime fp GhcVersionMismatch{..}], Nothing)
-    InstallationChecked compileTime ghcLibCheck -> do
-      -- This caches the mapping from Mod.hs -> hie.yaml
-      cradleLoc <- memoIO $ \v -> do
-          res <- findCradle v
-          -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path
-          -- try and normalise that
-          -- e.g. see https://github.com/digital-asset/ghcide/issues/126
-          res' <- traverse IO.makeAbsolute res
-          return $ normalise <$> res'
+        return $ returnWithVersion $ \fp -> return (([renderPackageSetupException compileTime fp GhcVersionMismatch{..}], Nothing),[])
+    InstallationChecked compileTime ghcLibCheck -> return $ do
+      ShakeExtras{logger, eventer, restartShakeSession, withIndefiniteProgress} <- getShakeExtras
+      IdeOptions{optTesting = IdeTesting optTesting} <- getIdeOptions
 
       -- Create a new HscEnv from a hieYaml root and a set of options
       -- If the hieYaml file already has an HscEnv, the new component is
@@ -269,7 +275,8 @@ loadSession optTesting ShakeExtras{logger, eventer, restartShakeSession, withInd
             hscEnv <- emptyHscEnv
             (df, targets) <- evalGhcEnv hscEnv $
                 setOptions opts (hsc_dflags hscEnv)
-            dep_info <- getDependencyInfo (componentDependencies opts ++ maybeToList hieYaml)
+            let deps = componentDependencies opts ++ maybeToList hieYaml
+            dep_info <- getDependencyInfo deps
             -- Now lookup to see whether we are combining with an existing HscEnv
             -- or making a new one. The lookup returns the HscEnv and a list of
             -- information about other components loaded into the HscEnv
@@ -329,7 +336,8 @@ loadSession optTesting ShakeExtras{logger, eventer, restartShakeSession, withInd
                 --   existing packages
                 pure (Map.insert hieYaml (newHscEnv, new_deps) m, (newHscEnv, head new_deps', tail new_deps'))
 
-      let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions) -> IO (IdeResult HscEnvEq)
+
+      let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions) -> IO (IdeResult HscEnvEq,[FilePath])
           session (hieYaml, cfp, opts) = do
             (hscEnv, new, old_deps) <- packageSetup (hieYaml, cfp, opts)
             -- Make a map from unit-id to DynFlags, this is used when trying to
@@ -350,11 +358,12 @@ loadSession optTesting ShakeExtras{logger, eventer, restartShakeSession, withInd
                 pure $ Map.insert hieYaml (HM.fromList (cs ++ cached_targets)) var
 
             -- Invalidate all the existing GhcSession build nodes by restarting the Shake session
+            invalidateShakeCache
             restartShakeSession [kick]
 
-            return (fst res)
+            return (second Map.keys res)
 
-      let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq)
+      let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath])
           consultCradle hieYaml cfp = do
              when optTesting $ eventer $ notifyCradleLoaded cfp
              logInfo logger $ T.pack ("Consulting the cradle for " <> show cfp)
@@ -379,10 +388,11 @@ loadSession optTesting ShakeExtras{logger, eventer, restartShakeSession, withInd
                  let res = (map (renderCradleError ncfp) err, Nothing)
                  modifyVar_ fileToFlags $ \var -> do
                    pure $ Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) var
-                 return res
+                 return (res,[])
 
       -- This caches the mapping from hie.yaml + Mod.hs -> [String]
-      let sessionOpts :: (Maybe FilePath, FilePath) -> IO (IdeResult HscEnvEq)
+      -- Returns the Ghc session and the cradle dependencies
+      let sessionOpts :: (Maybe FilePath, FilePath) -> IO (IdeResult HscEnvEq, [FilePath])
           sessionOpts (hieYaml, file) = do
             v <- fromMaybe HM.empty . Map.lookup hieYaml <$> readVar fileToFlags
             cfp <- canonicalizePath file
@@ -397,30 +407,26 @@ loadSession optTesting ShakeExtras{logger, eventer, restartShakeSession, withInd
                     -- Keep the same name cache
                     modifyVar_ hscEnvs (return . Map.adjust (\(h, _) -> (h, [])) hieYaml )
                     consultCradle hieYaml cfp
-                  else return opts
+                  else return (opts, Map.keys old_di)
               Nothing -> consultCradle hieYaml cfp
 
-      dummyAs <- async $ return (error "Uninitialised")
-      runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq)))
       -- The main function which gets options for a file. We only want one of these running
       -- at a time. Therefore the IORef contains the currently running cradle, if we try
       -- to get some more options then we wait for the currently running action to finish
       -- before attempting to do so.
-      let getOptions :: FilePath -> IO (IdeResult HscEnvEq)
+      let getOptions :: FilePath -> IO (IdeResult HscEnvEq, [FilePath])
           getOptions file = do
               hieYaml <- cradleLoc file
               sessionOpts (hieYaml, file) `catch` \e ->
-                  return ([renderPackageSetupException compileTime file e], Nothing)
+                  return (([renderPackageSetupException compileTime file e], Nothing),[])
 
-      return $ \file -> do
-        join $ mask_ $ modifyVar runningCradle $ \as -> do
+      returnWithVersion $ \file -> do
+        liftIO $ join $ mask_ $ modifyVar runningCradle $ \as -> do
           -- If the cradle is not finished, then wait for it to finish.
           void $ wait as
           as <- async $ getOptions file
           return (as, wait as)
 
-
-
 -- | Create a mapping from FilePaths to HscEnvEqs
 newComponentCache
          :: Logger

Diff for: src/Development/IDE/Core/Rules.hs

@@ -12,12 +12,14 @@
 --
 module Development.IDE.Core.Rules(
     IdeState, GetDependencies(..), GetParsedModule(..), TransitiveDependencies(..),
-    Priority(..), GhcSessionIO(..), GhcSessionFun(..),
+    Priority(..), GhcSessionIO(..),
     priorityTypeCheck,
     priorityGenerateCore,
     priorityFilesOfInterest,
     runAction, useE, useNoFileE, usesE,
-    toIdeResult, defineNoFile,
+    toIdeResult,
+    defineNoFile,
+    defineEarlyCutOffNoFile,
     mainRule,
     getAtPoint,
     getDefinition,
@@ -103,6 +105,11 @@ defineNoFile f = define $ \k file -> do
     if file == emptyFilePath then do res <- f k; return ([], Just res) else
         fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file"
 
+defineEarlyCutOffNoFile :: IdeRule k v => (k -> Action (ByteString, v)) -> Rules ()
+defineEarlyCutOffNoFile f = defineEarlyCutoff $ \k file -> do
+    if file == emptyFilePath then do (hash, res) <- f k; return (Just hash, ([], Just res)) else
+        fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file"
+
 
 ------------------------------------------------------------
 -- Exposed API
@@ -535,33 +542,36 @@ generateByteCodeRule =
 -- A local rule type to get caching. We want to use newCache, but it has
 -- thread killed exception issues, so we lift it to a full rule.
 -- https://github.com/digital-asset/daml/pull/2808#issuecomment-529639547
-type instance RuleResult GhcSessionIO = GhcSessionFun
+type instance RuleResult GhcSessionIO = IdeGhcSession
 
 data GhcSessionIO = GhcSessionIO deriving (Eq, Show, Typeable, Generic)
 instance Hashable GhcSessionIO
 instance NFData   GhcSessionIO
 instance Binary   GhcSessionIO
 
-newtype GhcSessionFun = GhcSessionFun (FilePath -> Action (IdeResult HscEnvEq))
-instance Show GhcSessionFun where show _ = "GhcSessionFun"
-instance NFData GhcSessionFun where rnf !_ = ()
-
-
 loadGhcSession :: Rules ()
 loadGhcSession = do
-    defineNoFile $ \GhcSessionIO -> do
+    -- This function should always be rerun because it tracks changes
+    -- to the version of the collection of HscEnv's.
+    defineEarlyCutOffNoFile $ \GhcSessionIO -> do
+        alwaysRerun
         opts <- getIdeOptions
-        GhcSessionFun <$> optGhcSession opts
-    -- This function should always be rerun because it consults a cache to
-    -- see what HscEnv needs to be used for the file, which can change.
-    -- However, it should also cut-off early if it's the same HscEnv as
-    -- last time
+        res <- optGhcSession opts
+
+        let fingerprint = hash (sessionVersion res)
+        return (BS.pack (show fingerprint), res)
+
     defineEarlyCutoff $ \GhcSession file -> do
-        GhcSessionFun fun <- useNoFile_ GhcSessionIO
-        alwaysRerun
-        val <- fun $ fromNormalizedFilePath file
+        IdeGhcSession{loadSessionFun} <- useNoFile_ GhcSessionIO
+        (val,deps) <- liftIO $ loadSessionFun $ fromNormalizedFilePath file
+
+        -- add the deps to the Shake graph
+        let addDependency fp = do
+                let nfp = toNormalizedFilePath' fp
+                itExists <- getFileExists nfp
+                when itExists $ void $ use_ GetModificationTime nfp
+        mapM_ addDependency deps
 
-        -- TODO: What was this doing before?
         opts <- getIdeOptions
         let cutoffHash =
               case optShakeFiles opts of

Diff for: src/Development/IDE/Types/Options.hs

@@ -14,6 +14,7 @@ module Development.IDE.Types.Options
   , IdePkgLocationOptions(..)
   , defaultIdeOptions
   , IdeResult
+  , IdeGhcSession(..)
   ) where
 
 import Development.Shake
@@ -23,12 +24,23 @@ import           GhcPlugins                     as GHC hiding (fst3, (<>))
 import qualified Language.Haskell.LSP.Types.Capabilities as LSP
 import qualified Data.Text as T
 import Development.IDE.Types.Diagnostics
+import Control.DeepSeq (NFData(..))
+
+data IdeGhcSession = IdeGhcSession
+  { loadSessionFun :: FilePath -> IO (IdeResult HscEnvEq, [FilePath])
+  -- ^ Returns the Ghc session and the cradle dependencies
+  , sessionVersion :: !Int
+  -- ^ Used as Shake key, versions must be unique and not reused
+  }
+
+instance Show IdeGhcSession where show _ = "IdeGhcSession"
+instance NFData IdeGhcSession where rnf !_ = ()
 
 data IdeOptions = IdeOptions
   { optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource
     -- ^ Preprocessor to run over all parsed source trees, generating a list of warnings
     --   and a list of errors, along with a new parse tree.
-  , optGhcSession :: Action (FilePath -> Action (IdeResult HscEnvEq))
+  , optGhcSession :: Action IdeGhcSession
     -- ^ Setup a GHC session for a given file, e.g. @Foo.hs@.
     --   For the same 'ComponentOptions' from hie-bios, the resulting function will be applied once per file.
     --   It is desirable that many files get the same 'HscEnvEq', so that more IDE features work.
@@ -80,7 +92,7 @@ clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress
 clientSupportsProgress caps = IdeReportProgress $ Just True ==
     (LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities))
 
-defaultIdeOptions :: Action (FilePath -> Action (IdeResult HscEnvEq)) -> IdeOptions
+defaultIdeOptions :: Action IdeGhcSession -> IdeOptions
 defaultIdeOptions session = IdeOptions
     {optPreprocessor = IdePreprocessedSource [] []
     ,optGhcSession = session

Diff for: test/exe/Main.hs

@@ -494,21 +494,23 @@ watchedFilesTests = testGroup "watched files"
       watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification
 
       -- Expect 4 subscriptions (A does not get any because it's VFS):
+      --  - /path-to-workspace/hie.yaml
       --  - /path-to-workspace/WatchedFilesMissingModule.hs
       --  - /path-to-workspace/WatchedFilesMissingModule.lhs
       --  - /path-to-workspace/src/WatchedFilesMissingModule.hs
       --  - /path-to-workspace/src/WatchedFilesMissingModule.lhs
-      liftIO $ length watchedFileRegs @?= 4
+      liftIO $ length watchedFileRegs @?= 5
 
   , testSession' "non workspace file" $ \sessionDir -> do
       liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-i/tmp\"]}}"
       _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"
       watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification
 
       -- Expect 2 subscriptions (/tmp does not get any as it is out of the workspace):
+      --  - /path-to-workspace/hie.yaml
       --  - /path-to-workspace/WatchedFilesMissingModule.hs
       --  - /path-to-workspace/WatchedFilesMissingModule.lhs
-      liftIO $ length watchedFileRegs @?= 2
+      liftIO $ length watchedFileRegs @?= 3
 
   -- TODO add a test for didChangeWorkspaceFolder
   ]