test/dummy-server/Main.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 import Data.Aeson
   3 import Data.Default
   4 import Data.List (isSuffixOf)
   5 import qualified Data.HashMap.Strict as HM
   6 import Language.Haskell.LSP.Core
   7 import Language.Haskell.LSP.Control
   8 import Language.Haskell.LSP.Messages
   9 import Language.Haskell.LSP.Types
  10 import Control.Concurrent
  11 import Control.Monad
  12 import System.Directory
  13 import System.FilePath
  14
  15 main = do
  16   lfvar <- newEmptyMVar
  17   let initCbs = InitializeCallbacks
  18         { onInitialConfiguration = const $ Right ()
  19         , onConfigurationChange = const $ Right ()
  20         , onStartup = \lf -> do
  21             putMVar lfvar lf
  22
  23             return Nothing
  24         }
  25       options = def
  26         { executeCommandCommands = Just ["doAnEdit"]
  27         }
  28   run initCbs (handlers lfvar) options Nothing
  29
  30 handlers :: MVar (LspFuncs ()) -> Handlers
  31 handlers lfvar = def
  32   { initializedHandler = pure $ \_ -> send $ NotLogMessage $ fmServerLogMessageNotification MtLog "initialized"
  33   , hoverHandler = pure $ \req -> send $
  34       RspHover $ makeResponseMessage req (Just (Hover (HoverContents (MarkupContent MkPlainText "hello")) Nothing))
  35   , documentSymbolHandler = pure $ \req -> send $
  36       RspDocumentSymbols $ makeResponseMessage req $ DSDocumentSymbols $
  37         List [ DocumentSymbol "foo"
  38                               Nothing
  39                               SkObject
  40                               Nothing
  41                               (mkRange 0 0 3 6)
  42                               (mkRange 0 0 3 6)
  43                               Nothing
  44              ]
  45   , didOpenTextDocumentNotificationHandler = pure $ \noti -> do
  46       let NotificationMessage _ _ (DidOpenTextDocumentParams doc) = noti
  47           TextDocumentItem uri _ _ _ = doc
  48           Just fp = uriToFilePath uri
  49           diag = Diagnostic (mkRange 0 0 0 1)
  50                             (Just DsWarning)
  51                             (Just (NumberValue 42))
  52                             (Just "dummy-server")
  53                             "Here's a warning"
  54                             Nothing
  55                             Nothing
  56       when (".hs" `isSuffixOf` fp) $ void $ forkIO $ do
  57         threadDelay (2 * 10^6)
  58         send $ NotPublishDiagnostics $
  59           fmServerPublishDiagnosticsNotification $ PublishDiagnosticsParams uri $ List [diag]
  60
  61       -- also act as a registerer for workspace/didChangeWatchedFiles
  62       when (".register" `isSuffixOf` fp) $ do
  63         reqId <- readMVar lfvar >>= getNextReqId
  64         send $ ReqRegisterCapability $ fmServerRegisterCapabilityRequest reqId $
  65           RegistrationParams $ List $
  66             [ Registration "0" WorkspaceDidChangeWatchedFiles $ Just $ toJSON $
  67                 DidChangeWatchedFilesRegistrationOptions $ List
  68                 [ FileSystemWatcher "*.watch" (Just (WatchKind True True True)) ]
  69             ]
  70       when (".register.abs" `isSuffixOf` fp) $ do
  71         curDir <- getCurrentDirectory
  72         reqId <- readMVar lfvar >>= getNextReqId
  73         send $ ReqRegisterCapability $ fmServerRegisterCapabilityRequest reqId $
  74           RegistrationParams $ List $
  75             [ Registration "1" WorkspaceDidChangeWatchedFiles $ Just $ toJSON $
  76                 DidChangeWatchedFilesRegistrationOptions $ List
  77                 [ FileSystemWatcher (curDir </> "*.watch") (Just (WatchKind True True True)) ]
  78             ]
  79
  80       -- also act as an unregisterer for workspace/didChangeWatchedFiles
  81       when (".unregister" `isSuffixOf` fp) $ do
  82         reqId <- readMVar lfvar >>= getNextReqId
  83         send $ ReqUnregisterCapability $ fmServerUnregisterCapabilityRequest reqId $
  84           UnregistrationParams $ List [ Unregistration "0" "workspace/didChangeWatchedFiles" ]
  85       when (".unregister.abs" `isSuffixOf` fp) $ do
  86         reqId <- readMVar lfvar >>= getNextReqId
  87         send $ ReqUnregisterCapability $ fmServerUnregisterCapabilityRequest reqId $
  88           UnregistrationParams $ List [ Unregistration "1" "workspace/didChangeWatchedFiles" ]
  89   , executeCommandHandler = pure $ \req -> do
  90       send $ RspExecuteCommand $ makeResponseMessage req Null
  91       reqId <- readMVar lfvar >>= getNextReqId
  92       let RequestMessage _ _ _ (ExecuteCommandParams "doAnEdit" (Just (List [val])) _) = req
  93           Success docUri = fromJSON val
  94           edit = List [TextEdit (mkRange 0 0 0 5) "howdy"]
  95       send $ ReqApplyWorkspaceEdit $ fmServerApplyWorkspaceEditRequest reqId $
  96         ApplyWorkspaceEditParams $ WorkspaceEdit (Just (HM.singleton docUri edit))
  97                                                  Nothing
  98   , codeActionHandler = pure $ \req -> do
  99       let RequestMessage _ _ _ params = req
 100           CodeActionParams _ _ cactx _ = params
 101           CodeActionContext diags _ = cactx
 102           caresults = fmap diag2caresult diags
 103           diag2caresult d = CACodeAction $
 104             CodeAction "Delete this"
 105                        Nothing
 106                        (Just (List [d]))
 107                        Nothing
 108                       (Just (Command "" "deleteThis" Nothing))
 109       send $ RspCodeAction $ makeResponseMessage req caresults
 110   , didChangeWatchedFilesNotificationHandler = pure $ \_ ->
 111       send $ NotLogMessage $ fmServerLogMessageNotification MtLog "got workspace/didChangeWatchedFiles"
 112   , completionHandler = pure $ \req -> do
 113       let res = CompletionList (CompletionListType False (List [item]))
 114           item =
 115             CompletionItem "foo" (Just CiConstant) (Just (List [])) Nothing
 116             Nothing Nothing Nothing Nothing Nothing Nothing Nothing
 117             Nothing Nothing Nothing Nothing Nothing
 118       send $ RspCompletion $ makeResponseMessage req res
 119   }
 120   where send msg = readMVar lfvar >>= \lf -> (sendFunc lf) msg
 121
 122 mkRange sl sc el ec = Range (Position sl sc) (Position el ec)