From: Luke Lau Date: Wed, 20 Jun 2018 16:37:32 +0000 (+0100) Subject: Handle text document change events with VFS X-Git-Url: http://git.lukelau.me/?p=opengl.git;a=commitdiff_plain;h=2ed0dbaf1233ec79ed0801b406ae9fbf4e36e8a4 Handle text document change events with VFS --- diff --git a/haskell-lsp-test.cabal b/haskell-lsp-test.cabal index 9fb63a3..51f5fb9 100644 --- a/haskell-lsp-test.cabal +++ b/haskell-lsp-test.cabal @@ -35,6 +35,7 @@ library , text , transformers , unordered-containers + , yi-rope if os(windows) build-depends: Win32 else diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs index 047e35b..b2d731e 100644 --- a/src/Language/Haskell/LSP/Test.hs +++ b/src/Language/Haskell/LSP/Test.hs @@ -57,12 +57,12 @@ module Language.Haskell.LSP.Test , getInitializeResponse , openDoc , getDocItem + , documentContents , getDocUri ) where import Control.Applicative import Control.Applicative.Combinators -import Control.Monad import Control.Monad.IO.Class import Control.Concurrent import Control.Lens hiding ((.=), List) @@ -71,12 +71,10 @@ import qualified Data.Text.IO as T import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as B import Data.Default -import Data.Foldable -import qualified Data.HashMap.Strict as HashMap -import Data.List +import qualified Data.Map as Map +import Data.Maybe import Language.Haskell.LSP.Types import qualified Language.Haskell.LSP.Types as LSP (error, id) -import Language.Haskell.LSP.Messages import Language.Haskell.LSP.VFS import Language.Haskell.LSP.Test.Compat import Language.Haskell.LSP.Test.Decoding @@ -86,6 +84,7 @@ import Language.Haskell.LSP.Test.Server import System.IO import System.Directory import System.FilePath +import qualified Yi.Rope as Rope -- | Starts a new session. runSession :: String -- ^ The command to run the server. @@ -133,38 +132,16 @@ listenServer serverOut = do reqMap <- liftIO $ readMVar $ requestMap context let msg = decodeFromServerMsg reqMap msgBytes - processTextChanges msg liftIO $ writeChan (messageChan context) msg listenServer serverOut -processTextChanges :: FromServerMessage -> Session () -processTextChanges (ReqApplyWorkspaceEdit r) = do - List changeParams <- case r ^. params . edit . documentChanges of - Just cs -> mapM applyTextDocumentEdit cs - Nothing -> case r ^. params . edit . changes of - Just cs -> mapM (uncurry applyTextEdit) (List (HashMap.toList cs)) - Nothing -> return (List []) - - let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) changeParams - mergedParams = map mergeParams groupedParams - - forM_ mergedParams (sendNotification TextDocumentDidChange) - - where applyTextDocumentEdit (TextDocumentEdit docId (List edits)) = do - oldVFS <- vfs <$> get - let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits - params = DidChangeTextDocumentParams docId (List changeEvents) - newVFS <- liftIO $ changeVFS oldVFS (fmClientDidChangeTextDocumentNotification params) - modify (\s -> s { vfs = newVFS }) - return params - - applyTextEdit uri edits = applyTextDocumentEdit (TextDocumentEdit (VersionedTextDocumentIdentifier uri 0) edits) - - mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams - mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params)) - in DidChangeTextDocumentParams (head params ^. textDocument) (List events) -processTextChanges _ = return () +-- | The current text contents of a document. +documentContents :: TextDocumentIdentifier -> Session T.Text +documentContents doc = do + vfs <- vfs <$> get + let file = vfs Map.! (doc ^. uri) + return $ Rope.toText $ Language.Haskell.LSP.VFS._text file -- | Sends a request to the server. -- @@ -221,9 +198,18 @@ sendNotification :: ToJSON a => ClientMethod -- ^ The notification method. -> a -- ^ The notification parameters. -> Session () -sendNotification method params = - let notif = NotificationMessage "2.0" method params - in sendNotification' notif + +-- | Open a virtual file if we send a did open text document notification +sendNotification TextDocumentDidOpen params = do + let params' = fromJust $ decode $ encode params + n :: DidOpenTextDocumentNotification + n = NotificationMessage "2.0" TextDocumentDidOpen params' + oldVFS <- vfs <$> get + newVFS <- liftIO $ openVFS oldVFS n + modify (\s -> s { vfs = newVFS }) + sendNotification' n + +sendNotification method params = sendNotification' (NotificationMessage "2.0" method params) sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session () sendNotification' = sendMessage @@ -265,3 +251,4 @@ getDocUri file = do context <- ask let fp = rootDir context file return $ filePathToUri fp + diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs index 3707dfd..db8bef5 100644 --- a/src/Language/Haskell/LSP/Test/Session.hs +++ b/src/Language/Haskell/LSP/Test/Session.hs @@ -1,12 +1,33 @@ -module Language.Haskell.LSP.Test.Session where - -import Control.Concurrent +{-# LANGUAGE OverloadedStrings #-} + +module Language.Haskell.LSP.Test.Session + ( Session + , SessionState(..) + , SessionContext(..) + , runSessionWithHandles + , get + , put + , modify + , ask) + +where + +import Control.Concurrent hiding (yield) +import Control.Lens hiding (List) import Control.Monad +import Control.Monad.IO.Class import Control.Monad.Trans.Class -import Control.Monad.Trans.Reader -import Control.Monad.Trans.State +import Control.Monad.Trans.Reader (ReaderT, runReaderT) +import qualified Control.Monad.Trans.Reader as Reader (ask) +import Control.Monad.Trans.State (StateT, runStateT) +import qualified Control.Monad.Trans.State as State (get, put, modify) +import qualified Data.ByteString.Lazy.Char8 as B +import Data.Aeson import Data.Conduit import Data.Conduit.Parser +import Data.Foldable +import Data.List +import qualified Data.HashMap.Strict as HashMap import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types import Language.Haskell.LSP.VFS @@ -45,24 +66,23 @@ type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m)) -- @ type Session = ParserStateReader FromServerMessage SessionState SessionContext IO +type SessionProcessor = ConduitT FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) -runSession' :: Chan FromServerMessage -> SessionContext -> SessionState -> Session a -> IO (a, SessionState) -runSession' chan context state session = runReaderT (runStateT conduit state) context - where conduit = runConduit $ chanSource chan .| runConduitParser session +runSession' :: Chan FromServerMessage -> SessionProcessor () -> SessionContext -> SessionState -> Session a -> IO (a, SessionState) +runSession' chan preprocessor context state session = runReaderT (runStateT conduit state) context + where conduit = runConduit $ chanSource chan .| preprocessor .| runConduitParser session get :: Monad m => ParserStateReader a s r m s -get = lift Control.Monad.Trans.State.get +get = lift State.get put :: Monad m => s -> ParserStateReader a s r m () -put = lift . Control.Monad.Trans.State.put +put = lift . State.put modify :: Monad m => (s -> s) -> ParserStateReader a s r m () -modify = lift . Control.Monad.Trans.State.modify +modify = lift . State.modify ask :: Monad m => ParserStateReader a s r m r -ask = lift $ lift Control.Monad.Trans.Reader.ask - - +ask = lift $ lift Reader.ask -- | 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. @@ -84,11 +104,48 @@ runSessionWithHandles serverIn serverOut serverHandler rootDir session = do initRsp <- newEmptyMVar let context = SessionContext serverIn absRootDir messageChan reqMap initRsp - initState = SessionState (IdInt 9) mempty + initState = SessionState (IdInt 0) mempty - threadId <- forkIO $ void $ runSession' meaninglessChan context initState (serverHandler serverOut) - (result, _) <- runSession' messageChan context initState session + threadId <- forkIO $ void $ runSession' meaninglessChan processor context initState (serverHandler serverOut) + (result, _) <- runSession' messageChan processor context initState session killThread threadId return result + + where processor :: SessionProcessor () + processor = awaitForever $ \msg -> do + processTextChanges msg + yield msg + + +processTextChanges :: FromServerMessage -> SessionProcessor () +processTextChanges (ReqApplyWorkspaceEdit r) = do + List changeParams <- case r ^. params . edit . documentChanges of + Just cs -> mapM applyTextDocumentEdit cs + Nothing -> case r ^. params . edit . changes of + Just cs -> mapM (uncurry applyTextEdit) (List (HashMap.toList cs)) + Nothing -> return (List []) + + let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) changeParams + mergedParams = map mergeParams groupedParams + + forM_ mergedParams $ \p -> do + h <- serverIn <$> lift (lift Reader.ask) + let msg = NotificationMessage "2.0" TextDocumentDidChange p + liftIO $ B.hPut h $ addHeader (encode msg) + + where applyTextDocumentEdit (TextDocumentEdit docId (List edits)) = do + oldVFS <- vfs <$> lift State.get + let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits + params = DidChangeTextDocumentParams docId (List changeEvents) + newVFS <- liftIO $ changeVFS oldVFS (fmClientDidChangeTextDocumentNotification params) + lift $ State.modify (\s -> s { vfs = newVFS }) + return params + + applyTextEdit uri edits = applyTextDocumentEdit (TextDocumentEdit (VersionedTextDocumentIdentifier uri 0) edits) + + mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams + mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params)) + in DidChangeTextDocumentParams (head params ^. textDocument) (List events) +processTextChanges _ = return () \ No newline at end of file diff --git a/test/Test.hs b/test/Test.hs index 8f71533..d615cb9 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -88,6 +88,9 @@ main = hspec $ do checkNoDiagnostics + contents <- documentContents doc + liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42" + parsingSpec data ApplyOneParams = AOP