{-# LANGUAGE RecordWildCards #-}
module Dhall.LSP.Server(run) where
import Control.Concurrent.MVar
import Control.Lens ((^.))
import Data.Aeson (Result (Success), fromJSON)
import Data.Default
import Data.Text (Text)
import Dhall.LSP.Handlers
( completionHandler
, didOpenTextDocumentNotificationHandler
, didSaveTextDocumentNotificationHandler
, documentFormattingHandler
, documentLinkHandler
, executeCommandHandler
, hoverHandler
, nullHandler
, wrapHandler
)
import Dhall.LSP.State
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 qualified Language.Haskell.LSP.Types.Lens as J
import qualified System.Log.Logger
run :: Maybe FilePath -> IO ()
run :: Maybe FilePath -> IO ()
run Maybe FilePath
mlog = do
Maybe FilePath -> IO ()
setupLogger Maybe FilePath
mlog
MVar ServerState
state <- IO (MVar ServerState)
forall a. IO (MVar a)
newEmptyMVar
let onInitialConfiguration :: J.InitializeRequest -> Either Text ServerConfig
onInitialConfiguration :: InitializeRequest -> Either Text ServerConfig
onInitialConfiguration InitializeRequest
req
| Just Value
initOpts <- InitializeRequest
req InitializeRequest
-> Getting (Maybe Value) InitializeRequest (Maybe Value)
-> Maybe Value
forall s a. s -> Getting a s a -> a
^. (InitializeParams -> Const (Maybe Value) InitializeParams)
-> InitializeRequest -> Const (Maybe Value) InitializeRequest
forall s a. HasParams s a => Lens' s a
J.params ((InitializeParams -> Const (Maybe Value) InitializeParams)
-> InitializeRequest -> Const (Maybe Value) InitializeRequest)
-> ((Maybe Value -> Const (Maybe Value) (Maybe Value))
-> InitializeParams -> Const (Maybe Value) InitializeParams)
-> Getting (Maybe Value) InitializeRequest (Maybe Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Value -> Const (Maybe Value) (Maybe Value))
-> InitializeParams -> Const (Maybe Value) InitializeParams
forall s a. HasInitializationOptions s a => Lens' s a
J.initializationOptions
, Success ServerConfig
config <- Value -> Result ServerConfig
forall a. FromJSON a => Value -> Result a
fromJSON Value
initOpts
= ServerConfig -> Either Text ServerConfig
forall a b. b -> Either a b
Right ServerConfig
config
onInitialConfiguration InitializeRequest
_ = ServerConfig -> Either Text ServerConfig
forall a b. b -> Either a b
Right ServerConfig
forall a. Default a => a
def
let onConfigurationChange :: J.DidChangeConfigurationNotification -> Either Text ServerConfig
onConfigurationChange :: DidChangeConfigurationNotification -> Either Text ServerConfig
onConfigurationChange DidChangeConfigurationNotification
notification
| Value
preConfig <- DidChangeConfigurationNotification
notification DidChangeConfigurationNotification
-> Getting Value DidChangeConfigurationNotification Value -> Value
forall s a. s -> Getting a s a -> a
^. (DidChangeConfigurationParams
-> Const Value DidChangeConfigurationParams)
-> DidChangeConfigurationNotification
-> Const Value DidChangeConfigurationNotification
forall s a. HasParams s a => Lens' s a
J.params ((DidChangeConfigurationParams
-> Const Value DidChangeConfigurationParams)
-> DidChangeConfigurationNotification
-> Const Value DidChangeConfigurationNotification)
-> ((Value -> Const Value Value)
-> DidChangeConfigurationParams
-> Const Value DidChangeConfigurationParams)
-> Getting Value DidChangeConfigurationNotification Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Const Value Value)
-> DidChangeConfigurationParams
-> Const Value DidChangeConfigurationParams
forall s a. HasSettings s a => Lens' s a
J.settings
, Success ServerConfig
config <- Value -> Result ServerConfig
forall a. FromJSON a => Value -> Result a
fromJSON Value
preConfig
= ServerConfig -> Either Text ServerConfig
forall a b. b -> Either a b
Right ServerConfig
config
onConfigurationChange DidChangeConfigurationNotification
_ = ServerConfig -> Either Text ServerConfig
forall a b. b -> Either a b
Right ServerConfig
forall a. Default a => a
def
let onStartup :: LSP.Core.LspFuncs ServerConfig -> IO (Maybe J.ResponseError)
onStartup :: LspFuncs ServerConfig -> IO (Maybe ResponseError)
onStartup LspFuncs ServerConfig
lsp = do
MVar ServerState -> ServerState -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ServerState
state (LspFuncs ServerConfig -> ServerState
initialState LspFuncs ServerConfig
lsp)
Maybe ResponseError -> IO (Maybe ResponseError)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ResponseError
forall a. Maybe a
Nothing
Int
_ <- InitializeCallbacks ServerConfig
-> Handlers -> Options -> Maybe FilePath -> IO Int
forall configs.
Show configs =>
InitializeCallbacks configs
-> Handlers -> Options -> Maybe FilePath -> IO Int
LSP.Control.run (InitializeCallbacks :: forall config.
(InitializeRequest -> Either Text config)
-> (DidChangeConfigurationNotification -> Either Text config)
-> (LspFuncs config -> IO (Maybe ResponseError))
-> InitializeCallbacks config
LSP.Core.InitializeCallbacks {LspFuncs ServerConfig -> IO (Maybe ResponseError)
DidChangeConfigurationNotification -> Either Text ServerConfig
InitializeRequest -> Either Text ServerConfig
onInitialConfiguration :: InitializeRequest -> Either Text ServerConfig
onConfigurationChange :: DidChangeConfigurationNotification -> Either Text ServerConfig
onStartup :: LspFuncs ServerConfig -> IO (Maybe ResponseError)
onStartup :: LspFuncs ServerConfig -> IO (Maybe ResponseError)
onConfigurationChange :: DidChangeConfigurationNotification -> Either Text ServerConfig
onInitialConfiguration :: InitializeRequest -> Either Text ServerConfig
..})
(MVar ServerState -> Handlers
lspHandlers MVar ServerState
state)
Options
lspOptions
Maybe FilePath
forall a. Maybe a
Nothing
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
setupLogger :: Maybe FilePath -> IO ()
setupLogger :: Maybe FilePath -> IO ()
setupLogger Maybe FilePath
Nothing = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
setupLogger (Just FilePath
"[OUTPUT]") = Maybe FilePath -> [FilePath] -> Priority -> IO ()
LSP.Core.setupLogger Maybe FilePath
forall a. Maybe a
Nothing [] Priority
System.Log.Logger.DEBUG
setupLogger Maybe FilePath
file = Maybe FilePath -> [FilePath] -> Priority -> IO ()
LSP.Core.setupLogger Maybe FilePath
file [] Priority
System.Log.Logger.DEBUG
syncOptions :: J.TextDocumentSyncOptions
syncOptions :: TextDocumentSyncOptions
syncOptions = TextDocumentSyncOptions :: Maybe Bool
-> Maybe TextDocumentSyncKind
-> Maybe Bool
-> Maybe Bool
-> Maybe SaveOptions
-> TextDocumentSyncOptions
J.TextDocumentSyncOptions
{ $sel:_openClose:TextDocumentSyncOptions :: Maybe Bool
J._openClose = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
, $sel:_change:TextDocumentSyncOptions :: Maybe TextDocumentSyncKind
J._change = TextDocumentSyncKind -> Maybe TextDocumentSyncKind
forall a. a -> Maybe a
Just TextDocumentSyncKind
J.TdSyncIncremental
, $sel:_willSave:TextDocumentSyncOptions :: Maybe Bool
J._willSave = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
, $sel:_willSaveWaitUntil:TextDocumentSyncOptions :: Maybe Bool
J._willSaveWaitUntil = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
, $sel:_save:TextDocumentSyncOptions :: Maybe SaveOptions
J._save = SaveOptions -> Maybe SaveOptions
forall a. a -> Maybe a
Just (SaveOptions -> Maybe SaveOptions)
-> SaveOptions -> Maybe SaveOptions
forall a b. (a -> b) -> a -> b
$ Maybe Bool -> SaveOptions
J.SaveOptions (Maybe Bool -> SaveOptions) -> Maybe Bool -> SaveOptions
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
}
lspOptions :: LSP.Core.Options
lspOptions :: Options
lspOptions = Options
forall a. Default a => a
def { textDocumentSync :: Maybe TextDocumentSyncOptions
LSP.Core.textDocumentSync = TextDocumentSyncOptions -> Maybe TextDocumentSyncOptions
forall a. a -> Maybe a
Just TextDocumentSyncOptions
syncOptions
, completionTriggerCharacters :: Maybe FilePath
LSP.Core.completionTriggerCharacters = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just [Char
':', Char
'.', Char
'/']
, executeCommandCommands :: Maybe [Text]
LSP.Core.executeCommandCommands =
[Text] -> Maybe [Text]
forall a. a -> Maybe a
Just
[ Text
"dhall.server.lint",
Text
"dhall.server.annotateLet",
Text
"dhall.server.freezeImport",
Text
"dhall.server.freezeAllImports"
]
}
lspHandlers :: MVar ServerState -> LSP.Core.Handlers
lspHandlers :: MVar ServerState -> Handlers
lspHandlers MVar ServerState
state
= Handlers
forall a. Default a => a
def { initializedHandler :: Maybe (Handler InitializedNotification)
LSP.Core.initializedHandler = Handler InitializedNotification
-> Maybe (Handler InitializedNotification)
forall a. a -> Maybe a
Just (Handler InitializedNotification
-> Maybe (Handler InitializedNotification))
-> Handler InitializedNotification
-> Maybe (Handler InitializedNotification)
forall a b. (a -> b) -> a -> b
$ MVar ServerState
-> (InitializedNotification -> HandlerM ())
-> Handler InitializedNotification
forall a. MVar ServerState -> (a -> HandlerM ()) -> a -> IO ()
wrapHandler MVar ServerState
state InitializedNotification -> HandlerM ()
forall a. a -> HandlerM ()
nullHandler
, hoverHandler :: Maybe (Handler HoverRequest)
LSP.Core.hoverHandler = Handler HoverRequest -> Maybe (Handler HoverRequest)
forall a. a -> Maybe a
Just (Handler HoverRequest -> Maybe (Handler HoverRequest))
-> Handler HoverRequest -> Maybe (Handler HoverRequest)
forall a b. (a -> b) -> a -> b
$ MVar ServerState
-> (HoverRequest -> HandlerM ()) -> Handler HoverRequest
forall a. MVar ServerState -> (a -> HandlerM ()) -> a -> IO ()
wrapHandler MVar ServerState
state HoverRequest -> HandlerM ()
hoverHandler
, didOpenTextDocumentNotificationHandler :: Maybe (Handler DidOpenTextDocumentNotification)
LSP.Core.didOpenTextDocumentNotificationHandler = Handler DidOpenTextDocumentNotification
-> Maybe (Handler DidOpenTextDocumentNotification)
forall a. a -> Maybe a
Just (Handler DidOpenTextDocumentNotification
-> Maybe (Handler DidOpenTextDocumentNotification))
-> Handler DidOpenTextDocumentNotification
-> Maybe (Handler DidOpenTextDocumentNotification)
forall a b. (a -> b) -> a -> b
$ MVar ServerState
-> (DidOpenTextDocumentNotification -> HandlerM ())
-> Handler DidOpenTextDocumentNotification
forall a. MVar ServerState -> (a -> HandlerM ()) -> a -> IO ()
wrapHandler MVar ServerState
state DidOpenTextDocumentNotification -> HandlerM ()
didOpenTextDocumentNotificationHandler
, didChangeTextDocumentNotificationHandler :: Maybe (Handler DidChangeTextDocumentNotification)
LSP.Core.didChangeTextDocumentNotificationHandler = Handler DidChangeTextDocumentNotification
-> Maybe (Handler DidChangeTextDocumentNotification)
forall a. a -> Maybe a
Just (Handler DidChangeTextDocumentNotification
-> Maybe (Handler DidChangeTextDocumentNotification))
-> Handler DidChangeTextDocumentNotification
-> Maybe (Handler DidChangeTextDocumentNotification)
forall a b. (a -> b) -> a -> b
$ MVar ServerState
-> (DidChangeTextDocumentNotification -> HandlerM ())
-> Handler DidChangeTextDocumentNotification
forall a. MVar ServerState -> (a -> HandlerM ()) -> a -> IO ()
wrapHandler MVar ServerState
state DidChangeTextDocumentNotification -> HandlerM ()
forall a. a -> HandlerM ()
nullHandler
, didSaveTextDocumentNotificationHandler :: Maybe (Handler DidSaveTextDocumentNotification)
LSP.Core.didSaveTextDocumentNotificationHandler = Handler DidSaveTextDocumentNotification
-> Maybe (Handler DidSaveTextDocumentNotification)
forall a. a -> Maybe a
Just (Handler DidSaveTextDocumentNotification
-> Maybe (Handler DidSaveTextDocumentNotification))
-> Handler DidSaveTextDocumentNotification
-> Maybe (Handler DidSaveTextDocumentNotification)
forall a b. (a -> b) -> a -> b
$ MVar ServerState
-> (DidSaveTextDocumentNotification -> HandlerM ())
-> Handler DidSaveTextDocumentNotification
forall a. MVar ServerState -> (a -> HandlerM ()) -> a -> IO ()
wrapHandler MVar ServerState
state DidSaveTextDocumentNotification -> HandlerM ()
didSaveTextDocumentNotificationHandler
, didCloseTextDocumentNotificationHandler :: Maybe (Handler DidCloseTextDocumentNotification)
LSP.Core.didCloseTextDocumentNotificationHandler = Handler DidCloseTextDocumentNotification
-> Maybe (Handler DidCloseTextDocumentNotification)
forall a. a -> Maybe a
Just (Handler DidCloseTextDocumentNotification
-> Maybe (Handler DidCloseTextDocumentNotification))
-> Handler DidCloseTextDocumentNotification
-> Maybe (Handler DidCloseTextDocumentNotification)
forall a b. (a -> b) -> a -> b
$ MVar ServerState
-> (DidCloseTextDocumentNotification -> HandlerM ())
-> Handler DidCloseTextDocumentNotification
forall a. MVar ServerState -> (a -> HandlerM ()) -> a -> IO ()
wrapHandler MVar ServerState
state DidCloseTextDocumentNotification -> HandlerM ()
forall a. a -> HandlerM ()
nullHandler
, cancelNotificationHandler :: Maybe (Handler CancelNotification)
LSP.Core.cancelNotificationHandler = Handler CancelNotification -> Maybe (Handler CancelNotification)
forall a. a -> Maybe a
Just (Handler CancelNotification -> Maybe (Handler CancelNotification))
-> Handler CancelNotification -> Maybe (Handler CancelNotification)
forall a b. (a -> b) -> a -> b
$ MVar ServerState
-> (CancelNotification -> HandlerM ())
-> Handler CancelNotification
forall a. MVar ServerState -> (a -> HandlerM ()) -> a -> IO ()
wrapHandler MVar ServerState
state CancelNotification -> HandlerM ()
forall a. a -> HandlerM ()
nullHandler
, responseHandler :: Maybe (Handler BareResponseMessage)
LSP.Core.responseHandler = Handler BareResponseMessage -> Maybe (Handler BareResponseMessage)
forall a. a -> Maybe a
Just (Handler BareResponseMessage
-> Maybe (Handler BareResponseMessage))
-> Handler BareResponseMessage
-> Maybe (Handler BareResponseMessage)
forall a b. (a -> b) -> a -> b
$ MVar ServerState
-> (BareResponseMessage -> HandlerM ())
-> Handler BareResponseMessage
forall a. MVar ServerState -> (a -> HandlerM ()) -> a -> IO ()
wrapHandler MVar ServerState
state BareResponseMessage -> HandlerM ()
forall a. a -> HandlerM ()
nullHandler
, executeCommandHandler :: Maybe (Handler ExecuteCommandRequest)
LSP.Core.executeCommandHandler = Handler ExecuteCommandRequest
-> Maybe (Handler ExecuteCommandRequest)
forall a. a -> Maybe a
Just (Handler ExecuteCommandRequest
-> Maybe (Handler ExecuteCommandRequest))
-> Handler ExecuteCommandRequest
-> Maybe (Handler ExecuteCommandRequest)
forall a b. (a -> b) -> a -> b
$ MVar ServerState
-> (ExecuteCommandRequest -> HandlerM ())
-> Handler ExecuteCommandRequest
forall a. MVar ServerState -> (a -> HandlerM ()) -> a -> IO ()
wrapHandler MVar ServerState
state ExecuteCommandRequest -> HandlerM ()
executeCommandHandler
, documentFormattingHandler :: Maybe (Handler DocumentFormattingRequest)
LSP.Core.documentFormattingHandler = Handler DocumentFormattingRequest
-> Maybe (Handler DocumentFormattingRequest)
forall a. a -> Maybe a
Just (Handler DocumentFormattingRequest
-> Maybe (Handler DocumentFormattingRequest))
-> Handler DocumentFormattingRequest
-> Maybe (Handler DocumentFormattingRequest)
forall a b. (a -> b) -> a -> b
$ MVar ServerState
-> (DocumentFormattingRequest -> HandlerM ())
-> Handler DocumentFormattingRequest
forall a. MVar ServerState -> (a -> HandlerM ()) -> a -> IO ()
wrapHandler MVar ServerState
state DocumentFormattingRequest -> HandlerM ()
documentFormattingHandler
, documentLinkHandler :: Maybe (Handler DocumentLinkRequest)
LSP.Core.documentLinkHandler = Handler DocumentLinkRequest -> Maybe (Handler DocumentLinkRequest)
forall a. a -> Maybe a
Just (Handler DocumentLinkRequest
-> Maybe (Handler DocumentLinkRequest))
-> Handler DocumentLinkRequest
-> Maybe (Handler DocumentLinkRequest)
forall a b. (a -> b) -> a -> b
$ MVar ServerState
-> (DocumentLinkRequest -> HandlerM ())
-> Handler DocumentLinkRequest
forall a. MVar ServerState -> (a -> HandlerM ()) -> a -> IO ()
wrapHandler MVar ServerState
state DocumentLinkRequest -> HandlerM ()
documentLinkHandler
, completionHandler :: Maybe (Handler CompletionRequest)
LSP.Core.completionHandler = Handler CompletionRequest -> Maybe (Handler CompletionRequest)
forall a. a -> Maybe a
Just (Handler CompletionRequest -> Maybe (Handler CompletionRequest))
-> Handler CompletionRequest -> Maybe (Handler CompletionRequest)
forall a b. (a -> b) -> a -> b
$ MVar ServerState
-> (CompletionRequest -> HandlerM ()) -> Handler CompletionRequest
forall a. MVar ServerState -> (a -> HandlerM ()) -> a -> IO ()
wrapHandler MVar ServerState
state CompletionRequest -> HandlerM ()
completionHandler
}