lsp 1.6.0.0 → 2.0.0.0
raw patch · 12 files changed
+591/−616 lines, 12 filesdep +row-typesdep ~lsp-typesdep ~sorted-listdep ~stm
Dependencies added: row-types
Dependency ranges changed: lsp-types, sorted-list, stm
Files
- ChangeLog.md +4/−0
- example/Reactor.hs +89/−87
- example/Simple.hs +18/−16
- lsp.cabal +122/−104
- src/Language/LSP/Diagnostics.hs +9/−8
- src/Language/LSP/Logging.hs +8/−7
- src/Language/LSP/Server/Control.hs +1/−1
- src/Language/LSP/Server/Core.hs +97/−99
- src/Language/LSP/Server/Processing.hs +150/−130
- src/Language/LSP/VFS.hs +31/−25
- test/DiagnosticsSpec.hs +42/−42
- test/VspSpec.hs +20/−97
ChangeLog.md view
@@ -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
example/Reactor.hs view
@@ -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) ]
example/Simple.hs view
@@ -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
lsp.cabal view
@@ -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
src/Language/LSP/Diagnostics.hs view
@@ -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) -- ---------------------------------------------------------------------
src/Language/LSP/Logging.hs view
@@ -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: --
src/Language/LSP/Server/Control.hs view
@@ -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
src/Language/LSP/Server/Core.hs view
@@ -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
src/Language/LSP/Server/Processing.hs view
@@ -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
src/Language/LSP/VFS.hs view
@@ -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 -- ---------------------------------------------------------------------
test/DiagnosticsSpec.hs view
@@ -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"+ ]) -- ---------------------------------
test/VspSpec.hs view
@@ -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"