{-# 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