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       when (".register.tmp" `isSuffixOf` fp) $ do
  80         tmpDir <- getTemporaryDirectory
  81         reqId <- readMVar lfvar >>= getNextReqId
  82         send $ ReqRegisterCapability $ fmServerRegisterCapabilityRequest reqId $
  83           RegistrationParams $ List $
  84             [ Registration "2" WorkspaceDidChangeWatchedFiles $ Just $ toJSON $
  85                 DidChangeWatchedFilesRegistrationOptions $ List
  86                 [ FileSystemWatcher (tmpDir </> "*.watch") (Just (WatchKind True True True)) ]
  87             ]
  88
  89       -- also act as an unregisterer for workspace/didChangeWatchedFiles
  90       when (".unregister" `isSuffixOf` fp) $ do
  91         reqId <- readMVar lfvar >>= getNextReqId
  92         send $ ReqUnregisterCapability $ fmServerUnregisterCapabilityRequest reqId $
  93           UnregistrationParams $ List [ Unregistration "0" "workspace/didChangeWatchedFiles" ]
  94       when (".unregister.abs" `isSuffixOf` fp) $ do
  95         reqId <- readMVar lfvar >>= getNextReqId
  96         send $ ReqUnregisterCapability $ fmServerUnregisterCapabilityRequest reqId $
  97           UnregistrationParams $ List [ Unregistration "1" "workspace/didChangeWatchedFiles" ]
  98       when (".unregister.tmp" `isSuffixOf` fp) $ do
  99         reqId <- readMVar lfvar >>= getNextReqId
 100         send $ ReqUnregisterCapability $ fmServerUnregisterCapabilityRequest reqId $
 101           UnregistrationParams $ List [ Unregistration "2" "workspace/didChangeWatchedFiles" ]
 102   , executeCommandHandler = pure $ \req -> do
 103       send $ RspExecuteCommand $ makeResponseMessage req Null
 104       reqId <- readMVar lfvar >>= getNextReqId
 105       let RequestMessage _ _ _ (ExecuteCommandParams "doAnEdit" (Just (List [val])) _) = req
 106           Success docUri = fromJSON val
 107           edit = List [TextEdit (mkRange 0 0 0 5) "howdy"]
 108       send $ ReqApplyWorkspaceEdit $ fmServerApplyWorkspaceEditRequest reqId $
 109         ApplyWorkspaceEditParams $ WorkspaceEdit (Just (HM.singleton docUri edit))
 110                                                  Nothing
 111   , codeActionHandler = pure $ \req -> do
 112       let RequestMessage _ _ _ params = req
 113           CodeActionParams _ _ cactx _ = params
 114           CodeActionContext diags _ = cactx
 115           caresults = fmap diag2caresult diags
 116           diag2caresult d = CACodeAction $
 117             CodeAction "Delete this"
 118                        Nothing
 119                        (Just (List [d]))
 120                        Nothing
 121                       (Just (Command "" "deleteThis" Nothing))
 122       send $ RspCodeAction $ makeResponseMessage req caresults
 123   , didChangeWatchedFilesNotificationHandler = pure $ \_ ->
 124       send $ NotLogMessage $ fmServerLogMessageNotification MtLog "got workspace/didChangeWatchedFiles"
 125   }
 126   where send msg = readMVar lfvar >>= \lf -> (sendFunc lf) msg
 127
 128 mkRange sl sc el ec = Range (Position sl sc) (Position el ec)