diff --git a/stack.cabal b/stack.cabal index d333e1291b..b7aab690b1 100644 --- a/stack.cabal +++ b/stack.cabal @@ -629,6 +629,7 @@ executable stack-integration-test main-is: IntegrationSpec.hs other-modules: StackTest + StackTest.Repl Paths_stack autogen-modules: Paths_stack diff --git a/tests/integration/lib/StackTest.hs b/tests/integration/lib/StackTest.hs index b279bd0f08..e19838ed4c 100644 --- a/tests/integration/lib/StackTest.hs +++ b/tests/integration/lib/StackTest.hs @@ -13,14 +13,6 @@ module StackTest , stackCleanFull , stackIgnoreException , stackErr - , Repl - , ReplConnection (..) - , nextPrompt - , replCommand - , replGetChar - , replGetLine - , runRepl - , repl , stackStderr , stackCheckStderr , stackErrStderr @@ -49,15 +41,11 @@ module StackTest , superslow ) where -import Control.Monad ( forever, unless, void, when ) -import Control.Monad.IO.Class ( liftIO ) -import Control.Monad.Trans.Reader ( ReaderT, ask, runReaderT ) -import Control.Concurrent ( forkIO ) +import Control.Monad ( unless, void, when ) import Control.Exception - ( Exception (..), IOException, bracket_, catch, throw + ( Exception (..), IOException, bracket_, catch , throwIO ) -import Data.Maybe ( fromMaybe ) import GHC.Stack ( HasCallStack ) import System.Environment ( getEnv, lookupEnv ) import System.Directory @@ -66,14 +54,12 @@ import System.Directory , setCurrentDirectory ) import System.IO - ( BufferMode (..), Handle, IOMode (..), hGetChar, hGetLine - , hPutChar, hPutStr, hPutStrLn, hSetBuffering, stderr - , withFile + ( hPutStr, hPutStrLn, stderr ) import System.IO.Error - ( isDoesNotExistError, isEOFError ) + ( isDoesNotExistError ) import System.Process - ( CreateProcess (..), StdStream (..), createProcess, proc + ( CreateProcess (..), createProcess, proc , readCreateProcessWithExitCode, readProcessWithExitCode , shell, waitForProcess ) @@ -149,74 +135,6 @@ stackErr args = do ec <- stack' args when (ec == ExitSuccess) $ error "stack was supposed to fail, but didn't" -type Repl = ReaderT ReplConnection IO - -data ReplConnection = ReplConnection - { replStdin :: Handle - , replStdout :: Handle - } - -nextPrompt :: Repl () -nextPrompt = do - (ReplConnection _ replStdoutHandle) <- ask - c <- liftIO $ hGetChar replStdoutHandle - if c == '>' - then do - -- Skip next character - void $ liftIO $ hGetChar replStdoutHandle - else nextPrompt - -replCommand :: String -> Repl () -replCommand cmd = do - (ReplConnection replStdinHandle _) <- ask - liftIO $ hPutStrLn replStdinHandle cmd - -replGetLine :: Repl String -replGetLine = ask >>= liftIO . hGetLine . replStdout - -replGetChar :: Repl Char -replGetChar = ask >>= liftIO . hGetChar . replStdout - -runRepl :: - HasCallStack - => FilePath - -> [String] - -> ReaderT ReplConnection IO () - -> IO ExitCode -runRepl cmd args actions = do - logInfo $ "Running: " ++ cmd ++ " " ++ unwords (map showProcessArgDebug args) - (Just rStdin, Just rStdout, Just rStderr, ph) <- - createProcess (proc cmd args) - { std_in = CreatePipe - , std_out = CreatePipe - , std_err = CreatePipe - } - hSetBuffering rStdin NoBuffering - hSetBuffering rStdout NoBuffering - hSetBuffering rStderr NoBuffering - -- Log stack repl's standard error output - tempDir <- if isWindows - then fromMaybe "" <$> lookupEnv "TEMP" - else pure "/tmp" - let tempLogFile = tempDir ++ "/stderr" - _ <- forkIO $ withFile tempLogFile WriteMode $ \logFileHandle -> do - hSetBuffering logFileHandle NoBuffering - forever $ - catch - (hGetChar rStderr >>= hPutChar logFileHandle) - (\e -> unless (isEOFError e) $ throw e) - runReaderT actions (ReplConnection rStdin rStdout) - waitForProcess ph - -repl :: HasCallStack => [String] -> Repl () -> IO () -repl args action = do - stackExe' <- stackExe - ec <- runRepl stackExe' ("repl":args) action - unless (ec == ExitSuccess) $ pure () - -- TODO: Understand why the exit code is 1 despite running GHCi tests - -- successfully. - -- else error $ "Exited with exit code: " ++ show ec - stackStderr :: HasCallStack => [String] -> IO (ExitCode, String) stackStderr args = do stackExe' <- stackExe diff --git a/tests/integration/lib/StackTest/Repl.hs b/tests/integration/lib/StackTest/Repl.hs new file mode 100644 index 0000000000..f08bdfceb5 --- /dev/null +++ b/tests/integration/lib/StackTest/Repl.hs @@ -0,0 +1,135 @@ +{- | +Integration-test helpers & fixtures for testing `stack repl` +-} +module StackTest.Repl + ( Repl + , ReplConnection (..) + , nextPrompt + , replCommand + , replGetChar + , replGetLine + , stackRepl + -- * Reexport + , module StackTest + ) where + +import Control.Exception (SomeException, catch, displayException, finally) +import Control.Monad ((>=>), unless, when) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans (lift) +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State qualified as State +import Data.Maybe (fromMaybe) +import Data.Foldable (toList) +import Data.Sequence as Seq (Seq(Empty), (|>), fromList) +import GHC.Stack (HasCallStack) +import System.Directory (removeFile) +import System.Environment (lookupEnv) +import System.Exit (ExitCode (..), exitFailure) +import System.IO + ( BufferMode (NoBuffering, LineBuffering), Handle, IOMode (ReadMode) + , hClose, hGetChar, hGetContents', hGetLine, hPutStrLn, hSetBuffering + , openTempFile + , withFile + ) +import System.Process + ( CreateProcess (std_err, std_in, std_out) + , StdStream (CreatePipe, UseHandle) + , createProcess, proc, waitForProcess + ) + +import StackTest + +type Repl = ReaderT ReplConnection IO + +data ReplConnection = ReplConnection + { replStdin :: Handle + , replStdout :: Handle + } + +replCommand :: String -> Repl () +replCommand cmd = do + (ReplConnection replStdinHandle _) <- ask + -- echo what we send to the test's stdout + liftIO . putStrLn $ "____> " <> cmd + liftIO $ hPutStrLn replStdinHandle cmd + +replGetChar :: Repl Char +replGetChar = asks replStdout >>= liftIO . hGetChar + +replGetLine :: Repl String +replGetLine = ask >>= liftIO . hGetLine . replStdout + +nextPrompt :: Repl () +nextPrompt = State.evalStateT poll Seq.Empty where + poll = do + c <- lift (asks replStdout) >>= liftIO . hGetChar + State.modify (|> c) + when (c == '\n') $ do + State.get >>= liftIO . putStr . ("ghci> " ++) . toList + State.put Seq.Empty + buf <- State.get + unless (buf == Seq.fromList "ghci> ") + poll + +runRepl + :: HasCallStack + => FilePath + -> [String] + -> Repl () + -> IO ExitCode +runRepl cmd args actions = do + (stderrBufPath, stderrBufHandle) <- openTempStderrBufferFile + hSetBuffering stderrBufHandle NoBuffering + + logInfo $ "Running: " ++ cmd ++ " " ++ unwords (map showProcessArgDebug args) ++ "\n\ + \ with stderr in " ++ stderrBufPath + + -- launch the GHCi subprocess, grab its FD handles and process handle + (Just rStdin, Just rStdout, Nothing, ph) <- + createProcess (proc cmd args) + { std_in = CreatePipe + , std_out = CreatePipe + , std_err = UseHandle stderrBufHandle + } + hSetBuffering rStdin LineBuffering + hSetBuffering rStdout NoBuffering + + -- run the test script which is to talk to the GHCi subprocess. + runReaderT actions (ReplConnection rStdin rStdout) + -- the nested actions script may fail in arbitrary ways; handle that here, + -- attaching the subprocess stderr as relevant context + `catch` \(e :: SomeException) -> do + putStrLn "==============================" + putStrLn "EXCEPTION in test: " + putStrLn . quote $ displayException e + putStrLn "------[ stderr of repl ]------" + withFile stderrBufPath ReadMode $ hGetContents' >=> putStr . quote + putStrLn "==============================" + `finally` do + hClose stderrBufHandle + removeFile stderrBufPath + + -- once done with the test, signal EOF on stdin for clean termination of ghci + hClose rStdin + -- read out the exit-code + waitForProcess ph + +-- | Roll a bicycle, rather than just `import Path.IO (getTempDir, openTempFile)`, +-- because it's a hassle to use anything beyond base & boot libs here. +openTempStderrBufferFile :: IO (FilePath, Handle) +openTempStderrBufferFile = getTempDir >>= (`openTempFile` "err.log") where + getTempDir | isWindows = fromMaybe "" <$> lookupEnv "TEMP" + | otherwise = pure "/tmp" + +-- | Testing helper to exercise `stack repl`. +stackRepl :: HasCallStack => [String] -> Repl () -> IO () +stackRepl args action = do + stackExe' <- stackExe + ec <- runRepl stackExe' ("repl" : "--ghci-options=-ignore-dot-ghci" : args) action + unless (ec == ExitSuccess) $ do + putStrLn $ "repl exited with " <> show ec + exitFailure + +quote :: String -> String +quote = unlines . map ("> " <>) . lines diff --git a/tests/integration/run-single-test.sh b/tests/integration/run-single-test.sh old mode 100644 new mode 100755 diff --git a/tests/integration/run-sort-tests.sh b/tests/integration/run-sort-tests.sh old mode 100644 new mode 100755 diff --git a/tests/integration/tests/3315-multi-ghc-options/Main.hs b/tests/integration/tests/3315-multi-ghc-options/Main.hs index 1a0ea36fce..60d8c9eec4 100644 --- a/tests/integration/tests/3315-multi-ghc-options/Main.hs +++ b/tests/integration/tests/3315-multi-ghc-options/Main.hs @@ -1,6 +1,6 @@ -import StackTest +import StackTest.Repl main :: IO () main = do stack ["build", "--ghc-options=-ddump-simpl -ddump-asm -DBAR -DBAZ"] - repl ["--ghc-options=-ddump-simpl -ddump-asm"] (pure ()) + stackRepl ["--ghc-options=-ddump-simpl -ddump-asm"] (pure ()) diff --git a/tests/integration/tests/3926-ghci-with-sublibraries/Main.hs b/tests/integration/tests/3926-ghci-with-sublibraries/Main.hs index df43dd9891..2685fe87e4 100644 --- a/tests/integration/tests/3926-ghci-with-sublibraries/Main.hs +++ b/tests/integration/tests/3926-ghci-with-sublibraries/Main.hs @@ -1,55 +1,36 @@ -import Control.Concurrent import Control.Monad.IO.Class import Control.Monad import Data.List -import StackTest -main :: IO () -main - | isWindows = - putStrLn "This test was disabled on Windows on 25 June 2023 (see \ - \https://github.com/commercialhaskell/stack/issues/6170)." - | otherwise = do - stack ["clean"] -- to make sure we can load the code even after a clean - copy "src/Lib.v1" "src/Lib.hs" - copy "src-internal/Internal.v1" "src-internal/Internal.hs" - stack ["build"] -- need a build before ghci at the moment, see #4148 - forkIO fileEditingThread - replThread - -replThread :: IO () -replThread = repl [] $ do - -- The command must be issued before searching the output for the next prompt, - -- otherwise, on Windows from msys2-20230526, `stack repl` encounters a EOF - -- and terminates gracefully. - replCommand ":main" - nextPrompt - line <- replGetLine - let expected = "hello world" - when (line /= expected) $ - error $ - "Main module didn't load correctly.\n" - <> "Expected: " <> expected <> "\n" - <> "Actual : " <> line <> "\n" - liftIO $ threadDelay 1000000 -- wait for an edit of the internal library - reloadAndTest "testInt" "42" "Internal library didn't reload." - liftIO $ threadDelay 1000000 -- wait for an edit of the internal library - reloadAndTest "testStr" "\"OK\"" "Main library didn't reload." +import StackTest.Repl -fileEditingThread :: IO () -fileEditingThread = do - threadDelay 1000000 - -- edit the internal library and pure to ghci - copy "src-internal/Internal.v2" "src-internal/Internal.hs" - threadDelay 1000000 - -- edit the internal library and end thread, returning to ghci - copy "src/Lib.v2" "src/Lib.hs" +main :: IO () +main = do + stack ["clean"] -- to make sure we can load the code even after a clean + copy "src/Lib.v1" "src/Lib.hs" + copy "src-internal/Internal.v1" "src-internal/Internal.hs" + stack ["build"] -- need a build before ghci at the moment, see #4148 + stackRepl [] $ do + nextPrompt + replCommand ":main" + line <- replGetLine + let expected = "hello world" + when (line /= expected) $ + error $ + "Main module didn't load correctly.\n" + <> "Expected: " <> expected <> "\n" + <> "Actual : " <> line <> "\n" + liftIO $ copy "src-internal/Internal.v2" "src-internal/Internal.hs" + reloadAndTest "testInt" "42" "Internal library didn't reload." + liftIO $ copy "src/Lib.v2" "src/Lib.hs" + reloadAndTest "testStr" "\"OK\"" "Main library didn't reload." reloadAndTest :: String -> String -> String -> Repl () reloadAndTest cmd exp err = do reload replCommand cmd line <- replGetLine + liftIO . putStrLn $ line unless (exp `isSuffixOf` line) $ error err reload :: Repl () diff --git a/tests/integration/tests/4270-files-order/Main.hs b/tests/integration/tests/4270-files-order/Main.hs index 4219d3ae7c..c4b1a56588 100644 --- a/tests/integration/tests/4270-files-order/Main.hs +++ b/tests/integration/tests/4270-files-order/Main.hs @@ -1,15 +1,13 @@ import Control.Monad import StackTest +import StackTest.Repl main :: IO () main = do stack ["build"] - repl [] $ do - -- The command must be issued before searching the output for the next - -- prompt, otherwise, on Windows from msys2-20230526, `stack repl` - -- encounters a EOF and terminates gracefully. - replCommand "putStrLn greeting" + stackRepl [] $ do nextPrompt + replCommand "putStrLn greeting" line <- replGetLine let expected = "Hello, world!" when (line /= expected) $ diff --git a/tests/integration/tests/module-added-multiple-times/Main.hs b/tests/integration/tests/module-added-multiple-times/Main.hs index d2745cffa3..73cfee36f5 100644 --- a/tests/integration/tests/module-added-multiple-times/Main.hs +++ b/tests/integration/tests/module-added-multiple-times/Main.hs @@ -1,14 +1,10 @@ import Control.Monad -import Data.List -import StackTest +import StackTest.Repl main :: IO () -main = repl [] $ do - -- The command must be issued before searching the output for the next prompt, - -- otherwise, on Windows from msys2-20230526, `stack repl` encounters a EOF - -- and terminates gracefully. - replCommand ":main" +main = stackRepl [] $ do nextPrompt + replCommand ":main" line <- replGetLine let expected = "Hello World!" when (line /= expected) $