{-# LANGUAGE BlockArguments     #-}
{-# LANGUAGE CPP                #-}
{-# LANGUAGE ExplicitNamespaces #-}
{-# LANGUAGE LambdaCase         #-}
{-# LANGUAGE RecordWildCards    #-}

{-| This is the entry point for the LSP server. -}
module Dhall.LSP.Server (
      run
    , runWith
    ) where

import Colog.Core                    (LogAction, WithSeverity)
import Control.Monad.IO.Class        (liftIO)
import Data.Aeson                    (fromJSON)
import Data.Default
import Dhall                         (EvaluateSettings, defaultEvaluateSettings)
import Dhall.LSP.Handlers
    ( cancelationHandler
    , completionHandler
    , didOpenTextDocumentNotificationHandler
    , didSaveTextDocumentNotificationHandler
    , documentDidCloseHandler
    , documentFormattingHandler
    , documentLinkHandler
    , executeCommandHandler
    , hoverHandler
    , initializedHandler
    , textDocumentChangeHandler
    , workspaceChangeConfigurationHandler
    )
import Dhall.LSP.State
import Language.LSP.Protocol.Message
import Language.LSP.Protocol.Types
import Language.LSP.Server
    ( LspServerLog
    , Options (..)
    , ServerDefinition (..)
    , type (<~>) (..)
    )
import Prettyprinter                 (Doc, Pretty, pretty, viaShow)
import System.Exit                   (ExitCode (..))
import System.IO                     (stdin, stdout)

import qualified Colog.Core                       as Colog
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.Logging             as LSP
import qualified Language.LSP.Server              as LSP
import qualified System.Exit                      as Exit

-- | The main entry point for the LSP server.
run :: Maybe FilePath -> IO ()
run :: Maybe FilePath -> IO ()
run = EvaluateSettings -> Maybe FilePath -> IO ()
runWith EvaluateSettings
defaultEvaluateSettings

-- | The main entry point for the LSP server.
runWith :: EvaluateSettings -> Maybe FilePath -> IO ()
runWith :: EvaluateSettings -> Maybe FilePath -> IO ()
runWith EvaluateSettings
settings = (LogAction IO (WithSeverity LspServerLog) -> IO ())
-> Maybe FilePath -> IO ()
withLogger ((LogAction IO (WithSeverity LspServerLog) -> IO ())
 -> Maybe FilePath -> IO ())
-> (LogAction IO (WithSeverity LspServerLog) -> IO ())
-> Maybe FilePath
-> IO ()
forall a b. (a -> b) -> a -> b
$ \LogAction IO (WithSeverity LspServerLog)
ioLogger -> do
  let clientLogger :: LogAction (LspM ServerConfig) (WithSeverity LspServerLog)
clientLogger = (WithSeverity LspServerLog -> WithSeverity Text)
-> LogAction (LspM ServerConfig) (WithSeverity Text)
-> LogAction (LspM ServerConfig) (WithSeverity LspServerLog)
forall a b (m :: * -> *).
(a -> b) -> LogAction m b -> LogAction m a
Colog.cmap ((LspServerLog -> Text)
-> WithSeverity LspServerLog -> WithSeverity Text
forall a b. (a -> b) -> WithSeverity a -> WithSeverity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath -> Text
Text.pack (FilePath -> Text)
-> (LspServerLog -> FilePath) -> LspServerLog -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Any -> FilePath
forall a. Show a => a -> FilePath
show (Doc Any -> FilePath)
-> (LspServerLog -> Doc Any) -> LspServerLog -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LspServerLog -> Doc Any
forall ann. LspServerLog -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty)) LogAction (LspM ServerConfig) (WithSeverity Text)
forall c (m :: * -> *).
MonadLsp c m =>
LogAction m (WithSeverity Text)
LSP.defaultClientLogger

  let lspLogger :: LogAction (LspM ServerConfig) (WithSeverity LspServerLog)
lspLogger = LogAction (LspM ServerConfig) (WithSeverity LspServerLog)
clientLogger LogAction (LspM ServerConfig) (WithSeverity LspServerLog)
-> LogAction (LspM ServerConfig) (WithSeverity LspServerLog)
-> LogAction (LspM ServerConfig) (WithSeverity LspServerLog)
forall a. Semigroup a => a -> a -> a
<> (forall x. IO x -> LspM ServerConfig x)
-> LogAction IO (WithSeverity LspServerLog)
-> LogAction (LspM ServerConfig) (WithSeverity LspServerLog)
forall (m :: * -> *) (n :: * -> *) a.
(forall x. m x -> n x) -> LogAction m a -> LogAction n a
Colog.hoistLogAction IO x -> LspM ServerConfig x
forall x. IO x -> LspM ServerConfig x
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO LogAction IO (WithSeverity LspServerLog)
ioLogger

  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 a. a -> m a
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
        { LSP.optTextDocumentSync = Just syncOptions

        , optCompletionTriggerCharacters = Just [':', '.', '/']

        -- Note that this registers the dhall.server.lint command
        -- with VSCode, which means that our plugin can't expose a
        -- command of the same name. In the case of dhall.lint we
        -- name the server-side command dhall.server.lint to work
        -- around this peculiarity.
        , optExecuteCommandCommands =
            Just
              [ "dhall.server.lint",
                "dhall.server.annotateLet",
                "dhall.server.freezeImport",
                "dhall.server.freezeAllImports"
              ]
        }

  let staticHandlers :: p -> Handlers HandlerM
staticHandlers p
_clientCapabilities =
        [Handlers HandlerM] -> Handlers HandlerM
forall a. Monoid a => [a] -> a
mconcat
          [ EvaluateSettings -> Handlers HandlerM
hoverHandler EvaluateSettings
settings
          , EvaluateSettings -> Handlers HandlerM
didOpenTextDocumentNotificationHandler EvaluateSettings
settings
          , EvaluateSettings -> Handlers HandlerM
didSaveTextDocumentNotificationHandler EvaluateSettings
settings
          , EvaluateSettings -> Handlers HandlerM
executeCommandHandler EvaluateSettings
settings
          , Handlers HandlerM
documentFormattingHandler
          , Handlers HandlerM
documentLinkHandler
          , EvaluateSettings -> Handlers HandlerM
completionHandler EvaluateSettings
settings
          , Handlers HandlerM
initializedHandler
          , Handlers HandlerM
workspaceChangeConfigurationHandler
          , Handlers HandlerM
textDocumentChangeHandler
          , Handlers HandlerM
cancelationHandler
          , Handlers HandlerM
documentDidCloseHandler
          ]

  let interpretHandler :: LanguageContextEnv ServerConfig -> HandlerM <~> IO
interpretHandler LanguageContextEnv ServerConfig
environment = Iso{IO a
-> ExceptT
     (Severity, Text) (StateT ServerState (LspM ServerConfig)) a
HandlerM a -> IO a
forall a.
IO a
-> ExceptT
     (Severity, Text) (StateT ServerState (LspM ServerConfig)) a
forall a.
ExceptT (Severity, Text) (StateT ServerState (LspM ServerConfig)) a
-> IO a
forward :: forall a.
ExceptT (Severity, Text) (StateT ServerState (LspM ServerConfig)) a
-> IO a
backward :: forall a.
IO a
-> ExceptT
     (Severity, Text) (StateT ServerState (LspM ServerConfig)) a
forward :: forall a.
ExceptT (Severity, Text) (StateT ServerState (LspM ServerConfig)) a
-> IO a
backward :: forall a.
IO a
-> ExceptT
     (Severity, Text) (StateT ServerState (LspM ServerConfig)) a
..}
        where
          forward :: HandlerM a -> IO a
          forward :: forall a.
ExceptT (Severity, Text) (StateT ServerState (LspM ServerConfig)) 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 (LspM ServerConfig) (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 (LspM ServerConfig) (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 _type_ :: MessageType
_type_ = MessageType
MessageType_Log

                    SServerMethod 'Method_WindowLogMessage
-> MessageParams 'Method_WindowLogMessage
-> LspT ServerConfig IO ()
forall (m :: Method 'ServerToClient 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification SServerMethod 'Method_WindowLogMessage
SMethod_WindowLogMessage LogMessageParams{Text
MessageType
_message :: Text
_type_ :: MessageType
$sel:_type_:LogMessageParams :: MessageType
$sel:_message:LogMessageParams :: Text
..}

                    IO a -> LspT ServerConfig IO a
forall x. IO x -> LspM ServerConfig x
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO a
forall a. 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 _type_ :: MessageType
_type_ = case Severity
severity_ of
                          Severity
Error   -> MessageType
MessageType_Error
                          Severity
Warning -> MessageType
MessageType_Warning
                          Severity
Info    -> MessageType
MessageType_Info
#if !MIN_TOOL_VERSION_ghc(9,2,0)
                          Log     -> MessageType_Log
#endif

                    SServerMethod 'Method_WindowShowMessage
-> MessageParams 'Method_WindowShowMessage
-> LspT ServerConfig IO ()
forall (m :: Method 'ServerToClient 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification SServerMethod 'Method_WindowShowMessage
SMethod_WindowShowMessage ShowMessageParams{Text
MessageType
_message :: Text
_type_ :: MessageType
$sel:_type_:ShowMessageParams :: MessageType
$sel:_message:ShowMessageParams :: Text
..}
                    IO a -> LspT ServerConfig IO a
forall x. IO x -> LspM ServerConfig x
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO a
forall a. 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 a. a -> LspT ServerConfig IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

                (ServerState, a) -> LspT ServerConfig IO (ServerState, a)
forall a. a -> LspT ServerConfig IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ServerState
newState, a
result)

          backward :: IO a
-> ExceptT
     (Severity, Text) (StateT ServerState (LspM ServerConfig)) a
backward = IO a
-> ExceptT
     (Severity, Text) (StateT ServerState (LspM ServerConfig)) a
forall a.
IO a
-> ExceptT
     (Severity, Text) (StateT ServerState (LspM ServerConfig)) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

  Int
exitCode <- LogAction IO (WithSeverity LspServerLog)
-> LogAction (LspM ServerConfig) (WithSeverity LspServerLog)
-> Handle
-> Handle
-> ServerDefinition ServerConfig
-> IO Int
forall config.
LogAction IO (WithSeverity LspServerLog)
-> LogAction (LspM config) (WithSeverity LspServerLog)
-> Handle
-> Handle
-> ServerDefinition config
-> IO Int
LSP.runServerWithHandles LogAction IO (WithSeverity LspServerLog)
ioLogger LogAction (LspM ServerConfig) (WithSeverity LspServerLog)
lspLogger Handle
stdin Handle
stdout ServerDefinition{Options
ServerConfig
LanguageContextEnv ServerConfig -> HandlerM <~> IO
LanguageContextEnv ServerConfig
-> TMessage 'Method_Initialize
-> IO (Either ResponseError (LanguageContextEnv ServerConfig))
LanguageContextEnv ServerConfig
-> TRequestMessage 'Method_Initialize
-> IO (Either ResponseError (LanguageContextEnv ServerConfig))
ClientCapabilities -> Handlers HandlerM
ServerConfig -> Value -> Either Text ServerConfig
forall {p}. p -> Handlers HandlerM
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 :: forall {b} {p}. FromJSON b => p -> Value -> Either Text b
doInitialize :: forall {m :: * -> *} {b} {p} {a}.
Monad m =>
b -> p -> m (Either a b)
options :: Options
staticHandlers :: forall {p}. p -> Handlers HandlerM
interpretHandler :: LanguageContextEnv ServerConfig -> HandlerM <~> IO
defaultConfig :: ServerConfig
onConfigurationChange :: ServerConfig -> Value -> Either Text ServerConfig
doInitialize :: LanguageContextEnv ServerConfig
-> TMessage 'Method_Initialize
-> IO (Either ResponseError (LanguageContextEnv ServerConfig))
staticHandlers :: ClientCapabilities -> Handlers HandlerM
interpretHandler :: LanguageContextEnv ServerConfig -> HandlerM <~> IO
options :: Options
..}

  case Int
exitCode of
      Int
0 -> () -> IO ()
forall a. a -> IO a
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)

-- | Retrieve the output logger.
-- If no filename is provided then logger is disabled, if input is the string
-- `[OUTPUT]` then we log to stderr.
-- TODO: ADD verbosity
withLogger :: (LogAction IO (WithSeverity LspServerLog) -> IO ()) -> Maybe FilePath -> IO ()
withLogger :: (LogAction IO (WithSeverity LspServerLog) -> IO ())
-> Maybe FilePath -> IO ()
withLogger LogAction IO (WithSeverity LspServerLog) -> IO ()
k = \case
  Maybe FilePath
Nothing -> LogAction IO (WithSeverity LspServerLog) -> IO ()
k ((WithSeverity LspServerLog -> IO ())
-> LogAction IO (WithSeverity LspServerLog)
forall (m :: * -> *) msg. (msg -> m ()) -> LogAction m msg
Colog.LogAction (IO () -> WithSeverity LspServerLog -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())))
  Just FilePath
"[OUTPUT]" -> LogAction IO FilePath -> IO ()
k' LogAction IO FilePath
forall (m :: * -> *). MonadIO m => LogAction m FilePath
Colog.logStringStderr
  Just FilePath
fp -> FilePath -> (LogAction IO FilePath -> IO ()) -> IO ()
forall (m :: * -> *) r.
MonadIO m =>
FilePath -> (LogAction m FilePath -> IO r) -> IO r
Colog.withLogStringFile FilePath
fp LogAction IO FilePath -> IO ()
k'
  where
    k' :: LogAction IO FilePath -> IO ()
k' = LogAction IO (WithSeverity LspServerLog) -> IO ()
k (LogAction IO (WithSeverity LspServerLog) -> IO ())
-> (LogAction IO FilePath
    -> LogAction IO (WithSeverity LspServerLog))
-> LogAction IO FilePath
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WithSeverity LspServerLog -> FilePath)
-> LogAction IO FilePath
-> LogAction IO (WithSeverity LspServerLog)
forall a b (m :: * -> *).
(a -> b) -> LogAction m b -> LogAction m a
Colog.cmap (Doc Any -> FilePath
forall a. Show a => a -> FilePath
show (Doc Any -> FilePath)
-> (WithSeverity LspServerLog -> Doc Any)
-> WithSeverity LspServerLog
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithSeverity LspServerLog -> Doc Any
forall a ann. Pretty a => WithSeverity a -> Doc ann
prettyMsg)

    prettyMsg :: Pretty a => WithSeverity a -> Doc ann
    prettyMsg :: forall a ann. Pretty a => WithSeverity a -> Doc ann
prettyMsg WithSeverity a
l = Doc ann
"[" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Severity -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow (WithSeverity a -> Severity
forall msg. WithSeverity msg -> Severity
Colog.getSeverity WithSeverity a
l) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"] " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> a -> Doc ann
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (WithSeverity a -> a
forall msg. WithSeverity msg -> msg
Colog.getMsg WithSeverity a
l)

-- 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 :: TextDocumentSyncOptions
syncOptions :: TextDocumentSyncOptions
syncOptions = 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
TextDocumentSyncKind_Incremental
  , $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)))
  }