1 {-# LANGUAGE OverloadedStrings #-}
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
14 let initCbs = InitializeCallbacks
15 { onInitialConfiguration = const $ Right ()
16 , onConfigurationChange = const $ Right ()
17 , onStartup = \lf -> do
23 { executeCommandCommands = Just ["doAnEdit"]
25 run initCbs (handlers lfvar) options Nothing
27 handlers :: MVar (LspFuncs ()) -> Handlers
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"
38 (Range (Position 0 0) (Position 0 1))
39 (Range (Position 0 0) (Position 0 1))
42 , didOpenTextDocumentNotificationHandler = pure $ \noti ->
44 threadDelay (2 * 10^6)
45 let NotificationMessage _ _ (DidOpenTextDocumentParams doc) = noti
46 TextDocumentItem uri _ _ _ = doc
47 diag = Diagnostic (Range (Position 0 0) (Position 0 1))
49 (Just (NumberValue 42))
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 (Range (Position 0 0) (Position 0 5)) "howdy"]
62 send $ ReqApplyWorkspaceEdit $ fmServerApplyWorkspaceEditRequest reqId $
63 ApplyWorkspaceEditParams $ WorkspaceEdit (Just (HM.singleton docUri edit))
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"
75 (Just (Command "" "deleteThis" Nothing))
76 send $ RspCodeAction $ makeResponseMessage req caresults
78 where send msg = readMVar lfvar >>= \lf -> (sendFunc lf) msg