{-# LANGUAGE RankNTypes #-}
module Development.IDE.Core.ProgressReporting
  ( ProgressEvent(..)
  , ProgressReporting(..)
  , noProgressReporting
  , delayedProgressReporting
  -- utilities, reexported for use in Core.Shake
  , mRunLspT
  , mRunLspTCallback
  -- for tests
  , recordProgress
  , InProgressState(..)
  )
   where

import           Control.Concurrent.Async
import           Control.Concurrent.STM.Stats   (TVar, atomicallyNamed,
                                                 modifyTVar', newTVarIO,
                                                 readTVarIO)
import           Control.Concurrent.Strict
import           Control.Monad.Extra
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Class      (lift)
import           Data.Foldable                  (for_)
import           Data.Functor                   (($>))
import qualified Data.Text                      as T
import           Data.Unique
import           Development.IDE.GHC.Orphans    ()
import           Development.IDE.Graph          hiding (ShakeValue)
import           Development.IDE.Types.Location
import           Development.IDE.Types.Options
import qualified Focus
import qualified Language.LSP.Server            as LSP
import           Language.LSP.Types
import qualified Language.LSP.Types             as LSP
import qualified StmContainers.Map              as STM
import           System.Time.Extra
import           UnliftIO.Exception             (bracket_)

data ProgressEvent
    = KickStarted
    | KickCompleted

data ProgressReporting  = ProgressReporting
  { ProgressReporting -> ProgressEvent -> IO ()
progressUpdate :: ProgressEvent -> IO ()
  , ProgressReporting
-> forall a. NormalizedFilePath -> Action a -> Action a
inProgress     :: forall a. NormalizedFilePath -> Action a -> Action a
  , ProgressReporting -> IO ()
progressStop   :: IO ()
  }

noProgressReporting :: IO ProgressReporting
noProgressReporting :: IO ProgressReporting
noProgressReporting = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ProgressReporting
  { progressUpdate :: ProgressEvent -> IO ()
progressUpdate = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  , inProgress :: forall a. NormalizedFilePath -> Action a -> Action a
inProgress = forall a b. a -> b -> a
const forall a. a -> a
id
  , progressStop :: IO ()
progressStop   = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  }

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

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

updateState :: IO (Async ()) -> Transition -> State -> IO State
updateState :: IO (Async ()) -> Transition -> State -> IO State
updateState IO (Async ())
_      Transition
_                    State
Stopped     = forall (f :: * -> *) a. Applicative f => a -> f a
pure State
Stopped
updateState IO (Async ())
start (Event ProgressEvent
KickStarted)   State
NotStarted  = Async () -> State
Running forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Async ())
start
updateState IO (Async ())
start (Event ProgressEvent
KickStarted)   (Running Async ()
a) = forall a. Async a -> IO ()
cancel Async ()
a forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Async () -> State
Running forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Async ())
start
updateState IO (Async ())
_     (Event ProgressEvent
KickCompleted) (Running Async ()
a) = forall a. Async a -> IO ()
cancel Async ()
a forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> State
NotStarted
updateState IO (Async ())
_     (Event ProgressEvent
KickCompleted) State
st          = forall (f :: * -> *) a. Applicative f => a -> f a
pure State
st
updateState IO (Async ())
_     Transition
StopProgress          (Running Async ()
a) = forall a. Async a -> IO ()
cancel Async ()
a forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> State
Stopped
updateState IO (Async ())
_     Transition
StopProgress          State
st          = forall (f :: * -> *) a. Applicative f => a -> f a
pure State
st

-- | Data structure to track progress across the project
data InProgressState = InProgressState
    { InProgressState -> TVar Int
todoVar    :: TVar Int  -- ^ Number of files to do
    , InProgressState -> TVar Int
doneVar    :: TVar Int  -- ^ Number of files done
    , 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (TVar a)
newTVarIO Int
0 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> IO (TVar a)
newTVarIO Int
0 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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
currentVar :: Map NormalizedFilePath Int
doneVar :: TVar Int
todoVar :: TVar Int
currentVar :: InProgressState -> Map NormalizedFilePath Int
doneVar :: InProgressState -> TVar Int
todoVar :: InProgressState -> TVar Int
..} NormalizedFilePath
file Int -> Int
shift = do
    (Maybe Int
prev, Int
new) <- forall a. String -> STM a -> IO a
atomicallyNamed String
"recordProgress" forall a b. (a -> b) -> a -> b
$ 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
    forall a. String -> STM a -> IO a
atomicallyNamed String
"recordProgress2" forall a b. (a -> b) -> a -> b
$ do
        case (Maybe Int
prev,Int
new) of
            (Maybe Int
Nothing,Int
0) -> forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
doneVar (forall a. Num a => a -> a -> a
+Int
1) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
todoVar (forall a. Num a => a -> a -> a
+Int
1)
            (Maybe Int
Nothing,Int
_) -> forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
todoVar (forall a. Num a => a -> a -> a
+Int
1)
            (Just Int
0, Int
0) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            (Just Int
0, Int
_) -> forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
doneVar forall a. Enum a => a -> a
pred
            (Just Int
_, Int
0) -> forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
doneVar (forall a. Num a => a -> a -> a
+Int
1)
            (Just Int
_, Int
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure()
  where
    alterPrevAndNew :: Focus Int STM (Maybe Int, Int)
alterPrevAndNew = do
        Maybe Int
prev <- forall (m :: * -> *) a. Monad m => Focus a m (Maybe a)
Focus.lookup
        forall (m :: * -> *) a.
Monad m =>
(Maybe a -> Maybe a) -> Focus a m ()
Focus.alter Maybe Int -> Maybe Int
alter
        Int
new <- forall (m :: * -> *) a. Monad m => a -> Focus a m a
Focus.lookupWithDefault Int
0
        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' = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int -> Int
shift Int
0) Int -> Int
shift Maybe Int
x in forall a. a -> Maybe a
Just Int
x'

-- | A 'ProgressReporting' that enqueues Begin and End notifications in a new
--   thread, with a grace period (nothing will be sent if 'KickCompleted' arrives
--   before the end of the grace period).
delayedProgressReporting
  :: Seconds  -- ^ Grace period before starting
  -> Seconds  -- ^ sampling delay
  -> Maybe (LSP.LanguageContextEnv c)
  -> ProgressReportingStyle
  -> IO ProgressReporting
delayedProgressReporting :: forall c.
Seconds
-> Seconds
-> Maybe (LanguageContextEnv c)
-> ProgressReportingStyle
-> IO ProgressReporting
delayedProgressReporting Seconds
before Seconds
after Maybe (LanguageContextEnv c)
Nothing ProgressReportingStyle
optProgressStyle = IO ProgressReporting
noProgressReporting
delayedProgressReporting Seconds
before Seconds
after (Just LanguageContextEnv c
lspEnv) ProgressReportingStyle
optProgressStyle = do
    InProgressState
inProgressState <- IO InProgressState
newInProgress
    Var State
progressState <- forall a. a -> IO (Var a)
newVar State
NotStarted
    let progressUpdate :: ProgressEvent -> IO ()
progressUpdate ProgressEvent
event = Transition -> IO ()
updateStateVar forall a b. (a -> b) -> a -> b
$ ProgressEvent -> Transition
Event ProgressEvent
event
        progressStop :: IO ()
progressStop   =  Transition -> IO ()
updateStateVar Transition
StopProgress
        updateStateVar :: Transition -> IO ()
updateStateVar = forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var State
progressState forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Async ()) -> Transition -> State -> IO State
updateState (forall {m :: * -> *}.
MonadUnliftIO m =>
InProgressState -> m (Async ())
lspShakeProgress InProgressState
inProgressState)

        inProgress :: NormalizedFilePath -> Action c -> Action c
inProgress = forall {c}.
InProgressState -> NormalizedFilePath -> Action c -> Action c
updateStateForFile InProgressState
inProgressState
    forall (m :: * -> *) a. Monad m => a -> m a
return ProgressReporting{IO ()
ProgressEvent -> IO ()
forall a. NormalizedFilePath -> Action a -> Action a
inProgress :: forall a. NormalizedFilePath -> Action a -> Action a
progressStop :: IO ()
progressUpdate :: ProgressEvent -> IO ()
progressStop :: IO ()
inProgress :: forall a. NormalizedFilePath -> Action a -> Action a
progressUpdate :: ProgressEvent -> IO ()
..}
    where
        lspShakeProgress :: InProgressState -> m (Async ())
lspShakeProgress InProgressState{TVar Int
Map NormalizedFilePath Int
currentVar :: Map NormalizedFilePath Int
doneVar :: TVar Int
todoVar :: TVar Int
currentVar :: InProgressState -> Map NormalizedFilePath Int
doneVar :: InProgressState -> TVar Int
todoVar :: InProgressState -> TVar Int
..} = do
            -- first sleep a bit, so we only show progress messages if it's going to take
            -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes)
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Seconds -> IO ()
sleep Seconds
before
            ProgressToken
u <- Text -> ProgressToken
ProgressTextToken forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unique -> Int
hashUnique forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Unique
newUnique

            Barrier (Either ResponseError Empty)
b <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a. IO (Barrier a)
newBarrier
            forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv c
lspEnv forall a b. (a -> b) -> a -> b
$ forall (m :: Method 'FromServer 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (ResponseResult m) -> f ())
-> f (LspId m)
LSP.sendRequest SMethod 'WindowWorkDoneProgressCreate
LSP.SWindowWorkDoneProgressCreate
                LSP.WorkDoneProgressCreateParams { $sel:_token:WorkDoneProgressCreateParams :: ProgressToken
_token = ProgressToken
u } forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Partial => Barrier a -> a -> IO ()
signalBarrier Barrier (Either ResponseError Empty)
b
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO (Async a)
async forall a b. (a -> b) -> a -> b
$ do
                Either ResponseError Empty
ready <- forall a. Barrier a -> IO a
waitBarrier Barrier (Either ResponseError Empty)
b
                forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv c
lspEnv forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Either ResponseError Empty
ready forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> m b -> m c -> m c
bracket_ (forall {config} {f :: * -> *}.
MonadLsp config f =>
ProgressToken -> f ()
start ProgressToken
u) (forall {config} {f :: * -> *}.
MonadLsp config f =>
ProgressToken -> f ()
stop ProgressToken
u) (forall {f :: * -> *} {config} {b}.
MonadLsp config f =>
ProgressToken -> UInt -> f b
loop ProgressToken
u UInt
0)
            where
                start :: ProgressToken -> f ()
start ProgressToken
id = forall (m :: Method 'FromServer 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification SMethod 'Progress
LSP.SProgress forall a b. (a -> b) -> a -> b
$
                    LSP.ProgressParams
                        { $sel:_token:ProgressParams :: ProgressToken
_token = ProgressToken
id
                        , $sel:_value:ProgressParams :: SomeProgressParams
_value = WorkDoneProgressBeginParams -> SomeProgressParams
LSP.Begin forall a b. (a -> b) -> a -> b
$ WorkDoneProgressBeginParams
                          { $sel:_title:WorkDoneProgressBeginParams :: Text
_title = Text
"Processing"
                          , $sel:_cancellable:WorkDoneProgressBeginParams :: Maybe Bool
_cancellable = forall a. Maybe a
Nothing
                          , $sel:_message:WorkDoneProgressBeginParams :: Maybe Text
_message = forall a. Maybe a
Nothing
                          , $sel:_percentage:WorkDoneProgressBeginParams :: Maybe UInt
_percentage = forall a. Maybe a
Nothing
                          }
                        }
                stop :: ProgressToken -> f ()
stop ProgressToken
id = forall (m :: Method 'FromServer 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification SMethod 'Progress
LSP.SProgress
                    LSP.ProgressParams
                        { $sel:_token:ProgressParams :: ProgressToken
_token = ProgressToken
id
                        , $sel:_value:ProgressParams :: SomeProgressParams
_value = WorkDoneProgressEndParams -> SomeProgressParams
LSP.End WorkDoneProgressEndParams
                          { $sel:_message:WorkDoneProgressEndParams :: Maybe Text
_message = forall a. Maybe a
Nothing
                          }
                        }
                loop :: ProgressToken -> UInt -> f b
loop ProgressToken
_ UInt
_ | ProgressReportingStyle
optProgressStyle forall a. Eq a => a -> a -> Bool
== ProgressReportingStyle
NoProgress =
                    forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay forall a. Bounded a => a
maxBound
                loop ProgressToken
id UInt
prevPct = do
                    Int
done <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> IO a
readTVarIO TVar Int
doneVar
                    Int
todo <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> IO a
readTVarIO TVar Int
todoVar
                    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Seconds -> IO ()
sleep Seconds
after
                    if Int
todo forall a. Eq a => a -> a -> Bool
== Int
0 then ProgressToken -> UInt -> f b
loop ProgressToken
id UInt
0 else do
                        let
                            nextFrac :: Double
                            nextFrac :: Seconds
nextFrac = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
done forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
todo
                            nextPct :: UInt
                            nextPct :: UInt
nextPct = forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$ Seconds
100 forall a. Num a => a -> a -> a
* Seconds
nextFrac
                        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UInt
nextPct forall a. Eq a => a -> a -> Bool
/= UInt
prevPct) forall a b. (a -> b) -> a -> b
$
                          forall (m :: Method 'FromServer 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification SMethod 'Progress
LSP.SProgress forall a b. (a -> b) -> a -> b
$
                          LSP.ProgressParams
                              { $sel:_token:ProgressParams :: ProgressToken
_token = ProgressToken
id
                              , $sel:_value:ProgressParams :: SomeProgressParams
_value = WorkDoneProgressReportParams -> SomeProgressParams
LSP.Report forall a b. (a -> b) -> a -> b
$ case ProgressReportingStyle
optProgressStyle of
                                  ProgressReportingStyle
Explicit -> LSP.WorkDoneProgressReportParams
                                    { $sel:_cancellable:WorkDoneProgressReportParams :: Maybe Bool
_cancellable = forall a. Maybe a
Nothing
                                    , $sel:_message:WorkDoneProgressReportParams :: Maybe Text
_message = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Int
done forall a. Semigroup a => a -> a -> a
<> String
"/" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
todo
                                    , $sel:_percentage:WorkDoneProgressReportParams :: Maybe UInt
_percentage = forall a. Maybe a
Nothing
                                    }
                                  ProgressReportingStyle
Percentage -> LSP.WorkDoneProgressReportParams
                                    { $sel:_cancellable:WorkDoneProgressReportParams :: Maybe Bool
_cancellable = forall a. Maybe a
Nothing
                                    , $sel:_message:WorkDoneProgressReportParams :: Maybe Text
_message = forall a. Maybe a
Nothing
                                    , $sel:_percentage:WorkDoneProgressReportParams :: Maybe UInt
_percentage = forall a. a -> Maybe a
Just UInt
nextPct
                                    }
                                  ProgressReportingStyle
NoProgress -> forall a. Partial => String -> a
error String
"unreachable"
                              }
                        ProgressToken -> UInt -> f b
loop ProgressToken
id UInt
nextPct

        updateStateForFile :: InProgressState -> NormalizedFilePath -> Action c -> Action c
updateStateForFile InProgressState
inProgress NormalizedFilePath
file = forall a b c. IO a -> (a -> IO b) -> (a -> Action c) -> Action c
actionBracket ((Int -> Int) -> IO ()
f forall a. Enum a => a -> a
succ) (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> IO ()
f forall a. Enum a => a -> a
pred) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const
            -- 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.
            where
              f :: (Int -> Int) -> IO ()
f Int -> Int
shift = InProgressState -> NormalizedFilePath -> (Int -> Int) -> IO ()
recordProgress InProgressState
inProgress NormalizedFilePath
file Int -> Int
shift

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 = 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 ()
_       = 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 = forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv c
lspEnv forall a b. (a -> b) -> a -> b
$ LspT c m a -> LspT c m a
f (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