diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,23 @@ # Revision history for haskell-lsp +## 0.4.0.0 -- 2018-07-10 + +* CodeAction support as per v3.8 of the specification, by @Bubba +* Update VersionedTextDocumentIdentifier to match specification, by @Bubba + +## 0.3.0.0 + +* Handle TextDocumentSync fallbacks with new TDS type. + +## 0.2.3.0 -- 2018-99-99 + +* GHC 8.4.3 support +* Apply changes to the VFS in the order received in a message. + This fixes vscode undo behaviour. By @Bubba +* Introduce additional error codes as per the LSP spec. By @Bubba +* Add preliminary support for recording LSP traffic for later playback + in test scenarios. By @Bubba + ## 0.2.2.0 -- 2018-05-04 * Make Diagnostic relatedInformation optional, as per the LSP Spec. By @Bubba. diff --git a/example/Main.hs b/example/Main.hs --- a/example/Main.hs +++ b/example/Main.hs @@ -57,16 +57,16 @@ let dp lf = do - liftIO $ U.logs $ "main.run:dp entered" + liftIO $ U.logs "main.run:dp entered" _rpid <- forkIO $ reactor lf rin - liftIO $ U.logs $ "main.run:dp tchan" + liftIO $ U.logs "main.run:dp tchan" dispatcherProc - liftIO $ U.logs $ "main.run:dp after dispatcherProc" + liftIO $ U.logs "main.run:dp after dispatcherProc" return Nothing flip E.finally finalProc $ do Core.setupLogger (Just "/tmp/lsp-hello.log") [] L.DEBUG - CTRL.run (return (Right ()), dp) (lspHandlers rin) lspOptions + CTRL.run (return (Right ()), dp) (lspHandlers rin) lspOptions (Just "/tmp/lsp-hello-session.log") where handlers = [ E.Handler ioExcept @@ -83,7 +83,7 @@ -- reply sent. data ReactorInput - = HandlerRequest Core.OutMessage + = HandlerRequest FromClientMessage -- ^ injected into the reactor input by each of the individual callback handlers -- --------------------------------------------------------------------- @@ -97,24 +97,24 @@ -- --------------------------------------------------------------------- -reactorSend :: (J.ToJSON a) => a -> R () () +reactorSend :: FromServerMessage -> R () () reactorSend msg = do lf <- ask liftIO $ Core.sendFunc lf msg -- --------------------------------------------------------------------- -publishDiagnostics :: Int -> J.Uri -> Maybe J.TextDocumentVersion -> DiagnosticsBySource -> R () () -publishDiagnostics maxToPublish uri mv diags = do +publishDiagnostics :: Int -> J.Uri -> J.TextDocumentVersion -> DiagnosticsBySource -> R () () +publishDiagnostics maxToPublish uri v diags = do lf <- ask - liftIO $ (Core.publishDiagnosticsFunc lf) maxToPublish uri mv diags + liftIO $ (Core.publishDiagnosticsFunc lf) maxToPublish uri v diags -- --------------------------------------------------------------------- nextLspReqId :: R () J.LspId nextLspReqId = do f <- asks Core.getNextReqId - liftIO $ f + liftIO f -- --------------------------------------------------------------------- @@ -123,20 +123,20 @@ -- server and backend compiler reactor :: Core.LspFuncs () -> TChan ReactorInput -> IO () reactor lf inp = do - liftIO $ U.logs $ "reactor:entered" + liftIO $ U.logs "reactor:entered" flip runReaderT lf $ forever $ do inval <- liftIO $ atomically $ readTChan inp case inval of -- Handle any response from a message originating at the server, such as -- "workspace/applyEdit" - HandlerRequest (Core.RspFromClient rm) -> do + HandlerRequest (RspFromClient rm) -> do liftIO $ U.logs $ "reactor:got RspFromClient:" ++ show rm -- ------------------------------- - HandlerRequest (Core.NotInitialized _notification) -> do - liftIO $ U.logm $ "****** reactor: processing Initialized Notification" + HandlerRequest (NotInitialized _notification) -> do + liftIO $ U.logm "****** reactor: processing Initialized Notification" -- Server is ready, register any specific capabilities we need {- @@ -163,7 +163,7 @@ let registrations = J.RegistrationParams (J.List [registration]) rid <- nextLspReqId - reactorSend $ fmServerRegisterCapabilityRequest rid registrations + reactorSend $ ReqRegisterCapability $ fmServerRegisterCapabilityRequest rid registrations -- example of showMessageRequest let @@ -171,12 +171,12 @@ (Just [J.MessageActionItem "option a", J.MessageActionItem "option b"]) rid1 <- nextLspReqId - reactorSend $ fmServerShowMessageRequest rid1 params + reactorSend $ ReqShowMessage $ fmServerShowMessageRequest rid1 params -- ------------------------------- - HandlerRequest (Core.NotDidOpenTextDocument notification) -> do - liftIO $ U.logm $ "****** reactor: processing NotDidOpenTextDocument" + HandlerRequest (NotDidOpenTextDocument notification) -> do + liftIO $ U.logm "****** reactor: processing NotDidOpenTextDocument" let doc = notification ^. J.params . J.textDocument @@ -187,7 +187,7 @@ -- ------------------------------- - HandlerRequest (Core.NotDidChangeTextDocument notification) -> do + HandlerRequest (NotDidChangeTextDocument notification) -> do let doc :: J.Uri doc = notification ^. J.params . J.textDocument @@ -197,13 +197,13 @@ Just (VirtualFile _version str) -> do liftIO $ U.logs $ "reactor:processing NotDidChangeTextDocument: vf got:" ++ (show $ Yi.toString str) Nothing -> do - liftIO $ U.logs $ "reactor:processing NotDidChangeTextDocument: vf returned Nothing" + liftIO $ U.logs "reactor:processing NotDidChangeTextDocument: vf returned Nothing" liftIO $ U.logs $ "reactor:processing NotDidChangeTextDocument: uri=" ++ (show doc) -- ------------------------------- - HandlerRequest (Core.NotDidSaveTextDocument notification) -> do + HandlerRequest (NotDidSaveTextDocument notification) -> do liftIO $ U.logm "****** reactor: processing NotDidSaveTextDocument" let doc = notification ^. J.params @@ -215,7 +215,7 @@ -- ------------------------------- - HandlerRequest (Core.ReqRename req) -> do + HandlerRequest (ReqRename req) -> do liftIO $ U.logs $ "reactor:got RenameRequest:" ++ show req let _params = req ^. J.params @@ -227,11 +227,11 @@ Nothing -- "changes" field is deprecated (Just (J.List [])) -- populate with actual changes from the rename let rspMsg = Core.makeResponseMessage req we - reactorSend rspMsg + reactorSend $ RspRename rspMsg -- ------------------------------- - HandlerRequest (Core.ReqHover req) -> do + HandlerRequest (ReqHover req) -> do liftIO $ U.logs $ "reactor:got HoverRequest:" ++ show req let J.TextDocumentPositionParams _doc pos = req ^. J.params J.Position _l _c' = pos @@ -240,11 +240,11 @@ ht = J.Hover ms (Just range) ms = J.List [J.CodeString $ J.LanguageString "lsp-hello" "TYPE INFO" ] range = J.Range pos pos - reactorSend $ Core.makeResponseMessage req ht + reactorSend $ RspHover $ Core.makeResponseMessage req ht -- ------------------------------- - HandlerRequest (Core.ReqCodeAction req) -> do + HandlerRequest (ReqCodeAction req) -> do liftIO $ U.logs $ "reactor:got CodeActionRequest:" ++ show req let params = req ^. J.params doc = params ^. J.textDocument @@ -266,20 +266,21 @@ ] cmdparams = Just args makeCommand (J.Diagnostic _r _s _c _source _m _l) = [] - let body = J.List $ concatMap makeCommand diags - reactorSend $ Core.makeResponseMessage req body + let body = J.List $ map J.CommandOrCodeActionCommand $ concatMap makeCommand diags + rsp = Core.makeResponseMessage req body + reactorSend $ RspCodeAction rsp -- ------------------------------- - HandlerRequest (Core.ReqExecuteCommand req) -> do - liftIO $ U.logs $ "reactor:got ExecuteCommandRequest:" -- ++ show req + HandlerRequest (ReqExecuteCommand req) -> do + liftIO $ U.logs "reactor:got ExecuteCommandRequest:" -- ++ show req let params = req ^. J.params margs = params ^. J.arguments liftIO $ U.logs $ "reactor:ExecuteCommandRequest:margs=" ++ show margs let - reply v = reactorSend $ Core.makeResponseMessage req v + reply v = reactorSend $ RspExecuteCommand $ Core.makeResponseMessage req v -- When we get a RefactorResult or HieDiff, we need to send a -- separate WorkspaceEdit Notification r = J.List [] :: J.List Int @@ -289,7 +290,7 @@ reply (J.Object mempty) lid <- nextLspReqId -- reactorSend $ J.RequestMessage "2.0" lid "workspace/applyEdit" (Just we) - reactorSend $ fmServerApplyWorkspaceEditRequest lid we + reactorSend $ ReqApplyWorkspaceEdit $ fmServerApplyWorkspaceEditRequest lid we Nothing -> reply (J.Object mempty) @@ -308,7 +309,7 @@ -- | Analyze the file and send any diagnostics to the client in a -- "textDocument/publishDiagnostics" notification sendDiagnostics :: J.Uri -> Maybe Int -> R () () -sendDiagnostics fileUri mversion = do +sendDiagnostics fileUri version = do let diags = [J.Diagnostic (J.Range (J.Position 0 1) (J.Position 0 5)) @@ -319,7 +320,7 @@ (Just (J.List [])) ] -- reactorSend $ J.NotificationMessage "2.0" "textDocument/publishDiagnostics" (Just r) - publishDiagnostics 100 fileUri mversion (partitionBySource diags) + publishDiagnostics 100 fileUri version (partitionBySource diags) -- --------------------------------------------------------------------- @@ -339,22 +340,22 @@ lspHandlers :: TChan ReactorInput -> Core.Handlers lspHandlers rin - = def { Core.initializedHandler = Just $ passHandler rin Core.NotInitialized - , Core.renameHandler = Just $ passHandler rin Core.ReqRename - , Core.hoverHandler = Just $ passHandler rin Core.ReqHover - , Core.didOpenTextDocumentNotificationHandler = Just $ passHandler rin Core.NotDidOpenTextDocument - , Core.didSaveTextDocumentNotificationHandler = Just $ passHandler rin Core.NotDidSaveTextDocument - , Core.didChangeTextDocumentNotificationHandler = Just $ passHandler rin Core.NotDidChangeTextDocument - , Core.didCloseTextDocumentNotificationHandler = Just $ passHandler rin Core.NotDidCloseTextDocument - , Core.cancelNotificationHandler = Just $ passHandler rin Core.NotCancelRequest + = def { Core.initializedHandler = Just $ passHandler rin NotInitialized + , Core.renameHandler = Just $ passHandler rin ReqRename + , Core.hoverHandler = Just $ passHandler rin ReqHover + , Core.didOpenTextDocumentNotificationHandler = Just $ passHandler rin NotDidOpenTextDocument + , Core.didSaveTextDocumentNotificationHandler = Just $ passHandler rin NotDidSaveTextDocument + , Core.didChangeTextDocumentNotificationHandler = Just $ passHandler rin NotDidChangeTextDocument + , Core.didCloseTextDocumentNotificationHandler = Just $ passHandler rin NotDidCloseTextDocument + , Core.cancelNotificationHandler = Just $ passHandler rin NotCancelRequestFromClient , Core.responseHandler = Just $ responseHandlerCb rin - , Core.codeActionHandler = Just $ passHandler rin Core.ReqCodeAction - , Core.executeCommandHandler = Just $ passHandler rin Core.ReqExecuteCommand + , Core.codeActionHandler = Just $ passHandler rin ReqCodeAction + , Core.executeCommandHandler = Just $ passHandler rin ReqExecuteCommand } -- --------------------------------------------------------------------- -passHandler :: TChan ReactorInput -> (a -> Core.OutMessage) -> Core.Handler a +passHandler :: TChan ReactorInput -> (a -> FromClientMessage) -> Core.Handler a passHandler rin c notification = do atomically $ writeTChan rin (HandlerRequest (c notification)) diff --git a/haskell-lsp.cabal b/haskell-lsp.cabal --- a/haskell-lsp.cabal +++ b/haskell-lsp.cabal @@ -1,5 +1,5 @@ name: haskell-lsp -version: 0.2.2.0 +version: 0.4.0.0 synopsis: Haskell library for the Microsoft Language Server Protocol description: An implementation of the types, and basic message server to @@ -14,19 +14,21 @@ license-file: LICENSE author: Alan Zimmerman maintainer: alan.zimm@gmail.com -copyright: Alan Zimmerman, 2016-2017 +copyright: Alan Zimmerman, 2016-2018 category: Development build-type: Simple extra-source-files: ChangeLog.md, README.md cabal-version: >=1.10 library - exposed-modules: Language.Haskell.LSP.Constant + exposed-modules: Language.Haskell.LSP.Capture + , Language.Haskell.LSP.Constant , Language.Haskell.LSP.Core , Language.Haskell.LSP.Control , Language.Haskell.LSP.Diagnostics , Language.Haskell.LSP.Messages , Language.Haskell.LSP.Types + , Language.Haskell.LSP.Types.Capabilities , Language.Haskell.LSP.Utility , Language.Haskell.LSP.VFS -- other-modules: @@ -42,7 +44,7 @@ , filepath , hslogger , hashable - , haskell-lsp-types + , haskell-lsp-types >= 0.4 , lens >= 4.15.2 , mtl , network-uri diff --git a/src/Language/Haskell/LSP/Capture.hs b/src/Language/Haskell/LSP/Capture.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/LSP/Capture.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +module Language.Haskell.LSP.Capture where + +import Data.Aeson +import Data.ByteString.Lazy.Char8 as BSL +import Data.Time.Clock +import GHC.Generics +import Language.Haskell.LSP.Messages + +data Event = FromClient UTCTime FromClientMessage + | FromServer UTCTime FromServerMessage + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +captureFromServer :: FromServerMessage -> Maybe FilePath -> IO () +captureFromServer _ Nothing = return () +captureFromServer msg (Just fp) = do + time <- getCurrentTime + let entry = FromServer time msg + + BSL.appendFile fp $ BSL.append (encode entry) "\n" + +captureFromClient :: FromClientMessage -> Maybe FilePath -> IO () +captureFromClient _ Nothing = return () +captureFromClient msg (Just fp) = do + time <- getCurrentTime + let entry = FromClient time msg + + BSL.appendFile fp $ BSL.append (encode entry) "\n" diff --git a/src/Language/Haskell/LSP/Control.hs b/src/Language/Haskell/LSP/Control.hs --- a/src/Language/Haskell/LSP/Control.hs +++ b/src/Language/Haskell/LSP/Control.hs @@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE BinaryLiterals #-} {-# LANGUAGE OverloadedStrings #-} @@ -9,6 +8,7 @@ module Language.Haskell.LSP.Control ( run + , runWithHandles ) where import Control.Concurrent @@ -19,56 +19,87 @@ import qualified Data.Aeson as J import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as B +import Data.Time.Clock +import Data.Time.Format #if __GLASGOW_HASKELL__ < 804 import Data.Monoid #endif +import Language.Haskell.LSP.Capture import qualified Language.Haskell.LSP.Core as Core +import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Utility import System.IO +import System.FilePath import Text.Parsec -- --------------------------------------------------------------------- +-- | Convenience function for 'runWithHandles stdin stdout'. run :: (Show c) => Core.InitializeCallback c - -- ^ function to be called once initialize has - -- been received from the client. Further message - -- processing will start only after this returns. + -- ^ function to be called once initialize has + -- been received from the client. Further message + -- processing will start only after this returns. -> Core.Handlers -> Core.Options + -> Maybe FilePath + -- ^ File to capture the session to. + -> IO Int +run = runWithHandles stdin stdout + +-- | Starts listening and sending requests and responses +-- at the specified handles. +runWithHandles :: (Show c) => + Handle + -- ^ Handle to read client input from. + -> Handle + -- ^ Handle to write output to. + -> Core.InitializeCallback c + -> Core.Handlers + -> Core.Options + -> Maybe FilePath -> IO Int -- exit code -run dp h o = do +runWithHandles hin hout dp h o captureFp = do logm $ B.pack "\n\n\n\n\nhaskell-lsp:Starting up server ..." - hSetBuffering stdin NoBuffering - hSetEncoding stdin utf8 + hSetBuffering hin NoBuffering + hSetEncoding hin utf8 - hSetBuffering stdout NoBuffering - hSetEncoding stdout utf8 + hSetBuffering hout NoBuffering + hSetEncoding hout utf8 - cout <- atomically newTChan :: IO (TChan BSL.ByteString) - _rhpid <- forkIO $ sendServer cout + timestamp <- formatTime defaultTimeLocale (iso8601DateFormat (Just "%H-%M-%S")) <$> getCurrentTime + let timestampCaptureFp = fmap (\f -> dropExtension f ++ timestamp ++ takeExtension f) + captureFp + cout <- atomically newTChan :: IO (TChan FromServerMessage) + _rhpid <- forkIO $ sendServer cout hout timestampCaptureFp + let sendFunc :: Core.SendFunc - sendFunc str = atomically $ writeTChan cout (J.encode str) + sendFunc msg = atomically $ writeTChan cout msg let lf = error "LifeCycle error, ClientCapabilities not set yet via initialize maessage" tvarId <- atomically $ newTVar 0 - tvarDat <- atomically $ newTVar $ Core.defaultLanguageContextData h o lf tvarId sendFunc + tvarDat <- atomically $ newTVar $ Core.defaultLanguageContextData h o lf tvarId sendFunc timestampCaptureFp - ioLoop dp tvarDat + ioLoop hin dp tvarDat return 1 + -- --------------------------------------------------------------------- -ioLoop :: (Show c) => Core.InitializeCallback c -> TVar (Core.LanguageContextData c) -> IO () -ioLoop dispatcherProc tvarDat = go BSL.empty +ioLoop :: (Show c) => Handle + -> Core.InitializeCallback c + -> TVar (Core.LanguageContextData c) + -> IO () +ioLoop hin dispatcherProc tvarDat = go BSL.empty where go :: BSL.ByteString -> IO () go buf = do - c <- BSL.hGet stdin 1 + c <- BSL.hGet hin 1 + if c == BSL.empty then do logm $ B.pack "\nhaskell-lsp:Got EOF, exiting 1 ...\n" @@ -79,15 +110,16 @@ case readContentLength (lbs2str newBuf) of Left _ -> go newBuf Right len -> do - cnt <- BSL.hGet stdin len + cnt <- BSL.hGet hin len + if cnt == BSL.empty then do logm $ B.pack "\nhaskell-lsp:Got EOF, exiting 1 ...\n" return () else do - logm $ (B.pack "---> ") <> cnt - Core.handleRequest dispatcherProc tvarDat newBuf cnt - ioLoop dispatcherProc tvarDat + logm $ B.pack "---> " <> cnt + Core.handleMessage dispatcherProc tvarDat newBuf cnt + ioLoop hin dispatcherProc tvarDat where readContentLength :: String -> Either ParseError Int readContentLength = parse parser "readContentLength" @@ -99,19 +131,27 @@ -- --------------------------------------------------------------------- --- | Simple server to make sure all stdout is serialised -sendServer :: TChan BSL.ByteString -> IO () -sendServer cstdout = do +-- | Simple server to make sure all output is serialised +sendServer :: TChan FromServerMessage -> Handle -> Maybe FilePath -> IO () +sendServer msgChan clientH captureFp = forever $ do - str <- atomically $ readTChan cstdout + msg <- atomically $ readTChan msgChan + + -- We need to make sure we only send over the content of the message, + -- and no other tags/wrapper stuff + let str = J.encode $ + J.genericToJSON (J.defaultOptions { J.sumEncoding = J.UntaggedValue }) msg + let out = BSL.concat [ str2lbs $ "Content-Length: " ++ show (BSL.length str) , str2lbs _TWO_CRLF , str ] - BSL.hPut stdout out - hFlush stdout + BSL.hPut clientH out + hFlush clientH logm $ B.pack "<--2--" <> str + + captureFromServer msg captureFp -- | -- diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -1,5 +1,4 @@ {-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE BinaryLiterals #-} {-# LANGUAGE OverloadedStrings #-} @@ -7,7 +6,7 @@ {-# LANGUAGE ScopedTypeVariables #-} module Language.Haskell.LSP.Core ( - handleRequest + handleMessage , LanguageContextData(..) , Handler , InitializeCallback @@ -15,9 +14,7 @@ , SendFunc , Handlers(..) , Options(..) - , OutMessage(..) , defaultLanguageContextData - , initializeRequestHandler , makeResponseMessage , makeResponseError , setupLogger @@ -41,6 +38,7 @@ import Data.Monoid import qualified Data.Text as T import Data.Text ( Text ) +import Language.Haskell.LSP.Capture import Language.Haskell.LSP.Constant import Language.Haskell.LSP.Messages import qualified Language.Haskell.LSP.TH.ClientCapabilities as C @@ -64,13 +62,12 @@ -- --------------------------------------------------------------------- -- | A function to send a message to the client -type SendFunc = forall a. (J.ToJSON a => a -> IO ()) +type SendFunc = FromServerMessage -> IO () -- | state used by the LSP dispatcher to manage the message loop data LanguageContextData a = LanguageContextData { resSeqDebugContextData :: !Int - , resRootPath :: !(Maybe FilePath) , resHandlers :: !Handlers , resOptions :: !Options , resSendResponse :: !SendFunc @@ -79,6 +76,7 @@ , resConfig :: !(Maybe a) , resLspId :: !(TVar Int) , resLspFuncs :: LspFuncs a -- NOTE: Cannot be strict, lazy initialization + , resCaptureFile :: !(Maybe FilePath) } -- --------------------------------------------------------------------- @@ -105,7 +103,7 @@ -- 'textDocument/publishDiagnostics' notification with the total (limited by the -- first parameter) whenever it is updated. type PublishDiagnosticsFunc = Int -- Max number of diagnostics to send - -> J.Uri -> Maybe J.TextDocumentVersion -> DiagnosticsBySource -> IO () + -> J.Uri -> J.TextDocumentVersion -> DiagnosticsBySource -> IO () -- | A function to remove all diagnostics from a particular source, and send the updates to the client. type FlushDiagnosticsBySourceFunc = Int -- Max number of diagnostics to send @@ -123,6 +121,7 @@ , publishDiagnosticsFunc :: !PublishDiagnosticsFunc , flushDiagnosticsBySourceFunc :: !FlushDiagnosticsBySourceFunc , getNextReqId :: !(IO J.LspId) + , rootPath :: !(Maybe FilePath) } -- | The function in the LSP process that is called once the 'initialize' @@ -164,7 +163,7 @@ -- Next 2 go from server -> client -- , registerCapabilityHandler :: !(Maybe (Handler J.RegisterCapabilityRequest)) -- , unregisterCapabilityHandler :: !(Maybe (Handler J.UnregisterCapabilityRequest)) - , willSaveWaitUntilTextDocHandler:: !(Maybe (Handler J.WillSaveWaitUntilTextDocumentResponse)) + , willSaveWaitUntilTextDocHandler:: !(Maybe (Handler J.WillSaveWaitUntilTextDocumentRequest)) -- Notifications from the client , didChangeConfigurationParamsHandler :: !(Maybe (Handler J.DidChangeConfigurationNotification)) @@ -179,22 +178,30 @@ , cancelNotificationHandler :: !(Maybe (Handler J.CancelNotification)) -- Responses to Request messages originated from the server - , responseHandler :: !(Maybe (Handler J.BareResponseMessage)) + -- TODO: Properly decode response types and replace them with actual handlers + , responseHandler :: !(Maybe (Handler J.BareResponseMessage)) + -- , registerCapabilityHandler :: !(Maybe (Handler J.RegisterCapabilityResponse)) + -- , unregisterCapabilityHandler :: !(Maybe (Handler J.RegisterCapabilityResponse)) + -- , showMessageHandler :: !(Maybe (Handler J.ShowMessageResponse)) + + -- Initialization request on startup + , initializeRequestHandler :: !(Maybe (Handler J.InitializeRequest)) + -- Will default to terminating `exitMessage` if Nothing + , exitNotificationHandler :: !(Maybe (Handler J.ExitNotification)) } instance Default Handlers where def = Handlers Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing + Nothing Nothing Nothing Nothing Nothing -- --------------------------------------------------------------------- nop :: a -> b -> IO a nop = const . return -helper :: J.FromJSON a - => (TVar (LanguageContextData c) -> a -> IO ()) - -> (TVar (LanguageContextData c) -> J.Value -> IO ()) + +helper :: J.FromJSON a => (TVar (LanguageContextData c) -> a -> IO ()) -> (TVar (LanguageContextData c) -> J.Value -> IO ()) helper requestHandler tvarDat json = case J.fromJSON json of J.Success req -> requestHandler tvarDat req @@ -212,47 +219,60 @@ handlerMap :: (Show c) => InitializeCallback c -> Handlers -> J.ClientMethod -> (TVar (LanguageContextData c) -> J.Value -> IO ()) -- General -handlerMap i _ J.Initialize = helper (initializeRequestHandler i) -handlerMap _ h J.Initialized = hh nop $ initializedHandler h +handlerMap i h J.Initialize = helper (initializeRequestHandler' i (initializeRequestHandler h)) +handlerMap _ h J.Initialized = hh nop NotInitialized $ initializedHandler h handlerMap _ _ J.Shutdown = helper shutdownRequestHandler -handlerMap _ _ J.Exit = \_ _ -> do - logm $ B.pack "haskell-lsp:Got exit, exiting" - exitSuccess -handlerMap _ h J.CancelRequest = hh nop $ cancelNotificationHandler h +handlerMap _ h J.Exit = + case exitNotificationHandler h of + Just _ -> hh nop NotExit $ exitNotificationHandler h + Nothing -> \ctxVar v -> do + ctx <- readTVarIO ctxVar + -- Capture exit notification + case J.fromJSON v :: J.Result J.ExitNotification of + J.Success n -> captureFromClient (NotExit n) (resCaptureFile ctx) + J.Error _ -> return () + logm $ B.pack "haskell-lsp:Got exit, exiting" + exitSuccess +handlerMap _ h J.CancelRequest = hh nop NotCancelRequestFromClient $ cancelNotificationHandler h -- Workspace -handlerMap i h J.WorkspaceDidChangeConfiguration = hc i $ didChangeConfigurationParamsHandler h -handlerMap _ h J.WorkspaceDidChangeWatchedFiles = hh nop $ didChangeWatchedFilesNotificationHandler h -handlerMap _ h J.WorkspaceSymbol = hh nop $ workspaceSymbolHandler h -handlerMap _ h J.WorkspaceExecuteCommand = hh nop $ executeCommandHandler h +handlerMap i h J.WorkspaceDidChangeConfiguration = hc i $ didChangeConfigurationParamsHandler h +handlerMap _ h J.WorkspaceDidChangeWatchedFiles = hh nop NotDidChangeWatchedFiles $ didChangeWatchedFilesNotificationHandler h +handlerMap _ h J.WorkspaceSymbol = hh nop ReqWorkspaceSymbols $ workspaceSymbolHandler h +handlerMap _ h J.WorkspaceExecuteCommand = hh nop ReqExecuteCommand $ executeCommandHandler h -- Document -handlerMap _ h J.TextDocumentDidOpen = hh openVFS $ didOpenTextDocumentNotificationHandler h -handlerMap _ h J.TextDocumentDidChange = hh changeVFS $ didChangeTextDocumentNotificationHandler h -handlerMap _ h J.TextDocumentWillSave = hh nop $ willSaveTextDocumentNotificationHandler h -handlerMap _ h J.TextDocumentWillSaveWaitUntil = hh nop $ willSaveWaitUntilTextDocHandler h -handlerMap _ h J.TextDocumentDidSave = hh nop $ didSaveTextDocumentNotificationHandler h -handlerMap _ h J.TextDocumentDidClose = hh closeVFS $ didCloseTextDocumentNotificationHandler h -handlerMap _ h J.TextDocumentCompletion = hh nop $ completionHandler h -handlerMap _ h J.CompletionItemResolve = hh nop $ completionResolveHandler h -handlerMap _ h J.TextDocumentHover = hh nop $ hoverHandler h -handlerMap _ h J.TextDocumentSignatureHelp = hh nop $ signatureHelpHandler h -handlerMap _ h J.TextDocumentReferences = hh nop $ referencesHandler h -handlerMap _ h J.TextDocumentDocumentHighlight = hh nop $ documentHighlightHandler h -handlerMap _ h J.TextDocumentDocumentSymbol = hh nop $ documentSymbolHandler h -handlerMap _ h J.TextDocumentFormatting = hh nop $ documentFormattingHandler h -handlerMap _ h J.TextDocumentRangeFormatting = hh nop $ documentRangeFormattingHandler h -handlerMap _ h J.TextDocumentOnTypeFormatting = hh nop $ documentTypeFormattingHandler h -handlerMap _ h J.TextDocumentDefinition = hh nop $ definitionHandler h -handlerMap _ h J.TextDocumentCodeAction = hh nop $ codeActionHandler h -handlerMap _ h J.TextDocumentCodeLens = hh nop $ codeLensHandler h -handlerMap _ h J.CodeLensResolve = hh nop $ codeLensResolveHandler h -handlerMap _ h J.TextDocumentDocumentLink = hh nop $ documentLinkHandler h -handlerMap _ h J.DocumentLinkResolve = hh nop $ documentLinkResolveHandler h -handlerMap _ h J.TextDocumentRename = hh nop $ renameHandler h +handlerMap _ h J.TextDocumentDidOpen = hh openVFS NotDidOpenTextDocument $ didOpenTextDocumentNotificationHandler h +handlerMap _ h J.TextDocumentDidChange = hh changeFromClientVFS NotDidChangeTextDocument $ didChangeTextDocumentNotificationHandler h +handlerMap _ h J.TextDocumentWillSave = hh nop NotWillSaveTextDocument $ willSaveTextDocumentNotificationHandler h +handlerMap _ h J.TextDocumentWillSaveWaitUntil = hh nop ReqWillSaveWaitUntil $ willSaveWaitUntilTextDocHandler h +handlerMap _ h J.TextDocumentDidSave = hh nop NotDidSaveTextDocument $ didSaveTextDocumentNotificationHandler h +handlerMap _ h J.TextDocumentDidClose = hh closeVFS NotDidCloseTextDocument $ didCloseTextDocumentNotificationHandler h +handlerMap _ h J.TextDocumentCompletion = hh nop ReqCompletion $ completionHandler h +handlerMap _ h J.CompletionItemResolve = hh nop ReqCompletionItemResolve $ completionResolveHandler h +handlerMap _ h J.TextDocumentHover = hh nop ReqHover $ hoverHandler h +handlerMap _ h J.TextDocumentSignatureHelp = hh nop ReqSignatureHelp $ signatureHelpHandler h +handlerMap _ h J.TextDocumentReferences = hh nop ReqFindReferences $ referencesHandler h +handlerMap _ h J.TextDocumentDocumentHighlight = hh nop ReqDocumentHighlights $ documentHighlightHandler h +handlerMap _ h J.TextDocumentDocumentSymbol = hh nop ReqDocumentSymbols $ documentSymbolHandler h +handlerMap _ h J.TextDocumentFormatting = hh nop ReqDocumentFormatting $ documentFormattingHandler h +handlerMap _ h J.TextDocumentRangeFormatting = hh nop ReqDocumentRangeFormatting $ documentRangeFormattingHandler h +handlerMap _ h J.TextDocumentOnTypeFormatting = hh nop ReqDocumentOnTypeFormatting $ documentTypeFormattingHandler h +handlerMap _ h J.TextDocumentDefinition = hh nop ReqDefinition $ definitionHandler h +handlerMap _ h J.TextDocumentCodeAction = hh nop ReqCodeAction $ codeActionHandler h +handlerMap _ h J.TextDocumentCodeLens = hh nop ReqCodeLens $ codeLensHandler h +handlerMap _ h J.CodeLensResolve = hh nop ReqCodeLensResolve $ codeLensResolveHandler h +handlerMap _ h J.TextDocumentDocumentLink = hh nop ReqDocumentLink $ documentLinkHandler h +handlerMap _ h J.DocumentLinkResolve = hh nop ReqDocumentLinkResolve $ documentLinkResolveHandler h +handlerMap _ h J.TextDocumentRename = hh nop ReqRename $ renameHandler h handlerMap _ _ (J.Misc x) = helper f - where f :: TVar (LanguageContextData c) -> J.TraceNotification -> IO () - f tvarDat _ = do + where f :: TVar (LanguageContextData c) -> J.Value -> IO () + f tvarDat n = do let msg = "haskell-lsp:Got " ++ T.unpack x ++ " ignoring" logm (B.pack msg) + + ctx <- readTVarIO tvarDat + + captureFromClient (UnknownFromClientMessage n) (resCaptureFile ctx) + sendErrorLog tvarDat (T.pack msg) -- --------------------------------------------------------------------- @@ -260,13 +280,16 @@ -- | Adapter from the normal handlers exposed to the library users and the -- internal message loop hh :: forall b c. (J.FromJSON b) - => (VFS -> b -> IO VFS) -> Maybe (Handler b) -> TVar (LanguageContextData c) -> J.Value -> IO () -hh getVfs mh tvarDat json = do + => (VFS -> b -> IO VFS) -> (b -> FromClientMessage) -> Maybe (Handler b) -> TVar (LanguageContextData c) -> J.Value -> IO () +hh getVfs wrapper mh tvarDat json = do case J.fromJSON json of J.Success req -> do ctx <- readTVarIO tvarDat vfs' <- getVfs (resVFS ctx) req atomically $ modifyTVar' tvarDat (\c -> c {resVFS = vfs'}) + + captureFromClient (wrapper req) (resCaptureFile ctx) + case mh of Just h -> h req Nothing -> do @@ -283,14 +306,17 @@ case J.fromJSON json of J.Success req -> do ctx <- readTVarIO tvarDat + + captureFromClient (NotDidChangeConfiguration req) (resCaptureFile ctx) + case c req of Left err -> do - let msg = T.pack $ unwords $ ["haskell-lsp:didChangeConfiguration error.", show req, show err] + let msg = T.pack $ unwords ["haskell-lsp:didChangeConfiguration error.", show req, show err] sendErrorLog tvarDat msg Right newConfig -> do -- logs $ "haskell-lsp:hc DidChangeConfigurationNotification got newConfig:" ++ show newConfig let ctx' = ctx { resConfig = Just newConfig } - atomically $ modifyTVar' tvarDat (\_ -> ctx') + atomically $ modifyTVar' tvarDat (const ctx') case mh of Just h -> h req Nothing -> return () @@ -302,72 +328,12 @@ -- --------------------------------------------------------------------- getVirtualFile :: TVar (LanguageContextData c) -> J.Uri -> IO (Maybe VirtualFile) -getVirtualFile tvarDat uri = do - ctx <- readTVarIO tvarDat - return $ Map.lookup uri (resVFS ctx) +getVirtualFile tvarDat uri = Map.lookup uri . resVFS <$> readTVarIO tvarDat -- --------------------------------------------------------------------- getConfig :: TVar (LanguageContextData c) -> IO (Maybe c) -getConfig tvar = do - ctx <- readTVarIO tvar - return (resConfig ctx) - - --- --------------------------------------------------------------------- - --- | Wrap all the protocol messages into a single type, for use in the language --- handler in storing the original message -data OutMessage = ReqHover J.HoverRequest - | ReqCompletion J.CompletionRequest - | ReqCompletionItemResolve J.CompletionItemResolveRequest - | ReqSignatureHelp J.SignatureHelpRequest - | ReqDefinition J.DefinitionRequest - | ReqFindReferences J.ReferencesRequest - | ReqDocumentHighlights J.DocumentHighlightRequest - | ReqDocumentSymbols J.DocumentSymbolRequest - | ReqWorkspaceSymbols J.WorkspaceSymbolRequest - | ReqCodeAction J.CodeActionRequest - | ReqCodeLens J.CodeLensRequest - | ReqCodeLensResolve J.CodeLensResolveRequest - | ReqDocumentFormatting J.DocumentFormattingRequest - | ReqDocumentRangeFormatting J.DocumentRangeFormattingRequest - | ReqDocumentOnTypeFormatting J.DocumentOnTypeFormattingRequest - | ReqRename J.RenameRequest - | ReqExecuteCommand J.ExecuteCommandRequest - -- responses - | RspHover J.HoverResponse - | RspCompletion J.CompletionResponse - | RspCompletionItemResolve J.CompletionItemResolveResponse - | RspSignatureHelp J.SignatureHelpResponse - | RspDefinition J.DefinitionResponse - | RspFindReferences J.ReferencesResponse - | RspDocumentHighlights J.DocumentHighlightsResponse - | RspDocumentSymbols J.DocumentSymbolsResponse - | RspWorkspaceSymbols J.WorkspaceSymbolsResponse - | RspCodeAction J.CodeActionResponse - | RspCodeLens J.CodeLensResponse - | RspCodeLensResolve J.CodeLensResolveResponse - | RspDocumentFormatting J.DocumentFormattingResponse - | RspDocumentRangeFormatting J.DocumentRangeFormattingResponse - | RspDocumentOnTypeFormatting J.DocumentOnTypeFormattingResponse - | RspRename J.RenameResponse - | RspExecuteCommand J.ExecuteCommandResponse - - -- notifications - | NotInitialized J.InitializedNotification - | NotDidChangeConfigurationParams J.DidChangeConfigurationNotification - | NotDidOpenTextDocument J.DidOpenTextDocumentNotification - | NotDidChangeTextDocument J.DidChangeTextDocumentNotification - | NotDidCloseTextDocument J.DidCloseTextDocumentNotification - | NotWillSaveTextDocument J.WillSaveTextDocumentNotification - | NotDidSaveTextDocument J.DidSaveTextDocumentNotification - | NotDidChangeWatchedFiles J.DidChangeWatchedFilesNotification - - | NotCancelRequest J.CancelNotification - - | RspFromClient J.BareResponseMessage - deriving (Eq,Read,Show) +getConfig tvar = resConfig <$> readTVarIO tvar -- --------------------------------------------------------------------- -- | @@ -401,15 +367,15 @@ -- | -- -- -defaultLanguageContextData :: Handlers -> Options -> LspFuncs c -> TVar Int -> SendFunc -> LanguageContextData c -defaultLanguageContextData h o lf tv sf = - LanguageContextData _INITIAL_RESPONSE_SEQUENCE Nothing h o sf mempty mempty Nothing tv lf +defaultLanguageContextData :: Handlers -> Options -> LspFuncs c -> TVar Int -> SendFunc -> Maybe FilePath -> LanguageContextData c +defaultLanguageContextData h o lf tv sf cf = + LanguageContextData _INITIAL_RESPONSE_SEQUENCE h o sf mempty mempty Nothing tv lf cf -- --------------------------------------------------------------------- -handleRequest :: (Show c) => InitializeCallback c +handleMessage :: (Show c) => InitializeCallback c -> TVar (LanguageContextData c) -> BSL.ByteString -> BSL.ByteString -> IO () -handleRequest dispatcherProc tvarDat contLenStr jsonStr = do +handleMessage dispatcherProc tvarDat contLenStr jsonStr = do {- Message Types we must handle are the following @@ -427,6 +393,7 @@ sendErrorLog tvarDat msg Right o -> do + case HM.lookup "method" o of Just cmd@(J.String s) -> case J.fromJSON cmd of J.Success m -> handle (J.Object o) m @@ -465,15 +432,15 @@ -- --------------------------------------------------------------------- -- | -- -sendEvent :: J.ToJSON a => TVar (LanguageContextData c) -> a -> IO () -sendEvent tvarCtx str = sendResponse tvarCtx str +sendEvent :: TVar (LanguageContextData c) -> FromServerMessage -> IO () +sendEvent tvarCtx msg = sendResponse tvarCtx msg -- | -- -sendResponse :: J.ToJSON a => TVar (LanguageContextData c) -> a -> IO () -sendResponse tvarCtx str = do +sendResponse :: TVar (LanguageContextData c) -> FromServerMessage -> IO () +sendResponse tvarCtx msg = do ctx <- readTVarIO tvarCtx - resSendResponse ctx str + resSendResponse ctx msg -- --------------------------------------------------------------------- @@ -485,22 +452,22 @@ sendErrorResponseS :: SendFunc -> J.LspIdRsp -> J.ErrorCode -> Text -> IO () sendErrorResponseS sf origId err msg = do - sf $ (J.ResponseMessage "2.0" origId Nothing - (Just $ J.ResponseError err msg Nothing) :: J.ErrorResponse) + sf $ RspError (J.ResponseMessage "2.0" origId Nothing + (Just $ J.ResponseError err msg Nothing) :: J.ErrorResponse) sendErrorLog :: TVar (LanguageContextData c) -> Text -> IO () sendErrorLog tv msg = sendErrorLogS (sendEvent tv) msg sendErrorLogS :: SendFunc -> Text -> IO () sendErrorLogS sf msg = - sf $ fmServerLogMessageNotification J.MtError msg + sf $ NotLogMessage $ fmServerLogMessageNotification J.MtError msg -- sendErrorShow :: String -> IO () -- sendErrorShow msg = sendErrorShowS sendEvent msg sendErrorShowS :: SendFunc -> Text -> IO () sendErrorShowS sf msg = - sf $ fmServerShowMessageNotification J.MtError msg + sf $ NotShowMessage $ fmServerShowMessageNotification J.MtError msg -- --------------------------------------------------------------------- @@ -519,18 +486,26 @@ -- | -- -initializeRequestHandler :: (Show c) => InitializeCallback c +initializeRequestHandler' :: (Show c) => InitializeCallback c + -> Maybe (Handler J.InitializeRequest) -> TVar (LanguageContextData c) - -> J.InitializeRequest -> IO () -initializeRequestHandler (_configHandler,dispatcherProc) tvarCtx req@(J.RequestMessage _ origId _ params) = + -> J.InitializeRequest + -> IO () +initializeRequestHandler' (_configHandler,dispatcherProc) mHandler tvarCtx req@(J.RequestMessage _ origId _ params) = flip E.catches (defaultErrorHandlers tvarCtx (J.responseId origId) req) $ do + case mHandler of + Just handler -> handler req + Nothing -> return () + ctx0 <- readTVarIO tvarCtx + -- capture initialize request + captureFromClient (ReqInitialize req) (resCaptureFile ctx0) + let rootDir = getFirst $ foldMap First [ params ^. J.rootUri >>= J.uriToFilePath , params ^. J.rootPath <&> T.unpack ] - atomically $ modifyTVar' tvarCtx (\c -> c { resRootPath = rootDir }) case rootDir of Nothing -> return () Just dir -> do @@ -553,6 +528,7 @@ (publishDiagnostics tvarCtx) (flushDiagnosticsBySource tvarCtx) (getLspId $ resLspId ctx0) + rootDir let ctx = ctx0 { resLspFuncs = lspFuncs } atomically $ writeTVar tvarCtx ctx @@ -560,7 +536,7 @@ case initializationResult of Just errResp -> do - sendResponse tvarCtx $ makeResponseError (J.responseId origId) errResp + sendResponse tvarCtx $ RspError $ makeResponseError (J.responseId origId) errResp Nothing -> do @@ -571,9 +547,13 @@ supported (Just _) = Just True supported Nothing = Nothing + sync = case textDocumentSync o of + Just x -> Just (J.TDSOptions x) + Nothing -> Nothing + capa = J.InitializeResponseCapabilitiesInner - { J._textDocumentSync = textDocumentSync o + { J._textDocumentSync = sync , J._hoverProvider = supported (hoverHandler h) , J._completionProvider = completionProvider o , J._signatureHelpProvider = signatureHelpProvider o @@ -592,13 +572,13 @@ , J._documentLinkProvider = documentLinkProvider o , J._executeCommandProvider = executeCommandProvider o -- TODO: Add something for experimental - , J._experimental = (Nothing :: Maybe J.Value) + , J._experimental = Nothing :: Maybe J.Value } -- TODO: wrap this up into a fn to create a response message res = J.ResponseMessage "2.0" (J.responseId origId) (Just $ J.InitializeResponseCapabilities capa) Nothing - sendResponse tvarCtx res + sendResponse tvarCtx $ RspInitialize res -- | -- @@ -607,23 +587,23 @@ flip E.catches (defaultErrorHandlers tvarCtx (J.responseId origId) req) $ do let res = makeResponseMessage req "ok" - sendResponse tvarCtx res + sendResponse tvarCtx $ RspShutdown res -- --------------------------------------------------------------------- -- | Take the new diagnostics, update the stored diagnostics for the given file -- and version, and publish the total to the client. publishDiagnostics :: TVar (LanguageContextData c) -> PublishDiagnosticsFunc -publishDiagnostics tvarDat maxDiagnosticCount uri mversion diags = do +publishDiagnostics tvarDat maxDiagnosticCount uri version diags = do ctx <- readTVarIO tvarDat - let ds = updateDiagnostics (resDiagnostics ctx) uri mversion diags + let ds = updateDiagnostics (resDiagnostics ctx) uri version diags atomically $ writeTVar tvarDat $ ctx{resDiagnostics = ds} let mdp = getDiagnosticParamsFor maxDiagnosticCount ds uri case mdp of Nothing -> return () Just params -> do - resSendResponse ctx - $ J.NotificationMessage "2.0" J.TextDocumentPublishDiagnostics (Just params) + resSendResponse ctx $ NotPublishDiagnostics + $ J.NotificationMessage "2.0" J.TextDocumentPublishDiagnostics params -- --------------------------------------------------------------------- @@ -642,8 +622,8 @@ case mdp of Nothing -> return () Just params -> do - resSendResponse ctx - $ J.NotificationMessage "2.0" J.TextDocumentPublishDiagnostics (Just params) + resSendResponse ctx $ NotPublishDiagnostics + $ J.NotificationMessage "2.0" J.TextDocumentPublishDiagnostics params -- |===================================================================== -- diff --git a/src/Language/Haskell/LSP/Diagnostics.hs b/src/Language/Haskell/LSP/Diagnostics.hs --- a/src/Language/Haskell/LSP/Diagnostics.hs +++ b/src/Language/Haskell/LSP/Diagnostics.hs @@ -42,7 +42,7 @@ type DiagnosticStore = Map.Map J.Uri StoreItem data StoreItem - = StoreItem (Maybe J.TextDocumentVersion) DiagnosticsBySource + = StoreItem J.TextDocumentVersion DiagnosticsBySource deriving (Show,Eq) type DiagnosticsBySource = Map.Map (Maybe J.DiagnosticSource) (SL.SortedList J.Diagnostic) @@ -63,7 +63,7 @@ -- --------------------------------------------------------------------- updateDiagnostics :: DiagnosticStore - -> J.Uri -> Maybe J.TextDocumentVersion -> DiagnosticsBySource + -> J.Uri -> J.TextDocumentVersion -> DiagnosticsBySource -> DiagnosticStore updateDiagnostics store uri mv newDiagsBySource = r where diff --git a/src/Language/Haskell/LSP/Messages.hs b/src/Language/Haskell/LSP/Messages.hs --- a/src/Language/Haskell/LSP/Messages.hs +++ b/src/Language/Haskell/LSP/Messages.hs @@ -1,6 +1,98 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} + module Language.Haskell.LSP.Messages - ( - module Language.Haskell.LSP.TH.Messages - ) where + ( module Language.Haskell.LSP.TH.MessageFuncs + , FromClientMessage(..) + , FromServerMessage(..) + ) +where -import Language.Haskell.LSP.TH.Messages +import Language.Haskell.LSP.TH.MessageFuncs +import Language.Haskell.LSP.TH.DataTypesJSON +import GHC.Generics +import Data.Aeson + +-- | A wrapper around a message that originates from the client +-- and is sent to the server. +data FromClientMessage = ReqInitialize InitializeRequest + | ReqShutdown ShutdownRequest + | ReqHover HoverRequest + | ReqCompletion CompletionRequest + | ReqCompletionItemResolve CompletionItemResolveRequest + | ReqSignatureHelp SignatureHelpRequest + | ReqDefinition DefinitionRequest + | ReqFindReferences ReferencesRequest + | ReqDocumentHighlights DocumentHighlightRequest + | ReqDocumentSymbols DocumentSymbolRequest + | ReqWorkspaceSymbols WorkspaceSymbolRequest + | ReqCodeAction CodeActionRequest + | ReqCodeLens CodeLensRequest + | ReqCodeLensResolve CodeLensResolveRequest + | ReqDocumentFormatting DocumentFormattingRequest + | ReqDocumentRangeFormatting DocumentRangeFormattingRequest + | ReqDocumentOnTypeFormatting DocumentOnTypeFormattingRequest + | ReqRename RenameRequest + | ReqExecuteCommand ExecuteCommandRequest + | ReqDocumentLink DocumentLinkRequest + | ReqDocumentLinkResolve DocumentLinkResolveRequest + | ReqWillSaveWaitUntil WillSaveWaitUntilTextDocumentRequest + -- Responses + | RspApplyWorkspaceEdit ApplyWorkspaceEditResponse + -- TODO: Remove this and properly decode the type of responses + -- based on the id + | RspFromClient BareResponseMessage + -- Notifications + | NotInitialized InitializedNotification + | NotExit ExitNotification + -- A cancel request notification is duplex! + | NotCancelRequestFromClient CancelNotification + | NotDidChangeConfiguration DidChangeConfigurationNotification + | NotDidOpenTextDocument DidOpenTextDocumentNotification + | NotDidChangeTextDocument DidChangeTextDocumentNotification + | NotDidCloseTextDocument DidCloseTextDocumentNotification + | NotWillSaveTextDocument WillSaveTextDocumentNotification + | NotDidSaveTextDocument DidSaveTextDocumentNotification + | NotDidChangeWatchedFiles DidChangeWatchedFilesNotification + -- Unknown (The client sends something we don't understand) + | UnknownFromClientMessage Value + deriving (Eq,Read,Show,Generic,ToJSON,FromJSON) + +-- | A wrapper around a message that originates from the server +-- and is sent to the client. +data FromServerMessage = ReqRegisterCapability RegisterCapabilityRequest + | ReqUnregisterCapability UnregisterCapabilityRequest + | ReqApplyWorkspaceEdit ApplyWorkspaceEditRequest + | ReqShowMessage ShowMessageRequest + -- Responses + | RspInitialize InitializeResponse + | RspShutdown ShutdownResponse + | RspHover HoverResponse + | RspCompletion CompletionResponse + | RspCompletionItemResolve CompletionItemResolveResponse + | RspSignatureHelp SignatureHelpResponse + | RspDefinition DefinitionResponse + | RspFindReferences ReferencesResponse + | RspDocumentHighlights DocumentHighlightsResponse + | RspDocumentSymbols DocumentSymbolsResponse + | RspWorkspaceSymbols WorkspaceSymbolsResponse + | RspCodeAction CodeActionResponse + | RspCodeLens CodeLensResponse + | RspCodeLensResolve CodeLensResolveResponse + | RspDocumentFormatting DocumentFormattingResponse + | RspDocumentRangeFormatting DocumentRangeFormattingResponse + | RspDocumentOnTypeFormatting DocumentOnTypeFormattingResponse + | RspRename RenameResponse + | RspExecuteCommand ExecuteCommandResponse + | RspError ErrorResponse + | RspDocumentLink DocumentLinkResponse + | RspDocumentLinkResolve DocumentLinkResolveResponse + | RspWillSaveWaitUntil WillSaveWaitUntilTextDocumentResponse + -- Notifications + | NotPublishDiagnostics PublishDiagnosticsNotification + | NotLogMessage LogMessageNotification + | NotShowMessage ShowMessageNotification + | NotTelemetry TelemetryNotification + -- A cancel request notification is duplex! + | NotCancelRequestFromServer CancelNotificationServer + deriving (Eq,Read,Show,Generic,ToJSON,FromJSON) diff --git a/src/Language/Haskell/LSP/Types/Capabilities.hs b/src/Language/Haskell/LSP/Types/Capabilities.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/LSP/Types/Capabilities.hs @@ -0,0 +1,6 @@ +module Language.Haskell.LSP.Types.Capabilities + ( + module Language.Haskell.LSP.TH.ClientCapabilities + ) where + +import Language.Haskell.LSP.TH.ClientCapabilities diff --git a/src/Language/Haskell/LSP/VFS.hs b/src/Language/Haskell/LSP/VFS.hs --- a/src/Language/Haskell/LSP/VFS.hs +++ b/src/Language/Haskell/LSP/VFS.hs @@ -14,23 +14,29 @@ VFS , VirtualFile(..) , openVFS - , changeVFS + , changeFromClientVFS + , changeFromServerVFS , closeVFS -- * for tests + , applyChanges , applyChange - , sortChanges , deleteChars , addChars , changeChars , yiSplitAt ) where +import Control.Lens +import Control.Monad import Data.Text ( Text ) import Data.List +import Data.Ord #if __GLASGOW_HASKELL__ < 804 import Data.Monoid #endif +import qualified Data.HashMap.Strict as HashMap import qualified Data.Map as Map +import Data.Maybe import qualified Language.Haskell.LSP.TH.DataTypesJSON as J import Language.Haskell.LSP.Utility import qualified Yi.Rope as Yi @@ -58,21 +64,54 @@ -- --------------------------------------------------------------------- -changeVFS :: VFS -> J.DidChangeTextDocumentNotification -> IO VFS -changeVFS vfs (J.NotificationMessage _ _ params) = do +changeFromClientVFS :: VFS -> J.DidChangeTextDocumentNotification -> IO VFS +changeFromClientVFS vfs (J.NotificationMessage _ _ params) = do let J.DidChangeTextDocumentParams vid (J.List changes) = params J.VersionedTextDocumentIdentifier uri version = vid case Map.lookup uri vfs of Just (VirtualFile _ str) -> do let str' = applyChanges str changes - return $ Map.insert uri (VirtualFile version str') vfs + -- the client shouldn't be sending over a null version, only the server. + return $ Map.insert uri (VirtualFile (fromMaybe 0 version) str') vfs Nothing -> do logs $ "haskell-lsp:changeVfs:can't find uri:" ++ show uri return vfs -- --------------------------------------------------------------------- +changeFromServerVFS :: VFS -> J.ApplyWorkspaceEditRequest -> IO VFS +changeFromServerVFS initVfs (J.RequestMessage _ _ _ params) = do + let J.ApplyWorkspaceEditParams edit = params + J.WorkspaceEdit mChanges mDocChanges = edit + case mDocChanges of + Just (J.List textDocEdits) -> applyEdits textDocEdits + Nothing -> case mChanges of + Just cs -> applyEdits $ HashMap.foldlWithKey' changeToTextDocumentEdit [] cs + Nothing -> do + logs "haskell-lsp:changeVfs:no changes" + return initVfs + + where + + changeToTextDocumentEdit acc uri edits = + acc ++ [J.TextDocumentEdit (J.VersionedTextDocumentIdentifier uri (Just 0)) edits] + + applyEdits = foldM f initVfs . sortOn (^. J.textDocument . J.version) + + f vfs (J.TextDocumentEdit vid (J.List edits)) = do + -- all edits are supposed to be applied at once + -- so apply from bottom up so they don't affect others + let sortedEdits = sortOn (Down . (^. J.range)) edits + changeEvents = map editToChangeEvent sortedEdits + ps = J.DidChangeTextDocumentParams vid (J.List changeEvents) + notif = J.NotificationMessage "" J.TextDocumentDidChange ps + changeFromClientVFS vfs notif + + editToChangeEvent (J.TextEdit range text) = J.TextDocumentContentChangeEvent (Just range) Nothing text + +-- --------------------------------------------------------------------- + closeVFS :: VFS -> J.DidCloseTextDocumentNotification -> IO VFS closeVFS vfs (J.NotificationMessage _ _ params) = do let J.DidCloseTextDocumentParams (J.TextDocumentIdentifier uri) = params @@ -89,12 +128,11 @@ } deriving (Read,Show,Eq) -} --- | Apply the list of changes, in descending order of range. Assuming no overlaps. +-- | Apply the list of changes. +-- Changes should be applied in the order that they are +-- received from the client. applyChanges :: Yi.YiString -> [J.TextDocumentContentChangeEvent] -> Yi.YiString -applyChanges str changes' = r - where - changes = sortChanges changes' - r = foldl' applyChange str changes +applyChanges = foldl' applyChange -- --------------------------------------------------------------------- @@ -175,17 +213,5 @@ (b,a) = Yi.splitAtLine l str before = Yi.concat [b,Yi.take c a] after = Yi.drop c a - - --- --------------------------------------------------------------------- - -sortChanges :: [J.TextDocumentContentChangeEvent] -> [J.TextDocumentContentChangeEvent] -sortChanges changes = changes' - where - myComp (J.TextDocumentContentChangeEvent (Just r1) _ _) - (J.TextDocumentContentChangeEvent (Just r2) _ _) - = compare r2 r1 -- want descending order - myComp _ _ = EQ - changes' = sortBy myComp changes -- --------------------------------------------------------------------- diff --git a/test/VspSpec.hs b/test/VspSpec.hs --- a/test/VspSpec.hs +++ b/test/VspSpec.hs @@ -32,17 +32,23 @@ vspSpec :: Spec vspSpec = do - describe "sorts changes" $ do - it "sorts changes that all have ranges" $ do - let - unsorted = - [ (J.TextDocumentContentChangeEvent (mkRange 1 0 2 0) Nothing "") - , (J.TextDocumentContentChangeEvent (mkRange 2 0 3 0) Nothing "") - ] - (sortChanges unsorted) `shouldBe` - [ (J.TextDocumentContentChangeEvent (mkRange 2 0 3 0) Nothing "") - , (J.TextDocumentContentChangeEvent (mkRange 1 0 2 0) Nothing "") - ] + describe "applys changes in order" $ do + it "handles vscode style undos" $ do + let orig = "abc" + changes = + [ J.TextDocumentContentChangeEvent (mkRange 0 2 0 3) Nothing "" + , J.TextDocumentContentChangeEvent (mkRange 0 1 0 2) Nothing "" + , J.TextDocumentContentChangeEvent (mkRange 0 0 0 1) Nothing "" + ] + applyChanges orig changes `shouldBe` "" + it "handles vscode style redos" $ do + let orig = "" + changes = + [ J.TextDocumentContentChangeEvent (mkRange 0 1 0 1) Nothing "a" + , J.TextDocumentContentChangeEvent (mkRange 0 2 0 2) Nothing "b" + , J.TextDocumentContentChangeEvent (mkRange 0 3 0 3) Nothing "c" + ] + applyChanges orig changes `shouldBe` "abc" -- ---------------------------------