Parameterize the haskell-lsp client config type (#416)

So that haskell-language-server can use its own config And separate it out from the IdeConfiguration which is separately set by the InitializeRequest message.
2024-09-11 05:36:09 +03:00 · 2020-02-14 12:21:27 +00:00 · 2020-02-14 12:21:27 +00:00 · 71ecd105d9
commit 71ecd105d9
parent d7715695dc
10 changed files with 73 additions and 52 deletions
--- a/exe/Main.hs
+++ b/exe/Main.hs
@ -89,12 +89,14 @@ main = do
    dir <- getCurrentDirectory

    let plugins = Completions.plugin <> CodeAction.plugin
+        onInitialConfiguration = const $ Right ()
+        onConfigurationChange  = const $ Right ()

    if argLSP then do
        t <- offsetTime
        hPutStrLn stderr "Starting LSP server..."
        hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"
-        runLanguageServer def (pluginHandler plugins) $ \getLspId event vfs caps -> do
+        runLanguageServer def (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps -> do
            t <- t
            hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
            -- very important we only call loadSession once, and it's fast, so just do it before starting
--- a/src/Development/IDE/Core/IdeConfiguration.hs
+++ b/src/Development/IDE/Core/IdeConfiguration.hs
@ -36,8 +36,8 @@ getIdeConfiguration :: Action IdeConfiguration
 getIdeConfiguration =
  getIdeGlobalAction >>= liftIO . readVar . unIdeConfigurationRef

-parseConfiguration :: InitializeRequest -> IdeConfiguration
-parseConfiguration RequestMessage { _params = InitializeParams {..} } =
+parseConfiguration :: InitializeParams -> IdeConfiguration
+parseConfiguration InitializeParams {..} =
  IdeConfiguration { .. }
 where
  workspaceFolders =
--- a/src/Development/IDE/LSP/HoverDefinition.hs
+++ b/src/Development/IDE/LSP/HoverDefinition.hs
@ -29,7 +29,7 @@ foundHover :: (Maybe Range, [T.Text]) -> Maybe Hover
 foundHover (mbRange, contents) =
  Just $ Hover (HoverContents $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator contents) mbRange

-setHandlersDefinition, setHandlersHover :: PartialHandlers
+setHandlersDefinition, setHandlersHover :: PartialHandlers c
 setHandlersDefinition = PartialHandlers $ \WithMessage{..} x ->
  return x{LSP.definitionHandler = withResponse RspDefinition $ const gotoDefinition}
 setHandlersHover      = PartialHandlers $ \WithMessage{..} x ->
--- a/src/Development/IDE/LSP/LanguageServer.hs
+++ b/src/Development/IDE/LSP/LanguageServer.hs
@ -39,11 +39,14 @@ import Language.Haskell.LSP.Core (LspFuncs(..))
 import Language.Haskell.LSP.Messages

 runLanguageServer
-    :: LSP.Options
-    -> PartialHandlers
+    :: forall config. (Show config)
+    => LSP.Options
+    -> PartialHandlers config
+    -> (InitializeRequest -> Either T.Text config)
+    -> (DidChangeConfigurationNotification -> Either T.Text config)
    -> (IO LspId -> (FromServerMessage -> IO ()) -> VFSHandle -> ClientCapabilities -> IO IdeState)
    -> IO ()
-runLanguageServer options userHandlers getIdeState = do
+runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeState = do
    -- Move stdout to another file descriptor and duplicate stderr
    -- to stdout. This guards against stray prints from corrupting the JSON-RPC
    -- message stream.
@ -60,7 +63,7 @@ runLanguageServer options userHandlers getIdeState = do

    -- Send everything over a channel, since you need to wait until after initialise before
    -- LspFuncs is available
-    clientMsgChan :: Chan Message <- newChan
+    clientMsgChan :: Chan (Message config) <- newChan

    -- These barriers are signaled when the threads reading from these chans exit.
    -- This should not happen but if it does, we will make sure that the whole server
@ -79,6 +82,7 @@ runLanguageServer options userHandlers getIdeState = do
    let withResponseAndRequest wrap wrapNewReq f = Just $ \r@RequestMessage{_id} -> do
            atomically $ modifyTVar pendingRequests (Set.insert _id)
            writeChan clientMsgChan $ ResponseAndRequest r wrap wrapNewReq f
+    let withInitialize f = Just $ \r -> writeChan clientMsgChan $ InitialParams r (\lsp ide x -> f lsp ide x)
    let cancelRequest reqId = atomically $ do
            queued <- readTVar pendingRequests
            -- We want to avoid that the list of cancelled requests
@ -95,6 +99,7 @@ runLanguageServer options userHandlers getIdeState = do
            cancelled <- readTVar cancelledRequests
            unless (reqId `Set.member` cancelled) retry
    let PartialHandlers parts =
+            initializeRequestHandler <>
            setHandlersIgnore <> -- least important
            setHandlersDefinition <> setHandlersHover <>
            setHandlersOutline <>
@ -103,11 +108,11 @@ runLanguageServer options userHandlers getIdeState = do
            cancelHandler cancelRequest
            -- Cancel requests are special since they need to be handled
            -- out of order to be useful. Existing handlers are run afterwards.
-    handlers <- parts WithMessage{withResponse, withNotification, withResponseAndRequest} def
+    handlers <- parts WithMessage{withResponse, withNotification, withResponseAndRequest, withInitialize} def

    let initializeCallbacks = LSP.InitializeCallbacks
-            { LSP.onInitialConfiguration = Right . parseConfiguration
-            , LSP.onConfigurationChange = const $ Left "Configuration changes not supported yet"
+            { LSP.onInitialConfiguration = onInitialConfig
+            , LSP.onConfigurationChange = onConfigChange
            , LSP.onStartup = handleInit (signalBarrier clientMsgBarrier ()) clearReqId waitForCancel clientMsgChan
            }

@ -122,13 +127,11 @@ runLanguageServer options userHandlers getIdeState = do
        , void $ waitBarrier clientMsgBarrier
        ]
    where
-        handleInit :: IO () -> (LspId -> IO ()) -> (LspId -> IO ()) -> Chan Message -> LSP.LspFuncs IdeConfiguration -> IO (Maybe err)
+        handleInit :: IO () -> (LspId -> IO ()) -> (LspId -> IO ()) -> Chan (Message config) -> LSP.LspFuncs config -> IO (Maybe err)
        handleInit exitClientMsg clearReqId waitForCancel clientMsgChan lspFuncs@LSP.LspFuncs{..} = do

            ide <- getIdeState getNextReqId sendFunc (makeLSPVFSHandle lspFuncs) clientCapabilities

-            mapM_ (registerIdeConfiguration (shakeExtras ide)) =<< config
-
            _ <- flip forkFinally (const exitClientMsg) $ forever $ do
                msg <- readChan clientMsgChan
                case msg of
@ -152,6 +155,12 @@ runLanguageServer options userHandlers getIdeState = do
                                Just (rm, newReqParams) -> do
                                    reqId <- getNextReqId
                                    sendFunc $ wrapNewReq $ RequestMessage "2.0" reqId rm newReqParams
+                    InitialParams x@RequestMessage{_id, _params} act -> do
+                        catch (act lspFuncs ide _params) $ \(e :: SomeException) ->
+                            logError (ideLogger ide) $ T.pack $
+                                "Unexpected exception on InitializeRequest handler, please report!\n" ++
+                                "Message: " ++ show x ++ "\n" ++
+                                "Exception: " ++ show e
            pure Nothing

        checkCancelled ide clearReqId waitForCancel lspFuncs@LSP.LspFuncs{..} wrap act msg _id _params k =
@ -177,17 +186,28 @@ runLanguageServer options userHandlers getIdeState = do
                    sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $
                        Just $ ResponseError InternalError (T.pack $ show e) Nothing

+initializeRequestHandler :: PartialHandlers config
+initializeRequestHandler = PartialHandlers $ \WithMessage{..} x -> return x{
+    LSP.initializeRequestHandler = withInitialize initHandler
+    }
+
+initHandler
+    :: LSP.LspFuncs c
+    -> IdeState
+    -> InitializeParams
+    -> IO ()
+initHandler _ ide params = registerIdeConfiguration (shakeExtras ide) (parseConfiguration params)

 -- | Things that get sent to us, but we don't deal with.
 --   Set them to avoid a warning in VS Code output.
-setHandlersIgnore :: PartialHandlers
+setHandlersIgnore :: PartialHandlers config
 setHandlersIgnore = PartialHandlers $ \_ x -> return x
    {LSP.initializedHandler = none
    ,LSP.responseHandler = none
    }
    where none = Just $ const $ return ()

-cancelHandler :: (LspId -> IO ()) -> PartialHandlers
+cancelHandler :: (LspId -> IO ()) -> PartialHandlers config
 cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x
    {LSP.cancelNotificationHandler = Just $ \msg@NotificationMessage {_params = CancelParams {_id}} -> do
            cancelRequest _id
@ -197,14 +217,15 @@ cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x

 -- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety
 --   and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer)
-data Message
-    = forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs IdeConfiguration -> IdeState -> req -> IO (Either ResponseError resp))
+data Message c
+    = forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp))
    -- | Used for cases in which we need to send not only a response,
    --   but also an additional request to the client.
    --   For example, 'executeCommand' may generate an 'applyWorkspaceEdit' request.
-    | forall m rm req resp newReqParams newReqBody . (Show m, Show rm, Show req) => ResponseAndRequest (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (RequestMessage rm newReqParams newReqBody -> FromServerMessage) (LSP.LspFuncs IdeConfiguration -> IdeState -> req -> IO (resp, Maybe (rm, newReqParams)))
-    | forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (LSP.LspFuncs IdeConfiguration -> IdeState -> req -> IO ())
-
+    | forall m rm req resp newReqParams newReqBody . (Show m, Show rm, Show req) => ResponseAndRequest (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (RequestMessage rm newReqParams newReqBody -> FromServerMessage) (LSP.LspFuncs c -> IdeState -> req -> IO (resp, Maybe (rm, newReqParams)))
+    | forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (LSP.LspFuncs c -> IdeState -> req -> IO ())
+    -- | Used for the InitializeRequest only, where the response is generated by the LSP core handler.
+    | InitialParams InitializeRequest (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ())

 modifyOptions :: LSP.Options -> LSP.Options
 modifyOptions x = x{ LSP.textDocumentSync   = Just $ tweakTDS origTDS
--- a/src/Development/IDE/LSP/Notifications.hs
+++ b/src/Development/IDE/LSP/Notifications.hs
@ -32,7 +32,7 @@ import           Development.IDE.Core.OfInterest
 whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()
 whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath

-setHandlersNotifications :: PartialHandlers
+setHandlersNotifications :: PartialHandlers c
 setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x
    {LSP.didOpenTextDocumentNotificationHandler = withNotification (LSP.didOpenTextDocumentNotificationHandler x) $
        \_ ide (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> do
@ -70,6 +70,7 @@ setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x
            logInfo (ideLogger ide) $ "Files created or deleted: " <> msg
            modifyFileExists ide events
            setSomethingModified ide
+
    ,LSP.didChangeWorkspaceFoldersNotificationHandler = withNotification (LSP.didChangeWorkspaceFoldersNotificationHandler x) $
        \_ ide (DidChangeWorkspaceFoldersParams events) -> do
            let add       = S.union
--- a/src/Development/IDE/LSP/Outline.hs
+++ b/src/Development/IDE/LSP/Outline.hs
@ -18,7 +18,6 @@ import           Data.Text                      ( Text
                                                )
 import qualified Data.Text                     as T
 import           Development.IDE.Core.Rules
-import           Development.IDE.Core.IdeConfiguration
 import           Development.IDE.Core.Shake
 import           Development.IDE.GHC.Compat
 import           Development.IDE.GHC.Error      ( srcSpanToRange )
@ -29,13 +28,13 @@ import           Outputable                     ( Outputable
                                                , showSDocUnsafe
                                                )

-setHandlersOutline :: PartialHandlers
+setHandlersOutline :: PartialHandlers c
 setHandlersOutline = PartialHandlers $ \WithMessage {..} x -> return x
  { LSP.documentSymbolHandler = withResponse RspDocumentSymbols moduleOutline
  }

 moduleOutline
-  :: LSP.LspFuncs IdeConfiguration -> IdeState -> DocumentSymbolParams -> IO (Either ResponseError DSResult)
+  :: LSP.LspFuncs c -> IdeState -> DocumentSymbolParams -> IO (Either ResponseError DSResult)
 moduleOutline _lsp ideState DocumentSymbolParams { _textDocument = TextDocumentIdentifier uri }
  = case uriToFilePath uri of
    Just (toNormalizedFilePath -> fp) -> do
--- a/src/Development/IDE/LSP/Server.hs
+++ b/src/Development/IDE/LSP/Server.hs
@ -14,33 +14,34 @@ import Data.Default
 import           Language.Haskell.LSP.Types
 import qualified Language.Haskell.LSP.Core as LSP
 import qualified Language.Haskell.LSP.Messages as LSP
-import Development.IDE.Core.IdeConfiguration
 import Development.IDE.Core.Service

-data WithMessage = WithMessage
+data WithMessage c = WithMessage
    {withResponse :: forall m req resp . (Show m, Show req) =>
        (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response
-        (LSP.LspFuncs IdeConfiguration -> IdeState -> req -> IO (Either ResponseError resp)) -> -- actual work
+        (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp)) -> -- actual work
        Maybe (LSP.Handler (RequestMessage m req resp))
    ,withNotification :: forall m req . (Show m, Show req) =>
        Maybe (LSP.Handler (NotificationMessage m req)) -> -- old notification handler
-        (LSP.LspFuncs IdeConfiguration -> IdeState -> req -> IO ()) -> -- actual work
+        (LSP.LspFuncs c -> IdeState -> req -> IO ()) -> -- actual work
        Maybe (LSP.Handler (NotificationMessage m req))
-    ,withResponseAndRequest :: forall m rm req resp newReqParams newReqBody.
+    ,withResponseAndRequest :: forall m rm req resp newReqParams newReqBody .
        (Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
        (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response
        (RequestMessage rm newReqParams newReqBody -> LSP.FromServerMessage) -> -- how to wrap the additional req
-        (LSP.LspFuncs IdeConfiguration -> IdeState -> req -> IO (resp, Maybe (rm, newReqParams))) -> -- actual work
+        (LSP.LspFuncs c -> IdeState -> req -> IO (resp, Maybe (rm, newReqParams))) -> -- actual work
        Maybe (LSP.Handler (RequestMessage m req resp))
+    , withInitialize :: (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ())
+                     -> Maybe (LSP.Handler InitializeRequest)
    }

-newtype PartialHandlers = PartialHandlers (WithMessage -> LSP.Handlers -> IO LSP.Handlers)
+newtype PartialHandlers c = PartialHandlers (WithMessage c -> LSP.Handlers -> IO LSP.Handlers)

-instance Default PartialHandlers where
+instance Default (PartialHandlers c) where
    def = PartialHandlers $ \_ x -> pure x

-instance Semigroup PartialHandlers where
+instance Semigroup (PartialHandlers c) where
    PartialHandlers a <> PartialHandlers b = PartialHandlers $ \w x -> a w x >>= b w

-instance Monoid PartialHandlers where
+instance Monoid (PartialHandlers c) where
    mempty = def
--- a/src/Development/IDE/Plugin.hs
+++ b/src/Development/IDE/Plugin.hs
@ -7,27 +7,26 @@ import Development.IDE.LSP.Server

 import           Language.Haskell.LSP.Types
 import Development.IDE.Core.Rules
-import           Development.IDE.Core.IdeConfiguration
 import qualified Language.Haskell.LSP.Core as LSP
 import Language.Haskell.LSP.Messages


-data Plugin = Plugin
+data Plugin c = Plugin
    {pluginRules :: Rules ()
-    ,pluginHandler :: PartialHandlers
+    ,pluginHandler :: PartialHandlers c
    }

-instance Default Plugin where
+instance Default (Plugin c) where
    def = Plugin mempty def

-instance Semigroup Plugin where
+instance Semigroup (Plugin c) where
    Plugin x1 y1 <> Plugin x2 y2 = Plugin (x1<>x2) (y1<>y2)

-instance Monoid Plugin where
+instance Monoid (Plugin c) where
    mempty = def


-codeActionPlugin :: (LSP.LspFuncs IdeConfiguration -> IdeState -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO (Either ResponseError [CAResult])) -> Plugin
+codeActionPlugin :: (LSP.LspFuncs c -> IdeState -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO (Either ResponseError [CAResult])) -> Plugin c
 codeActionPlugin f = Plugin mempty $ PartialHandlers $ \WithMessage{..} x -> return x{
    LSP.codeActionHandler = withResponse RspCodeAction g
    }
--- a/src/Development/IDE/Plugin/CodeAction.hs
+++ b/src/Development/IDE/Plugin/CodeAction.hs
@ -12,7 +12,6 @@ import           Language.Haskell.LSP.Types
 import Control.Monad (join)
 import Development.IDE.Plugin
 import Development.IDE.GHC.Compat
-import Development.IDE.Core.IdeConfiguration
 import Development.IDE.Core.Rules
 import Development.IDE.Core.RuleTypes
 import Development.IDE.Core.Service
@ -39,12 +38,12 @@ import Outputable (ppr, showSDocUnsafe)
 import DynFlags (xFlags, FlagSpec(..))
 import GHC.LanguageExtensions.Type (Extension)

-plugin :: Plugin
+plugin :: Plugin c
 plugin = codeActionPlugin codeAction <> Plugin mempty setHandlersCodeLens

 -- | Generate code actions.
 codeAction
-    :: LSP.LspFuncs IdeConfiguration
+    :: LSP.LspFuncs c
    -> IdeState
    -> TextDocumentIdentifier
    -> Range
@ -66,7 +65,7 @@ codeAction lsp state (TextDocumentIdentifier uri) _range CodeActionContext{_diag

 -- | Generate code lenses.
 codeLens
-    :: LSP.LspFuncs IdeConfiguration
+    :: LSP.LspFuncs c
    -> IdeState
    -> CodeLensParams
    -> IO (Either ResponseError (List CodeLens))
@ -87,7 +86,7 @@ codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri}

 -- | Execute the "typesignature.add" command.
 executeAddSignatureCommand
-    :: LSP.LspFuncs IdeConfiguration
+    :: LSP.LspFuncs c
    -> IdeState
    -> ExecuteCommandParams
    -> IO (Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))
@ -445,7 +444,7 @@ matchRegex message regex = case unifySpaces message =~~ regex of
    Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings
    Nothing -> Nothing

-setHandlersCodeLens :: PartialHandlers
+setHandlersCodeLens :: PartialHandlers c
 setHandlersCodeLens = PartialHandlers $ \WithMessage{..} x -> return x{
    LSP.codeLensHandler = withResponse RspCodeLens codeLens,
    LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit executeAddSignatureCommand
--- a/src/Development/IDE/Plugin/Completions.hs
+++ b/src/Development/IDE/Plugin/Completions.hs
@ -17,7 +17,6 @@ import Development.IDE.Plugin
 import Development.IDE.Core.Service
 import Development.IDE.Plugin.Completions.Logic
 import Development.IDE.Types.Location
-import Development.IDE.Core.IdeConfiguration
 import Development.IDE.Core.PositionMapping
 import Development.IDE.Core.RuleTypes
 import Development.IDE.Core.Shake
@ -26,7 +25,7 @@ import Development.IDE.LSP.Server
 import Development.IDE.Import.DependencyInformation


-plugin :: Plugin
+plugin :: Plugin c
 plugin = Plugin produceCompletions setHandlersCompletion

 produceCompletions :: Rules ()
@ -56,7 +55,7 @@ instance Binary   ProduceCompletions

 -- | Generate code actions.
 getCompletionsLSP
-    :: LSP.LspFuncs IdeConfiguration
+    :: LSP.LspFuncs c
    -> IdeState
    -> CompletionParams
    -> IO (Either ResponseError CompletionResponseResult)
@ -83,7 +82,7 @@ getCompletionsLSP lsp ide
          _ -> return (Completions $ List [])
      _ -> return (Completions $ List [])

-setHandlersCompletion :: PartialHandlers
+setHandlersCompletion :: PartialHandlers c
 setHandlersCompletion = PartialHandlers $ \WithMessage{..} x -> return x{
    LSP.completionHandler = withResponse RspCompletion getCompletionsLSP
    }