Merge pull request #72 from alanz/async-dispatch-1

Async dispatch

Author: alanz

app/MainHie.hs

@@ -4,11 +4,13 @@
 
 module Main where
 
-import           Control.Monad
-import           Control.Monad.Trans.Maybe
 import           Control.Concurrent
+import           Control.Concurrent.STM.TChan
 import           Control.Exception
 import           Control.Logging
+import           Control.Monad
+import           Control.Monad.STM
+import           Control.Monad.Trans.Maybe
 import qualified Data.Map as Map
 import           Data.Version (showVersion)
 import           Development.GitRev (gitCommitCount)
@@ -104,7 +106,7 @@ run opts = do
     getUserHomeDirectory >>= mapM_ setCurrentDirectory
 
     logm $  "run entered for HIE " ++ version
-    cin <- newChan :: IO (Chan ChannelRequest)
+    cin <- atomically newTChan :: IO (TChan ChannelRequest)
 
     -- log $ T.pack $ "replPluginInfo:" ++ show replPluginInfo
 
@@ -138,6 +140,6 @@ getUserHomeDirectory = do
 -- pass the request through to the main event dispatcher, and listen on the
 -- reply channel for the response, which should go back to the IDE, using
 -- whatever it takes.
-listener :: Chan ChannelRequest -> IO ()
+listener :: TChan ChannelRequest -> IO ()
 listener = assert False undefined
 

haskell-ide-engine.cabal

@@ -49,6 +49,7 @@ library
                      , pipes-attoparsec >= 0.5
                      , pipes-bytestring
                      , pipes-parse
+                     , stm
                      , servant-server
                      , text
                      , time
@@ -79,6 +80,7 @@ executable hie
                      , logging
                      , optparse-applicative
                      , optparse-simple
+                     , stm
                      , text
                      , time
                      , transformers
@@ -105,7 +107,10 @@ test-suite haskell-ide-test
                      , haskell-ide-plugin-ghcmod
                      , hspec
                      , logging
+                     , stm
                      , text
+                     , transformers
+                     , unordered-containers
   ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wall
   default-language:    Haskell2010
 

haskell-ide-example-plugin2/Haskell/Ide/ExamplePlugin2.hs

@@ -45,10 +45,10 @@ example2Descriptor = PluginDescriptor
 -- ---------------------------------------------------------------------
 
 sayHelloCmd :: CommandFunc T.Text
-sayHelloCmd _  _ = return (IdeResponseOk sayHello)
+sayHelloCmd = CmdSync $ \_ _ -> return (IdeResponseOk sayHello)
 
 sayHelloToCmd :: CommandFunc T.Text
-sayHelloToCmd _ req = do
+sayHelloToCmd = CmdSync $ \_ req -> do
   case Map.lookup "name" (ideParams req) of
     Nothing -> return $ missingParameter "name"
     Just (ParamTextP n) -> do

haskell-ide-plugin-api/Haskell/Ide/Engine/PluginDescriptor.hs

@@ -256,9 +256,17 @@ class (Monad m) => HasIdeState m where
 -- descriptor, and has all the required parameters. Where a command has only one
 -- allowed context the supplied context list does not add much value, but allows
 -- easy case checking when multiple contexts are supported.
-type CommandFunc resp = forall m. (MonadIO m,GHC.GhcMonad m,HasIdeState m)
+data CommandFunc resp = CmdSync (SyncCommandFunc resp)
+                      | CmdAsync (AsyncCommandFunc resp)
+                        -- ^ Note: does not forkIO, the command must decide when
+                        -- to do this.
+
+type SyncCommandFunc resp = forall m. (MonadIO m,GHC.GhcMonad m,HasIdeState m)
                 => [AcceptedContext] -> IdeRequest -> m (IdeResponse resp)
 
+type AsyncCommandFunc resp = forall m. (MonadIO m,GHC.GhcMonad m,HasIdeState m)
+                => (IdeResponse resp -> IO ()) -> [AcceptedContext] -> IdeRequest -> m ()
+
 -- ---------------------------------------------------------------------
 -- ValidResponse instances
 

haskell-ide-plugin-ghcmod/Haskell/Ide/GhcModPlugin.hs

@@ -98,7 +98,7 @@ ghcmodDescriptor = PluginDescriptor
 -- ---------------------------------------------------------------------
 
 checkCmd :: CommandFunc String
-checkCmd _ctxs req = do
+checkCmd = CmdSync $ \_ctxs req -> do
   case getParams (IdFile "file" :& RNil) req of
     Left err -> return err
     Right (ParamFile fileName :& RNil) -> do
@@ -111,7 +111,7 @@ checkCmd _ctxs req = do
 -- TODO: Must define a directory to base the search from, to be able to resolve
 -- the project root.
 findCmd :: CommandFunc String
-findCmd _ctxs req = do
+findCmd = CmdSync $ \_ctxs req -> do
   case getParams (IdText "symbol" :& RNil) req of
     Left err -> return err
     Right (ParamText _symbol :& RNil) -> do
@@ -126,7 +126,7 @@ findCmd _ctxs req = do
 -- ---------------------------------------------------------------------
 
 lintCmd :: CommandFunc String
-lintCmd _ctxs req = do
+lintCmd = CmdSync $ \_ctxs req -> do
   case getParams (IdFile "file" :& RNil) req of
     Left err -> return err
     Right (ParamFile fileName :& RNil) -> do
@@ -137,7 +137,7 @@ lintCmd _ctxs req = do
 -- ---------------------------------------------------------------------
 
 infoCmd :: CommandFunc String
-infoCmd _ctxs req = do
+infoCmd = CmdSync $ \_ctxs req -> do
   case getParams (IdFile "file" :& IdText "expr" :& RNil) req of
     Left err -> return err
     Right (ParamFile fileName :& ParamText expr :& RNil) -> do
@@ -148,7 +148,7 @@ infoCmd _ctxs req = do
 -- ---------------------------------------------------------------------
 
 typeCmd :: CommandFunc String
-typeCmd _ctxs req = do
+typeCmd = CmdSync $ \_ctxs req -> do
   case getParams (IdFile "file" :& IdPos "start_pos" :& RNil) req of
     Left err -> return err
     Right (ParamFile fileName :& ParamPos (r,c) :& RNil) -> do

haskell-ide-plugin-hare/Haskell/Ide/HaRePlugin.hs

@@ -87,7 +87,7 @@ hareDescriptor = PluginDescriptor
 -- ---------------------------------------------------------------------
 
 demoteCmd :: CommandFunc [FilePath]
-demoteCmd _ctxs req = do
+demoteCmd  = CmdSync $ \_ctxs req -> do
   case getParams (IdFile "file" :& IdPos "start_pos" :& RNil) req of
     Left err -> return err
     Right (ParamFile fileName :& ParamPos pos :& RNil) -> do
@@ -106,7 +106,7 @@ demoteCmd _ctxs req = do
 -- ---------------------------------------------------------------------
 
 dupdefCmd :: CommandFunc [FilePath]
-dupdefCmd _ctxs req = do
+dupdefCmd = CmdSync $ \_ctxs req -> do
   case getParams (IdFile "file" :& IdPos "start_pos" :& IdText "name" :& RNil) req of
     Left err -> return err
     Right (ParamFile fileName :& ParamPos pos :& ParamText name :& RNil) -> do
@@ -125,7 +125,7 @@ dupdefCmd _ctxs req = do
 -- ---------------------------------------------------------------------
 
 iftocaseCmd :: CommandFunc [FilePath]
-iftocaseCmd _ctxs req = do
+iftocaseCmd = CmdSync $ \_ctxs req -> do
   case getParams (IdFile "file" :& IdPos "start_pos" :& IdPos "end_pos" :& RNil) req of
     Left err -> return err
     Right (ParamFile fileName :& ParamPos start :& ParamPos end :& RNil) -> do
@@ -144,7 +144,7 @@ iftocaseCmd _ctxs req = do
 -- ---------------------------------------------------------------------
 
 liftonelevelCmd :: CommandFunc [FilePath]
-liftonelevelCmd _ctxs req = do
+liftonelevelCmd = CmdSync $ \_ctxs req -> do
   case getParams (IdFile "file" :& IdPos "start_pos" :& RNil) req of
     Left err -> return err
     Right (ParamFile fileName :& ParamPos pos :& RNil) -> do
@@ -163,7 +163,7 @@ liftonelevelCmd _ctxs req = do
 -- ---------------------------------------------------------------------
 
 lifttotoplevelCmd :: CommandFunc [FilePath]
-lifttotoplevelCmd _ctxs req = do
+lifttotoplevelCmd = CmdSync $ \_ctxs req -> do
   case getParams (IdFile "file" :& IdPos "start_pos" :& RNil) req of
     Left err -> return err
     Right (ParamFile fileName :& ParamPos pos :& RNil) -> do
@@ -182,7 +182,7 @@ lifttotoplevelCmd _ctxs req = do
 -- ---------------------------------------------------------------------
 
 renameCmd :: CommandFunc [FilePath]
-renameCmd _ctxs req = do
+renameCmd = CmdSync $ \_ctxs req -> do
   case getParams (IdFile "file" :& IdPos "start_pos" :& IdText "name" :& RNil) req of
     Left err -> return err
     Right (ParamFile fileName :& ParamPos pos :& ParamText name :& RNil) -> do

src/Haskell/Ide/Engine/BasePlugin.hs

@@ -76,15 +76,15 @@ baseDescriptor = PluginDescriptor
 -- ---------------------------------------------------------------------
 
 versionCmd :: CommandFunc String
-versionCmd _ _ = return (IdeResponseOk version)
+versionCmd = CmdSync $ \_ _ -> return (IdeResponseOk version)
 
 pluginsCmd :: CommandFunc Plugins
-pluginsCmd _ _ = do
+pluginsCmd = CmdSync $ \_ _ -> do
   plugins <- getPlugins
   return (IdeResponseOk plugins)
 
 commandsCmd :: CommandFunc [CommandName]
-commandsCmd _ req = do
+commandsCmd = CmdSync $ \_ req -> do
   plugins <- getPlugins
   -- TODO: Use Maybe Monad. What abut error reporting?
   case Map.lookup "plugin" (ideParams req) of
@@ -97,7 +97,7 @@ commandsCmd _ req = do
     Just x -> return $ incorrectParameter "plugin" ("ParamText"::String) x
 
 commandDetailCmd :: CommandFunc CommandDescriptor
-commandDetailCmd _ req = do
+commandDetailCmd = CmdSync $ \_ req -> do
   plugins <- getPlugins
   case getParams (IdText "plugin" :& IdText "command" :& RNil) req of
     Left err -> return err

src/Haskell/Ide/Engine/Console.hs

@@ -2,8 +2,9 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 module Haskell.Ide.Engine.Console where
 
-import           Control.Concurrent
+import           Control.Concurrent.STM.TChan
 import           Control.Monad.IO.Class
+import           Control.Monad.STM
 import           Data.Attoparsec.Text
 import qualified Data.Map as Map
 import           Data.Monoid
@@ -24,9 +25,9 @@ emptyEnv = ReplEnv
 
 -- ---------------------------------------------------------------------
 
-consoleListener :: Plugins -> Chan ChannelRequest -> IO ()
+consoleListener :: Plugins -> TChan ChannelRequest -> IO ()
 consoleListener plugins cin = do
-  cout <- newChan :: IO (Chan ChannelResponse)
+  cout <- atomically newTChan :: IO (TChan ChannelResponse)
   let
     startLoop :: ReplEnv -> Int -> InputT IO ()
     startLoop env cid = do
@@ -51,8 +52,8 @@ consoleListener plugins cin = do
               case req of
                 Left err -> outputStrLn (T.unpack err)
                 Right (plugin,reqVal) -> do
-                  liftIO $ writeChan cin (CReq plugin cid reqVal cout)
-                  rsp <- liftIO $ readChan cout
+                  liftIO $ atomically $ writeTChan cin (CReq plugin cid reqVal cout)
+                  rsp <- liftIO $ atomically $ readTChan cout
                   outputStrLn $ show (coutResp rsp)
               loop env (cid + 1)
 

src/Haskell/Ide/Engine/Dispatcher.hs

@@ -3,9 +3,10 @@
 {-# LANGUAGE GADTs #-}
 module Haskell.Ide.Engine.Dispatcher where
 
-import           Control.Concurrent
+import           Control.Concurrent.STM.TChan
 import           Control.Monad
 import           Control.Monad.IO.Class
+import           Control.Monad.STM
 import           Data.Aeson
 import           Data.Either
 import           Data.Monoid
@@ -21,26 +22,35 @@ import qualified Data.Map as Map
 
 -- |Listen on a Chan for ChannelRequest from the assorted listeners, and route
 -- them through to the appropriate plugin for processing.
-dispatcher :: Chan ChannelRequest -> IdeM ()
+dispatcher :: TChan ChannelRequest -> IdeM ()
 dispatcher cin = do
   plugins <- getPlugins
   forever $ do
     debugm "run:top of loop"
-    req <- liftIO $ readChan cin
+    req <- liftIO $ atomically $ readTChan cin
     debugm $ "main loop:got:" ++ show req
-    resp <- doDispatch plugins req
-    let cr = CResp (cinPlugin req) (cinReqId req) resp
-    liftIO $ writeChan (cinReplyChan req) cr
+    mresp <- doDispatch plugins req
+    case mresp of
+      Nothing -> return ()
+      Just resp -> liftIO $ sendResponse req resp
+
+-- ---------------------------------------------------------------------
+
+-- | Send a response from the plugin to the designated reply channel
+sendResponse :: (ValidResponse a) => ChannelRequest -> IdeResponse a -> IO ()
+sendResponse req resp = do
+  let cr = CResp (cinPlugin req) (cinReqId req) (fmap jsWrite resp)
+  liftIO $ atomically $ writeTChan (cinReplyChan req) cr
 
 -- ---------------------------------------------------------------------
 
 -- | Manage the process of looking up the request in the known plugins,
 -- validating the parameters passed and handing off to the appropriate
 -- 'CommandFunc'
-doDispatch :: Plugins -> ChannelRequest -> IdeM (IdeResponse Object)
+doDispatch :: Plugins -> ChannelRequest -> IdeM (Maybe (IdeResponse Object))
 doDispatch plugins creq = do
   case Map.lookup (cinPlugin creq) plugins of
-    Nothing -> return (IdeResponseError (IdeError
+    Nothing -> return $ Just (IdeResponseError (IdeError
                 UnknownPlugin ("No plugin found for:" <> cinPlugin creq )
                 (Just $ toJSON $ cinPlugin creq)))
     Just desc -> do
@@ -49,13 +59,20 @@ doDispatch plugins creq = do
       debugm $ "doDispatch:desc=" ++ show desc
       debugm $ "doDispatch:req=" ++ show req
       case Map.lookup (pn,ideCommand req) (pluginCache plugins) of
-        Nothing -> return (IdeResponseError (IdeError
+        Nothing -> return $ Just (IdeResponseError (IdeError
                     UnknownCommand ("No such command:" <> ideCommand req )
                     (Just $ toJSON $ ideCommand req)))
-        Just (Command cdesc cfunc) ->
+        Just (Command cdesc cfunc) -> do
           case validateContexts cdesc req of
-            Left err   -> return err
-            Right ctxs -> fmap jsWrite <$> cfunc ctxs req
+            Left err   -> return (Just err)
+            Right ctxs -> case cfunc of
+              CmdSync  f -> do
+                r <- f ctxs req
+                let r2 = fmap jsWrite r
+                return (Just r2)
+              CmdAsync f -> do
+                f (sendResponse creq) ctxs req
+                return Nothing
 
 -- ---------------------------------------------------------------------
 

src/Haskell/Ide/Engine/Transport/JsonHttp.hs

@@ -11,8 +11,9 @@ module Haskell.Ide.Engine.Transport.JsonHttp
   )
   where
 
-import           Control.Concurrent
+import           Control.Concurrent.STM.TChan
 import           Control.Monad.IO.Class
+import           Control.Monad.STM
 import           Data.Aeson
 import qualified Data.Map as Map
 import           Data.Maybe
@@ -54,33 +55,33 @@ testApi = Proxy
 -- that represents the API, are glued together using :<|>.
 --
 -- Each handler runs in the 'ExceptT ServantErr IO' monad.
-server :: Chan ChannelRequest ->  Chan ChannelResponse -> Server HieApi
+server :: TChan ChannelRequest ->  TChan ChannelResponse -> Server HieApi
 server cin cout = hieH
               :<|> egH
 
   where
         hieH plugin mrid reqVal = do
           let rid = fromMaybe 1 mrid
-          liftIO $ writeChan cin (CReq plugin rid reqVal cout)
-          rsp <- liftIO $ readChan cout
+          liftIO $ atomically $ writeTChan cin (CReq plugin rid reqVal cout)
+          rsp <- liftIO $ atomically $ readTChan cout
           return (coutResp rsp)
           -- return (IdeResponseOk (String $ pack $ show r))
 
         egH = return (IdeRequest ("version"::Text) Map.empty)
 
 -- Turn the server into a WAI app. 'serve' is provided by servant,
 -- more precisely by the Servant.Server module.
-test :: Chan ChannelRequest -> Chan ChannelResponse -> Application
+test :: TChan ChannelRequest -> TChan ChannelResponse -> Application
 test cin cout = serve testApi (server cin cout)
 
 -- Run the server.
 --
 -- 'run' comes from Network.Wai.Handler.Warp
-runTestServer :: Chan ChannelRequest -> Port -> IO ()
+runTestServer :: TChan ChannelRequest -> Port -> IO ()
 runTestServer cin port = do
-  cout <- newChan :: IO (Chan ChannelResponse)
+  cout <- atomically newTChan :: IO (TChan ChannelResponse)
   run port (test cin cout)
 
 -- Put this all to work!
-jsonHttpListener :: Chan ChannelRequest -> Port -> IO ()
+jsonHttpListener :: TChan ChannelRequest -> Port -> IO ()
 jsonHttpListener cin port = runTestServer cin port