Merge pull request #6740 from ulidtko/maint/repl-tests

Cleanup integration tests for `stack repl`

Author: mpilgrem

stack.cabal

@@ -628,6 +628,7 @@ executable stack-integration-test
   main-is: IntegrationSpec.hs
   other-modules:
       StackTest
+      StackTest.Repl
       Paths_stack
   autogen-modules:
       Paths_stack

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

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

tests/integration/run-single-test.sh

@@ -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 ())

tests/integration/run-sort-tests.sh

@@ -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 ()

tests/integration/tests/3315-multi-ghc-options/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) $

tests/integration/tests/3926-ghci-with-sublibraries/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) $