{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}

module Development.IDE.Core.ProgressReporting
  ( ProgressEvent (..),
    PerFileProgressReporting (..),
    ProgressReporting,
    noPerFileProgressReporting,
    progressReporting,
    progressReportingNoTrace,
    -- utilities, reexported for use in Core.Shake
    mRunLspT,
    mRunLspTCallback,
    -- for tests
    recordProgress,
    InProgressState (..),
    progressStop,
    progressUpdate
  )
where

import           Control.Concurrent.STM         (STM)
import           Control.Concurrent.STM.Stats   (TVar, atomically,
                                                 atomicallyNamed, modifyTVar',
                                                 newTVarIO, readTVar, retry)
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           Data.Functor                   (($>))
import qualified Data.Text                      as T
import           Development.IDE.GHC.Orphans    ()
import           Development.IDE.Types.Location
import           Development.IDE.Types.Options
import qualified Focus
import           Language.LSP.Protocol.Types
import           Language.LSP.Server            (ProgressAmount (..),
                                                 ProgressCancellable (..),
                                                 withProgress)
import qualified Language.LSP.Server            as LSP
import qualified StmContainers.Map              as STM
import           UnliftIO                       (Async, async, bracket, cancel)

data ProgressEvent
  = ProgressNewStarted
  | ProgressCompleted
  | ProgressStarted

data ProgressReporting = ProgressReporting
  { ProgressReporting -> ProgressEvent -> IO ()
_progressUpdate :: ProgressEvent -> IO (),
    ProgressReporting -> IO ()
_progressStop   :: IO ()
    -- ^ we are using IO here because creating and stopping the `ProgressReporting`
    -- is different from how we use it.
  }

data PerFileProgressReporting = PerFileProgressReporting
  {
    PerFileProgressReporting
-> forall a. NormalizedFilePath -> IO a -> IO a
inProgress             :: forall a. NormalizedFilePath -> IO a -> IO a,
    -- ^ see Note [ProgressReporting API and InProgressState]
    PerFileProgressReporting -> ProgressReporting
progressReportingInner :: ProgressReporting
  }

class ProgressReporter a where
    progressUpdate ::  a -> ProgressEvent -> IO ()
    progressStop :: a -> IO ()

instance ProgressReporter ProgressReporting where
    progressUpdate :: ProgressReporting -> ProgressEvent -> IO ()
progressUpdate = ProgressReporting -> ProgressEvent -> IO ()
_progressUpdate
    progressStop :: ProgressReporting -> IO ()
progressStop = ProgressReporting -> IO ()
_progressStop

instance ProgressReporter PerFileProgressReporting where
    progressUpdate :: PerFileProgressReporting -> ProgressEvent -> IO ()
progressUpdate = ProgressReporting -> ProgressEvent -> IO ()
_progressUpdate (ProgressReporting -> ProgressEvent -> IO ())
-> (PerFileProgressReporting -> ProgressReporting)
-> PerFileProgressReporting
-> ProgressEvent
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PerFileProgressReporting -> ProgressReporting
progressReportingInner
    progressStop :: PerFileProgressReporting -> IO ()
progressStop = ProgressReporting -> IO ()
_progressStop (ProgressReporting -> IO ())
-> (PerFileProgressReporting -> ProgressReporting)
-> PerFileProgressReporting
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PerFileProgressReporting -> ProgressReporting
progressReportingInner

{- Note [ProgressReporting API and InProgressState]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The progress of tasks can be tracked in two ways:

1. `ProgressReporting`: we have an internal state that actively tracks the progress.
   Changes to the progress are made directly to this state.

2. `ProgressReporting`: 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 `ProgressReporting`.
-}

noProgressReporting :: ProgressReporting
noProgressReporting :: ProgressReporting
noProgressReporting = ProgressReporting
      { _progressUpdate :: ProgressEvent -> IO ()
_progressUpdate = IO () -> ProgressEvent -> IO ()
forall a b. a -> b -> a
const (IO () -> ProgressEvent -> IO ())
-> IO () -> ProgressEvent -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (),
        _progressStop :: IO ()
_progressStop = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      }
noPerFileProgressReporting :: IO PerFileProgressReporting
noPerFileProgressReporting :: IO PerFileProgressReporting
noPerFileProgressReporting =
  PerFileProgressReporting -> IO PerFileProgressReporting
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PerFileProgressReporting -> IO PerFileProgressReporting)
-> PerFileProgressReporting -> IO PerFileProgressReporting
forall a b. (a -> b) -> a -> b
$
    PerFileProgressReporting
      { inProgress :: forall a. NormalizedFilePath -> IO a -> IO a
inProgress = (IO a -> IO a) -> NormalizedFilePath -> IO a -> IO a
forall a b. a -> b -> a
const IO a -> IO a
forall a. a -> a
id,
        progressReportingInner :: ProgressReporting
progressReportingInner = ProgressReporting
noProgressReporting
      }

-- | State used in 'delayedProgressReporting'
data State
  = NotStarted
  | Stopped
  | Running (Async ())

-- | State transitions used in 'delayedProgressReporting'
data Transition = Event ProgressEvent | StopProgress

updateState :: IO () -> Transition -> State -> IO State
updateState :: IO () -> Transition -> State -> IO State
updateState IO ()
_ Transition
_ State
Stopped = State -> IO State
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure State
Stopped
updateState IO ()
start (Event ProgressEvent
ProgressNewStarted) State
NotStarted = Async () -> State
Running (Async () -> State) -> IO (Async ()) -> IO State
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO () -> IO (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async IO ()
start
updateState IO ()
start (Event ProgressEvent
ProgressNewStarted) (Running Async ()
job) = Async () -> IO ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
cancel Async ()
job IO () -> IO State -> IO State
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Async () -> State
Running (Async () -> State) -> IO (Async ()) -> IO State
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO () -> IO (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async IO ()
start
updateState IO ()
start (Event ProgressEvent
ProgressStarted) State
NotStarted = Async () -> State
Running (Async () -> State) -> IO (Async ()) -> IO State
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO () -> IO (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async IO ()
start
updateState IO ()
_ (Event ProgressEvent
ProgressStarted) (Running Async ()
job) = State -> IO State
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Async () -> State
Running Async ()
job)
updateState IO ()
_ (Event ProgressEvent
ProgressCompleted) (Running Async ()
job) = Async () -> IO ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
cancel Async ()
job IO () -> State -> IO State
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> State
NotStarted
updateState IO ()
_ (Event ProgressEvent
ProgressCompleted) State
st = State -> IO State
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure State
st
updateState IO ()
_ Transition
StopProgress (Running Async ()
job) = Async () -> IO ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
cancel Async ()
job IO () -> State -> IO State
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> State
Stopped
updateState IO ()
_ Transition
StopProgress State
st = State -> IO State
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure State
st

-- | Data structure to track progress across the project
-- see Note [ProgressReporting API and InProgressState]
data InProgressState
  = InProgressState
      { -- | Number of files to do
        InProgressState -> TVar Int
todoVar    :: TVar Int,
        -- | Number of files done
        InProgressState -> TVar Int
doneVar    :: TVar Int,
        InProgressState -> Map NormalizedFilePath Int
currentVar :: STM.Map NormalizedFilePath Int
      }

newInProgress :: IO InProgressState
newInProgress :: IO InProgressState
newInProgress = TVar Int
-> TVar Int -> Map NormalizedFilePath Int -> InProgressState
InProgressState (TVar Int
 -> TVar Int -> Map NormalizedFilePath Int -> InProgressState)
-> IO (TVar Int)
-> IO (TVar Int -> Map NormalizedFilePath Int -> InProgressState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO (TVar Int)
forall a. a -> IO (TVar a)
newTVarIO Int
0 IO (TVar Int -> Map NormalizedFilePath Int -> InProgressState)
-> IO (TVar Int)
-> IO (Map NormalizedFilePath Int -> InProgressState)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO (TVar Int)
forall a. a -> IO (TVar a)
newTVarIO Int
0 IO (Map NormalizedFilePath Int -> InProgressState)
-> IO (Map NormalizedFilePath Int) -> IO InProgressState
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (Map NormalizedFilePath Int)
forall key value. IO (Map key value)
STM.newIO

recordProgress :: InProgressState -> NormalizedFilePath -> (Int -> Int) -> IO ()
recordProgress :: InProgressState -> NormalizedFilePath -> (Int -> Int) -> IO ()
recordProgress InProgressState {TVar Int
Map NormalizedFilePath Int
todoVar :: InProgressState -> TVar Int
doneVar :: InProgressState -> TVar Int
currentVar :: InProgressState -> Map NormalizedFilePath Int
todoVar :: TVar Int
doneVar :: TVar Int
currentVar :: Map NormalizedFilePath Int
..} NormalizedFilePath
file Int -> Int
shift = do
  (Maybe Int
prev, Int
new) <- String -> STM (Maybe Int, Int) -> IO (Maybe Int, Int)
forall a. String -> STM a -> IO a
atomicallyNamed String
"recordProgress" (STM (Maybe Int, Int) -> IO (Maybe Int, Int))
-> STM (Maybe Int, Int) -> IO (Maybe Int, Int)
forall a b. (a -> b) -> a -> b
$ Focus Int STM (Maybe Int, Int)
-> NormalizedFilePath
-> Map NormalizedFilePath Int
-> STM (Maybe Int, Int)
forall key value result.
Hashable key =>
Focus value STM result -> key -> Map key value -> STM result
STM.focus Focus Int STM (Maybe Int, Int)
alterPrevAndNew NormalizedFilePath
file Map NormalizedFilePath Int
currentVar
  String -> STM () -> IO ()
forall a. String -> STM a -> IO a
atomicallyNamed String
"recordProgress2" (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ case (Maybe Int
prev, Int
new) of
    (Maybe Int
Nothing, Int
0) -> TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
doneVar (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) STM () -> STM () -> STM ()
forall a b. STM a -> STM b -> STM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
todoVar (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    (Maybe Int
Nothing, Int
_) -> TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
todoVar (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    (Just Int
0, Int
0)  -> () -> STM ()
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    (Just Int
0, Int
_)  -> TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
doneVar Int -> Int
forall a. Enum a => a -> a
pred
    (Just Int
_, Int
0)  -> TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
doneVar (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    (Just Int
_, Int
_)  -> () -> STM ()
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    alterPrevAndNew :: Focus Int STM (Maybe Int, Int)
alterPrevAndNew = do
      Maybe Int
prev <- Focus Int STM (Maybe Int)
forall (m :: * -> *) a. Monad m => Focus a m (Maybe a)
Focus.lookup
      (Maybe Int -> Maybe Int) -> Focus Int STM ()
forall (m :: * -> *) a.
Monad m =>
(Maybe a -> Maybe a) -> Focus a m ()
Focus.alter Maybe Int -> Maybe Int
alter
      Int
new <- Int -> Focus Int STM Int
forall (m :: * -> *) a. Monad m => a -> Focus a m a
Focus.lookupWithDefault Int
0
      (Maybe Int, Int) -> Focus Int STM (Maybe Int, Int)
forall a. a -> Focus Int STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int
prev, Int
new)
    alter :: Maybe Int -> Maybe Int
alter Maybe Int
x = let x' :: Int
x' = Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int -> Int
shift Int
0) Int -> Int
shift Maybe Int
x in Int -> Maybe Int
forall a. a -> Maybe a
Just Int
x'


-- | `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.
progressReportingNoTrace ::
  STM Int ->
  STM Int ->
  Maybe (LSP.LanguageContextEnv c) ->
  T.Text ->
  ProgressReportingStyle ->
  IO ProgressReporting
progressReportingNoTrace :: forall c.
STM Int
-> STM Int
-> Maybe (LanguageContextEnv c)
-> Text
-> ProgressReportingStyle
-> IO ProgressReporting
progressReportingNoTrace STM Int
_ STM Int
_ Maybe (LanguageContextEnv c)
Nothing Text
_title ProgressReportingStyle
_optProgressStyle = ProgressReporting -> IO ProgressReporting
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ProgressReporting
noProgressReporting
progressReportingNoTrace STM Int
todo STM Int
done (Just LanguageContextEnv c
lspEnv) Text
title ProgressReportingStyle
optProgressStyle = do
  Var State
progressState <- State -> IO (Var State)
forall a. a -> IO (Var a)
newVar State
NotStarted
  let _progressUpdate :: ProgressEvent -> IO ()
_progressUpdate ProgressEvent
event = IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Transition -> IO ()
updateStateVar (Transition -> IO ()) -> Transition -> IO ()
forall a b. (a -> b) -> a -> b
$ ProgressEvent -> Transition
Event ProgressEvent
event
      _progressStop :: IO ()
_progressStop = Transition -> IO ()
updateStateVar Transition
StopProgress
      updateStateVar :: Transition -> IO ()
updateStateVar = Var State -> (State -> IO State) -> IO ()
forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var State
progressState ((State -> IO State) -> IO ())
-> (Transition -> State -> IO State) -> Transition -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> Transition -> State -> IO State
updateState (LanguageContextEnv c
-> Text -> ProgressReportingStyle -> STM Int -> STM Int -> IO ()
forall c.
LanguageContextEnv c
-> Text -> ProgressReportingStyle -> STM Int -> STM Int -> IO ()
progressCounter LanguageContextEnv c
lspEnv Text
title ProgressReportingStyle
optProgressStyle STM Int
todo STM Int
done)
  ProgressReporting -> IO ProgressReporting
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ProgressReporting {IO ()
ProgressEvent -> IO ()
_progressUpdate :: ProgressEvent -> IO ()
_progressStop :: IO ()
_progressUpdate :: ProgressEvent -> IO ()
_progressStop :: IO ()
..}

-- | `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 ::
  Maybe (LSP.LanguageContextEnv c) ->
  T.Text ->
  ProgressReportingStyle ->
  IO PerFileProgressReporting
progressReporting :: forall c.
Maybe (LanguageContextEnv c)
-> Text -> ProgressReportingStyle -> IO PerFileProgressReporting
progressReporting Maybe (LanguageContextEnv c)
Nothing Text
_title ProgressReportingStyle
_optProgressStyle = IO PerFileProgressReporting
noPerFileProgressReporting
progressReporting (Just LanguageContextEnv c
lspEnv) Text
title ProgressReportingStyle
optProgressStyle = do
  InProgressState
inProgressState <- IO InProgressState
newInProgress
  ProgressReporting
progressReportingInner <- STM Int
-> STM Int
-> Maybe (LanguageContextEnv c)
-> Text
-> ProgressReportingStyle
-> IO ProgressReporting
forall c.
STM Int
-> STM Int
-> Maybe (LanguageContextEnv c)
-> Text
-> ProgressReportingStyle
-> IO ProgressReporting
progressReportingNoTrace (TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar (TVar Int -> STM Int) -> TVar Int -> STM Int
forall a b. (a -> b) -> a -> b
$ InProgressState -> TVar Int
todoVar InProgressState
inProgressState)
                                (TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar (TVar Int -> STM Int) -> TVar Int -> STM Int
forall a b. (a -> b) -> a -> b
$ InProgressState -> TVar Int
doneVar InProgressState
inProgressState) (LanguageContextEnv c -> Maybe (LanguageContextEnv c)
forall a. a -> Maybe a
Just LanguageContextEnv c
lspEnv) Text
title ProgressReportingStyle
optProgressStyle
  let
    inProgress :: NormalizedFilePath -> IO a -> IO a
    inProgress :: forall a. NormalizedFilePath -> IO a -> IO a
inProgress = InProgressState -> NormalizedFilePath -> IO a -> IO a
forall {m :: * -> *} {c}.
MonadUnliftIO m =>
InProgressState -> NormalizedFilePath -> m c -> m c
updateStateForFile InProgressState
inProgressState
  PerFileProgressReporting -> IO PerFileProgressReporting
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return PerFileProgressReporting {ProgressReporting
NormalizedFilePath -> IO a -> IO a
forall a. NormalizedFilePath -> IO a -> IO a
inProgress :: forall a. NormalizedFilePath -> IO a -> IO a
progressReportingInner :: ProgressReporting
progressReportingInner :: ProgressReporting
inProgress :: forall a. NormalizedFilePath -> IO a -> IO a
..}
  where
    updateStateForFile :: InProgressState -> NormalizedFilePath -> m c -> m c
updateStateForFile InProgressState
inProgress NormalizedFilePath
file = m () -> (() -> m ()) -> (() -> m c) -> m c
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
UnliftIO.bracket (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> IO ()
f Int -> Int
forall a. Enum a => a -> a
succ) (m () -> () -> m ()
forall a b. a -> b -> a
const (m () -> () -> m ()) -> m () -> () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> IO ()
f Int -> Int
forall a. Enum a => a -> a
pred) ((() -> m c) -> m c) -> (m c -> () -> m c) -> m c -> m c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m c -> () -> m c
forall a b. a -> b -> a
const
      where
        -- This functions are deliberately eta-expanded to avoid space leaks.
        -- Do not remove the eta-expansion without profiling a session with at
        -- least 1000 modifications.

        f :: (Int -> Int) -> IO ()
f = InProgressState -> NormalizedFilePath -> (Int -> Int) -> IO ()
recordProgress InProgressState
inProgress NormalizedFilePath
file

-- Kill this to complete the progress session
progressCounter ::
  LSP.LanguageContextEnv c ->
  T.Text ->
  ProgressReportingStyle ->
  STM Int ->
  STM Int ->
  IO ()
progressCounter :: forall c.
LanguageContextEnv c
-> Text -> ProgressReportingStyle -> STM Int -> STM Int -> IO ()
progressCounter LanguageContextEnv c
lspEnv Text
title ProgressReportingStyle
optProgressStyle STM Int
getTodo STM Int
getDone =
  LanguageContextEnv c -> LspT c IO () -> IO ()
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv c
lspEnv (LspT c IO () -> IO ()) -> LspT c IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
-> Maybe ProgressToken
-> ProgressCancellable
-> ((ProgressAmount -> LspT c IO ()) -> LspT c IO ())
-> LspT c IO ()
forall c (m :: * -> *) a.
MonadLsp c m =>
Text
-> Maybe ProgressToken
-> ProgressCancellable
-> ((ProgressAmount -> m ()) -> m a)
-> m a
withProgress Text
title Maybe ProgressToken
forall a. Maybe a
Nothing ProgressCancellable
NotCancellable (((ProgressAmount -> LspT c IO ()) -> LspT c IO ())
 -> LspT c IO ())
-> ((ProgressAmount -> LspT c IO ()) -> LspT c IO ())
-> LspT c IO ()
forall a b. (a -> b) -> a -> b
$ \ProgressAmount -> LspT c IO ()
update -> (ProgressAmount -> LspT c IO ()) -> UInt -> LspT c IO ()
loop ProgressAmount -> LspT c IO ()
update UInt
0
  where
    loop :: (ProgressAmount -> LspT c IO ()) -> UInt -> LspT c IO ()
loop ProgressAmount -> LspT c IO ()
_ UInt
_ | ProgressReportingStyle
optProgressStyle ProgressReportingStyle -> ProgressReportingStyle -> Bool
forall a. Eq a => a -> a -> Bool
== ProgressReportingStyle
NoProgress = LspT c IO () -> LspT c IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (LspT c IO () -> LspT c IO ()) -> LspT c IO () -> LspT c IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> LspT c IO ()
forall a. IO a -> LspT c IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspT c IO ()) -> IO () -> LspT c IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
forall a. Bounded a => a
maxBound
    loop ProgressAmount -> LspT c IO ()
update UInt
prevPct = do
      (Int
todo, Int
done, UInt
nextPct) <- IO (Int, Int, UInt) -> LspT c IO (Int, Int, UInt)
forall a. IO a -> LspT c IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Int, Int, UInt) -> LspT c IO (Int, Int, UInt))
-> IO (Int, Int, UInt) -> LspT c IO (Int, Int, UInt)
forall a b. (a -> b) -> a -> b
$ STM (Int, Int, UInt) -> IO (Int, Int, UInt)
forall a. STM a -> IO a
atomically (STM (Int, Int, UInt) -> IO (Int, Int, UInt))
-> STM (Int, Int, UInt) -> IO (Int, Int, UInt)
forall a b. (a -> b) -> a -> b
$ do
        Int
todo <- STM Int
getTodo
        Int
done <- STM Int
getDone
        let nextFrac :: Double
            nextFrac :: Double
nextFrac = if Int
todo Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Double
0 else Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
done Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
todo
            nextPct :: UInt
            nextPct :: UInt
nextPct = Double -> UInt
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> UInt) -> Double -> UInt
forall a b. (a -> b) -> a -> b
$ Double
100 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
nextFrac
        Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UInt
nextPct UInt -> UInt -> Bool
forall a. Eq a => a -> a -> Bool
== UInt
prevPct) STM ()
forall a. STM a
retry
        (Int, Int, UInt) -> STM (Int, Int, UInt)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
todo, Int
done, UInt
nextPct)

      ()
_ <- ProgressAmount -> LspT c IO ()
update (Maybe UInt -> Maybe Text -> ProgressAmount
ProgressAmount (UInt -> Maybe UInt
forall a. a -> Maybe a
Just UInt
nextPct) (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
done String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
todo))
      (ProgressAmount -> LspT c IO ()) -> UInt -> LspT c IO ()
loop ProgressAmount -> LspT c IO ()
update UInt
nextPct

mRunLspT :: (Applicative m) => Maybe (LSP.LanguageContextEnv c) -> LSP.LspT c m () -> m ()
mRunLspT :: forall (m :: * -> *) c.
Applicative m =>
Maybe (LanguageContextEnv c) -> LspT c m () -> m ()
mRunLspT (Just LanguageContextEnv c
lspEnv) LspT c m ()
f = LanguageContextEnv c -> LspT c m () -> m ()
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv c
lspEnv LspT c m ()
f
mRunLspT Maybe (LanguageContextEnv c)
Nothing LspT c m ()
_       = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

mRunLspTCallback ::
  (Monad m) =>
  Maybe (LSP.LanguageContextEnv c) ->
  (LSP.LspT c m a -> LSP.LspT c m a) ->
  m a ->
  m a
mRunLspTCallback :: forall (m :: * -> *) c a.
Monad m =>
Maybe (LanguageContextEnv c)
-> (LspT c m a -> LspT c m a) -> m a -> m a
mRunLspTCallback (Just LanguageContextEnv c
lspEnv) LspT c m a -> LspT c m a
f m a
g = LanguageContextEnv c -> LspT c m a -> m a
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv c
lspEnv (LspT c m a -> m a) -> LspT c m a -> m a
forall a b. (a -> b) -> a -> b
$ LspT c m a -> LspT c m a
f (m a -> LspT c m a
forall (m :: * -> *) a. Monad m => m a -> LspT c m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m a
g)
mRunLspTCallback Maybe (LanguageContextEnv c)
Nothing LspT c m a -> LspT c m a
_ m a
g       = m a
g