{-# 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 s :: SpecTree
s = () -> [SpecTree] -> SpecM ()
forall a. a -> [SpecTree] -> SpecM a
SpecM () [SpecTree
s]

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

instance Applicative SpecM where
  pure :: a -> SpecM a
pure a :: a
a = a -> [SpecTree] -> SpecM a
forall a. a -> [SpecTree] -> SpecM a
SpecM a
a []
  <*> :: SpecM (a -> b) -> SpecM a -> SpecM 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 :: a -> SpecM a
return = a -> SpecM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  SpecM a :: a
a xs :: [SpecTree]
xs >>= :: SpecM a -> (a -> SpecM b) -> SpecM b
>>= f :: a -> SpecM b
f = case a -> SpecM b
f a
a of
    SpecM b :: b
b ys :: [SpecTree]
ys -> b -> [SpecTree] -> SpecM b
forall a. a -> [SpecTree] -> SpecM a
SpecM b
b ([SpecTree]
xs [SpecTree] -> [SpecTree] -> [SpecTree]
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
(Result -> Result -> Bool)
-> (Result -> Result -> Bool) -> Eq Result
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
(Int -> Result -> ShowS)
-> (Result -> String) -> ([Result] -> ShowS) -> Show Result
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 label :: String
label = SpecTree -> SpecM ()
add (SpecTree -> SpecM ())
-> (SpecM () -> SpecTree) -> SpecM () -> SpecM ()
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 label :: String
label = SpecTree -> SpecM ()
add (SpecTree -> SpecM ())
-> (Expectation -> SpecTree) -> Expectation -> SpecM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO Result -> SpecTree
SpecExample String
label (IO Result -> SpecTree)
-> (Expectation -> IO Result) -> Expectation -> SpecTree
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 0 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 x1 :: Int
x1 x2 :: Int
x2) <> :: Summary -> Summary -> Summary
<> (Summary y1 :: Int
y1 y2 :: Int
y2) = Int -> Int -> Summary
Summary (Int
x1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y1) (Int
x2 Int -> Int -> Int
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 labels :: [String]
labels (SpecM () xs :: [SpecTree]
xs) = [Summary] -> Summary
forall a. Monoid a => [a] -> a
mconcat ([Summary] -> Summary) -> IO [Summary] -> IO Summary
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SpecTree -> IO Summary) -> [SpecTree] -> IO [Summary]
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 labels :: [String]
labels spec :: SpecTree
spec = case SpecTree
spec of
      SpecExample label :: String
label x :: IO Result
x -> do
        String -> Expectation
putStr (String -> Expectation) -> String -> Expectation
forall a b. (a -> b) -> a -> b
$ "/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "/" ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. [a] -> [a]
reverse) (String
labelString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
labels) String -> ShowS
forall a. [a] -> [a] -> [a]
++ "/ "
        Result
r <- IO Result
x
        case Result
r of
          Success   -> do
            String -> Expectation
putStrLn "OK"
            Summary -> IO Summary
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Int -> Summary
Summary 1 0)
          Failure err :: String
err -> do
            String -> Expectation
putStrLn "FAILED"
            String -> Expectation
putStrLn String
err
            Summary -> IO Summary
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Int -> Summary
Summary 1 1)
      SpecGroup label :: String
label xs :: SpecM ()
xs  -> do
        [String] -> SpecM () -> IO Summary
runForrest (String
labelString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
labels) SpecM ()
xs

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

type Expectation = IO ()

infix 1 `shouldBe`, `shouldReturn`

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

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

expect :: String -> Bool -> Expectation
expect :: String -> Bool -> Expectation
expect label :: String
label f :: Bool
f
  | Bool
f         = () -> Expectation
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise = ExpectationFailure -> Expectation
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
(Int -> ExpectationFailure -> ShowS)
-> (ExpectationFailure -> String)
-> ([ExpectationFailure] -> ShowS)
-> Show ExpectationFailure
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
(ExpectationFailure -> ExpectationFailure -> Bool)
-> (ExpectationFailure -> ExpectationFailure -> Bool)
-> Eq ExpectationFailure
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 action :: Expectation
action = (Expectation
action Expectation -> IO Result -> IO Result
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
Success)
  IO Result -> [Handler Result] -> IO Result
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.
    (AsyncException -> IO Result) -> Handler Result
forall a e. Exception e => (e -> IO a) -> Handler a
E.Handler ((AsyncException -> IO Result) -> Handler Result)
-> (AsyncException -> IO Result) -> Handler Result
forall a b. (a -> b) -> a -> b
$ \e :: AsyncException
e -> AsyncException -> IO Result
forall a e. Exception e => e -> a
E.throw (AsyncException
e :: E.AsyncException)

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