From 0385fe0a09bf10b547939910299f238c7c4c08c9 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Sat, 20 Feb 2021 17:24:41 +0530 Subject: [PATCH 1/4] Parse config from initializeOptions and pass in the old value of config to onConfigurationChange --- example/Reactor.hs | 19 ++++++++++++------- example/Simple.hs | 3 ++- src/Language/LSP/Server/Core.hs | 13 ++++++++----- src/Language/LSP/Server/Processing.hs | 17 ++++++++++------- 4 files changed, 32 insertions(+), 20 deletions(-) diff --git a/example/Reactor.hs b/example/Reactor.hs index 54971d096..fad4af19b 100644 --- a/example/Reactor.hs +++ b/example/Reactor.hs @@ -59,7 +59,7 @@ main = do -- --------------------------------------------------------------------- data Config = Config { fooTheBar :: Bool, wibbleFactor :: Int } - deriving (Generic, J.ToJSON, J.FromJSON) + deriving (Generic, J.ToJSON, J.FromJSON, Show) run :: IO Int run = flip E.catches handlers $ do @@ -68,12 +68,11 @@ run = flip E.catches handlers $ do let serverDefinition = ServerDefinition - { onConfigurationChange = \v -> case J.fromJSON v of - J.Error e -> pure $ Left (T.pack e) - J.Success cfg -> do - sendNotification J.SWindowShowMessage $ - J.ShowMessageParams J.MtInfo $ "Wibble factor set to " <> T.pack (show (wibbleFactor cfg)) - pure $ Right cfg + { defaultConfig = Config {fooTheBar = False, wibbleFactor = 0 } + , onConfigurationChange = \_old v -> do + case J.fromJSON v of + J.Error e -> Left (T.pack e) + J.Success cfg -> Right cfg , doInitialize = \env _ -> forkIO (reactor rin) >> pure (Right env) , staticHandlers = lspHandlers rin , interpretHandler = \env -> Iso (runLspT env) liftIO @@ -196,6 +195,12 @@ handle = mconcat liftIO $ debugM "reactor.handle" $ "Processing DidOpenTextDocument for: " ++ show fileName sendDiagnostics (J.toNormalizedUri doc) (Just 0) + , notificationHandler J.SWorkspaceDidChangeConfiguration $ \msg -> do + cfg <- getConfig + liftIO $ debugM "configuration changed: " (show (msg,cfg)) + sendNotification J.SWindowShowMessage $ + J.ShowMessageParams J.MtInfo $ "Wibble factor set to " <> T.pack (show (wibbleFactor cfg)) + , notificationHandler J.STextDocumentDidChange $ \msg -> do let doc = msg ^. J.params . J.textDocument diff --git a/example/Simple.hs b/example/Simple.hs index ea6294daa..2963b7458 100644 --- a/example/Simple.hs +++ b/example/Simple.hs @@ -36,7 +36,8 @@ handlers = mconcat main :: IO Int main = runServer $ ServerDefinition - { onConfigurationChange = const $ pure $ Right () + { onConfigurationChange = const $ const $ Right () + , defaultConfig = () , doInitialize = \env _req -> pure $ Right env , staticHandlers = handlers , interpretHandler = \env -> Iso (runLspT env) liftIO diff --git a/src/Language/LSP/Server/Core.hs b/src/Language/LSP/Server/Core.hs index 4c9556fdd..39b10cb88 100644 --- a/src/Language/LSP/Server/Core.hs +++ b/src/Language/LSP/Server/Core.hs @@ -97,7 +97,7 @@ instance MonadLsp c m => MonadLsp c (IdentityT m) where data LanguageContextEnv config = LanguageContextEnv { resHandlers :: !(Handlers IO) - , resParseConfig :: !(J.Value -> IO (Either T.Text config)) + , resParseConfig :: !(config -> J.Value -> (Either T.Text config)) , resSendMessage :: !(FromServerMessage -> IO ()) -- We keep the state in a TVar to be thread safe , resState :: !(TVar (LanguageContextState config)) @@ -168,7 +168,7 @@ data LanguageContextState config = LanguageContextState { resVFS :: !VFSData , resDiagnostics :: !DiagnosticStore - , resConfig :: !(Maybe config) + , resConfig :: !config , resWorkspaceFolders :: ![WorkspaceFolder] , resProgressData :: !ProgressData , resPendingResponses :: !ResponseMap @@ -274,12 +274,15 @@ data ProgressCancellable = Cancellable | NotCancellable -- specific configuration data the language server needs to use. data ServerDefinition config = forall m a. ServerDefinition - { onConfigurationChange :: J.Value -> m (Either T.Text config) - -- ^ @onConfigurationChange newConfig@ is called whenever the + { defaultConfig :: config + -- ^ The default value we initialize the config variable to. + , onConfigurationChange :: config -> J.Value -> Either T.Text config + -- ^ @onConfigurationChange oldConfig newConfig@ is called whenever the -- clients sends a message with a changed client configuration. This -- callback should return either the parsed configuration data or an error -- indicating what went wrong. The parsed configuration object will be -- stored internally and can be accessed via 'config'. + -- It is also called on the `initializationOptions` field of the InitializeParams , doInitialize :: LanguageContextEnv config -> Message Initialize -> IO (Either ResponseError a) -- ^ Called *after* receiving the @initialize@ request and *before* -- returning the response. This callback will be invoked to offer the @@ -427,7 +430,7 @@ freshLspId = do -- | The current configuration from the client as set via the @initialize@ and -- @workspace/didChangeConfiguration@ requests. -getConfig :: MonadLsp config m => m (Maybe config) +getConfig :: MonadLsp config m => m config getConfig = getsState resConfig getClientCapabilities :: MonadLsp config m => m J.ClientCapabilities diff --git a/src/Language/LSP/Server/Processing.hs b/src/Language/LSP/Server/Processing.hs index 90a575d20..1eaf92c7e 100644 --- a/src/Language/LSP/Server/Processing.hs +++ b/src/Language/LSP/Server/Processing.hs @@ -96,11 +96,15 @@ initializeRequestHandler ServerDefinition{..} vfs sendFunc req = do Just (List xs) -> xs Nothing -> [] + initialConfig = case onConfigurationChange defaultConfig <$> (req ^. LSP.params . LSP.initializationOptions) of + Just (Right newConfig) -> newConfig + _ -> defaultConfig + tvarCtx <- liftIO $ newTVarIO $ LanguageContextState (VFSData vfs mempty) mempty - Nothing + initialConfig initialWfs defaultProgressData emptyIxMap @@ -109,7 +113,7 @@ initializeRequestHandler ServerDefinition{..} vfs sendFunc req = do 0 -- Call the 'duringInitialization' callback to let the server kick stuff up - let env = LanguageContextEnv handlers (forward interpreter . onConfigurationChange) sendFunc tvarCtx (params ^. LSP.capabilities) rootDir + let env = LanguageContextEnv handlers onConfigurationChange sendFunc tvarCtx (params ^. LSP.capabilities) rootDir handlers = transmuteHandlers interpreter staticHandlers interpreter = interpretHandler initializationResult initializationResult <- ExceptT $ doInitialize env req @@ -357,19 +361,18 @@ shutdownRequestHandler :: Handler IO Shutdown shutdownRequestHandler = \_req k -> do k $ Right Empty - - handleConfigChange :: Message WorkspaceDidChangeConfiguration -> LspM config () handleConfigChange req = do parseConfig <- LspT $ asks resParseConfig - res <- liftIO $ parseConfig (req ^. LSP.params . LSP.settings) + res <- stateState $ \ctx -> case parseConfig (resConfig ctx) (req ^. LSP.params . LSP.settings) of + Left err -> (Left err, ctx) + Right newConfig -> (Right (), ctx { resConfig = newConfig }) case res of Left err -> do let msg = T.pack $ unwords ["haskell-lsp:configuration parse error.", show req, show err] sendErrorLog msg - Right newConfig -> - modifyState $ \ctx -> ctx { resConfig = Just newConfig } + Right () -> pure () vfsFunc :: (VFS -> b -> (VFS, [String])) -> b -> LspM config () vfsFunc modifyVfs req = do From 4e2c93b03ce66410ec3c59b51b11351bbfb4b539 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Sat, 20 Feb 2021 19:01:47 +0530 Subject: [PATCH 2/4] fix func-test --- func-test/FuncTest.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/func-test/FuncTest.hs b/func-test/FuncTest.hs index 57daa20b7..f4fc4fd6c 100644 --- a/func-test/FuncTest.hs +++ b/func-test/FuncTest.hs @@ -29,7 +29,8 @@ main = hspec $ do killVar <- newEmptyMVar let definition = ServerDefinition - { onConfigurationChange = const $ pure $ Right () + { onConfigurationChange = const $ const $ Right () + , defaultConfig = () , doInitialize = \env _req -> pure $ Right env , staticHandlers = handlers killVar , interpretHandler = \env -> Iso (runLspT env) liftIO @@ -79,7 +80,8 @@ main = hspec $ do wf2 = WorkspaceFolder "/foo/baz" "My other workspace" definition = ServerDefinition - { onConfigurationChange = const $ pure $ Right () + { onConfigurationChange = const $ const $ Right () + , defaultConfig = () , doInitialize = \env _req -> pure $ Right env , staticHandlers = handlers , interpretHandler = \env -> Iso (runLspT env) liftIO From d9d1a84cc5240101e87a28ff2e41b759495f13e1 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Sat, 20 Feb 2021 19:18:51 +0530 Subject: [PATCH 3/4] add DataKinds to Lens.hs --- lsp-types/src/Language/LSP/Types/Lens.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/lsp-types/src/Language/LSP/Types/Lens.hs b/lsp-types/src/Language/LSP/Types/Lens.hs index a4341e4ff..b046d0069 100644 --- a/lsp-types/src/Language/LSP/Types/Lens.hs +++ b/lsp-types/src/Language/LSP/Types/Lens.hs @@ -7,6 +7,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} module Language.LSP.Types.Lens where From 5374aa5db305a0401e28aafbd98b5a0504046225 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Sat, 20 Feb 2021 19:40:56 +0530 Subject: [PATCH 4/4] add TypeInType to Lens.hs --- lsp-types/src/Language/LSP/Types/Lens.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/lsp-types/src/Language/LSP/Types/Lens.hs b/lsp-types/src/Language/LSP/Types/Lens.hs index b046d0069..e25e20dd0 100644 --- a/lsp-types/src/Language/LSP/Types/Lens.hs +++ b/lsp-types/src/Language/LSP/Types/Lens.hs @@ -8,6 +8,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeInType #-} module Language.LSP.Types.Lens where