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
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
|
{-# LANGUAGE DeriveDataTypeable, CPP #-}
-- | A lightweight implementation of a subset of Hspec's API.
module Test.Hspec (
-- * Types
SpecM
, Spec
-- * Defining a spec
, describe
, context
, it
-- ** Setting expectations
, Expectation
, expect
, shouldBe
, shouldReturn
-- * Running a spec
, hspec
) where
import Control.Applicative
import Control.Monad
import Data.Monoid
import Data.List (intercalate)
import Data.Typeable
import qualified Control.Exception as E
import System.Exit
-- a writer monad
data SpecM a = SpecM a [SpecTree]
add :: SpecTree -> SpecM ()
add s = SpecM () [s]
instance Monad SpecM where
return a = SpecM a []
SpecM a xs >>= f = case f a of
SpecM b ys -> SpecM b (xs ++ ys)
data SpecTree = SpecGroup String Spec
| SpecExample String (IO Result)
data Result = Success | Failure String
deriving (Eq, Show)
type Spec = SpecM ()
describe :: String -> Spec -> Spec
describe label = add . SpecGroup label
context :: String -> Spec -> Spec
context = describe
it :: String -> Expectation -> Spec
it label = add . SpecExample label . evaluateExpectation
-- | Summary of a test run.
data Summary = Summary Int Int
instance Monoid Summary where
mempty = Summary 0 0
(Summary x1 x2) `mappend` (Summary y1 y2) = Summary (x1 + y1) (x2 + y2)
runSpec :: Spec -> IO Summary
runSpec = runForrest []
where
runForrest :: [String] -> Spec -> IO Summary
runForrest labels (SpecM () xs) = mconcat <$> mapM (runTree labels) xs
runTree :: [String] -> SpecTree -> IO Summary
runTree labels spec = case spec of
SpecExample label x -> do
putStr $ "/" ++ (intercalate "/" . reverse) (label:labels) ++ "/ "
r <- x
case r of
Success -> do
putStrLn "OK"
return (Summary 1 0)
Failure err -> do
putStrLn "FAILED"
putStrLn err
return (Summary 1 1)
SpecGroup label xs -> do
runForrest (label:labels) xs
hspec :: Spec -> IO ()
hspec spec = do
Summary total failures <- runSpec spec
putStrLn (show total ++ " example(s), " ++ show failures ++ " failure(s)")
when (failures /= 0) exitFailure
type Expectation = IO ()
infix 1 `shouldBe`, `shouldReturn`
shouldBe :: (Show a, Eq a) => a -> a -> Expectation
actual `shouldBe` expected =
expect ("expected: " ++ show expected ++ "\n but got: " ++ show actual) (actual == expected)
shouldReturn :: (Show a, Eq a) => IO a -> a -> Expectation
action `shouldReturn` expected = action >>= (`shouldBe` expected)
expect :: String -> Bool -> Expectation
expect label f
| f = return ()
| otherwise = E.throwIO (ExpectationFailure label)
data ExpectationFailure = ExpectationFailure String
deriving (Show, Eq, Typeable)
instance E.Exception ExpectationFailure
evaluateExpectation :: Expectation -> IO Result
evaluateExpectation action = (action >> return Success)
`E.catches` [
-- Re-throw AsyncException, otherwise execution will not terminate on SIGINT
-- (ctrl-c). All AsyncExceptions are re-thrown (not just UserInterrupt)
-- because all of them indicate severe conditions and should not occur during
-- normal operation.
E.Handler $ \e -> E.throw (e :: E.AsyncException)
, E.Handler $ \(ExpectationFailure err) -> return (Failure err)
, E.Handler $ \e -> (return . Failure) ("*** Exception: " ++ show (e :: E.SomeException))
]
|
