X-Git-Url: https://git.lukelau.me/?p=lsp-test.git;a=blobdiff_plain;f=test%2Fdummy-server%2FMain.hs;h=5ecf12645bc0ccf1702b213bd01677a0062393d5;hp=f0819d84c3535aadb75500f05e38c6d1b06ae4b0;hb=84e2707604b3a64c00062104fa40e2ea76040155;hpb=8c79bbaf4135321c321b5599ada4a370e5dcb50d 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 + ]