X-Git-Url: https://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FSession.hs;h=d43d11a1f79b5c2df46285f54e42ea22bc2bf399;hb=98d03792f46f3ac870c010a78944822569e76763;hp=9076a8e5e02e9ed819479a7d10c2f3a2d4ffc21a;hpb=133940df94b1e8745598699a492e5c9534644d75;p=lsp-test.git diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs index 9076a8e..d43d11a 100644 --- a/src/Language/Haskell/LSP/Test/Session.hs +++ b/src/Language/Haskell/LSP/Test/Session.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} @@ -59,7 +60,6 @@ import qualified Data.Text.IO as T import qualified Data.HashMap.Strict as HashMap import Data.Maybe import Data.Function -import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types.Capabilities import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Lens @@ -72,6 +72,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. @@ -157,7 +160,7 @@ bumpTimeoutId prev = do data SessionState = SessionState { - curReqId :: LspId + curReqId :: Int , vfs :: VFS , curDiagnostics :: Map.Map NormalizedUri [Diagnostic] , overridingTimeout :: Bool @@ -216,8 +219,8 @@ runSession context state (Session session) = runReaderT (runStateT conduit state yield msg chanSource - isLogNotification (ServerMessage (NotShowMessage _)) = True - isLogNotification (ServerMessage (NotLogMessage _)) = True + isLogNotification (ServerMessage (FromServerMess SWindowShowMessage _)) = True + isLogNotification (ServerMessage (FromServerMess SWindowLogMessage _)) = True isLogNotification _ = False watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) () @@ -257,23 +260,29 @@ 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 mempty + initState vfs = SessionState 0 vfs mempty False Nothing 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)) + finally (timeout msgTimeoutMs (runSession' exitServer)) $ do -- Make sure to kill the listener first, before closing -- handles etc via cleanupProcess - (killThread tid >> cleanupProcess server) + 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 - (const $ runSession' session) + (const $ initVFS $ \vfs -> runSession context (initState vfs) session) return result updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) () @@ -285,35 +294,38 @@ updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m) => FromServerMessage -> m () -- Keep track of dynamic capability registration -updateState (ReqRegisterCapability req) = do +updateState (FromServerMess SClientRegisterCapability 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 +updateState (FromServerMess SClientUnregisterCapability 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 +updateState (FromServerMess STextDocumentPublishDiagnostics n) = do let List diags = n ^. params . diagnostics doc = n ^. params . uri modify $ \s -> let newDiags = Map.insert (toNormalizedUri doc) diags (curDiagnostics s) in s { curDiagnostics = newDiags } -updateState (ReqApplyWorkspaceEdit r) = do +updateState (FromServerMess SWorkspaceApplyEdit 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 @@ -323,7 +335,7 @@ updateState (ReqApplyWorkspaceEdit r) = do mergedParams = map mergeParams groupedParams -- TODO: Don't do this when replaying a session - forM_ mergedParams (sendMessage . NotificationMessage "2.0" TextDocumentDidChange) + forM_ mergedParams (sendMessage . NotificationMessage "2.0" STextDocumentDidChange) -- Update VFS to new document versions let sortedVersions = map (sortBy (compare `on` (^. textDocument . version))) groupedParams @@ -346,7 +358,7 @@ updateState (ReqApplyWorkspaceEdit r) = do let fp = fromJust $ uriToFilePath uri contents <- liftIO $ T.readFile fp let item = TextDocumentItem (filePathToUri fp) "" 0 contents - msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item) + msg = NotificationMessage "2.0" STextDocumentDidOpen (DidOpenTextDocumentParams item) liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg) modifyM $ \s -> do @@ -357,11 +369,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))