diff --git a/hie-eg-plugin-async/Haskell/Ide/ExamplePluginAsync.hs b/hie-eg-plugin-async/Haskell/Ide/ExamplePluginAsync.hs index dfb6b4f2a..d4ed0793e 100644 --- a/hie-eg-plugin-async/Haskell/Ide/ExamplePluginAsync.hs +++ b/hie-eg-plugin-async/Haskell/Ide/ExamplePluginAsync.hs @@ -25,6 +25,7 @@ exampleAsyncDescriptor = PluginDescriptor [ buildCommand (longRunningCmdSync Cmd1) "cmd1" "Long running synchronous command" [] [CtxNone] [] , buildCommand (longRunningCmdSync Cmd2) "cmd2" "Long running synchronous command" [] [CtxNone] [] + , buildCommand (streamingCmdAsync (CmdA 3 100)) "cmdA3" "Long running async/streaming command" [] [CtxNone] [] ] , pdExposedServices = [] , pdUsedServices = [] @@ -35,6 +36,11 @@ exampleAsyncDescriptor = PluginDescriptor data WorkerCmd = Cmd1 | Cmd2 deriving Show +data WorkerCmdAsync = CmdA + Int -- Number of times to repeat + Int -- delay between repeats + deriving Show + -- | Keep track of the communication channesl to the remote process. data SubProcess = SubProcess { spChIn :: TChan WorkerCmd @@ -99,3 +105,26 @@ workerProc cin cout = loop 1 loop (cnt + 1) -- --------------------------------------------------------------------- + +-- | This command manages interaction with a separate process, doing stuff. +streamingCmdAsync :: WorkerCmdAsync -> CommandFunc T.Text +streamingCmdAsync cmd = CmdAsync $ \replyFunc _ctx req -> do + tid <- liftIO $ forkIO (workerProcAsync cmd replyFunc) + debugm $ "streamingCmdAsync:launched worker as " ++ show tid + let tidStr = T.pack (show tid ++ ":") + liftIO $ replyFunc (IdeResponseOk $ tidStr <> "started from streamingCmdAsync") + +-- | This command manages interaction with a separate process, doing stuff. +workerProcAsync :: WorkerCmdAsync -> (IdeResponse T.Text -> IO ()) -> IO () +workerProcAsync (CmdA num delayMs) replyFunc = do + tid <- myThreadId + let tidStr = show tid ++ ":" + replyFunc (IdeResponseOk $ T.pack $ tidStr <> "starting") + let + go n = do + replyFunc (IdeResponseOk $ T.pack $ tidStr <> "iteration " <> show n) + threadDelay (delayMs * 1000) + mapM_ go [1..num] + replyFunc (IdeResponseOk $ T.pack $ tidStr <> "done") + +-- --------------------------------------------------------------------- diff --git a/src/Haskell/Ide/Engine/Dispatcher.hs b/src/Haskell/Ide/Engine/Dispatcher.hs index 73f23835c..598816e30 100644 --- a/src/Haskell/Ide/Engine/Dispatcher.hs +++ b/src/Haskell/Ide/Engine/Dispatcher.hs @@ -38,6 +38,7 @@ dispatcher cin = do -- | Send a response from the plugin to the designated reply channel sendResponse :: (ValidResponse a) => ChannelRequest -> IdeResponse a -> IO () sendResponse req resp = do + debugm $ "sendResponse (req,resp)=" ++ show (req,fmap jsWrite resp) let cr = CResp (cinPlugin req) (cinReqId req) (fmap jsWrite resp) liftIO $ atomically $ writeTChan (cinReplyChan req) cr