Handle [un]registerCapability and workspace/didChangeWatchedFiles

[lsp-test.git] / test / dummy-server / Main.hs

diff --git a/test/dummy-server/Main.hs b/test/dummy-server/Main.hs
index a7e6439078ead5af4db0275c3863bc610294d5e1..8120b030431c1bb0ce6b977f7a750755bb9dabda 100644 (file)
--- a/test/dummy-server/Main.hs
+++ b/test/dummy-server/Main.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 import Data.Aeson
 import Data.Default
+import Data.List (isSuffixOf)
 import qualified Data.HashMap.Strict as HM
 import Language.Haskell.LSP.Core
 import Language.Haskell.LSP.Control
@@ -8,6 +9,8 @@ import Language.Haskell.LSP.Messages
 import Language.Haskell.LSP.Types
 import Control.Concurrent
 import Control.Monad
+import System.Directory
+import System.FilePath
 
 main = do
   lfvar <- newEmptyMVar
@@ -39,11 +42,10 @@ handlers lfvar = def
                               (mkRange 0 0 3 6)
                               Nothing
              ]
-  , didOpenTextDocumentNotificationHandler = pure $ \noti ->
-      void $ forkIO $ do
-        threadDelay (2 * 10^6)
+  , didOpenTextDocumentNotificationHandler = pure $ \noti -> do
       let NotificationMessage _ _ (DidOpenTextDocumentParams doc) = noti
           TextDocumentItem uri _ _ _ = doc
+          Just fp = uriToFilePath uri
           diag = Diagnostic (mkRange 0 0 0 1)
                             (Just DsWarning)
                             (Just (NumberValue 42))
@@ -51,8 +53,39 @@ handlers lfvar = def
                             "Here's a warning"
                             Nothing
                             Nothing
+      when (".hs" `isSuffixOf` fp) $ void $ forkIO $ do
+        threadDelay (2 * 10^6)
         send $ NotPublishDiagnostics $
           fmServerPublishDiagnosticsNotification $ PublishDiagnosticsParams uri $ 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.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)) ]
+            ]
+
+      -- 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
@@ -74,6 +107,8 @@ handlers lfvar = def
                        Nothing
                       (Just (Command "" "deleteThis" Nothing))
       send $ RspCodeAction $ makeResponseMessage req caresults
+  , didChangeWatchedFilesNotificationHandler = pure $ \_ ->
+      send $ NotLogMessage $ fmServerLogMessageNotification MtLog "got workspace/didChangeWatchedFiles"
   }
   where send msg = readMVar lfvar >>= \lf -> (sendFunc lf) msg