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)
9 import Language.LSP.Server
10 import Language.LSP.Types
11 import System.Directory
12 import System.FilePath
14 import UnliftIO.Concurrent
17 handlerEnv <- HandlerEnv <$> newEmptyMVar <*> newEmptyMVar
18 runServer $ ServerDefinition
19 { doInitialize = \env _req -> pure $ Right env,
20 onConfigurationChange = const $ pure $ Right (),
21 staticHandlers = handlers,
22 interpretHandler = \env ->
24 (\m -> runLspT env (runReaderT m handlerEnv))
26 options = defaultOptions {executeCommandCommands = Just ["doAnEdit"]}
29 data HandlerEnv = HandlerEnv
30 { relRegToken :: MVar (RegistrationToken WorkspaceDidChangeWatchedFiles),
31 absRegToken :: MVar (RegistrationToken WorkspaceDidChangeWatchedFiles)
34 handlers :: Handlers (ReaderT HandlerEnv (LspM ()))
37 [ notificationHandler SInitialized $
39 sendNotification SWindowLogMessage $
40 LogMessageParams MtLog "initialized",
41 requestHandler STextDocumentHover $
46 Hover (HoverContents (MarkupContent MkPlainText "hello")) Nothing,
47 requestHandler STextDocumentDocumentSymbol $
62 notificationHandler STextDocumentDidOpen $
64 let NotificationMessage _ _ (DidOpenTextDocumentParams doc) = noti
65 TextDocumentItem uri _ _ _ = doc
66 Just fp = uriToFilePath uri
78 when (".hs" `isSuffixOf` fp) $
82 threadDelay (2 * 10 ^ 6)
84 sendNotification STextDocumentPublishDiagnostics $
85 PublishDiagnosticsParams uri Nothing (List [diag])
86 -- also act as a registerer for workspace/didChangeWatchedFiles
87 when (".register" `isSuffixOf` fp) $
90 DidChangeWatchedFilesRegistrationOptions $
94 (Just (WatchKind True True True))
96 Just token <- runInIO $
97 registerCapability SWorkspaceDidChangeWatchedFiles regOpts $
99 sendNotification SWindowLogMessage $
100 LogMessageParams MtLog "got workspace/didChangeWatchedFiles"
101 runInIO $ asks relRegToken >>= \v -> putMVar v token
102 when (".register.abs" `isSuffixOf` fp) $
104 curDir <- getCurrentDirectory
106 DidChangeWatchedFilesRegistrationOptions $
109 (curDir </> "*.watch")
110 (Just (WatchKind True True True))
112 Just token <- runInIO $
113 registerCapability SWorkspaceDidChangeWatchedFiles regOpts $
115 sendNotification SWindowLogMessage $
116 LogMessageParams MtLog "got workspace/didChangeWatchedFiles"
117 runInIO $ asks absRegToken >>= \v -> putMVar v token
118 -- also act as an unregisterer for workspace/didChangeWatchedFiles
119 when (".unregister" `isSuffixOf` fp) $
121 Just token <- runInIO $ asks relRegToken >>= tryReadMVar
122 runInIO $ unregisterCapability token
123 when (".unregister.abs" `isSuffixOf` fp) $
125 Just token <- runInIO $ asks absRegToken >>= tryReadMVar
126 runInIO $ unregisterCapability token,
127 requestHandler SWorkspaceExecuteCommand $ \req resp -> do
128 let RequestMessage _ _ _ (ExecuteCommandParams Nothing "doAnEdit" (Just (List [val]))) = req
129 Success docUri = fromJSON val
130 edit = List [TextEdit (mkRange 0 0 0 5) "howdy"]
132 ApplyWorkspaceEditParams (Just "Howdy edit") $
133 WorkspaceEdit (Just (HM.singleton docUri edit)) Nothing
135 void $ sendRequest SWorkspaceApplyEdit params (const (pure ())),
136 requestHandler STextDocumentCodeAction $ \req resp -> do
137 let RequestMessage _ _ _ params = req
138 CodeActionParams _ _ _ _ cactx = params
139 CodeActionContext diags _ = cactx
140 codeActions = fmap diag2ca diags
148 (Just (Command "" "deleteThis" Nothing))
149 resp $ Right $ InR <$> codeActions,
150 requestHandler STextDocumentCompletion $ \_req resp -> do
151 let res = CompletionList True (List [item])
170 resp $ Right $ InR res