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

{-| This is the entry point for the LSP server. -}
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

-- | The main entry point for the LSP server.
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
'/']

        -- 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.
        , 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)

-- | 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 :: 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


-- 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 :: 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)))
  }