diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,17 @@ # Revision history for haskell-lsp +## 0.18.0.0 -- 2019-11-17 + +* Explain the use of NonEmpty in + documentOnTypeFormattingTriggerCharacters (@bubba) +* Fix response type for CodeLensResolve, add the ContentModified error + code (@SquidDev) +* Virtual file fixes, removing race conditions and other cleanups (@mpickering) +* Add missing fmClientPrepareRenameRequest to MessageFuncs export (@alanz) +* Make explicit GHC 8.6.5 stack file (@alanz) +* Rework Core.Options and infer all server capabilities from handlers (@bubba) +* Generate lenses for WorkDoneProgress data types (@alanz) + ## 0.17.0.0 -- 2019-10-18 * Update progress reporting to match the LSP 3.15 specification (@cocreature) 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.17.0.0 +version: 0.18.0.0 synopsis: Haskell library for the Microsoft Language Server Protocol description: An implementation of the types, and basic message server to @@ -46,7 +46,7 @@ , filepath , hslogger , hashable - , haskell-lsp-types == 0.17.* + , haskell-lsp-types == 0.18.* , lens >= 4.15.2 , mtl , network-uri diff --git a/src/Language/Haskell/LSP/Capture.hs b/src/Language/Haskell/LSP/Capture.hs --- a/src/Language/Haskell/LSP/Capture.hs +++ b/src/Language/Haskell/LSP/Capture.hs @@ -18,7 +18,7 @@ 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 () @@ -26,5 +26,5 @@ 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 @@ -31,6 +31,7 @@ import Language.Haskell.LSP.Capture import qualified Language.Haskell.LSP.Core as Core import Language.Haskell.LSP.Messages +import Language.Haskell.LSP.VFS import Language.Haskell.LSP.Utility import System.IO import System.FilePath @@ -83,10 +84,10 @@ 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 timestampCaptureFp + initVFS $ \vfs -> do + tvarDat <- atomically $ newTVar $ Core.defaultLanguageContextData h o lf tvarId sendFunc timestampCaptureFp vfs - ioLoop hin initializeCallbacks tvarDat + ioLoop hin initializeCallbacks tvarDat return 1 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 @@ -9,6 +9,7 @@ module Language.Haskell.LSP.Core ( handleMessage , LanguageContextData(..) + , VFSData(..) , Handler , InitializeCallbacks(..) , LspFuncs(..) @@ -28,18 +29,19 @@ , reverseSortEdit ) where -import Control.Concurrent.STM import Control.Concurrent.Async +import Control.Concurrent.STM import qualified Control.Exception as E import Control.Monad import Control.Monad.IO.Class -import Control.Lens ( (<&>), (^.) ) +import Control.Lens ( (<&>), (^.), (^?), _Just ) 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 Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Map as Map import Data.Maybe import Data.Monoid @@ -79,8 +81,7 @@ , resHandlers :: !Handlers , resOptions :: !Options , resSendResponse :: !SendFunc - , resVFS :: !VFS - , reverseMap :: !(Map.Map FilePath FilePath) + , resVFS :: !VFSData , resDiagnostics :: !DiagnosticStore , resConfig :: !(Maybe config) , resLspId :: !(TVar Int) @@ -93,31 +94,46 @@ data ProgressData = ProgressData { progressNextId :: !Int , progressCancel :: !(Map.Map J.ProgressToken (IO ())) } +data VFSData = + VFSData + { vfsData :: !VFS + , reverseMap :: !(Map.Map FilePath FilePath) + } + -- --------------------------------------------------------------------- --- | Language Server Protocol options supported by the given language server. --- These are automatically turned into capabilities reported to the client --- during initialization. +-- | Language Server Protocol options that the server may configure. +-- If you set handlers for some requests, you may need to set some of these options. 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 + -- | The characters that trigger completion automatically. + , completionTriggerCharacters :: Maybe [Char] + -- | The list of all possible characters that commit a completion. This field can be used + -- if clients don't support individual commmit characters per completion item. See + -- `_commitCharactersSupport`. + , completionAllCommitCharacters :: Maybe [Char] + -- | The characters that trigger signature help automatically. + , signatureHelpTriggerCharacters :: Maybe [Char] + -- | List of characters that re-trigger signature help. + -- These trigger characters are only active when signature help is already showing. All trigger characters + -- are also counted as re-trigger characters. + , signatureHelpRetriggerCharacters :: Maybe [Char] + -- | CodeActionKinds that this server may return. + -- The list of kinds may be generic, such as `CodeActionKind.Refactor`, or the server + -- may list out every specific kind they provide. + , codeActionKinds :: Maybe [J.CodeActionKind] + -- | The list of characters that triggers on type formatting. + -- If you set `documentOnTypeFormattingHandler`, you **must** set this. + -- The first character is mandatory, so a 'NonEmpty' should be passed. + , documentOnTypeFormattingTriggerCharacters :: Maybe (NonEmpty Char) + -- | The commands to be executed on the server. + -- If you set `executeCommandHandler`, you **must** set this. + , executeCommandCommands :: Maybe [Text] } 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 @@ -159,6 +175,8 @@ -- server-provided function. , sendFunc :: !SendFunc , getVirtualFileFunc :: !(J.NormalizedUri -> IO (Maybe VirtualFile)) + -- ^ Function to return the 'VirtualFile' associated with a + -- given 'NormalizedUri', if there is one. , persistVirtualFileFunc :: !(J.NormalizedUri -> IO FilePath) , reverseFileMapFunc :: !(IO (FilePath -> FilePath)) , publishDiagnosticsFunc :: !PublishDiagnosticsFunc @@ -236,7 +254,7 @@ , colorPresentationHandler :: !(Maybe (Handler J.ColorPresentationRequest)) , documentFormattingHandler :: !(Maybe (Handler J.DocumentFormattingRequest)) , documentRangeFormattingHandler :: !(Maybe (Handler J.DocumentRangeFormattingRequest)) - , documentTypeFormattingHandler :: !(Maybe (Handler J.DocumentOnTypeFormattingRequest)) + , documentOnTypeFormattingHandler :: !(Maybe (Handler J.DocumentOnTypeFormattingRequest)) , renameHandler :: !(Maybe (Handler J.RenameRequest)) , prepareRenameHandler :: !(Maybe (Handler J.PrepareRenameRequest)) , foldingRangeHandler :: !(Maybe (Handler J.FoldingRangeRequest)) @@ -297,8 +315,8 @@ Nothing Nothing Nothing Nothing Nothing -- --------------------------------------------------------------------- -nop :: a -> b -> IO a -nop = const . return +nop :: Maybe (a -> b -> (a,[String])) +nop = Nothing helper :: J.FromJSON a => (TVar (LanguageContextData config) -> a -> IO ()) -> (TVar (LanguageContextData config) -> J.Value -> IO ()) @@ -316,8 +334,9 @@ _ -> failLog _ -> failLog -handlerMap :: (Show config) => InitializeCallbacks config - -> Handlers -> J.ClientMethod -> (TVar (LanguageContextData config) -> J.Value -> IO ()) +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 @@ -341,12 +360,12 @@ 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.TextDocumentDidOpen = hh (Just openVFS) NotDidOpenTextDocument $ didOpenTextDocumentNotificationHandler h +handlerMap _ h J.TextDocumentDidChange = hh (Just 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.TextDocumentDidClose = hh (Just 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 @@ -359,7 +378,7 @@ 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.TextDocumentOnTypeFormatting = hh nop ReqDocumentOnTypeFormatting $ documentOnTypeFormattingHandler 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 @@ -384,14 +403,19 @@ -- | 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 + => Maybe (VFS -> b -> (VFS, [String])) -> (b -> FromClientMessage) -> Maybe (Handler b) + -> TVar (LanguageContextData config) -> J.Value -> IO () +hh mVfs 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'}) + case mVfs of + Just modifyVfs -> do + join $ atomically $ modifyVFSData tvarDat $ \(VFSData vfs rm) -> + let (vfs', ls) = modifyVfs vfs req + in (VFSData vfs' rm, mapM_ logs ls) + Nothing -> return () + ctx <- readTVarIO tvarDat captureFromClient (wrapper req) (resCaptureFile ctx) case mh of @@ -455,10 +479,8 @@ 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') + Right newConfig -> + atomically $ modifyTVar' tvarDat (\ctx' -> ctx' { resConfig = Just newConfig }) case mh of Just h -> h req Nothing -> return () @@ -488,18 +510,28 @@ -- --------------------------------------------------------------------- +modifyVFSData :: TVar (LanguageContextData config) -> (VFSData -> (VFSData, a)) -> STM a +modifyVFSData tvarDat f = do + (vfs', a) <- f . resVFS <$> readTVar tvarDat + modifyTVar tvarDat $ \vd -> vd { resVFS = vfs' } + return a + +-- --------------------------------------------------------------------- + +-- | Return the 'VirtualFile' associated with a given 'NormalizedUri', if there is one. getVirtualFile :: TVar (LanguageContextData config) -> J.NormalizedUri -> IO (Maybe VirtualFile) -getVirtualFile tvarDat uri = Map.lookup uri . resVFS <$> readTVarIO tvarDat +getVirtualFile tvarDat uri = Map.lookup uri . vfsMap . vfsData . 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 +persistVirtualFile tvarDat uri = join $ atomically $ do + st <- readTVar tvarDat + let vfs_data = resVFS st + cur_vfs = vfsData vfs_data + revMap = reverseMap vfs_data - (fn, new_vfs) <- persistFileVFS vfs uri + let (fn, write) = persistFileVFS cur_vfs uri let revMap' = -- TODO: Does the VFS make sense for URIs which are not files? -- The reverse map should perhaps be (FilePath -> URI) @@ -507,9 +539,8 @@ Just uri_fp -> Map.insert fn uri_fp revMap Nothing -> revMap - atomically $ modifyTVar' tvarDat (\d -> d { resVFS = new_vfs - , reverseMap = revMap' }) - return fn + modifyVFSData tvarDat (\d -> (d { reverseMap = revMap' }, ())) + return (fn <$ write) -- TODO: should this function return a URI? -- | If the contents of a VFS has been dumped to a temporary file, map @@ -517,9 +548,9 @@ 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 + vfs <- resVFS <$> readTVarIO tvarDat + let f fp = fromMaybe fp . Map.lookup fp . reverseMap $ vfs + return f -- --------------------------------------------------------------------- @@ -558,9 +589,9 @@ -- | -- -- -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 +defaultLanguageContextData :: Handlers -> Options -> LspFuncs config -> TVar Int -> SendFunc -> Maybe FilePath -> VFS -> LanguageContextData config +defaultLanguageContextData h o lf tv sf cf vfs = + LanguageContextData _INITIAL_RESPONSE_SEQUENCE h o sf (VFSData vfs mempty) mempty Nothing tv lf cf mempty defaultProgressData defaultProgressData :: ProgressData @@ -758,7 +789,7 @@ -> ((Progress -> IO ()) -> IO a) -> IO a) withProgressBase indefinite title cancellable f | clientSupportsProgress = do - sf <- liftIO $ resSendResponse <$> readTVarIO tvarCtx + let sf = sendResponse tvarCtx progId <- getNewProgressId @@ -821,9 +852,10 @@ (getWfs tvarCtx) withProgress' withIndefiniteProgress' - let ctx = ctx0 { resLspFuncs = lspFuncs } - atomically $ writeTVar tvarCtx ctx + atomically $ modifyTVar tvarCtx (\cur_ctx -> cur_ctx { resLspFuncs = lspFuncs }) + ctx <- readTVarIO tvarCtx + initializationResult <- onStartup lspFuncs case initializationResult of @@ -831,68 +863,106 @@ sendResponse tvarCtx $ RspError $ makeResponseError (J.responseId origId) errResp Nothing -> do + let capa = serverCapabilities (getCapabilities params) (resOptions ctx) (resHandlers ctx) + -- 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 - let - h = resHandlers ctx - o = resOptions ctx + sendResponse tvarCtx $ RspInitialize res - supported (Just _) = Just True - supported Nothing = Nothing +-- | Infers the capabilities based on registered handlers, and sets the appropriate options. +-- A provider should be set to Nothing if the server does not support it, unless it is a +-- static option. +serverCapabilities :: C.ClientCapabilities -> Options -> Handlers -> J.InitializeResponseCapabilitiesInner +serverCapabilities clientCaps o h = + J.InitializeResponseCapabilitiesInner + { J._textDocumentSync = sync + , J._hoverProvider = supported (hoverHandler h) + , J._completionProvider = completionProvider + , J._signatureHelpProvider = signatureHelpProvider + , J._definitionProvider = supported (definitionHandler h) + , J._typeDefinitionProvider = Just $ J.GotoOptionsStatic $ isJust $ typeDefinitionHandler h + , J._implementationProvider = Just $ J.GotoOptionsStatic $ isJust $ typeDefinitionHandler h + , J._referencesProvider = supported (referencesHandler h) + , J._documentHighlightProvider = supported (documentHighlightHandler h) + , J._documentSymbolProvider = supported (documentSymbolHandler h) + , J._workspaceSymbolProvider = supported (workspaceSymbolHandler h) + , J._codeActionProvider = codeActionProvider + , J._codeLensProvider = supported' (codeLensHandler h) $ J.CodeLensOptions $ + supported (codeLensResolveHandler h) + , J._documentFormattingProvider = supported (documentFormattingHandler h) + , J._documentRangeFormattingProvider = supported (documentRangeFormattingHandler h) + , J._documentOnTypeFormattingProvider = documentOnTypeFormattingProvider + , J._renameProvider = Just $ J.RenameOptionsStatic $ isJust $ renameHandler h + , J._documentLinkProvider = supported' (documentLinkHandler h) $ J.DocumentLinkOptions $ + Just $ isJust $ documentLinkResolveHandler h + , J._colorProvider = Just $ J.ColorOptionsStatic $ isJust $ documentColorHandler h + , J._foldingRangeProvider = Just $ J.FoldingRangeOptionsStatic $ isJust $ foldingRangeHandler h + , J._executeCommandProvider = executeCommandProvider + , J._workspace = Just workspace + -- TODO: Add something for experimental + , J._experimental = Nothing :: Maybe J.Value + } + where + supported x = supported' x True - -- 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 + supported' (Just _) = Just + supported' Nothing = const Nothing - sync = case textDocumentSync o of - Just x -> Just (J.TDSOptions x) - Nothing -> Nothing + singleton :: a -> [a] + singleton x = [x] - 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 + completionProvider + | isJust $ completionHandler h = Just $ + J.CompletionOptions + (Just $ isJust $ completionResolveHandler h) + (map singleton <$> completionTriggerCharacters o) + (map singleton <$> completionAllCommitCharacters o) + | otherwise = 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 - } + clientSupportsCodeActionKinds = isJust $ + clientCaps ^? J.textDocument . _Just . J.codeAction . _Just . J.codeActionLiteralSupport - -- 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 + codeActionProvider + | clientSupportsCodeActionKinds + , isJust $ codeActionHandler h = Just $ maybe (J.CodeActionOptionsStatic True) (J.CodeActionOptions . Just) (codeActionKinds o) + | isJust $ codeActionHandler h = Just (J.CodeActionOptionsStatic True) + | otherwise = Just (J.CodeActionOptionsStatic False) - sendResponse tvarCtx $ RspInitialize res + signatureHelpProvider + | isJust $ signatureHelpHandler h = Just $ + J.SignatureHelpOptions + (map singleton <$> signatureHelpTriggerCharacters o) + (map singleton <$> signatureHelpRetriggerCharacters o) + | otherwise = Nothing + documentOnTypeFormattingProvider + | isJust $ documentOnTypeFormattingHandler h + , Just (first :| rest) <- documentOnTypeFormattingTriggerCharacters o = Just $ + J.DocumentOnTypeFormattingOptions (T.pack [first]) (Just (map (T.pack . singleton) rest)) + | isJust $ documentOnTypeFormattingHandler h + , Nothing <- documentOnTypeFormattingTriggerCharacters o = + error "documentOnTypeFormattingTriggerCharacters needs to be set if a documentOnTypeFormattingHandler is set" + | otherwise = Nothing + + executeCommandProvider + | isJust $ executeCommandHandler h + , Just cmds <- executeCommandCommands o = Just (J.ExecuteCommandOptions (J.List cmds)) + | isJust $ executeCommandHandler h + , Nothing <- executeCommandCommands o = + error "executeCommandCommands needs to be set if a executeCommandHandler is set" + | otherwise = 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 + progressCancelHandler :: TVar (LanguageContextData config) -> J.WorkDoneProgressCancelNotification -> IO () progressCancelHandler tvarCtx (J.NotificationMessage _ _ (J.WorkDoneProgressCancelParams tid)) = do mact <- Map.lookup tid . progressCancel . resProgressData <$> readTVarIO tvarCtx @@ -916,28 +986,29 @@ -- 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 + join $ atomically $ do + ctx <- readTVar tvarDat + let ds = updateDiagnostics (resDiagnostics ctx) uri version diags + writeTVar tvarDat $ ctx{resDiagnostics = ds} + let mdp = getDiagnosticParamsFor maxDiagnosticCount ds uri + return $ case mdp of + Nothing -> return () + Just params -> + 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 +flushDiagnosticsBySource tvarDat maxDiagnosticCount msource = join $ atomically $ do -- logs $ "haskell-lsp:flushDiagnosticsBySource:source=" ++ show source - ctx <- readTVarIO tvarDat + ctx <- readTVar tvarDat let ds = flushBySource (resDiagnostics ctx) msource - atomically $ writeTVar tvarDat $ ctx {resDiagnostics = ds} + writeTVar tvarDat $ ctx {resDiagnostics = ds} -- Send the updated diagnostics to the client - forM_ (Map.keys ds) $ \uri -> do + return $ forM_ (Map.keys ds) $ \uri -> do -- logs $ "haskell-lsp:flushDiagnosticsBySource:uri=" ++ show uri let mdp = getDiagnosticParamsFor maxDiagnosticCount ds uri case mdp of 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 @@ -4,6 +4,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} {-| Handles the "Language.Haskell.LSP.Types.TextDocumentDidChange" \/ @@ -14,13 +15,15 @@ -} module Language.Haskell.LSP.VFS ( - VFS + VFS(..) , VirtualFile(..) + , initVFS , openVFS , changeFromClientVFS , changeFromServerVFS , persistFileVFS , closeVFS + , updateVFS -- * manipulating the file contents , rangeLinesFromVfs @@ -40,10 +43,6 @@ import qualified Data.Text as T import Data.List import Data.Ord -#if __GLASGOW_HASKELL__ < 804 -import Data.Monoid -#endif -import System.IO.Temp import qualified Data.HashMap.Strict as HashMap import qualified Data.Map as Map import Data.Maybe @@ -52,6 +51,10 @@ import qualified Language.Haskell.LSP.Types as J import qualified Language.Haskell.LSP.Types.Lens as J import Language.Haskell.LSP.Utility +import System.FilePath +import Data.Hashable +import System.Directory +import System.IO.Temp -- --------------------------------------------------------------------- {-# ANN module ("hlint: ignore Eta reduce" :: String) #-} @@ -62,35 +65,50 @@ VirtualFile { _version :: Int , _text :: Rope - , _tmp_file :: Maybe FilePath } deriving (Show) -type VFS = Map.Map J.NormalizedUri VirtualFile +type VFSMap = Map.Map J.NormalizedUri VirtualFile +data VFS = VFS { vfsMap :: Map.Map J.NormalizedUri VirtualFile + , vfsTempDir :: FilePath -- ^ This is where all the temporary files will be written to + } deriving Show + +--- + +initVFS :: (VFS -> IO r) -> IO r +initVFS k = withSystemTempDirectory "haskell-lsp" $ \temp_dir -> k (VFS mempty temp_dir) + -- --------------------------------------------------------------------- -openVFS :: VFS -> J.DidOpenTextDocumentNotification -> IO VFS -openVFS vfs (J.NotificationMessage _ _ params) = do +openVFS :: VFS -> J.DidOpenTextDocumentNotification -> (VFS, [String]) +openVFS vfs (J.NotificationMessage _ _ params) = let J.DidOpenTextDocumentParams (J.TextDocumentItem uri _ version text) = params - return $ Map.insert (J.toNormalizedUri uri) (VirtualFile version (Rope.fromText text) Nothing) vfs + in (updateVFS (Map.insert (J.toNormalizedUri uri) (VirtualFile version (Rope.fromText text))) vfs + , []) + -- --------------------------------------------------------------------- -changeFromClientVFS :: VFS -> J.DidChangeTextDocumentNotification -> IO VFS -changeFromClientVFS vfs (J.NotificationMessage _ _ params) = do +changeFromClientVFS :: VFS -> J.DidChangeTextDocumentNotification -> (VFS,[String]) +changeFromClientVFS vfs (J.NotificationMessage _ _ params) = let J.DidChangeTextDocumentParams vid (J.List changes) = params J.VersionedTextDocumentIdentifier (J.toNormalizedUri -> uri) version = vid - case Map.lookup uri vfs of - Just (VirtualFile _ str _) -> do - let str' = applyChanges str changes - -- the client shouldn't be sending over a null version, only the server. - return $ Map.insert uri (VirtualFile (fromMaybe 0 version) str' Nothing) vfs - Nothing -> do - logs $ "haskell-lsp:changeVfs:can't find uri:" ++ show uri - return vfs + in + case Map.lookup uri (vfsMap vfs) of + Just (VirtualFile _ str) -> + let str' = applyChanges str changes + -- the client shouldn't be sending over a null version, only the server. + in (updateVFS (Map.insert uri (VirtualFile (fromMaybe 0 version) str')) vfs, []) + Nothing -> + -- logs $ "haskell-lsp:changeVfs:can't find uri:" ++ show uri + -- return vfs + (vfs, ["haskell-lsp:changeVfs:can't find uri:" ++ show uri]) +updateVFS :: (VFSMap -> VFSMap) -> VFS -> VFS +updateVFS f vfs@VFS{vfsMap} = vfs { vfsMap = f vfsMap } + -- --------------------------------------------------------------------- changeFromServerVFS :: VFS -> J.ApplyWorkspaceEditRequest -> IO VFS @@ -110,8 +128,11 @@ changeToTextDocumentEdit acc uri edits = acc ++ [J.TextDocumentEdit (J.VersionedTextDocumentIdentifier uri (Just 0)) edits] + -- applyEdits :: [J.TextDocumentEdit] -> VFS + applyEdits :: [J.TextDocumentEdit] -> IO VFS applyEdits = foldM f initVfs . sortOn (^. J.textDocument . J.version) + f :: VFS -> J.TextDocumentEdit -> IO VFS 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 @@ -119,29 +140,34 @@ changeEvents = map editToChangeEvent sortedEdits ps = J.DidChangeTextDocumentParams vid (J.List changeEvents) notif = J.NotificationMessage "" J.TextDocumentDidChange ps - changeFromClientVFS vfs notif + let (vfs',ls) = changeFromClientVFS vfs notif + mapM_ logs ls + return vfs' editToChangeEvent (J.TextEdit range text) = J.TextDocumentContentChangeEvent (Just range) Nothing text -- --------------------------------------------------------------------- +virtualFileName :: FilePath -> J.NormalizedUri -> VirtualFile -> FilePath +virtualFileName prefix uri (VirtualFile ver _) = + prefix show (hash (J.fromNormalizedUri uri)) ++ "-" ++ show ver ++ ".hs" -persistFileVFS :: VFS -> J.NormalizedUri -> IO (FilePath, VFS) +persistFileVFS :: VFS -> J.NormalizedUri -> (FilePath, IO ()) persistFileVFS vfs uri = - case Map.lookup uri vfs of + case Map.lookup uri (vfsMap vfs) of Nothing -> error ("File not found in VFS: " ++ show uri ++ show vfs) - Just (VirtualFile v txt tfile) -> - case tfile of - Just tfn -> return (tfn, vfs) - Nothing -> do - fn <- writeSystemTempFile "VFS.hs" (Rope.toString txt) - return (fn, Map.insert uri (VirtualFile v txt (Just fn)) vfs) + Just vf@(VirtualFile _v txt) -> + let tfn = virtualFileName (vfsTempDir vfs) uri vf + action = do + exists <- doesFileExist tfn + unless exists (writeFile tfn (Rope.toString txt)) + in (tfn, action) -- --------------------------------------------------------------------- -closeVFS :: VFS -> J.DidCloseTextDocumentNotification -> IO VFS -closeVFS vfs (J.NotificationMessage _ _ params) = do +closeVFS :: VFS -> J.DidCloseTextDocumentNotification -> (VFS, [String]) +closeVFS vfs (J.NotificationMessage _ _ params) = let J.DidCloseTextDocumentParams (J.TextDocumentIdentifier uri) = params - return $ Map.delete (J.toNormalizedUri uri) vfs + in (updateVFS (Map.delete (J.toNormalizedUri uri)) vfs,[]) -- --------------------------------------------------------------------- {- @@ -208,7 +234,7 @@ } deriving (Show,Eq) getCompletionPrefix :: (Monad m) => J.Position -> VirtualFile -> m (Maybe PosPrefixInfo) -getCompletionPrefix pos@(J.Position l c) (VirtualFile _ yitext _) = +getCompletionPrefix pos@(J.Position l c) (VirtualFile _ ropetext) = return $ Just $ fromMaybe (PosPrefixInfo "" "" "" pos) $ do -- Maybe monad let headMaybe [] = Nothing headMaybe (x:_) = Just x @@ -216,7 +242,7 @@ lastMaybe xs = Just $ last xs curLine <- headMaybe $ T.lines $ Rope.toText - $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine l yitext + $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine l ropetext let beforePos = T.take c curLine curWord <- case T.last beforePos of ' ' -> return "" -- don't count abc as the curword in 'abc ' @@ -235,10 +261,9 @@ -- --------------------------------------------------------------------- rangeLinesFromVfs :: VirtualFile -> J.Range -> T.Text -rangeLinesFromVfs (VirtualFile _ yitext _) (J.Range (J.Position lf _cf) (J.Position lt _ct)) = r +rangeLinesFromVfs (VirtualFile _ ropetext) (J.Range (J.Position lf _cf) (J.Position lt _ct)) = r where - (_ ,s1) = Rope.splitAtLine lf yitext + (_ ,s1) = Rope.splitAtLine lf ropetext (s2, _) = Rope.splitAtLine (lt - lf) s1 r = Rope.toText s2 - -- --------------------------------------------------------------------- diff --git a/test/InitialConfigurationSpec.hs b/test/InitialConfigurationSpec.hs --- a/test/InitialConfigurationSpec.hs +++ b/test/InitialConfigurationSpec.hs @@ -8,12 +8,13 @@ import Data.Default import Language.Haskell.LSP.Core import Language.Haskell.LSP.Types +import Language.Haskell.LSP.VFS import Language.Haskell.LSP.Types.Capabilities import Test.Hspec spec :: Spec spec = - describe "initial configuration" $ it "stores initial configuration data" $ do + describe "initial configuration" $ it "stores initial configuration data" $ initVFS $ \vfs -> do lfVar <- newEmptyMVar @@ -40,6 +41,7 @@ tvarLspId (const $ return ()) Nothing + vfs let putMsg msg = let jsonStr = encode msg in handleMessage initCb tvarCtx jsonStr diff --git a/test/JsonSpec.hs b/test/JsonSpec.hs --- a/test/JsonSpec.hs +++ b/test/JsonSpec.hs @@ -96,6 +96,7 @@ , ServerNotInitialized , UnknownErrorCode , RequestCancelled + , ContentModified ] -- | make lists of maximum length 3 for test performance diff --git a/test/VspSpec.hs b/test/VspSpec.hs --- a/test/VspSpec.hs +++ b/test/VspSpec.hs @@ -31,7 +31,7 @@ mkRange ls cs le ce = Just $ J.Range (J.Position ls cs) (J.Position le ce) vfsFromText :: T.Text -> VirtualFile -vfsFromText text = VirtualFile 0 (Rope.fromText text) Nothing +vfsFromText text = VirtualFile 0 (Rope.fromText text) -- --------------------------------------------------------------------- diff --git a/test/WorkspaceFoldersSpec.hs b/test/WorkspaceFoldersSpec.hs --- a/test/WorkspaceFoldersSpec.hs +++ b/test/WorkspaceFoldersSpec.hs @@ -8,12 +8,13 @@ import Data.Default import Language.Haskell.LSP.Core import Language.Haskell.LSP.Types +import Language.Haskell.LSP.VFS import Language.Haskell.LSP.Types.Capabilities import Test.Hspec spec :: Spec spec = - describe "workspace folders" $ it "keeps track of open workspace folders" $ do + describe "workspace folders" $ it "keeps track of open workspace folders" $ initVFS $ \vfs -> do lfVar <- newEmptyMVar @@ -31,6 +32,7 @@ tvarLspId (const $ return ()) Nothing + vfs let putMsg msg = let jsonStr = encode msg