{-# LANGUAGE DataKinds #-} {-# LANGUAGE ExplicitNamespaces #-} module StaticLS.Server where import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Class import Control.Monad.Trans.Except import Language.LSP.Server ( Handlers, LanguageContextEnv, LspT, ServerDefinition (..), type (<~>) (Iso), ) import qualified Language.LSP.Server as LSP import Language.LSP.Types import StaticLS.IDE.Definition import StaticLS.IDE.Hover import StaticLS.IDE.References import StaticLS.StaticEnv import StaticLS.StaticEnv.Options data LspEnv config = LspEnv { forall config. LspEnv config -> StaticEnv staticEnv :: StaticEnv , forall config. LspEnv config -> LanguageContextEnv config config :: LanguageContextEnv config } handleChangeConfiguration :: Handlers (LspT c StaticLs) handleChangeConfiguration :: forall c. Handlers (LspT c StaticLs) handleChangeConfiguration = SMethod 'WorkspaceDidChangeConfiguration -> Handler (LspT c StaticLs) 'WorkspaceDidChangeConfiguration -> Handlers (LspT c StaticLs) forall (m :: Method 'FromClient 'Notification) (f :: * -> *). SMethod m -> Handler f m -> Handlers f LSP.notificationHandler SMethod 'WorkspaceDidChangeConfiguration SWorkspaceDidChangeConfiguration (Handler (LspT c StaticLs) 'WorkspaceDidChangeConfiguration -> Handlers (LspT c StaticLs)) -> Handler (LspT c StaticLs) 'WorkspaceDidChangeConfiguration -> Handlers (LspT c StaticLs) forall a b. (a -> b) -> a -> b $ LspT c StaticLs () -> NotificationMessage 'WorkspaceDidChangeConfiguration -> LspT c StaticLs () forall a. a -> NotificationMessage 'WorkspaceDidChangeConfiguration -> a forall (f :: * -> *) a. Applicative f => a -> f a pure (LspT c StaticLs () -> NotificationMessage 'WorkspaceDidChangeConfiguration -> LspT c StaticLs ()) -> LspT c StaticLs () -> NotificationMessage '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 'Initialized -> Handler (LspT c StaticLs) 'Initialized -> Handlers (LspT c StaticLs) forall (m :: Method 'FromClient 'Notification) (f :: * -> *). SMethod m -> Handler f m -> Handlers f LSP.notificationHandler SMethod 'Initialized SInitialized (Handler (LspT c StaticLs) 'Initialized -> Handlers (LspT c StaticLs)) -> Handler (LspT c StaticLs) 'Initialized -> Handlers (LspT c StaticLs) forall a b. (a -> b) -> a -> b $ LspT c StaticLs () -> NotificationMessage 'Initialized -> LspT c StaticLs () forall a. a -> NotificationMessage 'Initialized -> a forall (f :: * -> *) a. Applicative f => a -> f a pure (LspT c StaticLs () -> NotificationMessage 'Initialized -> LspT c StaticLs ()) -> LspT c StaticLs () -> NotificationMessage '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 'TextDocumentHover -> Handler (LspT c StaticLs) 'TextDocumentHover -> Handlers (LspT c StaticLs) forall (m :: Method 'FromClient 'Request) (f :: * -> *). SMethod m -> Handler f m -> Handlers f LSP.requestHandler SMethod 'TextDocumentHover STextDocumentHover (Handler (LspT c StaticLs) 'TextDocumentHover -> Handlers (LspT c StaticLs)) -> Handler (LspT c StaticLs) 'TextDocumentHover -> Handlers (LspT c StaticLs) forall a b. (a -> b) -> a -> b $ \RequestMessage 'TextDocumentHover req Either ResponseError (Maybe Hover) -> LspT c StaticLs () resp -> do let hoverParams :: MessageParams 'TextDocumentHover hoverParams = RequestMessage '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 'TextDocumentHover hoverParams._textDocument MessageParams 'TextDocumentHover hoverParams._position Either ResponseError (Maybe Hover) -> LspT c StaticLs () resp (Maybe Hover -> Either ResponseError (Maybe Hover) forall a b. b -> Either a b Right Maybe Hover hover) handleDefinitionRequest :: Handlers (LspT c StaticLs) handleDefinitionRequest :: forall c. Handlers (LspT c StaticLs) handleDefinitionRequest = SMethod 'TextDocumentDefinition -> Handler (LspT c StaticLs) 'TextDocumentDefinition -> Handlers (LspT c StaticLs) forall (m :: Method 'FromClient 'Request) (f :: * -> *). SMethod m -> Handler f m -> Handlers f LSP.requestHandler SMethod 'TextDocumentDefinition STextDocumentDefinition (Handler (LspT c StaticLs) 'TextDocumentDefinition -> Handlers (LspT c StaticLs)) -> Handler (LspT c StaticLs) 'TextDocumentDefinition -> Handlers (LspT c StaticLs) forall a b. (a -> b) -> a -> b $ \RequestMessage 'TextDocumentDefinition req Either ResponseError (Location |? (List Location |? List LocationLink)) -> LspT c StaticLs () res -> do let defParams :: MessageParams 'TextDocumentDefinition defParams = RequestMessage 'TextDocumentDefinition req._params [Location] defs <- 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 :: * -> *). (HasCallStack, HasStaticEnv m, MonadIO m) => TextDocumentIdentifier -> Position -> m [Location] getDefinition MessageParams 'TextDocumentDefinition defParams._textDocument MessageParams 'TextDocumentDefinition defParams._position Either ResponseError (Location |? (List Location |? List LocationLink)) -> LspT c StaticLs () res (Either ResponseError (Location |? (List Location |? List LocationLink)) -> LspT c StaticLs ()) -> Either ResponseError (Location |? (List Location |? List LocationLink)) -> LspT c StaticLs () forall a b. (a -> b) -> a -> b $ (Location |? (List Location |? List LocationLink)) -> Either ResponseError (Location |? (List Location |? List LocationLink)) forall a b. b -> Either a b Right ((Location |? (List Location |? List LocationLink)) -> Either ResponseError (Location |? (List Location |? List LocationLink))) -> ([Location] -> Location |? (List Location |? List LocationLink)) -> [Location] -> Either ResponseError (Location |? (List Location |? List LocationLink)) forall b c a. (b -> c) -> (a -> b) -> a -> c . (List Location |? List LocationLink) -> Location |? (List Location |? List LocationLink) forall a b. b -> a |? b InR ((List Location |? List LocationLink) -> Location |? (List Location |? List LocationLink)) -> ([Location] -> List Location |? List LocationLink) -> [Location] -> Location |? (List Location |? List LocationLink) forall b c a. (b -> c) -> (a -> b) -> a -> c . List Location -> List Location |? List LocationLink forall a b. a -> a |? b InL (List Location -> List Location |? List LocationLink) -> ([Location] -> List Location) -> [Location] -> List Location |? List LocationLink forall b c a. (b -> c) -> (a -> b) -> a -> c . [Location] -> List Location forall a. [a] -> List a List ([Location] -> Either ResponseError (Location |? (List Location |? List LocationLink))) -> [Location] -> Either ResponseError (Location |? (List Location |? List LocationLink)) forall a b. (a -> b) -> a -> b $ [Location] defs handleReferencesRequest :: Handlers (LspT c StaticLs) handleReferencesRequest :: forall c. Handlers (LspT c StaticLs) handleReferencesRequest = SMethod 'TextDocumentReferences -> Handler (LspT c StaticLs) 'TextDocumentReferences -> Handlers (LspT c StaticLs) forall (m :: Method 'FromClient 'Request) (f :: * -> *). SMethod m -> Handler f m -> Handlers f LSP.requestHandler SMethod 'TextDocumentReferences STextDocumentReferences (Handler (LspT c StaticLs) 'TextDocumentReferences -> Handlers (LspT c StaticLs)) -> Handler (LspT c StaticLs) 'TextDocumentReferences -> Handlers (LspT c StaticLs) forall a b. (a -> b) -> a -> b $ \RequestMessage 'TextDocumentReferences req Either ResponseError (List Location) -> LspT c StaticLs () res -> do let refParams :: MessageParams 'TextDocumentReferences refParams = RequestMessage '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 'TextDocumentReferences refParams._textDocument MessageParams 'TextDocumentReferences refParams._position Either ResponseError (List Location) -> LspT c StaticLs () res (Either ResponseError (List Location) -> LspT c StaticLs ()) -> Either ResponseError (List Location) -> LspT c StaticLs () forall a b. (a -> b) -> a -> b $ List Location -> Either ResponseError (List Location) forall a b. b -> Either a b Right (List Location -> Either ResponseError (List Location)) -> ([Location] -> List Location) -> [Location] -> Either ResponseError (List Location) forall b c a. (b -> c) -> (a -> b) -> a -> c . [Location] -> List Location forall a. [a] -> List a List ([Location] -> Either ResponseError (List Location)) -> [Location] -> Either ResponseError (List Location) forall a b. (a -> b) -> a -> b $ [Location] refs handleCancelNotification :: Handlers (LspT c StaticLs) handleCancelNotification :: forall c. Handlers (LspT c StaticLs) handleCancelNotification = SMethod 'CancelRequest -> Handler (LspT c StaticLs) 'CancelRequest -> Handlers (LspT c StaticLs) forall (m :: Method 'FromClient 'Notification) (f :: * -> *). SMethod m -> Handler f m -> Handlers f LSP.notificationHandler SMethod 'CancelRequest forall {f :: From}. SMethod 'CancelRequest SCancelRequest (Handler (LspT c StaticLs) 'CancelRequest -> Handlers (LspT c StaticLs)) -> Handler (LspT c StaticLs) 'CancelRequest -> Handlers (LspT c StaticLs) forall a b. (a -> b) -> a -> b $ \NotificationMessage '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 'TextDocumentDidOpen -> Handler (LspT c StaticLs) 'TextDocumentDidOpen -> Handlers (LspT c StaticLs) forall (m :: Method 'FromClient 'Notification) (f :: * -> *). SMethod m -> Handler f m -> Handlers f LSP.notificationHandler SMethod 'TextDocumentDidOpen STextDocumentDidOpen (Handler (LspT c StaticLs) 'TextDocumentDidOpen -> Handlers (LspT c StaticLs)) -> Handler (LspT c StaticLs) 'TextDocumentDidOpen -> Handlers (LspT c StaticLs) forall a b. (a -> b) -> a -> b $ \NotificationMessage '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 'TextDocumentDidChange -> Handler (LspT c StaticLs) 'TextDocumentDidChange -> Handlers (LspT c StaticLs) forall (m :: Method 'FromClient 'Notification) (f :: * -> *). SMethod m -> Handler f m -> Handlers f LSP.notificationHandler SMethod 'TextDocumentDidChange STextDocumentDidChange (Handler (LspT c StaticLs) 'TextDocumentDidChange -> Handlers (LspT c StaticLs)) -> Handler (LspT c StaticLs) 'TextDocumentDidChange -> Handlers (LspT c StaticLs) forall a b. (a -> b) -> a -> b $ \NotificationMessage '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 'TextDocumentDidClose -> Handler (LspT c StaticLs) 'TextDocumentDidClose -> Handlers (LspT c StaticLs) forall (m :: Method 'FromClient 'Notification) (f :: * -> *). SMethod m -> Handler f m -> Handlers f LSP.notificationHandler SMethod 'TextDocumentDidClose STextDocumentDidClose (Handler (LspT c StaticLs) 'TextDocumentDidClose -> Handlers (LspT c StaticLs)) -> Handler (LspT c StaticLs) 'TextDocumentDidClose -> Handlers (LspT c StaticLs) forall a b. (a -> b) -> a -> b $ \NotificationMessage '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 'TextDocumentDidSave -> Handler (LspT c StaticLs) 'TextDocumentDidSave -> Handlers (LspT c StaticLs) forall (m :: Method 'FromClient 'Notification) (f :: * -> *). SMethod m -> Handler f m -> Handlers f LSP.notificationHandler SMethod 'TextDocumentDidSave STextDocumentDidSave (Handler (LspT c StaticLs) 'TextDocumentDidSave -> Handlers (LspT c StaticLs)) -> Handler (LspT c StaticLs) 'TextDocumentDidSave -> Handlers (LspT c StaticLs) forall a b. (a -> b) -> a -> b $ \NotificationMessage 'TextDocumentDidSave _ -> () -> LspT c StaticLs () forall a. a -> LspT c StaticLs a forall (f :: * -> *) a. Applicative f => a -> f a pure () initServer :: LanguageContextEnv config -> Message 'Initialize -> IO (Either ResponseError (LspEnv config)) initServer :: forall config. LanguageContextEnv config -> Message 'Initialize -> IO (Either ResponseError (LspEnv config)) initServer LanguageContextEnv config serverConfig Message '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 defaultStaticEnvOptions 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 $ ErrorCode -> Text -> Maybe Value -> ResponseError ResponseError ErrorCode 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 :: ServerDefinition () serverDef :: ServerDefinition () serverDef = ServerDefinition { onConfigurationChange :: () -> Value -> Either Text () onConfigurationChange = \() conf Value _ -> () -> Either Text () forall a b. b -> Either a b Right () conf , doInitialize :: LanguageContextEnv () -> Message 'Initialize -> IO (Either ResponseError (LspEnv ())) doInitialize = LanguageContextEnv () -> Message 'Initialize -> IO (Either ResponseError (LspEnv ())) forall config. LanguageContextEnv config -> Message 'Initialize -> IO (Either ResponseError (LspEnv config)) initServer , staticHandlers :: Handlers (LspT () StaticLs) staticHandlers = [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) 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 ] , 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 :: IO Int runServer :: IO Int runServer = do ServerDefinition () -> IO Int forall config. ServerDefinition config -> IO Int LSP.runServer ServerDefinition () serverDef