module Development.IDE.Core.ProgressReporting
( ProgressEvent(..)
, ProgressReporting(..)
, noProgressReporting
, progressReporting
, mRunLspT
, mRunLspTCallback
, 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 ()
}
data State
= NotStarted
| Stopped
| Running (Async ())
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 InProgressState = InProgressState
{ InProgressState -> TVar Int
todoVar :: TVar Int
, 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
$ 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
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