{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} 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 :: a -> Property IO property = a -> Property IO forall (m :: * -> *) a. Testable m a => a -> Property m test srcLocToLocation :: SrcLoc -> Location srcLocToLocation :: SrcLoc -> Location srcLocToLocation loc :: SrcLoc loc = Location :: FilePath -> Int -> Int -> Location Location { locationFile :: FilePath locationFile = SrcLoc -> FilePath srcLocFile SrcLoc loc , locationLine :: Int locationLine = SrcLoc -> Int srcLocStartLine SrcLoc loc , locationColumn :: Int locationColumn = SrcLoc -> Int srcLocStartCol SrcLoc loc } instance Testable IO (IO ()) where test :: IO () -> Property IO test action :: IO () action = IO (Property IO) -> Property IO forall (m :: * -> *) a. Testable m a => m a -> Property m monadic (IO (Property IO) -> Property IO) -> IO (Property IO) -> Property IO forall a b. (a -> b) -> a -> b $ do Either HUnitFailure () r <- IO () -> IO (Either HUnitFailure ()) forall e a. Exception e => IO a -> IO (Either e a) try IO () action Property IO -> IO (Property IO) forall (m :: * -> *) a. Monad m => a -> m a return (Property IO -> IO (Property IO)) -> Property IO -> IO (Property IO) forall a b. (a -> b) -> a -> b $ case Either HUnitFailure () r of Right () -> Bool -> Property IO forall (m :: * -> *) a. Testable m a => a -> Property m test Bool True Left e :: HUnitFailure e -> case HUnitFailure e of HUnit.HUnitFailure loc :: Maybe SrcLoc loc reason :: FailureReason reason -> Either FilePath FilePath -> Property IO forall (m :: * -> *) a. Testable m a => a -> Property m test (Either FilePath FilePath -> Property IO) -> (Reason -> Either FilePath FilePath) -> Reason -> Property IO forall b c a. (b -> c) -> (a -> b) -> a -> c . Reason -> Either FilePath FilePath failure (Reason -> Property IO) -> Reason -> Property IO forall a b. (a -> b) -> a -> b $ case FailureReason reason of HUnit.Reason s :: FilePath s -> FilePath -> Reason T.Reason FilePath s HUnit.ExpectedButGot prefix :: Maybe FilePath prefix expected :: FilePath expected actual :: FilePath actual -> FilePath -> FilePath -> FilePath -> Reason T.ExpectedActual (FilePath -> Maybe FilePath -> FilePath forall a. a -> Maybe a -> a fromMaybe "" Maybe FilePath prefix) FilePath expected FilePath actual where failure :: T.Reason -> Either String String failure :: Reason -> Either FilePath FilePath failure = FilePath -> Either FilePath FilePath forall a b. a -> Either a b Left (FilePath -> Either FilePath FilePath) -> (Reason -> FilePath) -> Reason -> Either FilePath FilePath forall b c a. (b -> c) -> (a -> b) -> a -> c . Result -> FilePath forall a. Show a => a -> FilePath show (Result -> FilePath) -> (Reason -> Result) -> Reason -> FilePath forall b c a. (b -> c) -> (a -> b) -> a -> c . Maybe Location -> Reason -> Result T.Failure (SrcLoc -> Location srcLocToLocation (SrcLoc -> Location) -> Maybe SrcLoc -> Maybe Location forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Maybe SrcLoc loc) instance Example (Property IO) where type Arg (Property IO) = () evaluateExample :: Property IO -> Params -> (ActionWith (Arg (Property IO)) -> IO ()) -> ProgressCallback -> IO Result evaluateExample p :: Property IO p c :: Params c _ reportProgress :: ProgressCallback reportProgress = do IORef Int counter <- Int -> IO (IORef Int) forall a. a -> IO (IORef a) newIORef 0 let hook :: TestQuality -> IO () hook _ = do IORef Int -> (Int -> Int) -> IO () forall a. IORef a -> (a -> a) -> IO () modifyIORef IORef Int counter Int -> Int forall a. Enum a => a -> a succ Int n <- IORef Int -> IO Int forall a. IORef a -> IO a readIORef IORef Int counter ProgressCallback reportProgress (Int n, 0) Maybe PropertyFailure r <- Int -> (TestQuality -> IO ()) -> Property IO -> IO (Maybe PropertyFailure) forall (m :: * -> *) a. Testable m a => Int -> (TestQuality -> m ()) -> a -> m (Maybe PropertyFailure) smallCheckWithHook (Params -> Int paramsSmallCheckDepth Params c) TestQuality -> IO () hook Property IO p Result -> IO Result forall (m :: * -> *) a. Monad m => a -> m a return (Result -> IO Result) -> (ResultStatus -> Result) -> ResultStatus -> IO Result forall b c a. (b -> c) -> (a -> b) -> a -> c . FilePath -> ResultStatus -> Result Result "" (ResultStatus -> IO Result) -> ResultStatus -> IO Result forall a b. (a -> b) -> a -> b $ case Maybe PropertyFailure r of Just e :: PropertyFailure e -> case FilePath -> (FilePath, Maybe Result) T.parseResult (PropertyFailure -> FilePath ppFailure PropertyFailure e) of (m :: FilePath m, Just (T.Failure loc :: Maybe Location loc reason :: Reason reason)) -> Maybe Location -> FailureReason -> ResultStatus Failure Maybe Location loc (FailureReason -> ResultStatus) -> FailureReason -> ResultStatus forall a b. (a -> b) -> a -> b $ case Reason reason of T.Reason err :: FilePath err -> FilePath -> FailureReason Reason (FilePath -> Maybe FilePath -> FilePath forall a. a -> Maybe a -> a fromMaybe "" (Maybe FilePath -> FilePath) -> Maybe FilePath -> FilePath forall a b. (a -> b) -> a -> b $ FilePath -> FilePath -> Maybe FilePath T.concatPrefix FilePath m FilePath err) T.ExpectedActual prefix :: FilePath prefix expected :: FilePath expected actual :: FilePath actual -> Maybe FilePath -> FilePath -> FilePath -> FailureReason ExpectedButGot (FilePath -> FilePath -> Maybe FilePath T.concatPrefix FilePath m FilePath prefix) FilePath expected FilePath actual (m :: FilePath m, Nothing) -> Maybe Location -> FailureReason -> ResultStatus Failure Maybe Location forall a. Maybe a Nothing (FilePath -> FailureReason Reason FilePath m) Nothing -> ResultStatus Success