module Test.Tasty.Golden.Internal where
import Control.Applicative
import Control.Monad.Cont
import Control.DeepSeq
import Control.Exception
import Data.Typeable (Typeable)
import Data.ByteString.Lazy as LB
import System.IO
import Test.Tasty.Providers
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 r
vgRun (ValueGetter a) = runContT a evaluate
instance IsTest Golden where
run _ golden _ = runGolden golden
testOptions = return []
runGolden :: Golden -> IO Result
runGolden (Golden getGolden getTested cmp _) = do
vgRun $ do
new <- getTested
ref <- getGolden
result <- liftIO $ cmp ref new
case result of
Just reason -> do
liftIO $ evaluate . rnf $ reason
return $ testFailed reason
Nothing ->
return $ testPassed ""