module Test.Hspec.Core.Type (
Spec
, SpecM (..)
, runSpecM
, fromSpecList
, SpecTree (..)
, Example (..)
, Result (..)
, Params (..)
, Progress
, describe
, it
, pending
, pendingWith
) where
import qualified Control.Exception as E
import Control.Applicative
import Control.Monad (when)
import Control.Monad.Trans.Writer (Writer, execWriter, tell)
import Data.Typeable (Typeable)
import Data.List (isPrefixOf)
import Data.Maybe (fromMaybe)
import Test.Hspec.Util
import Test.Hspec.Expectations
import Test.HUnit.Lang (HUnitFailure(..))
import qualified Test.QuickCheck as QC
import qualified Test.QuickCheck.State as QC
import qualified Test.QuickCheck.Property as QCP
import qualified Test.QuickCheck.IO ()
import Test.Hspec.Compat (isUserInterrupt)
type Spec = SpecM ()
newtype SpecM a = SpecM (Writer [SpecTree] a)
deriving (Functor, Applicative, Monad)
runSpecM :: Spec -> [SpecTree]
runSpecM (SpecM specs) = execWriter specs
fromSpecList :: [SpecTree] -> Spec
fromSpecList = SpecM . tell
data Result = Success | Pending (Maybe String) | Fail String
deriving (Eq, Show, Read, Typeable)
instance E.Exception Result
type Progress = (Int, Int)
data Params = Params {
paramsQuickCheckArgs :: QC.Args
, paramsReportProgress :: Progress -> IO ()
}
data SpecTree =
SpecGroup String [SpecTree]
| SpecItem String (Params -> IO Result)
describe :: String -> [SpecTree] -> SpecTree
describe s = SpecGroup msg
where
msg
| null s = "(no description given)"
| otherwise = s
it :: Example a => String -> a -> SpecTree
it s e = SpecItem msg (`evaluateExample` e)
where
msg
| null s = "(unspecified behavior)"
| otherwise = s
class Example a where
evaluateExample :: Params -> a -> IO Result
instance Example Bool where
evaluateExample _ b = if b then return Success else return (Fail "")
instance Example Expectation where
evaluateExample _ action = (action >> return Success) `E.catches` [
E.Handler (\(HUnitFailure err) -> (return . Fail) err)
, E.Handler (return :: Result -> IO Result)
]
instance Example Result where
evaluateExample _ r = return r
instance Example QC.Property where
evaluateExample c p = do
r <- QC.quickCheckWithResult (paramsQuickCheckArgs c) (QCP.callback progressCallback p)
when (isUserInterrupt r) $ do
E.throwIO E.UserInterrupt
return $
case r of
QC.Success {} -> Success
QC.Failure {QC.output = m} -> fromMaybe (Fail $ sanitizeFailureMessage m) (parsePending m)
QC.GaveUp {QC.numTests = n} -> Fail ("Gave up after " ++ quantify n "test" )
QC.NoExpectedFailure {} -> Fail ("No expected failure")
where
progressCallback = QCP.PostTest QCP.NotCounterexample $
\st _ -> paramsReportProgress c (QC.numSuccessTests st, QC.maxSuccessTests st)
sanitizeFailureMessage :: String -> String
sanitizeFailureMessage = strip . addFalsifiable . stripFailed
addFalsifiable :: String -> String
addFalsifiable m
| "(after " `isPrefixOf` m = "Falsifiable " ++ m
| otherwise = m
stripFailed :: String -> String
stripFailed m
| prefix `isPrefixOf` m = drop n m
| otherwise = m
where
prefix = "*** Failed! "
n = length prefix
parsePending :: String -> Maybe Result
parsePending m
| prefix `isPrefixOf` m = (readMaybe . takeWhile (/= '\'') . drop n) m
| otherwise = Nothing
where
n = length prefix
prefix = "*** Failed! Exception: '"
pending :: Expectation
pending = E.throwIO (Pending Nothing)
pendingWith :: String -> Expectation
pendingWith = E.throwIO . Pending . Just