new hls-graph runtime

Author: soulomoon

ghcide/ghcide.cabal

@@ -142,7 +142,6 @@ library
     Development.IDE.Core.Shake
     Development.IDE.Core.Tracing
     Development.IDE.Core.UseStale
-    Development.IDE.Core.WorkerThread
     Development.IDE.GHC.Compat
     Development.IDE.GHC.Compat.Core
     Development.IDE.GHC.Compat.CmdLine

ghcide/session-loader/Development/IDE/Session.hs

@@ -105,12 +105,12 @@ import qualified Data.HashSet                        as Set
 import qualified Data.Set                            as OS
 import           Database.SQLite.Simple
 import           Development.IDE.Core.Tracing        (withTrace)
-import           Development.IDE.Core.WorkerThread
 import qualified Development.IDE.GHC.Compat.Util     as Compat
 import           Development.IDE.Session.Diagnostics (renderCradleError)
 import           Development.IDE.Types.Shake         (WithHieDb,
                                                       WithHieDbShield (..),
                                                       toNoFileKey)
+import           Development.IDE.WorkerThread
 import           GHC.Data.Graph.Directed
 import           HieDb.Create
 import           HieDb.Types
@@ -153,6 +153,14 @@ data Log
   | LogSessionWorkerThread LogWorkerThread
 deriving instance Show Log
 
+instance Pretty LogWorkerThread where
+  pretty = \case
+    LogThreadEnding t -> "Worker thread ending:" <+> pretty t
+    LogThreadEnded t -> "Worker thread ended:" <+> pretty t
+    LogSingleWorkStarting t -> "Worker starting a unit of work: " <+> pretty t
+    LogSingleWorkEnded t -> "Worker ended a unit of work: " <+> pretty t
+    LogMainThreadId t tid -> "Main thread for" <+> pretty t <+> "is" <+> pretty (show tid)
+
 instance Pretty Log where
   pretty = \case
     LogSessionWorkerThread msg -> pretty msg
@@ -384,7 +392,7 @@ runWithDb recorder fp = ContT $ \k -> do
     _ <- withWriteDbRetryable deleteMissingRealFiles
     _ <- withWriteDbRetryable garbageCollectTypeNames
 
-    runContT (withWorkerQueue (cmapWithPrio LogSessionWorkerThread recorder) "hiedb thread" (writer withWriteDbRetryable))
+    runContT (withWorkerQueue (logWith (cmapWithPrio LogSessionWorkerThread recorder) Debug) "hiedb thread" (writer withWriteDbRetryable))
         $ \chan -> withHieDb fp (\readDb -> k (WithHieDbShield $ makeWithHieDbRetryable recorder rng readDb, chan))
   where
     writer withHieDbRetryable l = do

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

@@ -75,7 +75,7 @@ import           Development.IDE.Core.Preprocessor
 import           Development.IDE.Core.ProgressReporting       (progressUpdate)
 import           Development.IDE.Core.RuleTypes
 import           Development.IDE.Core.Shake
-import           Development.IDE.Core.WorkerThread            (writeTaskQueue)
+import           Development.IDE.WorkerThread            (writeTaskQueue)
 import           Development.IDE.Core.Tracing                 (withTrace)
 import qualified Development.IDE.GHC.Compat                   as Compat
 import qualified Development.IDE.GHC.Compat                   as GHC

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

@@ -45,14 +45,14 @@ import           Development.IDE.Core.IdeConfiguration        (isWorkspaceFile)
 import           Development.IDE.Core.RuleTypes
 import           Development.IDE.Core.Shake                   hiding (Log)
 import qualified Development.IDE.Core.Shake                   as Shake
-import           Development.IDE.Core.WorkerThread
 import           Development.IDE.GHC.Orphans                  ()
 import           Development.IDE.Graph
 import           Development.IDE.Import.DependencyInformation
 import           Development.IDE.Types.Diagnostics
 import           Development.IDE.Types.Location
 import           Development.IDE.Types.Options
 import           Development.IDE.Types.Shake                  (toKey)
+import           Development.IDE.WorkerThread
 import           HieDb.Create                                 (deleteMissingRealFiles)
 import           Ide.Logger                                   (Pretty (pretty),
                                                                Priority (Info),

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

@@ -46,14 +46,15 @@ import           Development.IDE.Core.IdeConfiguration
 import           Development.IDE.Core.Service          (shutdown)
 import           Development.IDE.Core.Shake            hiding (Log)
 import           Development.IDE.Core.Tracing
-import           Development.IDE.Core.WorkerThread
 import qualified Development.IDE.Session               as Session
 import           Development.IDE.Types.Shake           (WithHieDb,
                                                         WithHieDbShield (..))
+import           Development.IDE.WorkerThread
 import           Ide.Logger
 import           Language.LSP.Server                   (LanguageContextEnv,
                                                         LspServerLog,
                                                         type (<~>))
+import           System.Time.Extra                     (Seconds, sleep)
 import           System.Timeout                        (timeout)
 data Log
   = LogRegisteringIdeConfig !IdeConfiguration
@@ -67,10 +68,13 @@ data Log
   | LogShutDownTimeout Int
   | LogServerExitWith (Either () Int)
   | LogReactorShutdownConfirmed !T.Text
+  | LogInitializeIdeStateTookTooLong Seconds
   deriving Show
 
 instance Pretty Log where
   pretty = \case
+    LogInitializeIdeStateTookTooLong seconds ->
+        "Building the initial session took more than" <+> pretty seconds <+> "seconds"
     LogReactorShutdownRequested b ->
       "Requested reactor shutdown; stop signal posted: " <+> pretty b
     LogReactorShutdownConfirmed msg ->
@@ -350,8 +354,8 @@ handleInit initParams env (TRequestMessage _ _ m params) = otTracedHandler "Init
 runWithWorkerThreads :: Recorder (WithPriority Session.Log) -> FilePath -> (WithHieDb -> ThreadQueue -> IO ()) -> IO ()
 runWithWorkerThreads recorder dbLoc f = evalContT $ do
             (WithHieDbShield hiedb, threadQueue) <- runWithDb recorder dbLoc
-            sessionRestartTQueue <- withWorkerQueueSimple (cmapWithPrio Session.LogSessionWorkerThread recorder) "RestartTQueue"
-            sessionLoaderTQueue <- withWorkerQueueSimple (cmapWithPrio Session.LogSessionWorkerThread recorder) "SessionLoaderTQueue"
+            sessionRestartTQueue <- withWorkerQueueSimple (logWith (cmapWithPrio Session.LogSessionWorkerThread recorder) Debug) "RestartTQueue"
+            sessionLoaderTQueue <- withWorkerQueueSimple (logWith (cmapWithPrio Session.LogSessionWorkerThread recorder) Debug) "SessionLoaderTQueue"
             liftIO $ f hiedb (ThreadQueue threadQueue sessionRestartTQueue sessionLoaderTQueue)
 
 -- | Runs the action until it ends or until the given MVar is put.

ghcide/src/Development/IDE/LSP/LanguageServer.hs

@@ -65,11 +65,14 @@ library
     Development.IDE.Graph.KeyMap
     Development.IDE.Graph.KeySet
     Development.IDE.Graph.Rule
+    Development.IDE.WorkerThread
     Paths_hls_graph
 
   autogen-modules:    Paths_hls_graph
   hs-source-dirs:     src
   build-depends:
+    , mtl ^>=2.3.1
+    , safe-exceptions ^>=0.1.7.4
     , aeson
     , async                 >=2.0
     , base                  >=4.12    && <5
@@ -129,6 +132,7 @@ test-suite tests
     -threaded -rtsopts -with-rtsopts=-N -fno-ignore-asserts
 
   build-depends:
+    , transformers ^>=0.6.1.2
     , base
     , extra
     , hls-graph
@@ -138,5 +142,6 @@ test-suite tests
     , tasty
     , tasty-hspec >= 1.2
     , tasty-rerun
+    , transformers
 
   build-tool-depends: hspec-discover:hspec-discover

hls-graph/hls-graph.cabal

@@ -18,6 +18,7 @@ module Development.IDE.Graph(
     -- * Actions for inspecting the keys in the database
     getDirtySet,
     getKeysAndVisitedAge,
+
     module Development.IDE.Graph.KeyMap,
     module Development.IDE.Graph.KeySet,
     ) where

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

@@ -9,7 +9,8 @@ module Development.IDE.Graph.Database(
     shakeGetDatabaseKeys,
     shakeGetDirtySet,
     shakeGetCleanKeys
-    ,shakeGetBuildEdges) where
+    ,shakeGetBuildEdges,
+    shakeShutDatabase) where
 import           Control.Concurrent.STM.Stats            (readTVarIO)
 import           Data.Dynamic
 import           Data.Maybe
@@ -21,16 +22,20 @@ import           Development.IDE.Graph.Internal.Options
 import           Development.IDE.Graph.Internal.Profile  (writeProfile)
 import           Development.IDE.Graph.Internal.Rules
 import           Development.IDE.Graph.Internal.Types
+import           Development.IDE.WorkerThread            (TaskQueue)
 
 
 -- Placeholder to be the 'extra' if the user doesn't set it
 data NonExportedType = NonExportedType
 
-shakeNewDatabase :: ShakeOptions -> Rules () -> IO ShakeDatabase
-shakeNewDatabase opts rules = do
+shakeShutDatabase :: ShakeDatabase -> IO ()
+shakeShutDatabase (ShakeDatabase _ _ db) = shutDatabase db
+
+shakeNewDatabase :: TaskQueue (IO ()) -> ShakeOptions -> Rules () -> IO ShakeDatabase
+shakeNewDatabase que opts rules = do
     let extra = fromMaybe (toDyn NonExportedType) $ shakeExtra opts
     (theRules, actions) <- runRules extra rules
-    db <- newDatabase extra theRules
+    db <- newDatabase que extra theRules
     pure $ ShakeDatabase (length actions) actions db
 
 shakeRunDatabase :: ShakeDatabase -> [Action a] -> IO [a]