Formalize the ProgressReporting Type

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

@@ -69,9 +69,10 @@
 import           Data.Time                              (UTCTime (..))
 import           Data.Tuple.Extra                       (dupe)
 import           Debug.Trace
 import           Development.IDE.Core.FileStore         (resetInterfaceStore)
 import           Development.IDE.Core.Preprocessor
-import           Development.IDE.Core.ProgressReporting (ProgressReporting (..))
+import           Development.IDE.Core.ProgressReporting (ProgressReporting (..),
+                                                         progressReportingNoTrace, progressUpdate)
 import           Development.IDE.Core.RuleTypes
 import           Development.IDE.Core.Shake
 import           Development.IDE.Core.Tracing           (withTrace)
@@ -956,7 +957,7 @@
 
 
         convImport (L _ i) = (
                                (ideclPkgQual i)
                              , reLoc $ ideclName i)
 
         msrImports = implicit_imports ++ imps

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

@@ -1,15 +1,21 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies        #-}
+
 module Development.IDE.Core.ProgressReporting
   ( ProgressEvent (..),
     ProgressReporting (..),
+    ProgressReportingNoTrace,
     noProgressReporting,
     progressReporting,
-    progressReportingOutsideState,
+    progressReportingNoTrace,
     -- utilities, reexported for use in Core.Shake
     mRunLspT,
     mRunLspTCallback,
     -- for tests
     recordProgress,
     InProgressState (..),
+    progressStop,
+    progressUpdate
   )
 where
 
@@ -42,38 +48,60 @@ data ProgressEvent
   | ProgressCompleted
   | ProgressStarted
 
-data ProgressReporting m = ProgressReporting
-  { progressUpdate :: ProgressEvent -> m (),
-    inProgress     :: forall a. NormalizedFilePath -> m a -> m a,
-    -- ^ see Note [ProgressReporting API and InProgressState]
-    progressStop   :: IO ()
+data ProgressReportingNoTrace m = ProgressReportingNoTrace
+  { progressUpdateI :: ProgressEvent -> m (),
+    progressStopI   :: IO ()
     -- ^ we are using IO here because creating and stopping the `ProgressReporting`
     -- is different from how we use it.
   }
 
+data ProgressReporting m = ProgressReporting
+  {
+    inProgress             :: forall a. NormalizedFilePath -> m a -> m a,
+    -- ^ see Note [ProgressReporting API and InProgressState]
+    progressReportingInner :: ProgressReportingNoTrace m
+  }
+
+class ProgressReportingClass a where
+    type M a :: * -> *
+    progressUpdate ::  a -> ProgressEvent -> M a ()
+    progressStop :: a -> IO ()
+
+instance ProgressReportingClass (ProgressReportingNoTrace m) where
+    type M (ProgressReportingNoTrace m) = m
+    progressUpdate = progressUpdateI
+    progressStop = progressStopI
+
+instance ProgressReportingClass (ProgressReporting m) where
+    type M (ProgressReporting m) = m
+    progressUpdate :: ProgressReporting m -> ProgressEvent -> M (ProgressReporting m) ()
+    progressUpdate = progressUpdateI . progressReportingInner
+    progressStop = progressStopI . progressReportingInner
+
 {- Note [ProgressReporting API and InProgressState]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The progress of tasks can be tracked in two ways:
 
-1. `InProgressState`: This is an internal state that actively tracks the progress.
+1. `ProgressReporting`: we have an internal state that actively tracks the progress.
    Changes to the progress are made directly to this state.
 
-2. `InProgressStateOutSide`: This is an external state that tracks the progress.
+2. `ProgressReportingNoTrace`: there is an external state that tracks the progress.
    The external state is converted into an STM Int for the purpose of reporting progress.
 
-The `inProgress` function is only useful when we are using `InProgressState`.
-
-An alternative design could involve using GADTs to eliminate this discrepancy between
-`InProgressState` and `InProgressStateOutSide`.
+The `inProgress` function is only useful when we are using `ProgressReporting`.
 -}
 
+noProgressReportingNoTrace :: (MonadUnliftIO m) => (ProgressReportingNoTrace m)
+noProgressReportingNoTrace = ProgressReportingNoTrace
+      { progressUpdateI = const $ pure (),
+        progressStopI = pure ()
+      }
 noProgressReporting :: (MonadUnliftIO m) => IO (ProgressReporting m)
 noProgressReporting =
   return $
     ProgressReporting
-      { progressUpdate = const $ pure (),
-        inProgress = const id,
-        progressStop = pure ()
+      { inProgress = const id,
+        progressReportingInner = noProgressReportingNoTrace
       }
 
 -- | State used in 'delayedProgressReporting'
@@ -106,19 +134,11 @@ data InProgressState
         doneVar    :: TVar Int,
         currentVar :: STM.Map NormalizedFilePath Int
       }
-  | InProgressStateOutSide
-      -- we transform the outside state into STM Int for progress reporting purposes
-      { -- | Number of files to do
-        todo :: STM Int,
-        -- | Number of files done
-        done :: STM Int
-      }
 
 newInProgress :: IO InProgressState
 newInProgress = InProgressState <$> newTVarIO 0 <*> newTVarIO 0 <*> STM.newIO
 
 recordProgress :: InProgressState -> NormalizedFilePath -> (Int -> Int) -> IO ()
-recordProgress InProgressStateOutSide {} _ _ = return ()
 recordProgress InProgressState {..} file shift = do
   (prev, new) <- atomicallyNamed "recordProgress" $ STM.focus alterPrevAndNew file currentVar
   atomicallyNamed "recordProgress2" $ do
@@ -138,50 +158,44 @@ recordProgress InProgressState {..} file shift = do
     alter x = let x' = maybe (shift 0) shift x in Just x'
 
 
--- | `progressReporting` initiates a new progress reporting session.
--- It necessitates the active tracking of progress using the `inProgress` function.
--- Refer to Note [ProgressReporting API and InProgressState] for more details.
-progressReporting ::
-  (MonadUnliftIO m, MonadIO m) =>
-  Maybe (LSP.LanguageContextEnv c) ->
-  T.Text ->
-  ProgressReportingStyle ->
-  IO (ProgressReporting m)
-progressReporting = progressReporting' newInProgress
-
--- | `progressReportingOutsideState` initiates a new progress reporting session.
+-- | `progressReportingNoTrace` initiates a new progress reporting session.
 -- It functions similarly to `progressReporting`, but it utilizes an external state for progress tracking.
 -- Refer to Note [ProgressReporting API and InProgressState] for more details.
-progressReportingOutsideState ::
+progressReportingNoTrace ::
   (MonadUnliftIO m, MonadIO m) =>
   STM Int ->
   STM Int ->
   Maybe (LSP.LanguageContextEnv c) ->
   T.Text ->
   ProgressReportingStyle ->
-  IO (ProgressReporting m)
-progressReportingOutsideState todo done = progressReporting' (pure $ InProgressStateOutSide todo done)
+  IO (ProgressReportingNoTrace m)
+progressReportingNoTrace _ _ Nothing _title _optProgressStyle = return noProgressReportingNoTrace
+progressReportingNoTrace todo done (Just lspEnv) title optProgressStyle = do
+  progressState <- newVar NotStarted
+  let progressUpdateI event = liftIO $ updateStateVar $ Event event
+      progressStopI = updateStateVar StopProgress
+      updateStateVar = modifyVar_ progressState . updateState (progressCounter lspEnv title optProgressStyle todo done)
+  return ProgressReportingNoTrace {..}
 
-progressReporting' ::
+-- | `progressReporting` initiates a new progress reporting session.
+-- It necessitates the active tracking of progress using the `inProgress` function.
+-- Refer to Note [ProgressReporting API and InProgressState] for more details.
+progressReporting ::
+  forall c m.
   (MonadUnliftIO m, MonadIO m) =>
-  IO InProgressState ->
   Maybe (LSP.LanguageContextEnv c) ->
   T.Text ->
   ProgressReportingStyle ->
   IO (ProgressReporting m)
-progressReporting' _newState Nothing _title _optProgressStyle = noProgressReporting
-progressReporting' newState (Just lspEnv) title optProgressStyle = do
-  inProgressState <- newState
-  progressState <- newVar NotStarted
-  let progressUpdate event = liftIO $ updateStateVar $ Event event
-      progressStop = updateStateVar StopProgress
-      updateStateVar = modifyVar_ progressState . updateState (lspShakeProgressNew inProgressState)
+progressReporting Nothing _title _optProgressStyle = noProgressReporting
+progressReporting (Just lspEnv) title optProgressStyle = do
+  inProgressState <- newInProgress
+  progressReportingInner <- progressReportingNoTrace (readTVar $ todoVar inProgressState)
+                                (readTVar $ doneVar inProgressState) (Just lspEnv) title optProgressStyle
+  let inProgress :: forall a. NormalizedFilePath -> m a -> m a
       inProgress = updateStateForFile inProgressState
   return ProgressReporting {..}
   where
-    lspShakeProgressNew :: InProgressState -> IO ()
-    lspShakeProgressNew InProgressStateOutSide {..} = progressCounter lspEnv title optProgressStyle todo done
-    lspShakeProgressNew InProgressState {..} = progressCounter lspEnv title optProgressStyle (readTVar todoVar) (readTVar doneVar)
     updateStateForFile inProgress file = UnliftIO.bracket (liftIO $ f succ) (const $ liftIO $ f pred) . const
       where
         -- This functions are deliberately eta-expanded to avoid space leaks.

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

@@ -244,7 +244,7 @@ data HieDbWriter
   { indexQueue             :: IndexQueue
   , indexPending           :: TVar (HMap.HashMap NormalizedFilePath Fingerprint) -- ^ Avoid unnecessary/out of date indexing
   , indexCompleted         :: TVar Int -- ^ to report progress
-  , indexProgressReporting :: ProgressReporting IO
+  , indexProgressReporting :: ProgressReportingNoTrace IO
   }
 
 -- | Actions to queue up on the index worker thread
@@ -676,7 +676,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer
         indexPending <- newTVarIO HMap.empty
         indexCompleted <- newTVarIO 0
         semanticTokensId <- newTVarIO 0
-        indexProgressReporting <- progressReportingOutsideState
+        indexProgressReporting <- progressReportingNoTrace
             (liftM2 (+) (length <$> readTVar indexPending) (readTVar indexCompleted))
             (readTVar indexCompleted)
             lspEnv "Indexing" optProgressStyle