@@ -72,6 +72,7 @@ import qualified Data.SortedList as SL
7272import Development.IDE.Types.Diagnostics
7373import Development.IDE.Types.Location
7474import Development.IDE.Types.Options
75+import Control.Concurrent.Async
7576import Control.Concurrent.Extra
7677import Control.Exception
7778import Control.DeepSeq
@@ -378,11 +379,11 @@ shakeShut IdeState{..} = withMVar shakeAbort $ \stop -> do
378379
379380-- | This is a variant of withMVar where the first argument is run unmasked and if it throws
380381-- an exception, the previous value is restored while the second argument is executed masked.
381−withMVar' :: MVar a -> (a -> IO b) -> (b -> IO (a, c)) -> IO c
382+withMVar' :: MVar a -> (a -> IO ()) -> IO (a, c) -> IO c
382383withMVar' var unmasked masked = mask $ \restore -> do
383384 a <- takeMVar var
384− b <- restore (unmasked a) `onException` putMVar var a
385− (a', c) <- masked b
385+ restore (unmasked a) `onException` putMVar var a
386+ (a', c) <- masked
386387 putMVar var a'
387388 pure c
388389
@@ -394,29 +395,31 @@ shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts =
394395 (\stop -> do
395396 (stopTime,_) <- duration stop
396397 logDebug logger $ T.pack $ "Starting shakeRun (aborting the previous one took " ++ showDuration stopTime ++ ")"
397− bar <- newBarrier
398− start <- offsetTime
399− pure (start, bar))
398+ )
400399 -- It is crucial to be masked here, otherwise we can get killed
401400 -- between spawning the new thread and updating shakeAbort.
402401 -- See https://github.com/digital-asset/ghcide/issues/79
403− (\(start, bar) -> do
404− thread <- forkFinally (shakeRunDatabaseProfile shakeProfileDir shakeDb acts) $ \res -> do
405− runTime <- start
406− let res' = case res of
407− Left e -> "exception: " <> displayException e
408− Right _ -> "completed"
409− profile = case res of
410− Right (_, Just fp) ->
411− let link = case filePathToUri' $ toNormalizedFilePath fp of
412− NormalizedUri x -> x
413− in ", profile saved at " <> T.unpack link
414− _ -> ""
415− logDebug logger $ T.pack $
416− "Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ res' ++ profile ++ ")"
417− signalBarrier bar (fst <$> res)
418− -- important: we send an async exception to the thread, then wait for it to die, before continuing
419− pure (killThread thread >> void (waitBarrier bar), either throwIO return =<< waitBarrier bar))
402+ (do
403+ start <- offsetTime
404+ aThread <- asyncWithUnmask $ \restore -> do
405+ res <- try (restore $ shakeRunDatabaseProfile shakeProfileDir shakeDb acts)
406+ runTime <- start
407+ let res' = case res of
408+ Left e -> "exception: " <> displayException e
409+ Right _ -> "completed"
410+ profile = case res of
411+ Right (_, Just fp) ->
412+ let link = case filePathToUri' $ toNormalizedFilePath fp of
413+ NormalizedUri x -> x
414+ in ", profile saved at " <> T.unpack link
415+ _ -> ""
416+ let logMsg = logDebug logger $ T.pack $
417+ "Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ res' ++ profile ++ ")"
418+ return (fst <$> res, logMsg)
419+ let wrapUp (res, logMsg) = do
420+ () <- logMsg
421+ either (throwIO @SomeException) return res
422+ pure (cancel aThread, wrapUp =<< wait aThread))
420423
421424getDiagnostics :: IdeState -> IO [FileDiagnostic]
422425getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do