{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE BinaryLiterals #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module Language.Haskell.LSP.Core ( handleMessage , LanguageContextData(..) , Handler , InitializeCallbacks(..) , LspFuncs(..) , Progress(..) , ProgressCancellable(..) , ProgressCancelledException , SendFunc , Handlers(..) , Options(..) , defaultLanguageContextData , makeResponseMessage , makeResponseError , setupLogger , sendErrorResponseS , sendErrorLogS , sendErrorShowS , reverseSortEdit ) where import Control.Concurrent.STM import Control.Concurrent.Async import qualified Control.Exception as E import Control.Monad import Control.Monad.IO.Class import Control.Lens ( (<&>), (^.) ) import qualified Data.Aeson as J import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as B import Data.Default import qualified Data.HashMap.Strict as HM import qualified Data.List as L import qualified Data.Map as Map import Data.Maybe 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.Types.Capabilities as C import qualified Language.Haskell.LSP.Types as J import qualified Language.Haskell.LSP.Types.Lens as J import Language.Haskell.LSP.Utility import Language.Haskell.LSP.VFS import Language.Haskell.LSP.Diagnostics import System.Directory import System.Exit import System.IO import qualified System.Log.Formatter as L import qualified System.Log.Handler as LH import qualified System.Log.Handler.Simple as LHS import System.Log.Logger import qualified System.Log.Logger as L -- --------------------------------------------------------------------- {-# ANN module ("HLint: ignore Eta reduce" :: String) #-} {-# ANN module ("HLint: ignore Redundant do" :: String) #-} {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} -- --------------------------------------------------------------------- -- | A function to send a message to the client type SendFunc = FromServerMessage -> IO () -- | state used by the LSP dispatcher to manage the message loop data LanguageContextData config = LanguageContextData { resSeqDebugContextData :: !Int , resHandlers :: !Handlers , resOptions :: !Options , resSendResponse :: !SendFunc , resVFS :: !VFS , reverseMap :: !(Map.Map FilePath FilePath) , resDiagnostics :: !DiagnosticStore , resConfig :: !(Maybe config) , resLspId :: !(TVar Int) , resLspFuncs :: LspFuncs config -- NOTE: Cannot be strict, lazy initialization , resCaptureFile :: !(Maybe FilePath) , resWorkspaceFolders :: ![J.WorkspaceFolder] , resProgressData :: !ProgressData } data ProgressData = ProgressData { progressNextId :: !Int , progressCancel :: !(Map.Map J.ProgressToken (IO ())) } -- --------------------------------------------------------------------- -- | Language Server Protocol options supported by the given language server. -- These are automatically turned into capabilities reported to the client -- during initialization. data Options = Options { textDocumentSync :: Maybe J.TextDocumentSyncOptions , completionProvider :: Maybe J.CompletionOptions , signatureHelpProvider :: Maybe J.SignatureHelpOptions , typeDefinitionProvider :: Maybe J.GotoOptions , implementationProvider :: Maybe J.GotoOptions , codeActionProvider :: Maybe J.CodeActionOptions , codeLensProvider :: Maybe J.CodeLensOptions , documentOnTypeFormattingProvider :: Maybe J.DocumentOnTypeFormattingOptions , renameProvider :: Maybe J.RenameOptions , documentLinkProvider :: Maybe J.DocumentLinkOptions , colorProvider :: Maybe J.ColorOptions , foldingRangeProvider :: Maybe J.FoldingRangeOptions , executeCommandProvider :: Maybe J.ExecuteCommandOptions } instance Default Options where def = Options Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing -- | A function to publish diagnostics. It aggregates all diagnostics pertaining -- to a particular version of a document, by source, and sends a -- '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.NormalizedUri -> 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 -> Maybe J.DiagnosticSource -> IO () -- | A package indicating the perecentage of progress complete and a -- an optional message to go with it during a 'withProgress' -- -- @since 0.10.0.0 data Progress = Progress (Maybe Double) (Maybe Text) -- | Thrown if the user cancels a 'Cancellable' 'withProgress'/'withIndefiniteProgress'/ session -- -- @since 0.11.0.0 data ProgressCancelledException = ProgressCancelledException deriving Show instance E.Exception ProgressCancelledException -- | Whether or not the user should be able to cancel a 'withProgress'/'withIndefiniteProgress' -- session -- -- @since 0.11.0.0 data ProgressCancellable = Cancellable | NotCancellable -- | Returned to the server on startup, providing ways to interact with the client. data LspFuncs c = LspFuncs { clientCapabilities :: !C.ClientCapabilities , config :: !(IO (Maybe c)) -- ^ Derived from the DidChangeConfigurationNotification message via a -- server-provided function. , sendFunc :: !SendFunc , getVirtualFileFunc :: !(J.NormalizedUri -> IO (Maybe VirtualFile)) , persistVirtualFileFunc :: !(J.NormalizedUri -> IO FilePath) , reverseFileMapFunc :: !(IO (FilePath -> FilePath)) , publishDiagnosticsFunc :: !PublishDiagnosticsFunc , flushDiagnosticsBySourceFunc :: !FlushDiagnosticsBySourceFunc , getNextReqId :: !(IO J.LspId) , rootPath :: !(Maybe FilePath) , getWorkspaceFolders :: !(IO (Maybe [J.WorkspaceFolder])) , withProgress :: !(forall a . Text -> ProgressCancellable -> ((Progress -> IO ()) -> IO a) -> IO a) -- ^ Wrapper for reporting progress to the client during a long running -- task. -- 'withProgress' @title cancellable f@ starts a new progress reporting -- session, and finishes it once f is completed. -- f is provided with an update function that allows it to report on -- the progress during the session. -- If @cancellable@ is 'Cancellable', @f@ will be thrown a -- 'ProgressCancelledException' if the user cancels the action in -- progress. -- -- @since 0.10.0.0 , withIndefiniteProgress :: !(forall a . Text -> ProgressCancellable -> IO a -> IO a) -- ^ Same as 'withProgress', but for processes that do not report the -- precentage complete. -- -- @since 0.10.0.0 } -- | Contains all the callbacks to use for initialized the language server. -- it is parameterized over a config type variable representing the type for the -- specific configuration data the language server needs to use. data InitializeCallbacks config = InitializeCallbacks { onInitialConfiguration :: J.InitializeRequest -> Either T.Text config -- ^ Invoked on the first message from the language client, containg the client configuration -- This callback should return either the parsed configuration data or an error indicating -- what went wrong. The parsed configuration object will be stored internally and passed to -- hanlder functions as context. , onConfigurationChange :: J.DidChangeConfigurationNotification-> Either T.Text config -- ^ Invoked whenever the clients sends a message with a changed client configuration. -- This callback should return either the parsed configuration data or an error indicating -- what went wrong. The parsed configuration object will be stored internally and passed to -- hanlder functions as context. , onStartup :: LspFuncs config -> IO (Maybe J.ResponseError) -- ^ Once the initial configuration has been received, this callback will be invoked to offer -- the language server implementation the chance to create any processes or start new threads -- that may be necesary for the server lifecycle. } -- | The Handler type captures a function that receives local read-only state -- 'a', a function to send a reply message once encoded as a ByteString, and a -- received message of type 'b' type Handler b = b -> IO () -- | Callbacks from the language server to the language handler data Handlers = Handlers { -- Capability-advertised handlers hoverHandler :: !(Maybe (Handler J.HoverRequest)) , completionHandler :: !(Maybe (Handler J.CompletionRequest)) , completionResolveHandler :: !(Maybe (Handler J.CompletionItemResolveRequest)) , signatureHelpHandler :: !(Maybe (Handler J.SignatureHelpRequest)) , definitionHandler :: !(Maybe (Handler J.DefinitionRequest)) , typeDefinitionHandler :: !(Maybe (Handler J.TypeDefinitionRequest)) , implementationHandler :: !(Maybe (Handler J.ImplementationRequest)) , referencesHandler :: !(Maybe (Handler J.ReferencesRequest)) , documentHighlightHandler :: !(Maybe (Handler J.DocumentHighlightRequest)) , documentSymbolHandler :: !(Maybe (Handler J.DocumentSymbolRequest)) , workspaceSymbolHandler :: !(Maybe (Handler J.WorkspaceSymbolRequest)) , codeActionHandler :: !(Maybe (Handler J.CodeActionRequest)) , codeLensHandler :: !(Maybe (Handler J.CodeLensRequest)) , codeLensResolveHandler :: !(Maybe (Handler J.CodeLensResolveRequest)) , documentColorHandler :: !(Maybe (Handler J.DocumentColorRequest)) , colorPresentationHandler :: !(Maybe (Handler J.ColorPresentationRequest)) , documentFormattingHandler :: !(Maybe (Handler J.DocumentFormattingRequest)) , documentRangeFormattingHandler :: !(Maybe (Handler J.DocumentRangeFormattingRequest)) , documentTypeFormattingHandler :: !(Maybe (Handler J.DocumentOnTypeFormattingRequest)) , renameHandler :: !(Maybe (Handler J.RenameRequest)) , prepareRenameHandler :: !(Maybe (Handler J.PrepareRenameRequest)) , foldingRangeHandler :: !(Maybe (Handler J.FoldingRangeRequest)) -- new in 3.0 , documentLinkHandler :: !(Maybe (Handler J.DocumentLinkRequest)) , documentLinkResolveHandler :: !(Maybe (Handler J.DocumentLinkResolveRequest)) , executeCommandHandler :: !(Maybe (Handler J.ExecuteCommandRequest)) -- Next 2 go from server -> client -- , registerCapabilityHandler :: !(Maybe (Handler J.RegisterCapabilityRequest)) -- , unregisterCapabilityHandler :: !(Maybe (Handler J.UnregisterCapabilityRequest)) , willSaveWaitUntilTextDocHandler:: !(Maybe (Handler J.WillSaveWaitUntilTextDocumentRequest)) -- Notifications from the client , didChangeConfigurationParamsHandler :: !(Maybe (Handler J.DidChangeConfigurationNotification)) , didOpenTextDocumentNotificationHandler :: !(Maybe (Handler J.DidOpenTextDocumentNotification)) , didChangeTextDocumentNotificationHandler :: !(Maybe (Handler J.DidChangeTextDocumentNotification)) -- ^ Note: If you need to keep track of document changes, -- "Language.Haskell.LSP.VFS" will take care of these messages for you! , didCloseTextDocumentNotificationHandler :: !(Maybe (Handler J.DidCloseTextDocumentNotification)) , didSaveTextDocumentNotificationHandler :: !(Maybe (Handler J.DidSaveTextDocumentNotification)) , didChangeWatchedFilesNotificationHandler :: !(Maybe (Handler J.DidChangeWatchedFilesNotification)) , didChangeWorkspaceFoldersNotificationHandler :: !(Maybe (Handler J.DidChangeWorkspaceFoldersNotification)) -- new in 3.0 , initializedHandler :: !(Maybe (Handler J.InitializedNotification)) , willSaveTextDocumentNotificationHandler :: !(Maybe (Handler J.WillSaveTextDocumentNotification)) , cancelNotificationHandler :: !(Maybe (Handler J.CancelNotification)) -- Responses to Request messages originated from the server -- 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)) , customRequestHandler :: !(Maybe (Handler J.CustomClientRequest)) , customNotificationHandler :: !(Maybe (Handler J.CustomClientNotification)) } instance Default Handlers where -- These already implicitly do stuff to the VFS, so silence warnings about no handler def = nothings { didChangeTextDocumentNotificationHandler = Just ignore , didOpenTextDocumentNotificationHandler = Just ignore , didCloseTextDocumentNotificationHandler = Just ignore } where ignore = const (pure ()) nothings = 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 Nothing Nothing Nothing Nothing Nothing Nothing -- --------------------------------------------------------------------- nop :: a -> b -> IO a nop = const . return helper :: J.FromJSON a => (TVar (LanguageContextData config) -> a -> IO ()) -> (TVar (LanguageContextData config) -> J.Value -> IO ()) helper requestHandler tvarDat json = case J.fromJSON json of J.Success req -> requestHandler tvarDat req J.Error err -> do let msg = T.pack . unwords $ ["haskell-lsp:parse error.", show json, show err] ++ _ERR_MSG_URL failLog = sendErrorLog tvarDat msg case json of (J.Object o) -> case HM.lookup "id" o of Just olid -> case J.fromJSON olid of J.Success lid -> sendErrorResponse tvarDat lid msg _ -> failLog _ -> failLog _ -> failLog handlerMap :: (Show config) => InitializeCallbacks config -> Handlers -> J.ClientMethod -> (TVar (LanguageContextData config) -> J.Value -> IO ()) -- General handlerMap i h J.Initialize = handleInitialConfig i (initializeRequestHandler h) handlerMap _ h J.Initialized = hh nop NotInitialized $ initializedHandler h handlerMap _ _ J.Shutdown = helper shutdownRequestHandler 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 _ h J.WorkspaceDidChangeWorkspaceFolders = hwf $ didChangeWorkspaceFoldersNotificationHandler 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 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.TextDocumentDefinition = hh nop ReqDefinition $ definitionHandler h handlerMap _ h J.TextDocumentTypeDefinition = hh nop ReqTypeDefinition $ typeDefinitionHandler h handlerMap _ h J.TextDocumentImplementation = hh nop ReqImplementation $ implementationHandler 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.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.TextDocumentDocumentColor = hh nop ReqDocumentColor $ documentColorHandler h handlerMap _ h J.TextDocumentColorPresentation = hh nop ReqColorPresentation $ colorPresentationHandler 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 _ h J.TextDocumentPrepareRename = hh nop ReqPrepareRename $ prepareRenameHandler h handlerMap _ h J.TextDocumentFoldingRange = hh nop ReqFoldingRange $ foldingRangeHandler h handlerMap _ _ J.WorkDoneProgressCancel = helper progressCancelHandler handlerMap _ h (J.CustomClientMethod _) = \ctxData val -> case val of J.Object o | "id" `HM.member` o -> -- Custom request hh nop ReqCustomClient (customRequestHandler h) ctxData val _ -> -- Custom notification hh nop NotCustomClient (customNotificationHandler h) ctxData val -- --------------------------------------------------------------------- -- | Adapter from the normal handlers exposed to the library users and the -- internal message loop hh :: forall b config. (J.FromJSON b) => (VFS -> b -> IO VFS) -> (b -> FromClientMessage) -> Maybe (Handler b) -> TVar (LanguageContextData config) -> 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 let msg = T.pack $ unwords ["haskell-lsp:no handler for.", show json] sendErrorLog tvarDat msg J.Error err -> do let msg = T.pack $ unwords $ ["haskell-lsp:parse error.", show json, show err] ++ _ERR_MSG_URL sendErrorLog tvarDat msg handleInitialConfig :: (Show config) => InitializeCallbacks config -> Maybe (Handler J.InitializeRequest) -> TVar (LanguageContextData config) -> J.Value -> IO () handleInitialConfig (InitializeCallbacks { onInitialConfiguration, onStartup }) mh tvarDat json = handleMessageWithConfigChange ReqInitialize onInitialConfiguration (Just $ initializeRequestHandler' onStartup mh tvarDat) tvarDat json hc :: (Show config) => InitializeCallbacks config -> Maybe (Handler J.DidChangeConfigurationNotification) -> TVar (LanguageContextData config) -> J.Value -> IO () hc (InitializeCallbacks { onConfigurationChange }) mh tvarDat json = handleMessageWithConfigChange NotDidChangeConfiguration onConfigurationChange mh tvarDat json handleMessageWithConfigChange :: (J.FromJSON reqParams, Show reqParams, Show err) => (reqParams -> FromClientMessage) -- ^ The notification message from the client to expect -> (reqParams -> Either err config) -- ^ A function to parse the config out of the request -> Maybe (reqParams -> IO ()) -- ^ The upstream handler for the client request -> TVar (LanguageContextData config) -- ^ The context data containing the current configuration -> J.Value -- ^ The raw reqeust data -> IO () handleMessageWithConfigChange notification parseConfig mh tvarDat json = -- logs $ "haskell-lsp:hc DidChangeConfigurationNotification entered" case J.fromJSON json of J.Success req -> do ctx <- readTVarIO tvarDat captureFromClient (notification req) (resCaptureFile ctx) case parseConfig req of Left err -> do let msg = T.pack $ unwords ["haskell-lsp:configuration parse 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 (const ctx') case mh of Just h -> h req Nothing -> return () J.Error err -> do let msg = T.pack $ unwords $ ["haskell-lsp:parse error.", show json, show err] ++ _ERR_MSG_URL sendErrorLog tvarDat msg -- | Updates the list of workspace folders and then delegates back to 'hh' hwf :: Maybe (Handler J.DidChangeWorkspaceFoldersNotification) -> TVar (LanguageContextData config) -> J.Value -> IO () hwf h tvarDat json = do case J.fromJSON json :: J.Result J.DidChangeWorkspaceFoldersNotification of J.Success (J.NotificationMessage _ _ params) -> atomically $ do oldWfs <- resWorkspaceFolders <$> readTVar tvarDat let J.List toRemove = params ^. J.event . J.removed wfs0 = foldr L.delete oldWfs toRemove J.List toAdd = params ^. J.event . J.added wfs1 = wfs0 <> toAdd modifyTVar' tvarDat (\c -> c {resWorkspaceFolders = wfs1}) _ -> return () hh nop NotDidChangeWorkspaceFolders h tvarDat json -- --------------------------------------------------------------------- getVirtualFile :: TVar (LanguageContextData config) -> J.NormalizedUri -> IO (Maybe VirtualFile) getVirtualFile tvarDat uri = Map.lookup uri . resVFS <$> readTVarIO tvarDat -- | Dump the current text for a given VFS file to a temporary file, -- and return the path to the file. persistVirtualFile :: TVar (LanguageContextData config) -> J.NormalizedUri -> IO FilePath persistVirtualFile tvarDat uri = do st <- readTVarIO tvarDat let vfs = resVFS st revMap = reverseMap st (fn, new_vfs) <- persistFileVFS vfs uri let revMap' = -- TODO: Does the VFS make sense for URIs which are not files? -- The reverse map should perhaps be (FilePath -> URI) case J.uriToFilePath (J.fromNormalizedUri uri) of Just uri_fp -> Map.insert fn uri_fp revMap Nothing -> revMap atomically $ modifyTVar' tvarDat (\d -> d { resVFS = new_vfs , reverseMap = revMap' }) return fn -- TODO: should this function return a URI? -- | If the contents of a VFS has been dumped to a temporary file, map -- the temporary file name back to the original one. reverseFileMap :: TVar (LanguageContextData config) -> IO (FilePath -> FilePath) reverseFileMap tvarDat = do revMap <- reverseMap <$> readTVarIO tvarDat let f fp = fromMaybe fp $ Map.lookup fp revMap return f -- --------------------------------------------------------------------- getConfig :: TVar (LanguageContextData config) -> IO (Maybe config) getConfig tvar = resConfig <$> readTVarIO tvar -- --------------------------------------------------------------------- -- | -- -- _INITIAL_RESPONSE_SEQUENCE :: Int _INITIAL_RESPONSE_SEQUENCE = 0 -- | -- -- _SEP_WIN :: Char _SEP_WIN = '\\' -- | -- -- _SEP_UNIX :: Char _SEP_UNIX = '/' -- | -- -- _ERR_MSG_URL :: [String] _ERR_MSG_URL = [ "`stack update` and install new haskell-lsp." , "Or check information on https://marketplace.visualstudio.com/items?itemName=xxxxxxxxxxxxxxx" ] -- | -- -- defaultLanguageContextData :: Handlers -> Options -> LspFuncs config -> TVar Int -> SendFunc -> Maybe FilePath -> LanguageContextData config defaultLanguageContextData h o lf tv sf cf = LanguageContextData _INITIAL_RESPONSE_SEQUENCE h o sf mempty mempty mempty Nothing tv lf cf mempty defaultProgressData defaultProgressData :: ProgressData defaultProgressData = ProgressData 0 Map.empty -- --------------------------------------------------------------------- handleMessage :: (Show config) => InitializeCallbacks config -> TVar (LanguageContextData config) -> BSL.ByteString -> IO () handleMessage dispatcherProc tvarDat jsonStr = do {- Message Types we must handle are the following Request | jsonrpc | id | method | params? Response | jsonrpc | id | | | response? | error? Notification | jsonrpc | | method | params? -} case J.eitherDecode jsonStr :: Either String J.Object of Left err -> do let msg = T.pack $ unwords [ "haskell-lsp:incoming message parse error.", lbs2str jsonStr, show err] ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n" 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 J.Error _ -> do let msg = T.pack $ unwords ["haskell-lsp:unknown message received:method='" ++ T.unpack s ++ "',", lbs2str jsonStr] sendErrorLog tvarDat msg Just oops -> logs $ "haskell-lsp:got strange method param, ignoring:" ++ show oops Nothing -> do logs $ "haskell-lsp:Got reply message:" ++ show jsonStr handleResponse (J.Object o) where handleResponse json = do ctx <- readTVarIO tvarDat case responseHandler $ resHandlers ctx of Nothing -> sendErrorLog tvarDat $ T.pack $ "haskell-lsp: responseHandler is not defined, ignoring response " ++ lbs2str jsonStr Just h -> case J.fromJSON json of J.Success res -> h res J.Error err -> let msg = T.pack $ unwords $ ["haskell-lsp:response parse error.", lbs2str jsonStr, show err] ++ _ERR_MSG_URL in sendErrorLog tvarDat msg -- capability based handlers handle json cmd = do ctx <- readTVarIO tvarDat let h = resHandlers ctx handlerMap dispatcherProc h cmd tvarDat json -- --------------------------------------------------------------------- makeResponseMessage :: J.RequestMessage J.ClientMethod req resp -> resp -> J.ResponseMessage resp makeResponseMessage req result = J.ResponseMessage "2.0" (J.responseId $ req ^. J.id) (Just result) Nothing makeResponseError :: J.LspIdRsp -> J.ResponseError -> J.ResponseMessage () makeResponseError origId err = J.ResponseMessage "2.0" origId Nothing (Just err) -- --------------------------------------------------------------------- -- | -- sendEvent :: TVar (LanguageContextData config) -> FromServerMessage -> IO () sendEvent tvarCtx msg = sendResponse tvarCtx msg -- | -- sendResponse :: TVar (LanguageContextData config) -> FromServerMessage -> IO () sendResponse tvarCtx msg = do ctx <- readTVarIO tvarCtx resSendResponse ctx msg -- --------------------------------------------------------------------- -- | -- -- sendErrorResponse :: TVar (LanguageContextData config) -> J.LspIdRsp -> Text -> IO () sendErrorResponse tv origId msg = sendErrorResponseS (sendEvent tv) origId J.InternalError msg sendErrorResponseS :: SendFunc -> J.LspIdRsp -> J.ErrorCode -> Text -> IO () sendErrorResponseS sf origId err msg = do sf $ RspError (J.ResponseMessage "2.0" origId Nothing (Just $ J.ResponseError err msg Nothing) :: J.ErrorResponse) sendErrorLog :: TVar (LanguageContextData config) -> Text -> IO () sendErrorLog tv msg = sendErrorLogS (sendEvent tv) msg sendErrorLogS :: SendFunc -> Text -> IO () sendErrorLogS sf msg = sf $ NotLogMessage $ fmServerLogMessageNotification J.MtError msg -- sendErrorShow :: String -> IO () -- sendErrorShow msg = sendErrorShowS sendEvent msg sendErrorShowS :: SendFunc -> Text -> IO () sendErrorShowS sf msg = sf $ NotShowMessage $ fmServerShowMessageNotification J.MtError msg -- --------------------------------------------------------------------- defaultErrorHandlers :: (Show a) => TVar (LanguageContextData config) -> J.LspIdRsp -> a -> [E.Handler ()] defaultErrorHandlers tvarDat origId req = [ E.Handler someExcept ] where someExcept (e :: E.SomeException) = do let msg = T.pack $ unwords ["request error.", show req, show e] sendErrorResponse tvarDat origId msg sendErrorLog tvarDat msg -- |===================================================================== -- -- Handlers -- | -- initializeRequestHandler' :: (Show config) => (LspFuncs config -> IO (Maybe J.ResponseError)) -> Maybe (Handler J.InitializeRequest) -> TVar (LanguageContextData config) -> J.InitializeRequest -> IO () initializeRequestHandler' onStartup 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 () let wfs = case params ^. J.workspaceFolders of Just (J.List xs) -> xs Nothing -> [] atomically $ modifyTVar' tvarCtx (\c -> c { resWorkspaceFolders = wfs }) ctx0 <- readTVarIO tvarCtx let rootDir = getFirst $ foldMap First [ params ^. J.rootUri >>= J.uriToFilePath , params ^. J.rootPath <&> T.unpack ] case rootDir of Nothing -> return () Just dir -> do logs $ "haskell-lsp:initializeRequestHandler: setting current dir to project root:" ++ dir unless (null dir) $ setCurrentDirectory dir let getCapabilities :: J.InitializeParams -> C.ClientCapabilities getCapabilities (J.InitializeParams _ _ _ _ c _ _) = c getLspId tvId = atomically $ do cid <- readTVar tvId modifyTVar' tvId (+1) return $ J.IdInt cid clientSupportsWfs = fromMaybe False $ do let (C.ClientCapabilities mw _ _ _) = params ^. J.capabilities (C.WorkspaceClientCapabilities _ _ _ _ _ _ mwf _) <- mw mwf getWfs tvc | clientSupportsWfs = atomically $ Just . resWorkspaceFolders <$> readTVar tvc | otherwise = return Nothing clientSupportsProgress = fromMaybe False $ do let (C.ClientCapabilities _ _ wc _) = params ^. J.capabilities (C.WindowClientCapabilities mProgress) <- wc mProgress storeProgress :: J.ProgressToken -> Async a -> IO () storeProgress n a = atomically $ do pd <- resProgressData <$> readTVar tvarCtx let pc = progressCancel pd pc' = Map.insert n (cancelWith a ProgressCancelledException) pc modifyTVar tvarCtx (\ctx -> ctx { resProgressData = pd { progressCancel = pc' }}) deleteProgress :: J.ProgressToken -> IO () deleteProgress n = atomically $ do pd <- resProgressData <$> readTVar tvarCtx let x = progressCancel pd x' = Map.delete n x modifyTVar tvarCtx (\ctx -> ctx { resProgressData = pd { progressCancel = x' }}) -- Get a new id for the progress session and make a new one getNewProgressId :: IO J.ProgressToken getNewProgressId = liftIO $ atomically $ do pd <- resProgressData <$> readTVar tvarCtx let x = progressNextId pd modifyTVar tvarCtx (\ctx -> ctx { resProgressData = pd { progressNextId = x + 1 }}) return $ J.ProgressNumericToken x withProgressBase :: Bool -> (Text -> ProgressCancellable -> ((Progress -> IO ()) -> IO a) -> IO a) withProgressBase indefinite title cancellable f | clientSupportsProgress = do sf <- liftIO $ resSendResponse <$> readTVarIO tvarCtx progId <- getNewProgressId let initialPercentage | indefinite = Nothing | otherwise = Just 0 cancellable' = case cancellable of Cancellable -> True NotCancellable -> False rId <- getLspId $ resLspId ctx0 -- Create progress token liftIO $ sf $ ReqWorkDoneProgressCreate $ fmServerWorkDoneProgressCreateRequest rId $ J.WorkDoneProgressCreateParams progId -- Send initial notification liftIO $ sf $ NotWorkDoneProgressBegin $ fmServerWorkDoneProgressBeginNotification $ J.ProgressParams progId $ J.WorkDoneProgressBeginParams title (Just cancellable') Nothing initialPercentage aid <- async $ f (updater progId sf) storeProgress progId aid res <- wait aid -- Send done notification liftIO $ sf $ NotWorkDoneProgressEnd $ fmServerWorkDoneProgressEndNotification $ J.ProgressParams progId $ J.WorkDoneProgressEndParams Nothing -- Delete the progress cancellation from the map -- If we don't do this then it's easy to leak things as the map contains any IO action. deleteProgress progId return res | otherwise = f (const $ return ()) where updater progId sf (Progress percentage msg) = sf $ NotWorkDoneProgressReport $ fmServerWorkDoneProgressReportNotification $ J.ProgressParams progId $ J.WorkDoneProgressReportParams Nothing msg percentage withProgress' :: Text -> ProgressCancellable -> ((Progress -> IO ()) -> IO a) -> IO a withProgress' = withProgressBase False withIndefiniteProgress' :: Text -> ProgressCancellable -> IO a -> IO a withIndefiniteProgress' title cancellable f = withProgressBase True title cancellable (const f) -- Launch the given process once the project root directory has been set let lspFuncs = LspFuncs (getCapabilities params) (getConfig tvarCtx) (resSendResponse ctx0) (getVirtualFile tvarCtx) (persistVirtualFile tvarCtx) (reverseFileMap tvarCtx) (publishDiagnostics tvarCtx) (flushDiagnosticsBySource tvarCtx) (getLspId $ resLspId ctx0) rootDir (getWfs tvarCtx) withProgress' withIndefiniteProgress' let ctx = ctx0 { resLspFuncs = lspFuncs } atomically $ writeTVar tvarCtx ctx initializationResult <- onStartup lspFuncs case initializationResult of Just errResp -> do sendResponse tvarCtx $ RspError $ makeResponseError (J.responseId origId) errResp Nothing -> do let h = resHandlers ctx o = resOptions ctx supported (Just _) = Just True supported Nothing = Nothing -- If a dynamic setting is provided use it, else set a -- static True if there is a handler. static (Just d) _ = Just d static _ (Just _) = Just (J.GotoOptionsStatic True) static _ Nothing = Nothing static' (Just d) (Just _) = Just d static' _ (Just _) = Just (J.CodeActionOptionsStatic True) static' _ _ = Nothing sync = case textDocumentSync o of Just x -> Just (J.TDSOptions x) Nothing -> Nothing workspace = J.WorkspaceOptions workspaceFolder workspaceFolder = case didChangeWorkspaceFoldersNotificationHandler h of Just _ -> Just $ -- sign up to receive notifications J.WorkspaceFolderOptions (Just True) (Just (J.WorkspaceFolderChangeNotificationsBool True)) Nothing -> Nothing capa = J.InitializeResponseCapabilitiesInner { J._textDocumentSync = sync , J._hoverProvider = supported (hoverHandler h) , J._completionProvider = completionProvider o , J._signatureHelpProvider = signatureHelpProvider o , J._definitionProvider = supported (definitionHandler h) , J._typeDefinitionProvider = static (typeDefinitionProvider o) (typeDefinitionHandler h) , J._implementationProvider = implementationProvider o , J._referencesProvider = supported (referencesHandler h) , J._documentHighlightProvider = supported (documentHighlightHandler h) , J._documentSymbolProvider = supported (documentSymbolHandler h) , J._workspaceSymbolProvider = supported (workspaceSymbolHandler h) , J._codeActionProvider = static' (codeActionProvider o) (codeActionHandler h) , J._codeLensProvider = codeLensProvider o , J._documentFormattingProvider = supported (documentFormattingHandler h) , J._documentRangeFormattingProvider = supported (documentRangeFormattingHandler h) , J._documentOnTypeFormattingProvider = documentOnTypeFormattingProvider o , J._renameProvider = renameProvider o , J._documentLinkProvider = documentLinkProvider o , J._colorProvider = colorProvider o , J._foldingRangeProvider = foldingRangeProvider o , J._executeCommandProvider = executeCommandProvider o , J._workspace = Just workspace -- TODO: Add something for experimental , 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 $ RspInitialize res progressCancelHandler :: TVar (LanguageContextData config) -> J.WorkDoneProgressCancelNotification -> IO () progressCancelHandler tvarCtx (J.NotificationMessage _ _ (J.WorkDoneProgressCancelParams tid)) = do mact <- Map.lookup tid . progressCancel . resProgressData <$> readTVarIO tvarCtx case mact of Nothing -> return () Just cancelAction -> cancelAction -- | -- shutdownRequestHandler :: TVar (LanguageContextData config) -> J.ShutdownRequest -> IO () shutdownRequestHandler tvarCtx req@(J.RequestMessage _ origId _ _) = flip E.catches (defaultErrorHandlers tvarCtx (J.responseId origId) req) $ do let res = makeResponseMessage req Nothing 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 config) -> PublishDiagnosticsFunc publishDiagnostics tvarDat maxDiagnosticCount uri version diags = do ctx <- readTVarIO tvarDat 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 $ NotPublishDiagnostics $ J.NotificationMessage "2.0" J.TextDocumentPublishDiagnostics params -- --------------------------------------------------------------------- -- | Take the new diagnostics, update the stored diagnostics for the given file -- and version, and publish the total to the client. flushDiagnosticsBySource :: TVar (LanguageContextData config) -> FlushDiagnosticsBySourceFunc flushDiagnosticsBySource tvarDat maxDiagnosticCount msource = do -- logs $ "haskell-lsp:flushDiagnosticsBySource:source=" ++ show source ctx <- readTVarIO tvarDat let ds = flushBySource (resDiagnostics ctx) msource atomically $ writeTVar tvarDat $ ctx {resDiagnostics = ds} -- Send the updated diagnostics to the client forM_ (Map.keys ds) $ \uri -> do -- logs $ "haskell-lsp:flushDiagnosticsBySource:uri=" ++ show uri let mdp = getDiagnosticParamsFor maxDiagnosticCount ds uri case mdp of Nothing -> return () Just params -> do resSendResponse ctx $ NotPublishDiagnostics $ J.NotificationMessage "2.0" J.TextDocumentPublishDiagnostics params -- |===================================================================== -- -- utility -- | -- Logger -- setupLogger :: Maybe FilePath -> [String] -> Priority -> IO () setupLogger mLogFile extraLogNames level = do logStream <- case mLogFile of Just logFile -> openFile logFile AppendMode Nothing -> return stderr hSetEncoding logStream utf8 logH <- LHS.streamHandler logStream level let logHandle = logH {LHS.closeFunc = hClose} logFormat = L.tfLogFormatter _LOG_FORMAT_DATE _LOG_FORMAT logHandler = LH.setFormatter logHandle logFormat L.updateGlobalLogger L.rootLoggerName $ L.setHandlers ([] :: [LHS.GenericHandler Handle]) L.updateGlobalLogger _LOG_NAME $ L.setHandlers [logHandler] L.updateGlobalLogger _LOG_NAME $ L.setLevel level -- Also route the additional log names to the same log forM_ extraLogNames $ \logName -> do L.updateGlobalLogger logName $ L.setHandlers [logHandler] L.updateGlobalLogger logName $ L.setLevel level -- --------------------------------------------------------------------- -- | The changes in a workspace edit should be applied from the end of the file -- toward the start. Sort them into this order. reverseSortEdit :: J.WorkspaceEdit -> J.WorkspaceEdit reverseSortEdit (J.WorkspaceEdit cs dcs) = J.WorkspaceEdit cs' dcs' where cs' :: Maybe J.WorkspaceEditMap cs' = (fmap . fmap ) sortTextEdits cs dcs' :: Maybe (J.List J.TextDocumentEdit) dcs' = (fmap . fmap ) sortTextDocumentEdits dcs sortTextEdits :: J.List J.TextEdit -> J.List J.TextEdit sortTextEdits (J.List edits) = J.List (L.sortBy down edits) sortTextDocumentEdits :: J.TextDocumentEdit -> J.TextDocumentEdit sortTextDocumentEdits (J.TextDocumentEdit td (J.List edits)) = J.TextDocumentEdit td (J.List edits') where edits' = L.sortBy down edits down (J.TextEdit r1 _) (J.TextEdit r2 _) = r2 `compare` r1