test/dummy-server/Main.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 import Data.Aeson
   3 import Data.Default
   4 import qualified Data.HashMap.Strict as HM
   5 import Language.Haskell.LSP.Core
   6 import Language.Haskell.LSP.Control
   7 import Language.Haskell.LSP.Messages
   8 import Language.Haskell.LSP.Types
   9 import Control.Concurrent
  10 import Control.Monad
  11
  12 main = do
  13   lfvar <- newEmptyMVar
  14   let initCbs = InitializeCallbacks
  15         { onInitialConfiguration = const $ Right ()
  16         , onConfigurationChange = const $ Right ()
  17         , onStartup = \lf -> do
  18             putMVar lfvar lf
  19
  20             return Nothing
  21         }
  22       options = def
  23         { executeCommandCommands = Just ["doAnEdit"]
  24         }
  25   run initCbs (handlers lfvar) options Nothing
  26
  27 handlers :: MVar (LspFuncs ()) -> Handlers
  28 handlers lfvar = def
  29   { initializedHandler = pure $ \_ -> send $ NotLogMessage $ fmServerLogMessageNotification MtLog "initialized"
  30   , hoverHandler = pure $ \req -> send $
  31       RspHover $ makeResponseMessage req (Just (Hover (HoverContents (MarkupContent MkPlainText "hello")) Nothing))
  32   , documentSymbolHandler = pure $ \req -> send $
  33       RspDocumentSymbols $ makeResponseMessage req $ DSDocumentSymbols $
  34         List [ DocumentSymbol "foo"
  35                               Nothing
  36                               SkObject
  37                               Nothing
  38                               (mkRange 0 0 3 6)
  39                               (mkRange 0 0 3 6)
  40                               Nothing
  41              ]
  42   , didOpenTextDocumentNotificationHandler = pure $ \noti ->
  43       void $ forkIO $ do
  44         threadDelay (2 * 10^6)
  45         let NotificationMessage _ _ (DidOpenTextDocumentParams doc) = noti
  46             TextDocumentItem uri _ _ _ = doc
  47             diag = Diagnostic (mkRange 0 0 0 1)
  48                               (Just DsWarning)
  49                               (Just (NumberValue 42))
  50                               (Just "dummy-server")
  51                               "Here's a warning"
  52                               Nothing
  53                               Nothing
  54         send $ NotPublishDiagnostics $
  55           fmServerPublishDiagnosticsNotification $ PublishDiagnosticsParams uri $ List [diag]
  56   , executeCommandHandler = pure $ \req -> do
  57       send $ RspExecuteCommand $ makeResponseMessage req Null
  58       reqId <- readMVar lfvar >>= getNextReqId
  59       let RequestMessage _ _ _ (ExecuteCommandParams "doAnEdit" (Just (List [val])) _) = req
  60           Success docUri = fromJSON val
  61           edit = List [TextEdit (mkRange 0 0 0 5) "howdy"]
  62       send $ ReqApplyWorkspaceEdit $ fmServerApplyWorkspaceEditRequest reqId $
  63         ApplyWorkspaceEditParams $ WorkspaceEdit (Just (HM.singleton docUri edit))
  64                                                  Nothing
  65   , codeActionHandler = pure $ \req -> do
  66       let RequestMessage _ _ _ params = req
  67           CodeActionParams _ _ cactx _ = params
  68           CodeActionContext diags _ = cactx
  69           caresults = fmap diag2caresult diags
  70           diag2caresult d = CACodeAction $
  71             CodeAction "Delete this"
  72                        Nothing
  73                        (Just (List [d]))
  74                        Nothing
  75                       (Just (Command "" "deleteThis" Nothing))
  76       send $ RspCodeAction $ makeResponseMessage req caresults
  77   }
  78   where send msg = readMVar lfvar >>= \lf -> (sendFunc lf) msg
  79
  80 mkRange sl sc el ec = Range (Position sl sc) (Position el ec)