{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExplicitNamespaces #-}
{-# LANGUAGE ScopedTypeVariables #-}

module StaticLS.Server (
    runServer,
) where

--- Standard imports

import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except

--- Uncommon 3rd-party imports

import Language.LSP.Server (
    Handlers,
    LanguageContextEnv,
    LspT,
    ServerDefinition (..),
    type (<~>) (Iso),
 )

import Language.LSP.Protocol.Message (Method (..), ResponseError (..), SMethod (..), TMessage, TRequestMessage (..))
import Language.LSP.Protocol.Types
import qualified Language.LSP.Server as LSP

---- Local imports

import StaticLS.IDE.Definition
import StaticLS.IDE.Hover
import StaticLS.IDE.References
import StaticLS.IDE.Workspace.Symbol
import StaticLS.StaticEnv
import StaticLS.StaticEnv.Options

-------------------------------------------------------------------------

-----------------------------------------------------------------
--------------------- LSP event handlers ------------------------
-----------------------------------------------------------------

handleChangeConfiguration :: Handlers (LspT c StaticLs)
handleChangeConfiguration :: forall c. Handlers (LspT c StaticLs)
handleChangeConfiguration = SMethod 'Method_WorkspaceDidChangeConfiguration
-> Handler
     (LspT c StaticLs) 'Method_WorkspaceDidChangeConfiguration
-> Handlers (LspT c StaticLs)
forall (m :: Method 'ClientToServer 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
LSP.notificationHandler SMethod 'Method_WorkspaceDidChangeConfiguration
SMethod_WorkspaceDidChangeConfiguration (Handler (LspT c StaticLs) 'Method_WorkspaceDidChangeConfiguration
 -> Handlers (LspT c StaticLs))
-> Handler
     (LspT c StaticLs) 'Method_WorkspaceDidChangeConfiguration
-> Handlers (LspT c StaticLs)
forall a b. (a -> b) -> a -> b
$ LspT c StaticLs ()
-> TNotificationMessage 'Method_WorkspaceDidChangeConfiguration
-> LspT c StaticLs ()
forall a.
a
-> TNotificationMessage 'Method_WorkspaceDidChangeConfiguration
-> a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LspT c StaticLs ()
 -> TNotificationMessage 'Method_WorkspaceDidChangeConfiguration
 -> LspT c StaticLs ())
-> LspT c StaticLs ()
-> TNotificationMessage 'Method_WorkspaceDidChangeConfiguration
-> LspT c StaticLs ()
forall a b. (a -> b) -> a -> b
$ () -> LspT c StaticLs ()
forall a. a -> LspT c StaticLs a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

handleInitialized :: Handlers (LspT c StaticLs)
handleInitialized :: forall c. Handlers (LspT c StaticLs)
handleInitialized = SMethod 'Method_Initialized
-> Handler (LspT c StaticLs) 'Method_Initialized
-> Handlers (LspT c StaticLs)
forall (m :: Method 'ClientToServer 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
LSP.notificationHandler SMethod 'Method_Initialized
SMethod_Initialized (Handler (LspT c StaticLs) 'Method_Initialized
 -> Handlers (LspT c StaticLs))
-> Handler (LspT c StaticLs) 'Method_Initialized
-> Handlers (LspT c StaticLs)
forall a b. (a -> b) -> a -> b
$ LspT c StaticLs ()
-> TNotificationMessage 'Method_Initialized -> LspT c StaticLs ()
forall a. a -> TNotificationMessage 'Method_Initialized -> a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LspT c StaticLs ()
 -> TNotificationMessage 'Method_Initialized -> LspT c StaticLs ())
-> LspT c StaticLs ()
-> TNotificationMessage 'Method_Initialized
-> LspT c StaticLs ()
forall a b. (a -> b) -> a -> b
$ () -> LspT c StaticLs ()
forall a. a -> LspT c StaticLs a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

handleTextDocumentHoverRequest :: Handlers (LspT c StaticLs)
handleTextDocumentHoverRequest :: forall c. Handlers (LspT c StaticLs)
handleTextDocumentHoverRequest = SMethod 'Method_TextDocumentHover
-> Handler (LspT c StaticLs) 'Method_TextDocumentHover
-> Handlers (LspT c StaticLs)
forall (m :: Method 'ClientToServer 'Request) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
LSP.requestHandler SMethod 'Method_TextDocumentHover
SMethod_TextDocumentHover (Handler (LspT c StaticLs) 'Method_TextDocumentHover
 -> Handlers (LspT c StaticLs))
-> Handler (LspT c StaticLs) 'Method_TextDocumentHover
-> Handlers (LspT c StaticLs)
forall a b. (a -> b) -> a -> b
$ \TRequestMessage 'Method_TextDocumentHover
req Either ResponseError (Hover |? Null) -> LspT c StaticLs ()
resp -> do
    let hoverParams :: MessageParams 'Method_TextDocumentHover
hoverParams = TRequestMessage 'Method_TextDocumentHover
req._params
    Maybe Hover
hover <- StaticLs (Maybe Hover) -> LspT c StaticLs (Maybe Hover)
forall (m :: * -> *) a. Monad m => m a -> LspT c m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StaticLs (Maybe Hover) -> LspT c StaticLs (Maybe Hover))
-> StaticLs (Maybe Hover) -> LspT c StaticLs (Maybe Hover)
forall a b. (a -> b) -> a -> b
$ TextDocumentIdentifier -> Position -> StaticLs (Maybe Hover)
forall (m :: * -> *).
(HasCallStack, HasStaticEnv m, MonadIO m) =>
TextDocumentIdentifier -> Position -> m (Maybe Hover)
retrieveHover MessageParams 'Method_TextDocumentHover
hoverParams._textDocument MessageParams 'Method_TextDocumentHover
hoverParams._position
    Either ResponseError (Hover |? Null) -> LspT c StaticLs ()
resp (Either ResponseError (Hover |? Null) -> LspT c StaticLs ())
-> Either ResponseError (Hover |? Null) -> LspT c StaticLs ()
forall a b. (a -> b) -> a -> b
$ (Hover |? Null) -> Either ResponseError (Hover |? Null)
forall a b. b -> Either a b
Right ((Hover |? Null) -> Either ResponseError (Hover |? Null))
-> (Hover |? Null) -> Either ResponseError (Hover |? Null)
forall a b. (a -> b) -> a -> b
$ Maybe Hover -> Hover |? Null
forall a. Maybe a -> a |? Null
maybeToNull Maybe Hover
hover

handleDefinitionRequest :: Handlers (LspT c StaticLs)
handleDefinitionRequest :: forall c. Handlers (LspT c StaticLs)
handleDefinitionRequest = SMethod 'Method_TextDocumentDefinition
-> Handler (LspT c StaticLs) 'Method_TextDocumentDefinition
-> Handlers (LspT c StaticLs)
forall (m :: Method 'ClientToServer 'Request) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
LSP.requestHandler SMethod 'Method_TextDocumentDefinition
SMethod_TextDocumentDefinition (Handler (LspT c StaticLs) 'Method_TextDocumentDefinition
 -> Handlers (LspT c StaticLs))
-> Handler (LspT c StaticLs) 'Method_TextDocumentDefinition
-> Handlers (LspT c StaticLs)
forall a b. (a -> b) -> a -> b
$ \TRequestMessage 'Method_TextDocumentDefinition
req Either ResponseError (Definition |? ([DefinitionLink] |? Null))
-> LspT c StaticLs ()
resp -> do
    let defParams :: MessageParams 'Method_TextDocumentDefinition
defParams = TRequestMessage 'Method_TextDocumentDefinition
req._params
    [DefinitionLink]
defs <- StaticLs [DefinitionLink] -> LspT c StaticLs [DefinitionLink]
forall (m :: * -> *) a. Monad m => m a -> LspT c m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StaticLs [DefinitionLink] -> LspT c StaticLs [DefinitionLink])
-> StaticLs [DefinitionLink] -> LspT c StaticLs [DefinitionLink]
forall a b. (a -> b) -> a -> b
$ TextDocumentIdentifier -> Position -> StaticLs [DefinitionLink]
forall (m :: * -> *).
(HasCallStack, HasStaticEnv m, MonadIO m) =>
TextDocumentIdentifier -> Position -> m [DefinitionLink]
getDefinition MessageParams 'Method_TextDocumentDefinition
defParams._textDocument MessageParams 'Method_TextDocumentDefinition
defParams._position
    Either ResponseError (Definition |? ([DefinitionLink] |? Null))
-> LspT c StaticLs ()
resp (Either ResponseError (Definition |? ([DefinitionLink] |? Null))
 -> LspT c StaticLs ())
-> Either ResponseError (Definition |? ([DefinitionLink] |? Null))
-> LspT c StaticLs ()
forall a b. (a -> b) -> a -> b
$ (Definition |? ([DefinitionLink] |? Null))
-> Either ResponseError (Definition |? ([DefinitionLink] |? Null))
forall a b. b -> Either a b
Right ((Definition |? ([DefinitionLink] |? Null))
 -> Either ResponseError (Definition |? ([DefinitionLink] |? Null)))
-> ([DefinitionLink] -> Definition |? ([DefinitionLink] |? Null))
-> [DefinitionLink]
-> Either ResponseError (Definition |? ([DefinitionLink] |? Null))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([DefinitionLink] |? Null)
-> Definition |? ([DefinitionLink] |? Null)
forall a b. b -> a |? b
InR (([DefinitionLink] |? Null)
 -> Definition |? ([DefinitionLink] |? Null))
-> ([DefinitionLink] -> [DefinitionLink] |? Null)
-> [DefinitionLink]
-> Definition |? ([DefinitionLink] |? Null)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DefinitionLink] -> [DefinitionLink] |? Null
forall a b. a -> a |? b
InL ([DefinitionLink]
 -> Either ResponseError (Definition |? ([DefinitionLink] |? Null)))
-> [DefinitionLink]
-> Either ResponseError (Definition |? ([DefinitionLink] |? Null))
forall a b. (a -> b) -> a -> b
$ [DefinitionLink]
defs

handleTypeDefinitionRequest :: Handlers (LspT c StaticLs)
handleTypeDefinitionRequest :: forall c. Handlers (LspT c StaticLs)
handleTypeDefinitionRequest = SMethod 'Method_TextDocumentTypeDefinition
-> Handler (LspT c StaticLs) 'Method_TextDocumentTypeDefinition
-> Handlers (LspT c StaticLs)
forall (m :: Method 'ClientToServer 'Request) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
LSP.requestHandler SMethod 'Method_TextDocumentTypeDefinition
SMethod_TextDocumentTypeDefinition (Handler (LspT c StaticLs) 'Method_TextDocumentTypeDefinition
 -> Handlers (LspT c StaticLs))
-> Handler (LspT c StaticLs) 'Method_TextDocumentTypeDefinition
-> Handlers (LspT c StaticLs)
forall a b. (a -> b) -> a -> b
$ \TRequestMessage 'Method_TextDocumentTypeDefinition
req Either ResponseError (Definition |? ([DefinitionLink] |? Null))
-> LspT c StaticLs ()
resp -> do
    let typeDefParams :: MessageParams 'Method_TextDocumentTypeDefinition
typeDefParams = TRequestMessage 'Method_TextDocumentTypeDefinition
req._params
    [DefinitionLink]
defs <- StaticLs [DefinitionLink] -> LspT c StaticLs [DefinitionLink]
forall (m :: * -> *) a. Monad m => m a -> LspT c m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StaticLs [DefinitionLink] -> LspT c StaticLs [DefinitionLink])
-> StaticLs [DefinitionLink] -> LspT c StaticLs [DefinitionLink]
forall a b. (a -> b) -> a -> b
$ TextDocumentIdentifier -> Position -> StaticLs [DefinitionLink]
forall (m :: * -> *).
(HasCallStack, HasStaticEnv m, MonadIO m) =>
TextDocumentIdentifier -> Position -> m [DefinitionLink]
getTypeDefinition MessageParams 'Method_TextDocumentTypeDefinition
typeDefParams._textDocument MessageParams 'Method_TextDocumentTypeDefinition
typeDefParams._position
    Either ResponseError (Definition |? ([DefinitionLink] |? Null))
-> LspT c StaticLs ()
resp (Either ResponseError (Definition |? ([DefinitionLink] |? Null))
 -> LspT c StaticLs ())
-> Either ResponseError (Definition |? ([DefinitionLink] |? Null))
-> LspT c StaticLs ()
forall a b. (a -> b) -> a -> b
$ (Definition |? ([DefinitionLink] |? Null))
-> Either ResponseError (Definition |? ([DefinitionLink] |? Null))
forall a b. b -> Either a b
Right ((Definition |? ([DefinitionLink] |? Null))
 -> Either ResponseError (Definition |? ([DefinitionLink] |? Null)))
-> ([DefinitionLink] -> Definition |? ([DefinitionLink] |? Null))
-> [DefinitionLink]
-> Either ResponseError (Definition |? ([DefinitionLink] |? Null))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([DefinitionLink] |? Null)
-> Definition |? ([DefinitionLink] |? Null)
forall a b. b -> a |? b
InR (([DefinitionLink] |? Null)
 -> Definition |? ([DefinitionLink] |? Null))
-> ([DefinitionLink] -> [DefinitionLink] |? Null)
-> [DefinitionLink]
-> Definition |? ([DefinitionLink] |? Null)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DefinitionLink] -> [DefinitionLink] |? Null
forall a b. a -> a |? b
InL ([DefinitionLink]
 -> Either ResponseError (Definition |? ([DefinitionLink] |? Null)))
-> [DefinitionLink]
-> Either ResponseError (Definition |? ([DefinitionLink] |? Null))
forall a b. (a -> b) -> a -> b
$ [DefinitionLink]
defs

handleReferencesRequest :: Handlers (LspT c StaticLs)
handleReferencesRequest :: forall c. Handlers (LspT c StaticLs)
handleReferencesRequest = SMethod 'Method_TextDocumentReferences
-> Handler (LspT c StaticLs) 'Method_TextDocumentReferences
-> Handlers (LspT c StaticLs)
forall (m :: Method 'ClientToServer 'Request) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
LSP.requestHandler SMethod 'Method_TextDocumentReferences
SMethod_TextDocumentReferences (Handler (LspT c StaticLs) 'Method_TextDocumentReferences
 -> Handlers (LspT c StaticLs))
-> Handler (LspT c StaticLs) 'Method_TextDocumentReferences
-> Handlers (LspT c StaticLs)
forall a b. (a -> b) -> a -> b
$ \TRequestMessage 'Method_TextDocumentReferences
req Either ResponseError ([Location] |? Null) -> LspT c StaticLs ()
res -> do
    let refParams :: MessageParams 'Method_TextDocumentReferences
refParams = TRequestMessage 'Method_TextDocumentReferences
req._params
    [Location]
refs <- StaticLs [Location] -> LspT c StaticLs [Location]
forall (m :: * -> *) a. Monad m => m a -> LspT c m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StaticLs [Location] -> LspT c StaticLs [Location])
-> StaticLs [Location] -> LspT c StaticLs [Location]
forall a b. (a -> b) -> a -> b
$ TextDocumentIdentifier -> Position -> StaticLs [Location]
forall (m :: * -> *).
(HasStaticEnv m, MonadIO m) =>
TextDocumentIdentifier -> Position -> m [Location]
findRefs MessageParams 'Method_TextDocumentReferences
refParams._textDocument MessageParams 'Method_TextDocumentReferences
refParams._position
    Either ResponseError ([Location] |? Null) -> LspT c StaticLs ()
res (Either ResponseError ([Location] |? Null) -> LspT c StaticLs ())
-> Either ResponseError ([Location] |? Null) -> LspT c StaticLs ()
forall a b. (a -> b) -> a -> b
$ ([Location] |? Null) -> Either ResponseError ([Location] |? Null)
forall a b. b -> Either a b
Right (([Location] |? Null) -> Either ResponseError ([Location] |? Null))
-> ([Location] -> [Location] |? Null)
-> [Location]
-> Either ResponseError ([Location] |? Null)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Location] -> [Location] |? Null
forall a b. a -> a |? b
InL ([Location] -> Either ResponseError ([Location] |? Null))
-> [Location] -> Either ResponseError ([Location] |? Null)
forall a b. (a -> b) -> a -> b
$ [Location]
refs

handleCancelNotification :: Handlers (LspT c StaticLs)
handleCancelNotification :: forall c. Handlers (LspT c StaticLs)
handleCancelNotification = SMethod 'Method_CancelRequest
-> Handler (LspT c StaticLs) 'Method_CancelRequest
-> Handlers (LspT c StaticLs)
forall (m :: Method 'ClientToServer 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
LSP.notificationHandler SMethod 'Method_CancelRequest
forall {f :: MessageDirection}. SMethod 'Method_CancelRequest
SMethod_CancelRequest (Handler (LspT c StaticLs) 'Method_CancelRequest
 -> Handlers (LspT c StaticLs))
-> Handler (LspT c StaticLs) 'Method_CancelRequest
-> Handlers (LspT c StaticLs)
forall a b. (a -> b) -> a -> b
$ \TNotificationMessage 'Method_CancelRequest
_ -> () -> LspT c StaticLs ()
forall a. a -> LspT c StaticLs a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

handleDidOpen :: Handlers (LspT c StaticLs)
handleDidOpen :: forall c. Handlers (LspT c StaticLs)
handleDidOpen = SMethod 'Method_TextDocumentDidOpen
-> Handler (LspT c StaticLs) 'Method_TextDocumentDidOpen
-> Handlers (LspT c StaticLs)
forall (m :: Method 'ClientToServer 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
LSP.notificationHandler SMethod 'Method_TextDocumentDidOpen
SMethod_TextDocumentDidOpen (Handler (LspT c StaticLs) 'Method_TextDocumentDidOpen
 -> Handlers (LspT c StaticLs))
-> Handler (LspT c StaticLs) 'Method_TextDocumentDidOpen
-> Handlers (LspT c StaticLs)
forall a b. (a -> b) -> a -> b
$ \TNotificationMessage 'Method_TextDocumentDidOpen
_ -> () -> LspT c StaticLs ()
forall a. a -> LspT c StaticLs a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

handleDidChange :: Handlers (LspT c StaticLs)
handleDidChange :: forall c. Handlers (LspT c StaticLs)
handleDidChange = SMethod 'Method_TextDocumentDidChange
-> Handler (LspT c StaticLs) 'Method_TextDocumentDidChange
-> Handlers (LspT c StaticLs)
forall (m :: Method 'ClientToServer 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
LSP.notificationHandler SMethod 'Method_TextDocumentDidChange
SMethod_TextDocumentDidChange (Handler (LspT c StaticLs) 'Method_TextDocumentDidChange
 -> Handlers (LspT c StaticLs))
-> Handler (LspT c StaticLs) 'Method_TextDocumentDidChange
-> Handlers (LspT c StaticLs)
forall a b. (a -> b) -> a -> b
$ \TNotificationMessage 'Method_TextDocumentDidChange
_ -> () -> LspT c StaticLs ()
forall a. a -> LspT c StaticLs a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

handleDidClose :: Handlers (LspT c StaticLs)
handleDidClose :: forall c. Handlers (LspT c StaticLs)
handleDidClose = SMethod 'Method_TextDocumentDidClose
-> Handler (LspT c StaticLs) 'Method_TextDocumentDidClose
-> Handlers (LspT c StaticLs)
forall (m :: Method 'ClientToServer 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
LSP.notificationHandler SMethod 'Method_TextDocumentDidClose
SMethod_TextDocumentDidClose (Handler (LspT c StaticLs) 'Method_TextDocumentDidClose
 -> Handlers (LspT c StaticLs))
-> Handler (LspT c StaticLs) 'Method_TextDocumentDidClose
-> Handlers (LspT c StaticLs)
forall a b. (a -> b) -> a -> b
$ \TNotificationMessage 'Method_TextDocumentDidClose
_ -> () -> LspT c StaticLs ()
forall a. a -> LspT c StaticLs a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

handleDidSave :: Handlers (LspT c StaticLs)
handleDidSave :: forall c. Handlers (LspT c StaticLs)
handleDidSave = SMethod 'Method_TextDocumentDidSave
-> Handler (LspT c StaticLs) 'Method_TextDocumentDidSave
-> Handlers (LspT c StaticLs)
forall (m :: Method 'ClientToServer 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
LSP.notificationHandler SMethod 'Method_TextDocumentDidSave
SMethod_TextDocumentDidSave (Handler (LspT c StaticLs) 'Method_TextDocumentDidSave
 -> Handlers (LspT c StaticLs))
-> Handler (LspT c StaticLs) 'Method_TextDocumentDidSave
-> Handlers (LspT c StaticLs)
forall a b. (a -> b) -> a -> b
$ \TNotificationMessage 'Method_TextDocumentDidSave
_ -> () -> LspT c StaticLs ()
forall a. a -> LspT c StaticLs a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

handleWorkspaceSymbol :: Handlers (LspT c StaticLs)
handleWorkspaceSymbol :: forall c. Handlers (LspT c StaticLs)
handleWorkspaceSymbol = SMethod 'Method_WorkspaceSymbol
-> Handler (LspT c StaticLs) 'Method_WorkspaceSymbol
-> Handlers (LspT c StaticLs)
forall (m :: Method 'ClientToServer 'Request) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
LSP.requestHandler SMethod 'Method_WorkspaceSymbol
SMethod_WorkspaceSymbol (Handler (LspT c StaticLs) 'Method_WorkspaceSymbol
 -> Handlers (LspT c StaticLs))
-> Handler (LspT c StaticLs) 'Method_WorkspaceSymbol
-> Handlers (LspT c StaticLs)
forall a b. (a -> b) -> a -> b
$ \TRequestMessage 'Method_WorkspaceSymbol
req Either
  ResponseError ([SymbolInformation] |? ([WorkspaceSymbol] |? Null))
-> LspT c StaticLs ()
res -> do
    -- https://hackage.haskell.org/package/lsp-types-1.6.0.0/docs/Language-LSP-Types.html#t:WorkspaceSymbolParams
    [SymbolInformation]
symbols <- StaticLs [SymbolInformation] -> LspT c StaticLs [SymbolInformation]
forall (m :: * -> *) a. Monad m => m a -> LspT c m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Text -> StaticLs [SymbolInformation]
forall (m :: * -> *).
(HasCallStack, HasStaticEnv m, MonadIO m) =>
Text -> m [SymbolInformation]
symbolInfo TRequestMessage 'Method_WorkspaceSymbol
req._params._query)
    Either
  ResponseError ([SymbolInformation] |? ([WorkspaceSymbol] |? Null))
-> LspT c StaticLs ()
res (Either
   ResponseError ([SymbolInformation] |? ([WorkspaceSymbol] |? Null))
 -> LspT c StaticLs ())
-> Either
     ResponseError ([SymbolInformation] |? ([WorkspaceSymbol] |? Null))
-> LspT c StaticLs ()
forall a b. (a -> b) -> a -> b
$ ([SymbolInformation] |? ([WorkspaceSymbol] |? Null))
-> Either
     ResponseError ([SymbolInformation] |? ([WorkspaceSymbol] |? Null))
forall a b. b -> Either a b
Right (([SymbolInformation] |? ([WorkspaceSymbol] |? Null))
 -> Either
      ResponseError ([SymbolInformation] |? ([WorkspaceSymbol] |? Null)))
-> ([SymbolInformation]
    -> [SymbolInformation] |? ([WorkspaceSymbol] |? Null))
-> [SymbolInformation]
-> Either
     ResponseError ([SymbolInformation] |? ([WorkspaceSymbol] |? Null))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SymbolInformation]
-> [SymbolInformation] |? ([WorkspaceSymbol] |? Null)
forall a b. a -> a |? b
InL ([SymbolInformation]
 -> Either
      ResponseError ([SymbolInformation] |? ([WorkspaceSymbol] |? Null)))
-> [SymbolInformation]
-> Either
     ResponseError ([SymbolInformation] |? ([WorkspaceSymbol] |? Null))
forall a b. (a -> b) -> a -> b
$ [SymbolInformation]
symbols

-----------------------------------------------------------------
----------------------- Server definition -----------------------
-----------------------------------------------------------------

data LspEnv config = LspEnv
    { forall config. LspEnv config -> StaticEnv
staticEnv :: StaticEnv
    , forall config. LspEnv config -> LanguageContextEnv config
config :: LanguageContextEnv config
    }

initServer :: StaticEnvOptions -> LanguageContextEnv config -> TMessage 'Method_Initialize -> IO (Either ResponseError (LspEnv config))
initServer :: forall config.
StaticEnvOptions
-> LanguageContextEnv config
-> TMessage 'Method_Initialize
-> IO (Either ResponseError (LspEnv config))
initServer StaticEnvOptions
staticEnvOptions LanguageContextEnv config
serverConfig TMessage 'Method_Initialize
_ = do
    ExceptT ResponseError IO (LspEnv config)
-> IO (Either ResponseError (LspEnv config))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ResponseError IO (LspEnv config)
 -> IO (Either ResponseError (LspEnv config)))
-> ExceptT ResponseError IO (LspEnv config)
-> IO (Either ResponseError (LspEnv config))
forall a b. (a -> b) -> a -> b
$ do
        FilePath
wsRoot <- IO (Either ResponseError FilePath)
-> ExceptT ResponseError IO FilePath
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ResponseError FilePath)
 -> ExceptT ResponseError IO FilePath)
-> IO (Either ResponseError FilePath)
-> ExceptT ResponseError IO FilePath
forall a b. (a -> b) -> a -> b
$ LanguageContextEnv config
-> LspT config IO (Either ResponseError FilePath)
-> IO (Either ResponseError FilePath)
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv config
serverConfig LspT config IO (Either ResponseError FilePath)
forall config. LspM config (Either ResponseError FilePath)
getWsRoot
        StaticEnv
serverStaticEnv <- IO (Either ResponseError StaticEnv)
-> ExceptT ResponseError IO StaticEnv
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ResponseError StaticEnv)
 -> ExceptT ResponseError IO StaticEnv)
-> IO (Either ResponseError StaticEnv)
-> ExceptT ResponseError IO StaticEnv
forall a b. (a -> b) -> a -> b
$ StaticEnv -> Either ResponseError StaticEnv
forall a b. b -> Either a b
Right (StaticEnv -> Either ResponseError StaticEnv)
-> IO StaticEnv -> IO (Either ResponseError StaticEnv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> StaticEnvOptions -> IO StaticEnv
initStaticEnv FilePath
wsRoot StaticEnvOptions
staticEnvOptions
        LspEnv config -> ExceptT ResponseError IO (LspEnv config)
forall a. a -> ExceptT ResponseError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LspEnv config -> ExceptT ResponseError IO (LspEnv config))
-> LspEnv config -> ExceptT ResponseError IO (LspEnv config)
forall a b. (a -> b) -> a -> b
$
            LspEnv
                { $sel:staticEnv:LspEnv :: StaticEnv
staticEnv = StaticEnv
serverStaticEnv
                , $sel:config:LspEnv :: LanguageContextEnv config
config = LanguageContextEnv config
serverConfig
                }
  where
    getWsRoot :: LSP.LspM config (Either ResponseError FilePath)
    getWsRoot :: forall config. LspM config (Either ResponseError FilePath)
getWsRoot = do
        Maybe FilePath
mRootPath <- LspT config IO (Maybe FilePath)
forall config (m :: * -> *).
MonadLsp config m =>
m (Maybe FilePath)
LSP.getRootPath
        Either ResponseError FilePath
-> LspM config (Either ResponseError FilePath)
forall a. a -> LspT config IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError FilePath
 -> LspM config (Either ResponseError FilePath))
-> Either ResponseError FilePath
-> LspM config (Either ResponseError FilePath)
forall a b. (a -> b) -> a -> b
$ case Maybe FilePath
mRootPath of
            Maybe FilePath
Nothing -> ResponseError -> Either ResponseError FilePath
forall a b. a -> Either a b
Left (ResponseError -> Either ResponseError FilePath)
-> ResponseError -> Either ResponseError FilePath
forall a b. (a -> b) -> a -> b
$ (LSPErrorCodes |? ErrorCodes)
-> Text -> Maybe Value -> ResponseError
ResponseError (ErrorCodes -> LSPErrorCodes |? ErrorCodes
forall a b. b -> a |? b
InR ErrorCodes
ErrorCodes_InvalidRequest) Text
"No root workspace was found" Maybe Value
forall a. Maybe a
Nothing
            Just FilePath
p -> FilePath -> Either ResponseError FilePath
forall a b. b -> Either a b
Right FilePath
p

serverDef :: StaticEnvOptions -> ServerDefinition ()
serverDef :: StaticEnvOptions -> ServerDefinition ()
serverDef StaticEnvOptions
argOptions =
    ServerDefinition
        { onConfigChange :: () -> LspT () StaticLs ()
onConfigChange = \()
_conf -> () -> LspT () StaticLs ()
forall a. a -> LspT () StaticLs a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        , configSection :: Text
configSection = Text
""
        , parseConfig :: () -> Value -> Either Text ()
parseConfig = \()
_conf Value
_value -> () -> Either Text ()
forall a b. b -> Either a b
Right ()
        , doInitialize :: LanguageContextEnv ()
-> TMessage 'Method_Initialize
-> IO (Either ResponseError (LspEnv ()))
doInitialize = StaticEnvOptions
-> LanguageContextEnv ()
-> TMessage 'Method_Initialize
-> IO (Either ResponseError (LspEnv ()))
forall config.
StaticEnvOptions
-> LanguageContextEnv config
-> TMessage 'Method_Initialize
-> IO (Either ResponseError (LspEnv config))
initServer StaticEnvOptions
argOptions
        , -- TODO: Do handlers need to inspect clientCapabilities?
          staticHandlers :: ClientCapabilities -> Handlers (LspT () StaticLs)
staticHandlers = \ClientCapabilities
_clientCapabilities ->
            [Handlers (LspT () StaticLs)] -> Handlers (LspT () StaticLs)
forall a. Monoid a => [a] -> a
mconcat
                [ Handlers (LspT () StaticLs)
forall c. Handlers (LspT c StaticLs)
handleInitialized
                , Handlers (LspT () StaticLs)
forall c. Handlers (LspT c StaticLs)
handleChangeConfiguration
                , Handlers (LspT () StaticLs)
forall c. Handlers (LspT c StaticLs)
handleTextDocumentHoverRequest
                , Handlers (LspT () StaticLs)
forall c. Handlers (LspT c StaticLs)
handleDefinitionRequest
                , Handlers (LspT () StaticLs)
forall c. Handlers (LspT c StaticLs)
handleTypeDefinitionRequest
                , Handlers (LspT () StaticLs)
forall c. Handlers (LspT c StaticLs)
handleReferencesRequest
                , Handlers (LspT () StaticLs)
forall c. Handlers (LspT c StaticLs)
handleCancelNotification
                , Handlers (LspT () StaticLs)
forall c. Handlers (LspT c StaticLs)
handleDidOpen
                , Handlers (LspT () StaticLs)
forall c. Handlers (LspT c StaticLs)
handleDidChange
                , Handlers (LspT () StaticLs)
forall c. Handlers (LspT c StaticLs)
handleDidClose
                , Handlers (LspT () StaticLs)
forall c. Handlers (LspT c StaticLs)
handleDidSave
                , Handlers (LspT () StaticLs)
forall c. Handlers (LspT c StaticLs)
handleWorkspaceSymbol
                ]
        , interpretHandler :: LspEnv () -> LspT () StaticLs <~> IO
interpretHandler = \LspEnv ()
env -> (forall a. LspT () StaticLs a -> IO a)
-> (forall a. IO a -> LspT () StaticLs a)
-> LspT () StaticLs <~> IO
forall {k} (m :: k -> *) (n :: k -> *).
(forall (a :: k). m a -> n a)
-> (forall (a :: k). n a -> m a) -> m <~> n
Iso (StaticEnv -> StaticLs a -> IO a
forall a. StaticEnv -> StaticLs a -> IO a
runStaticLs LspEnv ()
env.staticEnv (StaticLs a -> IO a)
-> (LspT () StaticLs a -> StaticLs a) -> LspT () StaticLs a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LanguageContextEnv () -> LspT () StaticLs a -> StaticLs a
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LspEnv ()
env.config) IO a -> LspT () StaticLs a
forall a. IO a -> LspT () StaticLs a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
        , options :: Options
options = Options
LSP.defaultOptions
        , defaultConfig :: ()
defaultConfig = ()
        }

runServer :: StaticEnvOptions -> IO Int
runServer :: StaticEnvOptions -> IO Int
runServer StaticEnvOptions
argOptions = do
    ServerDefinition () -> IO Int
forall config. ServerDefinition config -> IO Int
LSP.runServer (StaticEnvOptions -> ServerDefinition ()
serverDef StaticEnvOptions
argOptions)