{-# LANGUAGE RankNTypes, ExistentialQuantification, DeriveDataTypeable,
MultiParamTypeClasses, GeneralizedNewtypeDeriving, CPP #-}
module Test.Tasty.Golden.Internal where
import Control.DeepSeq
import Control.Exception
import Data.Typeable (Typeable)
import Data.Proxy
import Data.Int
import System.IO.Error (isDoesNotExistError)
import Options.Applicative (metavar)
import Test.Tasty.Providers
import Test.Tasty.Options
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid ((<>))
#endif
data Golden =
forall a .
Golden
(IO a)
(IO a)
(a -> a -> IO (Maybe String))
(a -> IO ())
deriving Typeable
newtype AcceptTests = AcceptTests Bool
deriving (AcceptTests -> AcceptTests -> Bool
(AcceptTests -> AcceptTests -> Bool)
-> (AcceptTests -> AcceptTests -> Bool) -> Eq AcceptTests
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AcceptTests -> AcceptTests -> Bool
$c/= :: AcceptTests -> AcceptTests -> Bool
== :: AcceptTests -> AcceptTests -> Bool
$c== :: AcceptTests -> AcceptTests -> Bool
Eq, Eq AcceptTests
Eq AcceptTests =>
(AcceptTests -> AcceptTests -> Ordering)
-> (AcceptTests -> AcceptTests -> Bool)
-> (AcceptTests -> AcceptTests -> Bool)
-> (AcceptTests -> AcceptTests -> Bool)
-> (AcceptTests -> AcceptTests -> Bool)
-> (AcceptTests -> AcceptTests -> AcceptTests)
-> (AcceptTests -> AcceptTests -> AcceptTests)
-> Ord AcceptTests
AcceptTests -> AcceptTests -> Bool
AcceptTests -> AcceptTests -> Ordering
AcceptTests -> AcceptTests -> AcceptTests
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: AcceptTests -> AcceptTests -> AcceptTests
$cmin :: AcceptTests -> AcceptTests -> AcceptTests
max :: AcceptTests -> AcceptTests -> AcceptTests
$cmax :: AcceptTests -> AcceptTests -> AcceptTests
>= :: AcceptTests -> AcceptTests -> Bool
$c>= :: AcceptTests -> AcceptTests -> Bool
> :: AcceptTests -> AcceptTests -> Bool
$c> :: AcceptTests -> AcceptTests -> Bool
<= :: AcceptTests -> AcceptTests -> Bool
$c<= :: AcceptTests -> AcceptTests -> Bool
< :: AcceptTests -> AcceptTests -> Bool
$c< :: AcceptTests -> AcceptTests -> Bool
compare :: AcceptTests -> AcceptTests -> Ordering
$ccompare :: AcceptTests -> AcceptTests -> Ordering
$cp1Ord :: Eq AcceptTests
Ord, Typeable)
instance IsOption AcceptTests where
defaultValue :: AcceptTests
defaultValue = Bool -> AcceptTests
AcceptTests Bool
False
parseValue :: String -> Maybe AcceptTests
parseValue = (Bool -> AcceptTests) -> Maybe Bool -> Maybe AcceptTests
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> AcceptTests
AcceptTests (Maybe Bool -> Maybe AcceptTests)
-> (String -> Maybe Bool) -> String -> Maybe AcceptTests
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Bool
safeReadBool
optionName :: Tagged AcceptTests String
optionName = String -> Tagged AcceptTests String
forall (m :: * -> *) a. Monad m => a -> m a
return "accept"
optionHelp :: Tagged AcceptTests String
optionHelp = String -> Tagged AcceptTests String
forall (m :: * -> *) a. Monad m => a -> m a
return "Accept current results of golden tests"
optionCLParser :: Parser AcceptTests
optionCLParser = Maybe Char -> AcceptTests -> Parser AcceptTests
forall v. IsOption v => Maybe Char -> v -> Parser v
flagCLParser Maybe Char
forall a. Maybe a
Nothing (Bool -> AcceptTests
AcceptTests Bool
True)
newtype NoCreateFile = NoCreateFile Bool
deriving (NoCreateFile -> NoCreateFile -> Bool
(NoCreateFile -> NoCreateFile -> Bool)
-> (NoCreateFile -> NoCreateFile -> Bool) -> Eq NoCreateFile
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NoCreateFile -> NoCreateFile -> Bool
$c/= :: NoCreateFile -> NoCreateFile -> Bool
== :: NoCreateFile -> NoCreateFile -> Bool
$c== :: NoCreateFile -> NoCreateFile -> Bool
Eq, Eq NoCreateFile
Eq NoCreateFile =>
(NoCreateFile -> NoCreateFile -> Ordering)
-> (NoCreateFile -> NoCreateFile -> Bool)
-> (NoCreateFile -> NoCreateFile -> Bool)
-> (NoCreateFile -> NoCreateFile -> Bool)
-> (NoCreateFile -> NoCreateFile -> Bool)
-> (NoCreateFile -> NoCreateFile -> NoCreateFile)
-> (NoCreateFile -> NoCreateFile -> NoCreateFile)
-> Ord NoCreateFile
NoCreateFile -> NoCreateFile -> Bool
NoCreateFile -> NoCreateFile -> Ordering
NoCreateFile -> NoCreateFile -> NoCreateFile
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: NoCreateFile -> NoCreateFile -> NoCreateFile
$cmin :: NoCreateFile -> NoCreateFile -> NoCreateFile
max :: NoCreateFile -> NoCreateFile -> NoCreateFile
$cmax :: NoCreateFile -> NoCreateFile -> NoCreateFile
>= :: NoCreateFile -> NoCreateFile -> Bool
$c>= :: NoCreateFile -> NoCreateFile -> Bool
> :: NoCreateFile -> NoCreateFile -> Bool
$c> :: NoCreateFile -> NoCreateFile -> Bool
<= :: NoCreateFile -> NoCreateFile -> Bool
$c<= :: NoCreateFile -> NoCreateFile -> Bool
< :: NoCreateFile -> NoCreateFile -> Bool
$c< :: NoCreateFile -> NoCreateFile -> Bool
compare :: NoCreateFile -> NoCreateFile -> Ordering
$ccompare :: NoCreateFile -> NoCreateFile -> Ordering
$cp1Ord :: Eq NoCreateFile
Ord, Typeable)
instance IsOption NoCreateFile where
defaultValue :: NoCreateFile
defaultValue = Bool -> NoCreateFile
NoCreateFile Bool
False
parseValue :: String -> Maybe NoCreateFile
parseValue = (Bool -> NoCreateFile) -> Maybe Bool -> Maybe NoCreateFile
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> NoCreateFile
NoCreateFile (Maybe Bool -> Maybe NoCreateFile)
-> (String -> Maybe Bool) -> String -> Maybe NoCreateFile
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Bool
safeReadBool
optionName :: Tagged NoCreateFile String
optionName = String -> Tagged NoCreateFile String
forall (m :: * -> *) a. Monad m => a -> m a
return "no-create"
optionHelp :: Tagged NoCreateFile String
optionHelp = String -> Tagged NoCreateFile String
forall (m :: * -> *) a. Monad m => a -> m a
return "Error when golden file does not exist"
optionCLParser :: Parser NoCreateFile
optionCLParser = Maybe Char -> NoCreateFile -> Parser NoCreateFile
forall v. IsOption v => Maybe Char -> v -> Parser v
flagCLParser Maybe Char
forall a. Maybe a
Nothing (Bool -> NoCreateFile
NoCreateFile Bool
True)
newtype SizeCutoff = SizeCutoff { SizeCutoff -> Int64
getSizeCutoff :: Int64 }
deriving (SizeCutoff -> SizeCutoff -> Bool
(SizeCutoff -> SizeCutoff -> Bool)
-> (SizeCutoff -> SizeCutoff -> Bool) -> Eq SizeCutoff
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SizeCutoff -> SizeCutoff -> Bool
$c/= :: SizeCutoff -> SizeCutoff -> Bool
== :: SizeCutoff -> SizeCutoff -> Bool
$c== :: SizeCutoff -> SizeCutoff -> Bool
Eq, Eq SizeCutoff
Eq SizeCutoff =>
(SizeCutoff -> SizeCutoff -> Ordering)
-> (SizeCutoff -> SizeCutoff -> Bool)
-> (SizeCutoff -> SizeCutoff -> Bool)
-> (SizeCutoff -> SizeCutoff -> Bool)
-> (SizeCutoff -> SizeCutoff -> Bool)
-> (SizeCutoff -> SizeCutoff -> SizeCutoff)
-> (SizeCutoff -> SizeCutoff -> SizeCutoff)
-> Ord SizeCutoff
SizeCutoff -> SizeCutoff -> Bool
SizeCutoff -> SizeCutoff -> Ordering
SizeCutoff -> SizeCutoff -> SizeCutoff
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SizeCutoff -> SizeCutoff -> SizeCutoff
$cmin :: SizeCutoff -> SizeCutoff -> SizeCutoff
max :: SizeCutoff -> SizeCutoff -> SizeCutoff
$cmax :: SizeCutoff -> SizeCutoff -> SizeCutoff
>= :: SizeCutoff -> SizeCutoff -> Bool
$c>= :: SizeCutoff -> SizeCutoff -> Bool
> :: SizeCutoff -> SizeCutoff -> Bool
$c> :: SizeCutoff -> SizeCutoff -> Bool
<= :: SizeCutoff -> SizeCutoff -> Bool
$c<= :: SizeCutoff -> SizeCutoff -> Bool
< :: SizeCutoff -> SizeCutoff -> Bool
$c< :: SizeCutoff -> SizeCutoff -> Bool
compare :: SizeCutoff -> SizeCutoff -> Ordering
$ccompare :: SizeCutoff -> SizeCutoff -> Ordering
$cp1Ord :: Eq SizeCutoff
Ord, Typeable, Integer -> SizeCutoff
SizeCutoff -> SizeCutoff
SizeCutoff -> SizeCutoff -> SizeCutoff
(SizeCutoff -> SizeCutoff -> SizeCutoff)
-> (SizeCutoff -> SizeCutoff -> SizeCutoff)
-> (SizeCutoff -> SizeCutoff -> SizeCutoff)
-> (SizeCutoff -> SizeCutoff)
-> (SizeCutoff -> SizeCutoff)
-> (SizeCutoff -> SizeCutoff)
-> (Integer -> SizeCutoff)
-> Num SizeCutoff
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> SizeCutoff
$cfromInteger :: Integer -> SizeCutoff
signum :: SizeCutoff -> SizeCutoff
$csignum :: SizeCutoff -> SizeCutoff
abs :: SizeCutoff -> SizeCutoff
$cabs :: SizeCutoff -> SizeCutoff
negate :: SizeCutoff -> SizeCutoff
$cnegate :: SizeCutoff -> SizeCutoff
* :: SizeCutoff -> SizeCutoff -> SizeCutoff
$c* :: SizeCutoff -> SizeCutoff -> SizeCutoff
- :: SizeCutoff -> SizeCutoff -> SizeCutoff
$c- :: SizeCutoff -> SizeCutoff -> SizeCutoff
+ :: SizeCutoff -> SizeCutoff -> SizeCutoff
$c+ :: SizeCutoff -> SizeCutoff -> SizeCutoff
Num, Num SizeCutoff
Ord SizeCutoff
(Num SizeCutoff, Ord SizeCutoff) =>
(SizeCutoff -> Rational) -> Real SizeCutoff
SizeCutoff -> Rational
forall a. (Num a, Ord a) => (a -> Rational) -> Real a
toRational :: SizeCutoff -> Rational
$ctoRational :: SizeCutoff -> Rational
$cp2Real :: Ord SizeCutoff
$cp1Real :: Num SizeCutoff
Real, Int -> SizeCutoff
SizeCutoff -> Int
SizeCutoff -> [SizeCutoff]
SizeCutoff -> SizeCutoff
SizeCutoff -> SizeCutoff -> [SizeCutoff]
SizeCutoff -> SizeCutoff -> SizeCutoff -> [SizeCutoff]
(SizeCutoff -> SizeCutoff)
-> (SizeCutoff -> SizeCutoff)
-> (Int -> SizeCutoff)
-> (SizeCutoff -> Int)
-> (SizeCutoff -> [SizeCutoff])
-> (SizeCutoff -> SizeCutoff -> [SizeCutoff])
-> (SizeCutoff -> SizeCutoff -> [SizeCutoff])
-> (SizeCutoff -> SizeCutoff -> SizeCutoff -> [SizeCutoff])
-> Enum SizeCutoff
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: SizeCutoff -> SizeCutoff -> SizeCutoff -> [SizeCutoff]
$cenumFromThenTo :: SizeCutoff -> SizeCutoff -> SizeCutoff -> [SizeCutoff]
enumFromTo :: SizeCutoff -> SizeCutoff -> [SizeCutoff]
$cenumFromTo :: SizeCutoff -> SizeCutoff -> [SizeCutoff]
enumFromThen :: SizeCutoff -> SizeCutoff -> [SizeCutoff]
$cenumFromThen :: SizeCutoff -> SizeCutoff -> [SizeCutoff]
enumFrom :: SizeCutoff -> [SizeCutoff]
$cenumFrom :: SizeCutoff -> [SizeCutoff]
fromEnum :: SizeCutoff -> Int
$cfromEnum :: SizeCutoff -> Int
toEnum :: Int -> SizeCutoff
$ctoEnum :: Int -> SizeCutoff
pred :: SizeCutoff -> SizeCutoff
$cpred :: SizeCutoff -> SizeCutoff
succ :: SizeCutoff -> SizeCutoff
$csucc :: SizeCutoff -> SizeCutoff
Enum, Enum SizeCutoff
Real SizeCutoff
(Real SizeCutoff, Enum SizeCutoff) =>
(SizeCutoff -> SizeCutoff -> SizeCutoff)
-> (SizeCutoff -> SizeCutoff -> SizeCutoff)
-> (SizeCutoff -> SizeCutoff -> SizeCutoff)
-> (SizeCutoff -> SizeCutoff -> SizeCutoff)
-> (SizeCutoff -> SizeCutoff -> (SizeCutoff, SizeCutoff))
-> (SizeCutoff -> SizeCutoff -> (SizeCutoff, SizeCutoff))
-> (SizeCutoff -> Integer)
-> Integral SizeCutoff
SizeCutoff -> Integer
SizeCutoff -> SizeCutoff -> (SizeCutoff, SizeCutoff)
SizeCutoff -> SizeCutoff -> SizeCutoff
forall a.
(Real a, Enum a) =>
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> (a, a))
-> (a -> a -> (a, a))
-> (a -> Integer)
-> Integral a
toInteger :: SizeCutoff -> Integer
$ctoInteger :: SizeCutoff -> Integer
divMod :: SizeCutoff -> SizeCutoff -> (SizeCutoff, SizeCutoff)
$cdivMod :: SizeCutoff -> SizeCutoff -> (SizeCutoff, SizeCutoff)
quotRem :: SizeCutoff -> SizeCutoff -> (SizeCutoff, SizeCutoff)
$cquotRem :: SizeCutoff -> SizeCutoff -> (SizeCutoff, SizeCutoff)
mod :: SizeCutoff -> SizeCutoff -> SizeCutoff
$cmod :: SizeCutoff -> SizeCutoff -> SizeCutoff
div :: SizeCutoff -> SizeCutoff -> SizeCutoff
$cdiv :: SizeCutoff -> SizeCutoff -> SizeCutoff
rem :: SizeCutoff -> SizeCutoff -> SizeCutoff
$crem :: SizeCutoff -> SizeCutoff -> SizeCutoff
quot :: SizeCutoff -> SizeCutoff -> SizeCutoff
$cquot :: SizeCutoff -> SizeCutoff -> SizeCutoff
$cp2Integral :: Enum SizeCutoff
$cp1Integral :: Real SizeCutoff
Integral)
instance IsOption SizeCutoff where
defaultValue :: SizeCutoff
defaultValue = 1000
parseValue :: String -> Maybe SizeCutoff
parseValue = (Int64 -> SizeCutoff) -> Maybe Int64 -> Maybe SizeCutoff
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int64 -> SizeCutoff
SizeCutoff (Maybe Int64 -> Maybe SizeCutoff)
-> (String -> Maybe Int64) -> String -> Maybe SizeCutoff
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Int64
forall a. Read a => String -> Maybe a
safeRead (String -> Maybe Int64)
-> (String -> String) -> String -> Maybe Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '_')
optionName :: Tagged SizeCutoff String
optionName = String -> Tagged SizeCutoff String
forall (m :: * -> *) a. Monad m => a -> m a
return "size-cutoff"
optionHelp :: Tagged SizeCutoff String
optionHelp = String -> Tagged SizeCutoff String
forall (m :: * -> *) a. Monad m => a -> m a
return "hide golden test output if it's larger than n bytes (default: 1000)"
optionCLParser :: Parser SizeCutoff
optionCLParser = Mod OptionFields SizeCutoff -> Parser SizeCutoff
forall v. IsOption v => Mod OptionFields v -> Parser v
mkOptionCLParser (Mod OptionFields SizeCutoff -> Parser SizeCutoff)
-> Mod OptionFields SizeCutoff -> Parser SizeCutoff
forall a b. (a -> b) -> a -> b
$ String -> Mod OptionFields SizeCutoff
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar "n"
instance IsTest Golden where
run :: OptionSet -> Golden -> (Progress -> IO ()) -> IO Result
run opts :: OptionSet
opts golden :: Golden
golden _ = Golden -> OptionSet -> IO Result
runGolden Golden
golden OptionSet
opts
testOptions :: Tagged Golden [OptionDescription]
testOptions =
[OptionDescription] -> Tagged Golden [OptionDescription]
forall (m :: * -> *) a. Monad m => a -> m a
return
[ Proxy AcceptTests -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy AcceptTests
forall k (t :: k). Proxy t
Proxy :: Proxy AcceptTests)
, Proxy NoCreateFile -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy NoCreateFile
forall k (t :: k). Proxy t
Proxy :: Proxy NoCreateFile)
, Proxy SizeCutoff -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy SizeCutoff
forall k (t :: k). Proxy t
Proxy :: Proxy SizeCutoff)
]
runGolden :: Golden -> OptionSet -> IO Result
runGolden :: Golden -> OptionSet -> IO Result
runGolden (Golden getGolden :: IO a
getGolden getTested :: IO a
getTested cmp :: a -> a -> IO (Maybe String)
cmp update :: a -> IO ()
update) opts :: OptionSet
opts = do
do
Either SomeException a
mbNew <- IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
try IO a
getTested
case Either SomeException a
mbNew of
Left e :: SomeException
e -> do
Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ String -> Result
testFailed (String -> Result) -> String -> Result
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show (SomeException
e :: SomeException)
Right new :: a
new -> do
Either IOError a
mbRef <- IO a -> IO (Either IOError a)
forall e a. Exception e => IO a -> IO (Either e a)
try IO a
getGolden
case Either IOError a
mbRef of
Left e :: IOError
e | IOError -> Bool
isDoesNotExistError IOError
e ->
if Bool
noCreate
then Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ String -> Result
testFailed "Golden file does not exist; --no-create flag specified"
else do
a -> IO ()
update a
new
Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ String -> Result
testPassed "Golden file did not exist; created"
| Bool
otherwise -> IOError -> IO Result
forall e a. Exception e => e -> IO a
throwIO IOError
e
Right ref :: a
ref -> do
Maybe String
result <- a -> a -> IO (Maybe String)
cmp a
ref a
new
case Maybe String
result of
Just _reason :: String
_reason | Bool
accept -> do
a -> IO ()
update a
new
Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ String -> Result
testPassed "Accepted the new version"
Just reason :: String
reason -> do
() -> IO ()
forall a. a -> IO a
evaluate (() -> IO ()) -> (String -> ()) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ()
forall a. NFData a => a -> ()
rnf (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
reason
Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ String -> Result
testFailed String
reason
Nothing ->
Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ String -> Result
testPassed ""
where
AcceptTests accept :: Bool
accept = OptionSet -> AcceptTests
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
NoCreateFile noCreate :: Bool
noCreate = OptionSet -> NoCreateFile
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts