X-Git-Url: http://git.lukelau.me/?p=lsp-test.git;a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FSession.hs;h=a58496d5234dff41854b0f5baba401658daeffc7;hp=10f63b245fb0e5bf93f7b6a9f0d54ec0b27837c1;hb=7ee14165e9d2ebcc171716d41e3e207444c418b3;hpb=f8ee63f1c1d245c16f7a928c14c0e8908e6240c8 diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs index 10f63b2..a58496d 100644 --- a/src/Language/Haskell/LSP/Test/Session.hs +++ b/src/Language/Haskell/LSP/Test/Session.hs @@ -13,6 +13,7 @@ module Language.Haskell.LSP.Test.Session , get , put , modify + , modifyM , ask , asks , sendMessage @@ -34,6 +35,7 @@ import Control.Monad.Trans.State (StateT, runStateT) import qualified Control.Monad.Trans.State as State (get, put) import qualified Data.ByteString.Lazy.Char8 as B import Data.Aeson +import Data.Aeson.Encode.Pretty import Data.Conduit as Conduit import Data.Conduit.Parser as Parser import Data.Default @@ -44,8 +46,9 @@ import qualified Data.Text as T 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.TH.ClientCapabilities +import Language.Haskell.LSP.Types.Capabilities import Language.Haskell.LSP.Types hiding (error) import Language.Haskell.LSP.VFS import Language.Haskell.LSP.Test.Decoding @@ -70,13 +73,13 @@ type Session = ParserStateReader FromServerMessage SessionState SessionContext I -- | Stuff you can configure for a 'Session'. data SessionConfig = SessionConfig { - capabilities :: ClientCapabilities -- ^ Specific capabilities the client should advertise. Default is yes to everything. - , messageTimeout :: Int -- ^ Maximum time to wait for a message in seconds. Defaults to 60. - , logStdErr :: Bool -- ^ When True redirects the servers stderr output to haskell-lsp-test's stdout. Defaults to False + messageTimeout :: Int -- ^ Maximum time to wait for a message in seconds. Defaults to 60. + , logStdErr :: Bool -- ^ When True redirects the servers stderr output to haskell-lsp-test's stdout. Defaults to False. + , logMessages :: Bool -- ^ When True traces the communication between client and server to stdout. Defaults to True. } instance Default SessionConfig where - def = SessionConfig def 60 False + def = SessionConfig 60 False True data SessionMessage = ServerMessage FromServerMessage | TimeoutMessage Int @@ -90,6 +93,7 @@ data SessionContext = SessionContext , requestMap :: MVar RequestMap , initRsp :: MVar InitializeResponse , config :: SessionConfig + , sessionCapabilities :: ClientCapabilities } class Monad m => HasReader r m where @@ -123,6 +127,9 @@ class Monad m => HasState s m where modify :: (s -> s) -> m () modify f = get >>= put . f + modifyM :: (HasState s m, Monad m) => (s -> m s) -> m () + modifyM f = get >>= f >>= put + instance Monad m => HasState s (ParserStateReader a s r m) where get = lift State.get put = lift . State.put @@ -135,16 +142,14 @@ instance Monad m => HasState SessionState (ConduitM a b (StateT SessionState m)) type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m)) runSession :: SessionContext -> SessionState -> Session a -> IO (a, SessionState) -runSession context state session = - -- source <- sourceList <$> getChanContents (messageChan context) - runReaderT (runStateT conduit state) context +runSession context state session = runReaderT (runStateT conduit state) context where conduit = runConduit $ chanSource .| watchdog .| updateStateC .| runConduitParser (catchError session handler) handler (Unexpected "ConduitParser.empty") = do lastMsg <- fromJust . lastReceivedMessage <$> get name <- getParserName - liftIO $ throw (UnexpectedMessageException (T.unpack name) lastMsg) + liftIO $ throw (UnexpectedMessage (T.unpack name) lastMsg) handler e = throw e @@ -159,7 +164,7 @@ runSession context state session = curId <- curTimeoutId <$> get case msg of ServerMessage sMsg -> yield sMsg - TimeoutMessage tId -> when (curId == tId) $ throw TimeoutException + TimeoutMessage tId -> when (curId == tId) $ throw Timeout -- | An internal version of 'runSession' that allows for a custom handler to listen to the server. -- It also does not automatically send initialize and exit messages. @@ -167,10 +172,11 @@ runSessionWithHandles :: Handle -- ^ Server in -> Handle -- ^ Server out -> (Handle -> SessionContext -> IO ()) -- ^ Server listener -> SessionConfig - -> FilePath + -> ClientCapabilities + -> FilePath -- ^ Root directory -> Session a -> IO a -runSessionWithHandles serverIn serverOut serverHandler config rootDir session = do +runSessionWithHandles serverIn serverOut serverHandler config caps rootDir session = do absRootDir <- canonicalizePath rootDir hSetBuffering serverIn NoBuffering @@ -180,7 +186,7 @@ runSessionWithHandles serverIn serverOut serverHandler config rootDir session = messageChan <- newChan initRsp <- newEmptyMVar - let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config + let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config caps initState = SessionState (IdInt 0) mempty mempty 0 False Nothing threadId <- forkIO $ void $ serverHandler serverOut context @@ -215,9 +221,9 @@ updateState (ReqApplyWorkspaceEdit r) = do return $ concatMap (uncurry getChangeParams) (HashMap.toList cs) Nothing -> error "No changes!" - oldVFS <- vfs <$> get - newVFS <- liftIO $ changeFromServerVFS oldVFS r - modify (\s -> s { vfs = newVFS }) + modifyM $ \s -> do + newVFS <- liftIO $ changeFromServerVFS (vfs s) r + return $ s { vfs = newVFS } let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) allChangeParams mergedParams = map mergeParams groupedParams @@ -225,6 +231,18 @@ updateState (ReqApplyWorkspaceEdit r) = do -- TODO: Don't do this when replaying a session forM_ mergedParams (sendMessage . NotificationMessage "2.0" TextDocumentDidChange) + -- Update VFS to new document versions + let sortedVersions = map (sortBy (compare `on` (^. textDocument . version))) groupedParams + latestVersions = map ((^. textDocument) . last) sortedVersions + bumpedVersions = map (version . _Just +~ 1) latestVersions + + forM_ bumpedVersions $ \(VersionedTextDocumentIdentifier uri v) -> + modify $ \s -> + let oldVFS = vfs s + update (VirtualFile oldV t) = VirtualFile (fromMaybe oldV v) t + newVFS = Map.adjust update uri oldVFS + in s { vfs = newVFS } + where checkIfNeedsOpened uri = do oldVFS <- vfs <$> get ctx <- ask @@ -237,15 +255,15 @@ updateState (ReqApplyWorkspaceEdit r) = do msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item) liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg) - oldVFS <- vfs <$> get - newVFS <- liftIO $ openVFS oldVFS msg - modify (\s -> s { vfs = newVFS }) + modifyM $ \s -> do + newVFS <- liftIO $ openVFS (vfs s) msg + return $ s { vfs = newVFS } getParams (TextDocumentEdit docId (List edits)) = let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits in DidChangeTextDocumentParams docId (List changeEvents) - textDocumentVersions uri = map (VersionedTextDocumentIdentifier uri) [0..] + textDocumentVersions uri = map (VersionedTextDocumentIdentifier uri . Just) [0..] textDocumentEdits uri edits = map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip (textDocumentVersions uri) edits @@ -259,10 +277,12 @@ updateState _ = return () sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m () sendMessage msg = do h <- serverIn <$> ask - let encoded = encode msg - liftIO $ do + let encoded = encodePretty msg + + shouldLog <- asks $ logMessages . config + liftIO $ when shouldLog $ do - setSGR [SetColor Foreground Vivid Cyan] + setSGR [SetColor Foreground Dull Cyan] putStrLn $ "--> " ++ B.unpack encoded setSGR [Reset]