1 {-# LANGUAGE TypeInType #-}
2 {-# LANGUAGE OverloadedStrings #-}
5 import Control.Monad.Reader
6 import Data.Aeson hiding (defaultOptions)
7 import qualified Data.HashMap.Strict as HM
8 import Data.List (isSuffixOf)
10 import Language.LSP.Server
11 import Language.LSP.Types
12 import System.Directory
13 import System.FilePath
15 import UnliftIO.Concurrent
18 handlerEnv <- HandlerEnv <$> newEmptyMVar <*> newEmptyMVar
19 runServer $ ServerDefinition
20 { doInitialize = \env _req -> pure $ Right env,
21 onConfigurationChange = const $ pure $ Right (),
22 staticHandlers = handlers,
23 interpretHandler = \env ->
25 (\m -> runLspT env (runReaderT m handlerEnv))
27 options = defaultOptions {executeCommandCommands = Just ["doAnEdit"]}
30 data HandlerEnv = HandlerEnv
31 { relRegToken :: MVar (RegistrationToken WorkspaceDidChangeWatchedFiles),
32 absRegToken :: MVar (RegistrationToken WorkspaceDidChangeWatchedFiles)
35 handlers :: Handlers (ReaderT HandlerEnv (LspM ()))
38 [ notificationHandler SInitialized $
40 sendNotification SWindowLogMessage $
41 LogMessageParams MtLog "initialized"
42 , requestHandler STextDocumentHover $
47 Hover (HoverContents (MarkupContent MkPlainText "hello")) Nothing
48 , requestHandler STextDocumentDocumentSymbol $
63 , notificationHandler STextDocumentDidOpen $
65 let NotificationMessage _ _ (DidOpenTextDocumentParams doc) = noti
66 TextDocumentItem uri _ _ _ = doc
67 Just fp = uriToFilePath uri
79 when (".hs" `isSuffixOf` fp) $
83 threadDelay (2 * 10 ^ 6)
85 sendNotification STextDocumentPublishDiagnostics $
86 PublishDiagnosticsParams uri Nothing (List [diag])
87 -- also act as a registerer for workspace/didChangeWatchedFiles
88 when (".register" `isSuffixOf` fp) $
91 DidChangeWatchedFilesRegistrationOptions $
95 (Just (WatchKind True True True))
97 Just token <- runInIO $
98 registerCapability SWorkspaceDidChangeWatchedFiles regOpts $
100 sendNotification SWindowLogMessage $
101 LogMessageParams MtLog "got workspace/didChangeWatchedFiles"
102 runInIO $ asks relRegToken >>= \v -> putMVar v token
103 when (".register.abs" `isSuffixOf` fp) $
105 curDir <- getCurrentDirectory
107 DidChangeWatchedFilesRegistrationOptions $
110 (fromString $ curDir </> "*.watch")
111 (Just (WatchKind True True True))
113 Just token <- runInIO $
114 registerCapability SWorkspaceDidChangeWatchedFiles regOpts $
116 sendNotification SWindowLogMessage $
117 LogMessageParams MtLog "got workspace/didChangeWatchedFiles"
118 runInIO $ asks absRegToken >>= \v -> putMVar v token
119 -- also act as an unregisterer for workspace/didChangeWatchedFiles
120 when (".unregister" `isSuffixOf` fp) $
122 Just token <- runInIO $ asks relRegToken >>= tryReadMVar
123 runInIO $ unregisterCapability token
124 when (".unregister.abs" `isSuffixOf` fp) $
126 Just token <- runInIO $ asks absRegToken >>= tryReadMVar
127 runInIO $ unregisterCapability token
128 , requestHandler SWorkspaceExecuteCommand $ \req resp -> do
129 let RequestMessage _ _ _ (ExecuteCommandParams Nothing "doAnEdit" (Just (List [val]))) = req
130 Success docUri = fromJSON val
131 edit = List [TextEdit (mkRange 0 0 0 5) "howdy"]
133 ApplyWorkspaceEditParams (Just "Howdy edit") $
134 WorkspaceEdit (Just (HM.singleton docUri edit)) Nothing
136 void $ sendRequest SWorkspaceApplyEdit params (const (pure ()))
137 , requestHandler STextDocumentCodeAction $ \req resp -> do
138 let RequestMessage _ _ _ params = req
139 CodeActionParams _ _ _ _ cactx = params
140 CodeActionContext diags _ = cactx
141 codeActions = fmap diag2ca diags
150 (Just (Command "" "deleteThis" Nothing))
151 resp $ Right $ InR <$> codeActions
152 , requestHandler STextDocumentCompletion $ \_req resp -> do
153 let res = CompletionList True (List [item])
172 resp $ Right $ InR res