{-# LANGUAGE RecordWildCards #-}

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

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

  -- Callback that is called when the LSP server is started; makes the lsp
  -- state (LspFuncs) available to the message handlers through the `state` MVar.
  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 ()

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


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

-- Server capabilities. Tells the LSP client that we can execute commands etc.
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
'/']
                 -- 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]
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
        }