X-Git-Url: https://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FSession.hs;h=4ee9cf98185f4259d7ca9c0b20ffce62524f091a;hb=98ff10016bbd4eda3534ba04edcbc6e2ab9fd197;hp=ddd07a5da6693cc3ccc27bd0845df8cd7b58734d;hpb=af401b6d0439751d73ea230a219f37eb57286c90;p=lsp-test.git diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs index ddd07a5..4ee9cf9 100644 --- a/src/Language/Haskell/LSP/Test/Session.hs +++ b/src/Language/Haskell/LSP/Test/Session.hs @@ -54,6 +54,7 @@ import Data.Default import Data.Foldable import Data.List import qualified Data.Map as Map +import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Data.HashMap.Strict as HashMap @@ -63,6 +64,7 @@ import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types.Capabilities import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Lens +import qualified Language.Haskell.LSP.Types.Lens as LSP import Language.Haskell.LSP.VFS import Language.Haskell.LSP.Test.Compat import Language.Haskell.LSP.Test.Decoding @@ -71,6 +73,9 @@ import System.Console.ANSI import System.Directory import System.IO import System.Process (ProcessHandle()) +#ifndef mingw32_HOST_OS +import System.Process (waitForProcess) +#endif import System.Timeout -- | A session representing one instance of launching and connecting to a server. @@ -163,6 +168,10 @@ data SessionState = SessionState -- ^ The last received message from the server. -- Used for providing exception information , lastReceivedMessage :: Maybe FromServerMessage + , curDynCaps :: Map.Map T.Text Registration + -- ^ The capabilities that the server has dynamically registered with us so + -- far + , curProgressSessions :: Set.Set ProgressToken } class Monad m => HasState s m where @@ -253,17 +262,25 @@ runSessionWithHandles serverIn serverOut serverProc serverHandler config caps ro mainThreadId <- myThreadId let context = SessionContext serverIn absRootDir messageChan timeoutIdVar reqMap initRsp config caps - initState vfs = SessionState (IdInt 0) vfs mempty False Nothing + initState vfs = SessionState (IdInt 0) vfs mempty False Nothing mempty mempty runSession' ses = initVFS $ \vfs -> runSession context (initState vfs) ses errorHandler = throwTo mainThreadId :: SessionException -> IO () serverListenerLauncher = forkIO $ catch (serverHandler serverOut context) errorHandler server = (Just serverIn, Just serverOut, Nothing, serverProc) + msgTimeoutMs = messageTimeout config * 10^6 serverAndListenerFinalizer tid = do - finally (timeout (messageTimeout config * 1^6) - (runSession' exitServer)) - (cleanupProcess server >> killThread tid) + finally (timeout msgTimeoutMs (runSession' exitServer)) $ do + -- Make sure to kill the listener first, before closing + -- handles etc via cleanupProcess + killThread tid + -- Give the server some time to exit cleanly + -- It makes the server hangs in windows so we have to avoid it +#ifndef mingw32_HOST_OS + timeout msgTimeoutMs (waitForProcess serverProc) +#endif + cleanupProcess server (result, _) <- bracket serverListenerLauncher serverAndListenerFinalizer @@ -277,24 +294,44 @@ updateStateC = awaitForever $ \msg -> do updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m) => FromServerMessage -> m () +updateState (NotWorkDoneProgressBegin req) = + modify $ \s -> s { curProgressSessions = Set.insert (req ^. params . token) $ curProgressSessions s } +updateState (NotWorkDoneProgressEnd req) = + modify $ \s -> s { curProgressSessions = Set.delete (req ^. params . token) $ curProgressSessions s } + +-- Keep track of dynamic capability registration +updateState (ReqRegisterCapability req) = do + let List newRegs = (\r -> (r ^. LSP.id, r)) <$> req ^. params . registrations + modify $ \s -> + s { curDynCaps = Map.union (Map.fromList newRegs) (curDynCaps s) } + +updateState (ReqUnregisterCapability req) = do + let List unRegs = (^. LSP.id) <$> req ^. params . unregistrations + modify $ \s -> + let newCurDynCaps = foldr' Map.delete (curDynCaps s) unRegs + in s { curDynCaps = newCurDynCaps } + updateState (NotPublishDiagnostics n) = do let List diags = n ^. params . diagnostics doc = n ^. params . uri - modify (\s -> + modify $ \s -> let newDiags = Map.insert (toNormalizedUri doc) diags (curDiagnostics s) - in s { curDiagnostics = newDiags }) + in s { curDiagnostics = newDiags } updateState (ReqApplyWorkspaceEdit r) = do + -- First, prefer the versioned documentChanges field allChangeParams <- case r ^. params . edit . documentChanges of Just (List cs) -> do mapM_ (checkIfNeedsOpened . (^. textDocument . uri)) cs return $ map getParams cs + -- Then fall back to the changes field Nothing -> case r ^. params . edit . changes of Just cs -> do mapM_ checkIfNeedsOpened (HashMap.keys cs) - return $ concatMap (uncurry getChangeParams) (HashMap.toList cs) - Nothing -> error "No changes!" + concat <$> mapM (uncurry getChangeParams) (HashMap.toList cs) + Nothing -> + error "WorkspaceEdit contains neither documentChanges nor changes!" modifyM $ \s -> do newVFS <- liftIO $ changeFromServerVFS (vfs s) r @@ -338,11 +375,20 @@ updateState (ReqApplyWorkspaceEdit r) = do let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits in DidChangeTextDocumentParams docId (List changeEvents) - textDocumentVersions uri = map (VersionedTextDocumentIdentifier uri . Just) [0..] + -- For a uri returns an infinite list of versions [n,n+1,n+2,...] + -- where n is the current version + textDocumentVersions uri = do + m <- vfsMap . vfs <$> get + let curVer = fromMaybe 0 $ + _lsp_version <$> m Map.!? (toNormalizedUri uri) + pure $ map (VersionedTextDocumentIdentifier uri . Just) [curVer + 1..] - textDocumentEdits uri edits = map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip (textDocumentVersions uri) edits + textDocumentEdits uri edits = do + vers <- textDocumentVersions uri + pure $ map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip vers edits - getChangeParams uri (List edits) = map getParams (textDocumentEdits uri (reverse edits)) + getChangeParams uri (List edits) = + map <$> pure getParams <*> textDocumentEdits uri (reverse edits) mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params)) @@ -355,7 +401,7 @@ sendMessage msg = do logMsg LogClient msg liftIO $ B.hPut h (addHeader $ encode msg) --- | Execute a block f that will throw a 'Timeout' exception +-- | Execute a block f that will throw a 'Language.Haskell.LSP.Test.Exception.Timeout' exception -- after duration seconds. This will override the global timeout -- for waiting for messages to arrive defined in 'SessionConfig'. withTimeout :: Int -> Session a -> Session a @@ -393,5 +439,3 @@ logMsg t msg = do | otherwise = Cyan showPretty = B.unpack . encodePretty - -