Merge pull request #63 from clash-lang/improve-expect-functions

Improve debugability by adding call stacks / timeouts to expect functions

clash-vexriscv-sim/tests/Tests/Jtag.hs

@@ -1,6 +1,7 @@
 -- SPDX-FileCopyrightText: 2024 Google LLC
 --
 -- SPDX-License-Identifier: Apache-2.0
+{-# LANGUAGE NumericUnderscores #-}
 
 -- | Tests for the JTAG debug interface
 module Tests.Jtag where
@@ -10,10 +11,12 @@ import Control.Monad.Extra (ifM, when)
 import Data.List.Extra (trim)
 import Data.Maybe (fromJust)
 import Data.Proxy
+import GHC.Stack (CallStack, callStack, prettyCallStack)
 import System.Directory (findExecutable)
 import System.Exit
 import System.IO
 import System.Process
+import System.Timeout (timeout)
 import Test.Tasty
 import Test.Tasty.HUnit
 import Test.Tasty.Options
@@ -57,26 +60,64 @@ getGdb = do
     Nothing -> fail "Neither gdb-multiarch nor gdb found in PATH"
     Just x -> pure x
 
-expectLine :: Bool -> Handle -> String -> Assertion
-expectLine debug h expected = do
-  line <- hGetLine h
-  when debug $ do
-    hPutStr stderr "> "
-    hPutStrLn stderr line
-  ifM
-    (pure $ null line)
-    (expectLine debug h expected)
-    (expected @?= line)
-
-waitForLine :: Bool -> Handle -> String -> IO ()
-waitForLine debug h expected = do
-  line <- hGetLine h
-  when debug $ do
-    hPutStr stderr "> "
-    hPutStrLn stderr line
-  if line == expected
-    then pure ()
-    else waitForLine debug h expected
+expectLineOrTimeout ::
+  (HasCallStack) =>
+  -- | Number of microseconds to wait. I.e., 1_000_000 is 1 second.
+  Int ->
+  -- | Debug mode. Print output to stderr.
+  Bool ->
+  -- | Handle to read from.
+  Handle ->
+  -- | Expected line. Skips empty lines.
+  String ->
+  Assertion
+expectLineOrTimeout us debug h expected = do
+  result <- timeout us go
+  case result of
+    Just () -> pure ()
+    Nothing -> expectError callStack expected
+ where
+  go = do
+    line <- hGetLine h
+
+    when debug $ do
+      hPutStr stderr "> "
+      hPutStrLn stderr line
+
+    ifM
+      (pure $ null line)
+      go
+      (assertEqual (prettyCallStack callStack) expected line)
+
+waitForLineOrTimeout ::
+  (HasCallStack) =>
+  -- | Number of microseconds to wait. I.e., 1_000_000 is 1 second.
+  Int ->
+  -- | Debug mode. Print output to stderr.
+  Bool ->
+  -- | Handle to read from.
+  Handle ->
+  -- | Expected line. Skips any lines that do not match.
+  String ->
+  Assertion
+waitForLineOrTimeout us debug h expected = do
+  result <- timeout us go
+  case result of
+    Just () -> pure ()
+    Nothing -> expectError callStack expected
+ where
+  go = do
+    line <- hGetLine h
+    when debug $ do
+      hPutStr stderr "> "
+      hPutStrLn stderr line
+    if line == expected
+      then pure ()
+      else go
+
+expectError :: CallStack -> String -> Assertion
+expectError cs expected = do
+  assertFailure ("Timed out waiting for " <> expected <> "\n\n" <> prettyCallStack cs)
 
 {- | Run three processes in parallel:
 
@@ -98,6 +139,10 @@ test debug = do
   gdb <- getGdb
 
   let
+    -- Timeout after 60 seconds
+    expectLine = expectLineOrTimeout 60_000_000
+    waitForLine = waitForLineOrTimeout 60_000_000
+
     vexRiscvProc =
       (proc simulateExecPath [printElfPath])
         { std_out = CreatePipe

clash-vexriscv-sim/tests/Tests/JtagChain.hs

@@ -1,6 +1,7 @@
 -- SPDX-FileCopyrightText: 2022-2024 Google LLC
 --
 -- SPDX-License-Identifier: Apache-2.0
+{-# LANGUAGE NumericUnderscores #-}
 
 module Tests.JtagChain where
 
@@ -22,7 +23,7 @@ import Test.Tasty.HUnit (Assertion, testCase, (@=?))
 import Test.Tasty.Options (OptionDescription (Option))
 import Prelude
 
-import Tests.Jtag (JtagDebug (JtagDebug), cabalListBin, expectLine, getGdb, waitForLine)
+import Tests.Jtag (JtagDebug (JtagDebug), cabalListBin, expectLineOrTimeout, getGdb, waitForLineOrTimeout)
 import Utils.FilePath (BuildType (Debug), cabalProject, findParentContaining, rustBinsDir)
 
 getSimulateExecPath :: IO FilePath
@@ -32,6 +33,7 @@ getProjectRoot :: IO FilePath
 getProjectRoot = findParentContaining cabalProject
 
 test ::
+  (HasCallStack) =>
   -- | Print debug output of subprocesses
   Bool ->
   Assertion
@@ -54,6 +56,10 @@ test debug = do
   ensureExists logBPath
 
   let
+    -- Timeout after 120 seconds
+    expectLine = expectLineOrTimeout 120_000_000
+    waitForLine = waitForLineOrTimeout 120_000_000
+
     vexRiscvProc =
       ( proc
           simulateExecPath
@@ -120,7 +126,7 @@ ensureExists path = unlessM (doesPathExist path) (withFile path WriteMode (\_ ->
 errorHelper :: (HasCallStack) => String -> String -> m a
 errorHelper expected found = error ("expected `" <> expected <> "`, found `" <> found <> "`")
 
-tests :: TestTree
+tests :: (HasCallStack) => TestTree
 tests = askOption $ \(JtagDebug debug) ->
   testGroup
     "JTAG chaining"