module Test.Hspec.SmallCheck (property) where
import Prelude ()
import Test.Hspec.SmallCheck.Compat
import Data.IORef
import Test.Hspec.Core.Spec
import Test.SmallCheck
import Test.SmallCheck.Drivers
import qualified Test.HUnit.Lang as HUnit
import Control.Exception (try)
import Data.Maybe
import Data.CallStack
import qualified Test.Hspec.SmallCheck.Types as T
property :: Testable IO a => a -> Property IO
property = test
srcLocToLocation :: SrcLoc -> Location
srcLocToLocation loc = Location {
locationFile = srcLocFile loc
, locationLine = srcLocStartLine loc
, locationColumn = srcLocStartCol loc
}
instance Testable IO (IO ()) where
test action = monadic $ do
r <- try action
return $ case r of
Right () -> test True
Left e -> case e of
HUnit.HUnitFailure loc reason -> test . failure $ case reason of
HUnit.Reason s -> T.Reason s
HUnit.ExpectedButGot prefix expected actual -> T.ExpectedActual (fromMaybe "" prefix) expected actual
where
failure :: T.Reason -> Either String String
failure = Left . show . T.Failure (srcLocToLocation <$> loc)
instance Example (Property IO) where
type Arg (Property IO) = ()
evaluateExample p c _ reportProgress = do
counter <- newIORef 0
let hook _ = do
modifyIORef counter succ
n <- readIORef counter
reportProgress (n, 0)
r <- smallCheckWithHook (paramsSmallCheckDepth c) hook p
return . Result "" $ case r of
Just e -> case T.parseResult (ppFailure e) of
(m, Just (T.Failure loc reason)) -> Failure loc $ case reason of
T.Reason err -> Reason (fromMaybe "" $ T.concatPrefix m err)
T.ExpectedActual prefix expected actual -> ExpectedButGot (T.concatPrefix m prefix) expected actual
(m, Nothing) -> Failure Nothing (Reason m)
Nothing -> Success