lsp 1.1.1.0 → 1.2.0.0

raw patch · 13 files changed

+228/−242 lines, 13 filesdep ~lsp-typessetup-changedPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: lsp-types

API changes (from Hackage documentation)

Files

• ChangeLog.md +7/−0
• README.md +12/−86
• Setup.hs +0/−2
• example/Reactor.hs +22/−9
• example/Simple.hs +2/−1
• lsp.cabal +4/−4
• src/Language/LSP/Diagnostics.hs +1/−1
• src/Language/LSP/Server/Control.hs +6/−6
• src/Language/LSP/Server/Core.hs +114/−86
• src/Language/LSP/Server/Processing.hs +43/−36
• test/CapabilitiesSpec.hs +2/−2
• test/JsonSpec.hs +12/−9
• test/WorkspaceEditSpec.hs +3/−0

@@ -1,5 +1,12 @@ # Revision history for lsp +## 1.2.0.0++* Parse config from initializeOptions and pass in the old value of config to onConfigurationChange (#285) (wz1000)+* Break up big TVar record into lots of small TVars (#286) (@wz1000)+* Add some INLINE pragmas (@wz1000)+* Make method equality work for CustomMethods (@wz1000)+ ## 1.1.1.0  * Don't send begin progress notification twice (@wz1000)

@@ -1,91 +1,17 @@-![CI](https://github.com/alanz/lsp/workflows/Haskell%20CI/badge.svg)-[![Hackage](https://img.shields.io/hackage/v/lsp?label=lsp)](https://hackage.haskell.org/package/lsp)-[![Hackage](https://img.shields.io/hackage/v/lsp?label=lsp-types)](https://hackage.haskell.org/package/lsp-types)- # lsp-Haskell library for the Microsoft Language Server Protocol.-It currently implements all of the [3.15 specification](https://microsoft.github.io/language-server-protocol/specifications/specification-3-15/). -It is split into two separate packages, `lsp` and `lsp-types`-- `lsp-types` provides *type-safe* definitions that match up with the-typescript definitions laid out in the specification-- `lsp` is a library for building language servers, handling:-  - JSON-RPC transport-  - Keeping track of the document state in memory with the Virtual File System (VFS)-  - Responding to notifications and requests via handlers-  - Setting the server capabilities in the initialize request based on registered handlers-  - Dynamic registration of capabilities-  - Cancellable requests and progress notifications-  - Publishing and flushing of diagnostics--## Language servers built on lsp-- [ghcide](https://github.com/haskell/ghcide)-- [haskell-language-server](https://github.com/haskell/haskell-language-server)-- [dhall-lsp-server](https://github.com/dhall-lang/dhall-haskell/tree/master/dhall-lsp-server#readme)--## Example language servers-There are two example language servers in the `example/` folder. `Simple.hs` provides a minimal example:--```haskell-{-# LANGUAGE OverloadedStrings #-}--import Language.LSP.Server-import Language.LSP.Types-import Control.Monad.IO.Class-import qualified Data.Text as T--handlers :: Handlers (LspM ())-handlers = mconcat-  [ notificationHandler SInitialized $ \_not -> do-      let params = ShowMessageRequestParams MtInfo "Turn on code lenses?"-            (Just [MessageActionItem "Turn on", MessageActionItem "Don't"])-      _ <- sendRequest SWindowShowMessageRequest params $ \res ->-        case res of-          Right (Just (MessageActionItem "Turn on")) -> do-            let regOpts = CodeLensRegistrationOptions Nothing Nothing (Just False)-              -            _ <- registerCapability STextDocumentCodeLens regOpts $ \_req responder -> do-              let cmd = Command "Say hello" "lsp-hello-command" Nothing-                  rsp = List [CodeLens (mkRange 0 0 0 100) (Just cmd) Nothing]-              responder (Right rsp)-            pure ()-          Right _ ->-            sendNotification SWindowShowMessage (ShowMessageParams MtInfo "Not turning on code lenses")-          Left err ->-            sendNotification SWindowShowMessage (ShowMessageParams MtError $ "Something went wrong!\n" <> T.pack (show err))-      pure ()-  , requestHandler STextDocumentHover $ \req responder -> do-      let RequestMessage _ _ _ (HoverParams _doc pos _workDone) = req-          Position _l _c' = pos-          rsp = Hover ms (Just range)-          ms = HoverContents $ markedUpContent "lsp-demo-simple-server" "Hello world"-          range = Range pos pos-      responder (Right $ Just rsp)-  ]--main :: IO Int-main = runServer $ ServerDefinition-  { onConfigurationChange = const $ pure $ Right ()-  , doInitialize = \env _req -> pure $ Right env-  , staticHandlers = handlers-  , interpretHandler = \env -> Iso (runLspT env) liftIO-  , options = defaultOptions-  }-```--Whilst `Reactor.hs` shows how a reactor design can be used to handle all-requests on a separate thread, such in a way that we could then execute them on-multiple threads without blocking server communication. They can be installed-from source with--    cabal install lsp-demo-simple-server lsp-demo-reactor-server-    stack install :lsp-demo-simple-server :lsp-demo-reactor-server --flag haskell-lsp:demo--## Useful links--- https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md+lsp is a library for building language servers, handling: -## Other resources+- JSON-RPC transport+- Keeping track of the document state in memory with the Virtual File System (VFS)+- Responding to notifications and requests via handlers+- Setting the server capabilities in the initialize request based on registered handlers+- Dynamic registration of capabilities+- Cancellable requests and progress notifications+- Publishing and flushing of diagnostics -See #haskell-ide-engine on IRC freenode+It is part of the [lsp](https://github.com/haskell/lsp) family of packages,+along with [lsp-test](https://hackage.haskell.org/package/lsp-test) and+[lsp-types](https://hackage.haskell.org/package/lsp-types) +For more information, check https://github.com/haskell/lsp/blob/master/README.md

@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain

@@ -59,7 +59,7 @@ -- ---------------------------------------------------------------------  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 @@    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 @@     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@@ -222,10 +227,10 @@           newName = params ^. J.newName       vdoc <- getVersionedTextDoc (params ^. J.textDocument)       -- Replace some text at the position with what the user entered-      let edit = J.TextEdit (J.mkRange l c l (c + T.length newName)) newName+      let edit = J.InL $ J.TextEdit (J.mkRange l c l (c + T.length newName)) newName           tde = J.TextDocumentEdit vdoc (J.List [edit])           -- "documentChanges" field is preferred over "changes"-          rsp = J.WorkspaceEdit Nothing (Just (J.List [J.InL tde]))+          rsp = J.WorkspaceEdit Nothing (Just (J.List [J.InL tde])) Nothing       responder (Right rsp)    , requestHandler J.STextDocumentHover $ \req responder -> do@@ -236,6 +241,14 @@           ms = J.HoverContents $ J.markedUpContent "lsp-hello" "Your type info here!"           range = J.Range pos pos       responder (Right $ Just rsp)++  , requestHandler J.STextDocumentDocumentSymbol $ \req responder -> do+      liftIO $ debugM "reactor.handle" "Processing a textDocument/documentSymbol request"+      let J.DocumentSymbolParams _ _ doc = req ^. J.params+          loc = J.Location (doc ^. J.uri) (J.Range (J.Position 0 0) (J.Position 0 0))+          sym = J.SymbolInformation "lsp-hello" J.SkFunction Nothing Nothing loc Nothing+          rsp = J.InR (J.List [sym])+      responder (Right rsp)    , requestHandler J.STextDocumentCodeAction $ \req responder -> do       liftIO $ debugM "reactor.handle" $ "Processing a textDocument/codeAction request"

@@ -36,7 +36,8 @@  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

@@ -1,6 +1,6 @@ cabal-version:       2.2 name:                lsp-version:             1.1.1.0+version:             1.2.0.0 synopsis:            Haskell library for the Microsoft Language Server Protocol  description:         An implementation of the types, and basic message server to@@ -10,7 +10,7 @@                      An example of this is for Haskell via the Haskell IDE                      Engine, at https://github.com/haskell/haskell-ide-engine -homepage:            https://github.com/alanz/lsp+homepage:            https://github.com/haskell/lsp license:             MIT license-file:        LICENSE author:              Alan Zimmerman@@ -42,7 +42,7 @@                      , filepath                      , hslogger                      , hashable-                     , lsp-types == 1.1.*+                     , lsp-types == 1.2.*                      , dependent-map                      , lens >= 4.15.2                      , mtl@@ -152,4 +152,4 @@  source-repository head   type:     git-  location: https://github.com/alanz/lsp+  location: https://github.com/haskell/lsp

@@ -21,7 +21,7 @@   ) where  import qualified Data.SortedList as SL-import qualified Data.Map as Map+import qualified Data.Map.Strict as Map import qualified Data.HashMap.Strict as HM import qualified Language.LSP.Types      as J 

@@ -81,7 +81,7 @@     -> IO Int         -- exit code runServerWith clientIn clientOut serverDefinition = do -  infoM "haskell-lsp.runWith" "\n\n\n\n\nhaskell-lsp:Starting up server ..."+  infoM "lsp.runWith" "\n\n\n\n\nlsp:Starting up server ..."    cout <- atomically newTChan :: IO (TChan J.Value)   _rhpid <- forkIO $ sendServer cout clientOut@@ -108,7 +108,7 @@     Just (msg,remainder) -> do       case J.eitherDecode $ BSL.fromStrict msg of         Left err ->-          errorM "haskell-lsp.ioLoop" $+          errorM "lsp.ioLoop" $             "Got error while decoding initialize:\n" <> err <> "\n exiting 1 ...\n"         Right initialize -> do           mInitResp <- initializeRequestHandler serverDefinition vfs sendMsg initialize@@ -119,7 +119,7 @@      parseOne :: Result BS.ByteString -> IO (Maybe (BS.ByteString,BS.ByteString))     parseOne (Fail _ ctxs err) = do-      errorM "haskell-lsp.parseOne" $+      errorM "lsp.parseOne" $         "Failed to parse message header:\n" <> intercalate " > " ctxs <> ": " <>         err <> "\n exiting 1 ...\n"       pure Nothing@@ -127,11 +127,11 @@       bs <- clientIn       if BS.null bs         then do-          errorM "haskell-lsp.parseON" "haskell-lsp:Got EOF, exiting 1 ...\n"+          errorM "lsp.parseON" "lsp:Got EOF, exiting 1 ...\n"           pure Nothing         else parseOne (c bs)     parseOne (Done remainder msg) = do-      debugM "haskell-lsp.parseOne" $ "---> " <> T.unpack (T.decodeUtf8 msg)+      debugM "lsp.parseOne" $ "---> " <> T.unpack (T.decodeUtf8 msg)       pure $ Just (msg,remainder)      loop env = go@@ -168,7 +168,7 @@                 , str ]      clientOut out-    debugM "haskell-lsp.sendServer" $ "<--2--" <> TL.unpack (TL.decodeUtf8 str)+    debugM "lsp.sendServer" $ "<--2--" <> TL.unpack (TL.decodeUtf8 str)  -- | --

@@ -1,6 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE BangPatterns         #-} {-# LANGUAGE LambdaCase           #-} {-# LANGUAGE GADTs                #-} {-# LANGUAGE MultiWayIf           #-}@@ -47,8 +48,9 @@ import           Data.Kind import qualified Data.List as L import           Data.List.NonEmpty (NonEmpty(..))-import qualified Data.Map as Map+import qualified Data.Map.Strict as Map import           Data.Maybe+import           Data.Ord (Down (Down)) import qualified Data.Text as T import           Data.Text ( Text ) import qualified Data.UUID as UUID@@ -63,7 +65,7 @@ import qualified System.Log.Handler.Simple as LHS import           System.Log.Logger import qualified System.Log.Logger as L-import           System.Random+import           System.Random hiding (next) import           Control.Monad.Trans.Identity  -- ---------------------------------------------------------------------@@ -81,26 +83,33 @@ runLspT :: LanguageContextEnv config -> LspT config m a -> m a runLspT env = flip runReaderT env . unLspT +{-# INLINE runLspT #-}+ type LspM config = LspT config IO  class MonadUnliftIO m => MonadLsp config m | m -> config where   getLspEnv :: m (LanguageContextEnv config)  instance MonadUnliftIO m => MonadLsp config (LspT config m) where+  {-# SPECIALIZE instance MonadLsp config (LspT config IO) #-}+  {-# INLINE getLspEnv #-}   getLspEnv = LspT ask  instance MonadLsp c m => MonadLsp c (ReaderT r m) where+  {-# SPECIALIZE instance MonadLsp config (ReaderT r (LspT config IO)) #-}+  {-# INLINE getLspEnv #-}   getLspEnv = lift getLspEnv+ instance MonadLsp c m => MonadLsp c (IdentityT m) where   getLspEnv = lift getLspEnv  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))+  , resState               :: !(LanguageContextState config)   , resClientCapabilities  :: !J.ClientCapabilities   , resRootPath            :: !(Maybe FilePath)   }@@ -121,8 +130,8 @@ -- @  data Handlers m   = Handlers-  { reqHandlers :: DMap SMethod (ClientMessageHandler m Request)-  , notHandlers :: DMap SMethod (ClientMessageHandler m Notification)+  { reqHandlers :: !(DMap SMethod (ClientMessageHandler m Request))+  , notHandlers :: !(DMap SMethod (ClientMessageHandler m Notification))   } instance Semigroup (Handlers config) where   Handlers r1 n1 <> Handlers r2 n2 = Handlers (r1 <> r2) (n1 <> n2)@@ -166,15 +175,15 @@ -- | state used by the LSP dispatcher to manage the message loop data LanguageContextState config =   LanguageContextState-  { resVFS                 :: !VFSData-  , resDiagnostics         :: !DiagnosticStore-  , resConfig              :: !(Maybe config)-  , resWorkspaceFolders    :: ![WorkspaceFolder]+  { resVFS                 :: !(TVar VFSData)+  , resDiagnostics         :: !(TVar DiagnosticStore)+  , resConfig              :: !(TVar config)+  , resWorkspaceFolders    :: !(TVar [WorkspaceFolder])   , resProgressData        :: !ProgressData-  , resPendingResponses    :: !ResponseMap-  , resRegistrationsNot    :: !(RegistrationMap Notification)-  , resRegistrationsReq    :: !(RegistrationMap Request)-  , resLspId               :: !Int+  , resPendingResponses    :: !(TVar ResponseMap)+  , resRegistrationsNot    :: !(TVar (RegistrationMap Notification))+  , resRegistrationsReq    :: !(TVar (RegistrationMap Request))+  , resLspId               :: !(TVar Int)   }  type ResponseMap = IxMap LspId (Product SMethod ServerResponseCallback)@@ -185,8 +194,8 @@ newtype RegistrationId (m :: Method FromClient t) = RegistrationId Text   deriving Eq -data ProgressData = ProgressData { progressNextId :: !Int-                                 , progressCancel :: !(Map.Map ProgressToken (IO ())) }+data ProgressData = ProgressData { progressNextId :: !(TVar Int)+                                 , progressCancel :: !(TVar (Map.Map ProgressToken (IO ()))) }  data VFSData =   VFSData@@ -194,20 +203,23 @@     , reverseMap :: !(Map.Map FilePath FilePath)     } -modifyState :: MonadLsp config m => (LanguageContextState config -> LanguageContextState config) -> m ()-modifyState f = do-  tvarDat <- resState <$> getLspEnv+{-# INLINE modifyState #-}+modifyState :: MonadLsp config m => (LanguageContextState config -> TVar a) -> (a -> a) -> m ()+modifyState sel f = do+  tvarDat <- sel . resState <$> getLspEnv   liftIO $ atomically $ modifyTVar' tvarDat f -stateState :: MonadLsp config m => (LanguageContextState config -> (a,LanguageContextState config)) -> m a-stateState f = do-  tvarDat <- resState <$> getLspEnv+{-# INLINE stateState #-}+stateState :: MonadLsp config m => (LanguageContextState config -> TVar s) -> (s -> (a,s)) -> m a+stateState sel f = do+  tvarDat <- sel . resState <$> getLspEnv   liftIO $ atomically $ stateTVar tvarDat f -getsState :: MonadLsp config m => (LanguageContextState config -> a) -> m a+{-# INLINE getsState #-}+getsState :: MonadLsp config m => (LanguageContextState config -> TVar a) -> m a getsState f = do-  tvarDat <- resState <$> getLspEnv-  liftIO $ f <$> readTVarIO tvarDat+  tvarDat <- f . resState <$> getLspEnv+  liftIO $ readTVarIO tvarDat  -- --------------------------------------------------------------------- @@ -274,12 +286,15 @@ -- 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@@ -318,10 +333,10 @@ -- Might fail if the id was already in the map addResponseHandler :: MonadLsp config f => LspId m -> (Product SMethod ServerResponseCallback) m -> f Bool addResponseHandler lid h = do-  stateState $ \ctx@LanguageContextState{resPendingResponses} ->-    case insertIxMap lid h resPendingResponses of-      Just m -> (True, ctx { resPendingResponses = m})-      Nothing -> (False, ctx)+  stateState resPendingResponses $ \pending ->+    case insertIxMap lid h pending of+      Just !m -> (True, m)+      Nothing -> (False, pending)  sendNotification   :: forall (m :: Method FromServer Notification) f config. MonadLsp config f@@ -355,28 +370,33 @@  -- | Return the 'VirtualFile' associated with a given 'NormalizedUri', if there is one. getVirtualFile :: MonadLsp config m => NormalizedUri -> m (Maybe VirtualFile)-getVirtualFile uri = getsState $ Map.lookup uri . vfsMap . vfsData . resVFS+getVirtualFile uri = Map.lookup uri . vfsMap . vfsData <$> getsState resVFS +{-# INLINE getVirtualFile #-}+ getVirtualFiles :: MonadLsp config m => m VFS-getVirtualFiles = getsState $ vfsData . resVFS+getVirtualFiles = vfsData <$> getsState resVFS +{-# INLINE getVirtualFiles #-}+ -- | Dump the current text for a given VFS file to a temporary file, -- and return the path to the file. persistVirtualFile :: MonadLsp config m => NormalizedUri -> m (Maybe FilePath) persistVirtualFile uri = do-  join $ stateState $ \ctx@LanguageContextState{resVFS = vfs} ->+  join $ stateState resVFS $ \vfs ->     case persistFileVFS (vfsData vfs) uri of-      Nothing -> (return Nothing, ctx)+      Nothing -> (return Nothing, vfs)       Just (fn, write) ->-        let revMap = case uriToFilePath (fromNormalizedUri uri) of+        let !revMap = case uriToFilePath (fromNormalizedUri uri) of               Just uri_fp -> Map.insert fn uri_fp $ reverseMap vfs               -- TODO: Does the VFS make sense for URIs which are not files?               -- The reverse map should perhaps be (FilePath -> URI)               Nothing -> reverseMap vfs+            !vfs' = vfs {reverseMap = revMap}             act = do               liftIO write               pure (Just fn)-        in (act, ctx{resVFS = vfs {reverseMap = revMap} })+        in (act, vfs')  -- | Given a text document identifier, annotate it with the latest version. getVersionedTextDoc :: MonadLsp config m => TextDocumentIdentifier -> m VersionedTextDocumentIdentifier@@ -388,6 +408,8 @@         Nothing -> Nothing   return (VersionedTextDocumentIdentifier uri ver) +{-# INLINE getVersionedTextDoc #-}+ -- TODO: should this function return a URI? -- | If the contents of a VFS has been dumped to a temporary file, map -- the temporary file name back to the original one.@@ -397,10 +419,7 @@   let f fp = fromMaybe fp . Map.lookup fp . reverseMap $ vfs   return f --- -----------------------------------------------------------------------defaultProgressData :: ProgressData-defaultProgressData = ProgressData 0 Map.empty+{-# INLINE reverseFileMap #-}  -- --------------------------------------------------------------------- @@ -409,6 +428,8 @@   f <- resSendMessage <$> getLspEnv   liftIO $ f msg +{-# INLINE sendToClient #-}+ -- ---------------------------------------------------------------------  sendErrorLog :: MonadLsp config m => Text -> m ()@@ -416,26 +437,36 @@   sendToClient $ fromServerNot $     NotificationMessage "2.0" SWindowLogMessage (LogMessageParams MtError msg) +{-# INLINE sendErrorLog #-}+ -- ---------------------------------------------------------------------  freshLspId :: MonadLsp config m => m Int freshLspId = do-  stateState $ \c ->-    (resLspId c, c{resLspId = resLspId c+1})+  stateState resLspId $ \cur ->+    let !next = cur+1 in (cur, next) +{-# INLINE freshLspId #-}+ -- ---------------------------------------------------------------------  -- | 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 +{-# INLINE getConfig #-}+ getClientCapabilities :: MonadLsp config m => m J.ClientCapabilities getClientCapabilities = resClientCapabilities <$> getLspEnv +{-# INLINE getClientCapabilities #-}+ getRootPath :: MonadLsp config m => m (Maybe FilePath) getRootPath = resRootPath <$> getLspEnv +{-# INLINE getRootPath #-}+ -- | The current workspace folders, if the client supports workspace folders. getWorkspaceFolders :: MonadLsp config m => m (Maybe [WorkspaceFolder]) getWorkspaceFolders = do@@ -448,6 +479,8 @@     then Just <$> getsState resWorkspaceFolders     else pure Nothing +{-# INLINE getWorkspaceFolders #-}+ -- | Sends a @client/registerCapability@ request and dynamically registers -- a 'Method' with a 'Handler'. Returns 'Nothing' if the client does not -- support dynamic registration for the specified method, otherwise a@@ -479,14 +512,12 @@               regId = RegistrationId uuid           rio <- askUnliftIO           ~() <- case splitClientMethod method of-            IsClientNot -> modifyState $ \ctx ->-              let newRegs = DMap.insert method pair (resRegistrationsNot ctx)-                  pair = Pair regId (ClientMessageHandler (unliftIO rio . f))-                in ctx { resRegistrationsNot = newRegs }-            IsClientReq -> modifyState $ \ctx ->-              let newRegs = DMap.insert method pair (resRegistrationsReq ctx)-                  pair = Pair regId (ClientMessageHandler (\msg k -> unliftIO rio $ f msg (liftIO . k)))-                in ctx { resRegistrationsReq = newRegs }+            IsClientNot -> modifyState resRegistrationsNot $ \oldRegs ->+              let pair = Pair regId (ClientMessageHandler (unliftIO rio . f))+                in DMap.insert method pair oldRegs+            IsClientReq -> modifyState resRegistrationsReq $ \oldRegs ->+              let pair = Pair regId (ClientMessageHandler (\msg k -> unliftIO rio $ f msg (liftIO . k)))+                in DMap.insert method pair oldRegs             IsClientEither -> error "Cannot register capability for custom methods"            -- TODO: handle the scenario where this returns an error@@ -538,14 +569,8 @@ unregisterCapability :: MonadLsp config f => RegistrationToken m -> f () unregisterCapability (RegistrationToken m (RegistrationId uuid)) = do   ~() <- case splitClientMethod m of-    IsClientReq -> do-      reqRegs <- getsState resRegistrationsReq-      let newMap = DMap.delete m reqRegs-      modifyState (\ctx -> ctx { resRegistrationsReq = newMap })-    IsClientNot -> do-      notRegs <- getsState resRegistrationsNot-      let newMap = DMap.delete m notRegs-      modifyState (\ctx -> ctx { resRegistrationsNot = newMap })+    IsClientReq -> modifyState resRegistrationsReq $ DMap.delete m+    IsClientNot -> modifyState resRegistrationsNot $ DMap.delete m     IsClientEither -> error "Cannot unregister capability for custom methods"    let unregistration = J.Unregistration uuid (J.SomeClientMethod m)@@ -557,23 +582,24 @@ --------------------------------------------------------------------------------  storeProgress :: MonadLsp config m => ProgressToken -> Async a -> m ()-storeProgress n a = do-  let f = Map.insert n (cancelWith a ProgressCancelledException) . progressCancel-  modifyState $ \ctx -> ctx { resProgressData = (resProgressData ctx) { progressCancel = f (resProgressData ctx)}}+storeProgress n a = modifyState (progressCancel . resProgressData) $ Map.insert n (cancelWith a ProgressCancelledException) +{-# INLINE storeProgress #-}+ deleteProgress :: MonadLsp config m => ProgressToken -> m ()-deleteProgress n = do-  let f = Map.delete n . progressCancel-  modifyState $ \ctx -> ctx { resProgressData = (resProgressData ctx) { progressCancel = f (resProgressData ctx)}}+deleteProgress n = modifyState (progressCancel . resProgressData) $ Map.delete n +{-# INLINE deleteProgress #-}+ -- Get a new id for the progress session and make a new one getNewProgressId :: MonadLsp config m => m ProgressToken getNewProgressId = do-  stateState $ \ctx@LanguageContextState{resProgressData} ->-    let x = progressNextId resProgressData-        ctx' = ctx { resProgressData = resProgressData { progressNextId = x + 1 }}-    in (ProgressNumericToken x, ctx')+  stateState (progressNextId . resProgressData) $ \cur ->+    let !next = cur+1+    in (ProgressNumericToken cur, next) +{-# INLINE getNewProgressId #-}+ withProgressBase :: MonadLsp c m => Bool -> Text -> ProgressCancellable -> ((ProgressAmount -> m ()) -> m a) -> m a withProgressBase indefinite title cancellable f = do @@ -595,7 +621,7 @@             -- An error ocurred when the client was setting it up             -- No need to do anything then, as per the spec             Left _err -> pure ()-            Right () -> pure ()+            Right Empty -> pure ()    -- Send the begin and done notifications via 'bracket_' so that they are always fired   res <- withRunInIO $ \runInBase ->@@ -629,6 +655,8 @@   (J.WindowClientCapabilities mProgress) <- wc   mProgress +{-# INLINE clientSupportsProgress #-}+ -- | Wrapper for reporting progress to the client during a long running -- task. -- 'withProgress' @title cancellable f@ starts a new progress reporting@@ -662,15 +690,14 @@ -- by source, and sends a @textDocument/publishDiagnostics@ notification with -- the total (limited by the first parameter) whenever it is updated. publishDiagnostics :: MonadLsp config m => Int -> NormalizedUri -> TextDocumentVersion -> DiagnosticsBySource -> m ()-publishDiagnostics maxDiagnosticCount uri version diags = join $ stateState $ \ctx ->-  let ds = updateDiagnostics (resDiagnostics ctx) uri version diags-      ctx' = ctx{resDiagnostics = ds}-      mdp = getDiagnosticParamsFor maxDiagnosticCount ds uri+publishDiagnostics maxDiagnosticCount uri version diags = join $ stateState resDiagnostics $ \oldDiags->+  let !newDiags = updateDiagnostics oldDiags uri version diags+      mdp = getDiagnosticParamsFor maxDiagnosticCount newDiags uri       act = case mdp of         Nothing -> return ()         Just params ->           sendToClient $ J.fromServerNot $ J.NotificationMessage "2.0" J.STextDocumentPublishDiagnostics params-      in (act,ctx')+      in (act,newDiags)  -- --------------------------------------------------------------------- @@ -678,17 +705,16 @@ -- the client. flushDiagnosticsBySource :: MonadLsp config m => Int -- ^ Max number of diagnostics to send                          -> Maybe DiagnosticSource -> m ()-flushDiagnosticsBySource maxDiagnosticCount msource = join $ stateState $ \ctx ->-  let ds = flushBySource (resDiagnostics ctx) msource-      ctx' = ctx {resDiagnostics = ds}+flushDiagnosticsBySource maxDiagnosticCount msource = join $ stateState resDiagnostics $ \oldDiags ->+  let !newDiags = flushBySource oldDiags msource       -- Send the updated diagnostics to the client-      act = forM_ (HM.keys ds) $ \uri -> do-        let mdp = getDiagnosticParamsFor maxDiagnosticCount ds uri+      act = forM_ (HM.keys newDiags) $ \uri -> do+        let mdp = getDiagnosticParamsFor maxDiagnosticCount newDiags uri         case mdp of           Nothing -> return ()           Just params -> do             sendToClient $ J.fromServerNot $ J.NotificationMessage "2.0" J.STextDocumentPublishDiagnostics params-      in (act,ctx')+      in (act,newDiags)  -- ===================================================================== --@@ -734,7 +760,7 @@ -- | The changes in a workspace edit should be applied from the end of the file -- toward the start. Sort them into this order. reverseSortEdit :: J.WorkspaceEdit -> J.WorkspaceEdit-reverseSortEdit (J.WorkspaceEdit cs dcs) = J.WorkspaceEdit cs' dcs'+reverseSortEdit (J.WorkspaceEdit cs dcs anns) = J.WorkspaceEdit cs' dcs' anns   where     cs' :: Maybe J.WorkspaceEditMap     cs' = (fmap . fmap ) sortTextEdits cs@@ -743,12 +769,14 @@     dcs' = (fmap . fmap) sortOnlyTextDocumentEdits dcs      sortTextEdits :: J.List J.TextEdit -> J.List J.TextEdit-    sortTextEdits (J.List edits) = J.List (L.sortBy down edits)+    sortTextEdits (J.List edits) = J.List (L.sortOn (Down . (^. J.range)) edits)      sortOnlyTextDocumentEdits :: J.DocumentChange -> J.DocumentChange     sortOnlyTextDocumentEdits (J.InL (J.TextDocumentEdit td (J.List edits))) = J.InL $ J.TextDocumentEdit td (J.List edits')       where-        edits' = L.sortBy down edits+        edits' = L.sortOn (Down . editRange) edits     sortOnlyTextDocumentEdits (J.InR others) = J.InR others -    down (J.TextEdit r1 _) (J.TextEdit r2 _) = r2 `compare` r1+    editRange :: J.TextEdit J.|? J.AnnotatedTextEdit -> J.Range+    editRange (J.InR e) = e ^. J.range+    editRange (J.InL e) = e ^. J.range

@@ -6,6 +6,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} module Language.LSP.Server.Processing where @@ -37,21 +38,21 @@ import qualified Data.Dependent.Map as DMap import Data.Maybe import Data.Dependent.Map (DMap)-import qualified Data.Map as Map+import qualified Data.Map.Strict as Map import System.Exit  processMessage :: BSL.ByteString -> LspM config () processMessage jsonStr = do-  tvarDat <- LspT $ asks resState+  pendingResponsesVar <- LspT $ asks $ resPendingResponses . resState   join $ liftIO $ atomically $ fmap handleErrors $ runExceptT $ do       val <- except $ eitherDecode jsonStr-      ctx <- lift   $ readTVar tvarDat-      msg <- except $ parseEither (parser $ resPendingResponses ctx) val+      pending <- lift $ readTVar pendingResponsesVar+      msg <- except $ parseEither (parser pending) val       lift $ case msg of         FromClientMess m mess ->           pure $ handle m mess-        FromClientRsp (Pair (ServerResponseCallback f) (Const newMap)) res -> do-          modifyTVar' tvarDat (\c -> c { resPendingResponses = newMap })+        FromClientRsp (Pair (ServerResponseCallback f) (Const !newMap)) res -> do+          writeTVar pendingResponsesVar newMap           pure $ liftIO $ f (res ^. LSP.result)   where     parser :: ResponseMap -> Value -> Parser (FromClientMessage' (Product ServerResponseCallback (Const ResponseMap)))@@ -62,7 +63,7 @@     handleErrors = either (sendErrorLog . errMsg) id      errMsg err = TL.toStrict $ TL.unwords-      [ "haskell-lsp:incoming message parse error."+      [ "lsp:incoming message parse error."       , TL.decodeUtf8 jsonStr       , TL.pack err       ] <> "\n"@@ -96,20 +97,27 @@           Just (List xs) -> xs           Nothing -> [] -    tvarCtx <- liftIO $ newTVarIO $-      LanguageContextState-        (VFSData vfs mempty)-        mempty-        Nothing-        initialWfs-        defaultProgressData-        emptyIxMap-        mempty-        mempty-        0+        initialConfig = case onConfigurationChange defaultConfig <$> (req ^. LSP.params . LSP.initializationOptions) of+          Just (Right newConfig) -> newConfig+          _ -> defaultConfig +    stateVars <- liftIO $ do+      resVFS              <- newTVarIO (VFSData vfs mempty)+      resDiagnostics      <- newTVarIO mempty+      resConfig           <- newTVarIO initialConfig+      resWorkspaceFolders <- newTVarIO initialWfs+      resProgressData     <- do+        progressNextId <- newTVarIO 0+        progressCancel <- newTVarIO mempty+        pure ProgressData{..}+      resPendingResponses <- newTVarIO emptyIxMap+      resRegistrationsNot <- newTVarIO mempty+      resRegistrationsReq <- newTVarIO mempty+      resLspId            <- newTVarIO 0+      pure LanguageContextState{..}+     -- 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 stateVars (params ^. LSP.capabilities) rootDir         handlers = transmuteHandlers interpreter staticHandlers         interpreter = interpretHandler initializationResult     initializationResult <- ExceptT $ doInitialize env req@@ -202,9 +210,9 @@      codeActionProvider       | clientSupportsCodeActionKinds-      , supported_b STextDocumentCodeAction = Just $-          maybe (InL True) (InR . CodeActionOptions Nothing . Just . List)-                (codeActionKinds o)+      , supported_b STextDocumentCodeAction = Just $ case codeActionKinds o of+          Just ks -> InR $ CodeActionOptions Nothing (Just (List ks)) (supported SCodeLensResolve)+          Nothing -> InL True       | supported_b STextDocumentCodeAction = Just (InL True)       | otherwise = Just (InL False) @@ -302,7 +310,7 @@       Nothing         | SShutdown <- m -> liftIO $ shutdownRequestHandler msg (mkRspCb msg)         | otherwise -> do-            let errorMsg = T.pack $ unwords ["haskell-lsp:no handler for: ", show m]+            let errorMsg = T.pack $ unwords ["lsp:no handler for: ", show m]                 err = ResponseError MethodNotFound errorMsg Nothing             sendToClient $               FromServerRsp (msg ^. LSP.method) $ ResponseMessage "2.0" (Just (msg ^. LSP.id)) (Left err)@@ -314,7 +322,7 @@       ReqMess req -> case pickHandler dynReqHandlers reqHandlers of         Just h -> liftIO $ h req (mkRspCb req)         Nothing -> do-          let errorMsg = T.pack $ unwords ["haskell-lsp:no handler for: ", show m]+          let errorMsg = T.pack $ unwords ["lsp:no handler for: ", show m]               err = ResponseError MethodNotFound errorMsg Nothing           sendToClient $             FromServerRsp (req ^. LSP.method) $ ResponseMessage "2.0" (Just (req ^. LSP.id)) (Left err)@@ -334,7 +342,7 @@     reportMissingHandler       | isOptionalNotification m = return ()       | otherwise = do-          let errorMsg = T.pack $ unwords ["haskell-lsp:no handler for: ", show m]+          let errorMsg = T.pack $ unwords ["lsp:no handler for: ", show m]           sendErrorLog errorMsg     isOptionalNotification (SCustomMethod method)       | "$/" `T.isPrefixOf` method = True@@ -342,7 +350,7 @@  progressCancelHandler :: Message WindowWorkDoneProgressCancel -> LspM config () progressCancelHandler (NotificationMessage _ _ (WorkDoneProgressCancelParams tid)) = do-  mact <- getsState $ Map.lookup tid . progressCancel . resProgressData+  mact <- Map.lookup tid <$> getsState (progressCancel . resProgressData)   case mact of     Nothing -> return ()     Just cancelAction -> liftIO $ cancelAction@@ -357,25 +365,24 @@ 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 resConfig $ \oldConfig -> case parseConfig oldConfig (req ^. LSP.params . LSP.settings) of+    Left err -> (Left err, oldConfig)+    Right !newConfig -> (Right (), newConfig)   case res of     Left err -> do       let msg = T.pack $ unwords-            ["haskell-lsp:configuration parse error.", show req, show err]+            ["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-  join $ stateState $ \ctx@LanguageContextState{resVFS = VFSData vfs rm} ->-    let (vfs', ls) = modifyVfs vfs req-    in (liftIO $ mapM_ (debugM "haskell-lsp.vfsFunc") ls,ctx{ resVFS = VFSData vfs' rm})+  join $ stateState resVFS $ \(VFSData vfs rm) ->+    let (!vfs', ls) = modifyVfs vfs req+    in (liftIO $ mapM_ (debugM "lsp.vfsFunc") ls,VFSData vfs' rm)  -- | Updates the list of workspace folders updateWorkspaceFolders :: Message WorkspaceDidChangeWorkspaceFolders -> LspM config ()@@ -383,7 +390,7 @@   let List toRemove = params ^. LSP.event . LSP.removed       List toAdd = params ^. LSP.event . LSP.added       newWfs oldWfs = foldr delete oldWfs toRemove <> toAdd-  modifyState $ \c -> c {resWorkspaceFolders = newWfs $ resWorkspaceFolders c}+  modifyState resWorkspaceFolders newWfs  -- --------------------------------------------------------------------- 

@@ -8,9 +8,9 @@ spec = describe "capabilities" $ do   it "gives 3.10 capabilities" $     let ClientCapabilities _ (Just tdcs) _ _ = capsForVersion (LSPVersion 3 10)-        Just (DocumentSymbolClientCapabilities _ _ mHierarchical) = _documentSymbol tdcs+        Just (DocumentSymbolClientCapabilities _ _ mHierarchical _ _ ) = _documentSymbol tdcs       in mHierarchical `shouldBe` Just True   it "gives pre 3.10 capabilities" $       let ClientCapabilities _ (Just tdcs) _ _ = capsForVersion (LSPVersion 3 9)-          Just (DocumentSymbolClientCapabilities _ _ mHierarchical) = _documentSymbol tdcs+          Just (DocumentSymbolClientCapabilities _ _ mHierarchical _ _) = _documentSymbol tdcs         in mHierarchical `shouldBe` Nothing

@@ -52,8 +52,8 @@     it "CompletionItem" $       (J.decode "{\"jsonrpc\":\"2.0\",\"result\":[{\"label\":\"raisebox\"}],\"id\":1}" :: Maybe (ResponseMessage 'TextDocumentCompletion))         `shouldNotBe` Nothing-   + responseMessageSpec :: Spec responseMessageSpec = do   describe "edge cases" $ do@@ -61,15 +61,18 @@       let input = "{\"jsonrpc\": \"2.0\", \"id\": 123, \"result\": null}"         in  J.decode input `shouldBe` Just               ((ResponseMessage "2.0" (Just (IdInt 123)) (Right J.Null)) :: ResponseMessage 'WorkspaceExecuteCommand)+    it "handles missing params field" $ do+      J.eitherDecode "{ \"jsonrpc\": \"2.0\", \"id\": 15, \"method\": \"shutdown\"}"+        `shouldBe` Right (RequestMessage "2.0" (IdInt 15) SShutdown Empty)   describe "invalid JSON" $ do     it "throws if neither result nor error is present" $ do-      (J.eitherDecode "{\"jsonrpc\":\"2.0\",\"id\":1}" :: Either String (ResponseMessage 'Initialize)) -        `shouldBe` Left ("Error in $: both error and result cannot be Nothing") +      (J.eitherDecode "{\"jsonrpc\":\"2.0\",\"id\":1}" :: Either String (ResponseMessage 'Initialize))+        `shouldBe` Left ("Error in $: both error and result cannot be Nothing")     it "throws if both result and error are present" $ do-      (J.eitherDecode -        "{\"jsonrpc\":\"2.0\",\"id\": 1,\"result\":{\"capabilities\": {}},\"error\":{\"code\":-32700,\"message\":\"\",\"data\":null}}" -        :: Either String (ResponseMessage 'Initialize)) -        `shouldSatisfy` +      (J.eitherDecode+        "{\"jsonrpc\":\"2.0\",\"id\": 1,\"result\":{\"capabilities\": {}},\"error\":{\"code\":-32700,\"message\":\"\",\"data\":null}}"+        :: Either String (ResponseMessage 'Initialize))+        `shouldSatisfy`           (either (\err -> "Error in $: both error and result cannot be present" `isPrefixOf` err) (\_ -> False))  -- ---------------------------------------------------------------------@@ -100,7 +103,7 @@   arbitrary = Uri <$> arbitrary  instance Arbitrary Position where-  arbitrary = Position <$> arbitrary <*> arbitrary +  arbitrary = Position <$> arbitrary <*> arbitrary  instance Arbitrary Location where   arbitrary = Location <$> arbitrary <*> arbitrary@@ -171,5 +174,5 @@  instance Arbitrary WatchKind where   arbitrary = WatchKind <$> arbitrary <*> arbitrary <*> arbitrary-  + -- ---------------------------------------------------------------------

@@ -16,6 +16,9 @@     it "edits a multiline text" $       let te = TextEdit (Range (Position 1 0) (Position 2 0)) "slorem"         in applyTextEdit te "lorem\nipsum\ndolor" `shouldBe` "lorem\nsloremdolor"+    it "inserts text past the last line" $+      let te = TextEdit (Range (Position 3 2) (Position 3 2)) "foo"+        in applyTextEdit te "lorem\nipsum\ndolor" `shouldBe` "lorem\nipsum\ndolorfoo"    describe "editTextEdit" $     it "edits a multiline text edit" $