Initial example async process plugin

app/MainHie.hs

@@ -37,6 +37,7 @@ import           System.Environment
 import           Haskell.Ide.ApplyRefactPlugin
 import           Haskell.Ide.Engine.BasePlugin
 import           Haskell.Ide.ExamplePlugin2
+import           Haskell.Ide.ExamplePluginAsync
 import           Haskell.Ide.GhcModPlugin
 import           Haskell.Ide.HaRePlugin
 
@@ -50,6 +51,7 @@ plugins = Map.fromList
     -- up via a config file of some kind.
     ("applyrefact", applyRefactDescriptor)
   , ("eg2",         example2Descriptor)
+  , ("egasync",     exampleAsyncDescriptor)
   , ("ghcmod",      ghcmodDescriptor)
   , ("hare",        hareDescriptor)
     -- The base plugin, able to answer questions about the IDE Engine environment.

haskell-ide-engine.cabal

@@ -77,6 +77,7 @@ executable hie
                      , gitrev >= 1.1
                      , haskell-ide-engine
                      , hie-apply-refact
+                     , hie-eg-plugin-async
                      , hie-example-plugin2
                      , hie-ghc-mod
                      , hie-hare
@@ -98,6 +99,7 @@ test-suite haskell-ide-test
   other-modules:
                        ApplyRefactPluginSpec
                        DispatcherSpec
+                       ExamplePluginAsyncSpec
                        ExtensibleStateSpec
                        GhcModPluginSpec
                        HaRePluginSpec
@@ -113,6 +115,7 @@ test-suite haskell-ide-test
                      , fast-logger
                      , haskell-ide-engine
                      , hie-apply-refact
+                     , hie-eg-plugin-async
                      , hie-ghc-mod
                      , hie-hare
                      , hie-plugin-api

hie-eg-plugin-async/Haskell/Ide/ExamplePluginAsync.hs

@@ -0,0 +1,101 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE GADTs #-}
+module Haskell.Ide.ExamplePluginAsync where
+
+import           Control.Concurrent
+import           Control.Concurrent.STM.TChan
+import           Control.Monad.IO.Class
+import           Control.Monad.STM
+import           Haskell.Ide.Engine.ExtensibleState
+import           Haskell.Ide.Engine.MonadFunctions
+import           Haskell.Ide.Engine.PluginDescriptor
+import           Haskell.Ide.Engine.PluginUtils
+import           Data.Monoid
+import qualified Data.Map as Map
+import qualified Data.Text as T
+
+-- ---------------------------------------------------------------------
+
+exampleAsyncDescriptor :: PluginDescriptor
+exampleAsyncDescriptor = PluginDescriptor
+  {
+    pdUIShortName = "Async Example"
+  , pdUIOverview = "An example HIE plugin using multiple/async processes"
+  , pdCommands =
+      [
+        buildCommand (longRunningCmdSync Cmd1) "cmd1" "Long running synchronous command" [] [CtxNone] []
+      , buildCommand (longRunningCmdSync Cmd2) "cmd2" "Long running synchronous command" [] [CtxNone] []
+      ]
+  , pdExposedServices = []
+  , pdUsedServices    = []
+  }
+
+-- ---------------------------------------------------------------------
+
+data WorkerCmd = Cmd1 | Cmd2
+               deriving Show
+
+-- | Keep track of the communication channesl to the remote process.
+data SubProcess = SubProcess
+  { spChIn    :: TChan WorkerCmd
+  , spChOut   :: TChan T.Text
+  , spProcess :: ThreadId
+  }
+
+-- | Wrap it in a Maybe for pure initialisation
+data AsyncPluginState = APS (Maybe SubProcess)
+
+-- | Tag the state variable to enable it to be stored in the dispatcher state,
+-- accessible to all plugins, provided they know the type, as it is accessed via
+-- a @cast@
+instance ExtensionClass AsyncPluginState where
+  initialValue = APS Nothing
+
+-- ---------------------------------------------------------------------
+
+-- | This command manages interaction with a separate process, doing stuff.
+longRunningCmdSync :: WorkerCmd -> CommandFunc T.Text
+longRunningCmdSync cmd = CmdSync $ \_ctx req -> do
+  SubProcess cin cout _tid <- ensureProcessRunning
+  liftIO $ atomically $ writeTChan cin cmd
+  res <- liftIO $ atomically $ readTChan cout
+  return (IdeResponseOk $ "res=" <> res)
+
+-- ---------------------------------------------------------------------
+
+-- | If there is already a @SubProcess@ value in the plugin state return it,
+-- else create a new set of @TChan@ and fork the worker with them, storing the
+-- new @SubProcess@ value in the plugin state.
+ensureProcessRunning :: IdeM SubProcess
+ensureProcessRunning = do
+  (APS v) <- get -- from extensible state
+  sp <- case v of
+    Nothing -> do
+      cin  <- liftIO $ atomically newTChan
+      cout <- liftIO $ atomically newTChan
+      tid  <- liftIO $ forkIO (workerProc cin cout)
+      let v' = SubProcess cin cout tid
+      put (APS (Just v')) -- into extensible state
+      return v'
+    Just v' -> return v'
+  return sp
+
+-- ---------------------------------------------------------------------
+
+-- | Long running worker process, can be doing commands in an async manner
+workerProc :: TChan WorkerCmd -> TChan T.Text -> IO ()
+workerProc cin cout = loop 1
+  where
+    loop cnt = do
+      debugm "workerProc:top of loop"
+      req <- liftIO $ atomically $ readTChan cin
+      debugm $ "workerProc loop:got:" ++ show req
+      case req of
+        Cmd1 -> do
+          liftIO $ atomically $ writeTChan cout (T.pack $ "wp cmd1:cnt=" ++ show cnt)
+          loop (cnt + 1)
+        Cmd2 -> do
+          liftIO $ atomically $ writeTChan cout (T.pack $ "wp cmd2:cnt=" ++ show cnt)
+          loop (cnt + 1)
+
+-- ---------------------------------------------------------------------

hie-eg-plugin-async/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

hie-eg-plugin-async/hie-eg-plugin-async.cabal

@@ -0,0 +1,24 @@
+name:                hie-eg-plugin-async
+version:             0.1.0.0
+synopsis:            Haskell IDE example plugin, using async processes
+license:             BSD3
+license-file:        ../LICENSE
+author:              Many,TBD when we release
+maintainer:          alan.zimm@gmail.com (for now)
+copyright:           2015 TBD
+category:            Web
+build-type:          Simple
+-- extra-source-files:
+cabal-version:       >=1.10
+
+library
+  exposed-modules:     Haskell.Ide.ExamplePluginAsync
+  build-depends:       base >= 4.7 && < 5
+                     , hie-plugin-api
+                     , aeson
+                     , containers
+                     , stm
+                     , text
+                     , transformers
+  ghc-options:         -Wall
+  default-language:    Haskell2010

stack.yaml

@@ -5,6 +5,7 @@ packages:
 - .
 - hie-apply-refact
 - hie-example-plugin2
+- hie-eg-plugin-async
 - hie-plugin-api
 - hie-ghc-mod
 - hie-hare

test/ExamplePluginAsyncSpec.hs

@@ -0,0 +1,58 @@
+{-# LANGUAGE OverloadedStrings #-}
+module ExamplePluginAsyncSpec where
+
+import           Control.Concurrent
+import           Control.Concurrent.STM.TChan
+import           Control.Monad.IO.Class
+import           Control.Monad.STM
+import           Data.Aeson
+import qualified Data.HashMap.Strict as H
+import qualified Data.Text as T
+import qualified Data.HashMap.Strict as HM
+import qualified Data.Map as Map
+import           Data.Typeable
+import           Haskell.Ide.Engine.Dispatcher
+import           Haskell.Ide.Engine.ExtensibleState
+import           Haskell.Ide.Engine.Monad
+import           Haskell.Ide.Engine.MonadFunctions
+import           Haskell.Ide.Engine.PluginDescriptor
+import           Haskell.Ide.Engine.Types
+import           Haskell.Ide.Engine.Utils
+import           Haskell.Ide.Engine.PluginDescriptor
+import           Haskell.Ide.ExamplePluginAsync
+
+import           Test.Hspec
+
+main :: IO ()
+main = hspec spec
+
+spec :: Spec
+spec = do
+  describe "ExamplePluginAsync" examplePluginAsyncSpec
+
+examplePluginAsyncSpec :: Spec
+examplePluginAsyncSpec = do
+  describe "stores and retrieves in the state" $ do
+    it "stores the first one" $ do
+      chan <- atomically newTChan
+      chSync <- atomically newTChan
+      let req1 = IdeRequest "cmd1" (Map.fromList [])
+          cr1 = CReq "test" 1 req1 chan
+      let req2 = IdeRequest "cmd2" (Map.fromList [])
+          cr2 = CReq "test" 1 req2 chan
+      (ra,rb,rc) <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty)
+        (do
+          r1 <- doDispatch testPlugins cr1
+          r2 <- doDispatch testPlugins cr2
+          r3 <- doDispatch testPlugins cr1
+          return (r1,r2,r3))
+      ra `shouldBe` Just (IdeResponseOk (H.fromList ["ok" .= ("res=wp cmd1:cnt=1"::String)]))
+      rb `shouldBe` Just (IdeResponseOk (H.fromList ["ok" .= ("res=wp cmd2:cnt=2"::String)]))
+      rc `shouldBe` Just (IdeResponseOk (H.fromList ["ok" .= ("res=wp cmd1:cnt=3"::String)]))
+
+    -- ---------------------------------
+
+-- ---------------------------------------------------------------------
+
+testPlugins :: Plugins
+testPlugins = Map.fromList [("test",exampleAsyncDescriptor)]