clean up

Author: soulomoon

cabal.project

@@ -56,9 +56,3 @@ if impl(ghc >= 9.11)
   allow-newer:
     cabal-install-parsers:base,
     cabal-install-parsers:time,
-
-source-repository-package
-  type: git
-  location: https://github.com/soulomoon/lsp.git
-  tag: 640c7c755bf16128e3cb19c257688aa3305ff9f5
-  subdir: lsp lsp-types lsp-test

ghcide-test/exe/ResolveTests.hs

@@ -24,7 +24,7 @@ import           Language.LSP.Test             hiding (resolveCompletion)
 import           Test.Hls                      (IdeState, SMethod (..), liftIO,
                                                 mkPluginTestDescriptor,
                                                 someMethodToMethodString,
-                                                waitForKickDone)
+                                                waitForAllProgressDone)
 import qualified Test.Hls.FileSystem           as FS
 import           Test.Tasty
 import           Test.Tasty.HUnit
@@ -100,7 +100,7 @@ resolveRequests =
         , "data Foo = Foo { foo :: Int }"
         , "bar = Foo 4"
         ]
-      waitForKickDone
+      waitForAllProgressDone
       items <- getCompletions doc (Position 2 7)
       let resolveCompItems = filter (\i -> "test item" `T.isPrefixOf` (i ^. J.label)) items
       liftIO $ assertEqual "There must be exactly two results" 2 (length resolveCompItems)
@@ -113,7 +113,7 @@ resolveRequests =
         , "data Foo = Foo { foo :: Int }"
         , "bar = Foo 4"
         ]
-      waitForKickDone
+      waitForAllProgressDone
       -- Cant use 'getAllCodeActions', as this lsp-test function queries the diagnostic
       -- locations and we don't have diagnostics in these tests.
       cas <- Maybe.mapMaybe (preview _R) <$> getCodeActions doc (Range (Position 0 0) (Position 1 0))
@@ -128,7 +128,7 @@ resolveRequests =
         , "data Foo = Foo { foo :: Int }"
         , "bar = Foo 4"
         ]
-      waitForKickDone
+      waitForAllProgressDone
       cd <- getCodeLenses doc
       let resolveCodeLenses = filter (\i -> case i ^. J.command of
             Just cmd -> "test item" `T.isPrefixOf` (cmd ^. J.title)

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

@@ -1,6 +1,5 @@
-{-# LANGUAGE CPP                #-}
-{-# LANGUAGE ImpredicativeTypes #-}
-{-# LANGUAGE TypeFamilies       #-}
+{-# LANGUAGE CPP          #-}
+{-# LANGUAGE TypeFamilies #-}
 
 {-|
 The logic for setting up a ghcide session by tapping into hie-bios.
@@ -105,7 +104,8 @@ 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           Development.IDE.Core.WorkerThread   (awaitRunInThread,
+                                                      withWorkerQueue)
 import qualified Development.IDE.GHC.Compat.Util     as Compat
 import           Development.IDE.Session.Diagnostics (renderCradleError)
 import           Development.IDE.Types.Shake         (WithHieDb,
@@ -119,7 +119,6 @@ import qualified System.Random                       as Random
 import           System.Random                       (RandomGen)
 import           Text.ParserCombinators.ReadP        (readP_to_S)
 
-import qualified Control.Monad.Catch                 as MC
 import           GHC.Driver.Env                      (hsc_all_home_unit_ids)
 import           GHC.Driver.Errors.Types
 import           GHC.Types.Error                     (errMsgDiagnostic,
@@ -150,12 +149,10 @@ data Log
   | LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
   | LogHieBios HieBios.Log
   | LogSessionLoadingChanged
-  | LogSessionWorkerThread LogWorkerThread
 deriving instance Show Log
 
 instance Pretty Log where
   pretty = \case
-    LogSessionWorkerThread msg -> pretty msg
     LogNoneCradleFound path ->
       "None cradle found for" <+> pretty path <+> ", ignoring the file"
     LogSettingInitialDynFlags ->
@@ -384,8 +381,8 @@ runWithDb recorder fp = ContT $ \k -> do
     _ <- withWriteDbRetryable deleteMissingRealFiles
     _ <- withWriteDbRetryable garbageCollectTypeNames
 
-    runContT (withWorkerQueue (cmapWithPrio LogSessionWorkerThread recorder) "hiedb thread" (writer withWriteDbRetryable))
-        $ \chan -> withHieDb fp (\readDb -> k (WithHieDbShield $ makeWithHieDbRetryable recorder rng readDb, chan))
+    runContT (withWorkerQueue (writer withWriteDbRetryable)) $ \chan ->
+        withHieDb fp (\readDb -> k (WithHieDbShield $ makeWithHieDbRetryable recorder rng readDb, chan))
   where
     writer withHieDbRetryable l = do
         -- TODO: probably should let exceptions be caught/logged/handled by top level handler
@@ -418,7 +415,7 @@ getHieDbLoc dir = do
 -- components mapping to the same hie.yaml file are mapped to the same
 -- HscEnv which is updated as new components are discovered.
 
-loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> TaskQueue (IO ()) -> IO (Action IdeGhcSession)
+loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> TQueue (IO ()) -> IO (Action IdeGhcSession)
 loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do
   let toAbsolutePath = toAbsolute rootDir -- see Note [Root Directory]
   cradle_files <- newIORef []
@@ -756,7 +753,6 @@ emptyHscEnv :: NameCache -> FilePath -> IO HscEnv
 emptyHscEnv nc libDir = do
     -- We call setSessionDynFlags so that the loader is initialised
     -- We need to do this before we call initUnits.
-    -- we mask_ here because asynchronous exceptions might be swallowed
     env <- runGhc (Just libDir) $
       getSessionDynFlags >>= setSessionDynFlags >> getSession
     pure $ setNameCache nc (hscSetFlags ((hsc_dflags env){useUnicode = True }) env)

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

@@ -75,7 +75,6 @@ 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.Core.Tracing                 (withTrace)
 import qualified Development.IDE.GHC.Compat                   as Compat
 import qualified Development.IDE.GHC.Compat                   as GHC
@@ -883,7 +882,7 @@ indexHieFile se mod_summary srcPath !hash hf = do
       -- hiedb doesn't use the Haskell src, so we clear it to avoid unnecessarily keeping it around
       let !hf' = hf{hie_hs_src = mempty}
       modifyTVar' indexPending $ HashMap.insert srcPath hash
-      writeTaskQueue indexQueue $ \withHieDb -> do
+      writeTQueue indexQueue $ \withHieDb -> do
         -- We are now in the worker thread
         -- Check if a newer index of this file has been scheduled, and if so skip this one
         newerScheduled <- atomically $ do

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

@@ -45,7 +45,6 @@ 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
@@ -253,8 +252,8 @@ getVersionedTextDoc doc = do
     maybe (pure Nothing) getVirtualFile $
         uriToNormalizedFilePath $ toNormalizedUri uri
   let ver = case mvf of
-        Just (VirtualFile lspver _ _ _) -> lspver
-        Nothing                         -> 0
+        Just (VirtualFile lspver _ _) -> lspver
+        Nothing                       -> 0
   return (VersionedTextDocumentIdentifier uri ver)
 
 fileStoreRules :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules ()
@@ -305,7 +304,7 @@ typecheckParentsAction recorder nfp = do
 setSomethingModified :: VFSModified -> IdeState -> String -> IO [Key] -> IO ()
 setSomethingModified vfs state reason actionBetweenSession = do
     -- Update database to remove any files that might have been renamed/deleted
-    atomically $ writeTaskQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles)
+    atomically $ writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles)
     void $ restartShakeSession (shakeExtras state) vfs reason [] actionBetweenSession
 
 registerFileWatches :: [String] -> LSP.LspT Config IO Bool

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

@@ -23,30 +23,24 @@ import           Control.Concurrent.STM         (STM)
 import           Control.Concurrent.STM.Stats   (TVar, atomically,
                                                  atomicallyNamed, modifyTVar',
                                                  newTVarIO, readTVar, retry)
-import           Control.Concurrent.Strict      (modifyVar_, newBarrier, newVar,
-                                                 signalBarrier, threadDelay)
+import           Control.Concurrent.Strict      (modifyVar_, newVar,
+                                                 threadDelay)
 import           Control.Monad.Extra            hiding (loop)
 import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Class      (lift)
-import qualified Data.Aeson                     as J
 import           Data.Functor                   (($>))
 import qualified Data.Text                      as T
-import           Data.Unique                    (hashUnique, newUnique)
 import           Development.IDE.GHC.Orphans    ()
 import           Development.IDE.Types.Location
 import           Development.IDE.Types.Options
 import qualified Focus
-import           Language.LSP.Protocol.Message
 import           Language.LSP.Protocol.Types
-import qualified Language.LSP.Protocol.Types    as L
-import           Language.LSP.Server            (MonadLsp, ProgressAmount (..),
+import           Language.LSP.Server            (ProgressAmount (..),
                                                  ProgressCancellable (..),
-                                                 sendNotification, sendRequest,
                                                  withProgress)
 import qualified Language.LSP.Server            as LSP
 import qualified StmContainers.Map              as STM
 import           UnliftIO                       (Async, async, bracket, cancel)
-import qualified UnliftIO.Exception             as UE
 
 data ProgressEvent
   = ProgressNewStarted
@@ -174,7 +168,7 @@ progressReportingNoTrace todo done (Just lspEnv) title optProgressStyle = do
   let _progressUpdate event = liftIO $ updateStateVar $ Event event
       _progressStop = updateStateVar StopProgress
       updateStateVar = modifyVar_ progressState . updateState (progressCounter lspEnv title optProgressStyle todo done)
-  return ProgressReporting {_progressUpdate, _progressStop}
+  return ProgressReporting {..}
 
 -- | `progressReporting` initiates a new progress reporting session.
 -- It necessitates the active tracking of progress using the `inProgress` function.
@@ -202,28 +196,6 @@ progressReporting (Just lspEnv) title optProgressStyle = do
 
         f = recordProgress inProgress file
 
-withProgressDummy ::
-  forall c m a.
-  MonadLsp c m =>
-  T.Text ->
-  Maybe ProgressToken ->
-  ProgressCancellable ->
-  ((ProgressAmount -> m ()) -> m a) ->
-  m a
-withProgressDummy title _ _ f = do
-        UE.bracket start end $ \_ ->
-            f (const $ return ())
-  where
-    sendProgressReport token report = sendNotification SMethod_Progress $ ProgressParams token $ J.toJSON report
-    start = UE.uninterruptibleMask_ $ do
-        t <- L.ProgressToken . L.InR . T.pack . show . hashUnique <$> liftIO newUnique
-        r <- liftIO newBarrier
-        _ <- sendRequest SMethod_WindowWorkDoneProgressCreate (WorkDoneProgressCreateParams t) $ \_ -> liftIO $ signalBarrier r ()
-        sendProgressReport t $ WorkDoneProgressBegin L.AString title Nothing Nothing Nothing
-        return t
-    end t = do
-        sendProgressReport t (WorkDoneProgressEnd L.AString Nothing)
-
 -- Kill this to complete the progress session
 progressCounter ::
   LSP.LanguageContextEnv c ->
@@ -233,12 +205,8 @@ progressCounter ::
   STM Int ->
   IO ()
 progressCounter lspEnv title optProgressStyle getTodo getDone =
-    LSP.runLspT lspEnv $ withProgressChoice title Nothing NotCancellable $ \update -> loop update 0
+  LSP.runLspT lspEnv $ withProgress title Nothing NotCancellable $ \update -> loop update 0
   where
-    withProgressChoice = case optProgressStyle of
-        TestReporting -> withProgressDummy
-        _             -> withProgress
-
     loop _ _ | optProgressStyle == NoProgress = forever $ liftIO $ threadDelay maxBound
     loop update prevPct = do
       (todo, done, nextPct) <- liftIO $ atomically $ do

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

@@ -516,8 +516,8 @@ persistentHieFileRule recorder = addPersistentRule GetHieAst $ \file -> runMaybe
   vfsRef <- asks vfsVar
   vfsData <- liftIO $ _vfsMap <$> readTVarIO vfsRef
   (currentSource, ver) <- liftIO $ case M.lookup (filePathToUri' file) vfsData of
-    Just (Open vf) -> pure (virtualFileText vf, Just $ virtualFileVersion vf)
-    _ -> (,Nothing) . T.decodeUtf8 <$> BS.readFile (fromNormalizedFilePath file)
+    Nothing -> (,Nothing) . T.decodeUtf8 <$> BS.readFile (fromNormalizedFilePath file)
+    Just vf -> pure (virtualFileText vf, Just $ virtualFileVersion vf)
   let refmap = generateReferencesMap . getAsts . Compat.hie_asts $ res
       del = deltaFromDiff (T.decodeUtf8 $ Compat.hie_hs_src res) currentSource
   pure (HAR (Compat.hie_module res) (Compat.hie_asts res) refmap mempty (HieFromDisk res),del,ver)

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

@@ -25,7 +25,7 @@ module Development.IDE.Core.Shake(
     IdeState, shakeSessionInit, shakeExtras, shakeDb, rootDir,
     ShakeExtras(..), getShakeExtras, getShakeExtrasRules,
     KnownTargets(..), Target(..), toKnownFiles, unionKnownTargets, mkKnownTargets,
-    IdeRule, IdeResult, RestartQueue,
+    IdeRule, IdeResult,
     GetModificationTime(GetModificationTime, GetModificationTime_, missingFileDiagnostics),
     shakeOpen, shakeShut,
     shakeEnqueue,
@@ -254,15 +254,12 @@ data HieDbWriter
 -- | Actions to queue up on the index worker thread
 -- The inner `(HieDb -> IO ()) -> IO ()` wraps `HieDb -> IO ()`
 -- with (currently) retry functionality
-type IndexQueue = TaskQueue (((HieDb -> IO ()) -> IO ()) -> IO ())
-type RestartQueue = TaskQueue (IO ())
-type LoaderQueue = TaskQueue (IO ())
-
+type IndexQueue = TQueue (((HieDb -> IO ()) -> IO ()) -> IO ())
 
 data ThreadQueue = ThreadQueue {
     tIndexQueue     :: IndexQueue
-    , tRestartQueue :: RestartQueue
-    , tLoaderQueue  :: LoaderQueue
+    , tRestartQueue :: TQueue (IO ())
+    , tLoaderQueue  :: TQueue (IO ())
 }
 
 -- Note [Semantic Tokens Cache Location]
@@ -333,9 +330,9 @@ data ShakeExtras = ShakeExtras
       -- ^ Default HLS config, only relevant if the client does not provide any Config
     , dirtyKeys :: TVar KeySet
       -- ^ Set of dirty rule keys since the last Shake run
-    , restartQueue :: RestartQueue
+    , restartQueue :: TQueue (IO ())
       -- ^ Queue of restart actions to be run.
-    , loaderQueue :: LoaderQueue
+    , loaderQueue :: TQueue (IO ())
       -- ^ Queue of loader actions to be run.
     }
 
@@ -393,16 +390,11 @@ addPersistentRule k getVal = do
 
 class Typeable a => IsIdeGlobal a where
 
--- data VirtualFileEntry = Open VirtualFile | Closed ClosedVirtualFile
-getOpenFile :: VirtualFileEntry -> Maybe VirtualFile
-getOpenFile (Open vf) = Just vf
-getOpenFile _         = Nothing
 -- | Read a virtual file from the current snapshot
 getVirtualFile :: NormalizedFilePath -> Action (Maybe VirtualFile)
 getVirtualFile nf = do
   vfs <- fmap _vfsMap . liftIO . readTVarIO . vfsVar =<< getShakeExtras
-  let file = getOpenFile =<< Map.lookup (filePathToUri' nf) vfs
-  pure $! file -- Don't leak a reference to the entire map
+  pure $! Map.lookup (filePathToUri' nf) vfs -- Don't leak a reference to the entire map
 
 -- Take a snapshot of the current LSP VFS
 vfsSnapshot :: Maybe (LSP.LanguageContextEnv a) -> IO VFS