{-# 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 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 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 HUnitFailure e -> case HUnitFailure e of HUnit.HUnitFailure Maybe SrcLoc loc 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 FilePath s -> FilePath -> Reason T.Reason FilePath s HUnit.ExpectedButGot Maybe FilePath prefix FilePath expected FilePath actual -> FilePath -> FilePath -> FilePath -> Reason T.ExpectedActual (FilePath -> Maybe FilePath -> FilePath forall a. a -> Maybe a -> a fromMaybe FilePath "" 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 Property IO p Params c ActionWith (Arg (Property IO)) -> IO () _ ProgressCallback reportProgress = do IORef Int counter <- Int -> IO (IORef Int) forall a. a -> IO (IORef a) newIORef Int 0 let hook :: TestQuality -> IO () hook TestQuality _ = 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, Int 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 FilePath "" (ResultStatus -> IO Result) -> ResultStatus -> IO Result forall a b. (a -> b) -> a -> b $ case Maybe PropertyFailure r of Just PropertyFailure e -> case FilePath -> (FilePath, Maybe Result) T.parseResult (PropertyFailure -> FilePath ppFailure PropertyFailure e) of (FilePath m, Just (T.Failure Maybe Location loc 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 FilePath err -> FilePath -> FailureReason Reason (FilePath -> Maybe FilePath -> FilePath forall a. a -> Maybe a -> a fromMaybe FilePath "" (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 FilePath prefix FilePath expected FilePath actual -> Maybe FilePath -> FilePath -> FilePath -> FailureReason ExpectedButGot (FilePath -> FilePath -> Maybe FilePath T.concatPrefix FilePath m FilePath prefix) FilePath expected FilePath actual (FilePath m, Maybe Result Nothing) -> Maybe Location -> FailureReason -> ResultStatus Failure Maybe Location forall a. Maybe a Nothing (FilePath -> FailureReason Reason FilePath m) Maybe PropertyFailure Nothing -> ResultStatus Success