diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Revision history for lsp +## 2.0.0.0 + +* Support `lsp-types-2.0.0.0`. + ## 1.6.0.0 * Pinned to lsp-types 1.6 diff --git a/example/Reactor.hs b/example/Reactor.hs --- a/example/Reactor.hs +++ b/example/Reactor.hs @@ -45,8 +45,9 @@ import System.IO import Language.LSP.Diagnostics import Language.LSP.Logging (defaultClientLogger) -import qualified Language.LSP.Types as J -import qualified Language.LSP.Types.Lens as J +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 @@ -119,19 +120,19 @@ -- --------------------------------------------------------------------- -syncOptions :: J.TextDocumentSyncOptions -syncOptions = J.TextDocumentSyncOptions - { J._openClose = Just True - , J._change = Just J.TdSyncIncremental - , J._willSave = Just False - , J._willSaveWaitUntil = Just False - , J._save = Just $ J.InR $ J.SaveOptions $ Just False +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 } lspOptions :: Options lspOptions = defaultOptions - { textDocumentSync = Just syncOptions - , executeCommandCommands = Just ["lsp-hello-command"] + { optTextDocumentSync = Just syncOptions + , optExecuteCommandCommands = Just ["lsp-hello-command"] } -- --------------------------------------------------------------------- @@ -145,17 +146,19 @@ -- | Analyze the file and send any diagnostics to the client in a -- "textDocument/publishDiagnostics" notification -sendDiagnostics :: J.NormalizedUri -> Maybe Int32 -> LspM Config () +sendDiagnostics :: LSP.NormalizedUri -> Maybe Int32 -> LspM Config () sendDiagnostics fileUri version = do let - diags = [J.Diagnostic - (J.Range (J.Position 0 1) (J.Position 0 5)) - (Just J.DsWarning) -- severity + 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 (J.List [])) + (Just []) + Nothing ] publishDiagnostics 100 fileUri version (partitionBySource diags) @@ -176,12 +179,12 @@ 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 :: J.Method J.FromClient J.Request). Handler (LspM Config) a -> Handler (LspM Config) a + 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 :: J.Method J.FromClient J.Notification). Handler (LspM Config) a -> Handler (LspM Config) a + 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) @@ -189,49 +192,49 @@ -- | 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 J.SInitialized $ \_msg -> do + [ notificationHandler LSP.SMethod_Initialized $ \_msg -> do logger <& "Processing the Initialized notification" `WithSeverity` Info -- We're initialized! Lets send a showMessageRequest now - let params = J.ShowMessageRequestParams - J.MtWarning + let params = LSP.ShowMessageRequestParams + LSP.MessageType_Warning "What's your favourite language extension?" - (Just [J.MessageActionItem "Rank2Types", J.MessageActionItem "NPlusKPatterns"]) + (Just [LSP.MessageActionItem "Rank2Types", LSP.MessageActionItem "NPlusKPatterns"]) - void $ sendRequest J.SWindowShowMessageRequest params $ \res -> + 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 J.SWindowShowMessage (J.ShowMessageParams J.MtInfo "Excellent choice") + sendNotification LSP.SMethod_WindowShowMessage (LSP.ShowMessageParams LSP.MessageType_Info "Excellent choice") -- We can dynamically register a capability once the user accepts it - sendNotification J.SWindowShowMessage (J.ShowMessageParams J.MtInfo "Turning on code lenses dynamically") + sendNotification LSP.SMethod_WindowShowMessage (LSP.ShowMessageParams LSP.MessageType_Info "Turning on code lenses dynamically") - let regOpts = J.CodeLensRegistrationOptions Nothing Nothing (Just False) + let regOpts = LSP.CodeLensRegistrationOptions (LSP.InR LSP.Null) Nothing (Just False) - void $ registerCapability J.STextDocumentCodeLens regOpts $ \_req responder -> do + void $ registerCapability LSP.SMethod_TextDocumentCodeLens regOpts $ \_req responder -> do logger <& "Processing a textDocument/codeLens request" `WithSeverity` Info - let cmd = J.Command "Say hello" "lsp-hello-command" Nothing - rsp = J.List [J.CodeLens (J.mkRange 0 0 0 100) (Just cmd) Nothing] - responder (Right rsp) + 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 J.STextDocumentDidOpen $ \msg -> do - let doc = msg ^. J.params . J.textDocument . J.uri - fileName = J.uriToFilePath doc + , 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 (J.toNormalizedUri doc) (Just 0) + sendDiagnostics (LSP.toNormalizedUri doc) (Just 0) - , notificationHandler J.SWorkspaceDidChangeConfiguration $ \msg -> do + , notificationHandler LSP.SMethod_WorkspaceDidChangeConfiguration $ \msg -> do cfg <- getConfig logger L.<& ("Configuration changed: " <> T.pack (show (msg,cfg))) `WithSeverity` Info - sendNotification J.SWindowShowMessage $ - J.ShowMessageParams J.MtInfo $ "Wibble factor set to " <> T.pack (show (wibbleFactor cfg)) + sendNotification LSP.SMethod_WindowShowMessage $ + LSP.ShowMessageParams LSP.MessageType_Info $ "Wibble factor set to " <> T.pack (show (wibbleFactor cfg)) - , notificationHandler J.STextDocumentDidChange $ \msg -> do - let doc = msg ^. J.params - . J.textDocument - . J.uri - . to J.toNormalizedUri + , 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 @@ -240,73 +243,72 @@ Nothing -> do logger <& ("Didn't find anything in the VFS for: " <> T.pack (show doc)) `WithSeverity` Info - , notificationHandler J.STextDocumentDidSave $ \msg -> do - let doc = msg ^. J.params . J.textDocument . J.uri - fileName = J.uriToFilePath doc + , 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 (J.toNormalizedUri doc) Nothing + sendDiagnostics (LSP.toNormalizedUri doc) Nothing - , requestHandler J.STextDocumentRename $ \req responder -> do + , requestHandler LSP.SMethod_TextDocumentRename $ \req responder -> do logger <& "Processing a textDocument/rename request" `WithSeverity` Info - let params = req ^. J.params - J.Position l c = params ^. J.position - newName = params ^. J.newName - vdoc <- getVersionedTextDoc (params ^. J.textDocument) + 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 = J.InL $ J.TextEdit (J.mkRange l c l (c + fromIntegral (T.length newName))) newName - tde = J.TextDocumentEdit vdoc (J.List [edit]) + 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 = J.WorkspaceEdit Nothing (Just (J.List [J.InL tde])) Nothing - responder (Right rsp) + rsp = LSP.WorkspaceEdit Nothing (Just [LSP.InL tde]) Nothing + responder (Right $ LSP.InL rsp) - , requestHandler J.STextDocumentHover $ \req responder -> do + , requestHandler LSP.SMethod_TextDocumentHover $ \req responder -> do logger <& "Processing a textDocument/hover request" `WithSeverity` Info - let J.HoverParams _doc pos _workDone = req ^. J.params - J.Position _l _c' = pos - rsp = J.Hover ms (Just range) - ms = J.HoverContents $ J.markedUpContent "lsp-hello" "Your type info here!" - range = J.Range pos pos - responder (Right $ Just rsp) + 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 J.STextDocumentDocumentSymbol $ \req responder -> do + , requestHandler LSP.SMethod_TextDocumentDocumentSymbol $ \req responder -> do logger <& "Processing a textDocument/documentSymbol request" `WithSeverity` Info - let J.DocumentSymbolParams _ _ doc = req ^. J.params - loc = J.Location (doc ^. J.uri) (J.Range (J.Position 0 0) (J.Position 0 0)) - sym = J.SymbolInformation "lsp-hello" J.SkFunction Nothing Nothing loc Nothing - rsp = J.InR (J.List [sym]) - responder (Right rsp) + 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 J.STextDocumentCodeAction $ \req responder -> do + , requestHandler LSP.SMethod_TextDocumentCodeAction $ \req responder -> do logger <& "Processing a textDocument/codeAction request" `WithSeverity` Info - let params = req ^. J.params - doc = params ^. J.textDocument - (J.List diags) = params ^. J.context . J.diagnostics + 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 (J.Diagnostic (J.Range s _) _s _c (Just "lsp-hello") _m _t _l) = [J.Command title cmd cmdparams] - where - title = "Apply LSP hello command:" <> head (T.lines _m) + 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.List - [ J.object [("file", J.object [("textDocument",J.toJSON doc)])] - , J.object [("start_pos",J.object [("position", J.toJSON s)])] - ] + args = [ J.object [("file", J.object [("textDocument",J.toJSON doc)])] + , J.object [("start_pos",J.object [("position", J.toJSON s)])] + ] cmdparams = Just args - makeCommand (J.Diagnostic _r _s _c _source _m _t _l) = [] - rsp = J.List $ map J.InL $ concatMap makeCommand diags - responder (Right rsp) + in [LSP.Command title cmd cmdparams] + makeCommand _ = [] + rsp = map LSP.InL $ concatMap makeCommand diags + responder (Right $ LSP.InL rsp) - , requestHandler J.SWorkspaceExecuteCommand $ \req responder -> do + , requestHandler LSP.SMethod_WorkspaceExecuteCommand $ \req responder -> do logger <& "Processing a workspace/executeCommand request" `WithSeverity` Info - let params = req ^. J.params - margs = params ^. J.arguments + let params = req ^. LSP.params + margs = params ^. LSP.arguments logger <& ("The arguments are: " <> T.pack (show margs)) `WithSeverity` Debug - responder (Right (J.Object mempty)) -- respond to the request + responder (Right $ LSP.InL (J.Object mempty)) -- respond to the request void $ withProgress "Executing some long running command" Cancellable $ \update -> - forM [(0 :: J.UInt)..10] $ \i -> do + 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,37 +1,39 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DuplicateRecordFields #-} import Language.LSP.Server -import Language.LSP.Types +import Language.LSP.Protocol.Types +import Language.LSP.Protocol.Message import Control.Monad.IO.Class import qualified Data.Text as T handlers :: Handlers (LspM ()) handlers = mconcat - [ notificationHandler SInitialized $ \_not -> do - let params = ShowMessageRequestParams MtInfo "Turn on code lenses?" + [ notificationHandler SMethod_Initialized $ \_not -> do + let params = ShowMessageRequestParams MessageType_Info "Turn on code lenses?" (Just [MessageActionItem "Turn on", MessageActionItem "Don't"]) - _ <- sendRequest SWindowShowMessageRequest params $ \case - Right (Just (MessageActionItem "Turn on")) -> do - let regOpts = CodeLensRegistrationOptions Nothing Nothing (Just False) + _ <- sendRequest SMethod_WindowShowMessageRequest params $ \case + Right (InL (MessageActionItem "Turn on")) -> do + let regOpts = CodeLensRegistrationOptions (InR Null) Nothing (Just False) - _ <- registerCapability STextDocumentCodeLens regOpts $ \_req responder -> do + _ <- registerCapability SMethod_TextDocumentCodeLens regOpts $ \_req responder -> do let cmd = Command "Say hello" "lsp-hello-command" Nothing - rsp = List [CodeLens (mkRange 0 0 0 100) (Just cmd) Nothing] - responder (Right rsp) + rsp = [CodeLens (mkRange 0 0 0 100) (Just cmd) Nothing] + responder $ Right $ InL rsp pure () Right _ -> - sendNotification SWindowShowMessage (ShowMessageParams MtInfo "Not turning on code lenses") + sendNotification SMethod_WindowShowMessage (ShowMessageParams MessageType_Info "Not turning on code lenses") Left err -> - sendNotification SWindowShowMessage (ShowMessageParams MtError $ "Something went wrong!\n" <> T.pack (show err)) + sendNotification SMethod_WindowShowMessage (ShowMessageParams MessageType_Error $ "Something went wrong!\n" <> T.pack (show err)) pure () - , requestHandler STextDocumentHover $ \req responder -> do - let RequestMessage _ _ _ (HoverParams _doc pos _workDone) = req + , requestHandler SMethod_TextDocumentHover $ \req responder -> do + let TRequestMessage _ _ _ (HoverParams _doc pos _workDone) = req Position _l _c' = pos - rsp = Hover ms (Just range) - ms = HoverContents $ markedUpContent "lsp-demo-simple-server" "Hello world" + rsp = Hover (InL ms) (Just range) + ms = mkMarkdown "Hello world" range = Range pos pos - responder (Right $ Just rsp) + responder (Right $ InL rsp) ] main :: IO Int diff --git a/lsp.cabal b/lsp.cabal --- a/lsp.cabal +++ b/lsp.cabal @@ -1,122 +1,140 @@ -cabal-version: 2.2 -name: lsp -version: 1.6.0.0 -synopsis: Haskell library for the Microsoft Language Server Protocol +cabal-version: 2.2 +name: lsp +version: 2.0.0.0 +synopsis: Haskell library for the Microsoft Language Server Protocol +description: + An implementation of the types, and basic message server to + allow language implementors to support the Language Server + Protocol for their specific language. + . + An example of this is for Haskell via the Haskell Language + Server, at https://github.com/haskell/haskell-language-server -description: An implementation of the types, and basic message server to - allow language implementors to support the Language Server - Protocol for their specific language. - . - An example of this is for Haskell via the Haskell Language - Server, at https://github.com/haskell/haskell-language-server +homepage: https://github.com/haskell/lsp +license: MIT +license-file: LICENSE +author: Alan Zimmerman +maintainer: alan.zimm@gmail.com +copyright: Alan Zimmerman, 2016-2021 +category: Development +build-type: Simple +extra-source-files: + ChangeLog.md + README.md -homepage: https://github.com/haskell/lsp -license: MIT -license-file: LICENSE -author: Alan Zimmerman -maintainer: alan.zimm@gmail.com -copyright: Alan Zimmerman, 2016-2021 -category: Development -build-type: Simple -extra-source-files: ChangeLog.md, README.md +source-repository head + type: git + location: https://github.com/haskell/lsp library - reexported-modules: Language.LSP.Types - , Language.LSP.Types.Capabilities - , Language.LSP.Types.Lens - exposed-modules: Language.LSP.Server - , Language.LSP.Diagnostics - , Language.LSP.Logging - , Language.LSP.VFS - other-modules: Language.LSP.Server.Core - , Language.LSP.Server.Control - , Language.LSP.Server.Processing - ghc-options: -Wall - build-depends: base >= 4.11 && < 5 - , async >= 2.0 - , aeson >=1.0.0.0 - , attoparsec - , bytestring - , containers - , co-log-core >= 0.3.1.0 - , data-default - , directory - , exceptions - , filepath - , hashable - , lsp-types == 1.6.* - , lens >= 4.15.2 - , mtl < 2.4 - , prettyprinter - , sorted-list == 0.2.1.* - , stm == 2.5.* - , temporary - , text - , text-rope - , transformers >= 0.5.6 && < 0.7 - , unordered-containers - , unliftio-core >= 0.2.0.0 - -- used for generating random uuids for dynamic registration - , random - , uuid >= 1.3 - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -Wall -fprint-explicit-kinds + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -fprint-explicit-kinds + reexported-modules: + , Language.LSP.Protocol.Types + , Language.LSP.Protocol.Lens + , Language.LSP.Protocol.Capabilities + , Language.LSP.Protocol.Message + + exposed-modules: + Language.LSP.Diagnostics + Language.LSP.Logging + Language.LSP.Server + Language.LSP.VFS + + other-modules: + Language.LSP.Server.Control + Language.LSP.Server.Core + Language.LSP.Server.Processing + + ghc-options: -Wall + build-depends: + , aeson >=1.0.0.0 + , async >=2.0 + , attoparsec + , base >=4.11 && <5 + , bytestring + , co-log-core >=0.3.1.0 + , containers + , data-default + , directory + , exceptions + , filepath + , hashable + , lens >=4.15.2 + , lsp-types ^>=2.0 + , 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 + , unliftio-core >=0.2.0.0 + , unordered-containers + , uuid >=1.3 + executable lsp-demo-reactor-server - main-is: Reactor.hs - hs-source-dirs: example - default-language: Haskell2010 - ghc-options: -Wall -Wno-unticked-promoted-constructors + main-is: Reactor.hs + hs-source-dirs: example + default-language: Haskell2010 + ghc-options: -Wall -Wno-unticked-promoted-constructors + build-depends: + , aeson + , base + , co-log-core + , lens >=4.15.2 + , lsp + , prettyprinter + , stm + , text - build-depends: base - , aeson - , co-log-core - , lens >= 4.15.2 - , stm - , prettyprinter - , text - -- the package library. Comment this out if you want repl changes to propagate - , lsp + -- the package library. Comment this out if you want repl changes to propagate if !flag(demo) - buildable: False + buildable: False executable lsp-demo-simple-server - main-is: Simple.hs - hs-source-dirs: example - default-language: Haskell2010 - ghc-options: -Wall -Wno-unticked-promoted-constructors - build-depends: base - -- the package library. Comment this out if you want repl changes to propagate - , lsp - , text + main-is: Simple.hs + hs-source-dirs: example + default-language: Haskell2010 + ghc-options: -Wall -Wno-unticked-promoted-constructors + build-depends: + , base + , lsp + , text + + -- the package library. Comment this out if you want repl changes to propagate if !flag(demo) - buildable: False + buildable: False flag demo description: Build the demo executables default: False - test-suite lsp-test - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Main.hs - other-modules: Spec - DiagnosticsSpec - VspSpec - build-depends: base - , containers - , lsp - , hspec - , sorted-list == 0.2.1.* - , text - , text-rope - , unordered-containers - build-tool-depends: hspec-discover:hspec-discover - ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall - default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: + DiagnosticsSpec + Spec + VspSpec -source-repository head - type: git - location: https://github.com/haskell/lsp + build-depends: + , base + , containers + , hspec + , lsp + , row-types + , sorted-list >=0.2.1 && <0.2.2 + , text + , text-rope + , unordered-containers + + build-tool-depends: hspec-discover:hspec-discover + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + default-language: Haskell2010 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 @@ -23,7 +23,8 @@ import qualified Data.SortedList as SL import qualified Data.Map.Strict as Map import qualified Data.HashMap.Strict as HM -import qualified Language.LSP.Types as J +import Data.Text (Text) +import qualified Language.LSP.Protocol.Types as J -- --------------------------------------------------------------------- {-# ANN module ("hlint: ignore Eta reduce" :: String) #-} @@ -33,9 +34,9 @@ {- We need a three level store - Uri : Maybe TextDocumentVersion : Maybe DiagnosticSource : [Diagnostics] + Uri : Maybe Int32 : Maybe DiagnosticSource : [Diagnostics] -For a given Uri, as soon as we see a new (Maybe TextDocumentVersion) we flush +For a given Uri, as soon as we see a new (Maybe Int32) we flush all prior entries for the Uri. -} @@ -43,10 +44,10 @@ type DiagnosticStore = HM.HashMap J.NormalizedUri StoreItem data StoreItem - = StoreItem J.TextDocumentVersion DiagnosticsBySource + = StoreItem (Maybe J.Int32) DiagnosticsBySource deriving (Show,Eq) -type DiagnosticsBySource = Map.Map (Maybe J.DiagnosticSource) (SL.SortedList J.Diagnostic) +type DiagnosticsBySource = Map.Map (Maybe Text) (SL.SortedList J.Diagnostic) -- --------------------------------------------------------------------- @@ -55,7 +56,7 @@ -- --------------------------------------------------------------------- -flushBySource :: DiagnosticStore -> Maybe J.DiagnosticSource -> DiagnosticStore +flushBySource :: DiagnosticStore -> Maybe Text -> DiagnosticStore flushBySource store Nothing = store flushBySource store (Just source) = HM.map remove store where @@ -64,7 +65,7 @@ -- --------------------------------------------------------------------- updateDiagnostics :: DiagnosticStore - -> J.NormalizedUri -> J.TextDocumentVersion -> DiagnosticsBySource + -> J.NormalizedUri -> Maybe J.Int32 -> DiagnosticsBySource -> DiagnosticStore updateDiagnostics store uri mv newDiagsBySource = r where @@ -92,6 +93,6 @@ case HM.lookup uri ds of Nothing -> Nothing Just (StoreItem mv diags) -> - Just $ J.PublishDiagnosticsParams (J.fromNormalizedUri uri) (fmap fromIntegral mv) (J.List (take maxDiagnostics $ SL.fromSortedList $ mconcat $ Map.elems diags)) + Just $ J.PublishDiagnosticsParams (J.fromNormalizedUri uri) (fmap fromIntegral mv) (take maxDiagnostics $ SL.fromSortedList $ mconcat $ Map.elems diags) -- --------------------------------------------------------------------- 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 @@ -3,27 +3,28 @@ import Colog.Core import Language.LSP.Server.Core -import Language.LSP.Types +import Language.LSP.Protocol.Types +import Language.LSP.Protocol.Message import Data.Text (Text) logSeverityToMessageType :: Severity -> MessageType logSeverityToMessageType sev = case sev of - Error -> MtError - Warning -> MtWarning - Info -> MtInfo - Debug -> MtLog + Error -> MessageType_Error + Warning -> MessageType_Warning + Info -> MessageType_Info + Debug -> MessageType_Log -- | Logs messages to the client via @window/logMessage@. logToLogMessage :: (MonadLsp c m) => LogAction m (WithSeverity Text) logToLogMessage = LogAction $ \(WithSeverity msg sev) -> do sendToClient $ fromServerNot $ - NotificationMessage "2.0" SWindowLogMessage (LogMessageParams (logSeverityToMessageType sev) msg) + 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 $ - NotificationMessage "2.0" SWindowShowMessage (ShowMessageParams (logSeverityToMessageType sev) msg) + TNotificationMessage "2.0" SMethod_WindowShowMessage (ShowMessageParams (logSeverityToMessageType sev) msg) -- | A 'sensible' log action for logging messages to the client: -- 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 @@ -37,7 +37,7 @@ import Data.List import Language.LSP.Server.Core import qualified Language.LSP.Server.Processing as Processing -import Language.LSP.Types +import Language.LSP.Protocol.Message import Language.LSP.VFS import Language.LSP.Logging (defaultClientLogger) import System.IO 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 @@ -41,16 +41,19 @@ import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Map.Strict as Map import Data.Maybe +import Data.Row import Data.Monoid (Ap(..)) import Data.Ord (Down (Down)) import qualified Data.Text as T import Data.Text ( Text ) import qualified Data.UUID as UUID -import qualified Language.LSP.Types.Capabilities as J -import Language.LSP.Types as J -import Language.LSP.Types.SMethodMap (SMethodMap) -import qualified Language.LSP.Types.SMethodMap as SMethodMap -import qualified Language.LSP.Types.Lens as J +import Language.LSP.Protocol.Types +import Language.LSP.Protocol.Message +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 Language.LSP.Protocol.Utils.SMethodMap (SMethodMap) +import qualified Language.LSP.Protocol.Utils.SMethodMap as SMethodMap import Language.LSP.VFS import Language.LSP.Diagnostics import System.Random hiding (next) @@ -128,20 +131,20 @@ instance Monoid (Handlers config) where mempty = Handlers mempty mempty -notificationHandler :: forall (m :: Method FromClient Notification) f. SMethod m -> Handler f m -> Handlers f +notificationHandler :: forall (m :: Method ClientToServer Notification) f. SMethod m -> Handler f m -> Handlers f notificationHandler m h = Handlers mempty (SMethodMap.singleton m (ClientMessageHandler h)) -requestHandler :: forall (m :: Method FromClient Request) f. SMethod m -> Handler f m -> Handlers f +requestHandler :: forall (m :: Method ClientToServer Request) f. SMethod m -> Handler f m -> Handlers f requestHandler m h = Handlers (SMethodMap.singleton m (ClientMessageHandler h)) mempty --- | Wrapper to restrict 'Handler's to 'FromClient' 'Method's -newtype ClientMessageHandler f (t :: MethodType) (m :: Method FromClient t) = ClientMessageHandler (Handler f m) +-- | 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 type family Handler (f :: Type -> Type) (m :: Method from t) = (result :: Type) | result -> f t m where - Handler f (m :: Method _from Request) = RequestMessage m -> (Either ResponseError (ResponseResult m) -> f ()) -> f () - Handler f (m :: Method _from Notification) = NotificationMessage m -> 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 @@ -154,8 +157,8 @@ transmuteHandlers nat = mapHandlers (\i m k -> forward nat (i m (backward nat . k))) (\i m -> forward nat (i m)) mapHandlers - :: (forall (a :: Method FromClient Request). Handler m a -> Handler n a) - -> (forall (a :: Method FromClient Notification). Handler m a -> Handler n a) + :: (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 @@ -178,10 +181,10 @@ type ResponseMap = IxMap LspId (Product SMethod ServerResponseCallback) -type RegistrationMap (t :: MethodType) = SMethodMap (Product RegistrationId (ClientMessageHandler IO t)) +type RegistrationMap (t :: MessageKind) = SMethodMap (Product RegistrationId (ClientMessageHandler IO t)) -data RegistrationToken (m :: Method FromClient t) = RegistrationToken (SMethod m) (RegistrationId m) -newtype RegistrationId (m :: Method FromClient t) = RegistrationId Text +data RegistrationToken (m :: Method ClientToServer t) = RegistrationToken (SMethod m) (RegistrationId m) +newtype RegistrationId (m :: Method ClientToServer t) = RegistrationId Text deriving Eq data ProgressData = ProgressData { progressNextId :: !(TVar Int32) @@ -217,32 +220,32 @@ -- If you set handlers for some requests, you may need to set some of these options. data Options = Options - { textDocumentSync :: Maybe J.TextDocumentSyncOptions + { optTextDocumentSync :: Maybe J.TextDocumentSyncOptions -- | The characters that trigger completion automatically. - , completionTriggerCharacters :: Maybe [Char] + , 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`. - , completionAllCommitCharacters :: Maybe [Char] + , optCompletionAllCommitCharacters :: Maybe [Char] -- | The characters that trigger signature help automatically. - , signatureHelpTriggerCharacters :: Maybe [Char] + , 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. - , signatureHelpRetriggerCharacters :: Maybe [Char] + , 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. - , codeActionKinds :: Maybe [CodeActionKind] + , 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. - , documentOnTypeFormattingTriggerCharacters :: Maybe (NonEmpty Char) + , optDocumentOnTypeFormattingTriggerCharacters :: Maybe (NonEmpty Char) -- | The commands to be executed on the server. -- If you set `executeCommandHandler`, you **must** set this. - , executeCommandCommands :: Maybe [Text] + , optExecuteCommandCommands :: Maybe [Text] -- | Information about the server that can be advertised to the client. - , serverInfo :: Maybe J.ServerInfo + , optServerInfo :: Maybe (Rec ("name" .== Text .+ "version" .== Maybe Text)) } instance Default Options where @@ -285,7 +288,7 @@ -- indicating what went wrong. The parsed configuration object will be -- stored internally and can be accessed via 'config'. -- It is also called on the `initializationOptions` field of the InitializeParams - , doInitialize :: LanguageContextEnv config -> Message Initialize -> IO (Either ResponseError a) + , 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 @@ -316,8 +319,8 @@ -- | 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 FromServer Request) - = ServerResponseCallback (Either ResponseError (ResponseResult m) -> IO ()) +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 @@ -329,20 +332,20 @@ Nothing -> (False, pending) sendNotification - :: forall (m :: Method FromServer Notification) f config. MonadLsp config f + :: forall (m :: Method ServerToClient Notification) f config. MonadLsp config f => SServerMethod m -> MessageParams m -> f () sendNotification m params = - let msg = NotificationMessage "2.0" m params + let msg = TNotificationMessage "2.0" m params in case splitServerMethod m of IsServerNot -> sendToClient $ fromServerNot msg IsServerEither -> sendToClient $ FromServerMess m $ NotMess msg -sendRequest :: forall (m :: Method FromServer Request) f config. MonadLsp config f +sendRequest :: forall (m :: Method ServerToClient Request) f config. MonadLsp config f => SServerMethod m -> MessageParams m - -> (Either ResponseError (ResponseResult m) -> f ()) + -> (Either ResponseError (MessageResult m) -> f ()) -> f (LspId m) sendRequest m params resHandler = do reqId <- IdInt <$> freshLspId @@ -350,7 +353,7 @@ success <- addResponseHandler reqId (Pair m (ServerResponseCallback (rio . resHandler))) unless success $ error "LSP: could not send FromServer request as id is reused" - let msg = RequestMessage "2.0" reqId m params + let msg = TRequestMessage "2.0" reqId m params ~() <- case splitServerMethod m of IsServerReq -> sendToClient $ fromServerReq msg IsServerEither -> sendToClient $ FromServerMess m $ ReqMess msg @@ -403,8 +406,8 @@ let uri = doc ^. J.uri mvf <- getVirtualFile (toNormalizedUri uri) let ver = case mvf of - Just (VirtualFile lspver _ _) -> Just lspver - Nothing -> Nothing + Just (VirtualFile lspver _ _) -> lspver + Nothing -> 0 return (VersionedTextDocumentIdentifier uri ver) {-# INLINE getVersionedTextDoc #-} @@ -467,10 +470,7 @@ getWorkspaceFolders :: MonadLsp config m => m (Maybe [WorkspaceFolder]) getWorkspaceFolders = do clientCaps <- getClientCapabilities - let clientSupportsWfs = fromMaybe False $ do - let (J.ClientCapabilities mw _ _ _ _) = clientCaps - (J.WorkspaceClientCapabilities _ _ _ _ _ _ mwf _ _) <- mw - mwf + let clientSupportsWfs = fromMaybe False $ clientCaps ^? J.workspace . _Just . J.workspaceFolders . _Just if clientSupportsWfs then Just <$> getsState resWorkspaceFolders else pure Nothing @@ -481,7 +481,7 @@ -- 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 FromClient t) config. +registerCapability :: forall f t (m :: Method ClientToServer t) config. MonadLsp config f => SClientMethod m -> RegistrationOptions m @@ -503,8 +503,8 @@ -- First, check to see if the client supports dynamic registration on this method | dynamicSupported clientCaps = do uuid <- liftIO $ UUID.toText <$> getStdRandom random - let registration = J.Registration uuid method regOpts - params = J.RegistrationParams (J.List [J.SomeRegistration registration]) + let registration = J.TRegistration uuid method (Just regOpts) + params = J.RegistrationParams [toUntypedRegistration registration] regId = RegistrationId uuid rio <- askUnliftIO ~() <- case splitClientMethod method of @@ -517,7 +517,7 @@ IsClientEither -> error "Cannot register capability for custom methods" -- TODO: handle the scenario where this returns an error - _ <- sendRequest SClientRegisterCapability params $ \_res -> pure () + _ <- sendRequest SMethod_ClientRegisterCapability params $ \_res -> pure () pure (Just (RegistrationToken method regId)) | otherwise = pure Nothing @@ -530,37 +530,37 @@ -- | Checks if client capabilities declares that the method supports dynamic registration dynamicSupported clientCaps = case method of - SWorkspaceDidChangeConfiguration -> capDyn $ clientCaps ^? J.workspace . _Just . J.didChangeConfiguration . _Just - SWorkspaceDidChangeWatchedFiles -> capDyn $ clientCaps ^? J.workspace . _Just . J.didChangeWatchedFiles . _Just - SWorkspaceSymbol -> capDyn $ clientCaps ^? J.workspace . _Just . J.symbol . _Just - SWorkspaceExecuteCommand -> capDyn $ clientCaps ^? J.workspace . _Just . J.executeCommand . _Just - STextDocumentDidOpen -> capDyn $ clientCaps ^? J.textDocument . _Just . J.synchronization . _Just - STextDocumentDidChange -> capDyn $ clientCaps ^? J.textDocument . _Just . J.synchronization . _Just - STextDocumentDidClose -> capDyn $ clientCaps ^? J.textDocument . _Just . J.synchronization . _Just - STextDocumentCompletion -> capDyn $ clientCaps ^? J.textDocument . _Just . J.completion . _Just - STextDocumentHover -> capDyn $ clientCaps ^? J.textDocument . _Just . J.hover . _Just - STextDocumentSignatureHelp -> capDyn $ clientCaps ^? J.textDocument . _Just . J.signatureHelp . _Just - STextDocumentDeclaration -> capDyn $ clientCaps ^? J.textDocument . _Just . J.declaration . _Just - STextDocumentDefinition -> capDyn $ clientCaps ^? J.textDocument . _Just . J.definition . _Just - STextDocumentTypeDefinition -> capDyn $ clientCaps ^? J.textDocument . _Just . J.typeDefinition . _Just - STextDocumentImplementation -> capDyn $ clientCaps ^? J.textDocument . _Just . J.implementation . _Just - STextDocumentReferences -> capDyn $ clientCaps ^? J.textDocument . _Just . J.references . _Just - STextDocumentDocumentHighlight -> capDyn $ clientCaps ^? J.textDocument . _Just . J.documentHighlight . _Just - STextDocumentDocumentSymbol -> capDyn $ clientCaps ^? J.textDocument . _Just . J.documentSymbol . _Just - STextDocumentCodeAction -> capDyn $ clientCaps ^? J.textDocument . _Just . J.codeAction . _Just - STextDocumentCodeLens -> capDyn $ clientCaps ^? J.textDocument . _Just . J.codeLens . _Just - STextDocumentDocumentLink -> capDyn $ clientCaps ^? J.textDocument . _Just . J.documentLink . _Just - STextDocumentDocumentColor -> capDyn $ clientCaps ^? J.textDocument . _Just . J.colorProvider . _Just - STextDocumentColorPresentation -> capDyn $ clientCaps ^? J.textDocument . _Just . J.colorProvider . _Just - STextDocumentFormatting -> capDyn $ clientCaps ^? J.textDocument . _Just . J.formatting . _Just - STextDocumentRangeFormatting -> capDyn $ clientCaps ^? J.textDocument . _Just . J.rangeFormatting . _Just - STextDocumentOnTypeFormatting -> capDyn $ clientCaps ^? J.textDocument . _Just . J.onTypeFormatting . _Just - STextDocumentRename -> capDyn $ clientCaps ^? J.textDocument . _Just . J.rename . _Just - STextDocumentFoldingRange -> capDyn $ clientCaps ^? J.textDocument . _Just . J.foldingRange . _Just - STextDocumentSelectionRange -> capDyn $ clientCaps ^? J.textDocument . _Just . J.selectionRange . _Just - STextDocumentPrepareCallHierarchy -> capDyn $ clientCaps ^? J.textDocument . _Just . J.callHierarchy . _Just - STextDocumentSemanticTokens -> capDyn $ clientCaps ^? J.textDocument . _Just . J.semanticTokens . _Just - _ -> False + SMethod_WorkspaceDidChangeConfiguration -> capDyn $ clientCaps ^? J.workspace . _Just . J.didChangeConfiguration . _Just + SMethod_WorkspaceDidChangeWatchedFiles -> capDyn $ clientCaps ^? J.workspace . _Just . J.didChangeWatchedFiles . _Just + SMethod_WorkspaceSymbol -> capDyn $ clientCaps ^? J.workspace . _Just . J.symbol . _Just + SMethod_WorkspaceExecuteCommand -> capDyn $ clientCaps ^? J.workspace . _Just . J.executeCommand . _Just + SMethod_TextDocumentDidOpen -> capDyn $ clientCaps ^? J.textDocument . _Just . J.synchronization . _Just + SMethod_TextDocumentDidChange -> capDyn $ clientCaps ^? J.textDocument . _Just . J.synchronization . _Just + SMethod_TextDocumentDidClose -> capDyn $ clientCaps ^? J.textDocument . _Just . J.synchronization . _Just + SMethod_TextDocumentCompletion -> capDyn $ clientCaps ^? J.textDocument . _Just . J.completion . _Just + SMethod_TextDocumentHover -> capDyn $ clientCaps ^? J.textDocument . _Just . J.hover . _Just + SMethod_TextDocumentSignatureHelp -> capDyn $ clientCaps ^? J.textDocument . _Just . J.signatureHelp . _Just + SMethod_TextDocumentDeclaration -> capDyn $ clientCaps ^? J.textDocument . _Just . J.declaration . _Just + SMethod_TextDocumentDefinition -> capDyn $ clientCaps ^? J.textDocument . _Just . J.definition . _Just + SMethod_TextDocumentTypeDefinition -> capDyn $ clientCaps ^? J.textDocument . _Just . J.typeDefinition . _Just + SMethod_TextDocumentImplementation -> capDyn $ clientCaps ^? J.textDocument . _Just . J.implementation . _Just + SMethod_TextDocumentReferences -> capDyn $ clientCaps ^? J.textDocument . _Just . J.references . _Just + SMethod_TextDocumentDocumentHighlight -> capDyn $ clientCaps ^? J.textDocument . _Just . J.documentHighlight . _Just + SMethod_TextDocumentDocumentSymbol -> capDyn $ clientCaps ^? J.textDocument . _Just . J.documentSymbol . _Just + SMethod_TextDocumentCodeAction -> capDyn $ clientCaps ^? J.textDocument . _Just . J.codeAction . _Just + SMethod_TextDocumentCodeLens -> capDyn $ clientCaps ^? J.textDocument . _Just . J.codeLens . _Just + SMethod_TextDocumentDocumentLink -> capDyn $ clientCaps ^? J.textDocument . _Just . J.documentLink . _Just + SMethod_TextDocumentDocumentColor -> capDyn $ clientCaps ^? J.textDocument . _Just . J.colorProvider . _Just + SMethod_TextDocumentColorPresentation -> capDyn $ clientCaps ^? J.textDocument . _Just . J.colorProvider . _Just + SMethod_TextDocumentFormatting -> capDyn $ clientCaps ^? J.textDocument . _Just . J.formatting . _Just + SMethod_TextDocumentRangeFormatting -> capDyn $ clientCaps ^? J.textDocument . _Just . J.rangeFormatting . _Just + SMethod_TextDocumentOnTypeFormatting -> capDyn $ clientCaps ^? J.textDocument . _Just . J.onTypeFormatting . _Just + SMethod_TextDocumentRename -> capDyn $ clientCaps ^? J.textDocument . _Just . J.rename . _Just + SMethod_TextDocumentFoldingRange -> capDyn $ clientCaps ^? J.textDocument . _Just . J.foldingRange . _Just + SMethod_TextDocumentSelectionRange -> capDyn $ clientCaps ^? J.textDocument . _Just . J.selectionRange . _Just + SMethod_TextDocumentPrepareCallHierarchy -> capDyn $ clientCaps ^? J.textDocument . _Just . J.callHierarchy . _Just + --SMethod_TextDocumentSemanticTokens -> capDyn $ clientCaps ^? J.textDocument . _Just . J.semanticTokens . _Just + _ -> False -- | Sends a @client/unregisterCapability@ request and removes the handler -- for that associated registration. @@ -571,9 +571,9 @@ IsClientNot -> modifyState resRegistrationsNot $ SMethodMap.delete m IsClientEither -> error "Cannot unregister capability for custom methods" - let unregistration = J.Unregistration uuid (J.SomeClientMethod m) - params = J.UnregistrationParams (J.List [unregistration]) - void $ sendRequest SClientUnregisterCapability params $ \_res -> pure () + let unregistration = J.TUnregistration uuid m + params = J.UnregistrationParams [toUntypedUnregistration unregistration] + void $ sendRequest SMethod_ClientUnregisterCapability params $ \_res -> pure () -------------------------------------------------------------------------------- -- PROGRESS @@ -594,7 +594,7 @@ getNewProgressId = do stateState (progressNextId . resProgressData) $ \cur -> let !next = cur+1 - in (ProgressNumericToken cur, next) + in (J.ProgressToken $ J.InL cur, next) {-# INLINE getNewProgressId #-} @@ -613,25 +613,25 @@ -- Create progress token -- FIXME : This needs to wait until the request returns before -- continuing!!! - _ <- sendRequest SWindowWorkDoneProgressCreate + _ <- 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 Empty -> 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 SProgress $ - fmap Begin $ ProgressParams progId $ - WorkDoneProgressBeginParams title (Just cancellable') Nothing initialPercentage) + (runInBase $ sendNotification SMethod_Progress $ + ProgressParams progId $ J.toJSON $ + WorkDoneProgressBegin J.AString title (Just cancellable') Nothing initialPercentage) -- Send end notification - (runInBase $ sendNotification SProgress $ - End <$> ProgressParams progId (WorkDoneProgressEndParams Nothing)) $ do + (runInBase $ sendNotification SMethod_Progress $ + ProgressParams progId $ J.toJSON $ (WorkDoneProgressEnd J.AString Nothing)) $ do -- Run f asynchronously aid <- async $ runInBase $ f (updater progId) @@ -644,13 +644,11 @@ return res where updater progId (ProgressAmount percentage msg) = do - sendNotification SProgress $ fmap Report $ ProgressParams progId $ - WorkDoneProgressReportParams Nothing msg percentage + sendNotification SMethod_Progress $ ProgressParams progId $ J.toJSON $ + WorkDoneProgressReport J.AString Nothing msg percentage clientSupportsProgress :: J.ClientCapabilities -> Bool -clientSupportsProgress (J.ClientCapabilities _ _ wc _ _) = fromMaybe False $ do - (J.WindowClientCapabilities mProgress _ _) <- wc - mProgress +clientSupportsProgress caps = fromMaybe False $ caps ^? J.window . _Just . J.workDoneProgress . _Just {-# INLINE clientSupportsProgress #-} @@ -686,14 +684,14 @@ -- | 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 -> TextDocumentVersion -> DiagnosticsBySource -> m () +publishDiagnostics :: MonadLsp config m => Int -> NormalizedUri -> Maybe J.Int32 -> DiagnosticsBySource -> m () 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 $ J.fromServerNot $ J.NotificationMessage "2.0" J.STextDocumentPublishDiagnostics params + sendToClient $ J.fromServerNot $ J.TNotificationMessage "2.0" J.SMethod_TextDocumentPublishDiagnostics params in (act,newDiags) -- --------------------------------------------------------------------- @@ -701,7 +699,7 @@ -- | 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 DiagnosticSource -> m () + -> Maybe Text -> m () flushDiagnosticsBySource maxDiagnosticCount msource = join $ stateState resDiagnostics $ \oldDiags -> let !newDiags = flushBySource oldDiags msource -- Send the updated diagnostics to the client @@ -710,7 +708,7 @@ case mdp of Nothing -> return () Just params -> do - sendToClient $ J.fromServerNot $ J.NotificationMessage "2.0" J.STextDocumentPublishDiagnostics params + sendToClient $ J.fromServerNot $ J.TNotificationMessage "2.0" J.SMethod_TextDocumentPublishDiagnostics params in (act,newDiags) -- --------------------------------------------------------------------- @@ -720,17 +718,17 @@ reverseSortEdit :: J.WorkspaceEdit -> J.WorkspaceEdit reverseSortEdit (J.WorkspaceEdit cs dcs anns) = J.WorkspaceEdit cs' dcs' anns where - cs' :: Maybe J.WorkspaceEditMap + cs' :: Maybe (Map.Map Uri [TextEdit]) cs' = (fmap . fmap ) sortTextEdits cs - dcs' :: Maybe (J.List J.DocumentChange) + dcs' :: Maybe [J.DocumentChange] dcs' = (fmap . fmap) sortOnlyTextDocumentEdits dcs - sortTextEdits :: J.List J.TextEdit -> J.List J.TextEdit - sortTextEdits (J.List edits) = J.List (L.sortOn (Down . (^. J.range)) edits) + sortTextEdits :: [J.TextEdit] -> [J.TextEdit] + sortTextEdits edits = L.sortOn (Down . (^. J.range)) edits sortOnlyTextDocumentEdits :: J.DocumentChange -> J.DocumentChange - sortOnlyTextDocumentEdits (J.InL (J.TextDocumentEdit td (J.List edits))) = J.InL $ J.TextDocumentEdit td (J.List edits') + sortOnlyTextDocumentEdits (J.InL (J.TextDocumentEdit td edits)) = J.InL $ J.TextDocumentEdit td edits' where edits' = L.sortOn (Down . editRange) edits sortOnlyTextDocumentEdits (J.InR others) = J.InR others 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 @@ -9,8 +9,11 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE OverloadedLabels #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +-- there's just so much! +{-# OPTIONS_GHC -Wno-name-shadowing #-} -- So we can keep using the old prettyprinter modules (which have a better -- compatibility range) for now. {-# OPTIONS_GHC -Wno-deprecations #-} @@ -19,39 +22,40 @@ import Colog.Core (LogAction (..), WithSeverity (..), Severity (..), (<&)) -import Control.Lens hiding (List, Empty) -import Data.Aeson hiding (Options, Error) -import Data.Aeson.Types hiding (Options, Error) +import Control.Lens hiding (Empty) +import Data.Aeson hiding (Options, Error, Null) +import Data.Aeson.Types hiding (Options, Error, Null) import qualified Data.ByteString.Lazy as BSL -import Data.List +import Data.List import Data.List.NonEmpty (NonEmpty(..)) +import Data.Row import qualified Data.Text as T import qualified Data.Text.Lazy.Encoding as TL -import Language.LSP.Types -import Language.LSP.Types.Capabilities -import qualified Language.LSP.Types.Lens as LSP -import Language.LSP.Types.SMethodMap (SMethodMap) -import qualified Language.LSP.Types.SMethodMap as SMethodMap -import Language.LSP.Server.Core -import Language.LSP.VFS as VFS +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Types +import Language.LSP.Protocol.Message +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 qualified Data.Functor.Product as P import qualified Control.Exception as E -import Data.Monoid -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Except () -import Control.Concurrent.STM -import Control.Monad.Trans.Except -import Control.Monad.Reader -import Data.IxMap -import Data.Maybe +import Data.Monoid +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Except () +import Control.Concurrent.STM +import Control.Monad.Trans.Except +import Control.Monad.Reader +import Data.IxMap +import Data.Maybe import qualified Data.Map.Strict as Map -import Data.Text.Prettyprint.Doc -import System.Exit -import Data.Default (def) -import Control.Monad.State -import Control.Monad.Writer.Strict -import Data.Foldable (traverse_) +import Data.Text.Prettyprint.Doc +import System.Exit +import GHC.TypeLits (symbolVal) +import Control.Monad.State +import Control.Monad.Writer.Strict +import Data.Foldable (traverse_) data LspProcessingLog = VfsLog VfsLog @@ -95,7 +99,7 @@ pure $ handle logger m mess FromClientRsp (P.Pair (ServerResponseCallback f) (Const !newMap)) res -> do writeTVar pendingResponsesVar newMap - pure $ liftIO $ f (res ^. LSP.result) + pure $ liftIO $ f (res ^. L.result) where parser :: ResponseMap -> Value -> Parser (FromClientMessage' (P.Product ServerResponseCallback (Const ResponseMap))) parser rm = parseClientMessage $ \i -> @@ -109,25 +113,25 @@ :: ServerDefinition config -> VFS -> (FromServerMessage -> IO ()) - -> Message Initialize + -> TMessage Method_Initialize -> IO (Maybe (LanguageContextEnv config)) initializeRequestHandler ServerDefinition{..} vfs sendFunc req = do - let sendResp = sendFunc . FromServerRsp SInitialize + let sendResp = sendFunc . FromServerRsp SMethod_Initialize handleErr (Left err) = do - sendResp $ makeResponseError (req ^. LSP.id) err + sendResp $ makeResponseError (req ^. L.id) err pure Nothing handleErr (Right a) = pure $ Just a - flip E.catch (initializeErrorHandler $ sendResp . makeResponseError (req ^. LSP.id)) $ handleErr <=< runExceptT $ mdo + flip E.catch (initializeErrorHandler $ sendResp . makeResponseError (req ^. L.id)) $ handleErr <=< runExceptT $ mdo - let params = req ^. LSP.params - rootDir = getFirst $ foldMap First [ params ^. LSP.rootUri >>= uriToFilePath - , params ^. LSP.rootPath <&> T.unpack ] + let p = req ^. L.params + rootDir = getFirst $ foldMap First [ p ^? L.rootUri . _L >>= uriToFilePath + , p ^? L.rootPath . _Just . _L <&> T.unpack ] - let initialWfs = case params ^. LSP.workspaceFolders of - Just (List xs) -> xs - Nothing -> [] + let initialWfs = case p ^. L.workspaceFolders of + Just (InL xs) -> xs + _ -> [] - initialConfig = case onConfigurationChange defaultConfig <$> (req ^. LSP.params . LSP.initializationOptions) of + initialConfig = case onConfigurationChange defaultConfig <$> (p ^. L.initializationOptions) of Just (Right newConfig) -> newConfig _ -> defaultConfig @@ -147,21 +151,21 @@ pure LanguageContextState{..} -- Call the 'duringInitialization' callback to let the server kick stuff up - let env = LanguageContextEnv handlers onConfigurationChange sendFunc stateVars (params ^. LSP.capabilities) rootDir + let env = LanguageContextEnv handlers onConfigurationChange sendFunc stateVars (p ^. L.capabilities) rootDir handlers = transmuteHandlers interpreter staticHandlers interpreter = interpretHandler initializationResult initializationResult <- ExceptT $ doInitialize env req - let serverCaps = inferServerCapabilities (params ^. LSP.capabilities) options handlers - liftIO $ sendResp $ makeResponseMessage (req ^. LSP.id) (InitializeResult serverCaps (serverInfo options)) + let serverCaps = inferServerCapabilities (p ^. L.capabilities) options handlers + liftIO $ sendResp $ makeResponseMessage (req ^. L.id) (InitializeResult serverCaps (optServerInfo options)) pure env where - makeResponseMessage rid result = ResponseMessage "2.0" (Just rid) (Right result) - makeResponseError origId err = ResponseMessage "2.0" (Just origId) (Left err) + 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 InternalError msg Nothing + sendResp $ ResponseError (InR ErrorCodes_InternalError) msg Nothing pure Nothing where msg = T.pack $ unwords ["Error on initialize:", show e] @@ -174,37 +178,46 @@ inferServerCapabilities clientCaps o h = ServerCapabilities { _textDocumentSync = sync - , _hoverProvider = supportedBool STextDocumentHover + , _hoverProvider = supportedBool SMethod_TextDocumentHover , _completionProvider = completionProvider - , _declarationProvider = supportedBool STextDocumentDeclaration + , _declarationProvider = supportedBool SMethod_TextDocumentDeclaration , _signatureHelpProvider = signatureHelpProvider - , _definitionProvider = supportedBool STextDocumentDefinition - , _typeDefinitionProvider = supportedBool STextDocumentTypeDefinition - , _implementationProvider = supportedBool STextDocumentImplementation - , _referencesProvider = supportedBool STextDocumentReferences - , _documentHighlightProvider = supportedBool STextDocumentDocumentHighlight - , _documentSymbolProvider = supportedBool STextDocumentDocumentSymbol + , _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' STextDocumentCodeLens $ CodeLensOptions + , _codeLensProvider = supported' SMethod_TextDocumentCodeLens $ CodeLensOptions (Just False) - (supported SCodeLensResolve) - , _documentFormattingProvider = supportedBool STextDocumentFormatting - , _documentRangeFormattingProvider = supportedBool STextDocumentRangeFormatting + (supported SMethod_CodeLensResolve) + , _documentFormattingProvider = supportedBool SMethod_TextDocumentFormatting + , _documentRangeFormattingProvider = supportedBool SMethod_TextDocumentRangeFormatting , _documentOnTypeFormattingProvider = documentOnTypeFormattingProvider , _renameProvider = renameProvider - , _documentLinkProvider = supported' STextDocumentDocumentLink $ DocumentLinkOptions + , _documentLinkProvider = supported' SMethod_TextDocumentDocumentLink $ DocumentLinkOptions (Just False) - (supported SDocumentLinkResolve) - , _colorProvider = supportedBool STextDocumentDocumentColor - , _foldingRangeProvider = supportedBool STextDocumentFoldingRange + (supported SMethod_DocumentLinkResolve) + , _colorProvider = supportedBool SMethod_TextDocumentDocumentColor + , _foldingRangeProvider = supportedBool SMethod_TextDocumentFoldingRange , _executeCommandProvider = executeCommandProvider - , _selectionRangeProvider = supportedBool STextDocumentSelectionRange - , _callHierarchyProvider = supportedBool STextDocumentPrepareCallHierarchy + , _selectionRangeProvider = supportedBool SMethod_TextDocumentSelectionRange + , _callHierarchyProvider = supportedBool SMethod_TextDocumentPrepareCallHierarchy , _semanticTokensProvider = semanticTokensProvider - , _workspaceSymbolProvider = supportedBool SWorkspaceSymbol + , _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 } where @@ -229,102 +242,109 @@ singleton x = [x] completionProvider - | supported_b STextDocumentCompletion = Just $ - CompletionOptions - Nothing - (map T.singleton <$> completionTriggerCharacters o) - (map T.singleton <$> completionAllCommitCharacters o) - (supported SCompletionItemResolve) + | 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 clientSupportsCodeActionKinds = isJust $ - clientCaps ^? LSP.textDocument . _Just . LSP.codeAction . _Just . LSP.codeActionLiteralSupport + clientCaps ^? L.textDocument . _Just . L.codeAction . _Just . L.codeActionLiteralSupport . _Just codeActionProvider - | clientSupportsCodeActionKinds - , supported_b STextDocumentCodeAction = Just $ case codeActionKinds o of - Just ks -> InR $ CodeActionOptions Nothing (Just (List ks)) (supported SCodeLensResolve) - Nothing -> InL True - | supported_b STextDocumentCodeAction = Just (InL True) + | 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 + signatureHelpProvider - | supported_b STextDocumentSignatureHelp = Just $ + | supported_b SMethod_TextDocumentSignatureHelp = Just $ SignatureHelpOptions Nothing - (List . map T.singleton <$> signatureHelpTriggerCharacters o) - (List . map T.singleton <$> signatureHelpRetriggerCharacters o) + (map T.singleton <$> optSignatureHelpTriggerCharacters o) + (map T.singleton <$> optSignatureHelpRetriggerCharacters o) | otherwise = Nothing documentOnTypeFormattingProvider - | supported_b STextDocumentOnTypeFormatting - , Just (first :| rest) <- documentOnTypeFormattingTriggerCharacters o = Just $ + | supported_b SMethod_TextDocumentOnTypeFormatting + , Just (first :| rest) <- optDocumentOnTypeFormattingTriggerCharacters o = Just $ DocumentOnTypeFormattingOptions (T.pack [first]) (Just (map (T.pack . singleton) rest)) - | supported_b STextDocumentOnTypeFormatting - , Nothing <- documentOnTypeFormattingTriggerCharacters o = + | supported_b SMethod_TextDocumentOnTypeFormatting + , Nothing <- optDocumentOnTypeFormattingTriggerCharacters o = error "documentOnTypeFormattingTriggerCharacters needs to be set if a documentOnTypeFormattingHandler is set" | otherwise = Nothing executeCommandProvider - | supported_b SWorkspaceExecuteCommand - , Just cmds <- executeCommandCommands o = Just (ExecuteCommandOptions Nothing (List cmds)) - | supported_b SWorkspaceExecuteCommand - , Nothing <- executeCommandCommands o = + | 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 $ - clientCaps ^? LSP.textDocument . _Just . LSP.rename . _Just . LSP.prepareSupport . _Just + clientCaps ^? L.textDocument . _Just . L.rename . _Just . L.prepareSupport . _Just renameProvider | clientSupportsPrepareRename - , supported_b STextDocumentRename - , supported_b STextDocumentPrepareRename = Just $ + , supported_b SMethod_TextDocumentRename + , supported_b SMethod_TextDocumentPrepareRename = Just $ InR . RenameOptions Nothing . Just $ True - | supported_b STextDocumentRename = Just (InL 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 def semanticTokenRangeProvider semanticTokenFullProvider + semanticTokensProvider = Just $ InL $ SemanticTokensOptions Nothing defaultSemanticTokensLegend semanticTokenRangeProvider semanticTokenFullProvider semanticTokenRangeProvider - | supported_b STextDocumentSemanticTokensRange = Just $ SemanticTokensRangeBool True + | supported_b SMethod_TextDocumentSemanticTokensRange = Just $ InL True | otherwise = Nothing semanticTokenFullProvider - | supported_b STextDocumentSemanticTokensFull = Just $ SemanticTokensFullDelta $ SemanticTokensDeltaClientCapabilities $ supported STextDocumentSemanticTokensFullDelta + | supported_b SMethod_TextDocumentSemanticTokensFull = Just $ InR $ #delta .== supported SMethod_TextDocumentSemanticTokensFullDelta | otherwise = Nothing - sync = case textDocumentSync o of + sync = case optTextDocumentSync o of Just x -> Just (InL x) Nothing -> Nothing - workspace = WorkspaceServerCapabilities workspaceFolder - workspaceFolder = supported' SWorkspaceDidChangeWorkspaceFolders $ + 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. -handle :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> SClientMethod meth -> ClientMessage meth -> m () +handle :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> SClientMethod meth -> TClientMessage meth -> m () handle logger m msg = case m of - SWorkspaceDidChangeWorkspaceFolders -> handle' logger (Just updateWorkspaceFolders) m msg - SWorkspaceDidChangeConfiguration -> handle' logger (Just $ handleConfigChange logger) m msg - STextDocumentDidOpen -> handle' logger (Just $ vfsFunc logger openVFS) m msg - STextDocumentDidChange -> handle' logger (Just $ vfsFunc logger changeFromClientVFS) m msg - STextDocumentDidClose -> handle' logger (Just $ vfsFunc logger closeVFS) m msg - SWindowWorkDoneProgressCancel -> handle' logger (Just $ progressCancelHandler logger) m msg + SMethod_WorkspaceDidChangeWorkspaceFolders -> handle' logger (Just updateWorkspaceFolders) m msg + SMethod_WorkspaceDidChangeConfiguration -> handle' logger (Just $ handleConfigChange 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 FromClient t) config +handle' :: forall m t (meth :: Method ClientToServer t) config . (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) - -> Maybe (ClientMessage meth -> m ()) + -> Maybe (TClientMessage meth -> m ()) -- ^ An action to be run before invoking the handler, used for -- bookkeeping stuff like the vfs etc. -> SClientMethod meth - -> ClientMessage meth + -> TClientMessage meth -> m () handle' logger mAction m msg = do maybe (return ()) (\f -> f msg) mAction @@ -335,29 +355,29 @@ env <- getLspEnv let Handlers{reqHandlers, notHandlers} = resHandlers env - let mkRspCb :: RequestMessage (m1 :: Method FromClient Request) -> Either ResponseError (ResponseResult m1) -> IO () + let mkRspCb :: TRequestMessage (m1 :: Method ClientToServer Request) -> Either ResponseError (MessageResult m1) -> IO () mkRspCb req (Left err) = runLspT env $ sendToClient $ - FromServerRsp (req ^. LSP.method) $ ResponseMessage "2.0" (Just (req ^. LSP.id)) (Left err) + FromServerRsp (req ^. L.method) $ TResponseMessage "2.0" (Just (req ^. L.id)) (Left err) mkRspCb req (Right rsp) = runLspT env $ sendToClient $ - FromServerRsp (req ^. LSP.method) $ ResponseMessage "2.0" (Just (req ^. LSP.id)) (Right rsp) + FromServerRsp (req ^. L.method) $ TResponseMessage "2.0" (Just (req ^. L.id)) (Right rsp) case splitClientMethod m of IsClientNot -> case pickHandler dynNotHandlers notHandlers of Just h -> liftIO $ h msg Nothing - | SExit <- m -> exitNotificationHandler logger msg + | SMethod_Exit <- m -> exitNotificationHandler logger msg | otherwise -> do reportMissingHandler IsClientReq -> case pickHandler dynReqHandlers reqHandlers of Just h -> liftIO $ h msg (mkRspCb msg) Nothing - | SShutdown <- m -> liftIO $ shutdownRequestHandler msg (mkRspCb msg) + | SMethod_Shutdown <- m -> liftIO $ shutdownRequestHandler msg (mkRspCb msg) | otherwise -> do let errorMsg = T.pack $ unwords ["lsp:no handler for: ", show m] - err = ResponseError MethodNotFound errorMsg Nothing + err = ResponseError (InR ErrorCodes_MethodNotFound) errorMsg Nothing sendToClient $ - FromServerRsp (msg ^. LSP.method) $ ResponseMessage "2.0" (Just (msg ^. LSP.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 @@ -367,9 +387,9 @@ Just h -> liftIO $ h req (mkRspCb req) Nothing -> do let errorMsg = T.pack $ unwords ["lsp:no handler for: ", show m] - err = ResponseError MethodNotFound errorMsg Nothing + err = ResponseError (InR ErrorCodes_MethodNotFound) errorMsg Nothing sendToClient $ - FromServerRsp (req ^. LSP.method) $ ResponseMessage "2.0" (Just (req ^. LSP.id)) (Left err) + 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. @@ -386,12 +406,12 @@ reportMissingHandler = let optional = isOptionalNotification m in logger <& MissingHandler optional m `WithSeverity` if optional then Warning else Error - isOptionalNotification (SCustomMethod method) - | "$/" `T.isPrefixOf` method = True + isOptionalNotification (SMethod_CustomMethod p) + | "$/" `T.isPrefixOf` T.pack (symbolVal p) = True isOptionalNotification _ = False -progressCancelHandler :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> Message WindowWorkDoneProgressCancel -> m () -progressCancelHandler logger (NotificationMessage _ _ (WorkDoneProgressCancelParams tid)) = do +progressCancelHandler :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> TMessage Method_WindowWorkDoneProgressCancel -> m () +progressCancelHandler logger (TNotificationMessage _ _ (WorkDoneProgressCancelParams tid)) = do pdata <- getsState (progressCancel . resProgressData) case Map.lookup tid pdata of Nothing -> return () @@ -399,26 +419,26 @@ logger <& ProgressCancel tid `WithSeverity` Debug liftIO cancelAction -exitNotificationHandler :: (MonadIO m) => LogAction m (WithSeverity LspProcessingLog) -> Handler m Exit +exitNotificationHandler :: (MonadIO m) => LogAction m (WithSeverity LspProcessingLog) -> Handler m Method_Exit exitNotificationHandler logger _ = do logger <& Exiting `WithSeverity` Info liftIO exitSuccess -- | Default Shutdown handler -shutdownRequestHandler :: Handler IO Shutdown +shutdownRequestHandler :: Handler IO Method_Shutdown shutdownRequestHandler _req k = do - k $ Right Empty + k $ Right Null -handleConfigChange :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> Message WorkspaceDidChangeConfiguration -> m () +handleConfigChange :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> TMessage Method_WorkspaceDidChangeConfiguration -> m () handleConfigChange logger req = do parseConfig <- LspT $ asks resParseConfig - let settings = req ^. LSP.params . LSP.settings - res <- stateState resConfig $ \oldConfig -> case parseConfig oldConfig settings of + let s = req ^. L.params . L.settings + res <- stateState resConfig $ \oldConfig -> case parseConfig oldConfig s of Left err -> (Left err, oldConfig) Right !newConfig -> (Right (), newConfig) case res of Left err -> do - logger <& ConfigurationParseError settings err `WithSeverity` Error + logger <& ConfigurationParseError s err `WithSeverity` Error Right () -> pure () vfsFunc :: forall m n a config @@ -443,10 +463,10 @@ innerLogger = LogAction $ \m -> tell [m] -- | Updates the list of workspace folders -updateWorkspaceFolders :: Message WorkspaceDidChangeWorkspaceFolders -> LspM config () -updateWorkspaceFolders (NotificationMessage _ _ params) = do - let List toRemove = params ^. LSP.event . LSP.removed - List toAdd = params ^. LSP.event . LSP.added +updateWorkspaceFolders :: TMessage Method_WorkspaceDidChangeWorkspaceFolders -> LspM config () +updateWorkspaceFolders (TNotificationMessage _ _ params) = do + let toRemove = params ^. L.event . L.removed + toAdd = params ^. L.event . L.added newWfs oldWfs = foldr delete oldWfs toRemove <> toAdd modifyState resWorkspaceFolders newWfs 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,6 +1,7 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} @@ -77,16 +78,17 @@ import qualified Data.Text.IO as T import Data.Int (Int32) import Data.List +import Data.Row import Data.Ord -import qualified Data.HashMap.Strict as HashMap 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.Types as J -import qualified Language.LSP.Types.Lens as J +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 @@ -151,7 +153,7 @@ -- --------------------------------------------------------------------- -- | Applies the changes from a 'J.DidOpenTextDocument' to the 'VFS' -openVFS :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.Message 'J.TextDocumentDidOpen -> m () +openVFS :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.TMessage 'J.Method_TextDocumentDidOpen -> m () openVFS logger msg = do let J.TextDocumentItem (J.toNormalizedUri -> uri) _ version text = msg ^. J.params . J.textDocument vfile = VirtualFile version 0 (Rope.fromText text) @@ -161,12 +163,12 @@ -- --------------------------------------------------------------------- -- | Applies a 'DidChangeTextDocumentNotification' to the 'VFS' -changeFromClientVFS :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.Message 'J.TextDocumentDidChange -> m () +changeFromClientVFS :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.TMessage 'J.Method_TextDocumentDidChange -> m () changeFromClientVFS logger msg = do let - J.DidChangeTextDocumentParams vid (J.List changes) = msg ^. J.params + J.DidChangeTextDocumentParams vid changes = msg ^. J.params -- the client shouldn't be sending over a null version, only the server, but we just use 0 if that happens - J.VersionedTextDocumentIdentifier (J.toNormalizedUri -> uri) (fromMaybe 0 -> version) = vid + J.VersionedTextDocumentIdentifier (J.toNormalizedUri -> uri) version = vid vfs <- get case vfs ^. vfsMap . at uri of Just (VirtualFile _ file_ver contents) -> do @@ -177,7 +179,7 @@ -- --------------------------------------------------------------------- applyCreateFile :: (MonadState VFS m) => J.CreateFile -> m () -applyCreateFile (J.CreateFile (J.toNormalizedUri -> uri) options _ann) = +applyCreateFile (J.CreateFile _ann _kind (J.toNormalizedUri -> uri) options) = vfsMap %= Map.insertWith (\ new old -> if shouldOverwrite then new else old) uri @@ -197,7 +199,7 @@ Just (J.CreateFileOptions (Just False) (Just False)) -> False -- `overwrite` wins over `ignoreIfExists` applyRenameFile :: (MonadState VFS m) => J.RenameFile -> m () -applyRenameFile (J.RenameFile (J.toNormalizedUri -> oldUri) (J.toNormalizedUri -> newUri) options _ann) = do +applyRenameFile (J.RenameFile _ann _kind (J.toNormalizedUri -> oldUri) (J.toNormalizedUri -> newUri) options) = do vfs <- get case vfs ^. vfsMap . at oldUri of -- nothing to rename @@ -225,7 +227,7 @@ 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 (J.toNormalizedUri -> uri) options _ann) = do +applyDeleteFile logger (J.DeleteFile _ann _kind (J.toNormalizedUri -> uri) options) = do -- NOTE: we are ignoring the `recursive` option here because we don't know which file is a directory when (options ^? _Just . J.recursive . _Just == Just True) $ logger <& CantRecursiveDelete uri `WithSeverity` Warning @@ -239,13 +241,15 @@ _ -> pure () applyTextDocumentEdit :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.TextDocumentEdit -> m () -applyTextDocumentEdit logger (J.TextDocumentEdit vid (J.List edits)) = do +applyTextDocumentEdit logger (J.TextDocumentEdit vid edits) = do -- all edits are supposed to be applied at once -- so apply from bottom up so they don't affect others let sortedEdits = sortOn (Down . editRange) edits changeEvents = map editToChangeEvent sortedEdits - ps = J.DidChangeTextDocumentParams vid (J.List changeEvents) - notif = J.NotificationMessage "" J.STextDocumentDidChange ps + -- TODO: is this right? + 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 @@ -254,8 +258,8 @@ editRange (J.InL e) = e ^. J.range editToChangeEvent :: J.TextEdit J.|? J.AnnotatedTextEdit -> J.TextDocumentContentChangeEvent - editToChangeEvent (J.InR e) = J.TextDocumentContentChangeEvent (Just $ e ^. J.range) Nothing (e ^. J.newText) - editToChangeEvent (J.InL e) = J.TextDocumentContentChangeEvent (Just $ e ^. J.range) Nothing (e ^. J.newText) + 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 @@ -264,26 +268,28 @@ 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.Message 'J.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 case mDocChanges of - Just (J.List docChanges) -> applyDocumentChanges docChanges + Just docChanges -> applyDocumentChanges docChanges Nothing -> case mChanges of - Just cs -> applyDocumentChanges $ map J.InL $ HashMap.foldlWithKey' changeToTextDocumentEdit [] cs + Just cs -> applyDocumentChanges $ map J.InL $ Map.foldlWithKey' changeToTextDocumentEdit [] cs Nothing -> pure () where changeToTextDocumentEdit acc uri edits = - acc ++ [J.TextDocumentEdit (J.VersionedTextDocumentIdentifier uri (Just 0)) (fmap J.InL edits)] + acc ++ [J.TextDocumentEdit (J.OptionalVersionedTextDocumentIdentifier uri (J.InL 0)) (fmap J.InL edits)] applyDocumentChanges :: [J.DocumentChange] -> m () applyDocumentChanges = traverse_ (applyDocumentChange logger) . sortOn project -- for sorting [DocumentChange] - project :: J.DocumentChange -> J.TextDocumentVersion -- type TextDocumentVersion = Maybe Int - project (J.InL textDocumentEdit) = textDocumentEdit ^. J.textDocument . J.version + 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 -- --------------------------------------------------------------------- @@ -322,7 +328,7 @@ -- --------------------------------------------------------------------- -closeVFS :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.Message 'J.TextDocumentDidClose -> m () +closeVFS :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.TMessage 'J.Method_TextDocumentDidClose -> m () closeVFS logger msg = do let J.DidCloseTextDocumentParams (J.TextDocumentIdentifier (J.toNormalizedUri -> uri)) = msg ^. J.params logger <& Closing uri `WithSeverity` Debug @@ -339,10 +345,10 @@ -- --------------------------------------------------------------------- applyChange :: (Monad m) => LogAction m (WithSeverity VfsLog) -> Rope -> J.TextDocumentContentChangeEvent -> m Rope -applyChange _ _ (J.TextDocumentContentChangeEvent Nothing _ str) - = pure $ Rope.fromText str -applyChange logger str (J.TextDocumentContentChangeEvent (Just (J.Range (J.Position sl sc) (J.Position fl fc))) _ txt) +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 -- --------------------------------------------------------------------- diff --git a/test/DiagnosticsSpec.hs b/test/DiagnosticsSpec.hs --- a/test/DiagnosticsSpec.hs +++ b/test/DiagnosticsSpec.hs @@ -7,7 +7,7 @@ import qualified Data.SortedList as SL import Data.Text (Text) import Language.LSP.Diagnostics -import qualified Language.LSP.Types as J +import qualified Language.LSP.Protocol.Types as LSP import Test.Hspec @@ -29,20 +29,20 @@ -- --------------------------------------------------------------------- -mkDiagnostic :: Maybe J.DiagnosticSource -> Text -> J.Diagnostic +mkDiagnostic :: Maybe Text -> Text -> LSP.Diagnostic mkDiagnostic ms str = let - rng = J.Range (J.Position 0 1) (J.Position 3 0) - loc = J.Location (J.Uri "file") rng + rng = LSP.Range (LSP.Position 0 1) (LSP.Position 3 0) + loc = LSP.Location (LSP.Uri "file") rng in - J.Diagnostic rng Nothing Nothing ms str Nothing (Just (J.List [J.DiagnosticRelatedInformation loc str])) + LSP.Diagnostic rng Nothing Nothing Nothing ms str Nothing (Just [LSP.DiagnosticRelatedInformation loc str]) Nothing -mkDiagnostic2 :: Maybe J.DiagnosticSource -> Text -> J.Diagnostic +mkDiagnostic2 :: Maybe Text -> Text -> LSP.Diagnostic mkDiagnostic2 ms str = let - rng = J.Range (J.Position 4 1) (J.Position 5 0) - loc = J.Location (J.Uri "file") rng - in J.Diagnostic rng Nothing Nothing ms str Nothing (Just (J.List [J.DiagnosticRelatedInformation loc str])) + 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 -- --------------------------------------------------------------------- @@ -55,7 +55,7 @@ [ mkDiagnostic (Just "hlint") "a" , mkDiagnostic (Just "hlint") "b" ] - uri = J.toNormalizedUri $ J.Uri "uri" + 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) ] ) @@ -69,7 +69,7 @@ [ mkDiagnostic (Just "hlint") "a" , mkDiagnostic (Just "ghcmod") "b" ] - uri = J.toNormalizedUri $ J.Uri "uri" + uri = LSP.toNormalizedUri $ LSP.Uri "uri" (updateDiagnostics HM.empty uri Nothing (partitionBySource diags)) `shouldBe` HM.fromList [ (uri,StoreItem Nothing $ Map.fromList @@ -86,7 +86,7 @@ [ mkDiagnostic (Just "hlint") "a" , mkDiagnostic (Just "ghcmod") "b" ] - uri = J.toNormalizedUri $ J.Uri "uri" + uri = LSP.toNormalizedUri $ LSP.Uri "uri" (updateDiagnostics HM.empty uri (Just 1) (partitionBySource diags)) `shouldBe` HM.fromList [ (uri,StoreItem (Just 1) $ Map.fromList @@ -107,7 +107,7 @@ diags2 = [ mkDiagnostic (Just "hlint") "a2" ] - uri = J.toNormalizedUri $ J.Uri "uri" + uri = LSP.toNormalizedUri $ LSP.Uri "uri" let origStore = updateDiagnostics HM.empty uri Nothing (partitionBySource diags1) (updateDiagnostics origStore uri Nothing (partitionBySource diags2)) `shouldBe` HM.fromList @@ -125,7 +125,7 @@ diags2 = [ mkDiagnostic (Just "hlint") "a2" ] - uri = J.toNormalizedUri $ J.Uri "uri" + uri = LSP.toNormalizedUri $ LSP.Uri "uri" let origStore = updateDiagnostics HM.empty uri Nothing (partitionBySource diags1) (updateDiagnostics origStore uri Nothing (partitionBySource diags2)) `shouldBe` HM.fromList @@ -143,7 +143,7 @@ [ mkDiagnostic (Just "hlint") "a1" , mkDiagnostic (Just "ghcmod") "b1" ] - uri = J.toNormalizedUri $ J.Uri "uri" + 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 @@ -166,7 +166,7 @@ diags2 = [ mkDiagnostic (Just "hlint") "a2" ] - uri = J.toNormalizedUri $ J.Uri "uri" + 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 @@ -184,7 +184,7 @@ diags2 = [ mkDiagnostic (Just "hlint") "a2" ] - uri = J.toNormalizedUri $ J.Uri "uri" + 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 @@ -203,10 +203,10 @@ [ mkDiagnostic (Just "hlint") "a" , mkDiagnostic (Just "ghcmod") "b" ] - uri = J.toNormalizedUri $ J.Uri "uri" + uri = LSP.toNormalizedUri $ LSP.Uri "uri" let ds = updateDiagnostics HM.empty uri (Just 1) (partitionBySource diags) getDiagnosticParamsFor 10 ds uri `shouldBe` - Just (J.PublishDiagnosticsParams (J.fromNormalizedUri uri) (Just 1) (J.List $ reverse diags)) + Just (LSP.PublishDiagnosticsParams (LSP.fromNormalizedUri uri) (Just 1) (reverse diags)) -- --------------------------------- @@ -220,20 +220,20 @@ , mkDiagnostic (Just "hlint") "c" , mkDiagnostic (Just "ghcmod") "d" ] - uri = J.toNormalizedUri $ J.Uri "uri" + uri = LSP.toNormalizedUri $ LSP.Uri "uri" let ds = updateDiagnostics HM.empty uri (Just 1) (partitionBySource diags) getDiagnosticParamsFor 2 ds uri `shouldBe` - Just (J.PublishDiagnosticsParams (J.fromNormalizedUri uri) (Just 1) - (J.List [ - mkDiagnostic (Just "ghcmod") "d" - , mkDiagnostic (Just "hlint") "c" - ])) + Just (LSP.PublishDiagnosticsParams (LSP.fromNormalizedUri uri) (Just 1) + [ + mkDiagnostic (Just "ghcmod") "d" + , mkDiagnostic (Just "hlint") "c" + ]) getDiagnosticParamsFor 1 ds uri `shouldBe` - Just (J.PublishDiagnosticsParams (J.fromNormalizedUri uri) (Just 1) - (J.List [ - mkDiagnostic (Just "ghcmod") "d" - ])) + Just (LSP.PublishDiagnosticsParams (LSP.fromNormalizedUri uri) (Just 1) + [ + mkDiagnostic (Just "ghcmod") "d" + ]) -- --------------------------------- @@ -247,23 +247,23 @@ , mkDiagnostic (Just "hlint") "c" , mkDiagnostic (Just "ghcmod") "d" ] - uri = J.toNormalizedUri $ J.Uri "uri" + uri = LSP.toNormalizedUri $ LSP.Uri "uri" let ds = updateDiagnostics HM.empty uri (Just 1) (partitionBySource diags) getDiagnosticParamsFor 100 ds uri `shouldBe` - Just (J.PublishDiagnosticsParams (J.fromNormalizedUri uri) (Just 1) - (J.List [ - mkDiagnostic (Just "ghcmod") "d" - , mkDiagnostic (Just "hlint") "c" - , mkDiagnostic2 (Just "ghcmod") "b" - , mkDiagnostic2 (Just "hlint") "a" - ])) + 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 (J.PublishDiagnosticsParams (J.fromNormalizedUri uri) (Just 1) - (J.List [ - mkDiagnostic (Just "ghcmod") "d" - , mkDiagnostic2 (Just "ghcmod") "b" - ])) + Just (LSP.PublishDiagnosticsParams (LSP.fromNormalizedUri uri) (Just 1) + [ + mkDiagnostic (Just "ghcmod") "d" + , mkDiagnostic2 (Just "ghcmod") "b" + ]) -- --------------------------------- diff --git a/test/VspSpec.hs b/test/VspSpec.hs --- a/test/VspSpec.hs +++ b/test/VspSpec.hs @@ -1,10 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLabels #-} 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.Types as J +import qualified Language.LSP.Protocol.Types as J import qualified Data.Text as T import Test.Hspec @@ -31,23 +33,27 @@ -- --------------------------------------------------------------------- +mkChangeEvent :: J.Range -> T.Text -> J.TextDocumentContentChangeEvent +mkChangeEvent r t = J.TextDocumentContentChangeEvent $ J.InL $ #range .== r .+ #rangeLength .== Nothing .+ #text .== t + vspSpec :: Spec vspSpec = do describe "applys changes in order" $ do it "handles vscode style undos" $ do let orig = "abc" changes = - [ J.TextDocumentContentChangeEvent (Just $ J.mkRange 0 2 0 3) Nothing "" - , J.TextDocumentContentChangeEvent (Just $ J.mkRange 0 1 0 2) Nothing "" - , J.TextDocumentContentChangeEvent (Just $ J.mkRange 0 0 0 1) Nothing "" + [ mkChangeEvent (J.mkRange 0 2 0 3) "" + , mkChangeEvent (J.mkRange 0 1 0 2) "" + , mkChangeEvent (J.mkRange 0 0 0 1) "" ] applyChanges mempty orig changes `shouldBe` Identity "" it "handles vscode style redos" $ do let orig = "" changes = - [ J.TextDocumentContentChangeEvent (Just $ J.mkRange 0 1 0 1) Nothing "a" - , J.TextDocumentContentChangeEvent (Just $ J.mkRange 0 2 0 2) Nothing "b" - , J.TextDocumentContentChangeEvent (Just $ J.mkRange 0 3 0 3) Nothing "c" + [ + 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" @@ -63,25 +69,7 @@ , "-- fooo" , "foo :: Int" ] - new = applyChange mempty (fromString orig) - $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 2 1 2 5) (Just 4) "" - Rope.lines <$> new `shouldBe` Identity - [ "abcdg" - , "module Foo where" - , "-oo" - , "foo :: Int" - ] - - it "deletes characters within a line (no len)" $ do - let - orig = unlines - [ "abcdg" - , "module Foo where" - , "-- fooo" - , "foo :: Int" - ] - new = applyChange mempty (fromString orig) - $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 2 1 2 5) Nothing "" + new = applyChange mempty (fromString orig) $ mkChangeEvent (J.mkRange 2 1 2 5) "" Rope.lines <$> new `shouldBe` Identity [ "abcdg" , "module Foo where" @@ -100,30 +88,13 @@ , "-- fooo" , "foo :: Int" ] - new = applyChange mempty (fromString orig) - $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 2 0 3 0) (Just 8) "" + new = applyChange mempty (fromString orig) $ mkChangeEvent (J.mkRange 2 0 3 0) "" Rope.lines <$> new `shouldBe` Identity [ "abcdg" , "module Foo where" , "foo :: Int" ] - it "deletes one line(no len)" $ do - -- based on vscode log - let - orig = unlines - [ "abcdg" - , "module Foo where" - , "-- fooo" - , "foo :: Int" - ] - new = applyChange mempty (fromString orig) - $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 2 0 3 0) Nothing "" - Rope.lines <$> new `shouldBe` Identity - [ "abcdg" - , "module Foo where" - , "foo :: Int" - ] -- --------------------------------- it "deletes two lines" $ do @@ -135,28 +106,12 @@ , "foo :: Int" , "foo = bb" ] - new = applyChange mempty (fromString orig) - $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 1 0 3 0) (Just 19) "" + new = applyChange mempty (fromString orig) $ mkChangeEvent (J.mkRange 1 0 3 0) "" Rope.lines <$> new `shouldBe` Identity [ "module Foo where" , "foo = bb" ] - it "deletes two lines(no len)" $ do - -- based on vscode log - let - orig = unlines - [ "module Foo where" - , "-- fooo" - , "foo :: Int" - , "foo = bb" - ] - new = applyChange mempty (fromString orig) - $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 1 0 3 0) Nothing "" - Rope.lines <$> new `shouldBe` Identity - [ "module Foo where" - , "foo = bb" - ] -- --------------------------------- describe "adds characters" $ do @@ -168,8 +123,7 @@ , "module Foo where" , "foo :: Int" ] - new = applyChange mempty (fromString orig) - $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 1 16 1 16) (Just 0) "\n-- fooo" + new = applyChange mempty (fromString orig) $ mkChangeEvent (J.mkRange 1 16 1 16) "\n-- fooo" Rope.lines <$> new `shouldBe` Identity [ "abcdg" , "module Foo where" @@ -186,8 +140,7 @@ [ "module Foo where" , "foo = bb" ] - new = applyChange mempty (fromString orig) - $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 1 8 1 8) Nothing "\n-- fooo\nfoo :: Int" + new = applyChange mempty (fromString orig) $ mkChangeEvent (J.mkRange 1 8 1 8) "\n-- fooo\nfoo :: Int" Rope.lines <$> new `shouldBe` Identity [ "module Foo where" , "foo = bb" @@ -213,36 +166,7 @@ , " putStrLn \"hello world\"" ] -- new = changeChars (fromString orig) (J.Position 7 0) (J.Position 7 8) "baz =" - new = applyChange mempty (fromString orig) - $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 7 0 7 8) (Just 8) "baz =" - Rope.lines <$> new `shouldBe` Identity - [ "module Foo where" - , "-- fooo" - , "foo :: Int" - , "foo = bb" - , "" - , "bb = 5" - , "" - , "baz =" - , " putStrLn \"hello world\"" - ] - it "removes end of a line(no len)" $ do - -- based on vscode log - let - 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) - $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 7 0 7 8) Nothing "baz =" + new = applyChange mempty (fromString orig) $ mkChangeEvent (J.mkRange 7 0 7 8) "baz =" Rope.lines <$> new `shouldBe` Identity [ "module Foo where" , "-- fooo" @@ -260,8 +184,7 @@ [ "a𐐀b" , "a𐐀b" ] - new = applyChange mempty (fromString orig) - $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 1 0 1 3) (Just 3) "𐐀𐐀" + new = applyChange mempty (fromString orig) $ mkChangeEvent (J.mkRange 1 0 1 3) "𐐀𐐀" Rope.lines <$> new `shouldBe` Identity [ "a𐐀b" , "𐐀𐐀b"