Merge pull request #2451 from clash-lang/fix-2450

Expose non-`XException` bottoms in `hasX`

Author: martijnbastiaan

changelog/2023-04-14T16_53_05+02_00_expose_ErrorCall_in_hasX

@@ -0,0 +1 @@
+CHANGED: `hasX` now needs an `NFDataX` constraint, in addition to an `NFData` one. This API change was made to fix an issue where `hasX` would hide error calls in certain situations, see [#2450](https://github.com/clash-lang/clash-compiler/issues/2450).

clash-prelude/clash-prelude.cabal

@@ -442,6 +442,7 @@ test-suite unittests
                  Clash.Tests.TopEntityGeneration
                  Clash.Tests.Unsigned
                  Clash.Tests.Vector
+                 Clash.Tests.XException
 
                  Clash.Tests.Laws.Enum
                  Clash.Tests.Laws.SaturatingNum

clash-prelude/src/Clash/XException.hs

@@ -2,7 +2,7 @@
 Copyright  :  (C) 2016,      University of Twente,
                   2017,      QBayLogic, Google Inc.
                   2017-2019, Myrtle Software Ltd,
-                  2021-2022, QBayLogic B.V.
+                  2021-2023, QBayLogic B.V.
 License    :  BSD2 (see the file LICENSE)
 Maintainer :  QBayLogic B.V. <[email protected]>
 
@@ -258,13 +258,16 @@ hwSeqX = seqX
 infixr 0 `hwSeqX`
 
 -- | Evaluate a value with given function, returning 'Nothing' if it throws
--- 'XException'.
---
--- > maybeX hasX 42                  = Just 42
--- > maybeX hasX (XException msg)    = Nothing
--- > maybeX hasX (3, XException msg) = Nothing
--- > maybeX hasX (3, _|_)            = _|_
--- > maybeX hasX _|_                 = _|_
+-- 'XException'. Note that non-'XException' errors take precedence over 'XException'
+-- ones
+--
+-- > maybeX hasX 42                    = Just 42
+-- > maybeX hasX (XException msg)      = Nothing
+-- > maybeX hasX (3, XException msg)   = Nothing
+-- > maybeX hasX (XException msg, _|_) = _|_
+-- > maybeX hasX (_|_, XException msg) = _|_
+-- > maybeX hasX (3, _|_)              = _|_
+-- > maybeX hasX _|_                   = _|_
 -- >
 -- > maybeX isX 42                  = Just 42
 -- > maybeX isX (XException msg)    = Nothing
@@ -275,15 +278,18 @@ infixr 0 `hwSeqX`
 maybeX :: (a -> Either String a) -> a -> Maybe a
 maybeX f a = either (const Nothing) Just (f a)
 
--- | Fully evaluate a value, returning 'Nothing' if it throws 'XException'.
+-- | Fully evaluate a value, returning 'Nothing' if it throws 'XException'. Note
+-- that non-'XException' errors take precedence over 'XException' ones.
 --
--- > maybeHasX 42                  = Just 42
--- > maybeHasX (XException msg)    = Nothing
--- > maybeHasX (3, XException msg) = Nothing
--- > maybeHasX (3, _|_)            = _|_
--- > maybeHasX _|_                 = _|_
+-- > maybeHasX 42                    = Just 42
+-- > maybeHasX (XException msg)      = Nothing
+-- > maybeHasX (3, XException msg)   = Nothing
+-- > maybeHasX (XException msg, _|_) = _|_
+-- > maybeHasX (_|_, XException msg) = _|_
+-- > maybeHasX (3, _|_)              = _|_
+-- > maybeHasX _|_                   = _|_
 --
-maybeHasX :: NFData a => a -> Maybe a
+maybeHasX :: (NFData a, NFDataX a) => a -> Maybe a
 maybeHasX = maybeX hasX
 
 -- | Evaluate a value to WHNF, returning 'Nothing' if it throws 'XException'.
@@ -300,20 +306,26 @@ maybeIsX = maybeX isX
 -- If you want to determine if a value contains undefined parts, use
 -- 'hasUndefined' instead.
 --
--- > hasX 42                  = Right 42
--- > hasX (XException msg)    = Left msg
--- > hasX (3, XException msg) = Left msg
--- > hasX (3, _|_)            = _|_
--- > hasX _|_                 = _|_
+-- > hasX 42                    = Right 42
+-- > hasX (XException msg)      = Left msg
+-- > hasX (3, XException msg)   = Left msg
+-- > hasX (XException msg, _|_) = _|_
+-- > hasX (_|_, XException msg) = _|_
+-- > hasX (3, _|_)              = _|_
+-- > hasX _|_                   = _|_
 --
 -- If a data structure contains multiple 'XException's, the "first" message is
--- picked according to the implementation of 'rnf'.
-hasX :: NFData a => a -> Either String a
+-- picked according to the implementation of 'rnfX'.
+hasX :: (NFData a, NFDataX a) => a -> Either String a
 hasX a =
+  -- TODO: Whenever 'a' contains an 'XException', we need to reevaluate the
+  --       structure using 'rnfX' to make sure it didn't also contain another
+  --       error call. We could prevent the two traversals by making 'hasX' a
+  --       type class method. Also see: https://github.com/clash-lang/clash-compiler/issues/2450.
   unsafeDupablePerformIO
     (catch
       (evaluate (rnf a) >> return (Right a))
-      (\(XException msg) -> return (Left msg)))
+      (\(XException msg) -> evaluate (rnfX a) >> return (Left msg)))
 {-# NOINLINE hasX #-}
 
 -- | Evaluate a value to WHNF, returning @'Left' msg@ if is a 'XException'.

clash-prelude/src/Clash/XException/MaybeX.hs

@@ -35,7 +35,7 @@ import Control.Applicative
 import Control.DeepSeq (NFData)
 import Control.Exception (throw)
 
-import Clash.XException (XException(..), isX, hasX)
+import Clash.XException (XException(..), NFDataX, isX, hasX)
 
 -- | Structure helping programmers to deal with 'Clash.XException.XException'
 -- values. For safety reasons it can't be constructed directly, but should be
@@ -83,7 +83,7 @@ toMaybeX = pure
 
 -- | Construct a 'MaybeX' value. If 'hasX' evaluates to 'Left', this function
 -- will return 'IsX'. Otherwise, it will return 'IsDefined'.
-hasXToMaybeX :: NFData a => a -> MaybeX a
+hasXToMaybeX :: (NFDataX a, NFData a) => a -> MaybeX a
 hasXToMaybeX = either IsX_ IsDefined_ . hasX
 
 -- | Deconstruct 'MaybeX' into an @a@ - the opposite of 'toMaybeX'. Be careful

clash-prelude/tests/Clash/Tests/Vector.hs

@@ -37,9 +37,7 @@ case_showVectorInList =
   "[1 :> 2 :> Nil,3 :> 4 :> Nil]" @=? show [1 :> 2 :> Nil, 3 :> i 4 :> Nil]
 
 tests :: TestTree
-tests = testGroup "All"
-  [ $(testGroupGenerator)
-  ]
+tests = $(testGroupGenerator)
 
 -- Run with:
 --

clash-prelude/tests/Clash/Tests/XException.hs

@@ -0,0 +1,47 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Clash.Tests.XException where
+
+import Clash.XException
+
+import Test.Tasty
+import Test.Tasty.HUnit
+import Test.Tasty.HUnit.Extra
+import Test.Tasty.TH
+
+expectLeft :: HasCallStack => Either a b -> Assertion
+expectLeft (Left _) = pure ()
+expectLeft (Right _) = assertFailure "Expected Left, got Right"
+
+expectRight :: HasCallStack => Either a b -> Assertion
+expectRight (Right _) = pure ()
+expectRight (Left _) = assertFailure "Expected Right, got Left"
+
+case_hasX :: Assertion
+case_hasX = do
+  expectRight        $ hasX @(Int, Int) (1, 2)
+  expectLeft         $ hasX @(Int, Int) (x, 2)
+  expectLeft         $ hasX @(Int, Int) (1, x)
+  expectLeft         $ hasX @(Int, Int) (x, x)
+  expectLeft         $ hasX @(Int, Int) x
+  expectExceptionNoX $ hasX @(Int, Int) (e, 2)
+  expectExceptionNoX $ hasX @(Int, Int) (1, e)
+  expectExceptionNoX $ hasX @(Int, Int) (e, e)
+  expectExceptionNoX $ hasX @(Int, Int) (x, e)
+  expectExceptionNoX $ hasX @(Int, Int) (e, x)
+  expectExceptionNoX $ hasX @(Int, Int) e
+ where
+  x = errorX "X"
+  e = error "E"
+
+tests :: TestTree
+tests = $(testGroupGenerator)
+
+-- Run with:
+--
+--    ./repld p:tests -T Clash.Tests.XException.main
+--
+-- Add -W if you want to run tests in spite of warnings
+--
+main :: IO ()
+main = defaultMain tests

clash-prelude/tests/Test/Tasty/HUnit/Extra.hs

@@ -6,7 +6,6 @@ module Test.Tasty.HUnit.Extra
   , expectExceptionNoX
   ) where
 
-import Control.DeepSeq (NFData)
 import Control.Exception (SomeException, try, evaluate)
 import Test.Tasty.HUnit
 
@@ -20,14 +19,14 @@ expectXException a0 =
     Right a -> assertFailure ("Expected Exception, got: " <> show a)
 
 -- | Succeed if evaluating leads to an Exception
-expectException :: (Show a, NFData a) => a -> Assertion
+expectException :: Show a => a -> Assertion
 expectException a0 =
   try @SomeException (evaluate a0) >>= \case
     Left _ -> pure ()
     Right a -> assertFailure ("Expected Exception, got: " <> show a)
 
 -- | Succeed if evaluating leads to a non-XException Exception
-expectExceptionNoX :: (Show a, NFData a) => a -> Assertion
+expectExceptionNoX :: Show a => a -> Assertion
 expectExceptionNoX a0 =
   try @SomeException (try @XException (evaluate a0)) >>= \case
     Left _ -> pure ()

clash-prelude/tests/unittests.hs

@@ -24,6 +24,7 @@ import qualified Clash.Tests.Signed
 import qualified Clash.Tests.TopEntityGeneration
 import qualified Clash.Tests.Unsigned
 import qualified Clash.Tests.Vector
+import qualified Clash.Tests.XException
 
 import qualified Clash.Tests.Laws.Enum
 import qualified Clash.Tests.Laws.SaturatingNum
@@ -52,6 +53,7 @@ tests = testGroup "Unittests"
   , Clash.Tests.TopEntityGeneration.tests
   , Clash.Tests.Unsigned.tests
   , Clash.Tests.Vector.tests
+  , Clash.Tests.XException.tests
   , testGroup "Laws"
     [ Clash.Tests.Laws.Enum.tests
     , Clash.Tests.Laws.SaturatingNum.tests