1 {-# LANGUAGE OverloadedStrings #-}
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
12 import System.Directory
13 import System.FilePath
17 let initCbs = InitializeCallbacks
18 { onInitialConfiguration = const $ Right ()
19 , onConfigurationChange = const $ Right ()
20 , onStartup = \lf -> do
26 { executeCommandCommands = Just ["doAnEdit"]
28 run initCbs (handlers lfvar) options Nothing
30 handlers :: MVar (LspFuncs ()) -> Handlers
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"
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)
51 (Just (NumberValue 42))
56 when (".hs" `isSuffixOf` fp) $ void $ forkIO $ do
57 threadDelay (2 * 10^6)
58 send $ NotPublishDiagnostics $
59 fmServerPublishDiagnosticsNotification $ PublishDiagnosticsParams uri $ List [diag]
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)) ]
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)) ]
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))
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"
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]))
115 CompletionItem "foo" (Just CiConstant) (List []) Nothing
116 Nothing Nothing Nothing Nothing Nothing Nothing Nothing
117 Nothing Nothing Nothing Nothing Nothing
118 send $ RspCompletion $ makeResponseMessage req res
120 where send msg = readMVar lfvar >>= \lf -> (sendFunc lf) msg
122 mkRange sl sc el ec = Range (Position sl sc) (Position el ec)