@@ -24,6 +24,7 @@ import Control.Monad.Extra
2424import Control.Monad.IO.Class
2525import qualified Crypto.Hash.SHA1 as H
2626import Data.Aeson (ToJSON (toJSON ))
27+ import Data.Bifunctor (Bifunctor (second ))
2728import Data.ByteString.Base16 (encode )
2829import qualified Data.ByteString.Char8 as B
2930import Data.Default
@@ -199,7 +200,8 @@ main = do
199200 runLanguageServer options (pluginHandler plugins) getInitialConfig getConfigFromNotification $ \ getLspId event vfs caps wProg wIndefProg -> do
200201 t <- t
201202 hPutStrLn stderr $ " Started LSP server in " ++ showDuration t
202- let options = (defaultIdeOptions $ loadSessionShake dir)
203+ sessionLoader <- loadSession dir
204+ let options = (defaultIdeOptions sessionLoader)
203205 { optReportProgress = clientSupportsProgress caps
204206 , optShakeProfiling = argsShakeProfiling
205207 , optTesting = IdeTesting argsTesting
@@ -231,7 +233,8 @@ main = do
231233 vfs <- makeVFSHandle
232234 debouncer <- newAsyncDebouncer
233235 let dummyWithProg _ _ f = f (const (pure () ))
234- ide <- initialise def mainRule (pure $ IdInt 0 ) (showEvent lock) dummyWithProg (const (const id )) (logger Info ) debouncer (defaultIdeOptions $ loadSessionShake dir) vfs
236+ sessionLoader <- loadSession dir
237+ ide <- initialise def mainRule (pure $ IdInt 0 ) (showEvent lock) dummyWithProg (const (const id )) (logger Info ) debouncer (defaultIdeOptions sessionLoader) vfs
235238
236239 putStrLn " \n Step 4/4: Type checking the files"
237240 setFilesOfInterest ide $ HashSet. fromList $ map toNormalizedFilePath' files
@@ -300,40 +303,43 @@ targetToFile _ (TargetFile f _) = do
300303setNameCache :: IORef NameCache -> HscEnv -> HscEnv
301304setNameCache nc hsc = hsc { hsc_NC = nc }
302305
303- loadSessionShake :: FilePath -> Action (FilePath -> Action (IdeResult HscEnvEq ))
304- loadSessionShake fp = do
305- se <- getShakeExtras
306- IdeOptions {optTesting = IdeTesting ideTesting} <- getIdeOptions
307- res <- liftIO $ loadSession ideTesting se fp
308- return res
309-
310306-- | This is the key function which implements multi-component support. All
311307-- components mapping to the same hie.yaml file are mapped to the same
312308-- HscEnv which is updated as new components are discovered.
313- loadSession :: Bool -> ShakeExtras -> FilePath -> IO (FilePath -> Action ( IdeResult HscEnvEq ) )
314- loadSession optTesting ShakeExtras {logger, eventer, withIndefiniteProgress, ideNc} dir = do
309+ loadSession :: FilePath -> IO (Action IdeGhcSession )
310+ loadSession dir = do
315311 -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file
316312 hscEnvs <- newVar Map. empty :: IO (Var HieMap )
317313 -- Mapping from a Filepath to HscEnv
318314 fileToFlags <- newVar Map. empty :: IO (Var FlagsMap )
315+ -- Version of the mappings above
316+ version <- newVar 0
317+ let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar version)
318+ let invalidateShakeCache = do
319+ modifyVar_ version (return . succ )
320+ -- This caches the mapping from Mod.hs -> hie.yaml
321+ cradleLoc <- liftIO $ memoIO $ \ v -> do
322+ res <- findCradle v
323+ -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path
324+ -- try and normalise that
325+ -- e.g. see https://github.com/digital-asset/ghcide/issues/126
326+ res' <- traverse IO. makeAbsolute res
327+ return $ normalise <$> res'
319328
320329 libdir <- getLibdir
321330 installationCheck <- ghcVersionChecker libdir
322331
332+ dummyAs <- async $ return (error " Uninitialised" )
333+ runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq ,[FilePath ])))
334+
323335 case installationCheck of
324336 InstallationNotFound {.. } ->
325337 error $ " GHC installation not found in libdir: " <> libdir
326338 InstallationMismatch {.. } ->
327- return $ \ fp -> return ([renderPackageSetupException compileTime fp GhcVersionMismatch {.. }], Nothing )
328- InstallationChecked compileTime ghcLibCheck -> do
329- -- This caches the mapping from Mod.hs -> hie.yaml
330- cradleLoc <- memoIO $ \ v -> do
331- res <- findCradle v
332- -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path
333- -- try and normalise that
334- -- e.g. see https://github.com/digital-asset/ghcide/issues/126
335- res' <- traverse IO. makeAbsolute res
336- return $ normalise <$> res'
339+ return $ returnWithVersion $ \ fp -> return (([renderPackageSetupException compileTime fp GhcVersionMismatch {.. }], Nothing ),[] )
340+ InstallationChecked compileTime ghcLibCheck -> return $ do
341+ ShakeExtras {logger, eventer, restartShakeSession, withIndefiniteProgress, ideNc, session= ideSession} <- getShakeExtras
342+ IdeOptions {optTesting = IdeTesting optTesting} <- getIdeOptions
337343
338344 -- Create a new HscEnv from a hieYaml root and a set of options
339345 -- If the hieYaml file already has an HscEnv, the new component is
@@ -346,7 +352,8 @@ loadSession optTesting ShakeExtras{logger, eventer, withIndefiniteProgress, ideN
346352 hscEnv <- emptyHscEnv ideNc
347353 (df, targets) <- evalGhcEnv hscEnv $
348354 setOptions opts (hsc_dflags hscEnv)
349- dep_info <- getDependencyInfo (componentDependencies opts ++ maybeToList hieYaml)
355+ let deps = componentDependencies opts ++ maybeToList hieYaml
356+ dep_info <- getDependencyInfo deps
350357 -- Now lookup to see whether we are combining with an existing HscEnv
351358 -- or making a new one. The lookup returns the HscEnv and a list of
352359 -- information about other components loaded into the HscEnv
@@ -404,7 +411,7 @@ loadSession optTesting ShakeExtras{logger, eventer, withIndefiniteProgress, ideN
404411 -- existing packages
405412 pure (Map. insert hieYaml (newHscEnv, new_deps) m, (newHscEnv, head new_deps', tail new_deps'))
406413
407- let session :: (Maybe FilePath , NormalizedFilePath , ComponentOptions ) -> IO ([NormalizedFilePath ],IdeResult HscEnvEq )
414+ let session :: (Maybe FilePath , NormalizedFilePath , ComponentOptions ) -> IO ([NormalizedFilePath ],( IdeResult HscEnvEq ,[ FilePath ]) )
408415 session (hieYaml, cfp, opts) = do
409416 (hscEnv, new, old_deps) <- packageSetup (hieYaml, cfp, opts)
410417 -- Make a map from unit-id to DynFlags, this is used when trying to
@@ -425,11 +432,12 @@ loadSession optTesting ShakeExtras{logger, eventer, withIndefiniteProgress, ideN
425432 pure $ Map. insert hieYaml (HM. fromList (cs ++ cached_targets)) var
426433
427434 -- Invalidate all the existing GhcSession build nodes by restarting the Shake session
428- -- restartShakeSession [kick]
435+ invalidateShakeCache
436+ restartShakeSession [kick]
429437
430- return (map fst cs, fst res)
438+ return (map fst cs, second Map. keys res)
431439
432- let consultCradle :: Maybe FilePath -> FilePath -> IO ([NormalizedFilePath ], IdeResult HscEnvEq )
440+ let consultCradle :: Maybe FilePath -> FilePath -> IO ([NormalizedFilePath ], ( IdeResult HscEnvEq , [ FilePath ]) )
433441 consultCradle hieYaml cfp = do
434442 when optTesting $ eventer $ notifyCradleLoaded cfp
435443 logInfo logger $ T. pack (" Consulting the cradle for " <> show cfp)
@@ -454,10 +462,11 @@ loadSession optTesting ShakeExtras{logger, eventer, withIndefiniteProgress, ideN
454462 let res = (map (renderCradleError ncfp) err, Nothing )
455463 modifyVar_ fileToFlags $ \ var -> do
456464 pure $ Map. insertWith HM. union hieYaml (HM. singleton ncfp (res, dep_info)) var
457- return ([ncfp],res)
465+ return ([ncfp],( res, [] ) )
458466
459467 -- This caches the mapping from hie.yaml + Mod.hs -> [String]
460- let sessionOpts :: (Maybe FilePath , FilePath ) -> IO ([NormalizedFilePath ],IdeResult HscEnvEq )
468+ -- Returns the Ghc session and the cradle dependencies
469+ let sessionOpts :: (Maybe FilePath , FilePath ) -> IO ([NormalizedFilePath ], (IdeResult HscEnvEq , [FilePath ]))
461470 sessionOpts (hieYaml, file) = do
462471 v <- fromMaybe HM. empty . Map. lookup hieYaml <$> readVar fileToFlags
463472 cfp <- canonicalizePath file
@@ -472,38 +481,33 @@ loadSession optTesting ShakeExtras{logger, eventer, withIndefiniteProgress, ideN
472481 -- Keep the same name cache
473482 modifyVar_ hscEnvs (return . Map. adjust (\ (h, _) -> (h, [] )) hieYaml )
474483 consultCradle hieYaml cfp
475- else return ([] , opts)
484+ else return ([] , ( opts, Map. keys old_di) )
476485 Nothing -> consultCradle hieYaml cfp
477486
478- dummyAs <- async $ return (error " Uninitialised" )
479- runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq )))
480487 -- The main function which gets options for a file. We only want one of these running
481488 -- at a time. Therefore the IORef contains the currently running cradle, if we try
482489 -- to get some more options then we wait for the currently running action to finish
483490 -- before attempting to do so.
484- let getOptions :: FilePath -> IO ([NormalizedFilePath ],IdeResult HscEnvEq )
491+ let getOptions :: FilePath -> IO ([NormalizedFilePath ],( IdeResult HscEnvEq , [ FilePath ]) )
485492 getOptions file = do
486493 hieYaml <- cradleLoc file
487- sessionOpts (hieYaml, file) `catch` \ e -> do
488- return ([] ,([renderPackageSetupException compileTime file e], Nothing ))
494+ sessionOpts (hieYaml, file) `catch` \ e ->
495+ return ([] ,(( [renderPackageSetupException compileTime file e], Nothing ), [] ))
489496
490- return $ \ file -> do
497+ returnWithVersion $ \ file -> do
491498 (cs, opts) <- liftIO $ join $ mask_ $ modifyVar runningCradle $ \ as -> do
492499 -- If the cradle is not finished, then wait for it to finish.
493500 void $ wait as
494501 as <- async $ getOptions file
495502 return $ (fmap snd as, wait as)
496- let cfps = cs
497503 unless (null cs) $
498- delay " InitialLoad" $ void $ do
499- cfps' <- liftIO $ filterM (IO. doesFileExist . fromNormalizedFilePath) cfps
504+ void $ shakeEnqueueSession ideSession $ mkDelayedAction " InitialLoad" Info $ void $ do
505+ cfps' <- liftIO $ filterM (IO. doesFileExist . fromNormalizedFilePath) cs
500506 mmt <- uses GetModificationTime cfps'
501507 let cs_exist = catMaybes (zipWith (<$) cfps' mmt)
502508 uses GetModIface cs_exist
503509 pure opts
504510
505-
506-
507511-- | Create a mapping from FilePaths to HscEnvEqs
508512newComponentCache
509513 :: Logger
0 commit comments