From 84e2707604b3a64c00062104fa40e2ea76040155 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Mon, 12 Oct 2020 18:17:59 +0100 Subject: [PATCH] Update tests for lsp-1.0.0.0 --- cabal.project | 7 +- example/Test.hs | 10 +- hie.yaml | 16 ++ lsp-test.cabal | 15 +- src/Language/Haskell/LSP/Test/Exceptions.hs | 2 +- src/Language/Haskell/LSP/Test/Parsing.hs | 36 ++-- test/Test.hs | 91 ++++----- test/dummy-server/Main.hs | 213 ++++++++++++-------- 8 files changed, 214 insertions(+), 176 deletions(-) create mode 100644 hie.yaml diff --git a/cabal.project b/cabal.project index 48970de..5c4a647 100644 --- a/cabal.project +++ b/cabal.project @@ -1,11 +1,12 @@ packages: . + ./example flags: +DummyServer test-show-details: direct haddock-quickjump: True source-repository-package type: git - location: https://github.com/alanz/haskell-lsp.git - tag: 9dc38a36be7f1b316eff5dcf223a96d02c3ac6fd + location: https://github.com/alanz/lsp.git + tag: fd92be6d65f82f098cc0576e7e2200e38fb1cf94 subdir: . - haskell-lsp-types + lsp-types diff --git a/example/Test.hs b/example/Test.hs index 52ba45c..9d1fc0b 100644 --- a/example/Test.hs +++ b/example/Test.hs @@ -3,17 +3,17 @@ import Control.Monad.IO.Class import Language.Haskell.LSP.Test import Language.Haskell.LSP.Types -main = runSession "hie" fullCaps "../test/data/" $ do - docItem <- openDoc "Rename.hs" "haskell" +main = runSession "haskell-language-server" fullCaps "../test/data/" $ do + doc <- openDoc "Rename.hs" "haskell" -- Use your favourite favourite combinators. skipManyTill loggingNotification (count 2 publishDiagnosticsNotification) -- Send requests and notifications and receive responses - let params = DocumentSymbolParams docItem - rsp <- request TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse + rsp <- request STextDocumentDocumentSymbol $ + DocumentSymbolParams Nothing Nothing doc liftIO $ print rsp -- Or use one of the helper functions - getDocumentSymbols docItem >>= liftIO . print + getDocumentSymbols doc >>= liftIO . print diff --git a/hie.yaml b/hie.yaml new file mode 100644 index 0000000..bea6360 --- /dev/null +++ b/hie.yaml @@ -0,0 +1,16 @@ +cradle: + multi: + - path: "./test/data/" + config: { cradle: { none: } } + - path: "./example/" + config: { cradle: { none: } } + - path: "./" + config: + cradle: + cabal: + - path: "src" + component: "lib:lsp-test" + - path: "test/dummy-server" + component: "exe:dummy-server" + - path: "test" + component: "test:tests" diff --git a/lsp-test.cabal b/lsp-test.cabal index 0bf9dc9..1fcd4ec 100644 --- a/lsp-test.cabal +++ b/lsp-test.cabal @@ -22,7 +22,7 @@ build-type: Simple cabal-version: 2.0 extra-source-files: README.md , ChangeLog.md -tested-with: GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.3, GHC == 8.10.1 +tested-with: GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.3, GHC == 8.10.1, GHC == 8.10.2 source-repository head type: git @@ -36,13 +36,12 @@ Flag DummyServer library hs-source-dirs: src exposed-modules: Language.Haskell.LSP.Test - , Language.Haskell.LSP.Test.Replay - reexported-modules: haskell-lsp:Language.Haskell.LSP.Types - , haskell-lsp:Language.Haskell.LSP.Types.Capabilities + reexported-modules: lsp-types:Language.Haskell.LSP.Types + , lsp-types:Language.Haskell.LSP.Types.Capabilities , parser-combinators:Control.Applicative.Combinators default-language: Haskell2010 build-depends: base >= 4.10 && < 5 - , haskell-lsp >= 0.22 && < 0.24 + , lsp-types == 1.0.* , aeson , time , aeson-pretty @@ -83,12 +82,14 @@ executable dummy-server hs-source-dirs: test/dummy-server ghc-options: -W build-depends: base >= 4.10 && < 5 - , haskell-lsp >= 0.23 && < 0.24 + , lsp == 1.0.* , data-default , aeson , unordered-containers , directory , filepath + , unliftio + , mtl default-language: Haskell2010 scope: private if !flag(DummyServer) @@ -102,7 +103,7 @@ test-suite tests build-depends: base >= 4.10 && < 5 , hspec , lens - , haskell-lsp >= 0.22 && < 0.24 + , lsp-types == 1.0.* , lsp-test , data-default , aeson diff --git a/src/Language/Haskell/LSP/Test/Exceptions.hs b/src/Language/Haskell/LSP/Test/Exceptions.hs index c1fec6f..b28e256 100644 --- a/src/Language/Haskell/LSP/Test/Exceptions.hs +++ b/src/Language/Haskell/LSP/Test/Exceptions.hs @@ -33,7 +33,7 @@ instance Show SessionException where show (UnexpectedMessage expected lastMsg) = "Received an unexpected message from the server:\n" ++ "Was parsing: " ++ expected ++ "\n" ++ - "Last message received:\n" ++ B.unpack (encodePretty lastMsg) + "But the last message received was:\n" ++ B.unpack (encodePretty lastMsg) show (ReplayOutOfOrder received expected) = let expected' = nub expected getJsonDiff = lines . B.unpack . encodePretty diff --git a/src/Language/Haskell/LSP/Test/Parsing.hs b/src/Language/Haskell/LSP/Test/Parsing.hs index acd458c..92ab99f 100644 --- a/src/Language/Haskell/LSP/Test/Parsing.hs +++ b/src/Language/Haskell/LSP/Test/Parsing.hs @@ -15,6 +15,7 @@ module Language.Haskell.LSP.Test.Parsing satisfy , satisfyMaybe , message + , response , responseForId , customRequest , customNotification @@ -28,12 +29,10 @@ module Language.Haskell.LSP.Test.Parsing import Control.Applicative import Control.Concurrent -import Control.Lens import Control.Monad.IO.Class import Control.Monad import Data.Conduit.Parser hiding (named) import qualified Data.Conduit.Parser (named) -import Data.GADT.Compare import qualified Data.Text as T import Data.Typeable import Language.Haskell.LSP.Types @@ -108,31 +107,12 @@ satisfyMaybeM pred = do named :: T.Text -> Session a -> Session a named s (Session x) = Session (Data.Conduit.Parser.named s x) -mEq :: SServerMethod m1 -> SServerMethod m2 -> Maybe (m1 :~~: m2) -mEq m1 m2 = case (splitServerMethod m1, splitServerMethod m2) of - (IsServerNot, IsServerNot) -> do - Refl <- geq m1 m2 - pure HRefl - (IsServerReq, IsServerReq) -> do - Refl <- geq m1 m2 - pure HRefl - _ -> Nothing - -mEqClient :: SClientMethod m1 -> SClientMethod m2 -> Maybe (m1 :~~: m2) -mEqClient m1 m2 = case (splitClientMethod m1, splitClientMethod m2) of - (IsClientNot, IsClientNot) -> do - Refl <- geq m1 m2 - pure HRefl - (IsClientReq, IsClientReq) -> do - Refl <- geq m1 m2 - pure HRefl - _ -> Nothing --- | Matches non-custom messages +-- | Matches a request or a notification coming from the server. message :: SServerMethod m -> Session (ServerMessage m) message m1 = named (T.pack $ show m1) $ satisfyMaybe $ \case FromServerMess m2 msg -> do - HRefl <- mEq m1 m2 + HRefl <- mEqServer m1 m2 pure msg _ -> Nothing @@ -179,7 +159,15 @@ anyResponse = named "Any response" $ satisfy $ \case FromServerMess _ _ -> False FromServerRsp _ _ -> True --- | Matches a response for a specific id. +-- | Matches a response coming from the server. +response :: SMethod (m :: Method FromClient Request) -> Session (ResponseMessage m) +response m1 = named (T.pack $ show m1) $ satisfyMaybe $ \case + FromServerRsp m2 msg -> do + HRefl <- mEqClient m1 m2 + pure msg + _ -> Nothing + +-- | Like 'response', but matches a response for a specific id. responseForId :: SMethod (m :: Method FromClient Request) -> LspId m -> Session (ResponseMessage m) responseForId m lid = named (T.pack $ "Response for id: " ++ show lid) $ do satisfyMaybe $ \msg -> do diff --git a/test/Test.hs b/test/Test.hs index 7b911f4..12db785 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveGeneric #-} @@ -15,7 +17,6 @@ import Control.Concurrent import Control.Monad.IO.Class import Control.Monad import Control.Lens hiding (List) -import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Test import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Lens hiding @@ -25,6 +26,7 @@ import Language.Haskell.LSP.Types.Capabilities as LSP import System.Directory import System.FilePath import System.Timeout +import Data.Type.Equality {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} {-# ANN module ("HLint: ignore Unnecessary hiding" :: String) #-} @@ -51,7 +53,7 @@ main = findServer >>= \serverExe -> hspec $ do -- won't receive a request - will timeout -- incoming logging requests shouldn't increase the -- timeout - withTimeout 5 $ skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest + withTimeout 5 $ skipManyTill anyMessage (message SWorkspaceApplyEdit) :: Session ApplyWorkspaceEditRequest -- wait just a bit longer than 5 seconds so we have time -- to open the document in timeout 6000000 sesh `shouldThrow` anySessionException @@ -90,7 +92,7 @@ main = findServer >>= \serverExe -> hspec $ do withTimeout 10 $ liftIO $ threadDelay 7000000 getDocumentSymbols doc -- should now timeout - skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest + skipManyTill anyMessage (message SWorkspaceApplyEdit) isTimeout (Timeout _) = True isTimeout _ = False in sesh `shouldThrow` isTimeout @@ -100,7 +102,7 @@ main = findServer >>= \serverExe -> hspec $ do it "throw on time out" $ let sesh = runSessionWithConfig (def {messageTimeout = 10}) serverExe fullCaps "test/data/renamePass" $ do skipMany loggingNotification - _ <- message :: Session ApplyWorkspaceEditRequest + _ <- message SWorkspaceApplyEdit return () in sesh `shouldThrow` anySessionException @@ -112,52 +114,30 @@ main = findServer >>= \serverExe -> hspec $ do describe "UnexpectedMessageException" $ do it "throws when there's an unexpected message" $ - let selector (UnexpectedMessage "Publish diagnostics notification" (NotLogMessage _)) = True + let selector (UnexpectedMessage "Publish diagnostics notification" (FromServerMess SWindowLogMessage _)) = True selector _ = False in runSession serverExe fullCaps "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector it "provides the correct types that were expected and received" $ - let selector (UnexpectedMessage "ResponseMessage WorkspaceEdit" (RspDocumentSymbols _)) = True + let selector (UnexpectedMessage "STextDocumentRename" (FromServerRsp STextDocumentDocumentSymbol _)) = True selector _ = False sesh = do doc <- openDoc "Desktop/simple.hs" "haskell" - sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing) + sendRequest STextDocumentDocumentSymbol (DocumentSymbolParams Nothing Nothing doc) skipMany anyNotification - message :: Session RenameResponse -- the wrong type + response STextDocumentRename -- the wrong type in runSession serverExe fullCaps "test/data/renamePass" sesh `shouldThrow` selector - -- This is too fickle at the moment - -- describe "replaySession" $ - -- it "passes a test" $ - -- replaySession serverExe "test/data/renamePass" - -- it "fails a test" $ - -- let selector (ReplayOutOfOrder _ _) = True - -- selector _ = False - -- in replaySession serverExe "test/data/renameFail" `shouldThrow` selector - - -- describe "manual javascript session" $ - -- it "passes a test" $ - -- runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do - -- doc <- openDoc "test.js" "javascript" - - -- noDiagnostics - - -- Right (fooSymbol:_) <- getDocumentSymbols doc - - -- liftIO $ do - -- fooSymbol ^. name `shouldBe` "foo" - -- fooSymbol ^. kind `shouldBe` SkFunction - describe "text document VFS" $ it "sends back didChange notifications" $ runSession serverExe def "test/data/refactor" $ do doc <- openDoc "Main.hs" "haskell" let args = toJSON (doc ^. uri) - reqParams = ExecuteCommandParams "doAnEdit" (Just (List [args])) Nothing - request_ WorkspaceExecuteCommand reqParams + reqParams = ExecuteCommandParams Nothing "doAnEdit" (Just (List [args])) + request_ SWorkspaceExecuteCommand reqParams - editReq <- message :: Session ApplyWorkspaceEditRequest + editReq <- message SWorkspaceApplyEdit liftIO $ do let (Just cs) = editReq ^. params . edit . changes [(u, List es)] = HM.toList cs @@ -172,8 +152,8 @@ main = findServer >>= \serverExe -> hspec $ do doc <- openDoc "Main.hs" "haskell" let args = toJSON (doc ^. uri) - reqParams = ExecuteCommandParams "doAnEdit" (Just (List [args])) Nothing - request_ WorkspaceExecuteCommand reqParams + reqParams = ExecuteCommandParams Nothing "doAnEdit" (Just (List [args])) + request_ SWorkspaceExecuteCommand reqParams contents <- getDocumentEdit doc liftIO $ contents `shouldBe` "howdy:: IO Int\nmain = return (42)\n" @@ -181,7 +161,7 @@ main = findServer >>= \serverExe -> hspec $ do it "works" $ runSession serverExe fullCaps "test/data/refactor" $ do doc <- openDoc "Main.hs" "haskell" waitForDiagnostics - [CACodeAction action] <- getCodeActions doc (Range (Position 1 14) (Position 1 18)) + [InR action] <- getCodeActions doc (Range (Position 1 14) (Position 1 18)) liftIO $ action ^. title `shouldBe` "Delete this" describe "getAllCodeActions" $ @@ -190,7 +170,7 @@ main = findServer >>= \serverExe -> hspec $ do _ <- waitForDiagnostics actions <- getAllCodeActions doc liftIO $ do - let [CACodeAction action] = actions + let [InR action] = actions action ^. title `shouldBe` "Delete this" action ^. command . _Just . command `shouldBe` "deleteThis" @@ -311,7 +291,7 @@ main = findServer >>= \serverExe -> hspec $ do describe "satisfy" $ it "works" $ runSession serverExe fullCaps "test/data" $ do openDoc "Format.hs" "haskell" - let pred (NotLogMessage _) = True + let pred (FromServerMess SWindowLogMessage _) = True pred _ = False void $ satisfy pred @@ -322,29 +302,31 @@ main = findServer >>= \serverExe -> hspec $ do void publishDiagnosticsNotification describe "dynamic capabilities" $ do + it "keeps track" $ runSession serverExe fullCaps "test/data" $ do loggingNotification -- initialized log message createDoc ".register" "haskell" "" - message :: Session RegisterCapabilityRequest + message SClientRegisterCapability doc <- createDoc "Foo.watch" "haskell" "" - NotLogMessage msg <- loggingNotification + msg <- message SWindowLogMessage liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles" - caps <- getRegisteredCapabilities - liftIO $ caps `shouldBe` - [ Registration "0" WorkspaceDidChangeWatchedFiles $ Just $ toJSON $ - DidChangeWatchedFilesRegistrationOptions $ List - [ FileSystemWatcher "*.watch" (Just (WatchKind True True True)) ] - ] + [SomeRegistration (Registration _ regMethod regOpts)] <- getRegisteredCapabilities + liftIO $ do + case regMethod `mEqClient` SWorkspaceDidChangeWatchedFiles of + Just HRefl -> + regOpts `shouldBe` (DidChangeWatchedFilesRegistrationOptions $ List + [ FileSystemWatcher "*.watch" (Just (WatchKind True True True)) ]) + Nothing -> expectationFailure "Registration wasn't on workspace/didChangeWatchedFiles" -- now unregister it by sending a specific createDoc createDoc ".unregister" "haskell" "" - message :: Session UnregisterCapabilityRequest + message SClientUnregisterCapability createDoc "Bar.watch" "haskell" "" - void $ sendRequest TextDocumentHover $ TextDocumentPositionParams doc (Position 0 0) Nothing + void $ sendRequest STextDocumentHover $ HoverParams doc (Position 0 0) Nothing count 0 $ loggingNotification void $ anyResponse @@ -354,25 +336,22 @@ main = findServer >>= \serverExe -> hspec $ do loggingNotification -- initialized log message createDoc ".register.abs" "haskell" "" - message :: Session RegisterCapabilityRequest + message SClientRegisterCapability doc <- createDoc (curDir "Foo.watch") "haskell" "" - NotLogMessage msg <- loggingNotification + msg <- message SWindowLogMessage liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles" -- now unregister it by sending a specific createDoc createDoc ".unregister.abs" "haskell" "" - message :: Session UnregisterCapabilityRequest + message SClientUnregisterCapability createDoc (curDir "Bar.watch") "haskell" "" - void $ sendRequest TextDocumentHover $ TextDocumentPositionParams doc (Position 0 0) Nothing + void $ sendRequest STextDocumentHover $ HoverParams doc (Position 0 0) Nothing count 0 $ loggingNotification void $ anyResponse -mkRange :: Int -> Int -> Int -> Int -> Range -mkRange sl sc el ec = Range (Position sl sc) (Position el ec) - didChangeCaps :: ClientCapabilities didChangeCaps = def { _workspace = Just workspaceCaps } where @@ -383,7 +362,7 @@ docChangesCaps :: ClientCapabilities docChangesCaps = def { _workspace = Just workspaceCaps } where workspaceCaps = def { _workspaceEdit = Just editCaps } - editCaps = WorkspaceEditClientCapabilities (Just True) + editCaps = WorkspaceEditClientCapabilities (Just True) Nothing Nothing findExeRecursive :: FilePath -> FilePath -> IO (Maybe FilePath) diff --git a/test/dummy-server/Main.hs b/test/dummy-server/Main.hs index f0819d8..5ecf126 100644 --- a/test/dummy-server/Main.hs +++ b/test/dummy-server/Main.hs @@ -1,122 +1,175 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} + +import Control.Monad +import Control.Monad.Reader import Data.Aeson import Data.Default -import Data.List (isSuffixOf) import qualified Data.HashMap.Strict as HM -import Language.Haskell.LSP.Core +import Data.List (isSuffixOf) import Language.Haskell.LSP.Control -import Language.Haskell.LSP.Messages +import Language.Haskell.LSP.Core import Language.Haskell.LSP.Types -import Control.Concurrent -import Control.Monad import System.Directory import System.FilePath +import UnliftIO +import UnliftIO.Concurrent main = do - lfvar <- newEmptyMVar - let initCbs = InitializeCallbacks - { onInitialConfiguration = const $ Right () - , onConfigurationChange = const $ Right () - , onStartup = \lf -> do - putMVar lfvar lf - - return Nothing + handlerEnv <- HandlerEnv <$> newEmptyMVar <*> newEmptyMVar + let initCbs = + InitializeCallbacks + { doInitialize = \env _req -> pure $ Right env, + onConfigurationChange = const $ pure $ Right (), + staticHandlers = handlers, + interpretHandler = \env -> + Iso + (\m -> runLspT env (runReaderT m handlerEnv)) + liftIO } - options = def - { executeCommandCommands = Just ["doAnEdit"] + options = def {executeCommandCommands = Just ["doAnEdit"]} + run initCbs options + +data HandlerEnv = HandlerEnv + { relRegToken :: MVar (RegistrationToken WorkspaceDidChangeWatchedFiles), + absRegToken :: MVar (RegistrationToken WorkspaceDidChangeWatchedFiles) } - run initCbs (handlers lfvar) options Nothing -handlers :: MVar (LspFuncs ()) -> Handlers -handlers lfvar = def - { initializedHandler = pure $ \_ -> send $ NotLogMessage $ fmServerLogMessageNotification MtLog "initialized" - , hoverHandler = pure $ \req -> send $ - RspHover $ makeResponseMessage req (Just (Hover (HoverContents (MarkupContent MkPlainText "hello")) Nothing)) - , documentSymbolHandler = pure $ \req -> send $ - RspDocumentSymbols $ makeResponseMessage req $ DSDocumentSymbols $ - List [ DocumentSymbol "foo" +handlers :: Handlers (ReaderT HandlerEnv (LspM ())) +handlers = + mconcat + [ notificationHandler SInitialized $ + \_noti -> + sendNotification SWindowLogMessage $ + LogMessageParams MtLog "initialized", + requestHandler STextDocumentHover $ + \_req responder -> + responder $ + Right $ + Just $ + Hover (HoverContents (MarkupContent MkPlainText "hello")) Nothing, + requestHandler STextDocumentDocumentSymbol $ + \_req responder -> + responder $ + Right $ + InL $ + List + [ DocumentSymbol + "foo" Nothing SkObject Nothing (mkRange 0 0 3 6) (mkRange 0 0 3 6) Nothing - ] - , didOpenTextDocumentNotificationHandler = pure $ \noti -> do + ], + notificationHandler STextDocumentDidOpen $ + \noti -> do let NotificationMessage _ _ (DidOpenTextDocumentParams doc) = noti TextDocumentItem uri _ _ _ = doc Just fp = uriToFilePath uri - diag = Diagnostic (mkRange 0 0 0 1) + diag = + Diagnostic + (mkRange 0 0 0 1) (Just DsWarning) - (Just (NumberValue 42)) + (Just (InL 42)) (Just "dummy-server") "Here's a warning" Nothing Nothing - when (".hs" `isSuffixOf` fp) $ void $ forkIO $ do + withRunInIO $ + \runInIO -> do + when (".hs" `isSuffixOf` fp) $ + void $ + forkIO $ + do threadDelay (2 * 10 ^ 6) - send $ NotPublishDiagnostics $ - fmServerPublishDiagnosticsNotification $ PublishDiagnosticsParams uri $ List [diag] - + runInIO $ + sendNotification STextDocumentPublishDiagnostics $ + PublishDiagnosticsParams uri Nothing (List [diag]) -- also act as a registerer for workspace/didChangeWatchedFiles - when (".register" `isSuffixOf` fp) $ do - reqId <- readMVar lfvar >>= getNextReqId - send $ ReqRegisterCapability $ fmServerRegisterCapabilityRequest reqId $ - RegistrationParams $ List $ - [ Registration "0" WorkspaceDidChangeWatchedFiles $ Just $ toJSON $ - DidChangeWatchedFilesRegistrationOptions $ List - [ FileSystemWatcher "*.watch" (Just (WatchKind True True True)) ] + when (".register" `isSuffixOf` fp) $ + do + let regOpts = + DidChangeWatchedFilesRegistrationOptions $ + List + [ FileSystemWatcher + "*.watch" + (Just (WatchKind True True True)) ] - when (".register.abs" `isSuffixOf` fp) $ do + Just token <- runInIO $ + registerCapability SWorkspaceDidChangeWatchedFiles regOpts $ + \_noti -> + sendNotification SWindowLogMessage $ + LogMessageParams MtLog "got workspace/didChangeWatchedFiles" + runInIO $ asks relRegToken >>= \v -> putMVar v token + when (".register.abs" `isSuffixOf` fp) $ + do curDir <- getCurrentDirectory - reqId <- readMVar lfvar >>= getNextReqId - send $ ReqRegisterCapability $ fmServerRegisterCapabilityRequest reqId $ - RegistrationParams $ List $ - [ Registration "1" WorkspaceDidChangeWatchedFiles $ Just $ toJSON $ - DidChangeWatchedFilesRegistrationOptions $ List - [ FileSystemWatcher (curDir "*.watch") (Just (WatchKind True True True)) ] + let regOpts = + DidChangeWatchedFilesRegistrationOptions $ + List + [ FileSystemWatcher + (curDir "*.watch") + (Just (WatchKind True True True)) ] - + Just token <- runInIO $ + registerCapability SWorkspaceDidChangeWatchedFiles regOpts $ + \_noti -> + sendNotification SWindowLogMessage $ + LogMessageParams MtLog "got workspace/didChangeWatchedFiles" + runInIO $ asks absRegToken >>= \v -> putMVar v token -- also act as an unregisterer for workspace/didChangeWatchedFiles - when (".unregister" `isSuffixOf` fp) $ do - reqId <- readMVar lfvar >>= getNextReqId - send $ ReqUnregisterCapability $ fmServerUnregisterCapabilityRequest reqId $ - UnregistrationParams $ List [ Unregistration "0" "workspace/didChangeWatchedFiles" ] - when (".unregister.abs" `isSuffixOf` fp) $ do - reqId <- readMVar lfvar >>= getNextReqId - send $ ReqUnregisterCapability $ fmServerUnregisterCapabilityRequest reqId $ - UnregistrationParams $ List [ Unregistration "1" "workspace/didChangeWatchedFiles" ] - , executeCommandHandler = pure $ \req -> do - send $ RspExecuteCommand $ makeResponseMessage req Null - reqId <- readMVar lfvar >>= getNextReqId - let RequestMessage _ _ _ (ExecuteCommandParams "doAnEdit" (Just (List [val])) _) = req + when (".unregister" `isSuffixOf` fp) $ + do + Just token <- runInIO $ asks relRegToken >>= tryReadMVar + runInIO $ unregisterCapability token + when (".unregister.abs" `isSuffixOf` fp) $ + do + Just token <- runInIO $ asks absRegToken >>= tryReadMVar + runInIO $ unregisterCapability token, + requestHandler SWorkspaceExecuteCommand $ \req resp -> do + let RequestMessage _ _ _ (ExecuteCommandParams Nothing "doAnEdit" (Just (List [val]))) = req Success docUri = fromJSON val edit = List [TextEdit (mkRange 0 0 0 5) "howdy"] - send $ ReqApplyWorkspaceEdit $ fmServerApplyWorkspaceEditRequest reqId $ - ApplyWorkspaceEditParams $ WorkspaceEdit (Just (HM.singleton docUri edit)) - Nothing - , codeActionHandler = pure $ \req -> do + params = + ApplyWorkspaceEditParams (Just "Howdy edit") $ + WorkspaceEdit (Just (HM.singleton docUri edit)) Nothing + resp $ Right Null + void $ sendRequest SWorkspaceApplyEdit params (const (pure ())), + requestHandler STextDocumentCodeAction $ \req resp -> do let RequestMessage _ _ _ params = req - CodeActionParams _ _ cactx _ = params + CodeActionParams _ _ _ _ cactx = params CodeActionContext diags _ = cactx - caresults = fmap diag2caresult diags - diag2caresult d = CACodeAction $ - CodeAction "Delete this" + codeActions = fmap diag2ca diags + diag2ca d = + CodeAction + "Delete this" Nothing (Just (List [d])) Nothing + Nothing (Just (Command "" "deleteThis" Nothing)) - send $ RspCodeAction $ makeResponseMessage req caresults - , didChangeWatchedFilesNotificationHandler = pure $ \_ -> - send $ NotLogMessage $ fmServerLogMessageNotification MtLog "got workspace/didChangeWatchedFiles" - , completionHandler = pure $ \req -> do - let res = CompletionList (CompletionListType False (List [item])) + resp $ Right $ InR <$> codeActions, + requestHandler STextDocumentCompletion $ \_req resp -> do + let res = CompletionList True (List [item]) item = - CompletionItem "foo" (Just CiConstant) (Just (List [])) Nothing - Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing - send $ RspCompletion $ makeResponseMessage req res - } - where send msg = readMVar lfvar >>= \lf -> (sendFunc lf) msg - -mkRange sl sc el ec = Range (Position sl sc) (Position el ec) + CompletionItem + "foo" + (Just CiConstant) + (Just (List [])) + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + resp $ Right $ InR res + ] -- 2.30.2