aboutsummaryrefslogtreecommitdiff
path: root/tests/nanospec/Test/Hspec.hs
blob: 904ce2e0ecaacc3ee1a406ae9c90361dfed3e45d (plain) (blame)
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))
  ]