module Test.Golden.Internal where
import Data.Typeable (Typeable)
import Control.Applicative
import Control.Monad.Cont
import Test.Framework.Providers.API hiding (liftIO)
import qualified Test.Framework.Providers.API as TF
import Data.ByteString.Lazy as LB
import Control.Exception
import System.IO
import Data.Maybe
data Golden =
forall a .
Golden
(forall r . ValueGetter r a)
(forall r . ValueGetter r a)
(a -> a -> IO (Maybe String))
(a -> IO ())
deriving Typeable
newtype ValueGetter r a = ValueGetter
{ runValueGetter :: ContT r IO a }
deriving (Functor, Applicative, Monad, MonadCont, MonadIO)
vgReadFile :: FilePath -> ValueGetter r ByteString
vgReadFile path =
(liftIO . LB.hGetContents =<<) $
ValueGetter $
ContT $ \k ->
bracket
(openBinaryFile path ReadMode)
hClose
k
vgRun :: ValueGetter r r -> IO (Either SomeException r)
vgRun (ValueGetter a) = handleSyncExceptions $ runContT a evaluate
data Result
= Timeout
| Pass
| TestError String
instance Show Result where
show Timeout = "Timed out"
show Pass = "OK"
show (TestError s) = s
data TestCaseRunning = TestCaseRunning
instance Show TestCaseRunning where
show TestCaseRunning = "Running"
instance TestResultlike TestCaseRunning Result where
testSucceeded Pass = True
testSucceeded _ = False
instance Testlike TestCaseRunning Result Golden where
testTypeName _ = "Test Cases"
runTest topts golden = runImprovingIO $ do
let timeout = unK $ topt_timeout topts
mb_result <- maybeTimeoutImprovingIO timeout $
runGolden golden
return $ fromMaybe Timeout mb_result
runGolden :: Golden -> ImprovingIO TestCaseRunning f Result
runGolden g = do
yieldImprovement TestCaseRunning
TF.liftIO $ go g
handleSyncExceptions :: IO a -> IO (Either SomeException a)
handleSyncExceptions a =
catch (Right <$> a) $ \e ->
case fromException e of
Just async -> throwIO (async :: AsyncException)
Nothing -> return $ Left e
go :: Golden -> IO Result
go (Golden getGolden getTested cmp _) = do
result <- vgRun $ do
new <- getTested
ref <- getGolden
liftIO $ cmp ref new
return $
case result of
Left e -> TestError $ show e
Right (Just reason) -> TestError reason
Right Nothing -> Pass