在 Haskell 中执行严格

Question

在 Haskell 中做一些 TTD 时，我最近开发了以下函数：

import Test.HUnit
import Data.Typeable
import Control.Exception

assertException :: (Show a) => TypeRep -> IO a -> Assertion
assertException errType fun = catch (fun >> assertFailure msg) handle
    where
    msg = show errType ++ " exception was not raised!"
    handle (SomeException e) [...]

该函数采用预期异常和 IO 操作的类型表示。问题是大多数时候我都没有抛出异常，即使我应该这样做，因为懒惰。通常，fun 的失败部分实际上从未在这里进行评估。

为了解决这个问题，我尝试将(fun >> assertFailure msg) 替换为(seq fun $ assertFailure msg)。我还尝试启用 BangPatterns 扩展并在 fun 绑定之前添加一个 bang，但没有任何帮助。那么如何才能真正强制 Haskell 严格评估 fun？

Answer 1

你必须区分：

• 评估类型IO a的值
• 运行它所代表的动作，可能会产生副作用并返回a类型的值，并且
• 评估a（或其中的一部分）类型的结果。

这些总是按顺序发生，但不一定全部发生。代码

foo1 :: IO a -> IO ()
foo1 f = do
   seq f (putStrLn "done")

只会做第一个，而

foo2 :: IO a -> IO ()
foo2 f = do
   f -- equivalent to _ <- f
   putStrLn "done"

第二个也是最后一个

foo3 :: IO a -> IO ()
foo3 f = do
   x <- f 
   seq x $ putStrLn "done"

第三个也是如此（但在列表等复杂数据类型上使用seq 的常见警告适用）。

尝试这些参数并观察foo1、foo2 和foo3 对待它们的方式不同。

f1 = error "I am not a value"
f2 = fix id -- neither am I
f3 = do {putStrLn "Something is printed"; return 42}
f4 = do {putStrLn "Something is printed"; return (error "x has been evaluated")}
f5 = do {putStrLn "Something is printed"; return (Just (error "x has been deeply evaluated"))}

Answer 2

您可能需要将值强制为其正常形式，而不仅仅是其弱头部正常形式。例如，将Just (error "foo") 评估为WHNF 不会触发异常，它只会评估Just。我会使用evaluate（允许使用IO 操作正确排序强制评估）和rnf（或force，如果您需要某些值）的组合：

assertException :: (Show a) => TypeRep -> IO a -> Assertion
assertException errType fun =
    catch (fun >>= evaluate . rnf >> assertFailure msg) handle
  where ...

但是，要小心，因为 assertFailure is implemented 使用异常，所以包装到 catch 块中也可能会捕获它。所以我建议使用try 评估计算并在try 块之外调用assertFailure：

import Test.HUnit
import Data.Typeable
import Control.DeepSeq
import Control.Exception

assertException :: (NFData a, Show a) => TypeRep -> IO a -> Assertion
assertException errType fun =
    (try (fun >>= evaluate . rnf) :: IO (Either SomeException ())) >>= check
  where
    check (Right _) =
        assertFailure $ show errType ++ " exception was not raised!"
    check (Left (SomeException ex))
      | typeOf ex == errType    = return () -- the expected exception
      | otherwise               = assertFailure
                                    $ show ex ++ " is not " ++ show errType