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

diff --git a/test/dummy-server/Main.hs b/test/dummy-server/Main.hs
new file mode 100644
index 0000000..f67b043
--- /dev/null
+++ b/test/dummy-server/Main.hs
@@ -0,0 +1,78 @@
+{-# 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
+
+main = do
+  lfvar <- newEmptyMVar
+  let initCbs = InitializeCallbacks
+        { onInitialConfiguration = const $ Right ()
+        , onConfigurationChange = const $ Right ()
+        , onStartup = \lf -> do
+            putMVar lfvar lf
+
+            return Nothing
+        }
+      options = def
+        { executeCommandCommands = Just ["doAnEdit"]
+        }
+  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"
+                              Nothing
+                              SkObject
+                              Nothing
+                              (Range (Position 0 0) (Position 0 1))
+                              (Range (Position 0 0) (Position 0 1))
+                              Nothing
+             ]
+  , didOpenTextDocumentNotificationHandler = pure $ \noti ->
+      void $ forkIO $ do
+        threadDelay (2 * 10^6)
+        let NotificationMessage _ _ (DidOpenTextDocumentParams doc) = noti
+            TextDocumentItem uri _ _ _ = doc
+            diag = Diagnostic (Range (Position 0 0) (Position 0 1))
+                              (Just DsWarning)
+                              (Just (NumberValue 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
+          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
+      let RequestMessage _ _ _ params = req
+          CodeActionParams _ _ cactx _ = params
+          CodeActionContext diags _ = cactx
+          caresults = fmap diag2caresult diags
+          diag2caresult d = CACodeAction $
+            CodeAction "Delete this"
+                       Nothing
+                       (Just (List [d]))
+                       Nothing
+                      (Just (Command "" "deleteThis" Nothing))
+      send $ RspCodeAction $ makeResponseMessage req caresults
+  }
+  where send msg = readMVar lfvar >>= \lf -> (sendFunc lf) msg