Typecheck entire project on Initial Load and typecheck reverse dependencies of a file on saving

README.md

@@ -95,6 +95,24 @@ If you can't get `ghcide` working outside the editor, see [this setup troublesho
 
 `ghcide` has been designed to handle projects with hundreds or thousands of modules. If `ghci` can handle it, then `ghcide` should be able to handle it. The only caveat is that this currently requires GHC >= 8.6, and that the first time a module is loaded in the editor will trigger generation of support files in the background if those do not already exist.
 
+### Configuration
+
+`ghcide` accepts the following lsp configuration options:
+
+```typescript
+{
+  // When to check the dependents of a module
+  // AlwaysCheck means retypechecking them on every change
+  // CheckOnSave means dependent/parent modules will only be checked when you save
+  // "CheckOnSaveAndClose" by default
+  checkParents : "NeverCheck" | "CheckOnClose" | "CheckOnSaveAndClose" | "AlwaysCheck" | ,
+  // Whether to check the entire project on initial load
+  // true by default
+  checkProject : boolean
+
+}
+```
+
 ### Using with VS Code
 
 You can install the VSCode extension from the [VSCode

exe/Main.hs

@@ -8,6 +8,7 @@ module Main(main) where
 import Arguments
 import Control.Concurrent.Extra
 import Control.Monad.Extra
+import Control.Lens ( (^.) )
 import Data.Default
 import Data.List.Extra
 import Data.Maybe
@@ -33,6 +34,7 @@ import Development.IDE.Session
 import qualified Language.Haskell.LSP.Core as LSP
 import Language.Haskell.LSP.Messages
 import Language.Haskell.LSP.Types
+import Language.Haskell.LSP.Types.Lens (params, initializationOptions)
 import Development.IDE.LSP.LanguageServer
 import qualified System.Directory.Extra as IO
 import System.Environment
@@ -44,6 +46,7 @@ import System.Time.Extra
 import Paths_ghcide
 import Development.GitRev
 import qualified Data.HashSet as HashSet
+import qualified Data.Aeson as J
 
 import HIE.Bios.Cradle
 
@@ -78,8 +81,13 @@ main = do
     command <- makeLspCommandId "typesignature.add"
 
     let plugins = Completions.plugin <> CodeAction.plugin
-        onInitialConfiguration = const $ Right ()
-        onConfigurationChange  = const $ Right ()
+        onInitialConfiguration :: InitializeRequest -> Either T.Text LspConfig
+        onInitialConfiguration x = case x ^. params . initializationOptions of
+          Nothing -> Right defaultLspConfig
+          Just v -> case J.fromJSON v of
+            J.Error err -> Left $ T.pack err
+            J.Success a -> Right a
+        onConfigurationChange = const $ Left "Updating Not supported"
         options = def { LSP.executeCommandCommands = Just [command]
                       , LSP.completionTriggerCharacters = Just "."
                       }
@@ -88,15 +96,18 @@ main = do
         t <- offsetTime
         hPutStrLn stderr "Starting LSP server..."
         hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"
-        runLanguageServer options (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps wProg wIndefProg -> do
+        runLanguageServer options (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps wProg wIndefProg getConfig -> do
             t <- t
             hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
             sessionLoader <- loadSession dir
+            config <- fromMaybe defaultLspConfig <$> getConfig
             let options = (defaultIdeOptions sessionLoader)
                     { optReportProgress = clientSupportsProgress caps
                     , optShakeProfiling = argsShakeProfiling
                     , optTesting        = IdeTesting argsTesting
                     , optThreads        = argsThreads
+                    , optCheckParents   = checkParents config
+                    , optCheckProject   = checkProject config
                     }
                 logLevel = if argsVerbose then minBound else Info
             debouncer <- newAsyncDebouncer

ghcide.cabal

@@ -263,6 +263,7 @@ executable ghcide
                 "-with-rtsopts=-I0 -qg -A128M"
     main-is: Main.hs
     build-depends:
+        aeson,
         base == 4.*,
         data-default,
         directory,
@@ -274,6 +275,7 @@ executable ghcide
         haskell-lsp-types,
         hie-bios >= 0.6.0 && < 0.7,
         ghcide,
+        lens,
         optparse-applicative,
         text,
         unordered-containers

hie.yaml

@@ -10,6 +10,8 @@ cradle:
               component: "ghcide:lib:ghcide"
             - path: "./exe"
               component: "ghcide:exe:ghcide"
+            - path: "./session-loader"
+              component: "ghcide:lib:ghcide"
             - path: "./test"
               component: "ghcide:test:ghcide-tests"
             - path: "./bench"

session-loader/Development/IDE/Session.hs

@@ -25,13 +25,16 @@ import Data.Bifunctor
 import qualified Data.ByteString.Base16 as B16
 import Data.Either.Extra
 import Data.Function
+import qualified Data.HashSet as HashSet
+import Data.Hashable
 import Data.List
 import Data.IORef
 import Data.Maybe
 import Data.Time.Clock
 import Data.Version
 import Development.IDE.Core.OfInterest
 import Development.IDE.Core.Shake
+import Development.IDE.Core.RuleTypes
 import Development.IDE.GHC.Util
 import Development.IDE.Session.VersionCheck
 import Development.IDE.Types.Diagnostics
@@ -47,6 +50,7 @@ import Language.Haskell.LSP.Core
 import Language.Haskell.LSP.Messages
 import Language.Haskell.LSP.Types
 import System.Directory
+import qualified System.Directory.Extra as IO
 import System.FilePath
 import System.Info
 import System.IO
@@ -96,8 +100,10 @@ loadSession dir = do
   runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq,[FilePath])))
 
   return $ do
-    ShakeExtras{logger, eventer, restartShakeSession, withIndefiniteProgress, ideNc} <- getShakeExtras
-    IdeOptions{optTesting = IdeTesting optTesting} <- getIdeOptions
+    ShakeExtras{logger, eventer, restartShakeSession, withIndefiniteProgress
+               ,ideNc, knownFilesVar, session=ideSession} <- getShakeExtras
+
+    IdeOptions{optTesting = IdeTesting optTesting, optCheckProject = CheckProject checkProject } <- 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
@@ -170,7 +176,7 @@ loadSession dir = do
 
 
     let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath)
-                -> IO (IdeResult HscEnvEq,[FilePath])
+                -> IO ([NormalizedFilePath],(IdeResult HscEnvEq,[FilePath]))
         session args@(hieYaml, _cfp, _opts, _libDir) = do
           (hscEnv, new, old_deps) <- packageSetup args
           -- Make a map from unit-id to DynFlags, this is used when trying to
@@ -194,9 +200,9 @@ loadSession dir = do
           invalidateShakeCache
           restartShakeSession [kick]
 
-          return (second Map.keys res)
+          return (map fst cs ++ map fst cached_targets, second Map.keys res)
 
-    let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath])
+    let consultCradle :: Maybe FilePath -> FilePath -> IO ([NormalizedFilePath], (IdeResult HscEnvEq, [FilePath]))
         consultCradle hieYaml cfp = do
            when optTesting $ eventer $ notifyCradleLoaded cfp
            logInfo logger $ T.pack ("Consulting the cradle for " <> show cfp)
@@ -206,8 +212,6 @@ loadSession dir = do
            -- cradle is
            let progMsg = "Setting up project " <> T.pack (takeBaseName (cradleRootDir cradle))
 
-
-
            eopts <- withIndefiniteProgress progMsg NotCancellable $
              cradleToOptsAndLibDir cradle cfp
 
@@ -221,7 +225,7 @@ loadSession dir = do
                  InstallationNotFound{..} ->
                      error $ "GHC installation not found in libdir: " <> libdir
                  InstallationMismatch{..} ->
-                     return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[])
+                     return ([],(([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[]))
                  InstallationChecked _compileTime _ghcLibCheck ->
                    session (hieYaml, toNormalizedFilePath' cfp, opts, libDir)
              -- Failure case, either a cradle error or the none cradle
@@ -231,11 +235,12 @@ loadSession dir = do
                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 ([ncfp],(res,[]))
 
     -- This caches the mapping from hie.yaml + Mod.hs -> [String]
     -- Returns the Ghc session and the cradle dependencies
-    let sessionOpts :: (Maybe FilePath, FilePath) -> IO (IdeResult HscEnvEq, [FilePath])
+    let sessionOpts :: (Maybe FilePath, FilePath)
+                    -> IO ([NormalizedFilePath], (IdeResult HscEnvEq, [FilePath]))
         sessionOpts (hieYaml, file) = do
           v <- fromMaybe HM.empty . Map.lookup hieYaml <$> readVar fileToFlags
           cfp <- canonicalizePath file
@@ -250,25 +255,38 @@ loadSession dir = do
                   -- Keep the same name cache
                   modifyVar_ hscEnvs (return . Map.adjust (\(h, _) -> (h, [])) hieYaml )
                   consultCradle hieYaml cfp
-                else return (opts, Map.keys old_di)
+                else return (HM.keys v, (opts, Map.keys old_di))
             Nothing -> consultCradle hieYaml cfp
 
     -- 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, [FilePath])
+    let getOptions :: FilePath -> IO ([NormalizedFilePath],(IdeResult HscEnvEq, [FilePath]))
         getOptions file = do
             hieYaml <- cradleLoc file
             sessionOpts (hieYaml, file) `catch` \e ->
-                return (([renderPackageSetupException file e], Nothing),[])
+                return ([],(([renderPackageSetupException file e], Nothing),[]))
 
     returnWithVersion $ \file -> do
-      liftIO $ join $ mask_ $ modifyVar runningCradle $ \as -> do
+      (cs, opts) <- 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)
+        return (fmap snd as, wait as)
+      unless (null cs) $
+        -- Typecheck all files in the project on startup
+        void $ shakeEnqueueSession ideSession $ mkDelayedAction "InitialLoad" Debug $ void $ do
+          cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) cs
+          -- populate the knownFilesVar with all the
+          -- files in the project so that `knownFiles` can learn about them and
+          -- we can generate a complete module graph
+          liftIO $ modifyVar_ knownFilesVar $ traverseHashed $ pure . HashSet.union (HashSet.fromList cfps')
+          mmt <- uses GetModificationTime cfps'
+          let cs_exist = catMaybes (zipWith (<$) cfps' mmt)
+          when checkProject $
+            void $ uses GetModIface cs_exist
+      pure opts
 
 -- | Run the specific cradle on a specific FilePath via hie-bios.
 -- This then builds dependencies or whatever based on the cradle, gets the

src/Development/IDE/Core/Compile.hs

@@ -19,7 +19,7 @@ module Development.IDE.Core.Compile
   , mkTcModuleResult
   , generateByteCode
   , generateAndWriteHieFile
-  , generateAndWriteHiFile
+  , writeHiFile
   , getModSummaryFromImports
   , loadHieFile
   , loadInterface
@@ -133,9 +133,10 @@ typecheckModule (IdeDefer defer) hsc pm = do
         (warnings, tcm) <- withWarnings "typecheck" $ \tweak ->
             GHC.typecheckModule $ enableTopLevelWarnings
                                 $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}
-        tcm2 <- mkTcModuleResult tcm
         let errorPipeline = unDefer . hideDiag dflags
-        return (map errorPipeline warnings, tcm2)
+            diags = map errorPipeline warnings
+        tcm2 <- mkTcModuleResult tcm (any fst diags)
+        return (map snd diags, tcm2)
     where
         demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id
 
@@ -233,11 +234,11 @@ update_pm_mod_summary :: (ModSummary -> ModSummary) -> ParsedModule -> ParsedMod
 update_pm_mod_summary up pm =
   pm{pm_mod_summary = up $ pm_mod_summary pm}
 
-unDefer :: (WarnReason, FileDiagnostic) -> FileDiagnostic
-unDefer (Reason Opt_WarnDeferredTypeErrors         , fd) = upgradeWarningToError fd
-unDefer (Reason Opt_WarnTypedHoles                 , fd) = upgradeWarningToError fd
-unDefer (Reason Opt_WarnDeferredOutOfScopeVariables, fd) = upgradeWarningToError fd
-unDefer ( _                                        , fd) = fd
+unDefer :: (WarnReason, FileDiagnostic) -> (Bool, FileDiagnostic)
+unDefer (Reason Opt_WarnDeferredTypeErrors         , fd) = (True, upgradeWarningToError fd)
+unDefer (Reason Opt_WarnTypedHoles                 , fd) = (True, upgradeWarningToError fd)
+unDefer (Reason Opt_WarnDeferredOutOfScopeVariables, fd) = (True, upgradeWarningToError fd)
+unDefer ( _                                        , fd) = (False, fd)
 
 upgradeWarningToError :: FileDiagnostic -> FileDiagnostic
 upgradeWarningToError (nfp, sh, fd) =
@@ -257,8 +258,9 @@ addRelativeImport fp modu dflags = dflags
 mkTcModuleResult
     :: GhcMonad m
     => TypecheckedModule
+    -> Bool
     -> m TcModuleResult
-mkTcModuleResult tcm = do
+mkTcModuleResult tcm upgradedError = do
     session <- getSession
     let sf = modInfoSafe (tm_checked_module_info tcm)
 #if MIN_GHC_API_VERSION(8,10,0)
@@ -267,7 +269,7 @@ mkTcModuleResult tcm = do
     (iface, _) <- liftIO $ mkIfaceTc session Nothing sf details tcGblEnv
 #endif
     let mod_info = HomeModInfo iface details Nothing
-    return $ TcModuleResult tcm mod_info
+    return $ TcModuleResult tcm mod_info upgradedError
   where
     (tcGblEnv, details) = tm_internals_ tcm
 
@@ -294,8 +296,8 @@ generateAndWriteHieFile hscEnv tcm =
     mod_location = ms_location mod_summary
     targetPath   = Compat.ml_hie_file mod_location
 
-generateAndWriteHiFile :: HscEnv -> TcModuleResult -> IO [FileDiagnostic]
-generateAndWriteHiFile hscEnv tc =
+writeHiFile :: HscEnv -> TcModuleResult -> IO [FileDiagnostic]
+writeHiFile hscEnv tc =
   handleGenerationErrors dflags "interface generation" $ do
     atomicFileWrite targetPath $ \fp ->
       writeIfaceFile dflags fp modIface

src/Development/IDE/Core/FileStore.hs

@@ -11,6 +11,7 @@ module Development.IDE.Core.FileStore(
     setSomethingModified,
     fileStoreRules,
     modificationTime,
+    typecheckParents,
     VFSHandle,
     makeVFSHandle,
     makeLSPVFSHandle
@@ -37,6 +38,7 @@ import Development.IDE.Types.Location
 import Development.IDE.Core.OfInterest (kick)
 import Development.IDE.Core.RuleTypes
 import qualified Data.Rope.UTF16 as Rope
+import Development.IDE.Import.DependencyInformation
 
 #ifdef mingw32_HOST_OS
 import qualified System.Directory as Dir
@@ -202,8 +204,14 @@ setBufferModified state absFile contents = do
 
 -- | Note that some buffer for a specific file has been modified but not
 -- with what changes.
-setFileModified :: IdeState -> NormalizedFilePath -> IO ()
-setFileModified state nfp = do
+setFileModified :: IdeState
+                -> Bool -- ^ True indicates that we should also attempt to recompile
+                        -- modules which depended on this file. Currently
+                        -- it is true when saving but not on normal
+                        -- document modification events
+                -> NormalizedFilePath
+                -> IO ()
+setFileModified state prop nfp = do
     VFSHandle{..} <- getIdeGlobalState state
     when (isJust setVirtualFileContents) $
         fail "setSomethingModified can't be called on this type of VFSHandle"
@@ -213,6 +221,22 @@ setFileModified state nfp = do
           void $ use GetSpanInfo nfp
           liftIO $ progressUpdate KickCompleted
     shakeRestart state [da]
+    when prop $
+      typecheckParents state nfp
+
+typecheckParents :: IdeState -> NormalizedFilePath -> IO ()
+typecheckParents state nfp = void $ shakeEnqueue state parents
+  where parents = mkDelayedAction "ParentTC" L.Debug (typecheckParentsAction nfp)
+
+typecheckParentsAction :: NormalizedFilePath -> Action ()
+typecheckParentsAction nfp = do
+    revs <- reverseDependencies nfp <$> useNoFile_ GetModuleGraph
+    logger <- logger <$> getShakeExtras
+    let log = L.logInfo logger . T.pack
+    liftIO $ do
+      (log $ "Typechecking reverse dependencies for" ++ show nfp ++ ": " ++ show revs)
+        `catch` \(e :: SomeException) -> log (show e)
+    () <$ 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/OfInterest.hs

@@ -80,8 +80,6 @@ modifyFilesOfInterest state f = do
     OfInterestVar var <- getIdeGlobalState state
     files <- modifyVar var $ pure . dupe . f
     logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show $ HashSet.toList files)
-    let das = map (\nfp -> mkDelayedAction "OfInterest" Debug (use GetSpanInfo nfp)) (HashSet.toList files)
-    shakeRestart state das
 
 -- | Typecheck all the files of interest.
 --   Could be improved