diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # Revision history for lsp +## 2.3.0.0 + +- Fix inference of server capabilities for newer methods (except notebook methods). +- VFS no longer requires IO to initialize, functions that wrote to a temporary directory + now take the directory as an argument. + ## 2.2.0.0 - Many changes relating to client configuration diff --git a/example/Reactor.hs b/example/Reactor.hs --- a/example/Reactor.hs +++ b/example/Reactor.hs @@ -1,13 +1,12 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeInType #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} - +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeInType #-} -- So we can keep using the old prettyprinter modules (which have a better -- compatibility range) for now. {-# OPTIONS_GHC -Wno-deprecations #-} @@ -28,35 +27,35 @@ -} module Main (main) where -import Colog.Core (LogAction (..), WithSeverity (..), Severity (..), (<&)) -import qualified Colog.Core as L -import Control.Concurrent.STM.TChan -import qualified Control.Exception as E -import Control.Lens hiding (Iso) -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.STM -import qualified Data.Aeson as J -import Data.Int (Int32) -import qualified Data.Text as T -import Data.Text.Prettyprint.Doc -import GHC.Generics (Generic) -import Language.LSP.Server -import System.IO -import Language.LSP.Diagnostics -import Language.LSP.Logging (defaultClientLogger) -import qualified Language.LSP.Protocol.Types as LSP -import qualified Language.LSP.Protocol.Lens as LSP -import qualified Language.LSP.Protocol.Message as LSP -import Language.LSP.VFS -import System.Exit -import Control.Concurrent - +import Colog.Core (LogAction (..), Severity (..), WithSeverity (..), (<&)) +import Colog.Core qualified as L +import Control.Concurrent +import Control.Concurrent.STM.TChan +import Control.Exception qualified as E +import Control.Lens hiding (Iso) +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.STM +import Data.Aeson qualified as J +import Data.Int (Int32) +import Data.Text qualified as T +import Data.Text.Prettyprint.Doc +import GHC.Generics (Generic) +import Language.LSP.Diagnostics +import Language.LSP.Logging (defaultClientLogger) +import Language.LSP.Protocol.Lens qualified as LSP +import Language.LSP.Protocol.Message qualified as LSP +import Language.LSP.Protocol.Types qualified as LSP +import Language.LSP.Server +import Language.LSP.VFS +import System.Exit +import System.IO -- --------------------------------------------------------------------- -{-# ANN module ("HLint: ignore Eta reduce" :: String) #-} -{-# ANN module ("HLint: ignore Redundant do" :: String) #-} +{-# ANN module ("HLint: ignore Eta reduce" :: String) #-} +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} + -- --------------------------------------------------------------------- -- @@ -68,13 +67,12 @@ -- --------------------------------------------------------------------- -data Config = Config { fooTheBar :: Bool, wibbleFactor :: Int } +data Config = Config {fooTheBar :: Bool, wibbleFactor :: Int} deriving (Generic, J.ToJSON, J.FromJSON, Show) run :: IO Int run = flip E.catches handlers $ do - - rin <- atomically newTChan :: IO (TChan ReactorInput) + rin <- atomically newTChan :: IO (TChan ReactorInput) let -- Three loggers: @@ -88,54 +86,57 @@ dualLogger :: LogAction (LspM Config) (WithSeverity T.Text) dualLogger = clientLogger <> L.hoistLogAction liftIO stderrLogger - serverDefinition = ServerDefinition - { defaultConfig = Config {fooTheBar = False, wibbleFactor = 0 } - , parseConfig = \_old v -> do - case J.fromJSON v of - J.Error e -> Left (T.pack e) - J.Success cfg -> Right cfg - , onConfigChange = const $ pure () - , configSection = "demo" - , doInitialize = \env _ -> forkIO (reactor stderrLogger rin) >> pure (Right env) - -- Handlers log to both the client and stderr - , staticHandlers = \_caps -> lspHandlers dualLogger rin - , interpretHandler = \env -> Iso (runLspT env) liftIO - , options = lspOptions - } + serverDefinition = + ServerDefinition + { defaultConfig = Config{fooTheBar = False, wibbleFactor = 0} + , parseConfig = \_old v -> do + case J.fromJSON v of + J.Error e -> Left (T.pack e) + J.Success cfg -> Right cfg + , onConfigChange = const $ pure () + , configSection = "demo" + , doInitialize = \env _ -> forkIO (reactor stderrLogger rin) >> pure (Right env) + , -- Handlers log to both the client and stderr + staticHandlers = \_caps -> lspHandlers dualLogger rin + , interpretHandler = \env -> Iso (runLspT env) liftIO + , options = lspOptions + } let logToText = T.pack . show . pretty runServerWithHandles - -- Log to both the client and stderr when we can, stderr beforehand + -- Log to both the client and stderr when we can, stderr beforehand (L.cmap (fmap logToText) stderrLogger) (L.cmap (fmap logToText) dualLogger) stdin stdout serverDefinition - - where - handlers = [ E.Handler ioExcept - , E.Handler someExcept - ] - ioExcept (e :: E.IOException) = print e >> return 1 - someExcept (e :: E.SomeException) = print e >> return 1 + where + handlers = + [ E.Handler ioExcept + , E.Handler someExcept + ] + ioExcept (e :: E.IOException) = print e >> return 1 + someExcept (e :: E.SomeException) = print e >> return 1 -- --------------------------------------------------------------------- syncOptions :: LSP.TextDocumentSyncOptions -syncOptions = LSP.TextDocumentSyncOptions - { LSP._openClose = Just True - , LSP._change = Just LSP.TextDocumentSyncKind_Incremental - , LSP._willSave = Just False - , LSP._willSaveWaitUntil = Just False - , LSP._save = Just $ LSP.InR $ LSP.SaveOptions $ Just False - } +syncOptions = + LSP.TextDocumentSyncOptions + { LSP._openClose = Just True + , LSP._change = Just LSP.TextDocumentSyncKind_Incremental + , LSP._willSave = Just False + , LSP._willSaveWaitUntil = Just False + , LSP._save = Just $ LSP.InR $ LSP.SaveOptions $ Just False + } lspOptions :: Options -lspOptions = defaultOptions - { optTextDocumentSync = Just syncOptions - , optExecuteCommandCommands = Just ["lsp-hello-command"] - } +lspOptions = + defaultOptions + { optTextDocumentSync = Just syncOptions + , optExecuteCommandCommands = Just ["lsp-hello-command"] + } -- --------------------------------------------------------------------- @@ -146,29 +147,32 @@ newtype ReactorInput = ReactorAction (IO ()) --- | Analyze the file and send any diagnostics to the client in a --- "textDocument/publishDiagnostics" notification +{- | Analyze the file and send any diagnostics to the client in a + "textDocument/publishDiagnostics" notification +-} sendDiagnostics :: LSP.NormalizedUri -> Maybe Int32 -> LspM Config () sendDiagnostics fileUri version = do let - diags = [LSP.Diagnostic - (LSP.Range (LSP.Position 0 1) (LSP.Position 0 5)) - (Just LSP.DiagnosticSeverity_Warning) -- severity - Nothing -- code - Nothing - (Just "lsp-hello") -- source - "Example diagnostic message" - Nothing -- tags - (Just []) - Nothing - ] + diags = + [ LSP.Diagnostic + (LSP.Range (LSP.Position 0 1) (LSP.Position 0 5)) + (Just LSP.DiagnosticSeverity_Warning) -- severity + Nothing -- code + Nothing + (Just "lsp-hello") -- source + "Example diagnostic message" + Nothing -- tags + (Just []) + Nothing + ] publishDiagnostics 100 fileUri version (partitionBySource diags) -- --------------------------------------------------------------------- --- | The single point that all events flow through, allowing management of state --- to stitch replies and requests together from the two asynchronous sides: lsp --- server and backend compiler +{- | The single point that all events flow through, allowing management of state + to stitch replies and requests together from the two asynchronous sides: lsp + server and backend compiler +-} reactor :: L.LogAction IO (WithSeverity T.Text) -> TChan ReactorInput -> IO () reactor logger inp = do logger <& "Started the reactor" `WithSeverity` Info @@ -176,143 +180,143 @@ ReactorAction act <- atomically $ readTChan inp act --- | Check if we have a handler, and if we create a haskell-lsp handler to pass it as --- input into the reactor +{- | Check if we have a handler, and if we create a haskell-lsp handler to pass it as + input into the reactor +-} lspHandlers :: (m ~ LspM Config) => L.LogAction m (WithSeverity T.Text) -> TChan ReactorInput -> Handlers m lspHandlers logger rin = mapHandlers goReq goNot (handle logger) - where - goReq :: forall (a :: LSP.Method LSP.ClientToServer LSP.Request). Handler (LspM Config) a -> Handler (LspM Config) a - goReq f = \msg k -> do - env <- getLspEnv - liftIO $ atomically $ writeTChan rin $ ReactorAction (runLspT env $ f msg k) + where + goReq :: forall (a :: LSP.Method LSP.ClientToServer LSP.Request). Handler (LspM Config) a -> Handler (LspM Config) a + goReq f = \msg k -> do + env <- getLspEnv + liftIO $ atomically $ writeTChan rin $ ReactorAction (runLspT env $ f msg k) - goNot :: forall (a :: LSP.Method LSP.ClientToServer LSP.Notification). Handler (LspM Config) a -> Handler (LspM Config) a - goNot f = \msg -> do - env <- getLspEnv - liftIO $ atomically $ writeTChan rin $ ReactorAction (runLspT env $ f msg) + goNot :: forall (a :: LSP.Method LSP.ClientToServer LSP.Notification). Handler (LspM Config) a -> Handler (LspM Config) a + goNot f = \msg -> do + env <- getLspEnv + liftIO $ atomically $ writeTChan rin $ ReactorAction (runLspT env $ f msg) -- | Where the actual logic resides for handling requests and notifications. handle :: (m ~ LspM Config) => L.LogAction m (WithSeverity T.Text) -> Handlers m -handle logger = mconcat - [ notificationHandler LSP.SMethod_Initialized $ \_msg -> do - logger <& "Processing the Initialized notification" `WithSeverity` Info - - -- We're initialized! Lets send a showMessageRequest now - let params = LSP.ShowMessageRequestParams - LSP.MessageType_Warning - "What's your favourite language extension?" - (Just [LSP.MessageActionItem "Rank2Types", LSP.MessageActionItem "NPlusKPatterns"]) - - void $ sendRequest LSP.SMethod_WindowShowMessageRequest params $ \res -> - case res of - Left e -> logger <& ("Got an error: " <> T.pack (show e)) `WithSeverity` Error - Right _ -> do - sendNotification LSP.SMethod_WindowShowMessage (LSP.ShowMessageParams LSP.MessageType_Info "Excellent choice") - - -- We can dynamically register a capability once the user accepts it - sendNotification LSP.SMethod_WindowShowMessage (LSP.ShowMessageParams LSP.MessageType_Info "Turning on code lenses dynamically") - - let regOpts = LSP.CodeLensRegistrationOptions (LSP.InR LSP.Null) Nothing (Just False) - - void $ registerCapability LSP.SMethod_TextDocumentCodeLens regOpts $ \_req responder -> do - logger <& "Processing a textDocument/codeLens request" `WithSeverity` Info - let cmd = LSP.Command "Say hello" "lsp-hello-command" Nothing - rsp = [LSP.CodeLens (LSP.mkRange 0 0 0 100) (Just cmd) Nothing] - responder (Right $ LSP.InL rsp) - - , notificationHandler LSP.SMethod_TextDocumentDidOpen $ \msg -> do - let doc = msg ^. LSP.params . LSP.textDocument . LSP.uri - fileName = LSP.uriToFilePath doc - logger <& ("Processing DidOpenTextDocument for: " <> T.pack (show fileName)) `WithSeverity` Info - sendDiagnostics (LSP.toNormalizedUri doc) (Just 0) - - , notificationHandler LSP.SMethod_WorkspaceDidChangeConfiguration $ \msg -> do - cfg <- getConfig - logger L.<& ("Configuration changed: " <> T.pack (show (msg,cfg))) `WithSeverity` Info - sendNotification LSP.SMethod_WindowShowMessage $ - LSP.ShowMessageParams LSP.MessageType_Info $ "Wibble factor set to " <> T.pack (show (wibbleFactor cfg)) - - , notificationHandler LSP.SMethod_TextDocumentDidChange $ \msg -> do - let doc = msg ^. LSP.params - . LSP.textDocument - . LSP.uri - . to LSP.toNormalizedUri - logger <& ("Processing DidChangeTextDocument for: " <> T.pack (show doc)) `WithSeverity` Info - mdoc <- getVirtualFile doc - case mdoc of - Just (VirtualFile _version str _) -> do - logger <& ("Found the virtual file: " <> T.pack (show str)) `WithSeverity` Info - Nothing -> do - logger <& ("Didn't find anything in the VFS for: " <> T.pack (show doc)) `WithSeverity` Info - - , notificationHandler LSP.SMethod_TextDocumentDidSave $ \msg -> do - let doc = msg ^. LSP.params . LSP.textDocument . LSP.uri - fileName = LSP.uriToFilePath doc - logger <& ("Processing DidSaveTextDocument for: " <> T.pack (show fileName)) `WithSeverity` Info - sendDiagnostics (LSP.toNormalizedUri doc) Nothing - - , requestHandler LSP.SMethod_TextDocumentRename $ \req responder -> do - logger <& "Processing a textDocument/rename request" `WithSeverity` Info - let params = req ^. LSP.params - LSP.Position l c = params ^. LSP.position - newName = params ^. LSP.newName - vdoc <- getVersionedTextDoc (params ^. LSP.textDocument) - -- Replace some text at the position with what the user entered - let edit = LSP.InL $ LSP.TextEdit (LSP.mkRange l c l (c + fromIntegral (T.length newName))) newName - tde = LSP.TextDocumentEdit (LSP._versionedTextDocumentIdentifier # vdoc) [edit] - -- "documentChanges" field is preferred over "changes" - rsp = LSP.WorkspaceEdit Nothing (Just [LSP.InL tde]) Nothing - responder (Right $ LSP.InL rsp) +handle logger = + mconcat + [ notificationHandler LSP.SMethod_Initialized $ \_msg -> do + logger <& "Processing the Initialized notification" `WithSeverity` Info - , requestHandler LSP.SMethod_TextDocumentHover $ \req responder -> do - logger <& "Processing a textDocument/hover request" `WithSeverity` Info - let LSP.HoverParams _doc pos _workDone = req ^. LSP.params - LSP.Position _l _c' = pos - rsp = LSP.Hover ms (Just range) - ms = LSP.InL $ LSP.mkMarkdown "Your type info here!" - range = LSP.Range pos pos - responder (Right $ LSP.InL rsp) + -- We're initialized! Lets send a showMessageRequest now + let params = + LSP.ShowMessageRequestParams + LSP.MessageType_Warning + "What's your favourite language extension?" + (Just [LSP.MessageActionItem "Rank2Types", LSP.MessageActionItem "NPlusKPatterns"]) - , requestHandler LSP.SMethod_TextDocumentDocumentSymbol $ \req responder -> do - logger <& "Processing a textDocument/documentSymbol request" `WithSeverity` Info - let LSP.DocumentSymbolParams _ _ doc = req ^. LSP.params - loc = LSP.Location (doc ^. LSP.uri) (LSP.Range (LSP.Position 0 0) (LSP.Position 0 0)) - rsp = [LSP.SymbolInformation "lsp-hello" LSP.SymbolKind_Function Nothing Nothing Nothing loc] - responder (Right $ LSP.InL rsp) + void $ sendRequest LSP.SMethod_WindowShowMessageRequest params $ \res -> + case res of + Left e -> logger <& ("Got an error: " <> T.pack (show e)) `WithSeverity` Error + Right _ -> do + sendNotification LSP.SMethod_WindowShowMessage (LSP.ShowMessageParams LSP.MessageType_Info "Excellent choice") - , requestHandler LSP.SMethod_TextDocumentCodeAction $ \req responder -> do - logger <& "Processing a textDocument/codeAction request" `WithSeverity` Info - let params = req ^. LSP.params - doc = params ^. LSP.textDocument - diags = params ^. LSP.context . LSP.diagnostics - -- makeCommand only generates commands for diagnostics whose source is us - makeCommand d | (LSP.Range s _) <- d ^. LSP.range, (Just "lsp-hello") <- d ^. LSP.source = - let - title = "Apply LSP hello command:" <> head (T.lines $ d ^. LSP.message) - -- NOTE: the cmd needs to be registered via the InitializeResponse message. See lspOptions above - cmd = "lsp-hello-command" - -- need 'file' and 'start_pos' - args = [ J.object [("file", J.object [("textDocument",J.toJSON doc)])] - , J.object [("start_pos",J.object [("position", J.toJSON s)])] - ] - cmdparams = Just args - in [LSP.Command title cmd cmdparams] - makeCommand _ = [] - rsp = map LSP.InL $ concatMap makeCommand diags - responder (Right $ LSP.InL rsp) + -- We can dynamically register a capability once the user accepts it + sendNotification LSP.SMethod_WindowShowMessage (LSP.ShowMessageParams LSP.MessageType_Info "Turning on code lenses dynamically") - , requestHandler LSP.SMethod_WorkspaceExecuteCommand $ \req responder -> do - logger <& "Processing a workspace/executeCommand request" `WithSeverity` Info - let params = req ^. LSP.params - margs = params ^. LSP.arguments + let regOpts = LSP.CodeLensRegistrationOptions (LSP.InR LSP.Null) Nothing (Just False) - logger <& ("The arguments are: " <> T.pack (show margs)) `WithSeverity` Debug - responder (Right $ LSP.InL (J.Object mempty)) -- respond to the request + void $ registerCapability LSP.SMethod_TextDocumentCodeLens regOpts $ \_req responder -> do + logger <& "Processing a textDocument/codeLens request" `WithSeverity` Info + let cmd = LSP.Command "Say hello" "lsp-hello-command" Nothing + rsp = [LSP.CodeLens (LSP.mkRange 0 0 0 100) (Just cmd) Nothing] + responder (Right $ LSP.InL rsp) + , notificationHandler LSP.SMethod_TextDocumentDidOpen $ \msg -> do + let doc = msg ^. LSP.params . LSP.textDocument . LSP.uri + fileName = LSP.uriToFilePath doc + logger <& ("Processing DidOpenTextDocument for: " <> T.pack (show fileName)) `WithSeverity` Info + sendDiagnostics (LSP.toNormalizedUri doc) (Just 0) + , notificationHandler LSP.SMethod_WorkspaceDidChangeConfiguration $ \msg -> do + cfg <- getConfig + logger L.<& ("Configuration changed: " <> T.pack (show (msg, cfg))) `WithSeverity` Info + sendNotification LSP.SMethod_WindowShowMessage $ + LSP.ShowMessageParams LSP.MessageType_Info $ + "Wibble factor set to " <> T.pack (show (wibbleFactor cfg)) + , notificationHandler LSP.SMethod_TextDocumentDidChange $ \msg -> do + let doc = + msg + ^. LSP.params + . LSP.textDocument + . LSP.uri + . to LSP.toNormalizedUri + logger <& ("Processing DidChangeTextDocument for: " <> T.pack (show doc)) `WithSeverity` Info + mdoc <- getVirtualFile doc + case mdoc of + Just (VirtualFile _version str _) -> do + logger <& ("Found the virtual file: " <> T.pack (show str)) `WithSeverity` Info + Nothing -> do + logger <& ("Didn't find anything in the VFS for: " <> T.pack (show doc)) `WithSeverity` Info + , notificationHandler LSP.SMethod_TextDocumentDidSave $ \msg -> do + let doc = msg ^. LSP.params . LSP.textDocument . LSP.uri + fileName = LSP.uriToFilePath doc + logger <& ("Processing DidSaveTextDocument for: " <> T.pack (show fileName)) `WithSeverity` Info + sendDiagnostics (LSP.toNormalizedUri doc) Nothing + , requestHandler LSP.SMethod_TextDocumentRename $ \req responder -> do + logger <& "Processing a textDocument/rename request" `WithSeverity` Info + let params = req ^. LSP.params + LSP.Position l c = params ^. LSP.position + newName = params ^. LSP.newName + vdoc <- getVersionedTextDoc (params ^. LSP.textDocument) + -- Replace some text at the position with what the user entered + let edit = LSP.InL $ LSP.TextEdit (LSP.mkRange l c l (c + fromIntegral (T.length newName))) newName + tde = LSP.TextDocumentEdit (LSP._versionedTextDocumentIdentifier # vdoc) [edit] + -- "documentChanges" field is preferred over "changes" + rsp = LSP.WorkspaceEdit Nothing (Just [LSP.InL tde]) Nothing + responder (Right $ LSP.InL rsp) + , requestHandler LSP.SMethod_TextDocumentHover $ \req responder -> do + logger <& "Processing a textDocument/hover request" `WithSeverity` Info + let LSP.HoverParams _doc pos _workDone = req ^. LSP.params + LSP.Position _l _c' = pos + rsp = LSP.Hover ms (Just range) + ms = LSP.InL $ LSP.mkMarkdown "Your type info here!" + range = LSP.Range pos pos + responder (Right $ LSP.InL rsp) + , requestHandler LSP.SMethod_TextDocumentDocumentSymbol $ \req responder -> do + logger <& "Processing a textDocument/documentSymbol request" `WithSeverity` Info + let LSP.DocumentSymbolParams _ _ doc = req ^. LSP.params + loc = LSP.Location (doc ^. LSP.uri) (LSP.Range (LSP.Position 0 0) (LSP.Position 0 0)) + rsp = [LSP.SymbolInformation "lsp-hello" LSP.SymbolKind_Function Nothing Nothing Nothing loc] + responder (Right $ LSP.InL rsp) + , requestHandler LSP.SMethod_TextDocumentCodeAction $ \req responder -> do + logger <& "Processing a textDocument/codeAction request" `WithSeverity` Info + let params = req ^. LSP.params + doc = params ^. LSP.textDocument + diags = params ^. LSP.context . LSP.diagnostics + -- makeCommand only generates commands for diagnostics whose source is us + makeCommand d + | (LSP.Range s _) <- d ^. LSP.range + , (Just "lsp-hello") <- d ^. LSP.source = + let + title = "Apply LSP hello command:" <> head (T.lines $ d ^. LSP.message) + -- NOTE: the cmd needs to be registered via the InitializeResponse message. See lspOptions above + cmd = "lsp-hello-command" + -- need 'file' and 'start_pos' + args = + [ J.object [("file", J.object [("textDocument", J.toJSON doc)])] + , J.object [("start_pos", J.object [("position", J.toJSON s)])] + ] + cmdparams = Just args + in + [LSP.Command title cmd cmdparams] + makeCommand _ = [] + rsp = map LSP.InL $ concatMap makeCommand diags + responder (Right $ LSP.InL rsp) + , requestHandler LSP.SMethod_WorkspaceExecuteCommand $ \req responder -> do + logger <& "Processing a workspace/executeCommand request" `WithSeverity` Info + let params = req ^. LSP.params + margs = params ^. LSP.arguments - void $ withProgress "Executing some long running command" Cancellable $ \update -> - forM [(0 :: LSP.UInt)..10] $ \i -> do - update (ProgressAmount (Just (i * 10)) (Just "Doing stuff")) - liftIO $ threadDelay (1 * 1000000) - ] + logger <& ("The arguments are: " <> T.pack (show margs)) `WithSeverity` Debug + responder (Right $ LSP.InL (J.Object mempty)) -- respond to the request + void $ withProgress "Executing some long running command" Cancellable $ \update -> + forM [(0 :: LSP.UInt) .. 10] $ \i -> do + update (ProgressAmount (Just (i * 10)) (Just "Doing stuff")) + liftIO $ threadDelay (1 * 1000000) + ] -- --------------------------------------------------------------------- diff --git a/example/Simple.hs b/example/Simple.hs --- a/example/Simple.hs +++ b/example/Simple.hs @@ -1,22 +1,26 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} -import Language.LSP.Server -import Language.LSP.Protocol.Types -import Language.LSP.Protocol.Message import Control.Monad.IO.Class -import qualified Data.Text as T +import Data.Text qualified as T +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import Language.LSP.Server handlers :: Handlers (LspM ()) -handlers = mconcat - [ notificationHandler SMethod_Initialized $ \_not -> do - let params = ShowMessageRequestParams MessageType_Info "Turn on code lenses?" - (Just [MessageActionItem "Turn on", MessageActionItem "Don't"]) - _ <- sendRequest SMethod_WindowShowMessageRequest params $ \case +handlers = + mconcat + [ notificationHandler SMethod_Initialized $ \_not -> do + let params = + ShowMessageRequestParams + MessageType_Info + "Turn on code lenses?" + (Just [MessageActionItem "Turn on", MessageActionItem "Don't"]) + _ <- sendRequest SMethod_WindowShowMessageRequest params $ \case Right (InL (MessageActionItem "Turn on")) -> do let regOpts = CodeLensRegistrationOptions (InR Null) Nothing (Just False) - + _ <- registerCapability SMethod_TextDocumentCodeLens regOpts $ \_req responder -> do let cmd = Command "Say hello" "lsp-hello-command" Nothing rsp = [CodeLens (mkRange 0 0 0 100) (Just cmd) Nothing] @@ -26,24 +30,26 @@ sendNotification SMethod_WindowShowMessage (ShowMessageParams MessageType_Info "Not turning on code lenses") Left err -> sendNotification SMethod_WindowShowMessage (ShowMessageParams MessageType_Error $ "Something went wrong!\n" <> T.pack (show err)) - pure () - , requestHandler SMethod_TextDocumentHover $ \req responder -> do - let TRequestMessage _ _ _ (HoverParams _doc pos _workDone) = req - Position _l _c' = pos - rsp = Hover (InL ms) (Just range) - ms = mkMarkdown "Hello world" - range = Range pos pos - responder (Right $ InL rsp) - ] + pure () + , requestHandler SMethod_TextDocumentHover $ \req responder -> do + let TRequestMessage _ _ _ (HoverParams _doc pos _workDone) = req + Position _l _c' = pos + rsp = Hover (InL ms) (Just range) + ms = mkMarkdown "Hello world" + range = Range pos pos + responder (Right $ InL rsp) + ] main :: IO Int -main = runServer $ ServerDefinition - { parseConfig = const $ const $ Right () - , onConfigChange = const $ pure () - , defaultConfig = () - , configSection = "demo" - , doInitialize = \env _req -> pure $ Right env - , staticHandlers = \_caps -> handlers - , interpretHandler = \env -> Iso (runLspT env) liftIO - , options = defaultOptions - } +main = + runServer $ + ServerDefinition + { parseConfig = const $ const $ Right () + , onConfigChange = const $ pure () + , defaultConfig = () + , configSection = "demo" + , doInitialize = \env _req -> pure $ Right env + , staticHandlers = \_caps -> handlers + , interpretHandler = \env -> Iso (runLspT env) liftIO + , options = defaultOptions + } diff --git a/lsp.cabal b/lsp.cabal --- a/lsp.cabal +++ b/lsp.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: lsp -version: 2.2.0.0 +version: 2.3.0.0 synopsis: Haskell library for the Microsoft Language Server Protocol description: An implementation of the types, and basic message server to @@ -29,6 +29,7 @@ library hs-source-dirs: src default-language: Haskell2010 + default-extensions: ImportQualifiedPost ghc-options: -Wall -fprint-explicit-kinds reexported-modules: @@ -64,14 +65,13 @@ , hashable , lens-aeson , lens >=4.15.2 - , lsp-types ^>=2.0.1 + , lsp-types ^>=2.1 , mtl <2.4 , prettyprinter , random , row-types , sorted-list ^>=0.2.1 , stm ^>=2.5 - , temporary , text , text-rope , transformers >=0.5.6 && <0.7 @@ -83,6 +83,7 @@ main-is: Reactor.hs hs-source-dirs: example default-language: Haskell2010 + default-extensions: ImportQualifiedPost ghc-options: -Wall -Wno-unticked-promoted-constructors build-depends: , aeson @@ -102,6 +103,7 @@ main-is: Simple.hs hs-source-dirs: example default-language: Haskell2010 + default-extensions: ImportQualifiedPost ghc-options: -Wall -Wno-unticked-promoted-constructors build-depends: , base @@ -139,3 +141,4 @@ build-tool-depends: hspec-discover:hspec-discover ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall default-language: Haskell2010 + default-extensions: ImportQualifiedPost diff --git a/src/Language/LSP/Diagnostics.hs b/src/Language/LSP/Diagnostics.hs --- a/src/Language/LSP/Diagnostics.hs +++ b/src/Language/LSP/Diagnostics.hs @@ -7,28 +7,28 @@ Manage the "textDocument/publishDiagnostics" notifications to keep a local copy of the diagnostics for a particular file and version, partitioned by source. -} -module Language.LSP.Diagnostics - ( - DiagnosticStore - , DiagnosticsBySource - , StoreItem(..) - , partitionBySource - , flushBySource - , updateDiagnostics - , getDiagnosticParamsFor +module Language.LSP.Diagnostics ( + DiagnosticStore, + DiagnosticsBySource, + StoreItem (..), + partitionBySource, + flushBySource, + updateDiagnostics, + getDiagnosticParamsFor, -- * for tests - ) where +) where -import qualified Data.SortedList as SL -import qualified Data.Map.Strict as Map -import qualified Data.HashMap.Strict as HM +import Data.HashMap.Strict qualified as HM +import Data.Map.Strict qualified as Map +import Data.SortedList qualified as SL import Data.Text (Text) -import qualified Language.LSP.Protocol.Types as J +import Language.LSP.Protocol.Types qualified as J -- --------------------------------------------------------------------- {-# ANN module ("hlint: ignore Eta reduce" :: String) #-} {-# ANN module ("hlint: ignore Redundant do" :: String) #-} + -- --------------------------------------------------------------------- {- @@ -45,7 +45,7 @@ data StoreItem = StoreItem (Maybe J.Int32) DiagnosticsBySource - deriving (Show,Eq) + deriving (Show, Eq) type DiagnosticsBySource = Map.Map (Maybe Text) (SL.SortedList J.Diagnostic) @@ -57,34 +57,37 @@ -- --------------------------------------------------------------------- flushBySource :: DiagnosticStore -> Maybe Text -> DiagnosticStore -flushBySource store Nothing = store +flushBySource store Nothing = store flushBySource store (Just source) = HM.map remove store - where - remove (StoreItem mv diags) = StoreItem mv (Map.delete (Just source) diags) + where + remove (StoreItem mv diags) = StoreItem mv (Map.delete (Just source) diags) -- --------------------------------------------------------------------- -updateDiagnostics :: DiagnosticStore - -> J.NormalizedUri -> Maybe J.Int32 -> DiagnosticsBySource - -> DiagnosticStore +updateDiagnostics :: + DiagnosticStore -> + J.NormalizedUri -> + Maybe J.Int32 -> + DiagnosticsBySource -> + DiagnosticStore updateDiagnostics store uri mv newDiagsBySource = r - where - newStore :: DiagnosticStore - newStore = HM.insert uri (StoreItem mv newDiagsBySource) store + where + newStore :: DiagnosticStore + newStore = HM.insert uri (StoreItem mv newDiagsBySource) store - updateDbs dbs = HM.insert uri new store - where - new = StoreItem mv newDbs - -- note: Map.union is left-biased, so for identical keys the first - -- argument is used - newDbs = Map.union newDiagsBySource dbs + updateDbs dbs = HM.insert uri new store + where + new = StoreItem mv newDbs + -- note: Map.union is left-biased, so for identical keys the first + -- argument is used + newDbs = Map.union newDiagsBySource dbs - r = case HM.lookup uri store of - Nothing -> newStore - Just (StoreItem mvs dbs) -> - if mvs /= mv - then newStore - else updateDbs dbs + r = case HM.lookup uri store of + Nothing -> newStore + Just (StoreItem mvs dbs) -> + if mvs /= mv + then newStore + else updateDbs dbs -- --------------------------------------------------------------------- diff --git a/src/Language/LSP/Logging.hs b/src/Language/LSP/Logging.hs --- a/src/Language/LSP/Logging.hs +++ b/src/Language/LSP/Logging.hs @@ -1,11 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} + module Language.LSP.Logging (logToShowMessage, logToLogMessage, defaultClientLogger) where import Colog.Core -import Language.LSP.Server.Core -import Language.LSP.Protocol.Types -import Language.LSP.Protocol.Message import Data.Text (Text) +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import Language.LSP.Server.Core logSeverityToMessageType :: Severity -> MessageType logSeverityToMessageType sev = case sev of @@ -17,23 +18,26 @@ -- | Logs messages to the client via @window/logMessage@. logToLogMessage :: (MonadLsp c m) => LogAction m (WithSeverity Text) logToLogMessage = LogAction $ \(WithSeverity msg sev) -> do - sendToClient $ fromServerNot $ - TNotificationMessage "2.0" SMethod_WindowLogMessage (LogMessageParams (logSeverityToMessageType sev) msg) + sendToClient $ + fromServerNot $ + TNotificationMessage "2.0" SMethod_WindowLogMessage (LogMessageParams (logSeverityToMessageType sev) msg) -- | Logs messages to the client via @window/showMessage@. logToShowMessage :: (MonadLsp c m) => LogAction m (WithSeverity Text) logToShowMessage = LogAction $ \(WithSeverity msg sev) -> do - sendToClient $ fromServerNot $ - TNotificationMessage "2.0" SMethod_WindowShowMessage (ShowMessageParams (logSeverityToMessageType sev) msg) + sendToClient $ + fromServerNot $ + TNotificationMessage "2.0" SMethod_WindowShowMessage (ShowMessageParams (logSeverityToMessageType sev) msg) --- | A 'sensible' log action for logging messages to the client: --- --- * Shows 'Error' logs to the user via @window/showMessage@ --- * Logs 'Info' and above logs in the client via @window/logMessage@ --- --- If you want finer control (e.g. the ability to log 'Debug' logs based on a flag, or similar), --- then do not use this and write your own based on 'logToShowMessage' and 'logToLogMessage'. +{- | A 'sensible' log action for logging messages to the client: + + * Shows 'Error' logs to the user via @window/showMessage@ + * Logs 'Info' and above logs in the client via @window/logMessage@ + + If you want finer control (e.g. the ability to log 'Debug' logs based on a flag, or similar), + then do not use this and write your own based on 'logToShowMessage' and 'logToLogMessage'. +-} defaultClientLogger :: (MonadLsp c m) => LogAction m (WithSeverity Text) defaultClientLogger = filterBySeverity Error getSeverity logToShowMessage - <> filterBySeverity Info getSeverity logToLogMessage + <> filterBySeverity Info getSeverity logToLogMessage diff --git a/src/Language/LSP/Server.hs b/src/Language/LSP/Server.hs --- a/src/Language/LSP/Server.hs +++ b/src/Language/LSP/Server.hs @@ -1,68 +1,65 @@ {-# LANGUAGE TypeOperators #-} -module Language.LSP.Server - ( module Language.LSP.Server.Control - , VFSData(..) - , ServerDefinition(..) - -- * Handlers - , Handlers(..) - , Handler - , transmuteHandlers - , mapHandlers - , notificationHandler - , requestHandler - , ClientMessageHandler(..) +module Language.LSP.Server ( + module Language.LSP.Server.Control, + VFSData (..), + ServerDefinition (..), - , Options(..) - , defaultOptions + -- * Handlers + Handlers (..), + Handler, + transmuteHandlers, + mapHandlers, + notificationHandler, + requestHandler, + ClientMessageHandler (..), + Options (..), + defaultOptions, -- * LspT and LspM - , LspT(..) - , LspM - , MonadLsp(..) - , runLspT - , LanguageContextEnv(..) - , type (<~>)(..) - - , getClientCapabilities - , getConfig - , setConfig - , getRootPath - , getWorkspaceFolders - - , sendRequest - , sendNotification + LspT (..), + LspM, + MonadLsp (..), + runLspT, + LanguageContextEnv (..), + type (<~>) (..), + getClientCapabilities, + getConfig, + setConfig, + getRootPath, + getWorkspaceFolders, + sendRequest, + sendNotification, -- * Config - , requestConfigUpdate - , tryChangeConfig + requestConfigUpdate, + tryChangeConfig, -- * VFS - , getVirtualFile - , getVirtualFiles - , persistVirtualFile - , getVersionedTextDoc - , reverseFileMap - , snapshotVirtualFiles + getVirtualFile, + getVirtualFiles, + persistVirtualFile, + getVersionedTextDoc, + reverseFileMap, + snapshotVirtualFiles, -- * Diagnostics - , publishDiagnostics - , flushDiagnosticsBySource + publishDiagnostics, + flushDiagnosticsBySource, -- * Progress - , withProgress - , withIndefiniteProgress - , ProgressAmount(..) - , ProgressCancellable(..) - , ProgressCancelledException + withProgress, + withIndefiniteProgress, + ProgressAmount (..), + ProgressCancellable (..), + ProgressCancelledException, -- * Dynamic registration - , registerCapability - , unregisterCapability - , RegistrationToken - - , reverseSortEdit - ) where + registerCapability, + unregisterCapability, + RegistrationToken, + reverseSortEdit, +) where import Language.LSP.Server.Control import Language.LSP.Server.Core diff --git a/src/Language/LSP/Server/Control.hs b/src/Language/LSP/Server/Control.hs --- a/src/Language/LSP/Server/Control.hs +++ b/src/Language/LSP/Server/Control.hs @@ -1,48 +1,47 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE LambdaCase #-} - +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} -- So we can keep using the old prettyprinter modules (which have a better -- compatibility range) for now. {-# OPTIONS_GHC -Wno-deprecations #-} -module Language.LSP.Server.Control - ( +module Language.LSP.Server.Control ( -- * Running - runServer - , runServerWith - , runServerWithHandles - , LspServerLog (..) - ) where + runServer, + runServerWith, + runServerWithHandles, + LspServerLog (..), +) where -import qualified Colog.Core as L -import Colog.Core (LogAction (..), WithSeverity (..), Severity (..), (<&)) -import Control.Concurrent -import Control.Concurrent.STM.TChan -import Control.Monad -import Control.Monad.STM -import Control.Monad.IO.Class -import qualified Data.Aeson as J -import qualified Data.Attoparsec.ByteString as Attoparsec +import Colog.Core (LogAction (..), Severity (..), WithSeverity (..), (<&)) +import Colog.Core qualified as L +import Control.Applicative ((<|>)) +import Control.Concurrent +import Control.Concurrent.STM.TChan +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.STM +import Data.Aeson qualified as J +import Data.Attoparsec.ByteString qualified as Attoparsec import Data.Attoparsec.ByteString.Char8 -import qualified Data.ByteString as BS +import Data.ByteString qualified as BS import Data.ByteString.Builder.Extra (defaultChunkSize) -import qualified Data.ByteString.Lazy as BSL -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TL -import qualified Data.Text as T -import Data.Text.Prettyprint.Doc -import Data.List -import Language.LSP.Server.Core -import qualified Language.LSP.Server.Processing as Processing -import Language.LSP.Protocol.Message -import Language.LSP.VFS +import Data.ByteString.Lazy qualified as BSL +import Data.List +import Data.Text qualified as T +import Data.Text.Lazy qualified as TL +import Data.Text.Lazy.Encoding qualified as TL +import Data.Text.Prettyprint.Doc import Language.LSP.Logging (defaultClientLogger) -import System.IO +import Language.LSP.Protocol.Message +import Language.LSP.Server.Core +import Language.LSP.Server.Processing qualified as Processing +import Language.LSP.VFS +import System.IO -data LspServerLog = - LspProcessingLog Processing.LspProcessingLog +data LspServerLog + = LspProcessingLog Processing.LspProcessingLog | DecodeInitializeError String | HeaderParseFail [String] String | EOF @@ -54,13 +53,13 @@ instance Pretty LspServerLog where pretty (LspProcessingLog l) = pretty l pretty (DecodeInitializeError err) = - vsep [ - "Got error while decoding initialize:" + vsep + [ "Got error while decoding initialize:" , pretty err ] pretty (HeaderParseFail ctxs err) = - vsep [ - "Failed to parse message header:" + vsep + [ "Failed to parse message header:" , pretty (intercalate " > " ctxs) <> ": " <+> pretty err ] pretty EOF = "Got EOF" @@ -70,46 +69,47 @@ -- --------------------------------------------------------------------- --- | Convenience function for 'runServerWithHandles' which: --- (1) reads from stdin; --- (2) writes to stdout; and --- (3) logs to stderr and to the client, with some basic filtering. -runServer :: forall config . ServerDefinition config -> IO Int +{- | Convenience function for 'runServerWithHandles' which: + (1) reads from stdin; + (2) writes to stdout; and + (3) logs to stderr and to the client, with some basic filtering. +-} +runServer :: forall config. ServerDefinition config -> IO Int runServer = runServerWithHandles - ioLogger - lspLogger - stdin - stdout - where - prettyMsg l = "[" <> viaShow (L.getSeverity l) <> "] " <> pretty (L.getMsg l) - ioLogger :: LogAction IO (WithSeverity LspServerLog) - ioLogger = L.cmap (show . prettyMsg) L.logStringStderr - lspLogger :: LogAction (LspM config) (WithSeverity LspServerLog) - lspLogger = - let clientLogger = L.cmap (fmap (T.pack . show . pretty)) defaultClientLogger - in clientLogger <> L.hoistLogAction liftIO ioLogger + ioLogger + lspLogger + stdin + stdout + where + prettyMsg l = "[" <> viaShow (L.getSeverity l) <> "] " <> pretty (L.getMsg l) + ioLogger :: LogAction IO (WithSeverity LspServerLog) + ioLogger = L.cmap (show . prettyMsg) L.logStringStderr + lspLogger :: LogAction (LspM config) (WithSeverity LspServerLog) + lspLogger = + let clientLogger = L.cmap (fmap (T.pack . show . pretty)) defaultClientLogger + in clientLogger <> L.hoistLogAction liftIO ioLogger --- | Starts a language server over the specified handles. --- This function will return once the @exit@ notification is received. +{- | Starts a language server over the specified handles. + This function will return once the @exit@ notification is received. +-} runServerWithHandles :: - LogAction IO (WithSeverity LspServerLog) - -- ^ The logger to use outside the main body of the server where we can't assume the ability to send messages. - -> LogAction (LspM config) (WithSeverity LspServerLog) - -- ^ The logger to use once the server has started and can successfully send messages. - -> Handle - -- ^ Handle to read client input from. - -> Handle - -- ^ Handle to write output to. - -> ServerDefinition config - -> IO Int -- exit code + -- | The logger to use outside the main body of the server where we can't assume the ability to send messages. + LogAction IO (WithSeverity LspServerLog) -> + -- | The logger to use once the server has started and can successfully send messages. + LogAction (LspM config) (WithSeverity LspServerLog) -> + -- | Handle to read client input from. + Handle -> + -- | Handle to write output to. + Handle -> + ServerDefinition config -> + IO Int -- exit code runServerWithHandles ioLogger logger hin hout serverDefinition = do - hSetBuffering hin NoBuffering - hSetEncoding hin utf8 + hSetEncoding hin utf8 hSetBuffering hout NoBuffering - hSetEncoding hout utf8 + hSetEncoding hout utf8 let clientIn = BS.hGetSome hin defaultChunkSize @@ -120,21 +120,21 @@ runServerWith ioLogger logger clientIn clientOut serverDefinition --- | Starts listening and sending requests and responses --- using the specified I/O. +{- | Starts listening and sending requests and responses + using the specified I/O. +-} runServerWith :: - LogAction IO (WithSeverity LspServerLog) - -- ^ The logger to use outside the main body of the server where we can't assume the ability to send messages. - -> LogAction (LspM config) (WithSeverity LspServerLog) - -- ^ The logger to use once the server has started and can successfully send messages. - -> IO BS.ByteString - -- ^ Client input. - -> (BSL.ByteString -> IO ()) - -- ^ Function to provide output to. - -> ServerDefinition config - -> IO Int -- exit code + -- | The logger to use outside the main body of the server where we can't assume the ability to send messages. + LogAction IO (WithSeverity LspServerLog) -> + -- | The logger to use once the server has started and can successfully send messages. + LogAction (LspM config) (WithSeverity LspServerLog) -> + -- | Client input. + IO BS.ByteString -> + -- | Function to provide output to. + (BSL.ByteString -> IO ()) -> + ServerDefinition config -> + IO Int -- exit code runServerWith ioLogger logger clientIn clientOut serverDefinition = do - ioLogger <& Starting `WithSeverity` Info cout <- atomically newTChan :: IO (TChan J.Value) @@ -142,27 +142,26 @@ let sendMsg msg = atomically $ writeTChan cout $ J.toJSON msg - initVFS $ \vfs -> do - ioLoop ioLogger logger clientIn serverDefinition vfs sendMsg + ioLoop ioLogger logger clientIn serverDefinition emptyVFS sendMsg return 1 -- --------------------------------------------------------------------- ioLoop :: - forall config - . LogAction IO (WithSeverity LspServerLog) - -> LogAction (LspM config) (WithSeverity LspServerLog) - -> IO BS.ByteString - -> ServerDefinition config - -> VFS - -> (FromServerMessage -> IO ()) - -> IO () + forall config. + LogAction IO (WithSeverity LspServerLog) -> + LogAction (LspM config) (WithSeverity LspServerLog) -> + IO BS.ByteString -> + ServerDefinition config -> + VFS -> + (FromServerMessage -> IO ()) -> + IO () ioLoop ioLogger logger clientIn serverDefinition vfs sendMsg = do minitialize <- parseOne ioLogger clientIn (parse parser "") case minitialize of Nothing -> pure () - Just (msg,remainder) -> do + Just (msg, remainder) -> do case J.eitherDecode $ BSL.fromStrict msg of Left err -> ioLogger <& DecodeInitializeError err `WithSeverity` Error Right initialize -> do @@ -170,51 +169,63 @@ case mInitResp of Nothing -> pure () Just env -> runLspT env $ loop (parse parser remainder) - where + where + pioLogger = L.cmap (fmap LspProcessingLog) ioLogger + pLogger = L.cmap (fmap LspProcessingLog) logger - pioLogger = L.cmap (fmap LspProcessingLog) ioLogger - pLogger = L.cmap (fmap LspProcessingLog) logger + loop :: Result BS.ByteString -> LspM config () + loop = go + where + go r = do + res <- parseOne logger clientIn r + case res of + Nothing -> pure () + Just (msg, remainder) -> do + Processing.processMessage pLogger $ BSL.fromStrict msg + go (parse parser remainder) - loop :: Result BS.ByteString -> LspM config () - loop = go - where - go r = do - res <- parseOne logger clientIn r - case res of - Nothing -> pure () - Just (msg,remainder) -> do - Processing.processMessage pLogger $ BSL.fromStrict msg - go (parse parser remainder) + parser = do + try contentType <|> (return ()) + len <- contentLength + try contentType <|> (return ()) + _ <- string _ONE_CRLF + Attoparsec.take len - parser = do - _ <- string "Content-Length: " - len <- decimal - _ <- string _TWO_CRLF - Attoparsec.take len + contentLength = do + _ <- string "Content-Length: " + len <- decimal + _ <- string _ONE_CRLF + return len + contentType = do + _ <- string "Content-Type: " + skipWhile (/= '\r') + _ <- string _ONE_CRLF + return () + parseOne :: - MonadIO m - => LogAction m (WithSeverity LspServerLog) - -> IO BS.ByteString - -> Result BS.ByteString - -> m (Maybe (BS.ByteString,BS.ByteString)) + MonadIO m => + LogAction m (WithSeverity LspServerLog) -> + IO BS.ByteString -> + Result BS.ByteString -> + m (Maybe (BS.ByteString, BS.ByteString)) parseOne logger clientIn = go - where - go (Fail _ ctxs err) = do - logger <& HeaderParseFail ctxs err `WithSeverity` Error - pure Nothing - go (Partial c) = do - bs <- liftIO clientIn - if BS.null bs - then do - logger <& EOF `WithSeverity` Error - pure Nothing - else go (c bs) - go (Done remainder msg) = do - -- TODO: figure out how to re-enable - -- This can lead to infinite recursion in logging, see https://github.com/haskell/lsp/issues/447 - -- logger <& ParsedMsg (T.decodeUtf8 msg) `WithSeverity` Debug - pure $ Just (msg,remainder) + where + go (Fail _ ctxs err) = do + logger <& HeaderParseFail ctxs err `WithSeverity` Error + pure Nothing + go (Partial c) = do + bs <- liftIO clientIn + if BS.null bs + then do + logger <& EOF `WithSeverity` Error + pure Nothing + else go (c bs) + go (Done remainder msg) = do + -- TODO: figure out how to re-enable + -- This can lead to infinite recursion in logging, see https://github.com/haskell/lsp/issues/447 + -- logger <& ParsedMsg (T.decodeUtf8 msg) `WithSeverity` Debug + pure $ Just (msg, remainder) -- --------------------------------------------------------------------- @@ -228,20 +239,20 @@ -- and no other tags/wrapper stuff let str = J.encode msg - let out = BSL.concat - [ TL.encodeUtf8 $ TL.pack $ "Content-Length: " ++ show (BSL.length str) - , BSL.fromStrict _TWO_CRLF - , str ] + let out = + BSL.concat + [ TL.encodeUtf8 $ TL.pack $ "Content-Length: " ++ show (BSL.length str) + , BSL.fromStrict _TWO_CRLF + , str + ] clientOut out - -- TODO: figure out how to re-enable - -- This can lead to infinite recursion in logging, see https://github.com/haskell/lsp/issues/447 - -- logger <& SendMsg (TL.decodeUtf8 str) `WithSeverity` Debug --- | --- --- +-- TODO: figure out how to re-enable +-- This can lead to infinite recursion in logging, see https://github.com/haskell/lsp/issues/447 +-- logger <& SendMsg (TL.decodeUtf8 str) `WithSeverity` Debug + +_ONE_CRLF :: BS.ByteString +_ONE_CRLF = "\r\n" _TWO_CRLF :: BS.ByteString _TWO_CRLF = "\r\n\r\n" - - diff --git a/src/Language/LSP/Server/Core.hs b/src/Language/LSP/Server/Core.hs --- a/src/Language/LSP/Server/Core.hs +++ b/src/Language/LSP/Server/Core.hs @@ -1,93 +1,100 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE BinaryLiterals #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE TypeInType #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} {-# OPTIONS_GHC -fprint-explicit-kinds #-} module Language.LSP.Server.Core where -import Colog.Core (LogAction (..), - Severity (..), - WithSeverity (..), - (<&)) -import Control.Concurrent.Async -import Control.Concurrent.STM -import qualified Control.Exception as E -import Control.Lens (_Just, at, (^.), (^?)) -import Control.Monad -import Control.Monad.Catch (MonadCatch, MonadMask, - MonadThrow) -import Control.Monad.Fix -import Control.Monad.IO.Class -import Control.Monad.IO.Unlift -import Control.Monad.Trans.Class -import Control.Monad.Trans.Identity -import Control.Monad.Trans.Reader -import qualified Data.Aeson as J -import Data.Default -import Data.Functor.Product -import qualified Data.HashMap.Strict as HM -import Data.IxMap -import Data.Kind -import qualified Data.List as L -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.Map.Strict as Map -import Data.Maybe -import Data.Monoid (Ap (..)) -import Data.Ord (Down (Down)) -import Data.Row -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.UUID as UUID -import Language.LSP.Diagnostics -import qualified Language.LSP.Protocol.Lens as L -import Language.LSP.Protocol.Message -import qualified Language.LSP.Protocol.Message as L -import Language.LSP.Protocol.Types -import qualified Language.LSP.Protocol.Types as L -import Language.LSP.Protocol.Utils.SMethodMap (SMethodMap) -import qualified Language.LSP.Protocol.Utils.SMethodMap as SMethodMap -import Language.LSP.Protocol.Utils.Misc (prettyJSON) -import Language.LSP.VFS -import Prettyprinter -import System.Random hiding (next) +import Colog.Core ( + LogAction (..), + Severity (..), + WithSeverity (..), + (<&), + ) +import Control.Concurrent.Async +import Control.Concurrent.STM +import Control.Exception qualified as E +import Control.Lens (at, (^.), (^?), _Just) +import Control.Monad +import Control.Monad.Catch ( + MonadCatch, + MonadMask, + MonadThrow, + ) +import Control.Monad.Fix +import Control.Monad.IO.Class +import Control.Monad.IO.Unlift +import Control.Monad.Trans.Class +import Control.Monad.Trans.Identity +import Control.Monad.Trans.Reader +import Data.Aeson qualified as J +import Data.Default +import Data.Functor.Product +import Data.HashMap.Strict qualified as HM +import Data.IxMap +import Data.Kind +import Data.List qualified as L +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map.Strict qualified as Map +import Data.Maybe +import Data.Monoid (Ap (..)) +import Data.Ord (Down (Down)) +import Data.Row +import Data.Text (Text) +import Data.Text qualified as T +import Data.UUID qualified as UUID +import Language.LSP.Diagnostics +import Language.LSP.Protocol.Capabilities +import Language.LSP.Protocol.Lens qualified as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Message qualified as L +import Language.LSP.Protocol.Types +import Language.LSP.Protocol.Types qualified as L +import Language.LSP.Protocol.Utils.Misc (prettyJSON) +import Language.LSP.Protocol.Utils.SMethodMap (SMethodMap) +import Language.LSP.Protocol.Utils.SMethodMap qualified as SMethodMap +import Language.LSP.VFS +import Prettyprinter +import System.Random hiding (next) -- --------------------------------------------------------------------- -{-# ANN module ("HLint: ignore Eta reduce" :: String) #-} -{-# ANN module ("HLint: ignore Redundant do" :: String) #-} +{-# ANN module ("HLint: ignore Eta reduce" :: String) #-} +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} + -- --------------------------------------------------------------------- -data LspCoreLog = - -- TODO: arguably it would be nicer to have the config object itself in there, but - -- then we're going to need 'Pretty config' constraints everywhere - NewConfig J.Value +data LspCoreLog + = -- TODO: arguably it would be nicer to have the config object itself in there, but + -- then we're going to need 'Pretty config' constraints everywhere + NewConfig J.Value | ConfigurationParseError J.Value T.Text | ConfigurationNotSupported | BadConfigurationResponse ResponseError | WrongConfigSections [J.Value] - deriving Show + deriving (Show) instance Pretty LspCoreLog where pretty (NewConfig config) = "LSP: set new config:" <+> prettyJSON config pretty (ConfigurationNotSupported) = "LSP: not requesting configuration since the client does not support workspace/configuration" pretty (ConfigurationParseError settings err) = - vsep [ - "LSP: configuration parse error:" + vsep + [ "LSP: configuration parse error:" , pretty err , "when parsing" , prettyJSON settings @@ -95,7 +102,7 @@ pretty (BadConfigurationResponse err) = "LSP: error when requesting configuration: " <+> pretty err pretty (WrongConfigSections sections) = "LSP: expected only one configuration section, got: " <+> (prettyJSON $ J.toJSON sections) -newtype LspT config m a = LspT { unLspT :: ReaderT (LanguageContextEnv config) m a } +newtype LspT config m a = LspT {unLspT :: ReaderT (LanguageContextEnv config) m a} deriving (Functor, Applicative, Monad, MonadCatch, MonadIO, MonadMask, MonadThrow, MonadTrans, MonadUnliftIO, MonadFix) deriving (Semigroup, Monoid) via (Ap (LspT config m) a) @@ -104,7 +111,6 @@ runLspT :: LanguageContextEnv config -> LspT config m a -> m a runLspT env = flip runReaderT env . unLspT - {-# INLINE runLspT #-} type LspM config = LspT config IO @@ -125,38 +131,38 @@ instance MonadLsp c m => MonadLsp c (IdentityT m) where getLspEnv = lift getLspEnv -data LanguageContextEnv config = - LanguageContextEnv - { resHandlers :: !(Handlers IO) - , resConfigSection :: T.Text - , resParseConfig :: !(config -> J.Value -> Either T.Text config) - , resOnConfigChange :: !(config -> IO ()) - , resSendMessage :: !(FromServerMessage -> IO ()) - -- We keep the state in a TVar to be thread safe - , resState :: !(LanguageContextState config) +data LanguageContextEnv config = LanguageContextEnv + { resHandlers :: !(Handlers IO) + , resConfigSection :: T.Text + , resParseConfig :: !(config -> J.Value -> Either T.Text config) + , resOnConfigChange :: !(config -> IO ()) + , resSendMessage :: !(FromServerMessage -> IO ()) + , -- We keep the state in a TVar to be thread safe + resState :: !(LanguageContextState config) , resClientCapabilities :: !L.ClientCapabilities - , resRootPath :: !(Maybe FilePath) + , resRootPath :: !(Maybe FilePath) } -- --------------------------------------------------------------------- -- Handlers -- --------------------------------------------------------------------- --- | A mapping from methods to the static 'Handler's that should be used to --- handle responses when they come in from the client. To build up a 'Handlers', --- you should 'mconcat' a list of 'notificationHandler' and 'requestHandler's: --- --- @ --- mconcat [ --- notificationHandler SInitialized $ \notif -> pure () --- , requestHandler STextDocumentHover $ \req responder -> pure () --- ] --- @ -data Handlers m - = Handlers +{- | A mapping from methods to the static 'Handler's that should be used to + handle responses when they come in from the client. To build up a 'Handlers', + you should 'mconcat' a list of 'notificationHandler' and 'requestHandler's: + + @ + mconcat [ + notificationHandler SInitialized $ \notif -> pure () + , requestHandler STextDocumentHover $ \req responder -> pure () + ] + @ +-} +data Handlers m = Handlers { reqHandlers :: !(SMethodMap (ClientMessageHandler m Request)) , notHandlers :: !(SMethodMap (ClientMessageHandler m Notification)) } + instance Semigroup (Handlers config) where Handlers r1 n1 <> Handlers r2 n2 = Handlers (r1 <> r2) (n1 <> n2) instance Monoid (Handlers config) where @@ -171,43 +177,43 @@ -- | Wrapper to restrict 'Handler's to ClientToServer' 'Method's newtype ClientMessageHandler f (t :: MessageKind) (m :: Method ClientToServer t) = ClientMessageHandler (Handler f m) --- | The type of a handler that handles requests and notifications coming in --- from the server or client +{- | The type of a handler that handles requests and notifications coming in + from the server or client +-} type family Handler (f :: Type -> Type) (m :: Method from t) = (result :: Type) | result -> f t m where - Handler f (m :: Method _from Request) = TRequestMessage m -> (Either ResponseError (MessageResult m) -> f ()) -> f () + Handler f (m :: Method _from Request) = TRequestMessage m -> (Either ResponseError (MessageResult m) -> f ()) -> f () Handler f (m :: Method _from Notification) = TNotificationMessage m -> f () -- | How to convert two isomorphic data structures between each other. -data m <~> n - = Iso - { forward :: forall a. m a -> n a +data m <~> n = Iso + { forward :: forall a. m a -> n a , backward :: forall a. n a -> m a } transmuteHandlers :: (m <~> n) -> Handlers m -> Handlers n transmuteHandlers nat = mapHandlers (\i m k -> forward nat (i m (backward nat . k))) (\i m -> forward nat (i m)) -mapHandlers - :: (forall (a :: Method ClientToServer Request). Handler m a -> Handler n a) - -> (forall (a :: Method ClientToServer Notification). Handler m a -> Handler n a) - -> Handlers m -> Handlers n +mapHandlers :: + (forall (a :: Method ClientToServer Request). Handler m a -> Handler n a) -> + (forall (a :: Method ClientToServer Notification). Handler m a -> Handler n a) -> + Handlers m -> + Handlers n mapHandlers mapReq mapNot (Handlers reqs nots) = Handlers reqs' nots' - where - reqs' = SMethodMap.map (\(ClientMessageHandler i) -> ClientMessageHandler $ mapReq i) reqs - nots' = SMethodMap.map (\(ClientMessageHandler i) -> ClientMessageHandler $ mapNot i) nots + where + reqs' = SMethodMap.map (\(ClientMessageHandler i) -> ClientMessageHandler $ mapReq i) reqs + nots' = SMethodMap.map (\(ClientMessageHandler i) -> ClientMessageHandler $ mapNot i) nots -- | state used by the LSP dispatcher to manage the message loop -data LanguageContextState config = - LanguageContextState - { resVFS :: !(TVar VFSData) - , resDiagnostics :: !(TVar DiagnosticStore) - , resConfig :: !(TVar config) +data LanguageContextState config = LanguageContextState + { resVFS :: !(TVar VFSData) + , resDiagnostics :: !(TVar DiagnosticStore) + , resConfig :: !(TVar config) , resWorkspaceFolders :: !(TVar [WorkspaceFolder]) - , resProgressData :: !ProgressData + , resProgressData :: !ProgressData , resPendingResponses :: !(TVar ResponseMap) , resRegistrationsNot :: !(TVar (RegistrationMap Notification)) , resRegistrationsReq :: !(TVar (RegistrationMap Request)) - , resLspId :: !(TVar Int32) + , resLspId :: !(TVar Int32) } type ResponseMap = IxMap LspId (Product SMethod ServerResponseCallback) @@ -216,16 +222,17 @@ data RegistrationToken (m :: Method ClientToServer t) = RegistrationToken (SMethod m) (RegistrationId m) newtype RegistrationId (m :: Method ClientToServer t) = RegistrationId Text - deriving Eq + deriving (Eq) -data ProgressData = ProgressData { progressNextId :: !(TVar Int32) - , progressCancel :: !(TVar (Map.Map ProgressToken (IO ()))) } +data ProgressData = ProgressData + { progressNextId :: !(TVar Int32) + , progressCancel :: !(TVar (Map.Map ProgressToken (IO ()))) + } -data VFSData = - VFSData - { vfsData :: !VFS - , reverseMap :: !(Map.Map FilePath FilePath) - } +data VFSData = VFSData + { vfsData :: !VFS + , reverseMap :: !(Map.Map FilePath FilePath) + } {-# INLINE modifyState #-} modifyState :: MonadLsp config m => (LanguageContextState config -> TVar a) -> (a -> a) -> m () @@ -234,7 +241,7 @@ liftIO $ atomically $ modifyTVar' tvarDat f {-# INLINE stateState #-} -stateState :: MonadLsp config m => (LanguageContextState config -> TVar s) -> (s -> (a,s)) -> m a +stateState :: MonadLsp config m => (LanguageContextState config -> TVar s) -> (s -> (a, s)) -> m a stateState sel f = do tvarDat <- sel . resState <$> getLspEnv liftIO $ atomically $ stateTVar tvarDat f @@ -247,133 +254,149 @@ -- --------------------------------------------------------------------- --- | 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 - { optTextDocumentSync :: Maybe L.TextDocumentSyncOptions - -- | The characters that trigger completion automatically. - , optCompletionTriggerCharacters :: Maybe [Char] - -- | The list of all possible characters that commit a completion. This field can be used - -- if clients don't support individual commit characters per completion item. See - -- `_commitCharactersSupport`. - , optCompletionAllCommitCharacters :: Maybe [Char] - -- | The characters that trigger signature help automatically. - , optSignatureHelpTriggerCharacters :: 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. - , optSignatureHelpRetriggerCharacters :: 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. - , optCodeActionKinds :: Maybe [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. - , optDocumentOnTypeFormattingTriggerCharacters :: Maybe (NonEmpty Char) - -- | The commands to be executed on the server. - -- If you set `executeCommandHandler`, you **must** set this. - , optExecuteCommandCommands :: Maybe [Text] - -- | Information about the server that can be advertised to the client. - , optServerInfo :: Maybe (Rec ("name" .== Text .+ "version" .== Maybe Text)) - } +{- | 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 + { optTextDocumentSync :: Maybe L.TextDocumentSyncOptions + , optCompletionTriggerCharacters :: Maybe [Char] + -- ^ The characters that trigger completion automatically. + , optCompletionAllCommitCharacters :: Maybe [Char] + -- ^ The list of all possible characters that commit a completion. This field can be used + -- if clients don't support individual commit characters per completion item. See + -- `_commitCharactersSupport`. + , optSignatureHelpTriggerCharacters :: Maybe [Char] + -- ^ The characters that trigger signature help automatically. + , optSignatureHelpRetriggerCharacters :: 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. + , optCodeActionKinds :: Maybe [CodeActionKind] + -- ^ 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. + , optDocumentOnTypeFormattingTriggerCharacters :: Maybe (NonEmpty Char) + -- ^ 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. + , optExecuteCommandCommands :: Maybe [Text] + -- ^ The commands to be executed on the server. + -- If you set `executeCommandHandler`, you **must** set this. + , optServerInfo :: Maybe (Rec ("name" .== Text .+ "version" .== Maybe Text)) + -- ^ Information about the server that can be advertised to the client. + } instance Default Options where - def = Options Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing + def = + Options + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing defaultOptions :: Options defaultOptions = def --- | A package indicating the percentage of progress complete and a --- an optional message to go with it during a 'withProgress' --- --- @since 0.10.0.0 +{- | A package indicating the percentage of progress complete and a + an optional message to go with it during a 'withProgress' + + @since 0.10.0.0 +-} data ProgressAmount = ProgressAmount (Maybe UInt) (Maybe Text) --- | Thrown if the user cancels a 'Cancellable' 'withProgress'/'withIndefiniteProgress'/ session --- --- @since 0.11.0.0 +{- | Thrown if the user cancels a 'Cancellable' 'withProgress'/'withIndefiniteProgress'/ session + + @since 0.11.0.0 +-} data ProgressCancelledException = ProgressCancelledException - deriving Show + 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 +{- | Whether or not the user should be able to cancel a 'withProgress'/'withIndefiniteProgress' + session + + @since 0.11.0.0 +-} data ProgressCancellable = Cancellable | NotCancellable -- See Note [LSP configuration] for discussion of the configuration-related fields --- | 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. + +{- | 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 ServerDefinition config = forall m a. ServerDefinition - { defaultConfig :: config - -- ^ The default value we initialize the config variable to. - , configSection :: T.Text - -- ^ The "config section" that this server uses. This is used to identify the settings - -- that are relevant to the server. - , parseConfig :: config -> J.Value -> Either T.Text config - -- ^ @parseConfig oldConfig newConfigObject@ is called whenever we - -- get updated configuration from the client. - -- - -- @parseConfig@ is called on the object corresponding to the server's - -- config section, it should not itself try to look for the config section. - -- - -- Note that the 'J.Value' may represent only a partial object in the case where we - -- are handling a @workspace/didChangeConfiguration@ request where the client sends - -- only the changed settings. This is also the main circumstance where the old configuration - -- argument is useful. It is generally fine for servers to ignore this case and just - -- assume that the 'J.Value' represents a full new config and ignore the old configuration. - -- This will only be problematic in the case of clients which behave as above and *also* - -- don't support @workspace/configuration@, which is discouraged. - -- - , onConfigChange :: config -> m () - -- ^ This callback is called any time the configuration is updated, with - -- the new config. Servers that want to react to config changes should provide - -- a callback here, it is not sufficient to just add e.g. a @workspace/didChangeConfiguration@ - -- handler. - , doInitialize :: LanguageContextEnv config -> TMessage Method_Initialize -> IO (Either ResponseError a) - -- ^ Called *after* receiving the @initialize@ request and *before* - -- returning the response. This callback will be invoked to offer the - -- language server implementation the chance to create any processes or - -- start new threads that may be necessary for the server lifecycle. It can - -- also return an error in the initialization if necessary. - , staticHandlers :: ClientCapabilities -> Handlers m - -- ^ Handlers for any methods you want to statically support. - -- The handlers here cannot be unregistered during the server's lifetime - -- and will be registered statically in the initialize request. - -- The handlers provided can depend on the client capabilities, which - -- are static across the lifetime of the server. - , interpretHandler :: a -> (m <~> IO) - -- ^ How to run the handlers in your own monad of choice, @m@. - -- It is passed the result of 'doInitialize', so typically you will want - -- to thread along the 'LanguageContextEnv' as well as any other state you - -- need to run your monad. @m@ should most likely be built on top of - -- 'LspT'. - -- - -- @ - -- ServerDefinition { ... - -- , doInitialize = \env _req -> pure $ Right env - -- , interpretHandler = \env -> Iso - -- (runLspT env) -- how to convert from IO ~> m - -- liftIO -- how to convert from m ~> IO - -- } - -- @ - , options :: Options - -- ^ Configurable options for the server's capabilities. - } + { defaultConfig :: config + -- ^ The default value we initialize the config variable to. + , configSection :: T.Text + -- ^ The "config section" that this server uses. This is used to identify the settings + -- that are relevant to the server. + , parseConfig :: config -> J.Value -> Either T.Text config + -- ^ @parseConfig oldConfig newConfigObject@ is called whenever we + -- get updated configuration from the client. + -- + -- @parseConfig@ is called on the object corresponding to the server's + -- config section, it should not itself try to look for the config section. + -- + -- Note that the 'J.Value' may represent only a partial object in the case where we + -- are handling a @workspace/didChangeConfiguration@ request where the client sends + -- only the changed settings. This is also the main circumstance where the old configuration + -- argument is useful. It is generally fine for servers to ignore this case and just + -- assume that the 'J.Value' represents a full new config and ignore the old configuration. + -- This will only be problematic in the case of clients which behave as above and *also* + -- don't support @workspace/configuration@, which is discouraged. + , onConfigChange :: config -> m () + -- ^ This callback is called any time the configuration is updated, with + -- the new config. Servers that want to react to config changes should provide + -- a callback here, it is not sufficient to just add e.g. a @workspace/didChangeConfiguration@ + -- handler. + , doInitialize :: LanguageContextEnv config -> TMessage Method_Initialize -> IO (Either ResponseError a) + -- ^ Called *after* receiving the @initialize@ request and *before* + -- returning the response. This callback will be invoked to offer the + -- language server implementation the chance to create any processes or + -- start new threads that may be necessary for the server lifecycle. It can + -- also return an error in the initialization if necessary. + , staticHandlers :: ClientCapabilities -> Handlers m + -- ^ Handlers for any methods you want to statically support. + -- The handlers here cannot be unregistered during the server's lifetime + -- and will be registered statically in the initialize request. + -- The handlers provided can depend on the client capabilities, which + -- are static across the lifetime of the server. + , interpretHandler :: a -> (m <~> IO) + -- ^ How to run the handlers in your own monad of choice, @m@. + -- It is passed the result of 'doInitialize', so typically you will want + -- to thread along the 'LanguageContextEnv' as well as any other state you + -- need to run your monad. @m@ should most likely be built on top of + -- 'LspT'. + -- + -- @ + -- ServerDefinition { ... + -- , doInitialize = \env _req -> pure $ Right env + -- , interpretHandler = \env -> Iso + -- (runLspT env) -- how to convert from IO ~> m + -- liftIO -- how to convert from m ~> IO + -- } + -- @ + , options :: Options + -- ^ Configurable options for the server's capabilities. + } --- | A function that a 'Handler' is passed that can be used to respond to a --- request with either an error, or the response params. +{- | A function that a 'Handler' is passed that can be used to respond to a + request with either an error, or the response params. +-} newtype ServerResponseCallback (m :: Method ServerToClient Request) = ServerResponseCallback (Either ResponseError (MessageResult m) -> IO ()) --- | Return value signals if response handler was inserted successfully --- Might fail if the id was already in the map +{- | Return value signals if response handler was inserted successfully + Might fail if the id was already in the map +-} addResponseHandler :: MonadLsp config f => LspId m -> (Product SMethod ServerResponseCallback) m -> f Bool addResponseHandler lid h = do stateState resPendingResponses $ \pending -> @@ -381,22 +404,25 @@ Just !m -> (True, m) Nothing -> (False, pending) -sendNotification - :: forall (m :: Method ServerToClient Notification) f config. MonadLsp config f - => SServerMethod m - -> MessageParams m - -> f () +sendNotification :: + forall (m :: Method ServerToClient Notification) f config. + MonadLsp config f => + SServerMethod m -> + MessageParams m -> + f () sendNotification m params = let msg = TNotificationMessage "2.0" m params - in case splitServerMethod m of - IsServerNot -> sendToClient $ fromServerNot msg + in case splitServerMethod m of + IsServerNot -> sendToClient $ fromServerNot msg IsServerEither -> sendToClient $ FromServerMess m $ NotMess msg -sendRequest :: forall (m :: Method ServerToClient Request) f config. MonadLsp config f - => SServerMethod m - -> MessageParams m - -> (Either ResponseError (MessageResult m) -> f ()) - -> f (LspId m) +sendRequest :: + forall (m :: Method ServerToClient Request) f config. + MonadLsp config f => + SServerMethod m -> + MessageParams m -> + (Either ResponseError (MessageResult m) -> f ()) -> + f (LspId m) sendRequest m params resHandler = do reqId <- IdInt <$> freshLspId rio <- askRunInIO @@ -405,7 +431,7 @@ let msg = TRequestMessage "2.0" reqId m params ~() <- case splitServerMethod m of - IsServerReq -> sendToClient $ fromServerReq msg + IsServerReq -> sendToClient $ fromServerReq msg IsServerEither -> sendToClient $ FromServerMess m $ ReqMess msg return reqId @@ -416,39 +442,36 @@ getVirtualFile uri = do dat <- vfsData <$> getsState resVFS pure $ dat ^. vfsMap . at uri - {-# INLINE getVirtualFile #-} getVirtualFiles :: MonadLsp config m => m VFS getVirtualFiles = vfsData <$> getsState resVFS - {-# INLINE getVirtualFiles #-} -- | Take an atomic snapshot of the current state of the virtual file system. snapshotVirtualFiles :: LanguageContextEnv c -> STM VFS snapshotVirtualFiles env = vfsData <$> readTVar (resVFS $ resState env) - {-# INLINE snapshotVirtualFiles #-} - --- | Dump the current text for a given VFS file to a temporary file, --- and return the path to the file. -persistVirtualFile :: MonadLsp config m => LogAction m (WithSeverity VfsLog) -> NormalizedUri -> m (Maybe FilePath) -persistVirtualFile logger uri = do +{- | Dump the current text for a given VFS file to a file + in the given directory and return the path to the file. +-} +persistVirtualFile :: MonadLsp config m => LogAction m (WithSeverity VfsLog) -> FilePath -> NormalizedUri -> m (Maybe FilePath) +persistVirtualFile logger dir uri = do join $ stateState resVFS $ \vfs -> - case persistFileVFS logger (vfsData vfs) uri of + case persistFileVFS logger dir (vfsData vfs) uri of Nothing -> (return Nothing, vfs) Just (fn, write) -> let !revMap = case uriToFilePath (fromNormalizedUri uri) of Just uri_fp -> Map.insert fn uri_fp $ reverseMap vfs -- TODO: Does the VFS make sense for URIs which are not files? -- The reverse map should perhaps be (FilePath -> URI) - Nothing -> reverseMap vfs - !vfs' = vfs {reverseMap = revMap} + Nothing -> reverseMap vfs + !vfs' = vfs{reverseMap = revMap} act = do write pure (Just fn) - in (act, vfs') + in (act, vfs') -- | Given a text document identifier, annotate it with the latest version. getVersionedTextDoc :: MonadLsp config m => TextDocumentIdentifier -> m VersionedTextDocumentIdentifier @@ -457,20 +480,20 @@ mvf <- getVirtualFile (toNormalizedUri uri) let ver = case mvf of Just (VirtualFile lspver _ _) -> lspver - Nothing -> 0 + Nothing -> 0 return (VersionedTextDocumentIdentifier uri ver) - {-# INLINE getVersionedTextDoc #-} -- 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. + +{- | If the contents of a VFS has been dumped to a temporary file, map + the temporary file name back to the original one. +-} reverseFileMap :: MonadLsp config m => m (FilePath -> FilePath) reverseFileMap = do vfs <- getsState resVFS let f fp = fromMaybe fp . Map.lookup fp . reverseMap $ vfs return f - {-# INLINE reverseFileMap #-} -- --------------------------------------------------------------------- @@ -479,7 +502,6 @@ sendToClient msg = do f <- resSendMessage <$> getLspEnv liftIO $ f msg - {-# INLINE sendToClient #-} -- --------------------------------------------------------------------- @@ -487,33 +509,29 @@ freshLspId :: MonadLsp config m => m Int32 freshLspId = do stateState resLspId $ \cur -> - let !next = cur+1 in (cur, next) - + let !next = cur + 1 in (cur, next) {-# INLINE freshLspId #-} -- --------------------------------------------------------------------- --- | The current configuration from the client as set via the @initialize@ and --- @workspace/didChangeConfiguration@ requests, as well as by calls to --- 'setConfig'. +{- | The current configuration from the client as set via the @initialize@ and + @workspace/didChangeConfiguration@ requests, as well as by calls to + 'setConfig'. +-} getConfig :: MonadLsp config m => m config getConfig = getsState resConfig - {-# INLINE getConfig #-} setConfig :: MonadLsp config m => config -> m () setConfig config = stateState resConfig (const ((), config)) - {-# INLINE setConfig #-} getClientCapabilities :: MonadLsp config m => m L.ClientCapabilities getClientCapabilities = resClientCapabilities <$> getLspEnv - {-# INLINE getClientCapabilities #-} getRootPath :: MonadLsp config m => m (Maybe FilePath) getRootPath = resRootPath <$> getLspEnv - {-# INLINE getRootPath #-} -- | The current workspace folders, if the client supports workspace folders. @@ -524,101 +542,63 @@ if clientSupportsWfs then Just <$> getsState resWorkspaceFolders else pure Nothing - {-# INLINE getWorkspaceFolders #-} --- | Sends a @client/registerCapability@ request and dynamically registers --- a 'Method' with a 'Handler'. Returns 'Nothing' if the client does not --- support dynamic registration for the specified method, otherwise a --- 'RegistrationToken' which can be used to unregister it later. -registerCapability :: forall f t (m :: Method ClientToServer t) config. - MonadLsp config f - => SClientMethod m - -> RegistrationOptions m - -> Handler f m - -> f (Maybe (RegistrationToken m)) +{- | Sends a @client/registerCapability@ request and dynamically registers + a 'Method' with a 'Handler'. Returns 'Nothing' if the client does not + support dynamic registration for the specified method, otherwise a + 'RegistrationToken' which can be used to unregister it later. +-} +registerCapability :: + forall f t (m :: Method ClientToServer t) config. + MonadLsp config f => + SClientMethod m -> + RegistrationOptions m -> + Handler f m -> + f (Maybe (RegistrationToken m)) registerCapability method regOpts f = do clientCaps <- resClientCapabilities <$> getLspEnv handlers <- resHandlers <$> getLspEnv let alreadyStaticallyRegistered = case splitClientMethod method of - IsClientNot -> SMethodMap.member method $ notHandlers handlers - IsClientReq -> SMethodMap.member method $ reqHandlers handlers + IsClientNot -> SMethodMap.member method $ notHandlers handlers + IsClientReq -> SMethodMap.member method $ reqHandlers handlers IsClientEither -> error "Cannot register capability for custom methods" go clientCaps alreadyStaticallyRegistered - where - -- If the server has already registered statically, don't dynamically register - -- as per the spec - go _clientCaps True = pure Nothing - go clientCaps False - -- First, check to see if the client supports dynamic registration on this method - | dynamicSupported clientCaps = do - uuid <- liftIO $ UUID.toText <$> getStdRandom random - let registration = L.TRegistration uuid method (Just regOpts) - params = L.RegistrationParams [toUntypedRegistration registration] - regId = RegistrationId uuid - rio <- askUnliftIO - ~() <- case splitClientMethod method of - IsClientNot -> modifyState resRegistrationsNot $ \oldRegs -> - let pair = Pair regId (ClientMessageHandler (unliftIO rio . f)) - in SMethodMap.insert method pair oldRegs - IsClientReq -> modifyState resRegistrationsReq $ \oldRegs -> - let pair = Pair regId (ClientMessageHandler (\msg k -> unliftIO rio $ f msg (liftIO . k))) - in SMethodMap.insert method pair oldRegs - IsClientEither -> error "Cannot register capability for custom methods" - - -- TODO: handle the scenario where this returns an error - _ <- sendRequest SMethod_ClientRegisterCapability params $ \_res -> pure () - - pure (Just (RegistrationToken method regId)) - | otherwise = pure Nothing + where + -- If the server has already registered statically, don't dynamically register + -- as per the spec + go _clientCaps True = pure Nothing + go clientCaps False + -- First, check to see if the client supports dynamic registration on this method + | dynamicRegistrationSupported method clientCaps = do + uuid <- liftIO $ UUID.toText <$> getStdRandom random + let registration = L.TRegistration uuid method (Just regOpts) + params = L.RegistrationParams [toUntypedRegistration registration] + regId = RegistrationId uuid + rio <- askUnliftIO + ~() <- case splitClientMethod method of + IsClientNot -> modifyState resRegistrationsNot $ \oldRegs -> + let pair = Pair regId (ClientMessageHandler (unliftIO rio . f)) + in SMethodMap.insert method pair oldRegs + IsClientReq -> modifyState resRegistrationsReq $ \oldRegs -> + let pair = Pair regId (ClientMessageHandler (\msg k -> unliftIO rio $ f msg (liftIO . k))) + in SMethodMap.insert method pair oldRegs + IsClientEither -> error "Cannot register capability for custom methods" - -- Also I'm thinking we should move this function to somewhere in messages.hs so - -- we don't forget to update it when adding new methods... - capDyn :: L.HasDynamicRegistration a (Maybe Bool) => Maybe a -> Bool - capDyn (Just x) = fromMaybe False $ x ^. L.dynamicRegistration - capDyn Nothing = False + -- TODO: handle the scenario where this returns an error + _ <- sendRequest SMethod_ClientRegisterCapability params $ \_res -> pure () - -- | Checks if client capabilities declares that the method supports dynamic registration - dynamicSupported clientCaps = case method of - SMethod_WorkspaceDidChangeConfiguration -> capDyn $ clientCaps ^? L.workspace . _Just . L.didChangeConfiguration . _Just - SMethod_WorkspaceDidChangeWatchedFiles -> capDyn $ clientCaps ^? L.workspace . _Just . L.didChangeWatchedFiles . _Just - SMethod_WorkspaceSymbol -> capDyn $ clientCaps ^? L.workspace . _Just . L.symbol . _Just - SMethod_WorkspaceExecuteCommand -> capDyn $ clientCaps ^? L.workspace . _Just . L.executeCommand . _Just - SMethod_TextDocumentDidOpen -> capDyn $ clientCaps ^? L.textDocument . _Just . L.synchronization . _Just - SMethod_TextDocumentDidChange -> capDyn $ clientCaps ^? L.textDocument . _Just . L.synchronization . _Just - SMethod_TextDocumentDidClose -> capDyn $ clientCaps ^? L.textDocument . _Just . L.synchronization . _Just - SMethod_TextDocumentCompletion -> capDyn $ clientCaps ^? L.textDocument . _Just . L.completion . _Just - SMethod_TextDocumentHover -> capDyn $ clientCaps ^? L.textDocument . _Just . L.hover . _Just - SMethod_TextDocumentSignatureHelp -> capDyn $ clientCaps ^? L.textDocument . _Just . L.signatureHelp . _Just - SMethod_TextDocumentDeclaration -> capDyn $ clientCaps ^? L.textDocument . _Just . L.declaration . _Just - SMethod_TextDocumentDefinition -> capDyn $ clientCaps ^? L.textDocument . _Just . L.definition . _Just - SMethod_TextDocumentTypeDefinition -> capDyn $ clientCaps ^? L.textDocument . _Just . L.typeDefinition . _Just - SMethod_TextDocumentImplementation -> capDyn $ clientCaps ^? L.textDocument . _Just . L.implementation . _Just - SMethod_TextDocumentReferences -> capDyn $ clientCaps ^? L.textDocument . _Just . L.references . _Just - SMethod_TextDocumentDocumentHighlight -> capDyn $ clientCaps ^? L.textDocument . _Just . L.documentHighlight . _Just - SMethod_TextDocumentDocumentSymbol -> capDyn $ clientCaps ^? L.textDocument . _Just . L.documentSymbol . _Just - SMethod_TextDocumentCodeAction -> capDyn $ clientCaps ^? L.textDocument . _Just . L.codeAction . _Just - SMethod_TextDocumentCodeLens -> capDyn $ clientCaps ^? L.textDocument . _Just . L.codeLens . _Just - SMethod_TextDocumentDocumentLink -> capDyn $ clientCaps ^? L.textDocument . _Just . L.documentLink . _Just - SMethod_TextDocumentDocumentColor -> capDyn $ clientCaps ^? L.textDocument . _Just . L.colorProvider . _Just - SMethod_TextDocumentColorPresentation -> capDyn $ clientCaps ^? L.textDocument . _Just . L.colorProvider . _Just - SMethod_TextDocumentFormatting -> capDyn $ clientCaps ^? L.textDocument . _Just . L.formatting . _Just - SMethod_TextDocumentRangeFormatting -> capDyn $ clientCaps ^? L.textDocument . _Just . L.rangeFormatting . _Just - SMethod_TextDocumentOnTypeFormatting -> capDyn $ clientCaps ^? L.textDocument . _Just . L.onTypeFormatting . _Just - SMethod_TextDocumentRename -> capDyn $ clientCaps ^? L.textDocument . _Just . L.rename . _Just - SMethod_TextDocumentFoldingRange -> capDyn $ clientCaps ^? L.textDocument . _Just . L.foldingRange . _Just - SMethod_TextDocumentSelectionRange -> capDyn $ clientCaps ^? L.textDocument . _Just . L.selectionRange . _Just - SMethod_TextDocumentPrepareCallHierarchy -> capDyn $ clientCaps ^? L.textDocument . _Just . L.callHierarchy . _Just - --SMethod_TextDocumentSemanticTokens -> capDyn $ clientCaps ^? L.textDocument . _Just . L.semanticTokens . _Just - _ -> False + pure (Just (RegistrationToken method regId)) + | otherwise = pure Nothing --- | Sends a @client/unregisterCapability@ request and removes the handler --- for that associated registration. +{- | Sends a @client/unregisterCapability@ request and removes the handler + for that associated registration. +-} unregisterCapability :: MonadLsp config f => RegistrationToken m -> f () unregisterCapability (RegistrationToken m (RegistrationId uuid)) = do ~() <- case splitClientMethod m of - IsClientReq -> modifyState resRegistrationsReq $ SMethodMap.delete m - IsClientNot -> modifyState resRegistrationsNot $ SMethodMap.delete m + IsClientReq -> modifyState resRegistrationsReq $ SMethodMap.delete m + IsClientNot -> modifyState resRegistrationsNot $ SMethodMap.delete m IsClientEither -> error "Cannot unregister capability for custom methods" let unregistration = L.TUnregistration uuid m @@ -631,86 +611,93 @@ storeProgress :: MonadLsp config m => ProgressToken -> Async a -> m () storeProgress n a = modifyState (progressCancel . resProgressData) $ Map.insert n (cancelWith a ProgressCancelledException) - {-# INLINE storeProgress #-} deleteProgress :: MonadLsp config m => ProgressToken -> m () deleteProgress n = modifyState (progressCancel . resProgressData) $ Map.delete n - {-# INLINE deleteProgress #-} -- Get a new id for the progress session and make a new one getNewProgressId :: MonadLsp config m => m ProgressToken getNewProgressId = do stateState (progressNextId . resProgressData) $ \cur -> - let !next = cur+1 - in (L.ProgressToken $ L.InL cur, next) - + let !next = cur + 1 + in (L.ProgressToken $ L.InL cur, next) {-# INLINE getNewProgressId #-} withProgressBase :: MonadLsp c m => Bool -> Text -> ProgressCancellable -> ((ProgressAmount -> m ()) -> m a) -> m a withProgressBase indefinite title cancellable f = do - progId <- getNewProgressId let initialPercentage | indefinite = Nothing | otherwise = Just 0 cancellable' = case cancellable of - Cancellable -> True - NotCancellable -> False + Cancellable -> True + NotCancellable -> False -- Create progress token -- FIXME : This needs to wait until the request returns before -- continuing!!! - _ <- sendRequest SMethod_WindowWorkDoneProgressCreate - (WorkDoneProgressCreateParams progId) $ \res -> do - case res of - -- An error occurred when the client was setting it up - -- No need to do anything then, as per the spec - Left _err -> pure () - Right _ -> pure () + _ <- sendRequest + SMethod_WindowWorkDoneProgressCreate + (WorkDoneProgressCreateParams progId) + $ \res -> do + case res of + -- An error occurred when the client was setting it up + -- No need to do anything then, as per the spec + Left _err -> pure () + Right _ -> pure () -- Send the begin and done notifications via 'bracket_' so that they are always fired res <- withRunInIO $ \runInBase -> E.bracket_ -- Send begin notification - (runInBase $ sendNotification SMethod_Progress $ - ProgressParams progId $ J.toJSON $ - WorkDoneProgressBegin L.AString title (Just cancellable') Nothing initialPercentage) - + ( runInBase $ + sendNotification SMethod_Progress $ + ProgressParams progId $ + J.toJSON $ + WorkDoneProgressBegin L.AString title (Just cancellable') Nothing initialPercentage + ) -- Send end notification - (runInBase $ sendNotification SMethod_Progress $ - ProgressParams progId $ J.toJSON $ (WorkDoneProgressEnd L.AString Nothing)) $ do - - -- Run f asynchronously - aid <- async $ runInBase $ f (updater progId) - runInBase $ storeProgress progId aid - wait aid + ( runInBase $ + sendNotification SMethod_Progress $ + ProgressParams progId $ + J.toJSON $ + (WorkDoneProgressEnd L.AString Nothing) + ) + $ do + -- Run f asynchronously + aid <- async $ runInBase $ f (updater progId) + runInBase $ storeProgress progId aid + wait aid -- 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 - where updater progId (ProgressAmount percentage msg) = do - sendNotification SMethod_Progress $ ProgressParams progId $ J.toJSON $ - WorkDoneProgressReport L.AString Nothing msg percentage + where + updater progId (ProgressAmount percentage msg) = do + sendNotification SMethod_Progress $ + ProgressParams progId $ + J.toJSON $ + WorkDoneProgressReport L.AString Nothing msg percentage clientSupportsProgress :: L.ClientCapabilities -> Bool clientSupportsProgress caps = fromMaybe False $ caps ^? L.window . _Just . L.workDoneProgress . _Just - {-# INLINE clientSupportsProgress #-} --- | 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. +{- | 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. +-} withProgress :: MonadLsp c m => Text -> ProgressCancellable -> ((ProgressAmount -> m ()) -> m a) -> m a withProgress title cancellable f = do clientCaps <- getClientCapabilities @@ -718,10 +705,11 @@ then withProgressBase False title cancellable f else f (const $ return ()) --- | Same as 'withProgress', but for processes that do not report the --- precentage complete. --- --- @since 0.10.0.0 +{- | Same as 'withProgress', but for processes that do not report the + precentage complete. + + @since 0.10.0.0 +-} withIndefiniteProgress :: MonadLsp c m => Text -> ProgressCancellable -> m a -> m a withIndefiniteProgress title cancellable f = do clientCaps <- getClientCapabilities @@ -731,25 +719,31 @@ -- --------------------------------------------------------------------- --- | Aggregate 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. +{- | Aggregate 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. +-} publishDiagnostics :: MonadLsp config m => Int -> NormalizedUri -> Maybe L.Int32 -> DiagnosticsBySource -> m () -publishDiagnostics maxDiagnosticCount uri version diags = join $ stateState resDiagnostics $ \oldDiags-> +publishDiagnostics maxDiagnosticCount uri version diags = join $ stateState resDiagnostics $ \oldDiags -> let !newDiags = updateDiagnostics oldDiags uri version diags mdp = getDiagnosticParamsFor maxDiagnosticCount newDiags uri act = case mdp of Nothing -> return () Just params -> sendToClient $ L.fromServerNot $ L.TNotificationMessage "2.0" L.SMethod_TextDocumentPublishDiagnostics params - in (act,newDiags) + in (act, newDiags) -- --------------------------------------------------------------------- --- | Remove all diagnostics from a particular source, and send the updates to --- the client. -flushDiagnosticsBySource :: MonadLsp config m => Int -- ^ Max number of diagnostics to send - -> Maybe Text -> m () +{- | Remove all diagnostics from a particular source, and send the updates to + the client. +-} +flushDiagnosticsBySource :: + MonadLsp config m => + -- | Max number of diagnostics to send + Int -> + Maybe Text -> + m () flushDiagnosticsBySource maxDiagnosticCount msource = join $ stateState resDiagnostics $ \oldDiags -> let !newDiags = flushBySource oldDiags msource -- Send the updated diagnostics to the client @@ -759,33 +753,34 @@ Nothing -> return () Just params -> do sendToClient $ L.fromServerNot $ L.TNotificationMessage "2.0" L.SMethod_TextDocumentPublishDiagnostics params - in (act,newDiags) + in (act, newDiags) -- --------------------------------------------------------------------- --- | The changes in a workspace edit should be applied from the end of the file --- toward the start. Sort them into this order. +{- | The changes in a workspace edit should be applied from the end of the file + toward the start. Sort them into this order. +-} reverseSortEdit :: L.WorkspaceEdit -> L.WorkspaceEdit reverseSortEdit (L.WorkspaceEdit cs dcs anns) = L.WorkspaceEdit cs' dcs' anns - where - cs' :: Maybe (Map.Map Uri [TextEdit]) - cs' = (fmap . fmap ) sortTextEdits cs + where + cs' :: Maybe (Map.Map Uri [TextEdit]) + cs' = (fmap . fmap) sortTextEdits cs - dcs' :: Maybe [L.DocumentChange] - dcs' = (fmap . fmap) sortOnlyTextDocumentEdits dcs + dcs' :: Maybe [L.DocumentChange] + dcs' = (fmap . fmap) sortOnlyTextDocumentEdits dcs - sortTextEdits :: [L.TextEdit] -> [L.TextEdit] - sortTextEdits edits = L.sortOn (Down . (^. L.range)) edits + sortTextEdits :: [L.TextEdit] -> [L.TextEdit] + sortTextEdits edits = L.sortOn (Down . (^. L.range)) edits - sortOnlyTextDocumentEdits :: L.DocumentChange -> L.DocumentChange - sortOnlyTextDocumentEdits (L.InL (L.TextDocumentEdit td edits)) = L.InL $ L.TextDocumentEdit td edits' - where - edits' = L.sortOn (Down . editRange) edits - sortOnlyTextDocumentEdits (L.InR others) = L.InR others + sortOnlyTextDocumentEdits :: L.DocumentChange -> L.DocumentChange + sortOnlyTextDocumentEdits (L.InL (L.TextDocumentEdit td edits)) = L.InL $ L.TextDocumentEdit td edits' + where + edits' = L.sortOn (Down . editRange) edits + sortOnlyTextDocumentEdits (L.InR others) = L.InR others - editRange :: L.TextEdit L.|? L.AnnotatedTextEdit -> L.Range - editRange (L.InR e) = e ^. L.range - editRange (L.InL e) = e ^. L.range + editRange :: L.TextEdit L.|? L.AnnotatedTextEdit -> L.Range + editRange (L.InR e) = e ^. L.range + editRange (L.InL e) = e ^. L.range -------------------------------------------------------------------------------- -- CONFIG @@ -796,7 +791,7 @@ tryChangeConfig logger newConfigObject = do parseCfg <- LspT $ asks resParseConfig res <- stateState resConfig $ \oldConfig -> case parseCfg oldConfig newConfigObject of - Left err -> (Left err, oldConfig) + Left err -> (Left err, oldConfig) Right newConfig -> (Right newConfig, newConfig) case res of Left err -> do @@ -806,23 +801,23 @@ cb <- LspT $ asks resOnConfigChange liftIO $ cb newConfig --- | Send a `worksapce/configuration` request to update the server's config. --- --- This is called automatically in response to `workspace/didChangeConfiguration` notifications --- from the client, so should not normally be called manually. +{- | Send a `worksapce/configuration` request to update the server's config. + + This is called automatically in response to `workspace/didChangeConfiguration` notifications + from the client, so should not normally be called manually. +-} requestConfigUpdate :: (m ~ LspM config) => LogAction m (WithSeverity LspCoreLog) -> m () requestConfigUpdate logger = do caps <- LspT $ asks resClientCapabilities let supportsConfiguration = fromMaybe False $ caps ^? L.workspace . _Just . L.configuration . _Just if supportsConfiguration - then do - section <- LspT $ asks resConfigSection - void $ sendRequest SMethod_WorkspaceConfiguration (ConfigurationParams [ConfigurationItem Nothing (Just section)]) $ \case - Right [newConfigObject] -> tryChangeConfig logger newConfigObject - Right sections -> logger <& WrongConfigSections sections `WithSeverity` Error - Left err -> logger <& BadConfigurationResponse err `WithSeverity` Error - else - logger <& ConfigurationNotSupported `WithSeverity` Debug + then do + section <- LspT $ asks resConfigSection + void $ sendRequest SMethod_WorkspaceConfiguration (ConfigurationParams [ConfigurationItem Nothing (Just section)]) $ \case + Right [newConfigObject] -> tryChangeConfig logger newConfigObject + Right sections -> logger <& WrongConfigSections sections `WithSeverity` Error + Left err -> logger <& BadConfigurationResponse err `WithSeverity` Error + else logger <& ConfigurationNotSupported `WithSeverity` Debug {- Note [LSP configuration] LSP configuration is a huge mess. diff --git a/src/Language/LSP/Server/Processing.hs b/src/Language/LSP/Server/Processing.hs --- a/src/Language/LSP/Server/Processing.hs +++ b/src/Language/LSP/Server/Processing.hs @@ -1,74 +1,82 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeInType #-} - -{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} --- there's just so much! -{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeInType #-} -- So we can keep using the old prettyprinter modules (which have a better -- compatibility range) for now. {-# OPTIONS_GHC -Wno-deprecations #-} +-- there's just so much! +{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} module Language.LSP.Server.Processing where -import Colog.Core (LogAction (..), - Severity (..), - WithSeverity (..), - cmap, (<&)) +import Colog.Core ( + LogAction (..), + Severity (..), + WithSeverity (..), + cmap, + (<&), + ) -import Control.Concurrent.STM -import qualified Control.Exception as E -import Control.Lens hiding (Empty) -import Control.Monad -import Control.Monad.Except () -import Control.Monad.IO.Class -import Control.Monad.Reader -import Control.Monad.State -import Control.Monad.Trans.Except -import Control.Monad.Writer.Strict -import Data.Aeson hiding (Error, Null, - Options) -import Data.Aeson.Lens () -import Data.Aeson.Types hiding (Error, Null, - Options) -import qualified Data.ByteString.Lazy as BSL -import Data.Foldable (traverse_) -import qualified Data.Functor.Product as P -import Data.IxMap -import Data.List -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.Map.Strict as Map -import Data.Maybe -import Data.Monoid -import Data.Row -import Data.String (fromString) -import qualified Data.Text as T -import qualified Data.Text.Lazy.Encoding as TL -import Data.Text.Prettyprint.Doc -import qualified Language.LSP.Protocol.Lens as L -import Language.LSP.Protocol.Message -import Language.LSP.Protocol.Types -import Language.LSP.Protocol.Utils.SMethodMap (SMethodMap) -import qualified Language.LSP.Protocol.Utils.SMethodMap as SMethodMap -import Language.LSP.Server.Core -import Language.LSP.VFS as VFS -import System.Exit +import Control.Concurrent.STM +import Control.Exception qualified as E +import Control.Lens hiding (Empty) +import Control.Monad +import Control.Monad.Except () +import Control.Monad.IO.Class +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Trans.Except +import Control.Monad.Writer.Strict +import Data.Aeson hiding ( + Error, + Null, + Options, + ) +import Data.Aeson.Lens () +import Data.Aeson.Types hiding ( + Error, + Null, + Options, + ) +import Data.ByteString.Lazy qualified as BSL +import Data.Foldable (traverse_) +import Data.Functor.Product qualified as P +import Data.IxMap +import Data.List +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map.Strict qualified as Map +import Data.Maybe +import Data.Monoid +import Data.Row +import Data.String (fromString) +import Data.Text qualified as T +import Data.Text.Lazy.Encoding qualified as TL +import Data.Text.Prettyprint.Doc +import Language.LSP.Protocol.Lens qualified as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import Language.LSP.Protocol.Utils.SMethodMap (SMethodMap) +import Language.LSP.Protocol.Utils.SMethodMap qualified as SMethodMap +import Language.LSP.Server.Core +import Language.LSP.VFS as VFS +import System.Exit -data LspProcessingLog = - VfsLog VfsLog +data LspProcessingLog + = VfsLog VfsLog | LspCore LspCoreLog | MessageProcessingError BSL.ByteString String - | forall m . MissingHandler Bool (SClientMethod m) + | forall m. MissingHandler Bool (SClientMethod m) | ProgressCancel ProgressToken | Exiting @@ -78,8 +86,8 @@ pretty (VfsLog l) = pretty l pretty (LspCore l) = pretty l pretty (MessageProcessingError bs err) = - vsep [ - "LSP: incoming message parse error:" + vsep + [ "LSP: incoming message parse error:" , pretty err , "when processing" , pretty (TL.decodeUtf8 bs) @@ -92,31 +100,31 @@ processMessage logger jsonStr = do pendingResponsesVar <- LspT $ asks $ resPendingResponses . resState join $ liftIO $ atomically $ fmap handleErrors $ runExceptT $ do - val <- except $ eitherDecode jsonStr - pending <- lift $ readTVar pendingResponsesVar - msg <- except $ parseEither (parser pending) val - lift $ case msg of - FromClientMess m mess -> - pure $ handle logger m mess - FromClientRsp (P.Pair (ServerResponseCallback f) (Const !newMap)) res -> do - writeTVar pendingResponsesVar newMap - pure $ liftIO $ f (res ^. L.result) - where - parser :: ResponseMap -> Value -> Parser (FromClientMessage' (P.Product ServerResponseCallback (Const ResponseMap))) - parser rm = parseClientMessage $ \i -> - let (mhandler, newMap) = pickFromIxMap i rm - in (\(P.Pair m handler) -> (m,P.Pair handler (Const newMap))) <$> mhandler + val <- except $ eitherDecode jsonStr + pending <- lift $ readTVar pendingResponsesVar + msg <- except $ parseEither (parser pending) val + lift $ case msg of + FromClientMess m mess -> + pure $ handle logger m mess + FromClientRsp (P.Pair (ServerResponseCallback f) (Const !newMap)) res -> do + writeTVar pendingResponsesVar newMap + pure $ liftIO $ f (res ^. L.result) + where + parser :: ResponseMap -> Value -> Parser (FromClientMessage' (P.Product ServerResponseCallback (Const ResponseMap))) + parser rm = parseClientMessage $ \i -> + let (mhandler, newMap) = pickFromIxMap i rm + in (\(P.Pair m handler) -> (m, P.Pair handler (Const newMap))) <$> mhandler - handleErrors = either (\e -> logger <& MessageProcessingError jsonStr e `WithSeverity` Error) id + handleErrors = either (\e -> logger <& MessageProcessingError jsonStr e `WithSeverity` Error) id -- | Call this to initialize the session -initializeRequestHandler - :: LogAction IO (WithSeverity LspProcessingLog) - -> ServerDefinition config - -> VFS - -> (FromServerMessage -> IO ()) - -> TMessage Method_Initialize - -> IO (Maybe (LanguageContextEnv config)) +initializeRequestHandler :: + LogAction IO (WithSeverity LspProcessingLog) -> + ServerDefinition config -> + VFS -> + (FromServerMessage -> IO ()) -> + TMessage Method_Initialize -> + IO (Maybe (LanguageContextEnv config)) initializeRequestHandler logger ServerDefinition{..} vfs sendFunc req = do let sendResp = sendFunc . FromServerRsp SMethod_Initialize handleErr (Left err) = do @@ -124,41 +132,47 @@ pure Nothing handleErr (Right a) = pure $ Just a flip E.catch (initializeErrorHandler $ sendResp . makeResponseError (req ^. L.id)) $ handleErr <=< runExceptT $ mdo - let p = req ^. L.params - rootDir = getFirst $ foldMap First [ p ^? L.rootUri . _L >>= uriToFilePath - , p ^? L.rootPath . _Just . _L <&> T.unpack ] + rootDir = + getFirst $ + foldMap + First + [ p ^? L.rootUri . _L >>= uriToFilePath + , p ^? L.rootPath . _Just . _L <&> T.unpack + ] clientCaps = (p ^. L.capabilities) let initialWfs = case p ^. L.workspaceFolders of Just (InL xs) -> xs - _ -> [] + _ -> [] -- See Note [LSP configuration] configObject = lookForConfigSection configSection <$> (p ^. L.initializationOptions) initialConfig <- case configObject of Just o -> case parseConfig defaultConfig o of - Right newConfig -> pure newConfig - Left err -> do - -- Warn not error here, since initializationOptions is pretty unspecified - liftIO $ logger <& (LspCore $ ConfigurationParseError o err) `WithSeverity` Warning - pure defaultConfig + Right newConfig -> do + liftIO $ logger <& (LspCore $ NewConfig o) `WithSeverity` Debug + pure newConfig + Left err -> do + -- Warn not error here, since initializationOptions is pretty unspecified + liftIO $ logger <& (LspCore $ ConfigurationParseError o err) `WithSeverity` Warning + pure defaultConfig Nothing -> pure defaultConfig stateVars <- liftIO $ do - resVFS <- newTVarIO (VFSData vfs mempty) - resDiagnostics <- newTVarIO mempty - resConfig <- newTVarIO initialConfig + resVFS <- newTVarIO (VFSData vfs mempty) + resDiagnostics <- newTVarIO mempty + resConfig <- newTVarIO initialConfig resWorkspaceFolders <- newTVarIO initialWfs - resProgressData <- do + resProgressData <- do progressNextId <- newTVarIO 0 progressCancel <- newTVarIO mempty pure ProgressData{..} resPendingResponses <- newTVarIO emptyIxMap resRegistrationsNot <- newTVarIO mempty resRegistrationsReq <- newTVarIO mempty - resLspId <- newTVarIO 0 + resLspId <- newTVarIO 0 pure LanguageContextState{..} -- Call the 'duringInitialization' callback to let the server kick stuff up @@ -171,195 +185,248 @@ let serverCaps = inferServerCapabilities clientCaps options handlers liftIO $ sendResp $ makeResponseMessage (req ^. L.id) (InitializeResult serverCaps (optServerInfo options)) pure env - where - makeResponseMessage rid result = TResponseMessage "2.0" (Just rid) (Right result) - makeResponseError origId err = TResponseMessage "2.0" (Just origId) (Left err) - - initializeErrorHandler :: (ResponseError -> IO ()) -> E.SomeException -> IO (Maybe a) - initializeErrorHandler sendResp e = do - sendResp $ ResponseError (InR ErrorCodes_InternalError) msg Nothing - pure Nothing - where - msg = T.pack $ unwords ["Error on initialize:", show e] + where + makeResponseMessage rid result = TResponseMessage "2.0" (Just rid) (Right result) + makeResponseError origId err = TResponseMessage "2.0" (Just origId) (Left err) + initializeErrorHandler :: (ResponseError -> IO ()) -> E.SomeException -> IO (Maybe a) + initializeErrorHandler sendResp e = do + sendResp $ ResponseError (InR ErrorCodes_InternalError) msg Nothing + pure Nothing + where + msg = T.pack $ unwords ["Error on initialize:", show e] --- | 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. +{- | 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. +-} inferServerCapabilities :: ClientCapabilities -> Options -> Handlers m -> ServerCapabilities inferServerCapabilities clientCaps o h = ServerCapabilities - { _textDocumentSync = sync - , _hoverProvider = supportedBool SMethod_TextDocumentHover - , _completionProvider = completionProvider - , _declarationProvider = supportedBool SMethod_TextDocumentDeclaration - , _signatureHelpProvider = signatureHelpProvider - , _definitionProvider = supportedBool SMethod_TextDocumentDefinition - , _typeDefinitionProvider = supportedBool SMethod_TextDocumentTypeDefinition - , _implementationProvider = supportedBool SMethod_TextDocumentImplementation - , _referencesProvider = supportedBool SMethod_TextDocumentReferences - , _documentHighlightProvider = supportedBool SMethod_TextDocumentDocumentHighlight - , _documentSymbolProvider = supportedBool SMethod_TextDocumentDocumentSymbol - , _codeActionProvider = codeActionProvider - , _codeLensProvider = supported' SMethod_TextDocumentCodeLens $ CodeLensOptions - (Just False) - (supported SMethod_CodeLensResolve) - , _documentFormattingProvider = supportedBool SMethod_TextDocumentFormatting - , _documentRangeFormattingProvider = supportedBool SMethod_TextDocumentRangeFormatting + { _textDocumentSync = sync + , _hoverProvider = supportedBool SMethod_TextDocumentHover + , _completionProvider = completionProvider + , _inlayHintProvider = inlayProvider + , _declarationProvider = supportedBool SMethod_TextDocumentDeclaration + , _signatureHelpProvider = signatureHelpProvider + , _definitionProvider = supportedBool SMethod_TextDocumentDefinition + , _typeDefinitionProvider = supportedBool SMethod_TextDocumentTypeDefinition + , _implementationProvider = supportedBool SMethod_TextDocumentImplementation + , _referencesProvider = supportedBool SMethod_TextDocumentReferences + , _documentHighlightProvider = supportedBool SMethod_TextDocumentDocumentHighlight + , _documentSymbolProvider = supportedBool SMethod_TextDocumentDocumentSymbol + , _codeActionProvider = codeActionProvider + , _codeLensProvider = + supported' SMethod_TextDocumentCodeLens $ + CodeLensOptions + (Just False) + (supported SMethod_CodeLensResolve) + , _documentFormattingProvider = supportedBool SMethod_TextDocumentFormatting + , _documentRangeFormattingProvider = supportedBool SMethod_TextDocumentRangeFormatting , _documentOnTypeFormattingProvider = documentOnTypeFormattingProvider - , _renameProvider = renameProvider - , _documentLinkProvider = supported' SMethod_TextDocumentDocumentLink $ DocumentLinkOptions - (Just False) - (supported SMethod_DocumentLinkResolve) - , _colorProvider = supportedBool SMethod_TextDocumentDocumentColor - , _foldingRangeProvider = supportedBool SMethod_TextDocumentFoldingRange - , _executeCommandProvider = executeCommandProvider - , _selectionRangeProvider = supportedBool SMethod_TextDocumentSelectionRange - , _callHierarchyProvider = supportedBool SMethod_TextDocumentPrepareCallHierarchy - , _semanticTokensProvider = semanticTokensProvider - , _workspaceSymbolProvider = supportedBool SMethod_WorkspaceSymbol - , _workspace = Just workspace - -- TODO: Add something for experimental - , _experimental = Nothing :: Maybe Value - -- TODO - , _positionEncoding = Nothing - , _notebookDocumentSync = Nothing - , _linkedEditingRangeProvider = Nothing - , _monikerProvider = Nothing - , _typeHierarchyProvider = Nothing - , _inlineValueProvider = Nothing - , _inlayHintProvider = Nothing - , _diagnosticProvider = Nothing + , _renameProvider = renameProvider + , _documentLinkProvider = + supported' SMethod_TextDocumentDocumentLink $ + DocumentLinkOptions + (Just False) + (supported SMethod_DocumentLinkResolve) + , _colorProvider = supportedBool SMethod_TextDocumentDocumentColor + , _foldingRangeProvider = supportedBool SMethod_TextDocumentFoldingRange + , _executeCommandProvider = executeCommandProvider + , _selectionRangeProvider = supportedBool SMethod_TextDocumentSelectionRange + , _callHierarchyProvider = supportedBool SMethod_TextDocumentPrepareCallHierarchy + , _semanticTokensProvider = semanticTokensProvider + , _workspaceSymbolProvider = supportedBool SMethod_WorkspaceSymbol + , _workspace = Just workspace + , _experimental = Nothing :: Maybe Value + , -- The only encoding the VFS supports is the legacy UTF16 option at the moment + _positionEncoding = Just PositionEncodingKind_UTF16 + , _linkedEditingRangeProvider = + supported' SMethod_TextDocumentLinkedEditingRange $ + InR $ + InL $ + LinkedEditingRangeOptions{_workDoneProgress = Nothing} + , _monikerProvider = + supported' SMethod_TextDocumentMoniker $ + InR $ + InL $ + MonikerOptions{_workDoneProgress = Nothing} + , _typeHierarchyProvider = + supported' SMethod_TextDocumentPrepareTypeHierarchy $ + InR $ + InL $ + TypeHierarchyOptions{_workDoneProgress = Nothing} + , _inlineValueProvider = + supported' SMethod_TextDocumentInlineValue $ + InR $ + InL $ + InlineValueOptions{_workDoneProgress = Nothing} + , _diagnosticProvider = diagnosticProvider + , -- TODO: super unclear what to do about notebooks in general + _notebookDocumentSync = Nothing } - where - - -- | For when we just return a simple @true@/@false@ to indicate if we - -- support the capability - supportedBool = Just . InL . supported_b + where + -- \| For when we just return a simple @true@/@false@ to indicate if we + -- support the capability + supportedBool = Just . InL . supported_b - supported' m b - | supported_b m = Just b - | otherwise = Nothing + supported' m b + | supported_b m = Just b + | otherwise = Nothing - supported :: forall m. SClientMethod m -> Maybe Bool - supported = Just . supported_b + supported :: forall m. SClientMethod m -> Maybe Bool + supported = Just . supported_b - supported_b :: forall m. SClientMethod m -> Bool - supported_b m = case splitClientMethod m of - IsClientNot -> SMethodMap.member m $ notHandlers h - IsClientReq -> SMethodMap.member m $ reqHandlers h - IsClientEither -> error "capabilities depend on custom method" + supported_b :: forall m. SClientMethod m -> Bool + supported_b m = case splitClientMethod m of + IsClientNot -> SMethodMap.member m $ notHandlers h + IsClientReq -> SMethodMap.member m $ reqHandlers h + IsClientEither -> error "capabilities depend on custom method" - singleton :: a -> [a] - singleton x = [x] + singleton :: a -> [a] + singleton x = [x] - completionProvider - | supported_b SMethod_TextDocumentCompletion = Just $ - CompletionOptions { - _triggerCharacters=map T.singleton <$> optCompletionTriggerCharacters o - , _allCommitCharacters=map T.singleton <$> optCompletionAllCommitCharacters o - , _resolveProvider=supported SMethod_CompletionItemResolve - , _completionItem=Nothing - , _workDoneProgress=Nothing + completionProvider + | supported_b SMethod_TextDocumentCompletion = + Just $ + CompletionOptions + { _triggerCharacters = map T.singleton <$> optCompletionTriggerCharacters o + , _allCommitCharacters = map T.singleton <$> optCompletionAllCommitCharacters o + , _resolveProvider = supported SMethod_CompletionItemResolve + , _completionItem = Nothing + , _workDoneProgress = Nothing } - | otherwise = Nothing + | otherwise = Nothing - clientSupportsCodeActionKinds = isJust $ + inlayProvider + | supported_b SMethod_TextDocumentInlayHint = + Just $ + InR $ + InL + InlayHintOptions + { _workDoneProgress = Nothing + , _resolveProvider = supported SMethod_InlayHintResolve + } + | otherwise = Nothing + + clientSupportsCodeActionKinds = + isJust $ clientCaps ^? L.textDocument . _Just . L.codeAction . _Just . L.codeActionLiteralSupport . _Just - codeActionProvider - | supported_b SMethod_TextDocumentCodeAction = Just $ InR $ - CodeActionOptions { - _workDoneProgress = Nothing - , _codeActionKinds = codeActionKinds (optCodeActionKinds o) - , _resolveProvider = supported SMethod_CodeActionResolve - } - | otherwise = Just (InL False) + codeActionProvider + | supported_b SMethod_TextDocumentCodeAction = + Just $ + InR $ + CodeActionOptions + { _workDoneProgress = Nothing + , _codeActionKinds = codeActionKinds (optCodeActionKinds o) + , _resolveProvider = supported SMethod_CodeActionResolve + } + | otherwise = Just (InL False) - codeActionKinds (Just ks) - | clientSupportsCodeActionKinds = Just ks - codeActionKinds _ = Nothing + codeActionKinds (Just ks) + | clientSupportsCodeActionKinds = Just ks + codeActionKinds _ = Nothing - signatureHelpProvider - | supported_b SMethod_TextDocumentSignatureHelp = Just $ + signatureHelpProvider + | supported_b SMethod_TextDocumentSignatureHelp = + Just $ SignatureHelpOptions Nothing (map T.singleton <$> optSignatureHelpTriggerCharacters o) (map T.singleton <$> optSignatureHelpRetriggerCharacters o) - | otherwise = Nothing + | otherwise = Nothing - documentOnTypeFormattingProvider - | supported_b SMethod_TextDocumentOnTypeFormatting - , Just (first :| rest) <- optDocumentOnTypeFormattingTriggerCharacters o = Just $ + documentOnTypeFormattingProvider + | supported_b SMethod_TextDocumentOnTypeFormatting + , Just (first :| rest) <- optDocumentOnTypeFormattingTriggerCharacters o = + Just $ DocumentOnTypeFormattingOptions (T.pack [first]) (Just (map (T.pack . singleton) rest)) - | supported_b SMethod_TextDocumentOnTypeFormatting - , Nothing <- optDocumentOnTypeFormattingTriggerCharacters o = - error "documentOnTypeFormattingTriggerCharacters needs to be set if a documentOnTypeFormattingHandler is set" - | otherwise = Nothing + | supported_b SMethod_TextDocumentOnTypeFormatting + , Nothing <- optDocumentOnTypeFormattingTriggerCharacters o = + error "documentOnTypeFormattingTriggerCharacters needs to be set if a documentOnTypeFormattingHandler is set" + | otherwise = Nothing - executeCommandProvider - | supported_b SMethod_WorkspaceExecuteCommand - , Just cmds <- optExecuteCommandCommands o = Just (ExecuteCommandOptions Nothing cmds) - | supported_b SMethod_WorkspaceExecuteCommand - , Nothing <- optExecuteCommandCommands o = - error "executeCommandCommands needs to be set if a executeCommandHandler is set" - | otherwise = Nothing + executeCommandProvider + | supported_b SMethod_WorkspaceExecuteCommand + , Just cmds <- optExecuteCommandCommands o = + Just (ExecuteCommandOptions Nothing cmds) + | supported_b SMethod_WorkspaceExecuteCommand + , Nothing <- optExecuteCommandCommands o = + error "executeCommandCommands needs to be set if a executeCommandHandler is set" + | otherwise = Nothing - clientSupportsPrepareRename = fromMaybe False $ + clientSupportsPrepareRename = + fromMaybe False $ clientCaps ^? L.textDocument . _Just . L.rename . _Just . L.prepareSupport . _Just - renameProvider - | clientSupportsPrepareRename - , supported_b SMethod_TextDocumentRename - , supported_b SMethod_TextDocumentPrepareRename = Just $ - InR . RenameOptions Nothing . Just $ True - | supported_b SMethod_TextDocumentRename = Just (InL True) - | otherwise = Just (InL False) + renameProvider + | clientSupportsPrepareRename + , supported_b SMethod_TextDocumentRename + , supported_b SMethod_TextDocumentPrepareRename = + Just $ + InR . RenameOptions Nothing . Just $ + True + | supported_b SMethod_TextDocumentRename = Just (InL True) + | otherwise = Just (InL False) - -- Always provide the default legend - -- TODO: allow user-provided legend via 'Options', or at least user-provided types - semanticTokensProvider = Just $ InL $ SemanticTokensOptions Nothing defaultSemanticTokensLegend semanticTokenRangeProvider semanticTokenFullProvider - semanticTokenRangeProvider - | supported_b SMethod_TextDocumentSemanticTokensRange = Just $ InL True - | otherwise = Nothing - semanticTokenFullProvider - | supported_b SMethod_TextDocumentSemanticTokensFull = Just $ InR $ #delta .== supported SMethod_TextDocumentSemanticTokensFullDelta - | otherwise = Nothing + -- Always provide the default legend + -- TODO: allow user-provided legend via 'Options', or at least user-provided types + semanticTokensProvider = Just $ InL $ SemanticTokensOptions Nothing defaultSemanticTokensLegend semanticTokenRangeProvider semanticTokenFullProvider + semanticTokenRangeProvider + | supported_b SMethod_TextDocumentSemanticTokensRange = Just $ InL True + | otherwise = Nothing + semanticTokenFullProvider + | supported_b SMethod_TextDocumentSemanticTokensFull = Just $ InR $ #delta .== supported SMethod_TextDocumentSemanticTokensFullDelta + | otherwise = Nothing - sync = case optTextDocumentSync o of - Just x -> Just (InL x) - Nothing -> Nothing + sync = case optTextDocumentSync o of + Just x -> Just (InL x) + Nothing -> Nothing - workspace = #workspaceFolders .== workspaceFolder .+ #fileOperations .== Nothing - workspaceFolder = supported' SMethod_WorkspaceDidChangeWorkspaceFolders $ - -- sign up to receive notifications - WorkspaceFoldersServerCapabilities (Just True) (Just (InR True)) + workspace = #workspaceFolders .== workspaceFolder .+ #fileOperations .== Nothing + workspaceFolder = + supported' SMethod_WorkspaceDidChangeWorkspaceFolders $ + -- sign up to receive notifications + WorkspaceFoldersServerCapabilities (Just True) (Just (InR True)) --- | Invokes the registered dynamic or static handlers for the given message and --- method, as well as doing some bookkeeping. + diagnosticProvider = + supported' SMethod_TextDocumentDiagnostic $ + InL $ + DiagnosticOptions + { _workDoneProgress = Nothing + , _identifier = Nothing + , -- TODO: this is a conservative but maybe inaccurate, unclear how much it matters + _interFileDependencies = True + , _workspaceDiagnostics = supported_b SMethod_WorkspaceDiagnostic + } + +{- | Invokes the registered dynamic or static handlers for the given message and + method, as well as doing some bookkeeping. +-} handle :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> SClientMethod meth -> TClientMessage meth -> m () handle logger m msg = case m of SMethod_WorkspaceDidChangeWorkspaceFolders -> handle' logger (Just updateWorkspaceFolders) m msg - SMethod_WorkspaceDidChangeConfiguration -> handle' logger (Just $ handleDidChangeConfiguration logger) m msg + SMethod_WorkspaceDidChangeConfiguration -> handle' logger (Just $ handleDidChangeConfiguration logger) m msg -- See Note [LSP configuration] - SMethod_Initialized -> handle' logger (Just $ \_ -> requestConfigUpdate (cmap (fmap LspCore) logger)) m msg - SMethod_TextDocumentDidOpen -> handle' logger (Just $ vfsFunc logger openVFS) m msg - SMethod_TextDocumentDidChange -> handle' logger (Just $ vfsFunc logger changeFromClientVFS) m msg - SMethod_TextDocumentDidClose -> handle' logger (Just $ vfsFunc logger closeVFS) m msg - SMethod_WindowWorkDoneProgressCancel -> handle' logger (Just $ progressCancelHandler logger) m msg + SMethod_Initialized -> handle' logger (Just $ \_ -> requestConfigUpdate (cmap (fmap LspCore) logger)) m msg + SMethod_TextDocumentDidOpen -> handle' logger (Just $ vfsFunc logger openVFS) m msg + SMethod_TextDocumentDidChange -> handle' logger (Just $ vfsFunc logger changeFromClientVFS) m msg + SMethod_TextDocumentDidClose -> handle' logger (Just $ vfsFunc logger closeVFS) m msg + SMethod_WindowWorkDoneProgressCancel -> handle' logger (Just $ progressCancelHandler logger) m msg _ -> handle' logger Nothing m msg - -handle' :: forall m t (meth :: Method ClientToServer t) config - . (m ~ LspM config) - => LogAction m (WithSeverity LspProcessingLog) - -> Maybe (TClientMessage meth -> m ()) - -- ^ An action to be run before invoking the handler, used for - -- bookkeeping stuff like the vfs etc. - -> SClientMethod meth - -> TClientMessage meth - -> m () +handle' :: + forall m t (meth :: Method ClientToServer t) config. + (m ~ LspM config) => + LogAction m (WithSeverity LspProcessingLog) -> + -- | An action to be run before invoking the handler, used for + -- bookkeeping stuff like the vfs etc. + Maybe (TClientMessage meth -> m ()) -> + SClientMethod meth -> + TClientMessage meth -> + m () handle' logger mAction m msg = do maybe (return ()) (\f -> f msg) mAction @@ -370,10 +437,16 @@ let Handlers{reqHandlers, notHandlers} = resHandlers env let mkRspCb :: TRequestMessage (m1 :: Method ClientToServer Request) -> Either ResponseError (MessageResult m1) -> IO () - mkRspCb req (Left err) = runLspT env $ sendToClient $ - FromServerRsp (req ^. L.method) $ TResponseMessage "2.0" (Just (req ^. L.id)) (Left err) - mkRspCb req (Right rsp) = runLspT env $ sendToClient $ - FromServerRsp (req ^. L.method) $ TResponseMessage "2.0" (Just (req ^. L.id)) (Right rsp) + mkRspCb req (Left err) = + runLspT env $ + sendToClient $ + FromServerRsp (req ^. L.method) $ + TResponseMessage "2.0" (Just (req ^. L.id)) (Left err) + mkRspCb req (Right rsp) = + runLspT env $ + sendToClient $ + FromServerRsp (req ^. L.method) $ + TResponseMessage "2.0" (Just (req ^. L.id)) (Right rsp) case splitClientMethod m of IsClientNot -> case pickHandler dynNotHandlers notHandlers of @@ -382,7 +455,6 @@ | SMethod_Exit <- m -> exitNotificationHandler logger msg | otherwise -> do reportMissingHandler - IsClientReq -> case pickHandler dynReqHandlers reqHandlers of Just h -> liftIO $ h msg (mkRspCb msg) Nothing @@ -391,11 +463,11 @@ let errorMsg = T.pack $ unwords ["lsp:no handler for: ", show m] err = ResponseError (InR ErrorCodes_MethodNotFound) errorMsg Nothing sendToClient $ - FromServerRsp (msg ^. L.method) $ TResponseMessage "2.0" (Just (msg ^. L.id)) (Left err) - + FromServerRsp (msg ^. L.method) $ + TResponseMessage "2.0" (Just (msg ^. L.id)) (Left err) IsClientEither -> case msg of NotMess noti -> case pickHandler dynNotHandlers notHandlers of - Just h -> liftIO $ h noti + Just h -> liftIO $ h noti Nothing -> reportMissingHandler ReqMess req -> case pickHandler dynReqHandlers reqHandlers of Just h -> liftIO $ h req (mkRspCb req) @@ -403,23 +475,24 @@ let errorMsg = T.pack $ unwords ["lsp:no handler for: ", show m] err = ResponseError (InR ErrorCodes_MethodNotFound) errorMsg Nothing sendToClient $ - FromServerRsp (req ^. L.method) $ TResponseMessage "2.0" (Just (req ^. L.id)) (Left err) - where - -- | Checks to see if there's a dynamic handler, and uses it in favour of the - -- static handler, if it exists. - pickHandler :: RegistrationMap t -> SMethodMap (ClientMessageHandler IO t) -> Maybe (Handler IO meth) - pickHandler dynHandlerMap staticHandler = case (SMethodMap.lookup m dynHandlerMap, SMethodMap.lookup m staticHandler) of - (Just (P.Pair _ (ClientMessageHandler h)), _) -> Just h - (Nothing, Just (ClientMessageHandler h)) -> Just h - (Nothing, Nothing) -> Nothing + FromServerRsp (req ^. L.method) $ + TResponseMessage "2.0" (Just (req ^. L.id)) (Left err) + where + -- \| Checks to see if there's a dynamic handler, and uses it in favour of the + -- static handler, if it exists. + pickHandler :: RegistrationMap t -> SMethodMap (ClientMessageHandler IO t) -> Maybe (Handler IO meth) + pickHandler dynHandlerMap staticHandler = case (SMethodMap.lookup m dynHandlerMap, SMethodMap.lookup m staticHandler) of + (Just (P.Pair _ (ClientMessageHandler h)), _) -> Just h + (Nothing, Just (ClientMessageHandler h)) -> Just h + (Nothing, Nothing) -> Nothing - -- '$/' notifications should/could be ignored by server. - -- Don't log errors in that case. - -- See https://microsoft.github.io/language-server-protocol/specifications/specification-current/#-notifications-and-requests. - reportMissingHandler :: m () - reportMissingHandler = - let optional = isOptionalMethod (SomeMethod m) - in logger <& MissingHandler optional m `WithSeverity` if optional then Warning else Error + -- '$/' notifications should/could be ignored by server. + -- Don't log errors in that case. + -- See https://microsoft.github.io/language-server-protocol/specifications/specification-current/#-notifications-and-requests. + reportMissingHandler :: m () + reportMissingHandler = + let optional = isOptionalMethod (SomeMethod m) + in logger <& MissingHandler optional m `WithSeverity` if optional then Warning else Error progressCancelHandler :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> TMessage Method_WindowWorkDoneProgressCancel -> m () progressCancelHandler logger (TNotificationMessage _ _ (WorkDoneProgressCancelParams tid)) = do @@ -440,10 +513,11 @@ shutdownRequestHandler _req k = do k $ Right Null --- | Try to find the configuration section in an object that might represent "all" the settings. --- The heuristic we use is to look for a property with the right name, and use that if we find --- it. Otherwise we fall back to the whole object. --- See Note [LSP configuration] +{- | Try to find the configuration section in an object that might represent "all" the settings. + The heuristic we use is to look for a property with the right name, and use that if we find + it. Otherwise we fall back to the whole object. + See Note [LSP configuration] +-} lookForConfigSection :: T.Text -> Value -> Value lookForConfigSection section (Object o) | Just s' <- o ^. at (fromString $ T.unpack section) = s' lookForConfigSection _ o = o @@ -464,12 +538,13 @@ tryChangeConfig (cmap (fmap LspCore) logger) (lookForConfigSection section $ req ^. L.params . L.settings) requestConfigUpdate (cmap (fmap LspCore) logger) -vfsFunc :: forall m n a config - . (m ~ LspM config, n ~ WriterT [WithSeverity VfsLog] (State VFS)) - => LogAction m (WithSeverity LspProcessingLog) - -> (LogAction n (WithSeverity VfsLog) -> a -> n ()) - -> a - -> m () +vfsFunc :: + forall m n a config. + (m ~ LspM config, n ~ WriterT [WithSeverity VfsLog] (State VFS)) => + LogAction m (WithSeverity LspProcessingLog) -> + (LogAction n (WithSeverity VfsLog) -> a -> n ()) -> + a -> + m () vfsFunc logger modifyVfs req = do -- This is an intricate dance. We want to run the VFS functions essentially in STM, that's -- what 'stateState' does. But we also want them to log. We accomplish this by exfiltrating @@ -479,11 +554,11 @@ -- DList here if we're worried about performance. logs <- stateState resVFS $ \(VFSData vfs rm) -> let (ls, vfs') = flip runState vfs $ execWriterT $ modifyVfs innerLogger req - in (ls, VFSData vfs' rm) + in (ls, VFSData vfs' rm) traverse_ (\l -> logger <& fmap VfsLog l) logs - where - innerLogger :: LogAction n (WithSeverity VfsLog) - innerLogger = LogAction $ \m -> tell [m] + where + innerLogger :: LogAction n (WithSeverity VfsLog) + innerLogger = LogAction $ \m -> tell [m] -- | Updates the list of workspace folders updateWorkspaceFolders :: TMessage Method_WorkspaceDidChangeWorkspaceFolders -> LspM config () diff --git a/src/Language/LSP/VFS.hs b/src/Language/LSP/VFS.hs --- a/src/Language/LSP/VFS.hs +++ b/src/Language/LSP/VFS.hs @@ -1,120 +1,121 @@ {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeInType #-} - {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} - +{-# LANGUAGE ViewPatterns #-} -- So we can keep using the old prettyprinter modules (which have a better -- compatibility range) for now. {-# OPTIONS_GHC -Wno-deprecations #-} -{-| +{- | Handles the "Language.LSP.Types.TextDocumentDidChange" \/ "Language.LSP.Types.TextDocumentDidOpen" \/ "Language.LSP.Types.TextDocumentDidClose" messages to keep an in-memory `filesystem` of the current client workspace. The server can access and edit files in the client workspace by operating on the "VFS" in "LspFuncs". -} -module Language.LSP.VFS - ( - VFS(..) - , vfsMap - , vfsTempDir - , VirtualFile(..) - , lsp_version - , file_version - , file_text - , virtualFileText - , virtualFileVersion - , VfsLog (..) +module Language.LSP.VFS ( + VFS (..), + vfsMap, + VirtualFile (..), + lsp_version, + file_version, + file_text, + virtualFileText, + virtualFileVersion, + VfsLog (..), + -- * Managing the VFS - , initVFS - , openVFS - , changeFromClientVFS - , changeFromServerVFS - , persistFileVFS - , closeVFS + emptyVFS, + openVFS, + changeFromClientVFS, + changeFromServerVFS, + persistFileVFS, + closeVFS, -- * Positions and transformations - , CodePointPosition (..) - , line - , character - , codePointPositionToPosition - , positionToCodePointPosition - , CodePointRange (..) - , start - , end - , codePointRangeToRange - , rangeToCodePointRange + CodePointPosition (..), + line, + character, + codePointPositionToPosition, + positionToCodePointPosition, + CodePointRange (..), + start, + end, + codePointRangeToRange, + rangeToCodePointRange, -- * manipulating the file contents - , rangeLinesFromVfs - , PosPrefixInfo(..) - , getCompletionPrefix + rangeLinesFromVfs, + PosPrefixInfo (..), + getCompletionPrefix, -- * for tests - , applyChanges - , applyChange - , changeChars - ) where + applyChanges, + applyChange, + changeChars, +) where -import Control.Lens hiding ( (<.>), parts ) -import Control.Monad -import Colog.Core (LogAction (..), WithSeverity (..), Severity (..), (<&)) -import Control.Monad.State -import Data.Char (isUpper, isAlphaNum) -import Data.Text ( Text ) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import Data.Int (Int32) -import Data.List -import Data.Row -import Data.Ord -import qualified Data.Map.Strict as Map -import Data.Maybe -import qualified Data.Text.Rope as URope -import Data.Text.Utf16.Rope ( Rope ) -import qualified Data.Text.Utf16.Rope as Rope -import Data.Text.Prettyprint.Doc hiding (line) -import qualified Language.LSP.Protocol.Types as J -import qualified Language.LSP.Protocol.Lens as J -import qualified Language.LSP.Protocol.Message as J -import System.FilePath -import Data.Hashable -import System.Directory -import System.IO -import System.IO.Temp +import Colog.Core (LogAction (..), Severity (..), WithSeverity (..), (<&)) +import Control.Lens hiding (parts, (<.>)) +import Control.Monad +import Control.Monad.State +import Data.Char (isAlphaNum, isUpper) import Data.Foldable (traverse_) +import Data.Hashable +import Data.Int (Int32) +import Data.List +import Data.Map.Strict qualified as Map +import Data.Maybe +import Data.Ord +import Data.Row +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.IO qualified as T +import Data.Text.Prettyprint.Doc hiding (line) +import Data.Text.Rope qualified as URope +import Data.Text.Utf16.Rope (Rope) +import Data.Text.Utf16.Rope qualified as Rope +import Language.LSP.Protocol.Lens qualified as J +import Language.LSP.Protocol.Message qualified as J +import Language.LSP.Protocol.Types qualified as J +import System.Directory +import System.FilePath +import System.IO -- --------------------------------------------------------------------- {-# ANN module ("hlint: ignore Eta reduce" :: String) #-} {-# ANN module ("hlint: ignore Redundant do" :: String) #-} + -- --------------------------------------------------------------------- -data VirtualFile = - VirtualFile { - _lsp_version :: !Int32 -- ^ The LSP version of the document - , _file_version :: !Int -- ^ This number is only incremented whilst the file - -- remains in the map. - , _file_text :: !Rope -- ^ The full contents of the document - } deriving (Show) +data VirtualFile = VirtualFile + { _lsp_version :: !Int32 + -- ^ The LSP version of the document + , _file_version :: !Int + -- ^ This number is only incremented whilst the file + -- remains in the map. + , _file_text :: !Rope + -- ^ The full contents of the document + } + deriving (Show) -data VFS = VFS { _vfsMap :: !(Map.Map J.NormalizedUri VirtualFile) - , _vfsTempDir :: !FilePath -- ^ This is where all the temporary files will be written to - } deriving Show +data VFS = VFS + { _vfsMap :: !(Map.Map J.NormalizedUri VirtualFile) + } + deriving (Show) -data VfsLog = - SplitInsideCodePoint Rope.Position Rope +data VfsLog + = SplitInsideCodePoint Rope.Position Rope | URINotFound J.NormalizedUri | Opening J.NormalizedUri | Closing J.NormalizedUri @@ -147,8 +148,8 @@ --- -initVFS :: (VFS -> IO r) -> IO r -initVFS k = withSystemTempDirectory "haskell-lsp" $ \temp_dir -> k (VFS mempty temp_dir) +emptyVFS :: VFS +emptyVFS = VFS mempty -- --------------------------------------------------------------------- @@ -180,51 +181,52 @@ applyCreateFile :: (MonadState VFS m) => J.CreateFile -> m () applyCreateFile (J.CreateFile _ann _kind (J.toNormalizedUri -> uri) options) = - vfsMap %= Map.insertWith - (\ new old -> if shouldOverwrite then new else old) - uri - (VirtualFile 0 0 mempty) - where - shouldOverwrite :: Bool - shouldOverwrite = case options of - Nothing -> False -- default - Just (J.CreateFileOptions Nothing Nothing ) -> False -- default - Just (J.CreateFileOptions Nothing (Just True) ) -> False -- `ignoreIfExists` is True - Just (J.CreateFileOptions Nothing (Just False)) -> True -- `ignoreIfExists` is False - Just (J.CreateFileOptions (Just True) Nothing ) -> True -- `overwrite` is True - Just (J.CreateFileOptions (Just True) (Just True) ) -> True -- `overwrite` wins over `ignoreIfExists` - Just (J.CreateFileOptions (Just True) (Just False)) -> True -- `overwrite` is True - Just (J.CreateFileOptions (Just False) Nothing ) -> False -- `overwrite` is False - Just (J.CreateFileOptions (Just False) (Just True) ) -> False -- `overwrite` is False - Just (J.CreateFileOptions (Just False) (Just False)) -> False -- `overwrite` wins over `ignoreIfExists` + vfsMap + %= Map.insertWith + (\new old -> if shouldOverwrite then new else old) + uri + (VirtualFile 0 0 mempty) + where + shouldOverwrite :: Bool + shouldOverwrite = case options of + Nothing -> False -- default + Just (J.CreateFileOptions Nothing Nothing) -> False -- default + Just (J.CreateFileOptions Nothing (Just True)) -> False -- `ignoreIfExists` is True + Just (J.CreateFileOptions Nothing (Just False)) -> True -- `ignoreIfExists` is False + Just (J.CreateFileOptions (Just True) Nothing) -> True -- `overwrite` is True + Just (J.CreateFileOptions (Just True) (Just True)) -> True -- `overwrite` wins over `ignoreIfExists` + Just (J.CreateFileOptions (Just True) (Just False)) -> True -- `overwrite` is True + Just (J.CreateFileOptions (Just False) Nothing) -> False -- `overwrite` is False + Just (J.CreateFileOptions (Just False) (Just True)) -> False -- `overwrite` is False + Just (J.CreateFileOptions (Just False) (Just False)) -> False -- `overwrite` wins over `ignoreIfExists` applyRenameFile :: (MonadState VFS m) => J.RenameFile -> m () applyRenameFile (J.RenameFile _ann _kind (J.toNormalizedUri -> oldUri) (J.toNormalizedUri -> newUri) options) = do vfs <- get case vfs ^. vfsMap . at oldUri of - -- nothing to rename - Nothing -> pure () - Just file -> case vfs ^. vfsMap . at newUri of - -- the target does not exist, just move over - Nothing -> do - vfsMap . at oldUri .= Nothing - vfsMap . at newUri .= Just file - Just _ -> when shouldOverwrite $ do - vfsMap . at oldUri .= Nothing - vfsMap . at newUri .= Just file - where - shouldOverwrite :: Bool - shouldOverwrite = case options of - Nothing -> False -- default - Just (J.RenameFileOptions Nothing Nothing ) -> False -- default - Just (J.RenameFileOptions Nothing (Just True) ) -> False -- `ignoreIfExists` is True - Just (J.RenameFileOptions Nothing (Just False)) -> True -- `ignoreIfExists` is False - Just (J.RenameFileOptions (Just True) Nothing ) -> True -- `overwrite` is True - Just (J.RenameFileOptions (Just True) (Just True) ) -> True -- `overwrite` wins over `ignoreIfExists` - Just (J.RenameFileOptions (Just True) (Just False)) -> True -- `overwrite` is True - Just (J.RenameFileOptions (Just False) Nothing ) -> False -- `overwrite` is False - Just (J.RenameFileOptions (Just False) (Just True) ) -> False -- `overwrite` is False - Just (J.RenameFileOptions (Just False) (Just False)) -> False -- `overwrite` wins over `ignoreIfExists` + -- nothing to rename + Nothing -> pure () + Just file -> case vfs ^. vfsMap . at newUri of + -- the target does not exist, just move over + Nothing -> do + vfsMap . at oldUri .= Nothing + vfsMap . at newUri .= Just file + Just _ -> when shouldOverwrite $ do + vfsMap . at oldUri .= Nothing + vfsMap . at newUri .= Just file + where + shouldOverwrite :: Bool + shouldOverwrite = case options of + Nothing -> False -- default + Just (J.RenameFileOptions Nothing Nothing) -> False -- default + Just (J.RenameFileOptions Nothing (Just True)) -> False -- `ignoreIfExists` is True + Just (J.RenameFileOptions Nothing (Just False)) -> True -- `ignoreIfExists` is False + Just (J.RenameFileOptions (Just True) Nothing) -> True -- `overwrite` is True + Just (J.RenameFileOptions (Just True) (Just True)) -> True -- `overwrite` wins over `ignoreIfExists` + Just (J.RenameFileOptions (Just True) (Just False)) -> True -- `overwrite` is True + Just (J.RenameFileOptions (Just False) Nothing) -> False -- `overwrite` is False + Just (J.RenameFileOptions (Just False) (Just True)) -> False -- `overwrite` is False + Just (J.RenameFileOptions (Just False) (Just False)) -> False -- `overwrite` wins over `ignoreIfExists` applyDeleteFile :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.DeleteFile -> m () applyDeleteFile logger (J.DeleteFile _ann _kind (J.toNormalizedUri -> uri) options) = do @@ -236,8 +238,9 @@ case old of -- It's not entirely clear what the semantics of 'ignoreIfNotExists' are, but if it -- doesn't exist and we're not ignoring it, let's at least log it. - Nothing | options ^? _Just . J.ignoreIfNotExists . _Just /= Just True -> - logger <& CantRecursiveDelete uri `WithSeverity` Warning + Nothing + | options ^? _Just . J.ignoreIfNotExists . _Just /= Just True -> + logger <& CantRecursiveDelete uri `WithSeverity` Warning _ -> pure () applyTextDocumentEdit :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.TextDocumentEdit -> m () @@ -247,28 +250,27 @@ let sortedEdits = sortOn (Down . editRange) edits changeEvents = map editToChangeEvent sortedEdits -- TODO: is this right? - vid' = J.VersionedTextDocumentIdentifier (vid ^. J.uri) (case vid ^. J.version of {J.InL v -> v; J.InR _ -> 0}) + vid' = J.VersionedTextDocumentIdentifier (vid ^. J.uri) (case vid ^. J.version of J.InL v -> v; J.InR _ -> 0) ps = J.DidChangeTextDocumentParams vid' changeEvents notif = J.TNotificationMessage "" J.SMethod_TextDocumentDidChange ps changeFromClientVFS logger notif - - where - editRange :: J.TextEdit J.|? J.AnnotatedTextEdit -> J.Range - editRange (J.InR e) = e ^. J.range - editRange (J.InL e) = e ^. J.range + where + editRange :: J.TextEdit J.|? J.AnnotatedTextEdit -> J.Range + editRange (J.InR e) = e ^. J.range + editRange (J.InL e) = e ^. J.range - editToChangeEvent :: J.TextEdit J.|? J.AnnotatedTextEdit -> J.TextDocumentContentChangeEvent - editToChangeEvent (J.InR e) = J.TextDocumentContentChangeEvent $ J.InL $ #range .== e ^. J.range .+ #rangeLength .== Nothing .+ #text .== e ^. J.newText - editToChangeEvent (J.InL e) = J.TextDocumentContentChangeEvent $ J.InL $ #range .== e ^. J.range .+ #rangeLength .== Nothing .+ #text .== e ^. J.newText + editToChangeEvent :: J.TextEdit J.|? J.AnnotatedTextEdit -> J.TextDocumentContentChangeEvent + editToChangeEvent (J.InR e) = J.TextDocumentContentChangeEvent $ J.InL $ #range .== e ^. J.range .+ #rangeLength .== Nothing .+ #text .== e ^. J.newText + editToChangeEvent (J.InL e) = J.TextDocumentContentChangeEvent $ J.InL $ #range .== e ^. J.range .+ #rangeLength .== Nothing .+ #text .== e ^. J.newText applyDocumentChange :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.DocumentChange -> m () -applyDocumentChange logger (J.InL change) = applyTextDocumentEdit logger change -applyDocumentChange _ (J.InR (J.InL change)) = applyCreateFile change -applyDocumentChange _ (J.InR (J.InR (J.InL change))) = applyRenameFile change +applyDocumentChange logger (J.InL change) = applyTextDocumentEdit logger change +applyDocumentChange _ (J.InR (J.InL change)) = applyCreateFile change +applyDocumentChange _ (J.InR (J.InR (J.InL change))) = applyRenameFile change applyDocumentChange logger (J.InR (J.InR (J.InR change))) = applyDeleteFile logger change -- | Applies the changes from a 'ApplyWorkspaceEditRequest' to the 'VFS' -changeFromServerVFS :: forall m . MonadState VFS m => LogAction m (WithSeverity VfsLog) -> J.TMessage 'J.Method_WorkspaceApplyEdit -> m () +changeFromServerVFS :: forall m. MonadState VFS m => LogAction m (WithSeverity VfsLog) -> J.TMessage 'J.Method_WorkspaceApplyEdit -> m () changeFromServerVFS logger msg = do let J.ApplyWorkspaceEditParams _label edit = msg ^. J.params J.WorkspaceEdit mChanges mDocChanges _anns = edit @@ -277,20 +279,19 @@ Nothing -> case mChanges of Just cs -> applyDocumentChanges $ map J.InL $ Map.foldlWithKey' changeToTextDocumentEdit [] cs Nothing -> pure () - - where - changeToTextDocumentEdit acc uri edits = - acc ++ [J.TextDocumentEdit (J.OptionalVersionedTextDocumentIdentifier uri (J.InL 0)) (fmap J.InL edits)] + where + changeToTextDocumentEdit acc uri edits = + acc ++ [J.TextDocumentEdit (J.OptionalVersionedTextDocumentIdentifier uri (J.InL 0)) (fmap J.InL edits)] - applyDocumentChanges :: [J.DocumentChange] -> m () - applyDocumentChanges = traverse_ (applyDocumentChange logger) . sortOn project + applyDocumentChanges :: [J.DocumentChange] -> m () + applyDocumentChanges = traverse_ (applyDocumentChange logger) . sortOn project - -- for sorting [DocumentChange] - project :: J.DocumentChange -> Maybe J.Int32 - project (J.InL textDocumentEdit) = case textDocumentEdit ^. J.textDocument . J.version of - J.InL v -> Just v - _ -> Nothing - project _ = Nothing + -- for sorting [DocumentChange] + project :: J.DocumentChange -> Maybe J.Int32 + project (J.InL textDocumentEdit) = case textDocumentEdit ^. J.textDocument . J.version of + J.InL v -> Just v + _ -> Nothing + project _ = Nothing -- --------------------------------------------------------------------- virtualFileName :: FilePath -> J.NormalizedUri -> VirtualFile -> FilePath @@ -303,28 +304,28 @@ padLeft :: Int -> Int -> String padLeft n num = let numString = show num - in replicate (n - length numString) '0' ++ numString - in prefix basename ++ "-" ++ padLeft 5 file_ver ++ "-" ++ show (hash uri_raw) <.> takeExtensions basename + in replicate (n - length numString) '0' ++ numString + in prefix basename ++ "-" ++ padLeft 5 file_ver ++ "-" ++ show (hash uri_raw) <.> takeExtensions basename --- | Write a virtual file to a temporary file if it exists in the VFS. -persistFileVFS :: (MonadIO m) => LogAction m (WithSeverity VfsLog) -> VFS -> J.NormalizedUri -> Maybe (FilePath, m ()) -persistFileVFS logger vfs uri = +-- | Write a virtual file to a file in the given directory if it exists in the VFS. +persistFileVFS :: (MonadIO m) => LogAction m (WithSeverity VfsLog) -> FilePath -> VFS -> J.NormalizedUri -> Maybe (FilePath, m ()) +persistFileVFS logger dir vfs uri = case vfs ^. vfsMap . at uri of Nothing -> Nothing Just vf -> - let tfn = virtualFileName (vfs ^. vfsTempDir) uri vf + let tfn = virtualFileName dir uri vf action = do exists <- liftIO $ doesFileExist tfn unless exists $ do - let contents = Rope.toText (_file_text vf) - writeRaw h = do + let contents = Rope.toText (_file_text vf) + writeRaw h = do -- We honour original file line endings hSetNewlineMode h noNewlineTranslation hSetEncoding h utf8 T.hPutStr h contents - logger <& PersistingFile uri tfn `WithSeverity` Debug - liftIO $ withFile tfn WriteMode writeRaw - in Just (tfn, action) + logger <& PersistingFile uri tfn `WithSeverity` Debug + liftIO $ withFile tfn WriteMode writeRaw + in Just (tfn, action) -- --------------------------------------------------------------------- @@ -336,52 +337,60 @@ -- --------------------------------------------------------------------- --- | Apply the list of changes. --- Changes should be applied in the order that they are --- received from the client. +{- | Apply the list of changes. + Changes should be applied in the order that they are + received from the client. +-} applyChanges :: (Monad m) => LogAction m (WithSeverity VfsLog) -> Rope -> [J.TextDocumentContentChangeEvent] -> m Rope applyChanges logger = foldM (applyChange logger) -- --------------------------------------------------------------------- applyChange :: (Monad m) => LogAction m (WithSeverity VfsLog) -> Rope -> J.TextDocumentContentChangeEvent -> m Rope -applyChange logger str (J.TextDocumentContentChangeEvent (J.InL e)) | J.Range (J.Position sl sc) (J.Position fl fc) <- e .! #range, txt <- e .! #text - = changeChars logger str (Rope.Position (fromIntegral sl) (fromIntegral sc)) (Rope.Position (fromIntegral fl) (fromIntegral fc)) txt -applyChange _ _ (J.TextDocumentContentChangeEvent (J.InR e)) - = pure $ Rope.fromText $ e .! #text +applyChange logger str (J.TextDocumentContentChangeEvent (J.InL e)) + | J.Range (J.Position sl sc) (J.Position fl fc) <- e .! #range + , txt <- e .! #text = + changeChars logger str (Rope.Position (fromIntegral sl) (fromIntegral sc)) (Rope.Position (fromIntegral fl) (fromIntegral fc)) txt +applyChange _ _ (J.TextDocumentContentChangeEvent (J.InR e)) = + pure $ Rope.fromText $ e .! #text -- --------------------------------------------------------------------- --- | Given a 'Rope', start and end positions, and some new text, replace --- the given range with the new text. If the given positions lie within --- a code point then this does nothing (returns the original 'Rope') and logs. +{- | Given a 'Rope', start and end positions, and some new text, replace + the given range with the new text. If the given positions lie within + a code point then this does nothing (returns the original 'Rope') and logs. +-} changeChars :: (Monad m) => LogAction m (WithSeverity VfsLog) -> Rope -> Rope.Position -> Rope.Position -> Text -> m Rope changeChars logger str start finish new = do - case Rope.splitAtPosition finish str of - Nothing -> logger <& SplitInsideCodePoint finish str `WithSeverity` Warning >> pure str - Just (before, after) -> case Rope.splitAtPosition start before of - Nothing -> logger <& SplitInsideCodePoint start before `WithSeverity` Warning >> pure str - Just (before', _) -> pure $ mconcat [before', Rope.fromText new, after] + case Rope.splitAtPosition finish str of + Nothing -> logger <& SplitInsideCodePoint finish str `WithSeverity` Warning >> pure str + Just (before, after) -> case Rope.splitAtPosition start before of + Nothing -> logger <& SplitInsideCodePoint start before `WithSeverity` Warning >> pure str + Just (before', _) -> pure $ mconcat [before', Rope.fromText new, after] -- --------------------------------------------------------------------- --- | A position, like a 'J.Position', but where the offsets in the line are measured in --- Unicode code points instead of UTF-16 code units. -data CodePointPosition = - CodePointPosition - { -- | Line position in a document (zero-based). - _line :: J.UInt - -- | Character offset on a line in a document in *code points* (zero-based). - , _character :: J.UInt - } deriving (Show, Read, Eq, Ord) +{- | A position, like a 'J.Position', but where the offsets in the line are measured in + Unicode code points instead of UTF-16 code units. +-} +data CodePointPosition = CodePointPosition + { _line :: J.UInt + -- ^ Line position in a document (zero-based). + , _character :: J.UInt + -- ^ Character offset on a line in a document in *code points* (zero-based). + } + deriving (Show, Read, Eq, Ord) --- | A range, like a 'J.Range', but where the offsets in the line are measured in --- Unicode code points instead of UTF-16 code units. -data CodePointRange = - CodePointRange - { _start :: CodePointPosition -- ^ The range's start position. - , _end :: CodePointPosition -- ^ The range's end position. - } deriving (Show, Read, Eq, Ord) +{- | A range, like a 'J.Range', but where the offsets in the line are measured in + Unicode code points instead of UTF-16 code units. +-} +data CodePointRange = CodePointRange + { _start :: CodePointPosition + -- ^ The range's start position. + , _end :: CodePointPosition + -- ^ The range's end position. + } + deriving (Show, Read, Eq, Ord) makeFieldsNoPrefix ''CodePointPosition makeFieldsNoPrefix ''CodePointRange @@ -400,8 +409,9 @@ line. Which is okay-ish, so long as we don't have very long lines. -} --- | Extracts a specific line from a 'Rope.Rope'. --- Logarithmic in the number of lines. +{- | Extracts a specific line from a 'Rope.Rope'. + Logarithmic in the number of lines. +-} extractLine :: Rope.Rope -> Word -> Maybe Rope.Rope extractLine rope l = do -- Check for the line being out of bounds @@ -412,8 +422,9 @@ (prefix, _) = Rope.splitAtLine 1 suffix pure prefix --- | Translate a code-point offset into a code-unit offset. --- Linear in the length of the rope. +{- | Translate a code-point offset into a code-unit offset. + Linear in the length of the rope. +-} codePointOffsetToCodeUnitOffset :: URope.Rope -> Word -> Maybe Word codePointOffsetToCodeUnitOffset rope offset = do -- Check for the position being out of bounds @@ -422,11 +433,12 @@ let (prefix, _) = URope.splitAt offset rope -- Convert the prefix to a rope using *code units* utf16Prefix = Rope.fromText $ URope.toText prefix - -- Get the length of the prefix in *code units* + -- Get the length of the prefix in *code units* pure $ Rope.length utf16Prefix --- | Translate a UTF-16 code-unit offset into a code-point offset. --- Linear in the length of the rope. +{- | Translate a UTF-16 code-unit offset into a code-point offset. + Linear in the length of the rope. +-} codeUnitOffsetToCodePointOffset :: Rope.Rope -> Word -> Maybe Word codeUnitOffsetToCodePointOffset rope offset = do -- Check for the position being out of bounds @@ -435,15 +447,16 @@ (prefix, _) <- Rope.splitAt offset rope -- Convert the prefix to a rope using *code points* let utfPrefix = URope.fromText $ Rope.toText prefix - -- Get the length of the prefix in *code points* + -- Get the length of the prefix in *code points* pure $ URope.length utfPrefix --- | Given a virtual file, translate a 'CodePointPosition' in that file into a 'J.Position' in that file. --- --- Will return 'Nothing' if the requested position is out of bounds of the document. --- --- Logarithmic in the number of lines in the document, and linear in the length of the line containing --- the position. +{- | Given a virtual file, translate a 'CodePointPosition' in that file into a 'J.Position' in that file. + + Will return 'Nothing' if the requested position is out of bounds of the document. + + Logarithmic in the number of lines in the document, and linear in the length of the line containing + the position. +-} codePointPositionToPosition :: VirtualFile -> CodePointPosition -> Maybe J.Position codePointPositionToPosition vFile (CodePointPosition l cpc) = do -- See Note [Converting between code points and code units] @@ -455,22 +468,24 @@ cuc <- codePointOffsetToCodeUnitOffset utfLine (fromIntegral cpc) pure $ J.Position l (fromIntegral cuc) --- | Given a virtual file, translate a 'CodePointRange' in that file into a 'J.Range' in that file. --- --- Will return 'Nothing' if any of the positions are out of bounds of the document. --- --- Logarithmic in the number of lines in the document, and linear in the length of the lines containing --- the positions. +{- | Given a virtual file, translate a 'CodePointRange' in that file into a 'J.Range' in that file. + + Will return 'Nothing' if any of the positions are out of bounds of the document. + + Logarithmic in the number of lines in the document, and linear in the length of the lines containing + the positions. +-} codePointRangeToRange :: VirtualFile -> CodePointRange -> Maybe J.Range codePointRangeToRange vFile (CodePointRange b e) = J.Range <$> codePointPositionToPosition vFile b <*> codePointPositionToPosition vFile e --- | Given a virtual file, translate a 'J.Position' in that file into a 'CodePointPosition' in that file. --- --- Will return 'Nothing' if the requested position lies inside a code point, or if it is out of bounds of the document. --- --- Logarithmic in the number of lines in the document, and linear in the length of the line containing --- the position. +{- | Given a virtual file, translate a 'J.Position' in that file into a 'CodePointPosition' in that file. + + Will return 'Nothing' if the requested position lies inside a code point, or if it is out of bounds of the document. + + Logarithmic in the number of lines in the document, and linear in the length of the line containing + the position. +-} positionToCodePointPosition :: VirtualFile -> J.Position -> Maybe CodePointPosition positionToCodePointPosition vFile (J.Position l cuc) = do -- See Note [Converting between code points and code units] @@ -480,12 +495,13 @@ cpc <- codeUnitOffsetToCodePointOffset utf16Line (fromIntegral cuc) pure $ CodePointPosition l (fromIntegral cpc) --- | Given a virtual file, translate a 'J.Range' in that file into a 'CodePointRange' in that file. --- --- Will return 'Nothing' if any of the positions are out of bounds of the document. --- --- Logarithmic in the number of lines in the document, and linear in the length of the lines containing --- the positions. +{- | Given a virtual file, translate a 'J.Range' in that file into a 'CodePointRange' in that file. + + Will return 'Nothing' if any of the positions are out of bounds of the document. + + Logarithmic in the number of lines in the document, and linear in the length of the lines containing + the positions. +-} rangeToCodePointRange :: VirtualFile -> J.Range -> Maybe CodePointRange rangeToCodePointRange vFile (J.Range b e) = CodePointRange <$> positionToCodePointPosition vFile b <*> positionToCodePointPosition vFile e @@ -493,55 +509,61 @@ -- --------------------------------------------------------------------- -- TODO:AZ:move this to somewhere sane + -- | Describes the line at the current cursor position data PosPrefixInfo = PosPrefixInfo { fullLine :: !T.Text - -- ^ The full contents of the line the cursor is at - + -- ^ The full contents of the line the cursor is at , prefixModule :: !T.Text - -- ^ If any, the module name that was typed right before the cursor position. - -- For example, if the user has typed "Data.Maybe.from", then this property - -- will be "Data.Maybe" - + -- ^ If any, the module name that was typed right before the cursor position. + -- For example, if the user has typed "Data.Maybe.from", then this property + -- will be "Data.Maybe" , prefixText :: !T.Text - -- ^ The word right before the cursor position, after removing the module part. - -- For example if the user has typed "Data.Maybe.from", - -- then this property will be "from" + -- ^ The word right before the cursor position, after removing the module part. + -- For example if the user has typed "Data.Maybe.from", + -- then this property will be "from" , cursorPos :: !J.Position - -- ^ The cursor position - } deriving (Show,Eq) + -- ^ The cursor position + } + deriving (Show, Eq) getCompletionPrefix :: (Monad m) => J.Position -> VirtualFile -> m (Maybe PosPrefixInfo) getCompletionPrefix pos@(J.Position l c) (VirtualFile _ _ ropetext) = - return $ Just $ fromMaybe (PosPrefixInfo "" "" "" pos) $ do -- Maybe monad - let lastMaybe [] = Nothing - lastMaybe xs = Just $ last xs + return $ Just $ fromMaybe (PosPrefixInfo "" "" "" pos) $ do + -- Maybe monad + let lastMaybe [] = Nothing + lastMaybe xs = Just $ last xs - let curRope = fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (fromIntegral l) ropetext - beforePos <- Rope.toText . fst <$> Rope.splitAt (fromIntegral c) curRope - curWord <- - if | T.null beforePos -> Just "" - | T.last beforePos == ' ' -> Just "" -- don't count abc as the curword in 'abc ' - | otherwise -> lastMaybe (T.words beforePos) + let curRope = fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (fromIntegral l) ropetext + beforePos <- Rope.toText . fst <$> Rope.splitAt (fromIntegral c) curRope + curWord <- + if + | T.null beforePos -> Just "" + | T.last beforePos == ' ' -> Just "" -- don't count abc as the curword in 'abc ' + | otherwise -> lastMaybe (T.words beforePos) - let parts = T.split (=='.') - $ T.takeWhileEnd (\x -> isAlphaNum x || x `elem` ("._'"::String)) curWord - case reverse parts of - [] -> Nothing - (x:xs) -> do - let modParts = dropWhile (not . isUpper . T.head) - $ reverse $ filter (not .T.null) xs - modName = T.intercalate "." modParts - -- curRope is already a single line, but it may include an enclosing '\n' - let curLine = T.dropWhileEnd (== '\n') $ Rope.toText curRope - return $ PosPrefixInfo curLine modName x pos + let parts = + T.split (== '.') $ + T.takeWhileEnd (\x -> isAlphaNum x || x `elem` ("._'" :: String)) curWord + case reverse parts of + [] -> Nothing + (x : xs) -> do + let modParts = + dropWhile (not . isUpper . T.head) $ + reverse $ + filter (not . T.null) xs + modName = T.intercalate "." modParts + -- curRope is already a single line, but it may include an enclosing '\n' + let curLine = T.dropWhileEnd (== '\n') $ Rope.toText curRope + return $ PosPrefixInfo curLine modName x pos -- --------------------------------------------------------------------- rangeLinesFromVfs :: VirtualFile -> J.Range -> T.Text rangeLinesFromVfs (VirtualFile _ _ ropetext) (J.Range (J.Position lf _cf) (J.Position lt _ct)) = r - where - (_ ,s1) = Rope.splitAtLine (fromIntegral lf) ropetext - (s2, _) = Rope.splitAtLine (fromIntegral (lt - lf)) s1 - r = Rope.toText s2 + where + (_, s1) = Rope.splitAtLine (fromIntegral lf) ropetext + (s2, _) = Rope.splitAtLine (fromIntegral (lt - lf)) s1 + r = Rope.toText s2 + -- --------------------------------------------------------------------- diff --git a/test/DiagnosticsSpec.hs b/test/DiagnosticsSpec.hs --- a/test/DiagnosticsSpec.hs +++ b/test/DiagnosticsSpec.hs @@ -1,17 +1,17 @@ {-# LANGUAGE OverloadedStrings #-} -module DiagnosticsSpec where +module DiagnosticsSpec where -import qualified Data.Map as Map -import qualified Data.HashMap.Strict as HM -import qualified Data.SortedList as SL -import Data.Text (Text) -import Language.LSP.Diagnostics -import qualified Language.LSP.Protocol.Types as LSP +import Data.HashMap.Strict qualified as HM +import Data.Map qualified as Map +import Data.SortedList qualified as SL +import Data.Text (Text) +import Language.LSP.Diagnostics +import Language.LSP.Protocol.Types qualified as LSP -import Test.Hspec +import Test.Hspec -{-# ANN module ("HLint: ignore Redundant do" :: String) #-} +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} -- --------------------------------------------------------------------- @@ -34,7 +34,7 @@ let rng = LSP.Range (LSP.Position 0 1) (LSP.Position 3 0) loc = LSP.Location (LSP.Uri "file") rng - in + in LSP.Diagnostic rng Nothing Nothing Nothing ms str Nothing (Just [LSP.DiagnosticRelatedInformation loc str]) Nothing mkDiagnostic2 :: Maybe Text -> Text -> LSP.Diagnostic @@ -42,7 +42,8 @@ let rng = LSP.Range (LSP.Position 4 1) (LSP.Position 5 0) loc = LSP.Location (LSP.Uri "file") rng - in LSP.Diagnostic rng Nothing Nothing Nothing ms str Nothing (Just [LSP.DiagnosticRelatedInformation loc str]) Nothing + in + LSP.Diagnostic rng Nothing Nothing Nothing ms str Nothing (Just [LSP.DiagnosticRelatedInformation loc str]) Nothing -- --------------------------------------------------------------------- @@ -56,9 +57,9 @@ , mkDiagnostic (Just "hlint") "b" ] uri = LSP.toNormalizedUri $ LSP.Uri "uri" - (updateDiagnostics HM.empty uri Nothing (partitionBySource diags)) `shouldBe` - HM.fromList - [ (uri,StoreItem Nothing $ Map.fromList [(Just "hlint", SL.toSortedList diags) ] ) + (updateDiagnostics HM.empty uri Nothing (partitionBySource diags)) + `shouldBe` HM.fromList + [ (uri, StoreItem Nothing $ Map.fromList [(Just "hlint", SL.toSortedList diags)]) ] -- --------------------------------- @@ -70,12 +71,16 @@ , mkDiagnostic (Just "ghcmod") "b" ] uri = LSP.toNormalizedUri $ LSP.Uri "uri" - (updateDiagnostics HM.empty uri Nothing (partitionBySource diags)) `shouldBe` - HM.fromList - [ (uri,StoreItem Nothing $ Map.fromList - [(Just "hlint", SL.singleton (mkDiagnostic (Just "hlint") "a")) - ,(Just "ghcmod", SL.singleton (mkDiagnostic (Just "ghcmod") "b")) - ]) + (updateDiagnostics HM.empty uri Nothing (partitionBySource diags)) + `shouldBe` HM.fromList + [ + ( uri + , StoreItem Nothing $ + Map.fromList + [ (Just "hlint", SL.singleton (mkDiagnostic (Just "hlint") "a")) + , (Just "ghcmod", SL.singleton (mkDiagnostic (Just "ghcmod") "b")) + ] + ) ] -- --------------------------------- @@ -87,15 +92,19 @@ , mkDiagnostic (Just "ghcmod") "b" ] uri = LSP.toNormalizedUri $ LSP.Uri "uri" - (updateDiagnostics HM.empty uri (Just 1) (partitionBySource diags)) `shouldBe` - HM.fromList - [ (uri,StoreItem (Just 1) $ Map.fromList - [(Just "hlint", SL.singleton (mkDiagnostic (Just "hlint") "a")) - ,(Just "ghcmod", SL.singleton (mkDiagnostic (Just "ghcmod") "b")) - ]) + (updateDiagnostics HM.empty uri (Just 1) (partitionBySource diags)) + `shouldBe` HM.fromList + [ + ( uri + , StoreItem (Just 1) $ + Map.fromList + [ (Just "hlint", SL.singleton (mkDiagnostic (Just "hlint") "a")) + , (Just "ghcmod", SL.singleton (mkDiagnostic (Just "ghcmod") "b")) + ] + ) ] - -- --------------------------------- + -- --------------------------------- describe "updates a store for same document version" $ do it "updates a store without a document version, single source only" $ do @@ -109,9 +118,9 @@ ] uri = LSP.toNormalizedUri $ LSP.Uri "uri" let origStore = updateDiagnostics HM.empty uri Nothing (partitionBySource diags1) - (updateDiagnostics origStore uri Nothing (partitionBySource diags2)) `shouldBe` - HM.fromList - [ (uri,StoreItem Nothing $ Map.fromList [(Just "hlint", SL.toSortedList diags2) ] ) + (updateDiagnostics origStore uri Nothing (partitionBySource diags2)) + `shouldBe` HM.fromList + [ (uri, StoreItem Nothing $ Map.fromList [(Just "hlint", SL.toSortedList diags2)]) ] -- --------------------------------- @@ -127,12 +136,16 @@ ] uri = LSP.toNormalizedUri $ LSP.Uri "uri" let origStore = updateDiagnostics HM.empty uri Nothing (partitionBySource diags1) - (updateDiagnostics origStore uri Nothing (partitionBySource diags2)) `shouldBe` - HM.fromList - [ (uri,StoreItem Nothing $ Map.fromList - [(Just "hlint", SL.singleton (mkDiagnostic (Just "hlint") "a2")) - ,(Just "ghcmod", SL.singleton (mkDiagnostic (Just "ghcmod") "b1")) - ] ) + (updateDiagnostics origStore uri Nothing (partitionBySource diags2)) + `shouldBe` HM.fromList + [ + ( uri + , StoreItem Nothing $ + Map.fromList + [ (Just "hlint", SL.singleton (mkDiagnostic (Just "hlint") "a2")) + , (Just "ghcmod", SL.singleton (mkDiagnostic (Just "ghcmod") "b1")) + ] + ) ] -- --------------------------------- @@ -145,16 +158,19 @@ ] uri = LSP.toNormalizedUri $ LSP.Uri "uri" let origStore = updateDiagnostics HM.empty uri Nothing (partitionBySource diags1) - (updateDiagnostics origStore uri Nothing (Map.fromList [(Just "ghcmod",SL.toSortedList [])])) `shouldBe` - HM.fromList - [ (uri,StoreItem Nothing $ Map.fromList - [(Just "ghcmod", SL.toSortedList []) - ,(Just "hlint", SL.singleton (mkDiagnostic (Just "hlint") "a1")) - ] ) + (updateDiagnostics origStore uri Nothing (Map.fromList [(Just "ghcmod", SL.toSortedList [])])) + `shouldBe` HM.fromList + [ + ( uri + , StoreItem Nothing $ + Map.fromList + [ (Just "ghcmod", SL.toSortedList []) + , (Just "hlint", SL.singleton (mkDiagnostic (Just "hlint") "a1")) + ] + ) ] - - -- --------------------------------- + -- --------------------------------- describe "updates a store for a new document version" $ do it "updates a store without a document version, single source only" $ do @@ -168,9 +184,9 @@ ] uri = LSP.toNormalizedUri $ LSP.Uri "uri" let origStore = updateDiagnostics HM.empty uri (Just 1) (partitionBySource diags1) - (updateDiagnostics origStore uri (Just 2) (partitionBySource diags2)) `shouldBe` - HM.fromList - [ (uri,StoreItem (Just 2) $ Map.fromList [(Just "hlint", SL.toSortedList diags2) ] ) + (updateDiagnostics origStore uri (Just 2) (partitionBySource diags2)) + `shouldBe` HM.fromList + [ (uri, StoreItem (Just 2) $ Map.fromList [(Just "hlint", SL.toSortedList diags2)]) ] -- --------------------------------- @@ -186,17 +202,20 @@ ] uri = LSP.toNormalizedUri $ LSP.Uri "uri" let origStore = updateDiagnostics HM.empty uri (Just 1) (partitionBySource diags1) - (updateDiagnostics origStore uri (Just 2) (partitionBySource diags2)) `shouldBe` - HM.fromList - [ (uri,StoreItem (Just 2) $ Map.fromList - [(Just "hlint", SL.singleton (mkDiagnostic (Just "hlint") "a2")) - ] ) + (updateDiagnostics origStore uri (Just 2) (partitionBySource diags2)) + `shouldBe` HM.fromList + [ + ( uri + , StoreItem (Just 2) $ + Map.fromList + [ (Just "hlint", SL.singleton (mkDiagnostic (Just "hlint") "a2")) + ] + ) ] - -- --------------------------------- + -- --------------------------------- describe "retrieves all the diagnostics for a given uri" $ do - it "gets diagnostics for multiple sources" $ do let diags = @@ -205,65 +224,75 @@ ] uri = LSP.toNormalizedUri $ LSP.Uri "uri" let ds = updateDiagnostics HM.empty uri (Just 1) (partitionBySource diags) - getDiagnosticParamsFor 10 ds uri `shouldBe` - Just (LSP.PublishDiagnosticsParams (LSP.fromNormalizedUri uri) (Just 1) (reverse diags)) + getDiagnosticParamsFor 10 ds uri + `shouldBe` Just (LSP.PublishDiagnosticsParams (LSP.fromNormalizedUri uri) (Just 1) (reverse diags)) - -- --------------------------------- + -- --------------------------------- describe "limits the number of diagnostics retrieved, in order" $ do - it "gets diagnostics for multiple sources" $ do let diags = [ mkDiagnostic2 (Just "hlint") "a" , mkDiagnostic2 (Just "ghcmod") "b" - , mkDiagnostic (Just "hlint") "c" - , mkDiagnostic (Just "ghcmod") "d" + , mkDiagnostic (Just "hlint") "c" + , mkDiagnostic (Just "ghcmod") "d" ] uri = LSP.toNormalizedUri $ LSP.Uri "uri" let ds = updateDiagnostics HM.empty uri (Just 1) (partitionBySource diags) - getDiagnosticParamsFor 2 ds uri `shouldBe` - Just (LSP.PublishDiagnosticsParams (LSP.fromNormalizedUri uri) (Just 1) - [ - mkDiagnostic (Just "ghcmod") "d" - , mkDiagnostic (Just "hlint") "c" - ]) + getDiagnosticParamsFor 2 ds uri + `shouldBe` Just + ( LSP.PublishDiagnosticsParams + (LSP.fromNormalizedUri uri) + (Just 1) + [ mkDiagnostic (Just "ghcmod") "d" + , mkDiagnostic (Just "hlint") "c" + ] + ) - getDiagnosticParamsFor 1 ds uri `shouldBe` - Just (LSP.PublishDiagnosticsParams (LSP.fromNormalizedUri uri) (Just 1) - [ - mkDiagnostic (Just "ghcmod") "d" - ]) + getDiagnosticParamsFor 1 ds uri + `shouldBe` Just + ( LSP.PublishDiagnosticsParams + (LSP.fromNormalizedUri uri) + (Just 1) + [ mkDiagnostic (Just "ghcmod") "d" + ] + ) - -- --------------------------------- + -- --------------------------------- describe "flushes the diagnostics for a given source" $ do - it "gets diagnostics for multiple sources" $ do let diags = [ mkDiagnostic2 (Just "hlint") "a" , mkDiagnostic2 (Just "ghcmod") "b" - , mkDiagnostic (Just "hlint") "c" - , mkDiagnostic (Just "ghcmod") "d" + , mkDiagnostic (Just "hlint") "c" + , mkDiagnostic (Just "ghcmod") "d" ] uri = LSP.toNormalizedUri $ LSP.Uri "uri" let ds = updateDiagnostics HM.empty uri (Just 1) (partitionBySource diags) - getDiagnosticParamsFor 100 ds uri `shouldBe` - Just (LSP.PublishDiagnosticsParams (LSP.fromNormalizedUri uri) (Just 1) - [ - mkDiagnostic (Just "ghcmod") "d" - , mkDiagnostic (Just "hlint") "c" + getDiagnosticParamsFor 100 ds uri + `shouldBe` Just + ( LSP.PublishDiagnosticsParams + (LSP.fromNormalizedUri uri) + (Just 1) + [ mkDiagnostic (Just "ghcmod") "d" + , mkDiagnostic (Just "hlint") "c" , mkDiagnostic2 (Just "ghcmod") "b" , mkDiagnostic2 (Just "hlint") "a" - ]) + ] + ) let ds' = flushBySource ds (Just "hlint") - getDiagnosticParamsFor 100 ds' uri `shouldBe` - Just (LSP.PublishDiagnosticsParams (LSP.fromNormalizedUri uri) (Just 1) - [ - mkDiagnostic (Just "ghcmod") "d" + getDiagnosticParamsFor 100 ds' uri + `shouldBe` Just + ( LSP.PublishDiagnosticsParams + (LSP.fromNormalizedUri uri) + (Just 1) + [ mkDiagnostic (Just "ghcmod") "d" , mkDiagnostic2 (Just "ghcmod") "b" - ]) + ] + ) - -- --------------------------------- +-- --------------------------------- diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,7 +1,7 @@ module Main where +import Spec qualified import Test.Hspec.Runner -import qualified Spec main :: IO () main = hspec Spec.spec diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} + {- See https://github.com/hspec/hspec/tree/master/hspec-discover#readme diff --git a/test/VspSpec.hs b/test/VspSpec.hs --- a/test/VspSpec.hs +++ b/test/VspSpec.hs @@ -1,16 +1,17 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} + module VspSpec where -import Data.Row -import Data.String -import qualified Data.Text.Utf16.Rope as Rope -import Language.LSP.VFS -import qualified Language.LSP.Protocol.Types as J -import qualified Data.Text as T +import Data.Row +import Data.String +import Data.Text qualified as T +import Data.Text.Utf16.Rope qualified as Rope +import Language.LSP.Protocol.Types qualified as J +import Language.LSP.VFS -import Test.Hspec import Data.Functor.Identity +import Test.Hspec -- --------------------------------------------------------------------- @@ -50,27 +51,28 @@ it "handles vscode style redos" $ do let orig = "" changes = - [ - mkChangeEvent (J.mkRange 0 1 0 1) "a" + [ mkChangeEvent (J.mkRange 0 1 0 1) "a" , mkChangeEvent (J.mkRange 0 2 0 2) "b" , mkChangeEvent (J.mkRange 0 3 0 3) "c" ] applyChanges mempty orig changes `shouldBe` Identity "abc" - -- --------------------------------- + -- --------------------------------- describe "deletes characters" $ do it "deletes characters within a line" $ do -- based on vscode log let - orig = unlines - [ "abcdg" - , "module Foo where" - , "-- fooo" - , "foo :: Int" - ] + orig = + unlines + [ "abcdg" + , "module Foo where" + , "-- fooo" + , "foo :: Int" + ] new = applyChange mempty (fromString orig) $ mkChangeEvent (J.mkRange 2 1 2 5) "" - Rope.lines <$> new `shouldBe` Identity + Rope.lines <$> new + `shouldBe` Identity [ "abcdg" , "module Foo where" , "-oo" @@ -82,14 +84,16 @@ it "deletes one line" $ do -- based on vscode log let - orig = unlines - [ "abcdg" - , "module Foo where" - , "-- fooo" - , "foo :: Int" - ] + orig = + unlines + [ "abcdg" + , "module Foo where" + , "-- fooo" + , "foo :: Int" + ] new = applyChange mempty (fromString orig) $ mkChangeEvent (J.mkRange 2 0 3 0) "" - Rope.lines <$> new `shouldBe` Identity + Rope.lines <$> new + `shouldBe` Identity [ "abcdg" , "module Foo where" , "foo :: Int" @@ -100,31 +104,35 @@ it "deletes two lines" $ do -- based on vscode log let - orig = unlines - [ "module Foo where" - , "-- fooo" - , "foo :: Int" - , "foo = bb" - ] + orig = + unlines + [ "module Foo where" + , "-- fooo" + , "foo :: Int" + , "foo = bb" + ] new = applyChange mempty (fromString orig) $ mkChangeEvent (J.mkRange 1 0 3 0) "" - Rope.lines <$> new `shouldBe` Identity + Rope.lines <$> new + `shouldBe` Identity [ "module Foo where" , "foo = bb" ] - -- --------------------------------- + -- --------------------------------- describe "adds characters" $ do it "adds one line" $ do -- based on vscode log let - orig = unlines - [ "abcdg" - , "module Foo where" - , "foo :: Int" - ] + orig = + unlines + [ "abcdg" + , "module Foo where" + , "foo :: Int" + ] new = applyChange mempty (fromString orig) $ mkChangeEvent (J.mkRange 1 16 1 16) "\n-- fooo" - Rope.lines <$> new `shouldBe` Identity + Rope.lines <$> new + `shouldBe` Identity [ "abcdg" , "module Foo where" , "-- fooo" @@ -136,38 +144,42 @@ it "adds two lines" $ do -- based on vscode log let - orig = unlines - [ "module Foo where" - , "foo = bb" - ] + orig = + unlines + [ "module Foo where" + , "foo = bb" + ] new = applyChange mempty (fromString orig) $ mkChangeEvent (J.mkRange 1 8 1 8) "\n-- fooo\nfoo :: Int" - Rope.lines <$> new `shouldBe` Identity + Rope.lines <$> new + `shouldBe` Identity [ "module Foo where" , "foo = bb" , "-- fooo" , "foo :: Int" ] - -- --------------------------------- + -- --------------------------------- describe "changes characters" $ do it "removes end of a line" $ do -- based on vscode log let - orig = unlines - [ "module Foo where" - , "-- fooo" - , "foo :: Int" - , "foo = bb" - , "" - , "bb = 5" - , "" - , "baz = do" - , " putStrLn \"hello world\"" - ] + orig = + unlines + [ "module Foo where" + , "-- fooo" + , "foo :: Int" + , "foo = bb" + , "" + , "bb = 5" + , "" + , "baz = do" + , " putStrLn \"hello world\"" + ] -- new = changeChars (fromString orig) (J.Position 7 0) (J.Position 7 8) "baz =" new = applyChange mempty (fromString orig) $ mkChangeEvent (J.mkRange 7 0 7 8) "baz =" - Rope.lines <$> new `shouldBe` Identity + Rope.lines <$> new + `shouldBe` Identity [ "module Foo where" , "-- fooo" , "foo :: Int" @@ -180,54 +192,58 @@ ] it "indexes using utf-16 code units" $ do let - orig = unlines - [ "a𐐀b" - , "a𐐀b" - ] + orig = + unlines + [ "a𐐀b" + , "a𐐀b" + ] new = applyChange mempty (fromString orig) $ mkChangeEvent (J.mkRange 1 0 1 3) "𐐀𐐀" - Rope.lines <$> new `shouldBe` Identity + Rope.lines <$> new + `shouldBe` Identity [ "a𐐀b" , "𐐀𐐀b" ] - -- --------------------------------- + -- --------------------------------- describe "LSP utilities" $ do it "splits at a line" $ do let - orig = unlines - [ "module Foo where" - , "-- fooo" - , "foo :: Int" - , "foo = bb" - , "" - , "bb = 5" - , "" - , "baz = do" - , " putStrLn \"hello world\"" - ] - (left,right) = Rope.splitAtLine 4 (fromString orig) + orig = + unlines + [ "module Foo where" + , "-- fooo" + , "foo :: Int" + , "foo = bb" + , "" + , "bb = 5" + , "" + , "baz = do" + , " putStrLn \"hello world\"" + ] + (left, right) = Rope.splitAtLine 4 (fromString orig) - Rope.lines left `shouldBe` - [ "module Foo where" - , "-- fooo" - , "foo :: Int" - , "foo = bb" - ] - Rope.lines right `shouldBe` - [ "" - , "bb = 5" - , "" - , "baz = do" - , " putStrLn \"hello world\"" - ] + Rope.lines left + `shouldBe` [ "module Foo where" + , "-- fooo" + , "foo :: Int" + , "foo = bb" + ] + Rope.lines right + `shouldBe` [ "" + , "bb = 5" + , "" + , "baz = do" + , " putStrLn \"hello world\"" + ] it "converts code units to code points" $ do let - orig = unlines - [ "a𐐀b" - , "a𐐀b" - ] + orig = + unlines + [ "a𐐀b" + , "a𐐀b" + ] vfile = VirtualFile 0 0 (fromString orig) positionToCodePointPosition vfile (J.Position 1 0) `shouldBe` Just (CodePointPosition 1 0) @@ -245,10 +261,11 @@ it "converts code points to code units" $ do let - orig = unlines - [ "a𐐀b" - , "a𐐀b" - ] + orig = + unlines + [ "a𐐀b" + , "a𐐀b" + ] vfile = VirtualFile 0 0 (fromString orig) codePointPositionToPosition vfile (CodePointPosition 1 0) `shouldBe` Just (J.Position 1 0) @@ -266,10 +283,11 @@ it "getCompletionPrefix" $ do let - orig = T.unlines - [ "{-# ings #-}" - , "import Data.List" - ] + orig = + T.unlines + [ "{-# ings #-}" + , "import Data.List" + ] pp4 <- getCompletionPrefix (J.Position 0 4) (vfsFromText orig) pp4 `shouldBe` Just (PosPrefixInfo "{-# ings #-}" "" "" (J.Position 0 4))