module Test.Hspec (
SpecM
, Spec
, describe
, context
, it
, Expectation
, expect
, shouldBe
, shouldReturn
, hspec
#ifdef TEST
, evaluateExpectation
, Result (..)
#endif
) where
#if !(MIN_VERSION_base(4,8,0))
import Control.Applicative
import Data.Monoid
#endif
import Control.Monad
import Data.List (intercalate)
import Data.Typeable
import qualified Control.Exception as E
import System.Exit
data SpecM a = SpecM a [SpecTree]
add :: SpecTree -> SpecM ()
add s = SpecM () [s]
instance Functor SpecM where
fmap = undefined
instance Applicative SpecM where
pure a = SpecM a []
(<*>) = ap
instance Monad SpecM where
return = pure
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
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` [
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))
]