Typecheck entire project on Initial Load and typecheck reverse dependencies of a file on saving (#688)

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

Only propagate changes to parent modules when saving

Typecheck files when they are opened, don't TC FOI

Add known files rule

Don't save ifaces for files with defered errors

Co-authored-by: Zubin Duggal <zubin@cmi.ac.in>

* Add configuration for parent typechecking

* hlint ignore

* Use targets to filter located imports (#10)

* Use targets to filter located imports

* Remove import paths from the GHC session

Otherwise GHC will prioritize source files found in the import path

* Update session-loader/Development/IDE/Session.hs

Co-authored-by: Pepe Iborra <pepeiborra@me.com>

* Add session-loader to hie.yaml (#714)

* move known files rule to RuleTypes

* Disable checkParents on open and close document (#12)

* Really disable expensive checkParents

* Add an option to check parents on close

Co-authored-by: Matthew Pickering <matthewtpickering@gmail.com>
Co-authored-by: Pepe Iborra <pepeiborra@me.com>
Co-authored-by: Luke Lau <luke_lau@icloud.com>

Author: 4 people

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

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)
@@ -219,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
@@ -229,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
@@ -248,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