{-# LANGUAGE RankNTypes, ExistentialQuantification, DeriveDataTypeable,
    MultiParamTypeClasses, GeneralizedNewtypeDeriving, CPP #-}
module Test.Tasty.Golden.Internal where

import Control.DeepSeq
import Control.Exception
import Control.Monad (when)
import Data.Typeable (Typeable)
import Data.Proxy
import Data.Int
import Data.Char (toLower)
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

-- | See 'goldenTest' for explanation of the fields
data Golden =
  forall a .
    Golden
      (IO a)
      (IO a)
      (a -> a -> IO (Maybe String))
      (a -> IO ())
      (IO ())
  deriving Typeable

-- | This option, when set to 'True', specifies that we should run in the
-- «accept tests» mode
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 String
"accept"
  optionHelp :: Tagged AcceptTests String
optionHelp = String -> Tagged AcceptTests String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"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)

-- | This option, when set to 'True', specifies to error when a file does
-- not exist, instead of creating a new file.
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 String
"no-create"
  optionHelp :: Tagged NoCreateFile String
optionHelp = String -> Tagged NoCreateFile String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"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)

-- | The size, in bytes, such that the (incorrect) test output is not
-- displayed when it exceeds this size. Numeric underscores are accepted
-- for readability.
--
-- The default value is 1000 (i.e. 1Kb).
--
-- @since 2.3.3
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 = SizeCutoff
1000
  showDefaultValue :: SizeCutoff -> Maybe String
showDefaultValue = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> (SizeCutoff -> String) -> SizeCutoff -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> String
forall a. Show a => a -> String
show (Int64 -> String) -> (SizeCutoff -> Int64) -> SizeCutoff -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SizeCutoff -> Int64
getSizeCutoff
  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
/= Char
'_')
  optionName :: Tagged SizeCutoff String
optionName = String -> Tagged SizeCutoff String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"size-cutoff"
  optionHelp :: Tagged SizeCutoff String
optionHelp = String -> Tagged SizeCutoff String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"hide golden test output if it's larger than n bytes"
  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 String
"n"

-- | When / whether to delete the test output file,
-- when there is a golden file
--
-- @since 2.3.4
data DeleteOutputFile
  = Never  -- ^ Never delete the output file (default)
  | OnPass -- ^ Delete the output file if the test passes
  | Always -- ^ Always delete the output file. (May not be commonly used,
           --   but provided for completeness.)
  deriving (DeleteOutputFile -> DeleteOutputFile -> Bool
(DeleteOutputFile -> DeleteOutputFile -> Bool)
-> (DeleteOutputFile -> DeleteOutputFile -> Bool)
-> Eq DeleteOutputFile
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DeleteOutputFile -> DeleteOutputFile -> Bool
$c/= :: DeleteOutputFile -> DeleteOutputFile -> Bool
== :: DeleteOutputFile -> DeleteOutputFile -> Bool
$c== :: DeleteOutputFile -> DeleteOutputFile -> Bool
Eq, Eq DeleteOutputFile
Eq DeleteOutputFile
-> (DeleteOutputFile -> DeleteOutputFile -> Ordering)
-> (DeleteOutputFile -> DeleteOutputFile -> Bool)
-> (DeleteOutputFile -> DeleteOutputFile -> Bool)
-> (DeleteOutputFile -> DeleteOutputFile -> Bool)
-> (DeleteOutputFile -> DeleteOutputFile -> Bool)
-> (DeleteOutputFile -> DeleteOutputFile -> DeleteOutputFile)
-> (DeleteOutputFile -> DeleteOutputFile -> DeleteOutputFile)
-> Ord DeleteOutputFile
DeleteOutputFile -> DeleteOutputFile -> Bool
DeleteOutputFile -> DeleteOutputFile -> Ordering
DeleteOutputFile -> DeleteOutputFile -> DeleteOutputFile
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 :: DeleteOutputFile -> DeleteOutputFile -> DeleteOutputFile
$cmin :: DeleteOutputFile -> DeleteOutputFile -> DeleteOutputFile
max :: DeleteOutputFile -> DeleteOutputFile -> DeleteOutputFile
$cmax :: DeleteOutputFile -> DeleteOutputFile -> DeleteOutputFile
>= :: DeleteOutputFile -> DeleteOutputFile -> Bool
$c>= :: DeleteOutputFile -> DeleteOutputFile -> Bool
> :: DeleteOutputFile -> DeleteOutputFile -> Bool
$c> :: DeleteOutputFile -> DeleteOutputFile -> Bool
<= :: DeleteOutputFile -> DeleteOutputFile -> Bool
$c<= :: DeleteOutputFile -> DeleteOutputFile -> Bool
< :: DeleteOutputFile -> DeleteOutputFile -> Bool
$c< :: DeleteOutputFile -> DeleteOutputFile -> Bool
compare :: DeleteOutputFile -> DeleteOutputFile -> Ordering
$ccompare :: DeleteOutputFile -> DeleteOutputFile -> Ordering
$cp1Ord :: Eq DeleteOutputFile
Ord, Typeable, Int -> DeleteOutputFile -> String -> String
[DeleteOutputFile] -> String -> String
DeleteOutputFile -> String
(Int -> DeleteOutputFile -> String -> String)
-> (DeleteOutputFile -> String)
-> ([DeleteOutputFile] -> String -> String)
-> Show DeleteOutputFile
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [DeleteOutputFile] -> String -> String
$cshowList :: [DeleteOutputFile] -> String -> String
show :: DeleteOutputFile -> String
$cshow :: DeleteOutputFile -> String
showsPrec :: Int -> DeleteOutputFile -> String -> String
$cshowsPrec :: Int -> DeleteOutputFile -> String -> String
Show)

-- | This option controls when / whether the test output file is deleted
-- For example, it may be convenient to delete the output file when a test
-- passes, since it will be the same as the golden file.
--
-- It does nothing if
--
-- * running the test or accessing an existing golden value threw an exception.
--
-- * there is no golden file for the test
instance IsOption DeleteOutputFile where
  defaultValue :: DeleteOutputFile
defaultValue = DeleteOutputFile
Never
  parseValue :: String -> Maybe DeleteOutputFile
parseValue = String -> Maybe DeleteOutputFile
parseDeleteOutputFile
  optionName :: Tagged DeleteOutputFile String
optionName = String -> Tagged DeleteOutputFile String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"delete-output"
  optionHelp :: Tagged DeleteOutputFile String
optionHelp = String -> Tagged DeleteOutputFile String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"If there is a golden file, when to delete output files"
  showDefaultValue :: DeleteOutputFile -> Maybe String
showDefaultValue =  String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> (DeleteOutputFile -> String) -> DeleteOutputFile -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeleteOutputFile -> String
displayDeleteOutputFile
  optionCLParser :: Parser DeleteOutputFile
optionCLParser = Mod OptionFields DeleteOutputFile -> Parser DeleteOutputFile
forall v. IsOption v => Mod OptionFields v -> Parser v
mkOptionCLParser (Mod OptionFields DeleteOutputFile -> Parser DeleteOutputFile)
-> Mod OptionFields DeleteOutputFile -> Parser DeleteOutputFile
forall a b. (a -> b) -> a -> b
$ String -> Mod OptionFields DeleteOutputFile
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"never|onpass|always"

parseDeleteOutputFile :: String -> Maybe DeleteOutputFile
parseDeleteOutputFile :: String -> Maybe DeleteOutputFile
parseDeleteOutputFile String
s =
  case (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
s of
    String
"never"  -> DeleteOutputFile -> Maybe DeleteOutputFile
forall a. a -> Maybe a
Just DeleteOutputFile
Never
    String
"onpass" -> DeleteOutputFile -> Maybe DeleteOutputFile
forall a. a -> Maybe a
Just DeleteOutputFile
OnPass
    String
"always" -> DeleteOutputFile -> Maybe DeleteOutputFile
forall a. a -> Maybe a
Just DeleteOutputFile
Always
    String
_        -> Maybe DeleteOutputFile
forall a. Maybe a
Nothing

displayDeleteOutputFile :: DeleteOutputFile -> String
displayDeleteOutputFile :: DeleteOutputFile -> String
displayDeleteOutputFile DeleteOutputFile
dof = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (DeleteOutputFile -> String
forall a. Show a => a -> String
show DeleteOutputFile
dof)

instance IsTest Golden where
  run :: OptionSet -> Golden -> (Progress -> IO ()) -> IO Result
run OptionSet
opts Golden
golden Progress -> IO ()
_ = 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)
      , Proxy DeleteOutputFile -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy DeleteOutputFile
forall k (t :: k). Proxy t
Proxy :: Proxy DeleteOutputFile)
      ]

runGolden :: Golden -> OptionSet -> IO Result
runGolden :: Golden -> OptionSet -> IO Result
runGolden (Golden IO a
getGolden IO a
getTested a -> a -> IO (Maybe String)
cmp a -> IO ()
update IO ()
delete) OptionSet
opts = 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 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 a
new -> do

        Either SomeException a
mbRef <- IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
try IO a
getGolden

        case Either SomeException a
mbRef of
          Left SomeException
e
            | Just IOError
e' <- SomeException -> Maybe IOError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e, IOError -> Bool
isDoesNotExistError IOError
e' ->
              if Bool
noCreate
                then
                  -- Don't ever delete the output file in this case, as there is
                  -- no duplicate golden file
                  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
"Golden file does not exist; --no-create flag specified"
                else do
                  a -> IO ()
update a
new
                  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DeleteOutputFile
delOut DeleteOutputFile -> [DeleteOutputFile] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [DeleteOutputFile
Always, DeleteOutputFile
OnPass]) IO ()
delete
                  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 String
"Golden file did not exist; created"

            | Just (AsyncException
_ :: AsyncException) <- SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e -> SomeException -> IO Result
forall e a. Exception e => e -> IO a
throwIO SomeException
e
            | Just (IOError
_ :: IOError) <- SomeException -> Maybe IOError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e -> SomeException -> IO Result
forall e a. Exception e => e -> IO a
throwIO SomeException
e


            | Bool
otherwise -> do
                -- Other types of exceptions may be due to failing to decode the
                -- golden file. In that case, it makes sense to replace a broken
                -- golden file with the current version.
                a -> IO ()
update a
new
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DeleteOutputFile
delOut DeleteOutputFile -> [DeleteOutputFile] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [DeleteOutputFile
Always, DeleteOutputFile
OnPass]) IO ()
delete
                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 (String -> Result) -> String -> Result
forall a b. (a -> b) -> a -> b
$ String
"Accepted the new version. Was failing with exception:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e

          Right a
ref -> do

            Maybe String
result <- a -> a -> IO (Maybe String)
cmp a
ref a
new

            case Maybe String
result of
              Just String
_reason | Bool
accept -> do
                -- test failed; accept the new version
                a -> IO ()
update a
new
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DeleteOutputFile
delOut DeleteOutputFile -> [DeleteOutputFile] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [DeleteOutputFile
Always, DeleteOutputFile
OnPass]) IO ()
delete
                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 String
"Accepted the new version"

              Just String
reason -> do
                -- Make sure that the result is fully evaluated and doesn't depend
                -- on yet un-read lazy input
                () -> 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
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DeleteOutputFile
delOut DeleteOutputFile -> DeleteOutputFile -> Bool
forall a. Eq a => a -> a -> Bool
== DeleteOutputFile
Always) IO ()
delete
                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

              Maybe String
Nothing -> do
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DeleteOutputFile
delOut DeleteOutputFile -> [DeleteOutputFile] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [DeleteOutputFile
Always, DeleteOutputFile
OnPass]) IO ()
delete
                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 String
""
  where
    AcceptTests Bool
accept = OptionSet -> AcceptTests
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
    NoCreateFile Bool
noCreate = OptionSet -> NoCreateFile
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
    delOut :: DeleteOutputFile
delOut = OptionSet -> DeleteOutputFile
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts