module Test.Framework.Providers.Golden
( golden )
where
import Test.Framework.Providers.API
import Text.Printf
import Data.Maybe
import Data.ByteString.Lazy as LB
import System.IO
import Control.Exception
data Golden = Golden
{ goldenRef, goldenNew :: FilePath
, goldenAction :: IO ()
}
golden
:: TestName
-> FilePath
-> FilePath
-> IO ()
-> Test
golden name ref new act = Test name $ Golden ref new act
data Result
= Timeout
| Pass
| Differ FilePath FilePath
| NoNew IOException
| NoGolden IOException
instance Show Result where
show Timeout = "Timed out"
show Pass = "OK"
show (Differ ref new) = printf "Files '%s' and '%s' differ" new ref
show (NoNew ex) =
printf "Could not read test output: %s" $ show ex
show (NoGolden ex) =
printf "Could not read golden file: %s" $ show ex
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 (Golden ref new act) = do
yieldImprovement TestCaseRunning
liftIO $ do
act
compareFiles ref new
compareFiles :: FilePath -> FilePath -> IO Result
compareFiles ref new =
withFile NoGolden ref $ \h1 ->
withFile NoNew new $ \h2 ->
do
[cts1, cts2] <- mapM LB.hGetContents [h1, h2]
evaluate $ if cts1 == cts2 then Pass else Differ ref new
where
withFile
:: (IOException -> Result)
-> FilePath
-> (Handle -> IO Result)
-> IO Result
withFile wrapException path act =
bracket
(try $ openBinaryFile path ReadMode)
(either (const $ return ()) hClose)
(either (return . wrapException) act)