use AsyncParentKill exception to cancel session, minor imporvement to Step type.

Author: soulomoon

ghcide/src/Development/IDE/Core/Shake.hs

@@ -140,7 +140,8 @@ import           Development.IDE.GHC.Orphans            ()
 import           Development.IDE.Graph                  hiding (ShakeValue,
                                                          action)
 import qualified Development.IDE.Graph                  as Shake
-import           Development.IDE.Graph.Database         (ShakeDatabase,
+import           Development.IDE.Graph.Database         (AsyncParentKill (..),
+                                                         ShakeDatabase,
                                                          shakeGetBuildStep,
                                                          shakeGetDatabaseKeys,
                                                          shakeNewDatabase,
@@ -908,8 +909,11 @@ newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason = do
 
     --  Cancelling is required to flush the Shake database when either
     --  the filesystem or the Ghc configuration have changed
+    step <- shakeGetBuildStep shakeDb
     let cancelShakeSession :: IO ()
-        cancelShakeSession = cancel workThread
+        cancelShakeSession = do
+            tid <- myThreadId
+            cancelWith workThread $ AsyncParentKill tid step
 
     pure (ShakeSession{..})
 

ghcide/src/Development/IDE/Plugin/Test.hs

@@ -38,8 +38,7 @@ import           Development.IDE.Graph.Database       (ShakeDatabase,
                                                        shakeGetBuildEdges,
                                                        shakeGetBuildStep,
                                                        shakeGetCleanKeys)
-import           Development.IDE.Graph.Internal.Types (Result (resultBuilt, resultChanged, resultVisited),
-                                                       Step (Step))
+import           Development.IDE.Graph.Internal.Types (Result (resultBuilt, resultChanged, resultVisited))
 import qualified Development.IDE.Graph.Internal.Types as Graph
 import           Development.IDE.Types.Action
 import           Development.IDE.Types.HscEnvEq       (HscEnvEq (hscEnv))
@@ -145,7 +144,7 @@ getDatabaseKeys :: (Graph.Result -> Step)
 getDatabaseKeys field db = do
     keys <- shakeGetCleanKeys db
     step <- shakeGetBuildStep db
-    return [ k | (k, res) <- keys, field res == Step step]
+    return [ k | (k, res) <- keys, field res == step]
 
 parseAction :: CI String -> NormalizedFilePath -> Action (Either Text Bool)
 parseAction "typecheck" fp = Right . isJust <$> use TypeCheck fp

hls-graph/src/Development/IDE/Graph/Database.hs

@@ -1,4 +1,5 @@
 module Development.IDE.Graph.Database(
+    AsyncParentKill(..),
     ShakeDatabase,
     ShakeValue,
     shakeNewDatabase,
@@ -8,8 +9,8 @@ module Development.IDE.Graph.Database(
     shakeGetBuildStep,
     shakeGetDatabaseKeys,
     shakeGetDirtySet,
-    shakeGetCleanKeys
-    ,shakeGetBuildEdges) where
+    shakeGetCleanKeys,
+    shakeGetBuildEdges) where
 import           Control.Concurrent.STM.Stats            (readTVarIO)
 import           Data.Dynamic
 import           Data.Maybe
@@ -42,9 +43,9 @@ shakeGetDirtySet (ShakeDatabase _ _ db) =
     Development.IDE.Graph.Internal.Database.getDirtySet db
 
 -- | Returns the build number
-shakeGetBuildStep :: ShakeDatabase -> IO Int
+shakeGetBuildStep :: ShakeDatabase -> IO Step
 shakeGetBuildStep (ShakeDatabase _ _ db) = do
-    Step s <- readTVarIO $ databaseStep db
+    s <- readTVarIO $ databaseStep db
     return s
 
 -- Only valid if we never pull on the results, which we don't

hls-graph/src/Development/IDE/Graph/Internal/Types.hs

@@ -88,13 +88,7 @@ getDatabase = Action $ asks actionDatabase
 data ShakeDatabase = ShakeDatabase !Int [Action ()] Database
 
 newtype Step = Step Int
-    deriving newtype (Eq,Ord,Hashable,Show)
-
-
-getShakeStep :: MonadIO m => ShakeDatabase -> m Step
-getShakeStep (ShakeDatabase _ _ db) = do
-    s <- readTVarIO $ databaseStep db
-    return s
+    deriving newtype (Eq,Ord,Hashable,Show,Num,Enum,Real,Integral)
 
 ---------------------------------------------------------------------
 -- Keys