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

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.Graph          hiding (ShakeValue)
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, cancel)

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 = ProgressReporting -> IO ProgressReporting
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProgressReporting -> IO ProgressReporting)
-> ProgressReporting -> IO ProgressReporting
forall a b. (a -> b) -> a -> b
$ 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 ()
  , inProgress :: forall a. NormalizedFilePath -> Action a -> Action a
inProgress = (Action a -> Action a)
-> NormalizedFilePath -> Action a -> Action a
forall a b. a -> b -> a
const Action a -> Action a
forall a. a -> a
id
  , progressStop :: IO ()
progressStop   = () -> IO ()
forall a. a -> IO a
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 () -> 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
KickStarted)   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
KickStarted)   (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 ()
_     (Event ProgressEvent
KickCompleted) (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
KickCompleted) 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
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 (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
$ do
        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'

progressReporting
  :: Maybe (LSP.LanguageContextEnv c)
  -> ProgressReportingStyle
  -> IO ProgressReporting
progressReporting :: forall c.
Maybe (LanguageContextEnv c)
-> ProgressReportingStyle -> IO ProgressReporting
progressReporting Maybe (LanguageContextEnv c)
Nothing ProgressReportingStyle
_optProgressStyle = IO ProgressReporting
noProgressReporting
progressReporting (Just LanguageContextEnv c
lspEnv) ProgressReportingStyle
optProgressStyle = do
    InProgressState
inProgressState <- IO InProgressState
newInProgress
    Var State
progressState <- State -> IO (Var State)
forall a. a -> IO (Var a)
newVar State
NotStarted
    let progressUpdate :: ProgressEvent -> IO ()
progressUpdate ProgressEvent
event = 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 (InProgressState -> IO ()
lspShakeProgressNew InProgressState
inProgressState)
        inProgress :: NormalizedFilePath -> Action c -> Action c
inProgress = InProgressState -> NormalizedFilePath -> Action c -> Action c
forall {c}.
InProgressState -> NormalizedFilePath -> Action c -> Action c
updateStateForFile InProgressState
inProgressState
    ProgressReporting -> IO ProgressReporting
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ProgressReporting{IO ()
NormalizedFilePath -> Action a -> Action a
ProgressEvent -> IO ()
forall a. NormalizedFilePath -> Action a -> Action a
progressUpdate :: ProgressEvent -> IO ()
inProgress :: forall a. NormalizedFilePath -> Action a -> Action a
progressStop :: IO ()
progressUpdate :: ProgressEvent -> IO ()
progressStop :: IO ()
inProgress :: forall a. NormalizedFilePath -> Action a -> Action a
..}
    where
        lspShakeProgressNew :: InProgressState -> IO ()
        lspShakeProgressNew :: InProgressState -> IO ()
lspShakeProgressNew 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
..} =
            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
"Processing" 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 ()
forall {f :: * -> *} {a} {b}.
MonadIO f =>
(ProgressAmount -> f a) -> UInt -> f b
loop ProgressAmount -> LspT c IO ()
update UInt
0
            where
                loop :: (ProgressAmount -> f a) -> UInt -> f b
loop ProgressAmount -> f a
_ UInt
_ | ProgressReportingStyle
optProgressStyle ProgressReportingStyle -> ProgressReportingStyle -> Bool
forall a. Eq a => a -> a -> Bool
== ProgressReportingStyle
NoProgress = f () -> f b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (f () -> f b) -> f () -> f b
forall a b. (a -> b) -> a -> b
$ IO () -> f ()
forall a. IO a -> f a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> f ()) -> IO () -> f ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
forall a. Bounded a => a
maxBound
                loop ProgressAmount -> f a
update UInt
prevPct = do
                    (Int
todo, Int
done, UInt
nextPct) <- IO (Int, Int, UInt) -> f (Int, Int, UInt)
forall a. IO a -> f a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Int, Int, UInt) -> f (Int, Int, UInt))
-> IO (Int, Int, UInt) -> f (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 <- TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
todoVar
                        Int
done <- TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
doneVar
                        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)

                    a
_ <- ProgressAmount -> f a
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 -> f a) -> UInt -> f b
loop ProgressAmount -> f a
update UInt
nextPct
        updateStateForFile :: InProgressState -> NormalizedFilePath -> Action c -> Action c
updateStateForFile InProgressState
inProgress NormalizedFilePath
file = IO () -> (() -> IO ()) -> (() -> Action c) -> Action c
forall a b c. IO a -> (a -> IO b) -> (a -> Action c) -> Action c
actionBracket ((Int -> Int) -> IO ()
f Int -> Int
forall a. Enum a => a -> a
succ) (IO () -> () -> IO ()
forall a b. a -> b -> a
const (IO () -> () -> IO ()) -> IO () -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> IO ()
f Int -> Int
forall a. Enum a => a -> a
pred) ((() -> Action c) -> Action c)
-> (Action c -> () -> Action c) -> Action c -> Action c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Action c -> () -> Action 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 = 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