lsp-1.5.0.0: example/Reactor.hs
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE DuplicateRecordFields #-}
-- So we can keep using the old prettyprinter modules (which have a better
-- compatibility range) for now.
{-# OPTIONS_GHC -Wno-deprecations #-}
{- |
This is an example language server built with haskell-lsp using a 'Reactor'
design. With a 'Reactor' all requests are handled on a /single thread/.
A thread is spun up for it, which repeatedly reads from a 'TChan' of
'ReactorInput's.
The `lsp` handlers then simply pass on all the requests and
notifications onto the channel via 'ReactorInput's.
This way there is the option of executing requests on multiple threads, without
blocking server communication.
To try out this server, install it with
> cabal install lsp-demo-reactor-server -fdemo
and plug it into your client of choice.
-}
module Main (main) where
import Colog.Core (LogAction (..), WithSeverity (..), Severity (..), (<&))
import qualified Colog.Core as L
import Control.Concurrent.STM.TChan
import qualified Control.Exception as E
import Control.Lens hiding (Iso)
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.STM
import qualified Data.Aeson as J
import Data.Int (Int32)
import qualified Data.Text as T
import Data.Text.Prettyprint.Doc
import GHC.Generics (Generic)
import Language.LSP.Server
import System.IO
import Language.LSP.Diagnostics
import Language.LSP.Logging (defaultClientLogger)
import qualified Language.LSP.Types as J
import qualified Language.LSP.Types.Lens as J
import Language.LSP.VFS
import System.Exit
import Control.Concurrent
-- ---------------------------------------------------------------------
{-# ANN module ("HLint: ignore Eta reduce" :: String) #-}
{-# ANN module ("HLint: ignore Redundant do" :: String) #-}
{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
-- ---------------------------------------------------------------------
--
main :: IO ()
main = do
run >>= \case
0 -> exitSuccess
c -> exitWith . ExitFailure $ c
-- ---------------------------------------------------------------------
data Config = Config { fooTheBar :: Bool, wibbleFactor :: Int }
deriving (Generic, J.ToJSON, J.FromJSON, Show)
run :: IO Int
run = flip E.catches handlers $ do
rin <- atomically newTChan :: IO (TChan ReactorInput)
let
-- Three loggers:
-- 1. To stderr
-- 2. To the client (filtered by severity)
-- 3. To both
stderrLogger :: LogAction IO (WithSeverity T.Text)
stderrLogger = L.cmap show L.logStringStderr
clientLogger :: LogAction (LspM Config) (WithSeverity T.Text)
clientLogger = defaultClientLogger
dualLogger :: LogAction (LspM Config) (WithSeverity T.Text)
dualLogger = clientLogger <> L.hoistLogAction liftIO stderrLogger
serverDefinition = ServerDefinition
{ defaultConfig = Config {fooTheBar = False, wibbleFactor = 0 }
, onConfigurationChange = \_old v -> do
case J.fromJSON v of
J.Error e -> Left (T.pack e)
J.Success cfg -> Right cfg
, doInitialize = \env _ -> forkIO (reactor stderrLogger rin) >> pure (Right env)
-- Handlers log to both the client and stderr
, staticHandlers = lspHandlers dualLogger rin
, interpretHandler = \env -> Iso (runLspT env) liftIO
, options = lspOptions
}
let
logToText = T.pack . show . pretty
runServerWithHandles
-- Log to both the client and stderr when we can, stderr beforehand
(L.cmap (fmap logToText) stderrLogger)
(L.cmap (fmap logToText) dualLogger)
stdin
stdout
serverDefinition
where
handlers = [ E.Handler ioExcept
, E.Handler someExcept
]
ioExcept (e :: E.IOException) = print e >> return 1
someExcept (e :: E.SomeException) = print e >> return 1
-- ---------------------------------------------------------------------
syncOptions :: J.TextDocumentSyncOptions
syncOptions = J.TextDocumentSyncOptions
{ J._openClose = Just True
, J._change = Just J.TdSyncIncremental
, J._willSave = Just False
, J._willSaveWaitUntil = Just False
, J._save = Just $ J.InR $ J.SaveOptions $ Just False
}
lspOptions :: Options
lspOptions = defaultOptions
{ textDocumentSync = Just syncOptions
, executeCommandCommands = Just ["lsp-hello-command"]
}
-- ---------------------------------------------------------------------
-- The reactor is a process that serialises and buffers all requests from the
-- LSP client, so they can be sent to the backend compiler one at a time, and a
-- reply sent.
newtype ReactorInput
= ReactorAction (IO ())
-- | Analyze the file and send any diagnostics to the client in a
-- "textDocument/publishDiagnostics" notification
sendDiagnostics :: J.NormalizedUri -> Maybe Int32 -> LspM Config ()
sendDiagnostics fileUri version = do
let
diags = [J.Diagnostic
(J.Range (J.Position 0 1) (J.Position 0 5))
(Just J.DsWarning) -- severity
Nothing -- code
(Just "lsp-hello") -- source
"Example diagnostic message"
Nothing -- tags
(Just (J.List []))
]
publishDiagnostics 100 fileUri version (partitionBySource diags)
-- ---------------------------------------------------------------------
-- | The single point that all events flow through, allowing management of state
-- to stitch replies and requests together from the two asynchronous sides: lsp
-- server and backend compiler
reactor :: L.LogAction IO (WithSeverity T.Text) -> TChan ReactorInput -> IO ()
reactor logger inp = do
logger <& "Started the reactor" `WithSeverity` Info
forever $ do
ReactorAction act <- atomically $ readTChan inp
act
-- | Check if we have a handler, and if we create a haskell-lsp handler to pass it as
-- input into the reactor
lspHandlers :: (m ~ LspM Config) => L.LogAction m (WithSeverity T.Text) -> TChan ReactorInput -> Handlers m
lspHandlers logger rin = mapHandlers goReq goNot (handle logger)
where
goReq :: forall (a :: J.Method J.FromClient J.Request). Handler (LspM Config) a -> Handler (LspM Config) a
goReq f = \msg k -> do
env <- getLspEnv
liftIO $ atomically $ writeTChan rin $ ReactorAction (runLspT env $ f msg k)
goNot :: forall (a :: J.Method J.FromClient J.Notification). Handler (LspM Config) a -> Handler (LspM Config) a
goNot f = \msg -> do
env <- getLspEnv
liftIO $ atomically $ writeTChan rin $ ReactorAction (runLspT env $ f msg)
-- | Where the actual logic resides for handling requests and notifications.
handle :: (m ~ LspM Config) => L.LogAction m (WithSeverity T.Text) -> Handlers m
handle logger = mconcat
[ notificationHandler J.SInitialized $ \_msg -> do
logger <& "Processing the Initialized notification" `WithSeverity` Info
-- We're initialized! Lets send a showMessageRequest now
let params = J.ShowMessageRequestParams
J.MtWarning
"What's your favourite language extension?"
(Just [J.MessageActionItem "Rank2Types", J.MessageActionItem "NPlusKPatterns"])
void $ sendRequest J.SWindowShowMessageRequest params $ \res ->
case res of
Left e -> logger <& ("Got an error: " <> T.pack (show e)) `WithSeverity` Error
Right _ -> do
sendNotification J.SWindowShowMessage (J.ShowMessageParams J.MtInfo "Excellent choice")
-- We can dynamically register a capability once the user accepts it
sendNotification J.SWindowShowMessage (J.ShowMessageParams J.MtInfo "Turning on code lenses dynamically")
let regOpts = J.CodeLensRegistrationOptions Nothing Nothing (Just False)
void $ registerCapability J.STextDocumentCodeLens regOpts $ \_req responder -> do
logger <& "Processing a textDocument/codeLens request" `WithSeverity` Info
let cmd = J.Command "Say hello" "lsp-hello-command" Nothing
rsp = J.List [J.CodeLens (J.mkRange 0 0 0 100) (Just cmd) Nothing]
responder (Right rsp)
, notificationHandler J.STextDocumentDidOpen $ \msg -> do
let doc = msg ^. J.params . J.textDocument . J.uri
fileName = J.uriToFilePath doc
logger <& ("Processing DidOpenTextDocument for: " <> T.pack (show fileName)) `WithSeverity` Info
sendDiagnostics (J.toNormalizedUri doc) (Just 0)
, notificationHandler J.SWorkspaceDidChangeConfiguration $ \msg -> do
cfg <- getConfig
logger L.<& ("Configuration changed: " <> T.pack (show (msg,cfg))) `WithSeverity` Info
sendNotification J.SWindowShowMessage $
J.ShowMessageParams J.MtInfo $ "Wibble factor set to " <> T.pack (show (wibbleFactor cfg))
, notificationHandler J.STextDocumentDidChange $ \msg -> do
let doc = msg ^. J.params
. J.textDocument
. J.uri
. to J.toNormalizedUri
logger <& ("Processing DidChangeTextDocument for: " <> T.pack (show doc)) `WithSeverity` Info
mdoc <- getVirtualFile doc
case mdoc of
Just (VirtualFile _version str _) -> do
logger <& ("Found the virtual file: " <> T.pack (show str)) `WithSeverity` Info
Nothing -> do
logger <& ("Didn't find anything in the VFS for: " <> T.pack (show doc)) `WithSeverity` Info
, notificationHandler J.STextDocumentDidSave $ \msg -> do
let doc = msg ^. J.params . J.textDocument . J.uri
fileName = J.uriToFilePath doc
logger <& ("Processing DidSaveTextDocument for: " <> T.pack (show fileName)) `WithSeverity` Info
sendDiagnostics (J.toNormalizedUri doc) Nothing
, requestHandler J.STextDocumentRename $ \req responder -> do
logger <& "Processing a textDocument/rename request" `WithSeverity` Info
let params = req ^. J.params
J.Position l c = params ^. J.position
newName = params ^. J.newName
vdoc <- getVersionedTextDoc (params ^. J.textDocument)
-- Replace some text at the position with what the user entered
let edit = J.InL $ J.TextEdit (J.mkRange l c l (c + fromIntegral (T.length newName))) newName
tde = J.TextDocumentEdit vdoc (J.List [edit])
-- "documentChanges" field is preferred over "changes"
rsp = J.WorkspaceEdit Nothing (Just (J.List [J.InL tde])) Nothing
responder (Right rsp)
, requestHandler J.STextDocumentHover $ \req responder -> do
logger <& "Processing a textDocument/hover request" `WithSeverity` Info
let J.HoverParams _doc pos _workDone = req ^. J.params
J.Position _l _c' = pos
rsp = J.Hover ms (Just range)
ms = J.HoverContents $ J.markedUpContent "lsp-hello" "Your type info here!"
range = J.Range pos pos
responder (Right $ Just rsp)
, requestHandler J.STextDocumentDocumentSymbol $ \req responder -> do
logger <& "Processing a textDocument/documentSymbol request" `WithSeverity` Info
let J.DocumentSymbolParams _ _ doc = req ^. J.params
loc = J.Location (doc ^. J.uri) (J.Range (J.Position 0 0) (J.Position 0 0))
sym = J.SymbolInformation "lsp-hello" J.SkFunction Nothing Nothing loc Nothing
rsp = J.InR (J.List [sym])
responder (Right rsp)
, requestHandler J.STextDocumentCodeAction $ \req responder -> do
logger <& "Processing a textDocument/codeAction request" `WithSeverity` Info
let params = req ^. J.params
doc = params ^. J.textDocument
(J.List diags) = params ^. J.context . J.diagnostics
-- makeCommand only generates commands for diagnostics whose source is us
makeCommand (J.Diagnostic (J.Range s _) _s _c (Just "lsp-hello") _m _t _l) = [J.Command title cmd cmdparams]
where
title = "Apply LSP hello command:" <> head (T.lines _m)
-- NOTE: the cmd needs to be registered via the InitializeResponse message. See lspOptions above
cmd = "lsp-hello-command"
-- need 'file' and 'start_pos'
args = J.List
[ J.object [("file", J.object [("textDocument",J.toJSON doc)])]
, J.object [("start_pos",J.object [("position", J.toJSON s)])]
]
cmdparams = Just args
makeCommand (J.Diagnostic _r _s _c _source _m _t _l) = []
rsp = J.List $ map J.InL $ concatMap makeCommand diags
responder (Right rsp)
, requestHandler J.SWorkspaceExecuteCommand $ \req responder -> do
logger <& "Processing a workspace/executeCommand request" `WithSeverity` Info
let params = req ^. J.params
margs = params ^. J.arguments
logger <& ("The arguments are: " <> T.pack (show margs)) `WithSeverity` Debug
responder (Right (J.Object mempty)) -- respond to the request
void $ withProgress "Executing some long running command" Cancellable $ \update ->
forM [(0 :: J.UInt)..10] $ \i -> do
update (ProgressAmount (Just (i * 10)) (Just "Doing stuff"))
liftIO $ threadDelay (1 * 1000000)
]
-- ---------------------------------------------------------------------