module Test.Golden.Advanced
(
goldenTest,
ValueGetter(..),
vgLiftIO,
vgError,
vgReadFile,
Lit(..),
showLit
)
where
import Test.Framework.Providers.API as TF
import Data.Maybe
import Data.ByteString.Lazy as LB
import System.IO
import Control.Exception
import Control.Monad
import Control.Applicative
newtype ValueGetter e a = ValueGetter
{ runValueGetter :: forall r . (Either e a -> IO r) -> IO r }
instance Monad (ValueGetter e) where
return x = ValueGetter $ \k -> k $ Right x
ValueGetter a >>= f = ValueGetter $ \k ->
a $ \x -> case x of Left e -> k $ Left e; Right y -> runValueGetter (f y) k
instance Functor (ValueGetter e) where fmap = liftM
instance Applicative (ValueGetter e) where (<*>) = ap; pure = return
vgLiftIO :: IO a -> ValueGetter e a
vgLiftIO a = ValueGetter $ \k -> a >>= k . Right
vgError :: e -> ValueGetter e a
vgError e = ValueGetter $ \k -> k $ Left e
vgReadFile :: (IOException -> e) -> FilePath -> ValueGetter e ByteString
vgReadFile wrapException path =
(vgLiftIO . LB.hGetContents =<<) $
ValueGetter $ \k ->
bracket
(try $ openBinaryFile path ReadMode)
(either (const $ return ()) hClose)
(k . either (Left . wrapException) Right)
goldenTest
:: Show e
=> TestName
-> ValueGetter e a
-> ValueGetter e a
-> (a -> a -> IO (Maybe e))
-> (a -> IO ())
-> Test
goldenTest t golden test cmp upd = Test t $ Golden golden test cmp upd
data Golden = forall a e . Show e => Golden
(ValueGetter e a) (ValueGetter e a) (a -> a -> IO (Maybe e)) (a -> IO ())
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
go :: Golden -> IO Result
go (Golden getGolden getTested cmp _) =
($ (either (return . TestError . show) (const $ return Pass))) $
runValueGetter $
do
ref <- getGolden
new <- getTested
eq <- vgLiftIO $ cmp ref new
case eq of
Nothing -> return ()
Just e -> vgError e
newtype Lit = Lit String
instance Show Lit where show (Lit s) = s
showLit :: Show a => a -> Lit
showLit = Lit . show