lsp-test-0.15.0.1: test/DummyServer.hs

{-# LANGUAGE TypeInType #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE TypeApplications #-}
module DummyServer where

import Control.Monad
import Control.Monad.Reader
import Data.Aeson hiding (defaultOptions, Null)
import qualified Data.Map.Strict as M
import Data.List (isSuffixOf)
import Data.String
import UnliftIO.Concurrent
import Language.LSP.Server
import System.IO
import UnliftIO
import System.Directory
import System.FilePath
import System.Process
import Language.LSP.Protocol.Types
import Language.LSP.Protocol.Message
import Data.Proxy

withDummyServer :: ((Handle, Handle) -> IO ()) -> IO ()
withDummyServer f = do
  (hinRead, hinWrite) <- createPipe
  (houtRead, houtWrite) <- createPipe

  handlerEnv <- HandlerEnv <$> newEmptyMVar <*> newEmptyMVar
  let definition = ServerDefinition
        { doInitialize = \env _req -> pure $ Right env
        , defaultConfig = ()
        , onConfigurationChange = const $ pure $ Right ()
        , staticHandlers = \_caps -> handlers
        , interpretHandler = \env ->
            Iso (\m -> runLspT env (runReaderT m handlerEnv)) liftIO
        , options = defaultOptions {optExecuteCommandCommands = Just ["doAnEdit"]}
        }

  bracket
    (forkIO $ void $ runServerWithHandles mempty mempty hinRead houtWrite definition)
    killThread
    (const $ f (hinWrite, houtRead))


data HandlerEnv = HandlerEnv
  { relRegToken :: MVar (RegistrationToken Method_WorkspaceDidChangeWatchedFiles)
  , absRegToken :: MVar (RegistrationToken Method_WorkspaceDidChangeWatchedFiles)
  }

handlers :: Handlers (ReaderT HandlerEnv (LspM ()))
handlers =
  mconcat
    [ notificationHandler SMethod_Initialized $
        \_noti ->
          sendNotification SMethod_WindowLogMessage $
            LogMessageParams MessageType_Log "initialized"
    , requestHandler SMethod_TextDocumentHover $
        \_req responder ->
          responder $
            Right $
              InL $
                Hover (InL (MarkupContent MarkupKind_PlainText "hello")) Nothing
    , requestHandler SMethod_TextDocumentDocumentSymbol $
        \_req responder ->
          responder $
            Right $
              InR $ InL
                [ DocumentSymbol
                    "foo"
                    Nothing
                    SymbolKind_Object
                    Nothing
                    Nothing
                    (mkRange 0 0 3 6)
                    (mkRange 0 0 3 6)
                    Nothing
                ]
     , notificationHandler SMethod_TextDocumentDidOpen $
        \noti -> do
          let TNotificationMessage _ _ (DidOpenTextDocumentParams doc) = noti
              TextDocumentItem uri _ _ _ = doc
              Just fp = uriToFilePath uri
              diag =
                Diagnostic
                  (mkRange 0 0 0 1)
                  (Just DiagnosticSeverity_Warning)
                  (Just (InL 42))
                  Nothing
                  (Just "dummy-server")
                  "Here's a warning"
                  Nothing
                  Nothing
                  Nothing
          withRunInIO $
            \runInIO -> do
              when (".hs" `isSuffixOf` fp) $
                void $
                  forkIO $
                    do
                      threadDelay (2 * 10 ^ 6)
                      runInIO $
                        sendNotification SMethod_TextDocumentPublishDiagnostics $
                          PublishDiagnosticsParams uri Nothing [diag]
              -- also act as a registerer for workspace/didChangeWatchedFiles
              when (".register" `isSuffixOf` fp) $
                do
                  let regOpts =
                        DidChangeWatchedFilesRegistrationOptions
                          [ FileSystemWatcher
                              (GlobPattern $ InL $ Pattern "*.watch")
                              (Just WatchKind_Create)
                          ]
                  Just token <- runInIO $
                    registerCapability SMethod_WorkspaceDidChangeWatchedFiles regOpts $
                      \_noti ->
                        sendNotification SMethod_WindowLogMessage $
                          LogMessageParams MessageType_Log "got workspace/didChangeWatchedFiles"
                  runInIO $ asks relRegToken >>= \v -> putMVar v token
              when (".register.abs" `isSuffixOf` fp) $
                do
                  curDir <- getCurrentDirectory
                  let regOpts =
                        DidChangeWatchedFilesRegistrationOptions
                          [ FileSystemWatcher
                              (GlobPattern $ InL $ Pattern $ fromString $ curDir </> "*.watch")
                              (Just WatchKind_Create)
                          ]
                  Just token <- runInIO $
                    registerCapability SMethod_WorkspaceDidChangeWatchedFiles regOpts $
                      \_noti ->
                        sendNotification SMethod_WindowLogMessage $
                          LogMessageParams MessageType_Log "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

      -- this handler is used by the
      -- "text document VFS / sends back didChange notifications (documentChanges)" test
    , notificationHandler SMethod_TextDocumentDidChange $ \noti -> do
        let TNotificationMessage _ _ params = noti
        void $ sendNotification (SMethod_CustomMethod (Proxy @"custom/textDocument/didChange")) (toJSON params)

     , requestHandler SMethod_WorkspaceExecuteCommand $ \req resp -> do
       case req of
        TRequestMessage _ _ _ (ExecuteCommandParams Nothing "doAnEdit" (Just [val])) -> do
          let
            Success docUri = fromJSON val
            edit = [TextEdit (mkRange 0 0 0 5) "howdy"]
            params =
              ApplyWorkspaceEditParams (Just "Howdy edit") $
                WorkspaceEdit (Just (M.singleton docUri edit)) Nothing Nothing
          resp $ Right $ InR $ Null
          void $ sendRequest SMethod_WorkspaceApplyEdit params (const (pure ()))
        TRequestMessage _ _ _ (ExecuteCommandParams Nothing "doAVersionedEdit" (Just [val])) -> do
          let
            Success versionedDocUri = fromJSON val
            edit = [InL (TextEdit (mkRange 0 0 0 5) "howdy")]
            documentEdit = TextDocumentEdit versionedDocUri edit
            params =
              ApplyWorkspaceEditParams (Just "Howdy edit") $
                WorkspaceEdit Nothing (Just [InL documentEdit]) Nothing
          resp $ Right $ InR Null
          void $ sendRequest SMethod_WorkspaceApplyEdit params (const (pure ()))
        TRequestMessage _ _ _ (ExecuteCommandParams _ name _) ->
          error $ "unsupported command: " <> show name
     , requestHandler SMethod_TextDocumentCodeAction $ \req resp -> do
        let TRequestMessage _ _ _ params = req
            CodeActionParams _ _ _ _ cactx = params
            CodeActionContext diags _ _ = cactx
            codeActions = fmap diag2ca diags
            diag2ca d =
              CodeAction
                "Delete this"
                Nothing
                (Just [d])
                Nothing
                Nothing
                Nothing
                (Just (Command "" "deleteThis" Nothing))
                Nothing
        resp $ Right $ InL $ InR <$> codeActions
     , requestHandler SMethod_TextDocumentCompletion $ \_req resp -> do
        let res = CompletionList True Nothing [item]
            item =
              CompletionItem
                "foo"
                Nothing
                (Just CompletionItemKind_Constant)
                (Just [])
                Nothing
                Nothing
                Nothing
                Nothing
                Nothing
                Nothing
                Nothing
                Nothing
                Nothing
                Nothing
                Nothing
                Nothing
                Nothing
                Nothing
                Nothing
        resp $ Right $ InR $ InL res
     , requestHandler SMethod_TextDocumentPrepareCallHierarchy $ \req resp -> do
        let TRequestMessage _ _ _ params = req
            CallHierarchyPrepareParams _ pos _ = params
            Position x y = pos
            item =
              CallHierarchyItem
                "foo"
                SymbolKind_Method
                Nothing
                Nothing
                (Uri "")
                (Range (Position 2 3) (Position 4 5))
                (Range (Position 2 3) (Position 4 5))
                Nothing
        if x == 0 && y == 0
          then resp $ Right $ InR Null
          else resp $ Right $ InL [item]
     , requestHandler SMethod_CallHierarchyIncomingCalls $ \req resp -> do
        let TRequestMessage _ _ _ params = req
            CallHierarchyIncomingCallsParams _ _ item = params
        resp $ Right $ InL
          [CallHierarchyIncomingCall item [Range (Position 2 3) (Position 4 5)]]
     , requestHandler SMethod_CallHierarchyOutgoingCalls $ \req resp -> do
        let TRequestMessage _ _ _ params = req
            CallHierarchyOutgoingCallsParams _ _ item = params
        resp $ Right $ InL
          [CallHierarchyOutgoingCall item [Range (Position 4 5) (Position 2 3)]]
     , requestHandler SMethod_TextDocumentSemanticTokensFull $ \_req resp -> do
        let tokens = makeSemanticTokens defaultSemanticTokensLegend [SemanticTokenAbsolute 0 1 2 SemanticTokenTypes_Type []]
        case tokens of
          Left t -> resp $ Left $ ResponseError (InR ErrorCodes_InternalError) t Nothing
          Right tokens -> resp $ Right $ InL tokens
    ]