From 89f569e433378c45609223e64d6ac26cf0148188 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Fri, 29 Jun 2018 23:43:29 +0100 Subject: [PATCH] Refactor out some R functions --- src/Haskell/Ide/Engine/LSP/CodeActions.hs | 10 +-- src/Haskell/Ide/Engine/LSP/Config.hs | 4 +- src/Haskell/Ide/Engine/LSP/Reactor.hs | 73 +++++++++++++--- src/Haskell/Ide/Engine/Transport/LspStdio.hs | 87 +++++++++----------- 4 files changed, 109 insertions(+), 65 deletions(-) diff --git a/src/Haskell/Ide/Engine/LSP/CodeActions.hs b/src/Haskell/Ide/Engine/LSP/CodeActions.hs index 7a253d97..eadd1799 100644 --- a/src/Haskell/Ide/Engine/LSP/CodeActions.hs +++ b/src/Haskell/Ide/Engine/LSP/CodeActions.hs @@ -24,17 +24,17 @@ import Language.Haskell.LSP.Messages import Haskell.Ide.Engine.Plugin.Package import Haskell.Ide.Engine.MonadTypes -handleCodeActionReq :: TrackingNumber -> BM.Bimap T.Text T.Text -> (PluginRequest R -> R ()) -> J.CodeActionRequest -> R () -handleCodeActionReq tn commandMap makeRequest req = do +handleCodeActionReq :: TrackingNumber -> BM.Bimap T.Text T.Text -> J.CodeActionRequest -> R () +handleCodeActionReq tn commandMap req = do - vfsFunc <- asks Core.getVirtualFileFunc + vfsFunc <- asksLspFuncs Core.getVirtualFileFunc maybeVf <- liftIO $ vfsFunc doc let docVersion = case maybeVf of Just vf -> _version vf Nothing -> 0 docId = J.VersionedTextDocumentIdentifier doc docVersion - maybeRootDir <- asks Core.rootPath + maybeRootDir <- asksLspFuncs Core.rootPath let hlintActions = mapMaybe mkHlintAction $ filter validCommand diags -- |Some hints do not have an associated refactoring @@ -72,7 +72,7 @@ handleCodeActionReq tn commandMap makeRequest req = do wrapCodeAction :: J.CodeAction -> R (Maybe J.CommandOrCodeAction) wrapCodeAction action = do - (C.ClientCapabilities _ textDocCaps _) <- asks Core.clientCapabilities + (C.ClientCapabilities _ textDocCaps _) <- asksLspFuncs Core.clientCapabilities let literalSupport = textDocCaps >>= C._codeAction >>= C._codeActionLiteralSupport case literalSupport of Nothing -> return $ fmap J.CommandOrCodeActionCommand (action ^. J.command) diff --git a/src/Haskell/Ide/Engine/LSP/Config.hs b/src/Haskell/Ide/Engine/LSP/Config.hs index 5bd48366..eed13083 100644 --- a/src/Haskell/Ide/Engine/LSP/Config.hs +++ b/src/Haskell/Ide/Engine/LSP/Config.hs @@ -7,8 +7,8 @@ import Language.Haskell.LSP.Types -- | Callback from haskell-lsp core to convert the generic message to the -- specific one for hie -getConfig :: DidChangeConfigurationNotification -> Either T.Text Config -getConfig (NotificationMessage _ _ (DidChangeConfigurationParams p)) = +getConfigFromNotification :: DidChangeConfigurationNotification -> Either T.Text Config +getConfigFromNotification (NotificationMessage _ _ (DidChangeConfigurationParams p)) = case fromJSON p of Success c -> Right c Error err -> Left $ T.pack err diff --git a/src/Haskell/Ide/Engine/LSP/Reactor.hs b/src/Haskell/Ide/Engine/LSP/Reactor.hs index e1416a5b..63c72ad0 100644 --- a/src/Haskell/Ide/Engine/LSP/Reactor.hs +++ b/src/Haskell/Ide/Engine/LSP/Reactor.hs @@ -1,29 +1,78 @@ {-# LANGUAGE FlexibleContexts #-} -module Haskell.Ide.Engine.LSP.Reactor where +module Haskell.Ide.Engine.LSP.Reactor + ( R + , runReactor + , reactorSend + , reactorSend' + , makeRequest + , asksLspFuncs + , REnv(..) + ) +where -import Control.Monad.Reader -import qualified Language.Haskell.LSP.Core as Core -import Language.Haskell.LSP.Messages -import Haskell.Ide.Engine.LSP.Config +import Control.Concurrent.STM +import Control.Monad.Reader +import qualified Data.Set as S +import qualified Language.Haskell.LSP.Core as Core +import qualified Language.Haskell.LSP.Messages as J +import qualified Language.Haskell.LSP.Types as J +import Haskell.Ide.Engine.Dispatcher +import Haskell.Ide.Engine.LSP.Config +import Haskell.Ide.Engine.Types + + +data REnv = REnv + { dispatcherEnv :: DispatcherEnv + , reqChanIn :: TChan (PluginRequest R) + , lspFuncs :: Core.LspFuncs Config + } -- | The monad used in the reactor -type R = ReaderT (Core.LspFuncs Config) IO +type R = ReaderT REnv IO + +-- --------------------------------------------------------------------- + +runReactor + :: Core.LspFuncs Config + -> DispatcherEnv + -> TChan (PluginRequest R) + -> R a + -> IO a +runReactor lf de cin = flip runReaderT (REnv de cin lf) + +-- --------------------------------------------------------------------- + +asksLspFuncs :: MonadReader REnv m => (Core.LspFuncs Config -> a) -> m a +asksLspFuncs f = asks (f . lspFuncs) -- --------------------------------------------------------------------- -- reactor monad functions -- --------------------------------------------------------------------- -reactorSend :: (MonadIO m, MonadReader (Core.LspFuncs Config) m) => FromServerMessage -> m () +reactorSend :: (MonadIO m, MonadReader REnv m) => J.FromServerMessage -> m () reactorSend msg = do - sf <- asks Core.sendFunc + sf <- asksLspFuncs Core.sendFunc liftIO $ sf msg -- --------------------------------------------------------------------- -reactorSend' :: (MonadIO m, MonadReader (Core.LspFuncs Config) m) - => (Core.SendFunc -> IO ()) -> m () +reactorSend' + :: (MonadIO m, MonadReader REnv m) => (Core.SendFunc -> IO ()) -> m () reactorSend' f = do - lf <- ask - liftIO $ f (Core.sendFunc lf) + sf <- asksLspFuncs Core.sendFunc + liftIO $ f sf -- --------------------------------------------------------------------- + +makeRequest :: (MonadIO m, MonadReader REnv m) => PluginRequest R -> m () +makeRequest req@(GReq _ _ Nothing (Just lid) _ _) = writePluginReq req lid +makeRequest req@(IReq _ lid _ _) = writePluginReq req lid +makeRequest req = liftIO . atomically . flip writeTChan req =<< asks reqChanIn + +writePluginReq :: (MonadIO m, MonadReader REnv m) => PluginRequest R -> J.LspId -> m () +writePluginReq req lid = do + wipTVar <- asks (wipReqsTVar . dispatcherEnv) + cin <- asks reqChanIn + liftIO $ atomically $ do + modifyTVar wipTVar (S.insert lid) + writeTChan cin req diff --git a/src/Haskell/Ide/Engine/Transport/LspStdio.hs b/src/Haskell/Ide/Engine/Transport/LspStdio.hs index 48c80166..81fca5ed 100644 --- a/src/Haskell/Ide/Engine/Transport/LspStdio.hs +++ b/src/Haskell/Ide/Engine/Transport/LspStdio.hs @@ -108,27 +108,27 @@ run dispatcherProc cin _origDir captureFp = flip E.catches handlers $ do cancelTVar <- atomically $ newTVar S.empty wipTVar <- atomically $ newTVar S.empty versionTVar <- atomically $ newTVar Map.empty - let dispatcherEnv = DispatcherEnv + let dEnv = DispatcherEnv { cancelReqsTVar = cancelTVar , wipReqsTVar = wipTVar , docVersionTVar = versionTVar } - let reactorFunc = flip runReaderT lf $ reactor dispatcherEnv cin rin commandMap + let reactorFunc = runReactor lf dEnv cin $ reactor rin commandMap let errorHandler :: ErrorHandler errorHandler lid code e = Core.sendErrorResponseS (Core.sendFunc lf) (J.responseId lid) code e callbackHandler :: CallbackHandler R - callbackHandler f x = flip runReaderT lf $ f x + callbackHandler f x = runReactor lf dEnv cin $ f x -- haskell lsp sets the current directory to the project root in the InitializeRequest -- We launch the dispatcher after that so that the defualt cradle is -- recognized properly by ghc-mod - _ <- forkIO $ race_ (dispatcherProc dispatcherEnv errorHandler callbackHandler) reactorFunc + _ <- forkIO $ race_ (dispatcherProc dEnv errorHandler callbackHandler) reactorFunc return Nothing flip E.finally finalProc $ do - CTRL.run (getConfig, dp) (hieHandlers rin) (hieOptions (BM.elems commandMap)) captureFp + CTRL.run (getConfigFromNotification, dp) (hieHandlers rin) (hieOptions (BM.elems commandMap)) captureFp where handlers = [E.Handler ioExcept, E.Handler someExcept] finalProc = L.removeAllHandlers @@ -150,16 +150,16 @@ type ReactorInput configVal :: c -> (Config -> c) -> R c configVal defVal field = do - gmc <- asks Core.config + gmc <- asksLspFuncs Core.config mc <- liftIO gmc return $ maybe defVal field mc -- --------------------------------------------------------------------- -getPrefixAtPos :: (MonadIO m, MonadReader (Core.LspFuncs Config) m) +getPrefixAtPos :: (MonadIO m, MonadReader REnv m) => Uri -> Position -> m (Maybe (T.Text,T.Text)) getPrefixAtPos uri (Position l c) = do - mvf <- liftIO =<< asks Core.getVirtualFileFunc <*> pure uri + mvf <- liftIO =<< asksLspFuncs Core.getVirtualFileFunc <*> pure uri case mvf of Just (VFS.VirtualFile _ yitext) -> return $ do let headMaybe [] = Nothing @@ -182,14 +182,16 @@ getPrefixAtPos uri (Position l c) = do -- --------------------------------------------------------------------- -mapFileFromVfs :: (MonadIO m, MonadReader (Core.LspFuncs Config) m) - => TrackingNumber - -> TVar (Map.Map Uri Int) -> TChan (PluginRequest R) - -> J.VersionedTextDocumentIdentifier -> m () -mapFileFromVfs tn verTVar cin vtdi = do + +mapFileFromVfs :: (MonadIO m, MonadReader REnv m) + => TrackingNumber + -> J.VersionedTextDocumentIdentifier -> m () +mapFileFromVfs tn vtdi = do + verTVar <- asks (docVersionTVar . dispatcherEnv) + cin <- asks reqChanIn let uri = vtdi ^. J.uri ver = vtdi ^. J.version - vfsFunc <- asks Core.getVirtualFileFunc + vfsFunc <- asksLspFuncs Core.getVirtualFileFunc mvf <- liftIO $ vfsFunc uri case (mvf, uriToFilePath uri) of (Just (VFS.VirtualFile _ yitext), Just fp) -> do @@ -206,13 +208,14 @@ mapFileFromVfs tn verTVar cin vtdi = do return () (_, _) -> return () -_unmapFileFromVfs :: (MonadIO m) - => TrackingNumber -> TVar (Map.Map Uri Int) -> TChan (PluginRequest R) -> Uri -> m () -_unmapFileFromVfs tn verTVar cin uri = do - case uriToFilePath uri of +_unmapFileFromVfs :: (MonadIO m, MonadReader REnv m) => TrackingNumber -> J.Uri -> m () +_unmapFileFromVfs tn uri = do + verTVar <- asks (docVersionTVar . dispatcherEnv) + cin <- asks reqChanIn + case J.uriToFilePath uri of Just fp -> do let req = GReq tn (Just uri) Nothing Nothing (const $ return ()) - $ IdeResultOk <$> GM.unloadMappedFile fp + $ IdeResultOk <$> GM.unloadMappedFile fp liftIO $ atomically $ do modifyTVar' verTVar (Map.delete uri) writeTChan cin req @@ -250,31 +253,31 @@ updatePositionMap uri changes = pluginGetFile "updatePositionMap: " uri $ \file -- --------------------------------------------------------------------- -publishDiagnostics :: (MonadIO m, MonadReader (Core.LspFuncs Config) m) +publishDiagnostics :: (MonadIO m, MonadReader REnv m) => Int -> J.Uri -> Maybe J.TextDocumentVersion -> DiagnosticsBySource -> m () publishDiagnostics maxToSend uri' mv diags = do - lf <- ask + lf <- asks lspFuncs liftIO $ (Core.publishDiagnosticsFunc lf) maxToSend uri' mv diags -- --------------------------------------------------------------------- -flushDiagnosticsBySource :: (MonadIO m, MonadReader (Core.LspFuncs Config) m) +flushDiagnosticsBySource :: (MonadIO m, MonadReader REnv m) => Int -> Maybe J.DiagnosticSource -> m () flushDiagnosticsBySource maxToSend msource = do - lf <- ask + lf <- asks lspFuncs liftIO $ (Core.flushDiagnosticsBySourceFunc lf) maxToSend msource -- --------------------------------------------------------------------- -nextLspReqId :: (MonadIO m, MonadReader (Core.LspFuncs Config) m) +nextLspReqId :: (MonadIO m, MonadReader REnv m) => m J.LspId nextLspReqId = do - f <- asks Core.getNextReqId + f <- asksLspFuncs Core.getNextReqId liftIO f -- --------------------------------------------------------------------- -sendErrorLog :: (MonadIO m, MonadReader (Core.LspFuncs Config) m) +sendErrorLog :: (MonadIO m, MonadReader REnv m) => T.Text -> m () sendErrorLog msg = reactorSend' (`Core.sendErrorLogS` msg) @@ -289,18 +292,8 @@ sendErrorLog msg = reactorSend' (`Core.sendErrorLogS` msg) -- | The single point that all events flow through, allowing management of state -- to stitch replies and requests together from the two asynchronous sides: lsp -- server and hie dispatcher -reactor :: forall void. DispatcherEnv -> TChan (PluginRequest R) -> TChan ReactorInput -> BM.Bimap T.Text T.Text -> R void -reactor (DispatcherEnv cancelReqTVar wipTVar versionTVar) cin inp commandMap = do - let - makeRequest req@(GReq _ _ Nothing (Just lid) _ _) = liftIO $ atomically $ do - modifyTVar wipTVar (S.insert lid) - writeTChan cin req - makeRequest req@(IReq _ lid _ _) = liftIO $ atomically $ do - modifyTVar wipTVar (S.insert lid) - writeTChan cin req - makeRequest req = - liftIO $ atomically $ writeTChan cin req - +reactor :: forall void. TChan ReactorInput -> BM.Bimap T.Text T.Text -> R void +reactor inp commandMap = do -- forever $ do let loop :: TrackingNumber -> R void @@ -383,8 +376,8 @@ reactor (DispatcherEnv cancelReqTVar wipTVar versionTVar) cin inp commandMap = d td = notification ^. J.params . J.textDocument uri = td ^. J.uri ver = td ^. J.version - mapFileFromVfs tn versionTVar cin $ J.VersionedTextDocumentIdentifier uri ver - requestDiagnostics tn cin uri ver + mapFileFromVfs tn $ J.VersionedTextDocumentIdentifier uri ver + requestDiagnostics tn uri ver -- ------------------------------- @@ -408,14 +401,14 @@ reactor (DispatcherEnv cancelReqTVar wipTVar versionTVar) cin inp commandMap = d uri = vtdi ^. J.uri ver = vtdi ^. J.version J.List changes = params ^. J.contentChanges - mapFileFromVfs tn versionTVar cin vtdi + mapFileFromVfs tn vtdi makeRequest $ GReq tn (Just uri) Nothing Nothing (const $ return ()) $ -- mark this module's cache as stale pluginGetFile "markCacheStale:" uri $ \fp -> do markCacheStale fp -- Important - Call this before requestDiagnostics updatePositionMap uri changes - requestDiagnostics tn cin uri ver + requestDiagnostics tn uri ver NotDidCloseTextDocument notification -> do liftIO $ U.logm "****** reactor: processing NotDidCloseTextDocument" @@ -520,7 +513,7 @@ reactor (DispatcherEnv cancelReqTVar wipTVar versionTVar) cin inp commandMap = d ReqCodeAction req -> do liftIO $ U.logs $ "reactor:got CodeActionRequest:" ++ show req - handleCodeActionReq tn commandMap makeRequest req + handleCodeActionReq tn commandMap req -- TODO: make context specific commands for all sorts of things, such as refactorings -- ------------------------------- @@ -682,6 +675,7 @@ reactor (DispatcherEnv cancelReqTVar wipTVar versionTVar) cin inp commandMap = d NotCancelRequestFromClient notif -> do liftIO $ U.logs $ "reactor:got CancelRequest:" ++ show notif let lid = notif ^. J.params . J.id + DispatcherEnv cancelReqTVar wipTVar _ <- asks dispatcherEnv liftIO $ atomically $ do wip <- readTVar wipTVar when (S.member lid wip) $ do @@ -738,9 +732,10 @@ getDocsForName name pkg modName' = do -- --------------------------------------------------------------------- -- | get hlint and GHC diagnostics and loads the typechecked module into the cache -requestDiagnostics :: TrackingNumber -> TChan (PluginRequest R) -> J.Uri -> Int -> R () -requestDiagnostics tn cin file ver = do - lf <- ask +requestDiagnostics :: TrackingNumber -> J.Uri -> Int -> R () +requestDiagnostics tn file ver = do + lf <- asks lspFuncs + cin <- asks reqChanIn mc <- liftIO $ Core.config lf let -- | If there is a GHC error, flush the hlint diagnostics