Skip to content
This repository was archived by the owner on Oct 7, 2020. It is now read-only.

Async dispatch #72

Merged
merged 2 commits into from
Nov 14, 2015
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
10 changes: 6 additions & 4 deletions app/MainHie.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -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

Expand Down Expand Up @@ -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

5 changes: 5 additions & 0 deletions haskell-ide-engine.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -49,6 +49,7 @@ library
, pipes-attoparsec >= 0.5
, pipes-bytestring
, pipes-parse
, stm
, servant-server
, text
, time
Expand Down Expand Up @@ -79,6 +80,7 @@ executable hie
, logging
, optparse-applicative
, optparse-simple
, stm
, text
, time
, transformers
Expand All @@ -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

Expand Down
4 changes: 2 additions & 2 deletions haskell-ide-example-plugin2/Haskell/Ide/ExamplePlugin2.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
10 changes: 9 additions & 1 deletion haskell-ide-plugin-api/Haskell/Ide/Engine/PluginDescriptor.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand Down
10 changes: 5 additions & 5 deletions haskell-ide-plugin-ghcmod/Haskell/Ide/GhcModPlugin.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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
Expand All @@ -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
Expand All @@ -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
Expand Down
12 changes: 6 additions & 6 deletions haskell-ide-plugin-hare/Haskell/Ide/HaRePlugin.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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
Expand All @@ -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
Expand All @@ -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
Expand All @@ -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
Expand Down
8 changes: 4 additions & 4 deletions src/Haskell/Ide/Engine/BasePlugin.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand Down
11 changes: 6 additions & 5 deletions src/Haskell/Ide/Engine/Console.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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)

Expand Down
41 changes: 29 additions & 12 deletions src/Haskell/Ide/Engine/Dispatcher.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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

-- ---------------------------------------------------------------------

Expand Down
17 changes: 9 additions & 8 deletions src/Haskell/Ide/Engine/Transport/JsonHttp.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Loading