X-Git-Url: https://git.lukelau.me/?a=blobdiff_plain;f=test%2Fdummy-server%2FMain.hs;h=6beee8bb3ecc17aacd43fe4783dc6dca1eb38b71;hb=a3f3199c221524124aeabce9a91e73655800a862;hp=f67b043a2f213fb873650b0d2e814e614c82d818;hpb=ddc2cdb9d0563dcf30102c8ef41dc6932717a872;p=lsp-test.git

diff --git a/test/dummy-server/Main.hs b/test/dummy-server/Main.hs
index f67b043..6beee8b 100644
--- a/test/dummy-server/Main.hs
+++ b/test/dummy-server/Main.hs
@@ -1,78 +1,173 @@
+{-# LANGUAGE TypeInType #-}
 {-# LANGUAGE OverloadedStrings #-}
-import Data.Aeson
-import Data.Default
-import qualified Data.HashMap.Strict as HM
-import Language.Haskell.LSP.Core
-import Language.Haskell.LSP.Control
-import Language.Haskell.LSP.Messages
-import Language.Haskell.LSP.Types
-import Control.Concurrent
+
 import Control.Monad
+import Control.Monad.Reader
+import Data.Aeson hiding (defaultOptions)
+import qualified Data.HashMap.Strict as HM
+import Data.List (isSuffixOf)
+import Data.String
+import Language.LSP.Server
+import Language.LSP.Types
+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
+  runServer $ ServerDefinition
+    { doInitialize = \env _req -> pure $ Right env,
+      onConfigurationChange = const $ pure $ Right (),
+      staticHandlers = handlers,
+      interpretHandler = \env ->
+        Iso
+          (\m -> runLspT env (runReaderT m handlerEnv))
+          liftIO,
+      options = defaultOptions {executeCommandCommands = Just ["doAnEdit"]}
     }
-      options = def
-        { executeCommandCommands = Just ["doAnEdit"]
+
+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
-                              (Range (Position 0 0) (Position 0 1))
-                              (Range (Position 0 0) (Position 0 1))
+                      (mkRange 0 0 3 6)
+                      (mkRange 0 0 3 6)
                       Nothing
                   ]
-  , didOpenTextDocumentNotificationHandler = pure $ \noti ->
-      void $ forkIO $ do
-        threadDelay (2 * 10^6)
+     , notificationHandler STextDocumentDidOpen $
+        \noti -> do
           let NotificationMessage _ _ (DidOpenTextDocumentParams doc) = noti
               TextDocumentItem uri _ _ _ = doc
-            diag = Diagnostic (Range (Position 0 0) (Position 0 1))
+              Just fp = uriToFilePath uri
+              diag =
+                Diagnostic
+                  (mkRange 0 0 0 1)
                   (Just DsWarning)
-                              (Just (NumberValue 42))
+                  (Just (InL 42))
                   (Just "dummy-server")
                   "Here's a warning"
                   Nothing
                   Nothing
-        send $ NotPublishDiagnostics $
-          fmServerPublishDiagnosticsNotification $ PublishDiagnosticsParams uri $ List [diag]
-  , executeCommandHandler = pure $ \req -> do
-      send $ RspExecuteCommand $ makeResponseMessage req Null
-      reqId <- readMVar lfvar >>= getNextReqId
-      let RequestMessage _ _ _ (ExecuteCommandParams "doAnEdit" (Just (List [val])) _) = req
+          withRunInIO $
+            \runInIO -> do
+              when (".hs" `isSuffixOf` fp) $
+                void $
+                  forkIO $
+                    do
+                      threadDelay (2 * 10 ^ 6)
+                      runInIO $
+                        sendNotification STextDocumentPublishDiagnostics $
+                          PublishDiagnosticsParams uri Nothing (List [diag])
+              -- also act as a registerer for workspace/didChangeWatchedFiles
+              when (".register" `isSuffixOf` fp) $
+                do
+                  let regOpts =
+                        DidChangeWatchedFilesRegistrationOptions $
+                          List
+                            [ FileSystemWatcher
+                                "*.watch"
+                                (Just (WatchKind True True True))
+                            ]
+                  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
+                  let regOpts =
+                        DidChangeWatchedFilesRegistrationOptions $
+                          List
+                            [ FileSystemWatcher
+                                (fromString $ 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
+                  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 (Range (Position 0 0) (Position 0 5)) "howdy"]
-      send $ ReqApplyWorkspaceEdit $ fmServerApplyWorkspaceEditRequest reqId $
-        ApplyWorkspaceEditParams $ WorkspaceEdit (Just (HM.singleton docUri edit))
-                                                 Nothing
-  , codeActionHandler = pure $ \req -> do
+            edit = List [TextEdit (mkRange 0 0 0 5) "howdy"]
+            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
+                Nothing
                 (Just (Command "" "deleteThis" Nothing))
-      send $ RspCodeAction $ makeResponseMessage req caresults
-  }
-  where send msg = readMVar lfvar >>= \lf -> (sendFunc lf) msg
+        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
+        resp $ Right $ InR res
+    ]