+{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
+
+import Control.Monad
+import Control.Monad.Reader
import Data.Aeson
import Data.Default
-import Data.List (isSuffixOf)
import qualified Data.HashMap.Strict as HM
-import Language.Haskell.LSP.Core
+import Data.List (isSuffixOf)
import Language.Haskell.LSP.Control
-import Language.Haskell.LSP.Messages
+import Language.Haskell.LSP.Core
import Language.Haskell.LSP.Types
-import Control.Concurrent
-import Control.Monad
import System.Directory
import System.FilePath
+import UnliftIO
+import UnliftIO.Concurrent
main = do
- lfvar <- newEmptyMVar
- let initCbs = InitializeCallbacks
- { onInitialConfiguration = const $ Right ()
- , onConfigurationChange = const $ Right ()
- , onStartup = \lf -> do
- putMVar lfvar lf
-
- return Nothing
+ handlerEnv <- HandlerEnv <$> newEmptyMVar <*> newEmptyMVar
+ let initCbs =
+ InitializeCallbacks
+ { doInitialize = \env _req -> pure $ Right env,
+ onConfigurationChange = const $ pure $ Right (),
+ staticHandlers = handlers,
+ interpretHandler = \env ->
+ Iso
+ (\m -> runLspT env (runReaderT m handlerEnv))
+ liftIO
}
- options = def
- { executeCommandCommands = Just ["doAnEdit"]
+ options = def {executeCommandCommands = Just ["doAnEdit"]}
+ run initCbs options
+
+data HandlerEnv = HandlerEnv
+ { relRegToken :: MVar (RegistrationToken WorkspaceDidChangeWatchedFiles),
+ absRegToken :: MVar (RegistrationToken WorkspaceDidChangeWatchedFiles)
}
- run initCbs (handlers lfvar) options Nothing
-handlers :: MVar (LspFuncs ()) -> Handlers
-handlers lfvar = def
- { initializedHandler = pure $ \_ -> send $ NotLogMessage $ fmServerLogMessageNotification MtLog "initialized"
- , hoverHandler = pure $ \req -> send $
- RspHover $ makeResponseMessage req (Just (Hover (HoverContents (MarkupContent MkPlainText "hello")) Nothing))
- , documentSymbolHandler = pure $ \req -> send $
- RspDocumentSymbols $ makeResponseMessage req $ DSDocumentSymbols $
- List [ DocumentSymbol "foo"
+handlers :: Handlers (ReaderT HandlerEnv (LspM ()))
+handlers =
+ mconcat
+ [ notificationHandler SInitialized $
+ \_noti ->
+ sendNotification SWindowLogMessage $
+ LogMessageParams MtLog "initialized",
+ requestHandler STextDocumentHover $
+ \_req responder ->
+ responder $
+ Right $
+ Just $
+ Hover (HoverContents (MarkupContent MkPlainText "hello")) Nothing,
+ requestHandler STextDocumentDocumentSymbol $
+ \_req responder ->
+ responder $
+ Right $
+ InL $
+ List
+ [ DocumentSymbol
+ "foo"
Nothing
SkObject
Nothing
(mkRange 0 0 3 6)
(mkRange 0 0 3 6)
Nothing
- ]
- , didOpenTextDocumentNotificationHandler = pure $ \noti -> do
+ ],
+ notificationHandler STextDocumentDidOpen $
+ \noti -> do
let NotificationMessage _ _ (DidOpenTextDocumentParams doc) = noti
TextDocumentItem uri _ _ _ = doc
Just fp = uriToFilePath uri
- diag = Diagnostic (mkRange 0 0 0 1)
+ diag =
+ Diagnostic
+ (mkRange 0 0 0 1)
(Just DsWarning)
- (Just (NumberValue 42))
+ (Just (InL 42))
(Just "dummy-server")
"Here's a warning"
Nothing
Nothing
- when (".hs" `isSuffixOf` fp) $ void $ forkIO $ do
+ withRunInIO $
+ \runInIO -> do
+ when (".hs" `isSuffixOf` fp) $
+ void $
+ forkIO $
+ do
threadDelay (2 * 10 ^ 6)
- send $ NotPublishDiagnostics $
- fmServerPublishDiagnosticsNotification $ PublishDiagnosticsParams uri $ List [diag]
-
+ runInIO $
+ sendNotification STextDocumentPublishDiagnostics $
+ PublishDiagnosticsParams uri Nothing (List [diag])
-- also act as a registerer for workspace/didChangeWatchedFiles
- when (".register" `isSuffixOf` fp) $ do
- reqId <- readMVar lfvar >>= getNextReqId
- send $ ReqRegisterCapability $ fmServerRegisterCapabilityRequest reqId $
- RegistrationParams $ List $
- [ Registration "0" WorkspaceDidChangeWatchedFiles $ Just $ toJSON $
- DidChangeWatchedFilesRegistrationOptions $ List
- [ FileSystemWatcher "*.watch" (Just (WatchKind True True True)) ]
+ when (".register" `isSuffixOf` fp) $
+ do
+ let regOpts =
+ DidChangeWatchedFilesRegistrationOptions $
+ List
+ [ FileSystemWatcher
+ "*.watch"
+ (Just (WatchKind True True True))
]
- when (".register.abs" `isSuffixOf` fp) $ do
+ Just token <- runInIO $
+ registerCapability SWorkspaceDidChangeWatchedFiles regOpts $
+ \_noti ->
+ sendNotification SWindowLogMessage $
+ LogMessageParams MtLog "got workspace/didChangeWatchedFiles"
+ runInIO $ asks relRegToken >>= \v -> putMVar v token
+ when (".register.abs" `isSuffixOf` fp) $
+ do
curDir <- getCurrentDirectory
- reqId <- readMVar lfvar >>= getNextReqId
- send $ ReqRegisterCapability $ fmServerRegisterCapabilityRequest reqId $
- RegistrationParams $ List $
- [ Registration "1" WorkspaceDidChangeWatchedFiles $ Just $ toJSON $
- DidChangeWatchedFilesRegistrationOptions $ List
- [ FileSystemWatcher (curDir </> "*.watch") (Just (WatchKind True True True)) ]
+ let regOpts =
+ DidChangeWatchedFilesRegistrationOptions $
+ List
+ [ FileSystemWatcher
+ (curDir </> "*.watch")
+ (Just (WatchKind True True True))
]
-
+ Just token <- runInIO $
+ registerCapability SWorkspaceDidChangeWatchedFiles regOpts $
+ \_noti ->
+ sendNotification SWindowLogMessage $
+ LogMessageParams MtLog "got workspace/didChangeWatchedFiles"
+ runInIO $ asks absRegToken >>= \v -> putMVar v token
-- also act as an unregisterer for workspace/didChangeWatchedFiles
- when (".unregister" `isSuffixOf` fp) $ do
- reqId <- readMVar lfvar >>= getNextReqId
- send $ ReqUnregisterCapability $ fmServerUnregisterCapabilityRequest reqId $
- UnregistrationParams $ List [ Unregistration "0" "workspace/didChangeWatchedFiles" ]
- when (".unregister.abs" `isSuffixOf` fp) $ do
- reqId <- readMVar lfvar >>= getNextReqId
- send $ ReqUnregisterCapability $ fmServerUnregisterCapabilityRequest reqId $
- UnregistrationParams $ List [ Unregistration "1" "workspace/didChangeWatchedFiles" ]
- , executeCommandHandler = pure $ \req -> do
- send $ RspExecuteCommand $ makeResponseMessage req Null
- reqId <- readMVar lfvar >>= getNextReqId
- let RequestMessage _ _ _ (ExecuteCommandParams "doAnEdit" (Just (List [val])) _) = req
+ when (".unregister" `isSuffixOf` fp) $
+ do
+ Just token <- runInIO $ asks relRegToken >>= tryReadMVar
+ runInIO $ unregisterCapability token
+ when (".unregister.abs" `isSuffixOf` fp) $
+ do
+ Just token <- runInIO $ asks absRegToken >>= tryReadMVar
+ runInIO $ unregisterCapability token,
+ requestHandler SWorkspaceExecuteCommand $ \req resp -> do
+ let RequestMessage _ _ _ (ExecuteCommandParams Nothing "doAnEdit" (Just (List [val]))) = req
Success docUri = fromJSON val
edit = List [TextEdit (mkRange 0 0 0 5) "howdy"]
- send $ ReqApplyWorkspaceEdit $ fmServerApplyWorkspaceEditRequest reqId $
- ApplyWorkspaceEditParams $ WorkspaceEdit (Just (HM.singleton docUri edit))
- Nothing
- , codeActionHandler = pure $ \req -> do
+ params =
+ ApplyWorkspaceEditParams (Just "Howdy edit") $
+ WorkspaceEdit (Just (HM.singleton docUri edit)) Nothing
+ resp $ Right Null
+ void $ sendRequest SWorkspaceApplyEdit params (const (pure ())),
+ requestHandler STextDocumentCodeAction $ \req resp -> do
let RequestMessage _ _ _ params = req
- CodeActionParams _ _ cactx _ = params
+ CodeActionParams _ _ _ _ cactx = params
CodeActionContext diags _ = cactx
- caresults = fmap diag2caresult diags
- diag2caresult d = CACodeAction $
- CodeAction "Delete this"
+ codeActions = fmap diag2ca diags
+ diag2ca d =
+ CodeAction
+ "Delete this"
Nothing
(Just (List [d]))
Nothing
+ Nothing
(Just (Command "" "deleteThis" Nothing))
- send $ RspCodeAction $ makeResponseMessage req caresults
- , didChangeWatchedFilesNotificationHandler = pure $ \_ ->
- send $ NotLogMessage $ fmServerLogMessageNotification MtLog "got workspace/didChangeWatchedFiles"
- , completionHandler = pure $ \req -> do
- let res = CompletionList (CompletionListType False (List [item]))
+ resp $ Right $ InR <$> codeActions,
+ requestHandler STextDocumentCompletion $ \_req resp -> do
+ let res = CompletionList True (List [item])
item =
- CompletionItem "foo" (Just CiConstant) (Just (List [])) Nothing
- Nothing Nothing Nothing Nothing Nothing Nothing Nothing
- Nothing Nothing Nothing Nothing Nothing
- send $ RspCompletion $ makeResponseMessage req res
- }
- where send msg = readMVar lfvar >>= \lf -> (sendFunc lf) msg
-
-mkRange sl sc el ec = Range (Position sl sc) (Position el ec)
+ CompletionItem
+ "foo"
+ (Just CiConstant)
+ (Just (List []))
+ Nothing
+ Nothing
+ Nothing
+ Nothing
+ Nothing
+ Nothing
+ Nothing
+ Nothing
+ Nothing
+ Nothing
+ Nothing
+ Nothing
+ Nothing
+ resp $ Right $ InR res
+ ]
projects / lsp-test.git / blobdiff