Hedgehog Integration (WIP)

Author: kleinreact

clash-testbench/src/Clash/Testbench/Generate.hs

@@ -6,6 +6,8 @@ Maintainer:   QBayLogic B.V. <[email protected]>
 Use generators to create signal data.
 -}
 
+{-# LANGUAGE RecursiveDo #-}
+{-# LANGUAGE OverloadedStrings #-}
 module Clash.Testbench.Generate where
 
 import Hedgehog
@@ -25,27 +27,29 @@ import Clash.Testbench.Internal.Monad
 generate ::
   forall dom a.
   (NFDataX a, BitPack a, KnownDomain dom) =>
-  a -> Gen a -> TB (TBSignal dom a)
-generate def gen = do
+  Gen a -> TB (TBSignal dom a)
+generate gen = do
   TBDomain{..} <- tbDomain @dom
 
-  vRef <- liftIO $ newIORef def
-  simStepCache <- liftIO (readIORef simStepRef >>= newIORef)
+  vRef <- liftIO $ newIORef undefined
+  checkForProgress <- progressCheck simStepRef True
+  signalHistory <- newHistory
 
   mind SomeSignal IOInput
     { signalId     = NoID
     , signalCurVal = const $ do
-        v <- readIORef simStepRef
-        v' <- readIORef simStepCache
+        progress <- checkForProgress
 
-        if v == v'
-        then readIORef vRef
-        else do
+        if progress
+        then do
           x <- sample gen
           writeIORef vRef x
-          writeIORef simStepCache v
+          memorize signalHistory x
           return x
+        else
+          readIORef vRef
     , signalPrint  = Nothing
+    ,..
     }
 
 -- | Extended version of 'generate', which allows to generate a finite
@@ -60,32 +64,33 @@ generateN def gen = do
   TBDomain{..} <- tbDomain @dom
 
   vRef <- liftIO $ newIORef [def]
-  simStepCache <- liftIO (readIORef simStepRef >>= newIORef)
+  checkForProgress <- progressCheck simStepRef False
+  signalHistory <- newHistory
 
   mind SomeSignal IOInput
     { signalId     = NoID
     , signalCurVal = const $ do
-        v <- readIORef simStepRef
-        v' <- readIORef simStepCache
-
-        if v == v'
-        then readIORef vRef >>= \case
-          x : _ -> return x
-          [] -> do
-            x : xr <- sample gen
-            writeIORef vRef (x : xr)
-            return x
+        progress <- checkForProgress
 
-        else do
-          writeIORef simStepCache v
+        if progress
+        then
           readIORef vRef >>= \case
-            _ : x : xr -> do
+            h : x : xr -> do
+              memorize signalHistory h
               writeIORef vRef (x : xr)
               return x
-            _ -> do
+            [h] -> do
+              memorize signalHistory h
               x : xr <- sample gen
               writeIORef vRef (x : xr)
               return x
+            _ -> error "unreachable"
+        else readIORef vRef >>= \case
+          x : _ -> return x
+          [] -> do
+            x : xr <- sample gen
+            writeIORef vRef (x : xr)
+            return x
     , signalPrint  = Nothing
     , ..
     }
@@ -102,6 +107,7 @@ matchIOGen expectedOutput gen = do
 
   vRef <- liftIO $ newIORef undefined
   checkForProgress <- progressCheck simStepRef False
+  signalHistory <- newHistory
 
   mind SomeSignal $ IOInput
     { signalId     = NoID
@@ -119,6 +125,7 @@ matchIOGen expectedOutput gen = do
         else
           readIORef vRef
     , signalPrint  = Nothing
+    , ..
     }
 
  where
@@ -138,35 +145,40 @@ matchIOGenN ::
   forall dom i o.
   (NFDataX i, BitPack i, KnownDomain dom, Eq o, Show o, Show i) =>
   TBSignal dom o -> Gen [(i, o)] -> TB (TBSignal dom i)
-matchIOGenN expectedOutput gen = do
+matchIOGenN checkedOutput gen = mdo
   TBDomain{..} <- tbDomain @dom
 
   xs <- liftIO $ sample gen
   modify $ \st@ST{..} -> st { simSteps = max simSteps $ length xs }
+  liftIO $ Prelude.print xs
 
   vRef <- liftIO $ newIORef xs
   checkForProgress <- progressCheck simStepRef False
+  signalHistory <- newHistory
 
-  mind SomeSignal $ IOInput
+  s <- mind SomeSignal $ IOInput
     { signalId = NoID
     , signalCurVal = const $ do
         progress <- checkForProgress
 
         readIORef vRef >>=
           if progress
           then \case
-            _ : (i, o) : xr -> do
+            (h, _) : (i, o) : xr -> do
+              memorize signalHistory h
               writeIORef vRef ((i, o) : xr)
               curStep <- readIORef simStepRef
-              signalExpect expectedOutput $ Expectation (curStep, verify o)
+              signalExpect checkedOutput $ Expectation (curStep, verify s i o)
               return i
-            _ -> do
+            [(h, _)] -> do
+              memorize signalHistory h
               (i, o) : xr <- sample gen
 
               writeIORef vRef ((i, o) : xr)
               curStep <- readIORef simStepRef
-              signalExpect expectedOutput $ Expectation (curStep, verify o)
+              signalExpect checkedOutput $ Expectation (curStep, verify s i o)
               return i
+            _ -> error "unreachable"
           else \case
             (i, _) : _ -> return i
             [] -> do
@@ -175,11 +187,41 @@ matchIOGenN expectedOutput gen = do
               Prelude.print $ (i, o) : xr
               return i
     , signalPrint = Nothing
+    , ..
     }
 
+  return s
+
  where
-  verify x y = do
-    when (x /= y)
-      $ footnote
-      $ "Expected '" <> show x <> "' but the output is '" <> show y <> "'"
-    x === x
+  verify generatedInput currentInput expectedOutput observedOutput = do
+    when (expectedOutput /= observedOutput) $ do
+      xs <-
+        (<> [(currentInput, observedOutput)])
+          <$> (zip <$> history generatedInput <*> history checkedOutput)
+
+      let
+        cHeading = "Cycle"
+        iHeading = "Input"
+        oHeading = "Output"
+        cLen = length cHeading
+        iLen = maximum $ (length iHeading :) $ fmap (length . show . fst) xs
+        oLen = maximum $ (length oHeading :) $ fmap (length . show . snd) xs
+
+      footnote $ unlines $
+        [ "Expected to see the output '" <> show expectedOutput <> "',"
+        , "but the observed output is '" <> show observedOutput <> "'."
+        , ""
+        , "I/O History:"
+        , ""
+        , cHeading <>
+          replicate (iLen - length iHeading + 2) ' ' <> iHeading <>
+          replicate (oLen - length oHeading + 2) ' ' <> oHeading
+        , replicate (cLen + iLen + oLen + 4) '-'
+        ] <>
+        [ replicate (cLen - length (show c))     ' ' <> show c <>
+          replicate (iLen - length (show i) + 2) ' ' <> show i <>
+          replicate (oLen - length (show o) + 2) ' ' <> show o
+        | (c, (i, o)) <- zip [0 :: Int,1..] xs
+        ]
+
+      failure

clash-testbench/src/Clash/Testbench/Input.hs

@@ -51,27 +51,30 @@ fromList mode xs = do
 
   vRef <- liftIO $ newIORef xs
   checkForProgress <- progressCheck simStepRef False
+  signalHistory <- newHistory
+
+  let
+    signalCurVal m = do
+      x : xr <- readIORef vRef >>= return . \case
+        [] -> case mode of
+          Repeat     -> xs
+          Default v  -> [v]
+          IsInfinite -> error $ "Clash.Testbench.Input.fromList: "
+                             <> "end of list reached"
+        yr -> yr
+
+      progress <- checkForProgress
+
+      if progress
+      then do
+        memorize signalHistory x
+        writeIORef vRef xr
+        signalCurVal m
+      else
+        return x
 
   mind SomeSignal $ IOInput
     { signalId     = NoID
     , signalPrint  = Nothing
-    , signalCurVal = const $ do
-        readIORef vRef >>= \case
-          [] -> case mode of
-            Repeat -> do
-              let (x : xr) = xs
-              writeIORef vRef xr
-              return x
-            Default v ->
-              return v
-            IsInfinite ->
-              error $ "Clash.Testbench.Input.fromList: "
-                   <> "End of list reached."
-          x : xr -> do
-            progress <- checkForProgress
-
-            when progress $
-              writeIORef vRef xr
-
-            return x
+    , ..
     }