1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
|
{-# LANGUAGE GADTs, TemplateHaskell, CPP #-}
{-# OPTIONS_GHC -fdefer-type-errors #-}
module Main where
import Control.DeepSeq
import Control.Exception
import GHC.Generics (Generic)
import Test.Hspec
import Test.Hspec.Expectations (expectationFailure)
import qualified Test.HUnit.Lang as HL
import Test.ShouldNotTypecheck
data Result
= Success
| Failure
| Error String
#if MIN_VERSION_HUnit(1,3,0)
toResult :: HL.Result -> Result
toResult result = case result of
HL.Success -> Success
HL.Failure _ _ -> Failure
HL.Error _ msg -> Error msg
#else
toResult :: Maybe (Bool, String) -> Result
toResult result = case result of
Nothing -> Success
Just (True, _) -> Failure
Just (False, msg) -> Error msg
#endif
shouldFailAssertion :: IO () -> IO ()
shouldFailAssertion value = do
result <- HL.performTestCase value
case toResult result of
Success -> expectationFailure "Did not throw an assertion error"
Failure -> return ()
Error msg -> expectationFailure $ "Raised an error " ++ msg
shouldThrowException :: Exception e => e -> IO () -> IO ()
shouldThrowException exception value = do
result <- HL.performTestCase value
case toResult result of
Success -> expectationFailure "Did not throw exception: assertion succeeded"
Failure -> expectationFailure "Did not throw exception: assertion failed"
Error msg -> case msg == show exception of
True -> return ()
False -> expectationFailure "Incorrect exception propagated"
data Expr t where
IntVal :: Int -> Expr Int
BoolVal :: Bool -> Expr Bool
Add :: Expr Int -> Expr Int -> Expr Int
instance NFData (Expr t) where
rnf expr = case expr of
IntVal i -> rnf i
BoolVal b -> rnf b
Add l r -> rnf l `seq` rnf r
data NoNFDataInstance = NoNFDataInstance
main :: IO ()
main = hspec $ do
describe "shouldNotCompile" $ do
it "should not throw an assertion error when an expression is ill typed" $ do
shouldNotTypecheck ("foo" :: Int)
it "should throw an assertion error when an expression is well typed" $ do
shouldFailAssertion (shouldNotTypecheck ("foo" :: String))
it "should throw an actual exception and not fail the assertion if the expression contains an non-HUnitFailure exception" $ do
let exception = NoMethodError "lol"
shouldThrowException exception (shouldNotTypecheck (throw exception :: Int))
it "should propagate an actual exception and not fail the assertion if the expression contains a non-deferred ErrorCall exception" $ do
let exception = ErrorCall "yay"
shouldThrowException exception (shouldNotTypecheck (throw exception :: Int))
it "should not throw an assertion when an expression with more than one level of constructors is ill typed" $ do
shouldNotTypecheck (Add (BoolVal True) (IntVal 4))
it "should warn if an expression had a type error due to lack of NFData instance" $ do
shouldFailAssertion (shouldNotTypecheck NoNFDataInstance)
|
