强制执行严格哈斯克尔

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的失败部分实际上从来没有在这里评估过。

为了弥补这一点，我试图用(seq fun $ assertFailure msg)替换(fun >> assertFailure msg)。我还尝试启用BangPatterns扩展，并在fun绑定之前发出一声巨响，但没有任何帮助。那么我怎么才能真正强迫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 ... 

但是，要小心，因为assertFailureis implemented使用异常，所以包装到catch块可能会抓住它。所以，我建议，以评估使用try并调用assertFailure的try块外计算：

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