{-# 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

#ifdef TEST
-- * Internal stuff
, 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

-- a writer monad
data SpecM a = SpecM a [SpecTree]

add :: SpecTree -> SpecM ()
add :: SpecTree -> SpecM ()
add SpecTree
s = forall a. a -> [SpecTree] -> SpecM a
SpecM () [SpecTree
s]

instance Functor SpecM where
  fmap :: forall a b. (a -> b) -> SpecM a -> SpecM b
fmap = forall a. HasCallStack => a
undefined

instance Applicative SpecM where
  pure :: forall a. a -> SpecM a
pure a
a = forall a. a -> [SpecTree] -> SpecM a
SpecM a
a []
  <*> :: forall a b. SpecM (a -> b) -> SpecM a -> SpecM b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad SpecM where
  return :: forall a. a -> SpecM a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  SpecM a
a [SpecTree]
xs >>= :: forall a b. SpecM a -> (a -> SpecM b) -> SpecM b
>>= a -> SpecM b
f = case a -> SpecM b
f a
a of
    SpecM b
b [SpecTree]
ys -> forall a. a -> [SpecTree] -> SpecM a
SpecM b
b ([SpecTree]
xs forall a. [a] -> [a] -> [a]
++ [SpecTree]
ys)

data SpecTree = SpecGroup String Spec
              | SpecExample String (IO Result)

data Result = Success | Failure String
  deriving (Result -> Result -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Result -> Result -> Bool
$c/= :: Result -> Result -> Bool
== :: Result -> Result -> Bool
$c== :: Result -> Result -> Bool
Eq, Int -> Result -> ShowS
[Result] -> ShowS
Result -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Result] -> ShowS
$cshowList :: [Result] -> ShowS
show :: Result -> String
$cshow :: Result -> String
showsPrec :: Int -> Result -> ShowS
$cshowsPrec :: Int -> Result -> ShowS
Show)

type Spec = SpecM ()

describe :: String -> Spec -> Spec
describe :: String -> SpecM () -> SpecM ()
describe String
label = SpecTree -> SpecM ()
add forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> SpecM () -> SpecTree
SpecGroup String
label

context :: String -> Spec -> Spec
context :: String -> SpecM () -> SpecM ()
context = String -> SpecM () -> SpecM ()
describe

it :: String -> Expectation -> Spec
it :: String -> Expectation -> SpecM ()
it String
label = SpecTree -> SpecM ()
add forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO Result -> SpecTree
SpecExample String
label forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expectation -> IO Result
evaluateExpectation

-- | Summary of a test run.
data Summary = Summary Int Int

instance Monoid Summary where
  mempty :: Summary
mempty = Int -> Int -> Summary
Summary Int
0 Int
0
#if !MIN_VERSION_base(4,11,0)
  (Summary x1 x2) `mappend` (Summary y1 y2) = Summary (x1 + y1) (x2 + y2)
#else
instance Semigroup Summary where
  (Summary Int
x1 Int
x2) <> :: Summary -> Summary -> Summary
<> (Summary Int
y1 Int
y2) = Int -> Int -> Summary
Summary (Int
x1 forall a. Num a => a -> a -> a
+ Int
y1) (Int
x2 forall a. Num a => a -> a -> a
+ Int
y2)
#endif

runSpec :: Spec -> IO Summary
runSpec :: SpecM () -> IO Summary
runSpec = [String] -> SpecM () -> IO Summary
runForrest []
  where
    runForrest :: [String] -> Spec -> IO Summary
    runForrest :: [String] -> SpecM () -> IO Summary
runForrest [String]
labels (SpecM () [SpecTree]
xs) = forall a. Monoid a => [a] -> a
mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([String] -> SpecTree -> IO Summary
runTree [String]
labels) [SpecTree]
xs

    runTree :: [String] -> SpecTree -> IO Summary
    runTree :: [String] -> SpecTree -> IO Summary
runTree [String]
labels SpecTree
spec = case SpecTree
spec of
      SpecExample String
label IO Result
x -> do
        String -> Expectation
putStr forall a b. (a -> b) -> a -> b
$ String
"/" forall a. [a] -> [a] -> [a]
++ (forall a. [a] -> [[a]] -> [a]
intercalate String
"/" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse) (String
labelforall a. a -> [a] -> [a]
:[String]
labels) forall a. [a] -> [a] -> [a]
++ String
"/ "
        Result
r <- IO Result
x
        case Result
r of
          Result
Success   -> do
            String -> Expectation
putStrLn String
"OK"
            forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Int -> Summary
Summary Int
1 Int
0)
          Failure String
err -> do
            String -> Expectation
putStrLn String
"FAILED"
            String -> Expectation
putStrLn String
err
            forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Int -> Summary
Summary Int
1 Int
1)
      SpecGroup String
label SpecM ()
xs  -> do
        [String] -> SpecM () -> IO Summary
runForrest (String
labelforall a. a -> [a] -> [a]
:[String]
labels) SpecM ()
xs

hspec :: Spec -> IO ()
hspec :: SpecM () -> Expectation
hspec SpecM ()
spec = do
  Summary Int
total Int
failures <- SpecM () -> IO Summary
runSpec SpecM ()
spec
  String -> Expectation
putStrLn (forall a. Show a => a -> String
show Int
total forall a. [a] -> [a] -> [a]
++ String
" example(s), " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
failures forall a. [a] -> [a] -> [a]
++ String
" failure(s)")
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
failures forall a. Eq a => a -> a -> Bool
/= Int
0) forall a. IO a
exitFailure

type Expectation = IO ()

infix 1 `shouldBe`, `shouldReturn`

shouldBe :: (Show a, Eq a) => a -> a -> Expectation
a
actual shouldBe :: forall a. (Show a, Eq a) => a -> a -> Expectation
`shouldBe` a
expected =
  String -> Bool -> Expectation
expect (String
"expected: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
expected forall a. [a] -> [a] -> [a]
++ String
"\n but got: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
actual) (a
actual forall a. Eq a => a -> a -> Bool
== a
expected)

shouldReturn :: (Show a, Eq a) => IO a -> a -> Expectation
IO a
action shouldReturn :: forall a. (Show a, Eq a) => IO a -> a -> Expectation
`shouldReturn` a
expected = IO a
action forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall a. (Show a, Eq a) => a -> a -> Expectation
`shouldBe` a
expected)

expect :: String -> Bool -> Expectation
expect :: String -> Bool -> Expectation
expect String
label Bool
f
  | Bool
f         = forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise = forall e a. Exception e => e -> IO a
E.throwIO (String -> ExpectationFailure
ExpectationFailure String
label)

data ExpectationFailure = ExpectationFailure String
  deriving (Int -> ExpectationFailure -> ShowS
[ExpectationFailure] -> ShowS
ExpectationFailure -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExpectationFailure] -> ShowS
$cshowList :: [ExpectationFailure] -> ShowS
show :: ExpectationFailure -> String
$cshow :: ExpectationFailure -> String
showsPrec :: Int -> ExpectationFailure -> ShowS
$cshowsPrec :: Int -> ExpectationFailure -> ShowS
Show, ExpectationFailure -> ExpectationFailure -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ExpectationFailure -> ExpectationFailure -> Bool
$c/= :: ExpectationFailure -> ExpectationFailure -> Bool
== :: ExpectationFailure -> ExpectationFailure -> Bool
$c== :: ExpectationFailure -> ExpectationFailure -> Bool
Eq, Typeable)

instance E.Exception ExpectationFailure

evaluateExpectation :: Expectation -> IO Result
evaluateExpectation :: Expectation -> IO Result
evaluateExpectation Expectation
action = (Expectation
action forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Result
Success)
  forall a. IO a -> [Handler a] -> IO a
`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.
    forall a e. Exception e => (e -> IO a) -> Handler a
E.Handler forall a b. (a -> b) -> a -> b
$ \AsyncException
e -> forall a e. Exception e => e -> a
E.throw (AsyncException
e :: E.AsyncException)

  , forall a e. Exception e => (e -> IO a) -> Handler a
E.Handler forall a b. (a -> b) -> a -> b
$ \(ExpectationFailure String
err) -> forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Result
Failure String
err)
  , forall a e. Exception e => (e -> IO a) -> Handler a
E.Handler forall a b. (a -> b) -> a -> b
$ \SomeException
e -> (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Result
Failure) (String
"*** Exception: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (SomeException
e :: E.SomeException))
  ]