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 . safeRead
optionName = return "accept"
optionHelp = return "Accept current results of golden tests"
optionCLParser =
fmap AcceptTests $
switch
( long (untag (optionName :: Tagged AcceptTests String))
<> help (untag (optionHelp :: Tagged AcceptTests String))
)
instance IsTest Golden where
run opts golden _ = runGolden golden (lookupOption opts)
testOptions = return [Option (Proxy :: Proxy AcceptTests)]
runGolden :: Golden -> AcceptTests -> IO Result
runGolden (Golden getGolden getTested cmp update) (AcceptTests accept) = 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 -> 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 ""