refactor: simplify spawnAsyncWithDbRegistration by removing registerHook parameter

Author: soulomoon

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

@@ -163,7 +163,7 @@ builderOne' parentKey db@Database {..} stack key = UE.uninterruptibleMask $ \res
     case (viewToRun $ keyStatus <$> status) of
       (Dirty prev) -> do
         SMap.focus (updateStatus $ Running current prev) key databaseValues
-        let register = spawnRefresh db stack key barrier prev (return ()) refresh
+        let register = spawnRefresh db stack key barrier prev refresh
                         -- why it is important to use rollback here
 
                         {- Note [Rollback is required if killed before registration]
@@ -384,17 +384,15 @@ spawnRefresh ::
   Key ->
   MVar (Either SomeException (Key, Result)) ->
   Maybe Result ->
-  STM () ->
   (Database -> t -> Key -> Maybe Result -> IO Result) ->
   (SomeException -> IO ()) ->
   (forall a. IO a -> IO a) ->
   IO ()
-spawnRefresh db@Database {..} stack key barrier prevResult registerHook  refresher rollBack restore = do
+spawnRefresh db@Database {..} stack key barrier prevResult refresher rollBack restore = do
   Step currentStep <- readTVarIO databaseStep
   spawnAsyncWithDbRegistration
     db
     (DeliverStatus currentStep ("async computation; " ++ show key) key)
-    registerHook
     (refresher db stack key prevResult)
     (\r -> do
         case r of

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

@@ -62,7 +62,6 @@ pattern Key :: () => (Typeable a, Hashable a, Show a) => a -> Key
 pattern Key a <- (lookupKeyValue -> (KeyValue a _))
 pattern DirectKey :: Int -> Key
 pattern DirectKey a <- (lookupKeyValue -> (DirectKeyValue a))
-{-# COMPLETE Key #-}
 {-# COMPLETE Key, DirectKey #-}
 
 instance Pretty Key where

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

@@ -372,15 +372,14 @@ isRootKey _              = False
 -- 4. Exception safety with rollback on registration failure
 -- @ inline
 {-# INLINE spawnAsyncWithDbRegistration #-}
-spawnAsyncWithDbRegistration :: Database -> DeliverStatus -> STM () -> IO a1 -> (Either SomeException a1 -> IO ()) -> (forall a. IO a -> IO a) -> IO ()
-spawnAsyncWithDbRegistration db@Database{..} deliver registerHook asyncBody handler restore = do
+spawnAsyncWithDbRegistration :: Database -> DeliverStatus -> IO a1 -> (Either SomeException a1 -> IO ()) -> (forall a. IO a -> IO a) -> IO ()
+spawnAsyncWithDbRegistration db@Database{..} deliver asyncBody handler restore = do
     startBarrier <- newEmptyTMVarIO
     -- 1. we need to make sure the thread is registered before we actually start
     -- 2. we should not start in between the restart
     -- 3. if it is killed before we start, we need to cancel the async
     let register a = do
                     dbNotLocked db
-                    registerHook
                     modifyTVar' databaseThreads ((deliver, a):)
                     -- make sure we only start after the restart
                     putTMVar startBarrier ()
@@ -394,7 +393,7 @@ spawnAsyncWithDbRegistration db@Database{..} deliver registerHook asyncBody hand
 {-# INLINE runInThreadStmInNewThreads #-}
 runInThreadStmInNewThreads :: Database -> DeliverStatus -> IO a -> (Either SomeException a -> IO ()) -> IO ()
 runInThreadStmInNewThreads db deliver act handler = uninterruptibleMask $ \restore ->
-        spawnAsyncWithDbRegistration db deliver (return ()) act handler restore
+        spawnAsyncWithDbRegistration db deliver act handler restore
 
 getDataBaseStepInt :: Database -> STM Int
 getDataBaseStepInt db = do