    {-# 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 :: forall a. Testable IO a => 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 {
      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
        r <- IO () -> IO (Either HUnitFailure ())
    forall e a. Exception e => IO a -> IO (Either e a)
    try IO ()
    action
        return $ case 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
        counter <- Int -> IO (IORef Int)
    forall a. a -> IO (IORef a)
    newIORef Int
    0
        let 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
              n <- IORef Int -> IO Int
    forall a. IORef a -> IO a
    readIORef IORef Int
    counter
              reportProgress (n, 0)
        r <- smallCheckWithHook (fromMaybe 5 $ paramsSmallCheckDepth c) hook p
        return . Result "" $ case 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