@@ -24,6 +24,7 @@ import Control.Monad.Extra
24
24
import Control.Monad.IO.Class
25
25
import qualified Crypto.Hash.SHA1 as H
26
26
import Data.Aeson (ToJSON (toJSON ))
27
+ import Data.Bifunctor (Bifunctor (second ))
27
28
import Data.ByteString.Base16 (encode )
28
29
import qualified Data.ByteString.Char8 as B
29
30
import Data.Default
@@ -199,7 +200,8 @@ main = do
199
200
runLanguageServer options (pluginHandler plugins) getInitialConfig getConfigFromNotification $ \ getLspId event vfs caps wProg wIndefProg -> do
200
201
t <- t
201
202
hPutStrLn stderr $ " Started LSP server in " ++ showDuration t
202
- let options = (defaultIdeOptions $ loadSessionShake dir)
203
+ sessionLoader <- loadSession dir
204
+ let options = (defaultIdeOptions sessionLoader)
203
205
{ optReportProgress = clientSupportsProgress caps
204
206
, optShakeProfiling = argsShakeProfiling
205
207
, optTesting = IdeTesting argsTesting
@@ -231,7 +233,8 @@ main = do
231
233
vfs <- makeVFSHandle
232
234
debouncer <- newAsyncDebouncer
233
235
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
235
238
236
239
putStrLn " \n Step 4/4: Type checking the files"
237
240
setFilesOfInterest ide $ HashSet. fromList $ map toNormalizedFilePath' files
@@ -300,40 +303,43 @@ targetToFile _ (TargetFile f _) = do
300
303
setNameCache :: IORef NameCache -> HscEnv -> HscEnv
301
304
setNameCache nc hsc = hsc { hsc_NC = nc }
302
305
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
-
310
306
-- | This is the key function which implements multi-component support. All
311
307
-- components mapping to the same hie.yaml file are mapped to the same
312
308
-- 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
315
311
-- Mapping from hie.yaml file to HscEnv, one per hie.yaml file
316
312
hscEnvs <- newVar Map. empty :: IO (Var HieMap )
317
313
-- Mapping from a Filepath to HscEnv
318
314
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'
319
328
320
329
libdir <- getLibdir
321
330
installationCheck <- ghcVersionChecker libdir
322
331
332
+ dummyAs <- async $ return (error " Uninitialised" )
333
+ runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq ,[FilePath ])))
334
+
323
335
case installationCheck of
324
336
InstallationNotFound {.. } ->
325
337
error $ " GHC installation not found in libdir: " <> libdir
326
338
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
337
343
338
344
-- Create a new HscEnv from a hieYaml root and a set of options
339
345
-- If the hieYaml file already has an HscEnv, the new component is
@@ -346,7 +352,8 @@ loadSession optTesting ShakeExtras{logger, eventer, withIndefiniteProgress, ideN
346
352
hscEnv <- emptyHscEnv ideNc
347
353
(df, targets) <- evalGhcEnv hscEnv $
348
354
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
350
357
-- Now lookup to see whether we are combining with an existing HscEnv
351
358
-- or making a new one. The lookup returns the HscEnv and a list of
352
359
-- information about other components loaded into the HscEnv
@@ -404,7 +411,7 @@ loadSession optTesting ShakeExtras{logger, eventer, withIndefiniteProgress, ideN
404
411
-- existing packages
405
412
pure (Map. insert hieYaml (newHscEnv, new_deps) m, (newHscEnv, head new_deps', tail new_deps'))
406
413
407
- let session :: (Maybe FilePath , NormalizedFilePath , ComponentOptions ) -> IO ([NormalizedFilePath ],IdeResult HscEnvEq )
414
+ let session :: (Maybe FilePath , NormalizedFilePath , ComponentOptions ) -> IO ([NormalizedFilePath ],( IdeResult HscEnvEq ,[ FilePath ]) )
408
415
session (hieYaml, cfp, opts) = do
409
416
(hscEnv, new, old_deps) <- packageSetup (hieYaml, cfp, opts)
410
417
-- 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
425
432
pure $ Map. insert hieYaml (HM. fromList (cs ++ cached_targets)) var
426
433
427
434
-- Invalidate all the existing GhcSession build nodes by restarting the Shake session
428
- -- restartShakeSession [kick]
435
+ invalidateShakeCache
436
+ restartShakeSession [kick]
429
437
430
- return (map fst cs, fst res)
438
+ return (map fst cs, second Map. keys res)
431
439
432
- let consultCradle :: Maybe FilePath -> FilePath -> IO ([NormalizedFilePath ], IdeResult HscEnvEq )
440
+ let consultCradle :: Maybe FilePath -> FilePath -> IO ([NormalizedFilePath ], ( IdeResult HscEnvEq , [ FilePath ]) )
433
441
consultCradle hieYaml cfp = do
434
442
when optTesting $ eventer $ notifyCradleLoaded cfp
435
443
logInfo logger $ T. pack (" Consulting the cradle for " <> show cfp)
@@ -454,10 +462,11 @@ loadSession optTesting ShakeExtras{logger, eventer, withIndefiniteProgress, ideN
454
462
let res = (map (renderCradleError ncfp) err, Nothing )
455
463
modifyVar_ fileToFlags $ \ var -> do
456
464
pure $ Map. insertWith HM. union hieYaml (HM. singleton ncfp (res, dep_info)) var
457
- return ([ncfp],res)
465
+ return ([ncfp],( res, [] ) )
458
466
459
467
-- 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 ]))
461
470
sessionOpts (hieYaml, file) = do
462
471
v <- fromMaybe HM. empty . Map. lookup hieYaml <$> readVar fileToFlags
463
472
cfp <- canonicalizePath file
@@ -472,38 +481,33 @@ loadSession optTesting ShakeExtras{logger, eventer, withIndefiniteProgress, ideN
472
481
-- Keep the same name cache
473
482
modifyVar_ hscEnvs (return . Map. adjust (\ (h, _) -> (h, [] )) hieYaml )
474
483
consultCradle hieYaml cfp
475
- else return ([] , opts)
484
+ else return ([] , ( opts, Map. keys old_di) )
476
485
Nothing -> consultCradle hieYaml cfp
477
486
478
- dummyAs <- async $ return (error " Uninitialised" )
479
- runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq )))
480
487
-- The main function which gets options for a file. We only want one of these running
481
488
-- at a time. Therefore the IORef contains the currently running cradle, if we try
482
489
-- to get some more options then we wait for the currently running action to finish
483
490
-- before attempting to do so.
484
- let getOptions :: FilePath -> IO ([NormalizedFilePath ],IdeResult HscEnvEq )
491
+ let getOptions :: FilePath -> IO ([NormalizedFilePath ],( IdeResult HscEnvEq , [ FilePath ]) )
485
492
getOptions file = do
486
493
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 ), [] ))
489
496
490
- return $ \ file -> do
497
+ returnWithVersion $ \ file -> do
491
498
(cs, opts) <- liftIO $ join $ mask_ $ modifyVar runningCradle $ \ as -> do
492
499
-- If the cradle is not finished, then wait for it to finish.
493
500
void $ wait as
494
501
as <- async $ getOptions file
495
502
return $ (fmap snd as, wait as)
496
- let cfps = cs
497
503
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
500
506
mmt <- uses GetModificationTime cfps'
501
507
let cs_exist = catMaybes (zipWith (<$) cfps' mmt)
502
508
uses GetModIface cs_exist
503
509
pure opts
504
510
505
-
506
-
507
511
-- | Create a mapping from FilePaths to HscEnvEqs
508
512
newComponentCache
509
513
:: Logger
0 commit comments