Parse config from initializeOptions and pass in the old value of config to onConfigurationChange (#285)

* Parse config from initializeOptions and pass in the old value of config to onConfigurationChange

Author: wz1000

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

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

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

lsp-types/src/Language/LSP/Types/Lens.hs

@@ -7,6 +7,8 @@
 {-# LANGUAGE UndecidableInstances   #-}
 {-# LANGUAGE RankNTypes             #-}
 {-# LANGUAGE FlexibleContexts       #-}
+{-# LANGUAGE DataKinds              #-}
+{-# LANGUAGE TypeInType             #-}
 
 module Language.LSP.Types.Lens where
 

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

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