From ba3255afa89fd1faf4c8ed1a01ba482ec5755264 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Mon, 30 Jul 2018 20:58:43 +0100 Subject: [PATCH] Plug in hedgehog --- haskell-lsp-test.cabal | 3 + src/Language/Haskell/LSP/Test.hs | 120 ++++++++++++----------- src/Language/Haskell/LSP/Test/Machine.hs | 96 ++++++++++++++++++ src/Language/Haskell/LSP/Test/Parsing.hs | 18 ++-- src/Language/Haskell/LSP/Test/Server.hs | 15 +-- src/Language/Haskell/LSP/Test/Session.hs | 40 ++++---- 6 files changed, 203 insertions(+), 89 deletions(-) create mode 100644 src/Language/Haskell/LSP/Test/Machine.hs diff --git a/haskell-lsp-test.cabal b/haskell-lsp-test.cabal index d3ef940..1b2b05a 100644 --- a/haskell-lsp-test.cabal +++ b/haskell-lsp-test.cabal @@ -19,6 +19,7 @@ library hs-source-dirs: src exposed-modules: Language.Haskell.LSP.Test , Language.Haskell.LSP.Test.Replay + , Language.Haskell.LSP.Test.Machine reexported-modules: haskell-lsp:Language.Haskell.LSP.Types , haskell-lsp:Language.Haskell.LSP.Types.Capabilities , parser-combinators:Control.Applicative.Combinators @@ -34,7 +35,9 @@ library , containers , data-default , directory + , exceptions , filepath + , hedgehog , lens , mtl , parser-combinators diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs index aeae56b..de2cfe0 100644 --- a/src/Language/Haskell/LSP/Test.hs +++ b/src/Language/Haskell/LSP/Test.hs @@ -19,7 +19,7 @@ module Language.Haskell.LSP.Test runSession , runSessionWithHandles , runSessionWithConfig - , Session + , SessionT , SessionConfig(..) , SessionException(..) , anySessionException @@ -49,6 +49,7 @@ module Language.Haskell.LSP.Test -- ** Documents , openDoc , closeDoc + , getOpenDocs , documentContents , getDocumentEdit , getDocUri @@ -83,6 +84,7 @@ module Language.Haskell.LSP.Test , applyEdit ) where +import Conduit (MonadThrow) import Control.Applicative.Combinators import Control.Concurrent import Control.Monad @@ -114,23 +116,25 @@ import System.FilePath import qualified Yi.Rope as Rope -- | Starts a new session. -runSession :: String -- ^ The command to run the server. +runSession :: (MonadIO m, MonadThrow m) + => String -- ^ The command to run the server. -> LSP.ClientCapabilities -- ^ The capabilities that the client should declare. -> FilePath -- ^ The filepath to the root directory for the session. - -> Session a -- ^ The session to run. - -> IO a + -> SessionT m a -- ^ The session to run. + -> m a runSession = runSessionWithConfig def -- | Starts a new sesion with a client with the specified capabilities. -runSessionWithConfig :: SessionConfig -- ^ Configuration options for the session. +runSessionWithConfig :: forall m a. (MonadIO m, MonadThrow m) + => SessionConfig -- ^ Configuration options for the session. -> String -- ^ The command to run the server. -> LSP.ClientCapabilities -- ^ The capabilities that the client should declare. -> FilePath -- ^ The filepath to the root directory for the session. - -> Session a -- ^ The session to run. - -> IO a + -> SessionT m a -- ^ The session to run. + -> m a runSessionWithConfig config serverExe caps rootDir session = do - pid <- getCurrentProcessID - absRootDir <- canonicalizePath rootDir + pid <- liftIO getCurrentProcessID + absRootDir <- liftIO $ canonicalizePath rootDir let initializeParams = InitializeParams (Just pid) (Just $ T.pack absRootDir) @@ -142,7 +146,7 @@ runSessionWithConfig config serverExe caps rootDir session = do runSessionWithHandles serverIn serverOut listenServer config caps rootDir $ do -- Wrap the session around initialize and shutdown calls - initRspMsg <- sendRequest Initialize initializeParams :: Session InitializeResponse + initRspMsg <- sendRequest Initialize initializeParams :: SessionT m InitializeResponse liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error) @@ -172,7 +176,7 @@ runSessionWithConfig config serverExe caps rootDir session = do listenServer serverOut context -- | The current text contents of a document. -documentContents :: TextDocumentIdentifier -> Session T.Text +documentContents :: MonadIO m => TextDocumentIdentifier -> SessionT m T.Text documentContents doc = do vfs <- vfs <$> get let file = vfs Map.! (doc ^. uri) @@ -180,9 +184,9 @@ documentContents doc = do -- | Parses an ApplyEditRequest, checks that it is for the passed document -- and returns the new content -getDocumentEdit :: TextDocumentIdentifier -> Session T.Text +getDocumentEdit :: forall m. MonadIO m => TextDocumentIdentifier -> SessionT m T.Text getDocumentEdit doc = do - req <- message :: Session ApplyWorkspaceEditRequest + req <- message :: SessionT m ApplyWorkspaceEditRequest unless (checkDocumentChanges req || checkChanges req) $ liftIO $ throw (IncorrectApplyEditRequest (show req)) @@ -203,23 +207,23 @@ getDocumentEdit doc = do -- | Sends a request to the server and waits for its response. -- @ --- rsp <- sendRequest TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse +-- rsp <- sendRequest TextDocumentDocumentSymbol params :: SessionT m DocumentSymbolsResponse -- @ -- Note: will skip any messages in between the request and the response. -sendRequest :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a) +sendRequest :: (MonadIO m, ToJSON params, FromJSON a) => ClientMethod -> params -> SessionT m (ResponseMessage a) sendRequest m = sendRequest' m >=> skipManyTill anyMessage . responseForId -- | Send a request to the server and wait for its response, -- but discard it. -sendRequest_ :: ToJSON params => ClientMethod -> params -> Session () -sendRequest_ p = void . (sendRequest p :: ToJSON params => params -> Session (ResponseMessage Value)) +sendRequest_ :: forall m params. (MonadIO m, ToJSON params) => ClientMethod -> params -> SessionT m () +sendRequest_ p = void . (sendRequest p :: ToJSON params => params -> SessionT m (ResponseMessage Value)) -- | Sends a request to the server without waiting on the response. sendRequest' - :: ToJSON params + :: (ToJSON params, MonadIO m) => ClientMethod -- ^ The request method. -> params -- ^ The request parameters. - -> Session LspId -- ^ The id of the request that was sent. + -> SessionT m LspId -- ^ The id of the request that was sent. sendRequest' method params = do id <- curReqId <$> get modify $ \c -> c { curReqId = nextId id } @@ -248,7 +252,7 @@ instance ToJSON a => ToJSON (RequestMessage' a) where object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params] -sendRequestMessage :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session () +sendRequestMessage :: (MonadIO m, ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> SessionT m () sendRequestMessage req = do -- Update the request map reqMap <- requestMap <$> ask @@ -258,10 +262,10 @@ sendRequestMessage req = do sendMessage req -- | Sends a notification to the server. -sendNotification :: ToJSON a +sendNotification :: (MonadIO m, ToJSON a) => ClientMethod -- ^ The notification method. -> a -- ^ The notification parameters. - -> Session () + -> SessionT m () -- | Open a virtual file if we send a did open text document notification sendNotification TextDocumentDidOpen params = do @@ -285,29 +289,30 @@ sendNotification TextDocumentDidClose params = do sendNotification method params = sendNotification' (NotificationMessage "2.0" method params) -sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session () +sendNotification' :: (MonadIO m, ToJSON a, ToJSON b) => NotificationMessage a b -> SessionT m () sendNotification' = sendMessage -sendResponse :: ToJSON a => ResponseMessage a -> Session () +sendResponse :: (MonadIO m, ToJSON a) => ResponseMessage a -> SessionT m () sendResponse = sendMessage -- | 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. -initializeResponse :: Session InitializeResponse +initializeResponse :: MonadIO m => SessionT m InitializeResponse initializeResponse = initRsp <$> ask >>= (liftIO . readMVar) -- | Opens a text document and sends a notification to the client. -openDoc :: FilePath -> String -> Session TextDocumentIdentifier +openDoc :: MonadIO m => FilePath -> String -> SessionT m TextDocumentIdentifier 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. + getDocItem :: MonadIO m + =>FilePath -- ^ The path to the text document to read in. -> String -- ^ The language ID, e.g "haskell" for .hs files. - -> Session TextDocumentItem + -> SessionT m TextDocumentItem getDocItem file languageId = do context <- ask let fp = rootDir context file @@ -315,7 +320,7 @@ openDoc file languageId = do return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents -- | Closes a text document and sends a notification to the client. -closeDoc :: TextDocumentIdentifier -> Session () +closeDoc :: MonadIO m => TextDocumentIdentifier -> SessionT m () closeDoc docId = do let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri)) sendNotification TextDocumentDidClose params @@ -325,21 +330,24 @@ closeDoc docId = do newVfs <- liftIO $ closeVFS oldVfs notif modify $ \s -> s { vfs = newVfs } +getOpenDocs :: MonadIO m => SessionT m [TextDocumentIdentifier] +getOpenDocs = map TextDocumentIdentifier . Map.keys . vfs <$> get + -- | Gets the Uri for the file corrected to the session directory. -getDocUri :: FilePath -> Session Uri +getDocUri :: MonadIO m => FilePath -> SessionT m Uri getDocUri file = do context <- ask let fp = rootDir context file return $ filePathToUri fp -- | Waits for diagnostics to be published and returns them. -waitForDiagnostics :: Session [Diagnostic] +waitForDiagnostics :: forall m. MonadIO m => SessionT m [Diagnostic] waitForDiagnostics = do - diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification + diagsNot <- skipManyTill anyMessage message :: SessionT m PublishDiagnosticsNotification let (List diags) = diagsNot ^. params . LSP.diagnostics return diags -waitForDiagnosticsSource :: String -> Session [Diagnostic] +waitForDiagnosticsSource :: MonadIO m => String -> SessionT m [Diagnostic] waitForDiagnosticsSource src = do diags <- waitForDiagnostics let res = filter matches diags @@ -353,13 +361,13 @@ waitForDiagnosticsSource src = do -- | Expects a 'PublishDiagnosticsNotification' and throws an -- 'UnexpectedDiagnosticsException' if there are any diagnostics -- returned. -noDiagnostics :: Session () +noDiagnostics :: forall m. MonadIO m => SessionT m () noDiagnostics = do - diagsNot <- message :: Session PublishDiagnosticsNotification + diagsNot <- message :: SessionT m PublishDiagnosticsNotification when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics -- | Returns the symbols in a document. -getDocumentSymbols :: TextDocumentIdentifier -> Session [SymbolInformation] +getDocumentSymbols :: MonadIO m => TextDocumentIdentifier -> SessionT m [SymbolInformation] getDocumentSymbols doc = do ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc) maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr @@ -369,7 +377,7 @@ getDocumentSymbols doc = do -- | Returns all the code actions in a document by -- querying the code actions at each of the current -- diagnostics' positions. -getAllCodeActions :: TextDocumentIdentifier -> Session [CommandOrCodeAction] +getAllCodeActions :: forall m. MonadIO m => TextDocumentIdentifier -> SessionT m [CommandOrCodeAction] getAllCodeActions doc = do curDiags <- fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get let ctx = CodeActionContext (List curDiags) Nothing @@ -377,7 +385,7 @@ getAllCodeActions doc = do foldM (go ctx) [] curDiags where - go :: CodeActionContext -> [CommandOrCodeAction] -> Diagnostic -> Session [CommandOrCodeAction] + go :: CodeActionContext -> [CommandOrCodeAction] -> Diagnostic -> SessionT m [CommandOrCodeAction] go ctx acc diag = do ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx) @@ -388,7 +396,7 @@ getAllCodeActions doc = do in return (acc ++ cmdOrCAs) -- | Executes a command. -executeCommand :: Command -> Session () +executeCommand :: MonadIO m => Command -> SessionT m () executeCommand cmd = do let args = decode $ encode $ fromJust $ cmd ^. arguments execParams = ExecuteCommandParams (cmd ^. command) args @@ -398,19 +406,19 @@ executeCommand cmd = do -- Matching with the specification, if a code action -- contains both an edit and a command, the edit will -- be applied first. -executeCodeAction :: CodeAction -> Session () +executeCodeAction :: forall m. MonadIO m => CodeAction -> SessionT m () executeCodeAction action = do maybe (return ()) handleEdit $ action ^. edit maybe (return ()) executeCommand $ action ^. command - where handleEdit :: WorkspaceEdit -> Session () + where handleEdit :: WorkspaceEdit -> SessionT m () handleEdit e = -- Its ok to pass in dummy parameters here as they aren't used let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e) in updateState (ReqApplyWorkspaceEdit req) -- | Adds the current version to the document, as tracked by the session. -getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier +getVersionedDoc :: MonadIO m => TextDocumentIdentifier -> SessionT m VersionedTextDocumentIdentifier getVersionedDoc (TextDocumentIdentifier uri) = do fs <- vfs <$> get let ver = @@ -420,7 +428,7 @@ getVersionedDoc (TextDocumentIdentifier uri) = do return (VersionedTextDocumentIdentifier uri ver) -- | Applys an edit to the document and returns the updated document version. -applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier +applyEdit :: MonadIO m => TextDocumentIdentifier -> TextEdit -> SessionT m VersionedTextDocumentIdentifier applyEdit doc edit = do verDoc <- getVersionedDoc doc @@ -448,7 +456,7 @@ applyEdit doc edit = do getVersionedDoc doc -- | Returns the completions for the position in the document. -getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem] +getCompletions :: MonadIO m => TextDocumentIdentifier -> Position -> SessionT m [CompletionItem] getCompletions doc pos = do rsp <- sendRequest TextDocumentCompletion (TextDocumentPositionParams doc pos) @@ -457,40 +465,42 @@ getCompletions doc pos = do CompletionList (CompletionListType _ (List items)) -> return items -- | Returns the references for the position in the document. -getReferences :: TextDocumentIdentifier -- ^ The document to lookup in. +getReferences :: MonadIO m + => TextDocumentIdentifier -- ^ The document to lookup in. -> Position -- ^ The position to lookup. -> Bool -- ^ Whether to include declarations as references. - -> Session [Location] -- ^ The locations of the references. + -> SessionT m [Location] -- ^ The locations of the references. getReferences doc pos inclDecl = let ctx = ReferenceContext inclDecl params = ReferenceParams doc pos ctx in getResponseResult <$> sendRequest TextDocumentReferences params -- | Returns the definition(s) for the term at the specified position. -getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in. +getDefinitions :: MonadIO m + => TextDocumentIdentifier -- ^ The document the term is in. -> Position -- ^ The position the term is at. - -> Session [Location] -- ^ The location(s) of the definitions + -> SessionT m [Location] -- ^ The location(s) of the definitions getDefinitions doc pos = let params = TextDocumentPositionParams doc pos in getResponseResult <$> sendRequest TextDocumentDefinition params -- ^ Renames the term at the specified position. -rename :: TextDocumentIdentifier -> Position -> String -> Session () +rename :: forall m. MonadIO m => TextDocumentIdentifier -> Position -> String -> SessionT m () rename doc pos newName = do let params = RenameParams doc pos (T.pack newName) - rsp <- sendRequest TextDocumentRename params :: Session RenameResponse + rsp <- sendRequest TextDocumentRename params :: SessionT m RenameResponse let wEdit = getResponseResult rsp req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit) updateState (ReqApplyWorkspaceEdit req) -- | Returns the hover information at the specified position. -getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover) +getHover :: MonadIO m => TextDocumentIdentifier -> Position -> SessionT m (Maybe Hover) getHover doc pos = let params = TextDocumentPositionParams doc pos in getResponseResult <$> sendRequest TextDocumentHover params -- | Returns the highlighted occurences of the term at the specified position -getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight] +getHighlights :: MonadIO m => TextDocumentIdentifier -> Position -> SessionT m [DocumentHighlight] getHighlights doc pos = let params = TextDocumentPositionParams doc pos in getResponseResult <$> sendRequest TextDocumentDocumentHighlight params @@ -503,20 +513,20 @@ getResponseResult rsp = fromMaybe exc (rsp ^. result) (fromJust $ rsp ^. LSP.error) -- | Applies formatting to the specified document. -formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session () +formatDoc :: MonadIO m => TextDocumentIdentifier -> FormattingOptions -> SessionT m () formatDoc doc opts = do let params = DocumentFormattingParams doc opts edits <- getResponseResult <$> sendRequest TextDocumentFormatting params applyTextEdits doc edits -- | Applies formatting to the specified range in a document. -formatRange :: TextDocumentIdentifier -> FormattingOptions -> Range -> Session () +formatRange :: MonadIO m => TextDocumentIdentifier -> FormattingOptions -> Range -> SessionT m () formatRange doc opts range = do let params = DocumentRangeFormattingParams doc range opts edits <- getResponseResult <$> sendRequest TextDocumentRangeFormatting params applyTextEdits doc edits -applyTextEdits :: TextDocumentIdentifier -> List TextEdit -> Session () +applyTextEdits :: MonadIO m => TextDocumentIdentifier -> List TextEdit -> SessionT m () applyTextEdits doc edits = let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) Nothing req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit) diff --git a/src/Language/Haskell/LSP/Test/Machine.hs b/src/Language/Haskell/LSP/Test/Machine.hs new file mode 100644 index 0000000..3959123 --- /dev/null +++ b/src/Language/Haskell/LSP/Test/Machine.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} +module Language.Haskell.LSP.Test.Machine where + +import Control.Monad.Catch +import Data.Default +import Language.Haskell.LSP.Test +import qualified Language.Haskell.LSP.Types as L +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Debug.Trace + +data ModelState (v :: * -> *) = TDocClose | TDocOpen | TDocWaited + deriving (Eq, Ord, Show) + +data OpenDoc (v :: * -> *) = OpenDoc + deriving (Eq, Show) + +instance HTraversable OpenDoc where + htraverse _ OpenDoc = pure OpenDoc + +s_openDoc_init :: (Monad n) => Command n PropertySession ModelState +s_openDoc_init = + let gen TDocClose = Just $ pure OpenDoc + gen _ = Nothing + execute OpenDoc = openDoc "Format.hs" "haskell" + in Command gen execute [ + Require $ \s OpenDoc -> s == TDocClose + , Update $ \_s OpenDoc o -> TDocOpen + , Ensure $ \before after OpenDoc o -> do + before === TDocClose + let L.TextDocumentIdentifier uri = o + uri === L.Uri "file:///Users/luke/Source/haskell-lsp-test/test/data/Format.hs" + after === TDocOpen + ] + +data WaitDiags (v :: * -> *) = WaitDiags + deriving (Eq, Show) + +instance HTraversable WaitDiags where + htraverse _ WaitDiags = pure WaitDiags + +s_diagnostics :: Monad n => Command n PropertySession ModelState +s_diagnostics = + let gen TDocOpen = Just $ pure WaitDiags + gen _ = Nothing + execute WaitDiags = waitForDiagnostics + in Command gen execute [ + Require $ \s WaitDiags -> s == TDocOpen + , Update $ \s WaitDiags o -> TDocWaited + , Ensure $ \before after WaitDiags o -> o === [] + ] + +data CloseDoc (v :: * -> *) = CloseDoc + deriving (Eq, Show) + +instance HTraversable CloseDoc where + htraverse _ CloseDoc = pure CloseDoc + +s_closeDoc :: Monad n => Command n PropertySession ModelState +s_closeDoc = + let gen TDocOpen = Just $ pure CloseDoc + gen TDocWaited = Just $ pure CloseDoc + gen _ = Nothing + execute CloseDoc = closeDoc (L.TextDocumentIdentifier (L.Uri "file:///Users/luke/Source/haskell-lsp-test/test/data/Format.hs")) + in Command gen execute [ + Require $ \s CloseDoc -> s == TDocOpen || s == TDocWaited + , Update $ \_s CloseDoc o -> TDocClose + ] + +type PropertySession = SessionT (PropertyT IO) + +instance MonadThrow m => MonadCatch (SessionT m) where + catch f h = f + +instance MonadTest PropertySession where + liftTest = lift . liftTest + +initialState :: ModelState v +initialState = TDocClose + +prop_doc :: Property +prop_doc = property $ do + actions <- forAll $ + Gen.sequential (Range.constant 1 100) initialState + [ s_openDoc_init + , s_diagnostics + , s_closeDoc + ] + runSessionWithConfig (def { logMessages = True }) "hie --lsp" def "test/data" $ + executeSequential initialState actions + diff --git a/src/Language/Haskell/LSP/Test/Parsing.hs b/src/Language/Haskell/LSP/Test/Parsing.hs index 2936b31..967e962 100644 --- a/src/Language/Haskell/LSP/Test/Parsing.hs +++ b/src/Language/Haskell/LSP/Test/Parsing.hs @@ -22,7 +22,7 @@ import Language.Haskell.LSP.Test.Messages import Language.Haskell.LSP.Test.Session import System.Console.ANSI -satisfy :: (FromServerMessage -> Bool) -> Session FromServerMessage +satisfy :: MonadIO m => (FromServerMessage -> Bool) -> SessionT m FromServerMessage satisfy pred = do skipTimeout <- overridingTimeout <$> get @@ -52,31 +52,31 @@ satisfy pred = do else empty -- | Matches a message of type 'a'. -message :: forall a. (Typeable a, FromJSON a) => Session a +message :: forall a m. (Typeable a, FromJSON a, MonadIO m) => SessionT m a message = let parser = decode . encodeMsg :: FromServerMessage -> Maybe a in named (T.pack $ show $ head $ snd $ splitTyConApp $ last $ typeRepArgs $ typeOf parser) $ castMsg <$> satisfy (isJust . parser) -- | Matches if the message is a notification. -anyNotification :: Session FromServerMessage +anyNotification :: MonadIO m => SessionT m FromServerMessage anyNotification = named "Any notification" $ satisfy isServerNotification -- | Matches if the message is a request. -anyRequest :: Session FromServerMessage +anyRequest :: MonadIO m => SessionT m FromServerMessage anyRequest = named "Any request" $ satisfy isServerRequest -- | Matches if the message is a response. -anyResponse :: Session FromServerMessage +anyResponse :: MonadIO m => SessionT m FromServerMessage anyResponse = named "Any response" $ satisfy isServerResponse -responseForId :: forall a. FromJSON a => LspId -> Session (ResponseMessage a) +responseForId :: forall a m. (FromJSON a, MonadIO m) => LspId -> SessionT m (ResponseMessage a) responseForId lid = named (T.pack $ "Response for id: " ++ show lid) $ do let parser = decode . encodeMsg :: FromServerMessage -> Maybe (ResponseMessage a) x <- satisfy (maybe False (\z -> z ^. LSP.id == responseId lid) . parser) return $ castMsg x -anyMessage :: Session FromServerMessage +anyMessage :: MonadIO m => SessionT m FromServerMessage anyMessage = satisfy (const True) -- | A stupid method for getting out the inner message. @@ -92,7 +92,7 @@ encodeMsgPretty :: FromServerMessage -> B.ByteString encodeMsgPretty = encodePretty . genericToJSON (defaultOptions { sumEncoding = UntaggedValue }) -- | Matches if the message is a log message notification or a show message notification/request. -loggingNotification :: Session FromServerMessage +loggingNotification :: MonadIO m => SessionT m FromServerMessage loggingNotification = named "Logging notification" $ satisfy shouldSkip where shouldSkip (NotLogMessage _) = True @@ -100,7 +100,7 @@ loggingNotification = named "Logging notification" $ satisfy shouldSkip shouldSkip (ReqShowMessage _) = True shouldSkip _ = False -publishDiagnosticsNotification :: Session PublishDiagnosticsNotification +publishDiagnosticsNotification :: MonadIO m => SessionT m PublishDiagnosticsNotification publishDiagnosticsNotification = named "Publish diagnostics notification" $ do NotPublishDiagnostics diags <- satisfy test return diags diff --git a/src/Language/Haskell/LSP/Test/Server.hs b/src/Language/Haskell/LSP/Test/Server.hs index 7d00f23..ff66748 100644 --- a/src/Language/Haskell/LSP/Test/Server.hs +++ b/src/Language/Haskell/LSP/Test/Server.hs @@ -2,27 +2,28 @@ module Language.Haskell.LSP.Test.Server (withServer) where import Control.Concurrent import Control.Monad +import Control.Monad.IO.Class import Language.Haskell.LSP.Test.Compat import System.IO import System.Process -withServer :: String -> Bool -> (Handle -> Handle -> Int -> IO a) -> IO a +withServer :: MonadIO m => String -> Bool -> (Handle -> Handle -> Int -> m a) -> m a withServer serverExe logStdErr f = do -- TODO Probably should just change runServer to accept -- separate command and arguments let cmd:args = words serverExe createProc = (proc cmd args) { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe } - (Just serverIn, Just serverOut, Just serverErr, serverProc) <- createProcess createProc + (Just serverIn, Just serverOut, Just serverErr, serverProc) <- liftIO $ createProcess createProc -- Need to continuously consume to stderr else it gets blocked -- Can't pass NoStream either to std_err - hSetBuffering serverErr NoBuffering - errSinkThread <- forkIO $ forever $ hGetLine serverErr >>= when logStdErr . putStrLn + liftIO $ hSetBuffering serverErr NoBuffering + errSinkThread <- liftIO $ forkIO $ forever $ hGetLine serverErr >>= when logStdErr . putStrLn - pid <- getProcessID serverProc + pid <- liftIO $ getProcessID serverProc result <- f serverIn serverOut pid - killThread errSinkThread - terminateProcess serverProc + liftIO $ killThread errSinkThread + liftIO $ terminateProcess serverProc return result diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs index a58496d..bff9bce 100644 --- a/src/Language/Haskell/LSP/Test/Session.hs +++ b/src/Language/Haskell/LSP/Test/Session.hs @@ -1,10 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts, UndecidableInstances #-} module Language.Haskell.LSP.Test.Session - ( Session + ( SessionT , SessionConfig(..) , SessionMessage(..) , SessionContext(..) @@ -23,6 +23,7 @@ module Language.Haskell.LSP.Test.Session where +import Conduit import Control.Concurrent hiding (yield) import Control.Exception import Control.Lens hiding (List) @@ -36,7 +37,6 @@ 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 import Data.Foldable @@ -68,7 +68,7 @@ import System.IO -- sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams docItem) -- diagnostics <- getMessage :: Session PublishDiagnosticsNotification -- @ -type Session = ParserStateReader FromServerMessage SessionState SessionContext IO +type SessionT m = ParserStateReader FromServerMessage SessionState SessionContext m -- | Stuff you can configure for a 'Session'. data SessionConfig = SessionConfig @@ -141,25 +141,27 @@ 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 :: (MonadIO m, MonadThrow m) => SessionContext -> SessionState -> SessionT m a -> m (a, SessionState) runSession context state session = runReaderT (runStateT conduit state) context where conduit = runConduit $ chanSource .| watchdog .| updateStateC .| runConduitParser (catchError session handler) + handler :: MonadIO m => ConduitParserException -> SessionT m a handler (Unexpected "ConduitParser.empty") = do lastMsg <- fromJust . lastReceivedMessage <$> get name <- getParserName liftIO $ throw (UnexpectedMessage (T.unpack name) lastMsg) - handler e = throw e + handler e = liftIO $ throw e + chanSource :: MonadIO m => ConduitT () SessionMessage m () chanSource = do msg <- liftIO $ readChan (messageChan context) yield msg chanSource - watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) () + watchdog :: MonadIO m => ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext m)) () watchdog = Conduit.awaitForever $ \msg -> do curId <- curTimeoutId <$> get case msg of @@ -168,35 +170,37 @@ runSession context state session = runReaderT (runStateT conduit state) context -- | 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. -runSessionWithHandles :: Handle -- ^ Server in +runSessionWithHandles :: (MonadIO m, MonadThrow m) + => Handle -- ^ Server in -> Handle -- ^ Server out -> (Handle -> SessionContext -> IO ()) -- ^ Server listener -> SessionConfig -> ClientCapabilities -> FilePath -- ^ Root directory - -> Session a - -> IO a + -> SessionT m a + -> m a runSessionWithHandles serverIn serverOut serverHandler config caps rootDir session = do - absRootDir <- canonicalizePath rootDir + absRootDir <- liftIO $ canonicalizePath rootDir + liftIO $ do hSetBuffering serverIn NoBuffering hSetBuffering serverOut NoBuffering - reqMap <- newMVar newRequestMap - messageChan <- newChan - initRsp <- newEmptyMVar + reqMap <- liftIO $ newMVar newRequestMap + messageChan <- liftIO newChan + initRsp <- liftIO newEmptyMVar 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 + threadId <- liftIO $ forkIO $ void $ serverHandler serverOut context (result, _) <- runSession context initState session - killThread threadId + liftIO $ killThread threadId return result -updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) () +updateStateC :: MonadIO m => ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext m)) () updateStateC = awaitForever $ \msg -> do updateState msg yield msg @@ -291,7 +295,7 @@ sendMessage msg = do -- | Execute a block f that will throw a 'TimeoutException' -- after duration seconds. This will override the global timeout -- for waiting for messages to arrive defined in 'SessionConfig'. -withTimeout :: Int -> Session a -> Session a +withTimeout :: MonadIO m => Int -> SessionT m a -> SessionT m a withTimeout duration f = do chan <- asks messageChan timeoutId <- curTimeoutId <$> get -- 2.30.2