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.

Author: alanz

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

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 =

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

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

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

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

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

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
     }

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

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
     }