{-# LANGUAGE RankNTypes, ExistentialQuantification, DeriveDataTypeable,
MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}
module Test.Tasty.Golden.Internal where
import Control.DeepSeq
import Control.Exception
import Data.Typeable (Typeable)
import Options.Applicative
import Data.Monoid
import Data.Tagged
import Data.Proxy
import System.IO.Error (isDoesNotExistError)
import Test.Tasty.Providers
import Test.Tasty.Options
data Golden =
forall a .
Golden
(IO a)
(IO a)
(a -> a -> IO (Maybe String))
(a -> IO ())
deriving Typeable
newtype AcceptTests = AcceptTests Bool
deriving (Eq, Ord, Typeable)
instance IsOption AcceptTests where
defaultValue = AcceptTests False
parseValue = fmap AcceptTests . safeReadBool
optionName = return "accept"
optionHelp = return "Accept current results of golden tests"
optionCLParser = flagCLParser Nothing (AcceptTests True)
newtype NoCreateFile = NoCreateFile Bool
deriving (Eq, Ord, Typeable)
instance IsOption NoCreateFile where
defaultValue = NoCreateFile False
parseValue = fmap NoCreateFile . safeReadBool
optionName = return "no-create"
optionHelp = return "Error when golden file does not exist"
optionCLParser = flagCLParser Nothing (NoCreateFile True)
instance IsTest Golden where
run opts golden _ = runGolden golden opts
testOptions =
return
[ Option (Proxy :: Proxy AcceptTests)
, Option (Proxy :: Proxy NoCreateFile)
]
runGolden :: Golden -> OptionSet -> IO Result
runGolden (Golden getGolden getTested cmp update) opts = do
do
mbNew <- try getTested
case mbNew of
Left e -> do
return $ testFailed $ show (e :: SomeException)
Right new -> do
mbRef <- try getGolden
case mbRef of
Left e | isDoesNotExistError e ->
if noCreate
then return $ testFailed "Golden file does not exist; --no-create flag specified"
else do
update new
return $ testPassed "Golden file did not exist; created"
| otherwise -> throwIO e
Right ref -> do
result <- cmp ref new
case result of
Just _reason | accept -> do
update new
return $ testPassed "Accepted the new version"
Just reason -> do
evaluate . rnf $ reason
return $ testFailed reason
Nothing ->
return $ testPassed ""
where
AcceptTests accept = lookupOption opts
NoCreateFile noCreate = lookupOption opts