Simplify dhall-lsp-server and reorganise its modules (#992)
* Clean up dhall-lsp-server's Main.hs
Also adds haddock comments.
* Remove TODO comment
The comment talks about adding a mechanism for protocol-level logging to
dhall-lsp-server. Since the VSCode LSP implementation has this feature
already baked in on the client side, we don't have to implement it
ourselves.
* Simplify dhall-lsp-server's infrastructure
So far we had a system where we set up the LSP message handlers to relay
messages to a separate dispatcher thread via a shared channel. Since our
language server is at the same time designed in a completely synchronous
manner, this complication turns out to be unnecessary.
* Remove sample code
* Fix unused variable warning
* Reorganise dhall-lsp-server's module hierarchy
Prefixes all modules with "Dhall.LSP.".
Previously:
Backend.Dhall.
.Diagnostics
.Formatting
LSP.
.Handlers
.Handlers.
.Diagnostics
.DocumentFormatting
.Server
Now:
Dhall.LSP.
.Backend.
.Diagnostics
.Formatting
.Handlers
.Handlers.
.Diagnostics
.DocumentFormatting
.Server
* Make dhall-lsp-server tests compile again
They still fail though!
This commit is contained in:
Frederik Ramcke
GitHub
parent
fc5b382238
commit
dfee2fbbca
|
|
@ -1,70 +1,64 @@
|
|||
{-| This module contains the top-level entrypoint and options parsing for the
|
||||
@dhall-lsp-server@ executable
|
||||
-}
|
||||
|
||||
module Main (main) where
|
||||
module Main
|
||||
( main
|
||||
)
|
||||
where
|
||||
|
||||
import qualified System.Exit
|
||||
import Options.Applicative (Parser, ParserInfo)
|
||||
import qualified Options.Applicative
|
||||
import Control.Applicative ((<|>))
|
||||
|
||||
import System.Exit (exitSuccess, exitWith)
|
||||
|
||||
import LSP.Server(run)
|
||||
import qualified Dhall.LSP.Server
|
||||
|
||||
-- | Top-level program options
|
||||
data Options = Options {
|
||||
command :: Command
|
||||
, logFile :: Maybe String -- file where the server process debug log should be written
|
||||
command :: Mode
|
||||
, logFile :: Maybe FilePath
|
||||
}
|
||||
|
||||
data Command = CmdVersion | Default
|
||||
-- | The mode in which to run @dhall-lsp-server@
|
||||
data Mode = Version | LSPServer
|
||||
|
||||
parseOptions :: Parser Options
|
||||
parseOptions = Options <$> parseMode
|
||||
<*> Options.Applicative.optional parseLogFile
|
||||
where
|
||||
parseLogFile = Options.Applicative.strOption
|
||||
(
|
||||
Options.Applicative.long "log"
|
||||
<> Options.Applicative.help "If present writes debug output to the specified file")
|
||||
parseOptions =
|
||||
Options <$> parseMode <*> Options.Applicative.optional parseLogFile
|
||||
where
|
||||
parseLogFile = Options.Applicative.strOption
|
||||
(Options.Applicative.long "log" <> Options.Applicative.help
|
||||
"If present writes debug output to the specified file"
|
||||
)
|
||||
|
||||
|
||||
subcommand :: String -> String -> Parser a -> Parser a
|
||||
subcommand name description parser =
|
||||
Options.Applicative.hsubparser
|
||||
( Options.Applicative.command name parserInfo
|
||||
<> Options.Applicative.metavar name
|
||||
)
|
||||
subcommand name description parser = Options.Applicative.hsubparser
|
||||
(Options.Applicative.command name parserInfo
|
||||
<> Options.Applicative.metavar name
|
||||
)
|
||||
where
|
||||
parserInfo =
|
||||
Options.Applicative.info parser
|
||||
( Options.Applicative.fullDesc
|
||||
<> Options.Applicative.progDesc description
|
||||
)
|
||||
parserInfo = Options.Applicative.info
|
||||
parser
|
||||
(Options.Applicative.fullDesc <> Options.Applicative.progDesc description)
|
||||
|
||||
parseMode :: Parser Command
|
||||
parseMode :: Parser Mode
|
||||
parseMode =
|
||||
subcommand
|
||||
"version"
|
||||
"Display version"
|
||||
(pure CmdVersion)
|
||||
<|> pure Default
|
||||
subcommand "version" "Display version" (pure Version) <|> pure LSPServer
|
||||
|
||||
parserInfoOptions :: ParserInfo Options
|
||||
parserInfoOptions =
|
||||
Options.Applicative.info
|
||||
(Options.Applicative.helper <*> parseOptions)
|
||||
( Options.Applicative.progDesc "Interpreter for the Dhall language"
|
||||
<> Options.Applicative.fullDesc
|
||||
)
|
||||
parserInfoOptions = Options.Applicative.info
|
||||
(Options.Applicative.helper <*> parseOptions)
|
||||
(Options.Applicative.progDesc "LSP server for the Dhall language"
|
||||
<> Options.Applicative.fullDesc
|
||||
)
|
||||
|
||||
runCommand :: Options -> IO ()
|
||||
runCommand Options{..} = case command of
|
||||
CmdVersion -> putStrLn ("0.0.1.1" :: String)-- TODO: read from build
|
||||
Default ->
|
||||
run logFile (pure ()) >>= \case
|
||||
0 -> exitSuccess
|
||||
c -> exitWith . System.Exit.ExitFailure $ c
|
||||
runCommand Options {..} = case command of
|
||||
Version -> putStrLn ("0.0.1.1" :: String)
|
||||
LSPServer -> Dhall.LSP.Server.run logFile
|
||||
|
||||
-- | Entry point for the @dhall-lsp-server@ executable
|
||||
main :: IO ()
|
||||
main = Options.Applicative.execParser parserInfoOptions >>= runCommand
|
||||
|
||||
|
||||
main = do options <- Options.Applicative.execParser parserInfoOptions
|
||||
runCommand options
|
||||
|
|
|
|||
|
|
@ -20,16 +20,15 @@ source-repository head
|
|||
|
||||
library
|
||||
exposed-modules:
|
||||
Backend.Dhall.Diagnostics
|
||||
Backend.Dhall.Formatting
|
||||
LSP.Common
|
||||
LSP.Dispatcher
|
||||
LSP.Handlers.Diagnostics
|
||||
LSP.Handlers.DocumentFormatting
|
||||
LSP.Server
|
||||
Dhall.LSP.Backend.Diagnostics
|
||||
Dhall.LSP.Backend.Formatting
|
||||
Dhall.LSP.Handlers
|
||||
Dhall.LSP.Handlers.Diagnostics
|
||||
Dhall.LSP.Handlers.DocumentFormatting
|
||||
Dhall.LSP.Server
|
||||
other-modules:
|
||||
Paths_dhall_lsp_server
|
||||
Util
|
||||
Dhall.LSP.Util
|
||||
hs-source-dirs:
|
||||
src
|
||||
default-extensions: LambdaCase OverloadedStrings FlexibleInstances TypeApplications RecordWildCards ScopedTypeVariables
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module Backend.Dhall.Diagnostics
|
||||
module Dhall.LSP.Backend.Diagnostics
|
||||
( DhallException
|
||||
, runDhall
|
||||
, diagnose
|
||||
|
|
@ -19,7 +19,7 @@ import Dhall.Core (Expr(Note))
|
|||
import Dhall
|
||||
(rootDirectory, sourceName, defaultInputSettings, inputExprWithSettings)
|
||||
|
||||
import Util
|
||||
import Dhall.LSP.Util
|
||||
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
module Backend.Dhall.Formatting(formatDocument) where
|
||||
module Dhall.LSP.Backend.Formatting(formatDocument) where
|
||||
|
||||
import Dhall.Pretty (CharacterSet(..), layoutOpts)
|
||||
import Dhall.Parser(exprAndHeaderFromText, ParseError(..))
|
||||
122
dhall-lsp-server/src/Dhall/LSP/Handlers.hs
Normal file
122
dhall-lsp-server/src/Dhall/LSP/Handlers.hs
Normal file
|
|
@ -0,0 +1,122 @@
|
|||
module Dhall.LSP.Handlers where
|
||||
|
||||
import qualified Language.Haskell.LSP.Core as LSP
|
||||
import qualified Language.Haskell.LSP.Messages as LSP
|
||||
import qualified Language.Haskell.LSP.Utility as LSP
|
||||
import qualified Language.Haskell.LSP.Types as J
|
||||
import qualified Language.Haskell.LSP.Types.Lens as J
|
||||
|
||||
import qualified Dhall.LSP.Handlers.Diagnostics as Handlers
|
||||
import qualified Dhall.LSP.Handlers.DocumentFormatting as Handlers
|
||||
import Dhall.LSP.Backend.Diagnostics
|
||||
|
||||
import Control.Lens ((^.))
|
||||
import Control.Monad.Reader (runReaderT)
|
||||
import qualified Data.Text.IO
|
||||
import qualified Network.URI.Encode as URI
|
||||
import qualified Data.Text as Text
|
||||
import Data.Maybe (mapMaybe)
|
||||
|
||||
-- handler that doesn't do anything. Useful for example to make haskell-lsp shut
|
||||
-- up about unhandled DidChangeTextDocument notifications (which are already
|
||||
-- handled haskell-lsp itself).
|
||||
nullHandler :: LSP.LspFuncs () -> a -> IO ()
|
||||
nullHandler _ _ = return ()
|
||||
|
||||
initializedHandler :: LSP.LspFuncs () -> J.InitializedNotification -> IO ()
|
||||
initializedHandler _lsp _notification = do
|
||||
LSP.logs "LSP Handler: processing InitializedNotification"
|
||||
return ()
|
||||
|
||||
-- This is a quick-and-dirty prototype implementation that will be completely
|
||||
-- rewritten!
|
||||
hoverHandler :: LSP.LspFuncs () -> J.HoverRequest -> IO ()
|
||||
hoverHandler lsp request = do
|
||||
LSP.logs "LSP Handler: processing HoverRequest"
|
||||
let
|
||||
uri = request ^. J.params . J.textDocument . J.uri
|
||||
(J.Position line col) = request ^. (J.params . J.position)
|
||||
fileName = case J.uriToFilePath uri of
|
||||
Nothing -> fail "Failed to parse URI in ReqHover."
|
||||
Just path -> path
|
||||
txt <- Data.Text.IO.readFile fileName
|
||||
errors <- runDhall fileName txt
|
||||
let
|
||||
explanations = mapMaybe (explain txt) errors
|
||||
isHovered :: Diagnosis -> Bool
|
||||
isHovered (Diagnosis _ Nothing _) = False
|
||||
isHovered (Diagnosis _ (Just (Range left right)) _) =
|
||||
left <= (line, col) && (line, col) <= right
|
||||
hover = case filter isHovered explanations of
|
||||
[] -> Nothing
|
||||
(diag : _) -> hoverFromDiagnosis diag
|
||||
LSP.sendFunc lsp $ LSP.RspHover $ LSP.makeResponseMessage request hover
|
||||
|
||||
|
||||
hoverFromDiagnosis :: Diagnosis -> Maybe J.Hover
|
||||
hoverFromDiagnosis (Diagnosis _ Nothing _) = Nothing
|
||||
hoverFromDiagnosis (Diagnosis _ (Just (Range left right)) diagnosis) = Just
|
||||
J.Hover { .. }
|
||||
where
|
||||
_range =
|
||||
Just $ J.Range (uncurry J.Position left) (uncurry J.Position right)
|
||||
encodedDiag = URI.encode (Text.unpack diagnosis)
|
||||
command =
|
||||
"[Explain error](dhall-explain:?" <> Text.pack encodedDiag <> " )"
|
||||
_contents = J.List [J.PlainString command]
|
||||
|
||||
didOpenTextDocumentNotificationHandler
|
||||
:: LSP.LspFuncs () -> J.DidOpenTextDocumentNotification -> IO ()
|
||||
didOpenTextDocumentNotificationHandler lsp notification = do
|
||||
LSP.logs "LSP Handler: processing DidOpenTextDocumentNotification"
|
||||
let
|
||||
uri = notification ^. J.params . J.textDocument . J.uri
|
||||
version = notification ^. J.params . J.textDocument . J.version
|
||||
LSP.logs $ "\turi=" <> show uri <> " version: " <> show version
|
||||
flip runReaderT lsp $ Handlers.sendDiagnostics uri (Just version)
|
||||
|
||||
|
||||
didSaveTextDocumentNotificationHandler
|
||||
:: LSP.LspFuncs () -> J.DidSaveTextDocumentNotification -> IO ()
|
||||
didSaveTextDocumentNotificationHandler lsp notification = do
|
||||
LSP.logs "LSP Handler: processing DidSaveTextDocumentNotification"
|
||||
let
|
||||
uri = notification ^. J.params . J.textDocument . J.uri
|
||||
LSP.logs $ "\turi=" <> show uri
|
||||
flip runReaderT lsp $ Handlers.sendDiagnostics uri Nothing
|
||||
|
||||
{- didChangeTextDocumentNotificationHandler
|
||||
:: LSP.LspFuncs () -> J.DidChangeTextDocumentNotification -> IO ()
|
||||
-}
|
||||
|
||||
didCloseTextDocumentNotificationHandler
|
||||
:: LSP.LspFuncs () -> J.DidCloseTextDocumentNotification -> IO ()
|
||||
didCloseTextDocumentNotificationHandler lsp notification = do
|
||||
LSP.logs "LSP Handler: processing DidCloseTextDocumentNotification"
|
||||
let
|
||||
uri = notification ^. J.params . J.textDocument . J.uri
|
||||
LSP.logs $ "\turi=" <> show uri
|
||||
flip runReaderT lsp $ Handlers.sendEmptyDiagnostics uri Nothing
|
||||
|
||||
{- cancelNotificationHandler
|
||||
:: LSP.LspFuncs () -> J.CancelNotification -> IO ()
|
||||
-}
|
||||
|
||||
responseHandler :: LSP.LspFuncs () -> J.BareResponseMessage -> IO ()
|
||||
responseHandler _lsp response =
|
||||
LSP.logs $ "LSP Handler: Ignoring ResponseMessage: " ++ show response
|
||||
|
||||
executeCommandHandler :: LSP.LspFuncs () -> J.ExecuteCommandRequest -> IO ()
|
||||
executeCommandHandler _lsp request =
|
||||
LSP.logs $ "LSP Handler: Ignoring ExecuteCommandRequest: " ++ show request
|
||||
|
||||
documentFormattingHandler
|
||||
:: LSP.LspFuncs () -> J.DocumentFormattingRequest -> IO ()
|
||||
documentFormattingHandler lsp request = do
|
||||
LSP.logs "LSP Handler: processing DocumentFormattingRequest"
|
||||
let uri = request ^. J.params . J.textDocument . J.uri
|
||||
formattedDocument <- flip runReaderT lsp
|
||||
$ Handlers.formatDocument uri undefined undefined
|
||||
LSP.sendFunc lsp $ LSP.RspDocumentFormatting $ LSP.makeResponseMessage
|
||||
request
|
||||
formattedDocument
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
{-| This module contains everything related on how LSP server handles diagnostic messages. -}
|
||||
module LSP.Handlers.Diagnostics( compilerDiagnostics
|
||||
module Dhall.LSP.Handlers.Diagnostics( compilerDiagnostics
|
||||
, sendEmptyDiagnostics
|
||||
, sendDiagnostics
|
||||
) where
|
||||
|
|
@ -25,7 +25,7 @@ import Control.Monad.Trans (lift, liftIO)
|
|||
|
||||
import Data.Text (Text)
|
||||
|
||||
import Backend.Dhall.Diagnostics
|
||||
import Dhall.LSP.Backend.Diagnostics
|
||||
|
||||
|
||||
|
||||
|
|
@ -1,8 +1,8 @@
|
|||
module LSP.Handlers.DocumentFormatting(formatDocument) where
|
||||
module Dhall.LSP.Handlers.DocumentFormatting(formatDocument) where
|
||||
|
||||
|
||||
|
||||
import qualified Backend.Dhall.Formatting as Formatting
|
||||
import qualified Dhall.LSP.Backend.Formatting as Formatting
|
||||
|
||||
import qualified Language.Haskell.LSP.Core as LSP.Core
|
||||
|
||||
98
dhall-lsp-server/src/Dhall/LSP/Server.hs
Normal file
98
dhall-lsp-server/src/Dhall/LSP/Server.hs
Normal file
|
|
@ -0,0 +1,98 @@
|
|||
|
||||
{-| This is the entry point for the LSP server. All calls are delegated to the haskell-lsp library
|
||||
which does the heavy lifting.
|
||||
-}
|
||||
module Dhall.LSP.Server(run) where
|
||||
|
||||
import Control.Concurrent.STM.TVar
|
||||
import Data.Default
|
||||
import qualified Language.Haskell.LSP.Control as LSP.Control
|
||||
import qualified Language.Haskell.LSP.Core as LSP.Core
|
||||
|
||||
import qualified Language.Haskell.LSP.Types as J
|
||||
|
||||
import Data.Text (Text)
|
||||
import qualified System.Log.Logger
|
||||
import GHC.Conc (atomically)
|
||||
|
||||
import qualified Dhall.LSP.Handlers as Handlers
|
||||
|
||||
-- | The main entry point for the LSP server.
|
||||
run :: Maybe FilePath -> IO ()
|
||||
run mlog = do
|
||||
setupLogger mlog
|
||||
vlsp <- newTVarIO Nothing
|
||||
_ <- LSP.Control.run (makeConfig, initCallback vlsp) (lspHandlers vlsp)
|
||||
lspOptions Nothing
|
||||
return ()
|
||||
where
|
||||
-- Callback that is called when the LSP server is started; makes the lsp
|
||||
-- state (LspFuncs) available to the message handlers through the vlsp TVar.
|
||||
initCallback
|
||||
:: TVar (Maybe (LSP.Core.LspFuncs ()))
|
||||
-> LSP.Core.LspFuncs ()
|
||||
-> IO (Maybe J.ResponseError)
|
||||
initCallback vlsp lsp = do
|
||||
atomically $ writeTVar vlsp (Just lsp)
|
||||
return Nothing
|
||||
|
||||
-- Interpret DidChangeConfigurationNotification; pointless at the moment
|
||||
-- since we don't use a configuration.
|
||||
makeConfig :: J.DidChangeConfigurationNotification -> Either Text ()
|
||||
makeConfig _ = Right ()
|
||||
|
||||
-- | sets the output logger.
|
||||
-- | if no filename is provided then logger is disabled, if input is string `[OUTPUT]` then log goes to stderr,
|
||||
-- | which then redirects inside VSCode to the output pane of the plugin.
|
||||
setupLogger :: Maybe FilePath -> IO () -- TODO: ADD verbosity
|
||||
setupLogger Nothing = pure ()
|
||||
setupLogger (Just "[OUTPUT]") = LSP.Core.setupLogger Nothing [] System.Log.Logger.DEBUG
|
||||
setupLogger file = LSP.Core.setupLogger file [] System.Log.Logger.DEBUG
|
||||
|
||||
|
||||
-- Tells the LSP client to notify us about file changes. Handled behind the
|
||||
-- scenes by haskell-lsp (in Language.Haskell.LSP.VFS); we don't handle the
|
||||
-- corresponding notifications ourselves.
|
||||
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
|
||||
}
|
||||
|
||||
-- Server capabilities. Tells the LSP client that we can execute commands etc.
|
||||
lspOptions :: LSP.Core.Options
|
||||
lspOptions = def { LSP.Core.textDocumentSync = Just syncOptions
|
||||
, LSP.Core.executeCommandProvider = Just (J.ExecuteCommandOptions (J.List [])) -- no commands implemented
|
||||
}
|
||||
|
||||
lspHandlers :: TVar (Maybe (LSP.Core.LspFuncs ())) -> LSP.Core.Handlers
|
||||
lspHandlers lsp
|
||||
= def { LSP.Core.initializedHandler = Just $ wrapHandler lsp Handlers.initializedHandler
|
||||
, LSP.Core.hoverHandler = Just $ wrapHandler lsp Handlers.hoverHandler
|
||||
, LSP.Core.didOpenTextDocumentNotificationHandler = Just $ wrapHandler lsp Handlers.didOpenTextDocumentNotificationHandler
|
||||
, LSP.Core.didChangeTextDocumentNotificationHandler = Just $ wrapHandler lsp Handlers.nullHandler
|
||||
, LSP.Core.didSaveTextDocumentNotificationHandler = Just $ wrapHandler lsp Handlers.didSaveTextDocumentNotificationHandler
|
||||
, LSP.Core.didCloseTextDocumentNotificationHandler = Just $ wrapHandler lsp Handlers.didCloseTextDocumentNotificationHandler
|
||||
, LSP.Core.cancelNotificationHandler = Just $ wrapHandler lsp Handlers.nullHandler
|
||||
, LSP.Core.responseHandler = Just $ wrapHandler lsp Handlers.responseHandler
|
||||
, LSP.Core.executeCommandHandler = Just $ wrapHandler lsp Handlers.executeCommandHandler
|
||||
, LSP.Core.documentFormattingHandler = Just $ wrapHandler lsp Handlers.documentFormattingHandler
|
||||
}
|
||||
|
||||
-- Workaround to make our single-threaded LSP fit dhall-lsp's API, which
|
||||
-- expects a multi-threaded implementation.
|
||||
wrapHandler
|
||||
:: TVar (Maybe (LSP.Core.LspFuncs ()))
|
||||
-> (LSP.Core.LspFuncs () -> a -> IO ())
|
||||
-> a
|
||||
-> IO ()
|
||||
wrapHandler vlsp handle message = do
|
||||
mlsp <- readTVarIO vlsp
|
||||
case mlsp of
|
||||
Just lsp -> handle lsp message
|
||||
Nothing ->
|
||||
fail "A handler was called before the LSP was initialized properly.\
|
||||
\ This should never happen."
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
-- | Miscellaneous utility functions
|
||||
|
||||
module Util (
|
||||
module Dhall.LSP.Util (
|
||||
tshow,
|
||||
lines',
|
||||
unlines'
|
||||
|
|
@ -25,4 +25,4 @@ lines' text =
|
|||
-- | A variant of @Data.Text.unlines@ that is the exact inverse to @lines'@ (and
|
||||
-- vice-versa).
|
||||
unlines' :: [Text] -> Text
|
||||
unlines' = intercalate "\n"
|
||||
unlines' = intercalate "\n"
|
||||
|
|
@ -1,19 +0,0 @@
|
|||
{-| Common utilities / types for the LSP part -}
|
||||
module LSP.Common(sendToClient, nextLspReqId) where
|
||||
|
||||
import Language.Haskell.LSP.Messages
|
||||
import qualified Language.Haskell.LSP.Core as LSP.Core
|
||||
|
||||
import qualified Language.Haskell.LSP.Types as J
|
||||
import Control.Monad.Reader.Class (ask, asks)
|
||||
import Control.Monad.Reader (ReaderT)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
|
||||
|
||||
sendToClient :: FromServerMessage -> ReaderT (LSP.Core.LspFuncs ()) IO ()
|
||||
sendToClient msg = do
|
||||
lf <- ask
|
||||
liftIO $ LSP.Core.sendFunc lf msg
|
||||
|
||||
nextLspReqId :: ReaderT (LSP.Core.LspFuncs ()) IO J.LspId
|
||||
nextLspReqId = asks LSP.Core.getNextReqId >>= liftIO
|
||||
|
|
@ -1,160 +0,0 @@
|
|||
module LSP.Dispatcher(dispatcher) where
|
||||
|
||||
import Control.Concurrent.STM.TChan
|
||||
import Language.Haskell.LSP.Messages
|
||||
import qualified Language.Haskell.LSP.Core as LSP.Core
|
||||
import qualified Language.Haskell.LSP.Types as LSP.Types
|
||||
import qualified Language.Haskell.LSP.Utility as LSP.Utility
|
||||
|
||||
import qualified Language.Haskell.LSP.Types as J
|
||||
import qualified Language.Haskell.LSP.Types.Lens as J
|
||||
|
||||
import LSP.Common
|
||||
import LSP.Handlers.Diagnostics
|
||||
import LSP.Handlers.DocumentFormatting
|
||||
import Backend.Dhall.Diagnostics
|
||||
|
||||
import Control.Lens
|
||||
import Control.Monad (forever)
|
||||
import Control.Monad.Trans (liftIO)
|
||||
import Control.Monad.Reader (ReaderT, runReaderT)
|
||||
import Control.Monad.Reader.Class (ask)
|
||||
import GHC.Conc (atomically)
|
||||
import qualified Data.Text.IO
|
||||
import Data.Maybe (mapMaybe)
|
||||
import qualified Network.URI.Encode as URI
|
||||
import qualified Data.Text as Text
|
||||
|
||||
-- ! FIXME: replace logs/logm (which are just utilities) with own logging functions to make intent clearer
|
||||
-- | A basic router, which reads from Client messages queue `inp` and executes appropriate actions
|
||||
dispatcher :: LSP.Core.LspFuncs () -> TChan FromClientMessage -> IO ()
|
||||
dispatcher lf inp = do
|
||||
liftIO $ LSP.Utility.logs "inside dispatcher"
|
||||
flip runReaderT lf $ forever $ do
|
||||
inval <- liftIO $ atomically $ readTChan inp
|
||||
case inval of
|
||||
|
||||
(RspFromClient rm) ->
|
||||
liftIO $ LSP.Utility.logs $ "reactor:got RspFromClient:" ++ show rm
|
||||
|
||||
-- -------------------------------
|
||||
|
||||
(NotInitialized _notification) -> do
|
||||
liftIO $ LSP.Utility.logm "****** reactor: processing Initialized Notification"
|
||||
|
||||
let
|
||||
registration = J.Registration "dhall-lsp-server-registered" J.WorkspaceExecuteCommand Nothing
|
||||
let registrations = J.RegistrationParams (J.List [registration])
|
||||
rid <- nextLspReqId
|
||||
|
||||
-- client/registerCapability
|
||||
sendToClient $ ReqRegisterCapability $ fmServerRegisterCapabilityRequest rid registrations
|
||||
|
||||
-- example of showMessageRequest
|
||||
-- let
|
||||
-- params = J.ShowMessageRequestParams J.MtWarning "choose an option for XXX"
|
||||
-- (Just [J.MessageActionItem "option a", J.MessageActionItem "option b"])
|
||||
-- rid1 <- nextLspReqId
|
||||
|
||||
-- reactorSend $ ReqShowMessage $ fmServerShowMessageRequest rid1 params
|
||||
|
||||
-- -------------------------------
|
||||
|
||||
(NotDidOpenTextDocument notification) -> do
|
||||
liftIO $ LSP.Utility.logm "****** reactor: processing NotDidOpenTextDocument"
|
||||
let
|
||||
doc = notification ^. J.params
|
||||
. J.textDocument
|
||||
. J.uri
|
||||
v = notification ^. J.params
|
||||
. J.textDocument
|
||||
. J.version
|
||||
fileName = J.uriToFilePath doc
|
||||
liftIO $ LSP.Utility.logs $ "********* fileName=" <> show fileName <> "version: " <> show v
|
||||
sendDiagnostics doc (Just v)
|
||||
|
||||
|
||||
|
||||
(NotDidSaveTextDocument notification) -> do
|
||||
liftIO $ LSP.Utility.logm "****** reactor: processing NotDidSaveTextDocument"
|
||||
let
|
||||
doc = notification ^. J.params
|
||||
. J.textDocument
|
||||
. J.uri
|
||||
|
||||
fileName = J.uriToFilePath doc
|
||||
liftIO $ LSP.Utility.logs $ "********* fileName=" ++ show fileName
|
||||
sendDiagnostics doc Nothing
|
||||
|
||||
|
||||
(NotDidCloseTextDocument req) -> do
|
||||
liftIO $ LSP.Utility.logm "****** reactor: processing NotDidCloseTextDocument"
|
||||
let
|
||||
doc = req ^. J.params
|
||||
. J.textDocument
|
||||
. J.uri
|
||||
fileName = J.uriToFilePath doc
|
||||
liftIO $ LSP.Utility.logs $ "********* fileName=" ++ show fileName
|
||||
sendEmptyDiagnostics doc Nothing
|
||||
|
||||
|
||||
(ReqDocumentFormatting req) -> do
|
||||
liftIO $ LSP.Utility.logm "****** reactor: processing ReqDocumentFormatting"
|
||||
let
|
||||
uri = req ^. J.params
|
||||
. J.textDocument
|
||||
. J.uri
|
||||
range = req ^. J.params
|
||||
. J.options
|
||||
tabSize = range ^. J.tabSize
|
||||
insertSpaces = range ^. J.insertSpaces
|
||||
|
||||
formattedDocument <- formatDocument uri tabSize insertSpaces
|
||||
publish req RspDocumentFormatting formattedDocument
|
||||
|
||||
-- This is a quick-and-dirty prototype implementation that will be
|
||||
-- completely rewritten!
|
||||
ReqHover req -> do
|
||||
liftIO $ LSP.Utility.logm "****** reactor: processing ReqHover"
|
||||
let (J.Position line col) = req ^. (J.params . J.position)
|
||||
doc = req ^. (J.params . J.textDocument . J.uri)
|
||||
fileName = case J.uriToFilePath doc of
|
||||
Nothing -> fail "Failed to parse URI in ReqHover."
|
||||
Just path -> path
|
||||
txt <- liftIO $ Data.Text.IO.readFile fileName
|
||||
errors <- liftIO $ runDhall fileName txt
|
||||
let explanations = mapMaybe (explain txt) errors
|
||||
isHovered :: Diagnosis -> Bool
|
||||
isHovered (Diagnosis _ Nothing _) = False
|
||||
isHovered (Diagnosis _ (Just (Range left right)) _)
|
||||
= left <= (line,col) && (line,col) <= right
|
||||
hover = case filter isHovered explanations of
|
||||
[] -> Nothing
|
||||
(diag : _) -> hoverFromDiagnosis diag
|
||||
publish req RspHover hover
|
||||
|
||||
unknown ->
|
||||
liftIO $ LSP.Utility.logs $ "\nIGNORING!!!\n HandlerRequest:" ++ show unknown
|
||||
|
||||
hoverFromDiagnosis :: Diagnosis -> Maybe J.Hover
|
||||
hoverFromDiagnosis (Diagnosis _ Nothing _) = Nothing
|
||||
hoverFromDiagnosis (Diagnosis _ (Just (Range left right)) diagnosis) = Just J.Hover{..}
|
||||
where
|
||||
_range = Just $ J.Range (uncurry J.Position left) (uncurry J.Position right)
|
||||
encodedDiag = URI.encode (Text.unpack diagnosis)
|
||||
command = "[Explain error](dhall-explain:?" <> Text.pack encodedDiag <> ")"
|
||||
_contents = J.List [J.PlainString command]
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
|
||||
publish :: J.RequestMessage J.ClientMethod req resp
|
||||
-> (J.ResponseMessage resp -> FromServerMessage)
|
||||
-> resp
|
||||
-> ReaderT (LSP.Core.LspFuncs ()) IO ()
|
||||
publish req unwrap response =
|
||||
do
|
||||
lf <- ask
|
||||
let
|
||||
rspMessage = LSP.Core.makeResponseMessage req response
|
||||
liftIO $ LSP.Core.sendFunc lf (unwrap rspMessage)
|
||||
|
|
@ -1,109 +0,0 @@
|
|||
|
||||
{-| This is the entry point for the LSP server. All calls are delegated to the haskell-lsp library
|
||||
which does the heavy lifting.
|
||||
-}
|
||||
module LSP.Server(run) where
|
||||
|
||||
import Control.Concurrent(forkIO)
|
||||
import Control.Concurrent.STM.TChan
|
||||
import qualified Control.Exception
|
||||
import Data.Default
|
||||
import Language.Haskell.LSP.Messages
|
||||
import qualified Language.Haskell.LSP.Control as LSP.Control
|
||||
import qualified Language.Haskell.LSP.Core as LSP.Core
|
||||
import qualified Language.Haskell.LSP.Utility as LSP.Utility
|
||||
|
||||
import qualified Language.Haskell.LSP.Types as J
|
||||
|
||||
import qualified System.Log.Logger
|
||||
import GHC.Conc (atomically)
|
||||
|
||||
import LSP.Dispatcher(dispatcher)
|
||||
|
||||
run :: Maybe String -> IO () -> IO Int
|
||||
run maybeLog dispatcherProc = flip Control.Exception.catches handlers $ do
|
||||
|
||||
rin <- atomically newTChan :: IO (TChan FromClientMessage)
|
||||
|
||||
let
|
||||
dp lf = do
|
||||
_rpid <- forkIO $ dispatcher lf rin
|
||||
dispatcherProc
|
||||
pure Nothing
|
||||
|
||||
flip Control.Exception.finally finalProc $ do
|
||||
setupLogger maybeLog
|
||||
LSP.Control.run (pure (Right ()), dp) (lspHandlers rin) lspOptions Nothing
|
||||
-- TODO: CTRL.run takes logger as the last option, and should write LSP log into it
|
||||
-- TODO: 1. make upstream logger write in the format which lsp-inspector can read
|
||||
-- TODO: 2. it would be cool, if we start writing log on file creation, e.g.
|
||||
-- TODO: e.g. "touch file /var/log/dhall-lsp-server/log-2018-03-12-12-45-34-fe5dk3.log to enable LSP logging"
|
||||
|
||||
where
|
||||
handlers = [ Control.Exception.Handler ioExcept
|
||||
, Control.Exception.Handler someExcept
|
||||
]
|
||||
finalProc = System.Log.Logger.removeAllHandlers
|
||||
ioExcept (e :: Control.Exception.IOException) = error $ show $ e -- print e >> pure 1
|
||||
someExcept (e :: Control.Exception.SomeException) = error $ show $ e -- print e >> pure 1
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
|
||||
-- | sets the output logger.
|
||||
-- | if no filename is provided then logger is disabled, if input is string `[OUTPUT]` then log goes to stderr,
|
||||
-- | which then redirects inside VSCode to the output pane of the plugin.
|
||||
setupLogger :: Maybe FilePath -> IO () -- TODO: ADD verbosity
|
||||
setupLogger Nothing = pure ()
|
||||
setupLogger (Just "[OUTPUT]") = LSP.Core.setupLogger Nothing [] System.Log.Logger.DEBUG
|
||||
setupLogger file = LSP.Core.setupLogger file [] System.Log.Logger.DEBUG
|
||||
|
||||
|
||||
|
||||
syncOptions :: J.TextDocumentSyncOptions
|
||||
syncOptions = J.TextDocumentSyncOptions
|
||||
{ J._openClose = Just True
|
||||
, J._change = Just J.TdSyncNone--J.TdSyncIncremental
|
||||
, J._willSave = Just False
|
||||
, J._willSaveWaitUntil = Just False
|
||||
, J._save = Just $ J.SaveOptions $ Just False
|
||||
}
|
||||
|
||||
-- Capabilities entry point
|
||||
lspOptions :: LSP.Core.Options
|
||||
lspOptions = def { LSP.Core.textDocumentSync = Just syncOptions
|
||||
-- , Core.executeCommandProvider = Just (J.ExecuteCommandOptions (J.List ["lsp-hello-command"]))
|
||||
-- , Core.codeLensProvider = Just (J.CodeLensOptions (Just False))
|
||||
}
|
||||
|
||||
lspHandlers :: TChan FromClientMessage -> LSP.Core.Handlers
|
||||
lspHandlers rin
|
||||
= def { LSP.Core.initializedHandler = Just $ passHandler rin NotInitialized
|
||||
-- , Core.renameHandler = Just $ passHandler rin ReqRename
|
||||
, LSP.Core.hoverHandler = Just $ passHandler rin ReqHover
|
||||
, LSP.Core.didOpenTextDocumentNotificationHandler = Just $ passHandler rin NotDidOpenTextDocument
|
||||
, LSP.Core.didSaveTextDocumentNotificationHandler = Just $ passHandler rin NotDidSaveTextDocument
|
||||
, LSP.Core.didChangeTextDocumentNotificationHandler = Just $ passHandler rin NotDidChangeTextDocument
|
||||
, LSP.Core.didCloseTextDocumentNotificationHandler = Just $ passHandler rin NotDidCloseTextDocument
|
||||
, LSP.Core.cancelNotificationHandler = Just $ passHandler rin NotCancelRequestFromClient
|
||||
, LSP.Core.responseHandler = Just $ responseHandlerCb rin
|
||||
-- , Core.codeActionHandler = Just $ passHandler rin ReqCodeAction
|
||||
, LSP.Core.executeCommandHandler = Just $ passHandler rin ReqExecuteCommand
|
||||
, LSP.Core.documentFormattingHandler = Just $ passHandler rin ReqDocumentFormatting
|
||||
}
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
passHandler :: TChan FromClientMessage -> (a -> FromClientMessage) -> LSP.Core.Handler a
|
||||
passHandler rin convert notification =
|
||||
atomically $ writeTChan rin (convert notification)
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
responseHandlerCb :: TChan FromClientMessage -> LSP.Core.Handler J.BareResponseMessage
|
||||
responseHandlerCb _rin resp =
|
||||
LSP.Utility.logs $ ">>> got ignoring ResponseMessage:" ++ show resp
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
|
||||
|
|
@ -11,7 +11,7 @@ import Language.Haskell.LSP.Types(
|
|||
)
|
||||
|
||||
import Data.Foldable (traverse_)
|
||||
import LSP.Handlers.Diagnostics (compilerDiagnostics)
|
||||
import Dhall.LSP.Handlers.Diagnostics (compilerDiagnostics)
|
||||
|
||||
import qualified Data.Text
|
||||
import qualified Data.Text.IO
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user