Checking to see if this helps with error logging.

bittide-instances/exe/post-dna-over-serial/Main.hs

@@ -10,14 +10,12 @@ module Main where
 import Clash.Prelude
 import Prelude ()
 
-import Control.Monad.Extra
 import qualified Data.List as L
 import Data.Maybe
 import Numeric
 import System.Environment (withArgs)
 import System.IO
 import System.Process
-import System.Timeout
 import Test.Tasty.HUnit
 import Test.Tasty.TH
 
@@ -50,10 +48,12 @@ case_dnaOverSerial = do
       let
         picocomStdOutHandle = fromJust maybePicocomStdOut
 
-      terminalReadyResult <-
-        timeout 10_000_000 $ waitForLine picocomStdOutHandle "Terminal ready"
-      when (isNothing terminalReadyResult) $ do
-        assertFailure "Timeout waiting for \"Terminal ready\""
+      waitForLine
+        "Timeout waiting for \"Terminal ready\""
+        10_000_000
+        (pure ())
+        picocomStdOutHandle
+        "Terminal ready"
 
       _ <- hGetLine picocomStdOutHandle -- Discard a potentially incomplete line
       receivedDna <- hGetLine picocomStdOutHandle

bittide-instances/exe/post-vex-riscv-tcp-test/Main.hs

@@ -93,7 +93,7 @@ case_testTcpClient = do
       hSetBuffering openOcdStdErr LineBuffering
 
       putStr "Waiting for halt..."
-      expectLine openOcdStdErr waitForHalt
+      expectLine Nothing openOcdStdErr waitForHalt
       putStrLn " Done"
 
       putStrLn "Starting Picocom..."
@@ -102,6 +102,7 @@ case_testTcpClient = do
           picocomStdInHandle = fromJust maybePicocomStdIn
           picocomStdOutHandle = fromJust maybePicocomStdOut
 
+        let
           -- Create function to log the output of the processes
           loggingSequence = do
             threadDelay 1_000_000 -- Wait 1 second for data loggers to catch up
@@ -127,16 +128,25 @@ case_testTcpClient = do
         hSetBuffering picocomStdOutHandle LineBuffering
 
         putStrLn "Waiting for Picocom to be ready..."
-        tryWithTimeout "Picocom handshake" 10_000_000 $
-          waitForLine picocomStdOutHandle "Terminal ready"
+        waitForLine
+          "Picocom handshake"
+          10_000_000
+          loggingSequence
+          picocomStdOutHandle
+          "Terminal ready"
 
         putStrLn "Starting GDB..."
         withCreateProcess gdbProc $ \_ (fromJust -> gdbStdOut) _ _ -> do
           hSetBuffering gdbStdOut LineBuffering
 
           putStrLn "Waiting for \"Starting TCP Client\""
-          tryWithTimeout "Handshake softcore" 10_000_000 $
-            waitForLine picocomStdOutHandle "Starting TCP Client"
+
+          waitForLine
+            "Handshake softcore"
+            10_000_000
+            loggingSequence
+            picocomStdOutHandle
+            "Starting TCP Client"
 
           let numberOfClients = 1
           putStrLn $ "Waiting for " <> show numberOfClients <> " clients to connect to TCP server."

bittide-instances/exe/post-vex-riscv-test/Main.hs

@@ -6,13 +6,11 @@
 
 import Prelude
 
-import Control.Concurrent (threadDelay)
 import Data.Maybe (fromJust)
 import System.Environment (withArgs)
 import System.IO
 import System.Posix.Env (getEnvironment)
 import System.Process
-import System.Timeout
 
 import Test.Tasty.HUnit
 import Test.Tasty.TH
@@ -64,59 +62,49 @@ case_testGdbProgram = do
 
     withCreateProcess openOcdProc $ \_ _ (fromJust -> openOcdStdErr) _ -> do
       hSetBuffering openOcdStdErr LineBuffering
-      expectLine openOcdStdErr waitForHalt
+      expectLine Nothing openOcdStdErr waitForHalt
 
       -- XXX: Picocom doesn't immediately clean up after closing, because it
       --      spawns as a child of the shell (start.sh). We could use 'exec' to
       --      make sure the intermediate shell doesn't exist, but this causes
       --      the whole test program to exit with signal 15 (??????).
-      withCreateProcess picocomProc $ \maybePicocomStdIn maybePicocomStdOut maybePicocomStdErr _ -> do
+      withCreateProcess picocomProc $ \maybePicocomStdIn maybePicocomStdOut _ _ -> do
         let
           picocomStdIn = fromJust maybePicocomStdIn
           picocomStdOut = fromJust maybePicocomStdOut
 
-          -- Create function to log the output of the processes
-          loggingSequence = do
-            threadDelay 1_000_000 -- Wait 1 second for data loggers to catch up
-            putStrLn "Picocom stdout"
-            picocomOut <- readRemainingChars picocomStdOut
-            putStrLn picocomOut
-            case maybePicocomStdErr of
-              Nothing -> pure ()
-              Just h -> do
-                putStrLn "Picocom StdErr"
-                readRemainingChars h >>= putStrLn
-
-          tryWithTimeout :: String -> Int -> IO a -> IO a
-          tryWithTimeout actionName dur action = do
-            result <- timeout dur action
-            case result of
-              Nothing -> do
-                loggingSequence
-                assertFailure $ "Timeout while performing action: " <> actionName
-              Just r -> pure r
-
         hSetBuffering picocomStdIn LineBuffering
         hSetBuffering picocomStdOut LineBuffering
 
-        tryWithTimeout "Waiting for \"Terminal ready\"" 10_000_000 $
-          waitForLine picocomStdOut "Terminal ready"
+        waitForLine
+          "Waiting for \"Terminal ready\""
+          10_000_000
+          (pure ())
+          picocomStdOut
+          "Terminal ready"
 
         withCreateProcess gdbProc $ \_ (fromJust -> gdbStdOut) _ _ -> do
           -- Wait for GDB to program the FPGA. If successful, we should see
           -- "going in echo mode" in the picocom output.
           hSetBuffering gdbStdOut LineBuffering
-          tryWithTimeout "Waiting for \"Going in echo mode!\"" 10_000_000 $
-            waitForLine picocomStdOut "Going in echo mode!"
+          waitForLine
+            "Waiting for \"Going in echo mode!\""
+            10_000_000
+            (pure ())
+            picocomStdOut
+            "Going in echo mode!"
 
           -- Wait for GDB to reach its last command - where it will wait indefinitely
-          tryWithTimeout "Waiting for \"> continue\"" 10_000_000 $
-            waitForLine gdbStdOut "> continue"
+          waitForLine "Waiting for \"> continue\"" 10_000_000 (pure ()) gdbStdOut "> continue"
 
           -- Test UART echo
           hPutStrLn picocomStdIn "Hello, UART!"
-          tryWithTimeout "Waiting for \"Hello, UART!\"" 10_000_000 $
-            waitForLine picocomStdOut "Hello, UART!"
+          waitForLine
+            "Waiting for \"Hello, UART!\""
+            10_000_000
+            (pure ())
+            picocomStdOut
+            "Hello, UART!"
 
 main :: IO ()
 main = withArgs ["--timeout", "2m"] $(defaultMainGenerator)

bittide-instances/src/Project/Handle.hs

@@ -9,6 +9,7 @@ import Prelude
 import Data.List.Extra (trim)
 import System.IO
 
+import Data.Time (diffUTCTime, getCurrentTime)
 import Test.Tasty.HUnit
 
 data Error = Ok | Error String
@@ -20,32 +21,69 @@ reading lines. If the filter returns @Stop Ok@, the function will return
 successfully. If the filter returns @Stop (Error msg)@, the function will
 fail with the given message, along with a log of all processed lines.
 -}
-expectLine :: (HasCallStack) => Handle -> (String -> Filter) -> Assertion
-expectLine = expectLine' ""
+expectLine ::
+  (HasCallStack) => Maybe (Int, String, IO ()) -> Handle -> (String -> Filter) -> Assertion
+expectLine Nothing h f = expectLine' []
  where
-  expectLine' s0 h f = do
+  expectLine' s0 = do
     line <- hGetLine h
     let
       trimmed = trim line
-      s1 = s0 <> "\n" <> line
-      cont = expectLine' s1 h f
+      s1 = s0 ++ [line]
+      cont = expectLine' s1
     if null trimmed
       then cont
       else case f trimmed of
         Continue -> cont
         Stop Ok -> pure ()
         Stop (Error msg) -> do
-          putStrLn s1
-          assertFailure msg
+          rest <- readRemainingChars h
+          putStrLn $ "handle buffer dump:\n" <> rest
+          putStrLn "previously read:"
+          mapM_ putStrLn s1
+          assertFailure $ "failure message: " <> msg
+expectLine (Just (timeout, msg, onErr)) h f = getCurrentTime >>= expectLine' []
+ where
+  timeout' = toRational timeout
+  expectLine' s t0 = do
+    now <- getCurrentTime
+    if toRational (diffUTCTime t0 now) >= timeout'
+      then do
+        onErr
+        putStrLn "previously read:"
+        mapM_ putStrLn s
+        assertFailure $ "expect line timed out on: `" <> msg
+      else do
+        line <- hGetLine h
+        let
+          trimmed = trim line
+          s1 = s ++ [line]
+          cont = expectLine' s1 t0
+        if null trimmed
+          then cont
+          else case f trimmed of
+            Continue -> cont
+            Stop Ok -> pure ()
+            Stop (Error msg1) -> do
+              onErr
+              rest <- readRemainingChars h
+              putStrLn $ "handle buffer dump:\n" <> rest
+              putStrLn "previously read:"
+              mapM_ putStrLn s1
+              assertFailure $
+                "expect line failed on `"
+                  <> msg
+                  <> "`. message: `"
+                  <> msg1
 
 {- | Utility function that reads lines from a handle, and waits for a specific
 line to appear. Though this function does not fail in the traditional sense,
 it will get stuck if the expected line does not appear. Only use in combination
 with sensible time outs (also see 'main').
 -}
-waitForLine :: Handle -> String -> IO ()
-waitForLine h expected =
-  expectLine h $ \s ->
+waitForLine :: String -> Int -> IO () -> Handle -> String -> IO ()
+waitForLine msg timeout onErr h expected =
+  expectLine (Just (timeout, msg, onErr)) h $ \s ->
     if s == expected
       then Stop Ok
       else Continue
@@ -58,4 +96,4 @@ readRemainingChars h = do
     then do
       c <- hGetChar h
       (c :) <$> readRemainingChars h
-    else (pure "")
+    else pure ""