X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FSession.hs;h=0553160aee215862ebb4fbad547f087a9fcbaca6;hb=3581d880c87b59cc4c856aee83f77fea9a38890b;hp=a427137825c7978ad8ba891c406848f66288e2eb;hpb=0f8b9d328f4d950ff0a2e1c3b5aed593b21c2d3a;p=opengl.git diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs index a427137..0553160 100644 --- a/src/Language/Haskell/LSP/Test/Session.hs +++ b/src/Language/Haskell/LSP/Test/Session.hs @@ -11,33 +11,40 @@ module Language.Haskell.LSP.Test.Session , get , put , modify + , modifyM , ask) where import Control.Concurrent hiding (yield) +import Control.Exception import Control.Lens hiding (List) import Control.Monad import Control.Monad.IO.Class -import Control.Monad.Trans.Class +import Control.Monad.Except 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 hiding (await) import Data.Conduit.Parser import Data.Default import Data.Foldable import Data.List +import qualified Data.Map as Map +import qualified Data.Text as T +import qualified Data.Text.IO as T import qualified Data.HashMap.Strict as HashMap +import Data.Maybe import Language.Haskell.LSP.Messages import Language.Haskell.LSP.TH.ClientCapabilities -import Language.Haskell.LSP.Types +import Language.Haskell.LSP.Types hiding (error) import Language.Haskell.LSP.VFS import Language.Haskell.LSP.Test.Compat import Language.Haskell.LSP.Test.Decoding +import Language.Haskell.LSP.Test.Exceptions import System.Directory import System.IO @@ -57,12 +64,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. - timeout :: Int -- ^ Maximum time to wait for a request in seconds. + capabilities :: ClientCapabilities -- ^ Specific capabilities the client should advertise. Default is yes to everything. + , timeout :: Int -- ^ Maximum time to wait for a request in seconds. Defaults to 60. + , logStdErr :: Bool -- ^ When True redirects the servers stderr output to haskell-lsp-test's stdout. Defaults to False } instance Default SessionConfig where - def = SessionConfig def 60 + def = SessionConfig def 60 False class Monad m => MonadSessionConfig m where sessionConfig :: m SessionConfig @@ -88,11 +96,32 @@ data SessionState = SessionState type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m)) -type SessionProcessor = ConduitT FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) +type SessionProcessor = ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) 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 + where conduit = runConduit $ chanSource chan .| preprocessor .| runConduitParser (catchError session handler) + handler e@(Unexpected "ConduitParser.empty") = do + + -- Horrible way to get last item in conduit: + -- Add a fake message so we can tell when to stop + liftIO $ writeChan chan (RspShutdown (ResponseMessage "EMPTY" IdRspNull Nothing Nothing)) + x <- peek + case x of + Just x -> do + lastMsg <- skipToEnd x + name <- getParserName + liftIO $ throw (UnexpectedMessageException (T.unpack name) lastMsg) + Nothing -> throw e + + handler e = throw e + + skipToEnd x = do + y <- peek + case y of + Just (RspShutdown (ResponseMessage "EMPTY" IdRspNull Nothing Nothing)) -> return x + Just _ -> await >>= skipToEnd + Nothing -> return x get :: Monad m => ParserStateReader a s r m s get = lift State.get @@ -103,6 +132,12 @@ put = lift . State.put modify :: Monad m => (s -> s) -> ParserStateReader a s r m () modify = lift . State.modify +modifyM :: Monad m => (s -> m s) -> ParserStateReader a s r m () +modifyM f = do + old <- lift State.get + new <- lift $ lift $ lift $ f old + lift $ State.put new + ask :: Monad m => ParserStateReader a s r m r ask = lift $ lift Reader.ask @@ -144,30 +179,57 @@ runSessionWithHandles serverIn serverOut serverHandler config rootDir session = processTextChanges :: FromServerMessage -> SessionProcessor () processTextChanges (ReqApplyWorkspaceEdit r) = do - List changeParams <- case r ^. params . edit . documentChanges of - Just cs -> mapM applyTextDocumentEdit cs + + allChangeParams <- case r ^. params . edit . documentChanges of + Just (List cs) -> do + mapM_ (checkIfNeedsOpened . (^. textDocument . uri)) cs + return $ map getParams cs Nothing -> case r ^. params . edit . changes of - Just cs -> mapM (uncurry applyTextEdit) (List (HashMap.toList cs)) - Nothing -> return (List []) + Just cs -> do + mapM_ checkIfNeedsOpened (HashMap.keys cs) + return $ concatMap (uncurry getChangeParams) (HashMap.toList cs) + Nothing -> error "No changes!" - let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) changeParams + oldVFS <- vfs <$> lift State.get + newVFS <- liftIO $ changeFromServerVFS oldVFS r + lift $ State.modify (\s -> s { vfs = newVFS }) + + let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) allChangeParams mergedParams = map mergeParams groupedParams + ctx <- lift $ lift Reader.ask + -- TODO: Don't do this when replaying a session forM_ mergedParams $ \p -> do - h <- serverIn <$> lift (lift Reader.ask) - let msg = NotificationMessage "2.0" TextDocumentDidChange p + let h = serverIn ctx + msg = NotificationMessage "2.0" TextDocumentDidChange p liftIO $ B.hPut h $ addHeader (encode msg) - where applyTextDocumentEdit (TextDocumentEdit docId (List edits)) = do + where checkIfNeedsOpened uri = 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) + ctx <- lift $ lift Reader.ask + + -- if its not open, open it + unless (uri `Map.member` oldVFS) $ 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) + liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg) + + oldVFS <- vfs <$> lift State.get + newVFS <- liftIO $ openVFS oldVFS msg lift $ State.modify (\s -> s { vfs = newVFS }) - return params - applyTextEdit uri edits = applyTextDocumentEdit (TextDocumentEdit (VersionedTextDocumentIdentifier uri 0) edits) + 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..] + + textDocumentEdits uri edits = map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip (textDocumentVersions uri) edits + + getChangeParams uri (List edits) = map getParams (textDocumentEdits uri (reverse edits)) mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))