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)) ]
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)) ]
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))
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"
121 (Just (Command "" "deleteThis" Nothing))
122 send $ RspCodeAction $ makeResponseMessage req caresults
123 , didChangeWatchedFilesNotificationHandler = pure $ \_ ->
124 send $ NotLogMessage $ fmServerLogMessageNotification MtLog "got workspace/didChangeWatchedFiles"
126 where send msg = readMVar lfvar >>= \lf -> (sendFunc lf) msg
128 mkRange sl sc el ec = Range (Position sl sc) (Position el ec)