X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest.hs;h=eb09d826a82f05d5015dfabecd5c85ce4e35cb5c;hb=57bc413473ab2900cae76ce54c3d49a8937e3562;hp=4f82498c732ad64263070d2e1d7f7d420dc4caa4;hpb=5170a20560a68b8fcaed83ecaf6146d84a147992;p=opengl.git diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs index 4f82498..eb09d82 100644 --- a/src/Language/Haskell/LSP/Test.hs +++ b/src/Language/Haskell/LSP/Test.hs @@ -16,7 +16,12 @@ module Language.Haskell.LSP.Test -- * Sessions runSession , runSessionWithHandles + , runSessionWithConfig , Session + , SessionConfig(..) + , MonadSessionConfig(..) + , SessionException(..) + , anySessionException -- * Sending , sendRequest , sendNotification @@ -54,56 +59,70 @@ module Language.Haskell.LSP.Test , (<|>) , satisfy -- * Utilities - , getInitializeResponse + , initializeResponse , openDoc - , getDocItem + , documentContents + , getDocumentEdit , getDocUri + , noDiagnostics + , getDocumentSymbols + , getDiagnostics ) where import Control.Applicative import Control.Applicative.Combinators +import Control.Concurrent import Control.Monad import Control.Monad.IO.Class -import Control.Concurrent +import Control.Exception import Control.Lens hiding ((.=), List) import qualified Data.Text as T 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 Language.Haskell.LSP.Types -import qualified Language.Haskell.LSP.Types as LSP (error, id) -import Language.Haskell.LSP.Messages +import qualified Data.Map as Map +import Data.Maybe +import Language.Haskell.LSP.Types hiding (id, capabilities) +import qualified Language.Haskell.LSP.Types as LSP import Language.Haskell.LSP.VFS import Language.Haskell.LSP.Test.Compat import Language.Haskell.LSP.Test.Decoding +import Language.Haskell.LSP.Test.Exceptions import Language.Haskell.LSP.Test.Parsing import Language.Haskell.LSP.Test.Session 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. -> FilePath -- ^ The filepath to the root directory for the session. -> Session a -- ^ The session to run. -> IO a -runSession serverExe rootDir session = do - pid <- getProcessID +runSession = runSessionWithConfig def + +-- | Starts a new sesion with a client with the specified capabilities. +runSessionWithConfig :: SessionConfig -- ^ The capabilities the client should have. + -> String -- ^ The command to run the server. + -> FilePath -- ^ The filepath to the root directory for the session. + -> Session a -- ^ The session to run. + -> IO a +runSessionWithConfig config serverExe rootDir session = do + pid <- getCurrentProcessID absRootDir <- canonicalizePath rootDir let initializeParams = InitializeParams (Just pid) (Just $ T.pack absRootDir) (Just $ filePathToUri absRootDir) Nothing - def + (capabilities config) (Just TraceOff) - - withServer serverExe $ \serverIn serverOut _ -> runSessionWithHandles serverIn serverOut listenServer rootDir $ do + withServer serverExe $ \serverIn serverOut _ -> + runSessionWithHandles serverIn serverOut listenServer config rootDir $ do -- Wrap the session around initialize and shutdown calls sendRequest Initialize initializeParams @@ -133,39 +152,45 @@ 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 }) - liftIO $ print 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 docUri = doc ^. uri + file <- case Map.lookup docUri vfs' of + Just file -> return file + Nothing -> do + openDoc (fromJust (uriToFilePath docUri)) "" + newVfs <- vfs <$> get + return $ newVfs Map.! docUri + return $ Rope.toText $ Language.Haskell.LSP.VFS._text file + +-- | Parses an ApplyEditRequest, checks that it is for the passed document +-- and returns the new content +getDocumentEdit :: TextDocumentIdentifier -> Session T.Text +getDocumentEdit doc = do + req <- request :: Session ApplyWorkspaceEditRequest + + unless (checkDocumentChanges req || checkChanges req) $ + liftIO $ throw (IncorrectApplyEditRequestException (show req)) + + documentContents doc + where + checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool + checkDocumentChanges req = + let changes = req ^. params . edit . documentChanges + maybeDocs = fmap (fmap (^. textDocument . uri)) changes + in case maybeDocs of + Just docs -> (doc ^. uri) `elem` docs + Nothing -> False + checkChanges :: ApplyWorkspaceEditRequest -> Bool + checkChanges req = + let mMap = req ^. params . edit . changes + in maybe False (HashMap.member (doc ^. uri)) mMap -- | Sends a request to the server. -- @@ -222,9 +247,28 @@ 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 + +-- | Close a virtual file if we send a close text document notification +sendNotification TextDocumentDidClose params = do + let params' = fromJust $ decode $ encode params + n :: DidCloseTextDocumentNotification + n = NotificationMessage "2.0" TextDocumentDidClose params' + oldVFS <- vfs <$> get + newVFS <- liftIO $ closeVFS 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 @@ -240,8 +284,8 @@ sendMessage msg = do -- | Returns the initialize response that was received from the server. -- The initialize requests and responses are not included the session, -- so if you need to test it use this. -getInitializeResponse :: Session InitializeResponse -getInitializeResponse = initRsp <$> ask >>= (liftIO . readMVar) +initializeResponse :: Session InitializeResponse +initializeResponse = initRsp <$> ask >>= (liftIO . readMVar) -- | Opens a text document and sends a notification to the client. openDoc :: FilePath -> String -> Session TextDocumentIdentifier @@ -249,7 +293,7 @@ openDoc file languageId = do item <- getDocItem file languageId sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item) TextDocumentIdentifier <$> getDocUri file - + where -- | Reads in a text document as the first version. getDocItem :: FilePath -- ^ The path to the text document to read in. -> String -- ^ The language ID, e.g "haskell" for .hs files. @@ -266,3 +310,23 @@ getDocUri file = do context <- ask let fp = rootDir context file return $ filePathToUri fp + +getDiagnostics :: Session [Diagnostic] +getDiagnostics = do + diagsNot <- notification :: Session PublishDiagnosticsNotification + let (List diags) = diagsNot ^. params . LSP.diagnostics + return diags + +-- | Expects a 'PublishDiagnosticsNotification' and throws an +-- 'UnexpectedDiagnosticsException' if there are any diagnostics +-- returned. +noDiagnostics :: Session () +noDiagnostics = do + diagsNot <- notification :: Session PublishDiagnosticsNotification + when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnosticsException + +-- | Returns the symbols in a document. +getDocumentSymbols :: TextDocumentIdentifier -> Session DocumentSymbolsResponse +getDocumentSymbols doc = do + sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc) + response \ No newline at end of file