descript-lang-0.2.0.0: app/Server/Run.hs
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
module Server.Run
( runServe
) where
import Control.Applicative
import Control.Concurrent
import Control.Concurrent.STM.TChan
import Control.Lens
import Control.Monad
import qualified Control.Monad.Catch as E
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.STM
import qualified Data.Aeson as J
import Data.Default
import Data.Monoid
import qualified Data.Text as T
import Descript.Build
import qualified Descript.BasicInj as BasicInj
import Descript.Misc
import qualified Language.Haskell.LSP.Control as CTRL
import qualified Language.Haskell.LSP.Core as Core
import Language.Haskell.LSP.Diagnostics
import Language.Haskell.LSP.Messages
import qualified Language.Haskell.LSP.Types as J
import qualified Language.Haskell.LSP.Utility as U
import Server.Decode
import Server.Encode
import System.Exit
import qualified System.Log.Logger as L
runServe :: IO ()
runServe = do
-- putStrLn "Starting server..."
serve handleServerStart >>= \case
0 -> do
putStrLn "Server stopped"
exitSuccess
c -> do
putStrLn $ "Server stopped with error or interrupt"
exitWith . ExitFailure $ c
handleServerStart :: IO ()
handleServerStart = do
-- putStrLn "Server started. Ctrl-C to stop"
pure ()
-- Derived from Haskell LSP example
-- (https://github.com/alanz/haskell-lsp/blob/master/example/Main.hs)
-- and Haskell IDE Engine implementation
-- (https://github.com/alanz/haskell-ide-engine/blob/master/src/Haskell/Ide/Engine/Transport/LspStdio.hs)
-- ---------------------------------------------------------------------
serve :: IO () -> IO Int
serve dispatcherProc = E.handle finishErr $ do
rin <- atomically newTChan :: IO (TChan ReactorInput)
let dp lf = do
liftIO $ U.logs $ "main.run:dp entered"
dispatcherProc
liftIO $ U.logs $ "main.run:dp after dispatcher"
_ <- forkIO $ reactor lf rin
pure Nothing
Core.setupLogger (Just "/tmp/descript-server.log") [] L.DEBUG
res <- CTRL.run (getConfig, dp) (lspHandlers rin) lspOptions
U.logs $ "****** FINISHED WITH CODE: " ++ show res
finish
pure res
where finishErr (e :: E.SomeException) = do
U.logs $ "****** FINISHED WITH ERROR: " ++ show e
finish
pure 1
finish = L.removeAllHandlers
-- ---------------------------------------------------------------------
-- | Callback from haskell-lsp core to convert the generic message to the
-- specific one for hie
getConfig :: J.DidChangeConfigurationNotification -> Either T.Text Config
getConfig (J.NotificationMessage _ _ (J.DidChangeConfigurationParams p)) =
case J.fromJSON p of
J.Success c -> Right c
J.Error err -> Left $ T.pack err
newtype Config =
Config
{ maxNumberOfProblems :: Int
} deriving (Show)
instance J.FromJSON Config where
parseJSON = J.withObject "Config" $ \v -> do
s <- v J..: "descript"
flip (J.withObject "Config.settings") s $ \o -> Config
<$> o J..: "maxNumberOfProblems"
-- ---------------------------------------------------------------------
-- 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.
data ReactorInput
= HandlerRequest Core.OutMessage
-- ^ injected into the reactor input by each of the individual callback handlers
-- ---------------------------------------------------------------------
-- | The monad used in the reactor
type R a = ReaderT (Core.LspFuncs Config) IO a
-- ---------------------------------------------------------------------
-- reactor monad functions
-- ---------------------------------------------------------------------
-- Unlike makeResponseMessage, allows for a response for an arbitrary
-- request (without request type).
makeResponseMessage' :: J.LspIdRsp -> resp -> J.ResponseMessage resp
makeResponseMessage' rid result
= J.ResponseMessage "2.0" rid (Just result) Nothing
-- ---------------------------------------------------------------------
reactorSend :: (J.ToJSON a) => a -> R ()
reactorSend msg = do
lf <- ask
liftIO $ Core.sendFunc lf msg
-- ---------------------------------------------------------------------
publishDiagnostics :: J.Uri -> Maybe J.TextDocumentVersion -> DiagnosticsBySource -> R ()
publishDiagnostics uri mv diags = do
lf <- ask
config <- liftIO $ Core.config lf
let maxNumProbs
= case maxNumberOfProblems <$> config of
Nothing -> maxBound
Just (-1) -> maxBound
Just x -> x
liftIO $ (Core.publishDiagnosticsFunc lf) maxNumProbs uri mv diags
-- ---------------------------------------------------------------------
nextLspReqId :: R J.LspId
nextLspReqId = do
f <- asks Core.getNextReqId
liftIO $ f
-- ---------------------------------------------------------------------
-- | 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 :: Core.LspFuncs Config -> TChan ReactorInput -> IO ()
reactor lf inp = flip runReaderT lf $ do
liftIO $ U.logs $ "reactor:entered"
cache <- newGlobalCache
let handlers = [ E.Handler onSomeExcept
]
onSomeExcept (e :: E.SomeException) = do
liftIO $ U.logm $ "****** EXCEPTION ******"
liftIO $ U.logs $ show e
forever $ (`E.catches` handlers) $ do
HandlerRequest inval <- liftIO $ atomically $ readTChan inp
case inval of
-- Handle any response from a message originating at the server, such as
-- "workspace/applyEdit"
Core.RspFromClient rm -> do
liftIO $ U.logs $ "reactor:got RspFromClient:" ++ show rm
-- -------------------------------
Core.NotInitialized _notification -> do
liftIO $ U.logm $ "****** reactor: processing Initialized Notification"
-- Server is ready, register any specific capabilities we need
{-
Example:
{
"method": "client/registerCapability",
"params": {
"registrations": [
{
"id": "79eee87c-c409-4664-8102-e03263673f6f",
"method": "textDocument/willSaveWaitUntil",
"registerOptions": {
"documentSelector": [
{ "language": "javascript" }
]
}
}
]
}
}
-}
let registration = J.Registration "descript-server-registered" J.WorkspaceExecuteCommand Nothing
registrations = J.RegistrationParams $ J.List [registration]
rid <- nextLspReqId
reactorSend $ fmServerRegisterCapabilityRequest rid registrations
-- -------------------------------
Core.NotDidOpenTextDocument notification -> do
liftIO $ U.logm $ "****** reactor: processing NotDidOpenTextDocument"
let doc = notification ^. J.params . J.textDocument
uri = decodeUri $ doc ^. J.uri
version = doc ^. J.version
text = doc ^. J.text
liftIO $ U.logs $ "********* uri = " ++ show uri
addFile (inDelegate uri) uri version text cache
-- -------------------------------
Core.NotDidCloseTextDocument notification -> do
liftIO $ U.logm $ "****** reactor: processing NotDidCloseTextDocument"
let uri = decodeUri $ notification ^. J.params . J.textDocument . J.uri
liftIO $ U.logs $ "********* uri = " ++ show uri
delFile uri cache
-- -------------------------------
Core.NotDidChangeTextDocument notification -> do
liftIO $ U.logm $ "****** reactor: processing NotDidChangeTextDocument"
let params = notification ^. J.params
doc = params ^. J.textDocument
uri = decodeUri $ doc ^. J.uri
version = doc ^. J.version
change = decodeChange $ params ^. J.contentChanges
liftIO $ U.logs $ "********* uri = " ++ show uri
changeFile (inDelegate uri) uri version change cache
-- -------------------------------
Core.NotDidSaveTextDocument notification -> do
liftIO $ U.logm "****** reactor: processing NotDidSaveTextDocument"
let uri = decodeUri $ notification ^. J.params . J.textDocument . J.uri
liftIO $ U.logs $ "********* uri = " ++ show uri
-- -------------------------------
Core.ReqRename req -> do
liftIO $ U.logs $ "reactor:got RenameRequest:" ++ show req
let rid = J.responseId $ req ^. J.id
params = req ^. J.params
doc = params ^. J.textDocument
uri = decodeUri $ doc ^. J.uri
loc = decodeLoc $ params ^. J.position
newName = T.unpack $ params ^. J.newName
refactorFile (outDelegate rid uri) uri (BasicInj.renameSymbolAt loc newName) cache
-- -------------------------------
Core.ReqHover req -> do
liftIO $ U.logs $ "reactor:got HoverRequest:" ++ show req
{- let J.TextDocumentPositionParams _doc pos = req ^. J.params
let ht = J.Hover ms (Just range)
ms = J.List [J.CodeString $ J.LanguageString "descript" "TYPE INFO" ]
range = J.Range pos pos
reactorSend $ Core.makeResponseMessage req ht -}
-- -------------------------------
Core.ReqCodeAction req -> do
liftIO $ U.logs $ "reactor:got CodeActionRequest:" ++ show req
{- let params = req ^. J.params
doc = params ^. J.textDocument
-- fileName = drop (length ("file://"::String)) doc
-- J.Range from to = J._range (params :: J.CodeActionParams)
(J.List diags) = params ^. J.context . J.diagnostics
let
-- makeCommand only generates commands for diagnostics whose source is us
makeCommand (J.Diagnostic (J.Range start _) _s _c (Just "descript") _m _l) = [J.Command title cmd cmdparams]
where
title = "Apply Descript command:" <> head (T.lines _m)
-- NOTE: the cmd needs to be registered via the InitializeResponse message. See lspOptions above
cmd = "rename"
-- need 'file' and 'start_pos'
args = J.Array$ V.fromList
[ J.Object $ H.fromList [("file", J.Object $ H.fromList [("textDocument",J.toJSON doc)])]
, J.Object $ H.fromList [("start_pos",J.Object $ H.fromList [("position", J.toJSON start)])]
]
cmdparams = Just args
makeCommand (J.Diagnostic _r _s _c _source _m _l) = []
let body = J.List $ concatMap makeCommand diags
reactorSend $ Core.makeResponseMessage req body -}
-- -------------------------------
Core.ReqExecuteCommand req -> do
liftIO $ U.logs $ "reactor:got ExecuteCommandRequest:" ++ show req
{- let params = req ^. J.params
margs = params ^. J.arguments
liftIO $ U.logs $ "reactor:ExecuteCommandRequest:margs=" ++ show margs
let
reply v = reactorSend $ Core.makeResponseMessage req v
-- When we get a RefactorResult or HieDiff, we need to send a
-- separate WorkspaceEdit Notification
r = J.List [] :: J.List Int
liftIO $ U.logs $ "ExecuteCommand response got:r=" ++ show r
case toWorkspaceEdit r of
Just we -> do
reply (J.Object mempty)
lid <- nextLspReqId
-- reactorSend $ J.RequestMessage "2.0" lid "workspace/applyEdit" (Just we)
reactorSend $ fmServerApplyWorkspaceEditRequest lid we
Nothing ->
reply (J.Object mempty) -}
-- -------------------------------
Core.ReqCompletion req -> do
liftIO $ U.logs $ "reactor:got CompletionRequest:" ++ show req
{- let params = req ^. J.params
filePath = J.uriToFilePath $ params ^. J.textDocument ^. J.uri
pos = params ^. J.position
mprefix <- getPrefixAtPos doc pos
callback <- hieResponseHelper (req ^. J.id) $ \compls -> do
let rspMsg = Core.makeResponseMessage req
$ J.Completions $ J.List compls
reactorSend rspMsg
case mprefix of
Nothing -> liftIO $ callback $ IdeResponseOk []
Just prefix -> do
let hreq = IReq (req ^. J.id) callback
$ Hie.getCompletions doc prefix
makeRequest hreq -}
Core.ReqCompletionItemResolve req -> do
liftIO $ U.logs $ "reactor:got CompletionItemResolveRequest:" ++ show req
{- let origCompl = req ^. J.params
mquery = case J.fromJSON <$> origCompl ^. J.xdata of
Just (J.Success q) -> Just q
_ -> Nothing
callback <- hieResponseHelper (req ^. J.id) $ \docs -> do
let rspMsg = Core.makeResponseMessage req $
origCompl & J.documentation .~ docs
reactorSend rspMsg
let hreq = GReq Nothing Nothing (Just $ req ^. J.id) callback $ runExceptT $ do
case mquery of
Nothing -> return Nothing
Just query -> do
res <- lift $ liftToGhc $ Hoogle.infoCmd' query
case res of
Right x -> return $ Just x
_ -> return Nothing
makeRequest hreq -}
-- -------------------------------
Core.ReqDocumentHighlights req -> do
liftIO $ U.logs $ "reactor:got DocumentHighlightsRequest:" ++ show req
{- let rid = J.responseId $ req ^. J.id
params = req ^. J.params
doc = params ^. J.textDocument
uri = decodeUri $ doc ^. J.uri
loc = decodeLoc $ params ^. J.position
refsRes <- inspectFile uri (BasicInj.refsToSymbolAt loc) cache
case refsRes of
Failure err -> do
let msg = Text.pack $ summary err
rerr = J.ResponseError J.InvalidRequest msg Nothing
Core.makeResponseError req rerr
Just refs -> do
let erefs = encodeReferences refs
rsp = Core.makeResponseMessage req erefs
reactorSend rsp -}
{- let params = req ^. J.params
doc = params ^. J.textDocument ^. J.uri
pos = params ^. J.position
callback <- hieResponseHelper (req ^. J.id) $ \highlights -> do
let rspMsg = Core.makeResponseMessage req $ J.List highlights
reactorSend rspMsg
let hreq = IReq (req ^. J.id) callback
$ Hie.getReferencesInDoc doc pos
makeRequest hreq -}
-- -------------------------------
Core.ReqDefinition req -> do
liftIO $ U.logs $ "reactor:got DefinitionRequest:" ++ show req
{- let params = req ^. J.params
doc = params ^. J.textDocument . J.uri
pos = params ^. J.position
callback <- hieResponseHelper (req ^. J.id) $ \loc -> do
let rspMsg = Core.makeResponseMessage req loc
reactorSend rspMsg
let hreq = GReq (Just doc) Nothing (Just $ req ^. J.id) callback
$ fmap J.MultiLoc <$> Hie.findDef doc pos
makeRequest hreq -}
Core.ReqFindReferences req -> do
liftIO $ U.logs $ "reactor:got FindReferences:" ++ show req
{- let params = req ^. J.params
doc = params ^. J.textDocument ^. J.uri
pos = params ^. J.position
callback <- hieResponseHelper (req ^. J.id) $ \highlights -> do
let rspMsg = Core.makeResponseMessage req $ J.List highlights
reactorSend rspMsg
let hreq = IReq (req ^. J.id) callback
$ fmap (map (J.Location doc . (^. J.range)))
<$> Hie.getReferencesInDoc doc pos
makeRequest hreq -}
-- -------------------------------
Core.ReqDocumentFormatting req -> do
liftIO $ U.logs $ "reactor:got FormatRequest:" ++ show req
{- let params = req ^. J.params
doc = params ^. J.textDocument . J.uri
tabSize = params ^. J.options . J.tabSize
callback <- hieResponseHelper (req ^. J.id) $ \textEdit -> do
let rspMsg = Core.makeResponseMessage req $ J.List textEdit
reactorSend rspMsg
let hreq = GReq (Just doc) Nothing (Just $ req ^. J.id) callback
$ Brittany.brittanyCmd tabSize doc Nothing
makeRequest hreq -}
-- -------------------------------
Core.ReqDocumentRangeFormatting req -> do
liftIO $ U.logs $ "reactor:got FormatRequest:" ++ show req
{- let params = req ^. J.params
doc = params ^. J.textDocument . J.uri
range = params ^. J.range
tabSize = params ^. J.options . J.tabSize
callback <- hieResponseHelper (req ^. J.id) $ \textEdit -> do
let rspMsg = Core.makeResponseMessage req $ J.List textEdit
reactorSend rspMsg
let hreq = GReq (Just doc) Nothing (Just $ req ^. J.id) callback
$ Brittany.brittanyCmd tabSize doc (Just range)
makeRequest hreq -}
-- -------------------------------
Core.ReqDocumentSymbols req -> do
liftIO $ U.logs $ "reactor:got Document symbol request:" ++ show req
{- let uri = req ^. J.params . J.textDocument . J.uri
callback <- hieResponseHelper (req ^. J.id) $ \docSymbols -> do
let rspMsg = Core.makeResponseMessage req $ J.List docSymbols
reactorSend rspMsg
let hreq = IReq (req ^. J.id) callback
$ Hie.getSymbols uri
makeRequest hreq -}
-- -------------------------------
Core.NotCancelRequest notif -> do
liftIO $ U.logs $ "reactor:got CancelRequest:" ++ show notif
{- let lid = notif ^. J.params . J.id
liftIO $ atomically $ do
wip <- readTVar wipTVar
when (S.member lid wip) $ do
modifyTVar' cancelReqTVar (S.insert lid) -}
-- -------------------------------
Core.NotDidChangeConfigurationParams notif -> do
liftIO $ U.logs $ "reactor:didChangeConfiguration notification:" ++ show notif
{- -- if hlint has been turned off, flush the disgnostics
diagsOn <- configVal True hlintOn
maxDiagnosticsToSend <- configVal 50 maxNumberOfProblems
liftIO $ U.logs $ "reactor:didChangeConfiguration diagsOn:" ++ show diagsOn
-- If hlint is off, remove the diags. But make sure they get sent, in
-- case maxDiagnosticsToSend has changed.
if diagsOn
then flushDiagnosticsBySource maxDiagnosticsToSend Nothing
else flushDiagnosticsBySource maxDiagnosticsToSend (Just "hlint") -}
-- -------------------------------
om -> do
liftIO $ U.logs $ "reactor:got HandlerRequest:" ++ show om
-- ---------------------------------------------------------------------
inDelegate :: FilePath
-> CacheDelegate (ReaderT (Core.LspFuncs Config) IO)
inDelegate uri
= CacheDelegate
{ onUpdateFile = onInUpdateFile uri
, onWarning = onInWarning
, onError = onInError uri
}
outDelegate :: J.LspIdRsp
-> FilePath
-> CacheDelegate (ReaderT (Core.LspFuncs Config) IO)
outDelegate rid uri
= CacheDelegate
{ onUpdateFile = onOutUpdateFile rid uri
, onWarning = onOutWarning
, onError = onOutError rid uri
}
onInUpdateFile :: FilePath
-> FileUpdate
-> FileCache
-> R ()
onInUpdateFile uri (UpdateBasicInj _) x = do
liftIO $ U.logs $ "********* updating basic"
let uri' = encodeUri uri
version = fileVersion x
let diags = BasicInj.diagnose $ forceGetPhaseCache $ srcBasicInj x
ediags = partitionBySource $ map encodeDiagnostic diags
publishDiagnostics uri' (Just version) ediags
onInUpdateFile _ _ _ = pure ()
onOutUpdateFile :: J.LspIdRsp
-> FilePath
-> FileUpdate
-> FileCache
-> R ()
onOutUpdateFile rid uri (UpdateText new patchOpt) x = do
liftIO $ U.logs "********* updating text"
let old = phaseCached $ srcText x
patchOpt' = patchOpt <|> fmap (`replacePatch` new) old
case patchOpt' of
Nothing -> onOutError rid uri CachePatchBeforeText
Just patch -> do
let uri' = encodeUri uri
doc = J.VersionedTextDocumentIdentifier uri' $ fileVersion x
de = J.TextDocumentEdit doc $ encodePatch patch
we = J.WorkspaceEdit Nothing $ Just $ J.List [de]
rspMsg = makeResponseMessage' rid we
reactorSend rspMsg
onOutUpdateFile _ _ _ _ = pure ()
onInWarning :: CacheWarning
-> R ()
-> R ()
onInWarning _ continue = continue
onOutWarning :: CacheWarning
-> R ()
-> R ()
onOutWarning (CacheRefactorWarning _ _) continue = continue
{- do
let params = J.ShowMessageRequestParams J.MtWarning ...
(Just [J.MessageActionItem "Continue", J.MessageActionItem "Cancel"])
rid <- nextLspReqId
reactorSend $ fmServerShowMessageRequest rid params -}
onInError :: FilePath
-> CacheError
-> R ()
onInError uri (CacheParseError x err) = do
liftIO $ U.logs "********* got error: CacheParseError"
let uri' = encodeUri uri
version = fileVersion x
eerr = encodeParseError err
diags = partitionBySource eerr
publishDiagnostics uri' (Just version) diags
onInError _ err = do
liftIO $ U.logs $ "******** got unexpected in error: " ++ show err
onOutError :: J.LspIdRsp
-> FilePath
-> CacheError
-> R ()
onOutError rid _ CacheFileNotFound = do
liftIO $ U.logs "********* got error: CacheFileNotFound"
let err = J.ResponseError J.InternalError fileNotFoundErrMsg Nothing
rspMsg = Core.makeResponseError rid err
reactorSend rspMsg
onOutError rid _ CachePatchBeforeText = do
liftIO $ U.logs "********* got error: CachePathBeforeText"
let err = J.ResponseError J.InternalError patchBeforeTextErrMsg Nothing
rspMsg = Core.makeResponseError rid err
reactorSend rspMsg
onOutError rid _ CacheRefactorBeforeParse = do
liftIO $ U.logs "********* got error: CacheRefactorBeforeParse"
let err = J.ResponseError J.InternalError refactorBeforeParseErrMsg Nothing
rspMsg = Core.makeResponseError rid err
reactorSend rspMsg
onOutError rid uri (CacheRefactorError x err) = do
let file = mkSFile uri $ forceGetPhaseCache $ srcText x
msg = "Refactor error: " <> T.pack (summaryF file err)
rerr = J.ResponseError J.InvalidRequest msg Nothing
rspMsg = Core.makeResponseError rid rerr
reactorSend rspMsg
onOutError _ _ err = do
liftIO $ U.logs $ "********* got unexpected out error: " ++ show err
fileNotFoundErrMsg :: T.Text
fileNotFoundErrMsg = "No file cached at this path. Reopen the file to fix."
patchBeforeTextErrMsg :: T.Text
patchBeforeTextErrMsg = "No text cached at this path. Reopen the file to fix."
refactorBeforeParseErrMsg :: T.Text
refactorBeforeParseErrMsg = "Can't refactor because the source isn't parsed."
-- ---------------------------------------------------------------------
-- toWorkspaceEdit :: t -> Maybe J.ApplyWorkspaceEditParams
-- toWorkspaceEdit _ = Nothing
-- ---------------------------------------------------------------------
{- -- | Analyze the file and send any diagnostics to the client in a
-- "textDocument/publishDiagnostics" notification
sendDiagnostics :: J.Uri -> Maybe Int -> R ()
sendDiagnostics fileUri mversion = do
let
diags = [J.Diagnostic
(J.Range (J.Position 0 1) (J.Position 0 5))
(Just J.DsWarning) -- severity
Nothing -- code
(Just "descript-server") -- source
"Example diagnostic message"
(Just (J.List []))
]
-- reactorSend $ J.NotificationMessage "2.0" "textDocument/publishDiagnostics" (Just r)
publishDiagnostics 100 fileUri mversion (partitionBySource diags) -}
-- ---------------------------------------------------------------------
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.SaveOptions $ Just False
}
lspOptions :: Core.Options
lspOptions = def { Core.textDocumentSync = Just syncOptions
, Core.completionProvider = Just (J.CompletionOptions (Just True) (Just ["<", ">"]))
, Core.executeCommandProvider = Just (J.ExecuteCommandOptions (J.List ["rename"]))
}
lspHandlers :: TChan ReactorInput -> Core.Handlers
lspHandlers rin
= def { Core.initializedHandler = Just $ passHandler rin Core.NotInitialized
, Core.renameHandler = Just $ passHandler rin Core.ReqRename
, Core.hoverHandler = Just $ passHandler rin Core.ReqHover
, Core.didOpenTextDocumentNotificationHandler = Just $ passHandler rin Core.NotDidOpenTextDocument
, Core.didSaveTextDocumentNotificationHandler = Just $ passHandler rin Core.NotDidSaveTextDocument
, Core.didChangeTextDocumentNotificationHandler = Just $ passHandler rin Core.NotDidChangeTextDocument
, Core.didCloseTextDocumentNotificationHandler = Just $ passHandler rin Core.NotDidCloseTextDocument
, Core.cancelNotificationHandler = Just $ passHandler rin Core.NotCancelRequest
, Core.responseHandler = Just $ responseHandlerCb rin
, Core.codeActionHandler = Just $ passHandler rin Core.ReqCodeAction
, Core.executeCommandHandler = Just $ passHandler rin Core.ReqExecuteCommand
, Core.completionHandler = Just $ passHandler rin Core.ReqCompletion
, Core.completionResolveHandler = Just $ passHandler rin Core.ReqCompletionItemResolve
, Core.documentHighlightHandler = Just $ passHandler rin Core.ReqDocumentHighlights
, Core.documentFormattingHandler = Just $ passHandler rin Core.ReqDocumentFormatting
, Core.documentRangeFormattingHandler = Just $ passHandler rin Core.ReqDocumentRangeFormatting
, Core.documentSymbolHandler = Just $ passHandler rin Core.ReqDocumentSymbols
}
-- ---------------------------------------------------------------------
passHandler :: TChan ReactorInput -> (a -> Core.OutMessage) -> Core.Handler a
passHandler rin c notification = do
atomically $ writeTChan rin (HandlerRequest (c notification))
-- ---------------------------------------------------------------------
responseHandlerCb :: TChan ReactorInput -> Core.Handler J.BareResponseMessage
responseHandlerCb _rin resp = do
U.logs $ "******** got ResponseMessage, ignoring:" ++ show resp
-- ---------------------------------------------------------------------