{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ExplicitNamespaces #-}
{-# LANGUAGE RecordWildCards #-}
module Dhall.LSP.Server(run) where
import Control.Monad.IO.Class (liftIO)
import Data.Aeson (fromJSON)
import Data.Default
import Dhall.LSP.Handlers
( completionHandler
, didOpenTextDocumentNotificationHandler
, didSaveTextDocumentNotificationHandler
, documentFormattingHandler
, documentLinkHandler
, executeCommandHandler
, hoverHandler
)
import Dhall.LSP.State
import Language.LSP.Server (Options(..), ServerDefinition(..), type (<~>)(..))
import Language.LSP.Types
import System.Exit (ExitCode(..))
import qualified Control.Concurrent.MVar as MVar
import qualified Control.Monad.Trans.Except as Except
import qualified Control.Monad.Trans.State.Strict as State
import qualified Data.Aeson as Aeson
import qualified Data.Text as Text
import qualified Language.LSP.Server as LSP
import qualified System.Exit as Exit
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 <- ServerState -> IO (MVar ServerState)
forall a. a -> IO (MVar a)
MVar.newMVar ServerState
initialState
let defaultConfig :: ServerConfig
defaultConfig = ServerConfig
forall a. Default a => a
def
let onConfigurationChange :: p -> Value -> Either Text b
onConfigurationChange p
_oldConfig Value
json =
case Value -> Result b
forall a. FromJSON a => Value -> Result a
fromJSON Value
json of
Aeson.Success b
config -> b -> Either Text b
forall a b. b -> Either a b
Right b
config
Aeson.Error FilePath
string -> Text -> Either Text b
forall a b. a -> Either a b
Left (FilePath -> Text
Text.pack FilePath
string)
let doInitialize :: b -> p -> m (Either a b)
doInitialize b
environment p
_request = do
Either a b -> m (Either a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> Either a b
forall a b. b -> Either a b
Right b
environment)
let options :: Options
options = Options
forall a. Default a => a
def
{ textDocumentSync :: Maybe TextDocumentSyncOptions
LSP.textDocumentSync = TextDocumentSyncOptions -> Maybe TextDocumentSyncOptions
forall a. a -> Maybe a
Just TextDocumentSyncOptions
syncOptions
, completionTriggerCharacters :: Maybe FilePath
completionTriggerCharacters = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just [Char
':', Char
'.', Char
'/']
, executeCommandCommands :: Maybe [Text]
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"
]
}
let staticHandlers :: Handlers HandlerM
staticHandlers =
[Handlers HandlerM] -> Handlers HandlerM
forall a. Monoid a => [a] -> a
mconcat
[ Handlers HandlerM
hoverHandler
, Handlers HandlerM
didOpenTextDocumentNotificationHandler
, Handlers HandlerM
didSaveTextDocumentNotificationHandler
, Handlers HandlerM
executeCommandHandler
, Handlers HandlerM
documentFormattingHandler
, Handlers HandlerM
documentLinkHandler
, Handlers HandlerM
completionHandler
]
let interpretHandler :: LanguageContextEnv ServerConfig -> HandlerM <~> IO
interpretHandler LanguageContextEnv ServerConfig
environment = Iso :: forall k (m :: k -> *) (n :: k -> *).
(forall (a :: k). m a -> n a)
-> (forall (a :: k). n a -> m a) -> m <~> n
Iso{forall a.
IO a
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) a
forall a. HandlerM a -> IO a
forward :: forall a. HandlerM a -> IO a
backward :: forall a.
IO a
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) a
backward :: forall a.
IO a
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) a
forward :: forall a. HandlerM a -> IO a
..}
where
forward :: HandlerM a -> IO a
forward :: HandlerM a -> IO a
forward HandlerM a
handler =
MVar ServerState -> (ServerState -> IO (ServerState, a)) -> IO a
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
MVar.modifyMVar MVar ServerState
state \ServerState
oldState -> do
LanguageContextEnv ServerConfig
-> LspT ServerConfig IO (ServerState, a) -> IO (ServerState, a)
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv ServerConfig
environment do
(Either (Severity, Text) a
e, ServerState
newState) <- StateT
ServerState (LspT ServerConfig IO) (Either (Severity, Text) a)
-> ServerState
-> LspT ServerConfig IO (Either (Severity, Text) a, ServerState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
State.runStateT (HandlerM a
-> StateT
ServerState (LspT ServerConfig IO) (Either (Severity, Text) a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Except.runExceptT HandlerM a
handler) ServerState
oldState
a
result <- case Either (Severity, Text) a
e of
Left (Severity
Log, Text
_message) -> do
let _xtype :: MessageType
_xtype = MessageType
MtLog
SServerMethod 'WindowLogMessage
-> MessageParams 'WindowLogMessage -> LspT ServerConfig IO ()
forall (m :: Method 'FromServer 'Notification) (f :: * -> *)
config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification SServerMethod 'WindowLogMessage
SWindowLogMessage LogMessageParams :: MessageType -> Text -> LogMessageParams
LogMessageParams{Text
MessageType
$sel:_xtype:LogMessageParams :: MessageType
$sel:_message:LogMessageParams :: Text
_xtype :: MessageType
_message :: Text
..}
IO a -> LspT ServerConfig IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (Text -> FilePath
Text.unpack Text
_message))
Left (Severity
severity_, Text
_message) -> do
let _xtype :: MessageType
_xtype = case Severity
severity_ of
Severity
Error -> MessageType
MtError
Severity
Warning -> MessageType
MtWarning
Severity
Info -> MessageType
MtInfo
Severity
Log -> MessageType
MtLog
SServerMethod 'WindowShowMessage
-> MessageParams 'WindowShowMessage -> LspT ServerConfig IO ()
forall (m :: Method 'FromServer 'Notification) (f :: * -> *)
config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification SServerMethod 'WindowShowMessage
SWindowShowMessage ShowMessageParams :: MessageType -> Text -> ShowMessageParams
ShowMessageParams{Text
MessageType
$sel:_xtype:ShowMessageParams :: MessageType
$sel:_message:ShowMessageParams :: Text
_xtype :: MessageType
_message :: Text
..}
IO a -> LspT ServerConfig IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (Text -> FilePath
Text.unpack Text
_message))
Right a
a -> do
a -> LspT ServerConfig IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
(ServerState, a) -> LspT ServerConfig IO (ServerState, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (ServerState
newState, a
result)
backward :: IO a
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) a
backward = IO a
-> ExceptT
(Severity, Text) (StateT ServerState (LspT ServerConfig IO)) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
Int
exitCode <- ServerDefinition ServerConfig -> IO Int
forall config. ServerDefinition config -> IO Int
LSP.runServer ServerDefinition :: forall config (m :: * -> *) a.
config
-> (config -> Value -> Either Text config)
-> (LanguageContextEnv config
-> Message 'Initialize -> IO (Either ResponseError a))
-> Handlers m
-> (a -> m <~> IO)
-> Options
-> ServerDefinition config
ServerDefinition{Handlers HandlerM
Options
ServerConfig
LanguageContextEnv ServerConfig -> HandlerM <~> IO
LanguageContextEnv ServerConfig
-> Message 'Initialize
-> IO (Either ResponseError (LanguageContextEnv ServerConfig))
ServerConfig -> Value -> Either Text ServerConfig
forall b p. FromJSON b => p -> Value -> Either Text b
forall (m :: * -> *) b p a. Monad m => b -> p -> m (Either a b)
defaultConfig :: ServerConfig
onConfigurationChange :: ServerConfig -> Value -> Either Text ServerConfig
doInitialize :: LanguageContextEnv ServerConfig
-> Message 'Initialize
-> IO (Either ResponseError (LanguageContextEnv ServerConfig))
staticHandlers :: Handlers HandlerM
interpretHandler :: LanguageContextEnv ServerConfig -> HandlerM <~> IO
options :: Options
interpretHandler :: LanguageContextEnv ServerConfig -> HandlerM <~> IO
staticHandlers :: Handlers HandlerM
options :: Options
doInitialize :: forall (m :: * -> *) b p a. Monad m => b -> p -> m (Either a b)
onConfigurationChange :: forall b p. FromJSON b => p -> Value -> Either Text b
defaultConfig :: ServerConfig
..}
case Int
exitCode of
Int
0 -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Int
n -> ExitCode -> IO ()
forall a. ExitCode -> IO a
Exit.exitWith (Int -> ExitCode
ExitFailure Int
n)
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.setupLogger Maybe FilePath
forall a. Maybe a
Nothing [] Priority
System.Log.Logger.DEBUG
setupLogger Maybe FilePath
file = Maybe FilePath -> [FilePath] -> Priority -> IO ()
LSP.setupLogger Maybe FilePath
file [] Priority
System.Log.Logger.DEBUG
syncOptions :: TextDocumentSyncOptions
syncOptions :: TextDocumentSyncOptions
syncOptions = TextDocumentSyncOptions :: Maybe Bool
-> Maybe TextDocumentSyncKind
-> Maybe Bool
-> Maybe Bool
-> Maybe (Bool |? SaveOptions)
-> TextDocumentSyncOptions
TextDocumentSyncOptions
{ $sel:_openClose:TextDocumentSyncOptions :: Maybe Bool
_openClose = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
, $sel:_change:TextDocumentSyncOptions :: Maybe TextDocumentSyncKind
_change = TextDocumentSyncKind -> Maybe TextDocumentSyncKind
forall a. a -> Maybe a
Just TextDocumentSyncKind
TdSyncIncremental
, $sel:_willSave:TextDocumentSyncOptions :: Maybe Bool
_willSave = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
, $sel:_willSaveWaitUntil:TextDocumentSyncOptions :: Maybe Bool
_willSaveWaitUntil = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
, $sel:_save:TextDocumentSyncOptions :: Maybe (Bool |? SaveOptions)
_save = (Bool |? SaveOptions) -> Maybe (Bool |? SaveOptions)
forall a. a -> Maybe a
Just (SaveOptions -> Bool |? SaveOptions
forall a b. b -> a |? b
InR (Maybe Bool -> SaveOptions
SaveOptions (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False)))
}