Skip to content

Commit 89f7e25

Browse files
michaelpjmichaelpj
committed
Comments
1 parent 130e2c6 commit 89f7e25

File tree

2 files changed

+148
-131
lines changed

2 files changed

+148
-131
lines changed

‎lsp/src/Language/LSP/Server/Core.hs

Lines changed: 86 additions & 82 deletions
Original file line numberDiff line numberDiff line change
@@ -1,65 +1,69 @@
1+
{-# LANGUAGE BangPatterns #-}
2+
{-# LANGUAGE BinaryLiterals #-}
3+
{-# LANGUAGE DerivingVia #-}
4+
{-# LANGUAGE FlexibleContexts #-}
5+
{-# LANGUAGE FlexibleInstances #-}
6+
{-# LANGUAGE FunctionalDependencies #-}
7+
{-# LANGUAGE GADTs #-}
18
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2-
{-# LANGUAGE TypeFamilyDependencies #-}
3-
{-# LANGUAGE DerivingVia #-}
4-
{-# LANGUAGE UndecidableInstances #-}
5-
{-# LANGUAGE BangPatterns #-}
6-
{-# LANGUAGE GADTs #-}
7-
{-# LANGUAGE BinaryLiterals #-}
8-
{-# LANGUAGE OverloadedStrings #-}
9-
{-# LANGUAGE RankNTypes #-}
10-
{-# LANGUAGE ScopedTypeVariables #-}
11-
{-# LANGUAGE FlexibleContexts #-}
12-
{-# LANGUAGE TypeInType #-}
13-
{-# LANGUAGE FlexibleInstances #-}
14-
{-# LANGUAGE FunctionalDependencies #-}
15-
{-# LANGUAGE TypeOperators #-}
16-
{-# LANGUAGE RoleAnnotations #-}
17-
{-# LANGUAGE LambdaCase #-}
9+
{-# LANGUAGE LambdaCase #-}
10+
{-# LANGUAGE OverloadedStrings #-}
11+
{-# LANGUAGE RankNTypes #-}
12+
{-# LANGUAGE RoleAnnotations #-}
13+
{-# LANGUAGE ScopedTypeVariables #-}
14+
{-# LANGUAGE TypeFamilyDependencies #-}
15+
{-# LANGUAGE TypeInType #-}
16+
{-# LANGUAGE TypeOperators #-}
17+
{-# LANGUAGE UndecidableInstances #-}
1818
{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
1919
{-# OPTIONS_GHC -fprint-explicit-kinds #-}
2020

2121
module Language.LSP.Server.Core where
2222

23-
import Colog.Core (LogAction (..), WithSeverity (..), Severity (..), (<&))
23+
import Colog.Core (LogAction (..),
24+
Severity (..),
25+
WithSeverity (..),
26+
(<&))
2427
import Control.Concurrent.Async
2528
import Control.Concurrent.STM
26-
import qualified Control.Exception as E
29+
import qualified Control.Exception as E
30+
import Control.Lens (_Just, at, (^.), (^?))
2731
import Control.Monad
32+
import Control.Monad.Catch (MonadCatch, MonadMask,
33+
MonadThrow)
2834
import Control.Monad.Fix
2935
import Control.Monad.IO.Class
30-
import Control.Monad.Trans.Reader
31-
import Control.Monad.Trans.Class
3236
import Control.Monad.IO.Unlift
33-
import Control.Lens ( (^.), (^?), _Just, at)
34-
import qualified Data.Aeson as J
37+
import Control.Monad.Trans.Class
38+
import Control.Monad.Trans.Identity
39+
import Control.Monad.Trans.Reader
40+
import qualified Data.Aeson as J
3541
import Data.Default
3642
import Data.Functor.Product
43+
import qualified Data.HashMap.Strict as HM
3744
import Data.IxMap
38-
import qualified Data.HashMap.Strict as HM
3945
import Data.Kind
40-
import qualified Data.List as L
41-
import Data.List.NonEmpty (NonEmpty(..))
42-
import qualified Data.Map.Strict as Map
46+
import qualified Data.List as L
47+
import Data.List.NonEmpty (NonEmpty (..))
48+
import qualified Data.Map.Strict as Map
4349
import Data.Maybe
50+
import Data.Monoid (Ap (..))
51+
import Data.Ord (Down (Down))
4452
import Data.Row
45-
import Data.Monoid (Ap(..))
46-
import Data.Ord (Down (Down))
47-
import qualified Data.Text as T
48-
import Data.Text ( Text )
49-
import qualified Data.UUID as UUID
50-
import Language.LSP.Protocol.Types
51-
import Language.LSP.Protocol.Message
52-
import qualified Language.LSP.Protocol.Types as L
53-
import qualified Language.LSP.Protocol.Lens as L
54-
import qualified Language.LSP.Protocol.Message as L
53+
import Data.Text (Text)
54+
import qualified Data.Text as T
55+
import qualified Data.UUID as UUID
56+
import Language.LSP.Diagnostics
57+
import qualified Language.LSP.Protocol.Lens as L
58+
import Language.LSP.Protocol.Message
59+
import qualified Language.LSP.Protocol.Message as L
60+
import Language.LSP.Protocol.Types
61+
import qualified Language.LSP.Protocol.Types as L
5562
import Language.LSP.Protocol.Utils.SMethodMap (SMethodMap)
5663
import qualified Language.LSP.Protocol.Utils.SMethodMap as SMethodMap
5764
import Language.LSP.VFS
58-
import Language.LSP.Diagnostics
59-
import System.Random hiding (next)
60-
import Control.Monad.Trans.Identity
61-
import Control.Monad.Catch (MonadMask, MonadCatch, MonadThrow)
62-
import Prettyprinter
65+
import Prettyprinter
66+
import System.Random hiding (next)
6367

6468
-- ---------------------------------------------------------------------
6569
{-# ANN module ("HLint: ignore Eta reduce" :: String) #-}
@@ -122,15 +126,15 @@ instance MonadLsp c m => MonadLsp c (IdentityT m) where
122126

123127
data LanguageContextEnv config =
124128
LanguageContextEnv
125-
{ resHandlers :: !(Handlers IO)
126-
, resConfigSection :: T.Text
127-
, resParseConfig :: !(config -> J.Value -> Either T.Text config)
128-
, resOnConfigChange :: !(config -> IO ())
129-
, resSendMessage :: !(FromServerMessage -> IO ())
129+
{ resHandlers :: !(Handlers IO)
130+
, resConfigSection :: T.Text
131+
, resParseConfig :: !(config -> J.Value -> Either T.Text config)
132+
, resOnConfigChange :: !(config -> IO ())
133+
, resSendMessage :: !(FromServerMessage -> IO ())
130134
-- We keep the state in a TVar to be thread safe
131-
, resState :: !(LanguageContextState config)
132-
, resClientCapabilities :: !L.ClientCapabilities
133-
, resRootPath :: !(Maybe FilePath)
135+
, resState :: !(LanguageContextState config)
136+
, resClientCapabilities :: !L.ClientCapabilities
137+
, resRootPath :: !(Maybe FilePath)
134138
}
135139

136140
-- ---------------------------------------------------------------------
@@ -175,7 +179,7 @@ type family Handler (f :: Type -> Type) (m :: Method from t) = (result :: Type)
175179
-- | How to convert two isomorphic data structures between each other.
176180
data m <~> n
177181
= Iso
178-
{ forward :: forall a. m a -> n a
182+
{ forward :: forall a. m a -> n a
179183
, backward :: forall a. n a -> m a
180184
}
181185

@@ -194,15 +198,15 @@ mapHandlers mapReq mapNot (Handlers reqs nots) = Handlers reqs' nots'
194198
-- | state used by the LSP dispatcher to manage the message loop
195199
data LanguageContextState config =
196200
LanguageContextState
197-
{ resVFS :: !(TVar VFSData)
198-
, resDiagnostics :: !(TVar DiagnosticStore)
199-
, resConfig :: !(TVar config)
200-
, resWorkspaceFolders :: !(TVar [WorkspaceFolder])
201-
, resProgressData :: !ProgressData
202-
, resPendingResponses :: !(TVar ResponseMap)
203-
, resRegistrationsNot :: !(TVar (RegistrationMap Notification))
204-
, resRegistrationsReq :: !(TVar (RegistrationMap Request))
205-
, resLspId :: !(TVar Int32)
201+
{ resVFS :: !(TVar VFSData)
202+
, resDiagnostics :: !(TVar DiagnosticStore)
203+
, resConfig :: !(TVar config)
204+
, resWorkspaceFolders :: !(TVar [WorkspaceFolder])
205+
, resProgressData :: !ProgressData
206+
, resPendingResponses :: !(TVar ResponseMap)
207+
, resRegistrationsNot :: !(TVar (RegistrationMap Notification))
208+
, resRegistrationsReq :: !(TVar (RegistrationMap Request))
209+
, resLspId :: !(TVar Int32)
206210
}
207211

208212
type ResponseMap = IxMap LspId (Product SMethod ServerResponseCallback)
@@ -218,7 +222,7 @@ data ProgressData = ProgressData { progressNextId :: !(TVar Int32)
218222

219223
data VFSData =
220224
VFSData
221-
{ vfsData :: !VFS
225+
{ vfsData :: !VFS
222226
, reverseMap :: !(Map.Map FilePath FilePath)
223227
}
224228

@@ -315,16 +319,17 @@ data ServerDefinition config = forall m a.
315319
-- ^ @parseConfig oldConfig newConfigObject@ is called whenever we
316320
-- get updated configuration from the client.
317321
--
318-
-- @parseConfig@ is called on the object corresponding to the config section, it should
319-
-- not itself try to look for the config section.
322+
-- @parseConfig@ is called on the object corresponding to the server's
323+
-- config section, it should not itself try to look for the config section.
320324
--
321-
-- @parseConfig@ also receives the old configuration. This is only useful when parsing
322-
-- changed settings from @workspace/didChangeConfiguration@ requests where the client
323-
-- sends only the changed settings. However, this behaviour is discouraged, so in future
324-
-- @parseConfig@ may change to only take a full new config object.
325+
-- Note that the 'J.Value' may represent only a partial object in the case where we
326+
-- are handling a @workspace/didChangeConfiguration@ request where the client sends
327+
-- only the changed settings. This is also the main circumstance where the old configuration
328+
-- argument is useful. It is generally fine for servers to ignore this case and just
329+
-- assume that the 'J.Value' represents a full new config and ignore the old configuration.
330+
-- This will only be problematic in the case of clients which behave as above and *also*
331+
-- don't support @workspace/configuration@, which is discouraged.
325332
--
326-
-- @parseConfig@ should return either the parsed configuration data or an error
327-
-- indicating what went wrong.
328333
, onConfigChange :: config -> m ()
329334
-- ^ This callback is called any time the configuration is updated, with
330335
-- the new config. Servers that want to react to config changes should provide
@@ -383,7 +388,7 @@ sendNotification
383388
sendNotification m params =
384389
let msg = TNotificationMessage "2.0" m params
385390
in case splitServerMethod m of
386-
IsServerNot -> sendToClient $ fromServerNot msg
391+
IsServerNot -> sendToClient $ fromServerNot msg
387392
IsServerEither -> sendToClient $ FromServerMess m $ NotMess msg
388393

389394
sendRequest :: forall (m :: Method ServerToClient Request) f config. MonadLsp config f
@@ -399,7 +404,7 @@ sendRequest m params resHandler = do
399404

400405
let msg = TRequestMessage "2.0" reqId m params
401406
~() <- case splitServerMethod m of
402-
IsServerReq -> sendToClient $ fromServerReq msg
407+
IsServerReq -> sendToClient $ fromServerReq msg
403408
IsServerEither -> sendToClient $ FromServerMess m $ ReqMess msg
404409
return reqId
405410

@@ -437,7 +442,7 @@ persistVirtualFile logger uri = do
437442
Just uri_fp -> Map.insert fn uri_fp $ reverseMap vfs
438443
-- TODO: Does the VFS make sense for URIs which are not files?
439444
-- The reverse map should perhaps be (FilePath -> URI)
440-
Nothing -> reverseMap vfs
445+
Nothing -> reverseMap vfs
441446
!vfs' = vfs {reverseMap = revMap}
442447
act = do
443448
write
@@ -451,7 +456,7 @@ getVersionedTextDoc doc = do
451456
mvf <- getVirtualFile (toNormalizedUri uri)
452457
let ver = case mvf of
453458
Just (VirtualFile lspver _ _) -> lspver
454-
Nothing -> 0
459+
Nothing -> 0
455460
return (VersionedTextDocumentIdentifier uri ver)
456461

457462
{-# INLINE getVersionedTextDoc #-}
@@ -535,8 +540,8 @@ registerCapability method regOpts f = do
535540
clientCaps <- resClientCapabilities <$> getLspEnv
536541
handlers <- resHandlers <$> getLspEnv
537542
let alreadyStaticallyRegistered = case splitClientMethod method of
538-
IsClientNot -> SMethodMap.member method $ notHandlers handlers
539-
IsClientReq -> SMethodMap.member method $ reqHandlers handlers
543+
IsClientNot -> SMethodMap.member method $ notHandlers handlers
544+
IsClientReq -> SMethodMap.member method $ reqHandlers handlers
540545
IsClientEither -> error "Cannot register capability for custom methods"
541546
go clientCaps alreadyStaticallyRegistered
542547
where
@@ -611,8 +616,8 @@ registerCapability method regOpts f = do
611616
unregisterCapability :: MonadLsp config f => RegistrationToken m -> f ()
612617
unregisterCapability (RegistrationToken m (RegistrationId uuid)) = do
613618
~() <- case splitClientMethod m of
614-
IsClientReq -> modifyState resRegistrationsReq $ SMethodMap.delete m
615-
IsClientNot -> modifyState resRegistrationsNot $ SMethodMap.delete m
619+
IsClientReq -> modifyState resRegistrationsReq $ SMethodMap.delete m
620+
IsClientNot -> modifyState resRegistrationsNot $ SMethodMap.delete m
616621
IsClientEither -> error "Cannot unregister capability for custom methods"
617622

618623
let unregistration = L.TUnregistration uuid m
@@ -651,7 +656,7 @@ withProgressBase indefinite title cancellable f = do
651656
| indefinite = Nothing
652657
| otherwise = Just 0
653658
cancellable' = case cancellable of
654-
Cancellable -> True
659+
Cancellable -> True
655660
NotCancellable -> False
656661

657662
-- Create progress token
@@ -663,7 +668,7 @@ withProgressBase indefinite title cancellable f = do
663668
-- An error occurred when the client was setting it up
664669
-- No need to do anything then, as per the spec
665670
Left _err -> pure ()
666-
Right _ -> pure ()
671+
Right _ -> pure ()
667672

668673
-- Send the begin and done notifications via 'bracket_' so that they are always fired
669674
res <- withRunInIO $ \runInBase ->
@@ -790,8 +795,8 @@ tryChangeConfig :: (m ~ LspM config) => LogAction m (WithSeverity LspCoreLog) ->
790795
tryChangeConfig logger newConfigObject = do
791796
parseCfg <- LspT $ asks resParseConfig
792797
res <- stateState resConfig $ \oldConfig -> case parseCfg oldConfig newConfigObject of
793-
Left err -> (Left err, oldConfig)
794-
Right !newConfig -> (Right newConfig, newConfig)
798+
Left err -> (Left err, oldConfig)
799+
Right newConfig -> (Right newConfig, newConfig)
795800
case res of
796801
Left err -> do
797802
logger <& ConfigurationParseError newConfigObject err `WithSeverity` Warning
@@ -811,11 +816,10 @@ requestConfigUpdate logger = do
811816
if supportsConfiguration
812817
then do
813818
section <- LspT $ asks resConfigSection
814-
_ <- sendRequest SMethod_WorkspaceConfiguration (ConfigurationParams [ConfigurationItem Nothing (Just section)]) $ \case
819+
void $ sendRequest SMethod_WorkspaceConfiguration (ConfigurationParams [ConfigurationItem Nothing (Just section)]) $ \case
815820
Right [newConfigObject] -> tryChangeConfig logger newConfigObject
816821
Right sections -> logger <& WrongConfigSections sections `WithSeverity` Error
817822
Left err -> logger <& BadConfigurationResponse err `WithSeverity` Error
818-
pure ()
819823
else
820824
logger <& ConfigurationNotSupported `WithSeverity` Debug
821825

0 commit comments

Comments
 (0)