{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Test.Tasty.Golden
(
goldenVsFile
, goldenVsString
, goldenVsFileDiff
, goldenVsStringDiff
, SizeCutoff(..)
, DeleteOutputFile(..)
, writeBinaryFile
, findByExtension
, createDirectoriesAndWriteFile
)
where
import Test.Tasty
import Test.Tasty.Golden.Advanced
import Test.Tasty.Golden.Internal
import Text.Printf
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Encoding as LT
import System.IO
import System.IO.Temp
import qualified System.Process.Typed as PT
import System.Exit
import System.FilePath
import System.Directory
import Control.Exception
import Control.Monad
import qualified Data.Set as Set
import Foreign.C.Error
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid
#endif
goldenVsFile
:: TestName
-> FilePath
-> FilePath
-> IO ()
-> TestTree
goldenVsFile :: TestName -> TestName -> TestName -> IO () -> TestTree
goldenVsFile TestName
name TestName
ref TestName
new IO ()
act =
TestName
-> IO ByteString
-> IO ByteString
-> (ByteString -> ByteString -> IO (Maybe TestName))
-> (ByteString -> IO ())
-> IO ()
-> TestTree
forall a.
TestName
-> IO a
-> IO a
-> (a -> a -> IO (Maybe TestName))
-> (a -> IO ())
-> IO ()
-> TestTree
goldenTest2
TestName
name
(TestName -> IO ByteString
readFileStrict TestName
ref)
(IO ()
act IO () -> IO ByteString -> IO ByteString
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TestName -> IO ByteString
readFileStrict TestName
new)
ByteString -> ByteString -> IO (Maybe TestName)
cmp
ByteString -> IO ()
upd
IO ()
del
where
cmp :: ByteString -> ByteString -> IO (Maybe TestName)
cmp = TestName -> ByteString -> ByteString -> IO (Maybe TestName)
forall a. Eq a => TestName -> a -> a -> IO (Maybe TestName)
simpleCmp (TestName -> ByteString -> ByteString -> IO (Maybe TestName))
-> TestName -> ByteString -> ByteString -> IO (Maybe TestName)
forall a b. (a -> b) -> a -> b
$ TestName -> TestName -> TestName -> TestName
forall r. PrintfType r => TestName -> r
printf TestName
"Files '%s' and '%s' differ" TestName
ref TestName
new
upd :: ByteString -> IO ()
upd = TestName -> ByteString -> IO ()
createDirectoriesAndWriteFile TestName
ref
del :: IO ()
del = TestName -> IO ()
removeFile TestName
new
goldenVsString
:: TestName
-> FilePath
-> IO LBS.ByteString
-> TestTree
goldenVsString :: TestName -> TestName -> IO ByteString -> TestTree
goldenVsString TestName
name TestName
ref IO ByteString
act =
(SizeCutoff -> TestTree) -> TestTree
forall v. IsOption v => (v -> TestTree) -> TestTree
askOption ((SizeCutoff -> TestTree) -> TestTree)
-> (SizeCutoff -> TestTree) -> TestTree
forall a b. (a -> b) -> a -> b
$ \SizeCutoff
sizeCutoff ->
TestName
-> IO ByteString
-> IO ByteString
-> (ByteString -> ByteString -> IO (Maybe TestName))
-> (ByteString -> IO ())
-> TestTree
forall a.
TestName
-> IO a
-> IO a
-> (a -> a -> IO (Maybe TestName))
-> (a -> IO ())
-> TestTree
goldenTest
TestName
name
(TestName -> IO ByteString
readFileStrict TestName
ref)
IO ByteString
act
(SizeCutoff -> ByteString -> ByteString -> IO (Maybe TestName)
cmp SizeCutoff
sizeCutoff)
ByteString -> IO ()
upd
where
cmp :: SizeCutoff -> ByteString -> ByteString -> IO (Maybe TestName)
cmp SizeCutoff
sizeCutoff ByteString
x ByteString
y = TestName -> ByteString -> ByteString -> IO (Maybe TestName)
forall a. Eq a => TestName -> a -> a -> IO (Maybe TestName)
simpleCmp TestName
msg ByteString
x ByteString
y
where
msg :: TestName
msg = TestName -> TestName -> TestName
forall r. PrintfType r => TestName -> r
printf TestName
"Test output was different from '%s'. It was:\n" TestName
ref TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<>
ByteString -> TestName
unpackUtf8 (SizeCutoff -> ByteString -> ByteString
truncateLargeOutput SizeCutoff
sizeCutoff ByteString
y)
upd :: ByteString -> IO ()
upd = TestName -> ByteString -> IO ()
createDirectoriesAndWriteFile TestName
ref
simpleCmp :: Eq a => String -> a -> a -> IO (Maybe String)
simpleCmp :: TestName -> a -> a -> IO (Maybe TestName)
simpleCmp TestName
e a
x a
y =
Maybe TestName -> IO (Maybe TestName)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe TestName -> IO (Maybe TestName))
-> Maybe TestName -> IO (Maybe TestName)
forall a b. (a -> b) -> a -> b
$ if a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y then Maybe TestName
forall a. Maybe a
Nothing else TestName -> Maybe TestName
forall a. a -> Maybe a
Just TestName
e
goldenVsFileDiff
:: TestName
-> (FilePath -> FilePath -> [String])
-> FilePath
-> FilePath
-> IO ()
-> TestTree
goldenVsFileDiff :: TestName
-> (TestName -> TestName -> [TestName])
-> TestName
-> TestName
-> IO ()
-> TestTree
goldenVsFileDiff TestName
name TestName -> TestName -> [TestName]
cmdf TestName
ref TestName
new IO ()
act =
(SizeCutoff -> TestTree) -> TestTree
forall v. IsOption v => (v -> TestTree) -> TestTree
askOption ((SizeCutoff -> TestTree) -> TestTree)
-> (SizeCutoff -> TestTree) -> TestTree
forall a b. (a -> b) -> a -> b
$ \SizeCutoff
sizeCutoff ->
TestName
-> IO ()
-> IO ()
-> (() -> () -> IO (Maybe TestName))
-> (() -> IO ())
-> IO ()
-> TestTree
forall a.
TestName
-> IO a
-> IO a
-> (a -> a -> IO (Maybe TestName))
-> (a -> IO ())
-> IO ()
-> TestTree
goldenTest2
TestName
name
(TestName -> IO ()
throwIfDoesNotExist TestName
ref)
IO ()
act
(\()
_ ()
_ -> [TestName] -> SizeCutoff -> IO (Maybe TestName)
runDiff (TestName -> TestName -> [TestName]
cmdf TestName
ref TestName
new) SizeCutoff
sizeCutoff)
() -> IO ()
forall p. p -> IO ()
upd
IO ()
del
where
upd :: p -> IO ()
upd p
_ = TestName -> IO ByteString
readFileStrict TestName
new IO ByteString -> (ByteString -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TestName -> ByteString -> IO ()
createDirectoriesAndWriteFile TestName
ref
del :: IO ()
del = TestName -> IO ()
removeFile TestName
new
throwIfDoesNotExist :: FilePath -> IO ()
throwIfDoesNotExist :: TestName -> IO ()
throwIfDoesNotExist TestName
ref = do
Bool
exists <- TestName -> IO Bool
doesFileExist TestName
ref
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IOError -> IO ()
forall a. IOError -> IO a
ioError (IOError -> IO ()) -> IOError -> IO ()
forall a b. (a -> b) -> a -> b
$
TestName -> Errno -> Maybe Handle -> Maybe TestName -> IOError
errnoToIOError TestName
"goldenVsFileDiff" Errno
eNOENT Maybe Handle
forall a. Maybe a
Nothing Maybe TestName
forall a. Maybe a
Nothing
goldenVsStringDiff
:: TestName
-> (FilePath -> FilePath -> [String])
-> FilePath
-> IO LBS.ByteString
-> TestTree
goldenVsStringDiff :: TestName
-> (TestName -> TestName -> [TestName])
-> TestName
-> IO ByteString
-> TestTree
goldenVsStringDiff TestName
name TestName -> TestName -> [TestName]
cmdf TestName
ref IO ByteString
act =
(SizeCutoff -> TestTree) -> TestTree
forall v. IsOption v => (v -> TestTree) -> TestTree
askOption ((SizeCutoff -> TestTree) -> TestTree)
-> (SizeCutoff -> TestTree) -> TestTree
forall a b. (a -> b) -> a -> b
$ \SizeCutoff
sizeCutoff ->
TestName
-> IO ByteString
-> IO ByteString
-> (ByteString -> ByteString -> IO (Maybe TestName))
-> (ByteString -> IO ())
-> TestTree
forall a.
TestName
-> IO a
-> IO a
-> (a -> a -> IO (Maybe TestName))
-> (a -> IO ())
-> TestTree
goldenTest
TestName
name
(TestName -> IO ByteString
readFileStrict TestName
ref)
(IO ByteString
act)
(SizeCutoff -> ByteString -> ByteString -> IO (Maybe TestName)
forall p. SizeCutoff -> p -> ByteString -> IO (Maybe TestName)
cmp SizeCutoff
sizeCutoff)
ByteString -> IO ()
upd
where
template :: TestName
template = TestName -> TestName
takeBaseName TestName
ref TestName -> TestName -> TestName
<.> TestName
"actual"
cmp :: SizeCutoff -> p -> ByteString -> IO (Maybe TestName)
cmp SizeCutoff
sizeCutoff p
_ ByteString
actBS = TestName
-> (TestName -> Handle -> IO (Maybe TestName))
-> IO (Maybe TestName)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
TestName -> (TestName -> Handle -> m a) -> m a
withSystemTempFile TestName
template ((TestName -> Handle -> IO (Maybe TestName))
-> IO (Maybe TestName))
-> (TestName -> Handle -> IO (Maybe TestName))
-> IO (Maybe TestName)
forall a b. (a -> b) -> a -> b
$ \TestName
tmpFile Handle
tmpHandle -> do
Handle -> ByteString -> IO ()
LBS.hPut Handle
tmpHandle ByteString
actBS IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
tmpHandle
let cmd :: [TestName]
cmd = TestName -> TestName -> [TestName]
cmdf TestName
ref TestName
tmpFile
Maybe TestName
diff_result :: Maybe String <- [TestName] -> SizeCutoff -> IO (Maybe TestName)
runDiff [TestName]
cmd SizeCutoff
sizeCutoff
Maybe TestName -> IO (Maybe TestName)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe TestName -> IO (Maybe TestName))
-> Maybe TestName -> IO (Maybe TestName)
forall a b. (a -> b) -> a -> b
$ ((TestName -> TestName) -> Maybe TestName -> Maybe TestName)
-> Maybe TestName -> (TestName -> TestName) -> Maybe TestName
forall a b c. (a -> b -> c) -> b -> a -> c
flip (TestName -> TestName) -> Maybe TestName -> Maybe TestName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe TestName
diff_result ((TestName -> TestName) -> Maybe TestName)
-> (TestName -> TestName) -> Maybe TestName
forall a b. (a -> b) -> a -> b
$ \TestName
diff ->
TestName -> TestName -> TestName -> TestName
forall r. PrintfType r => TestName -> r
printf TestName
"Test output was different from '%s'. Output of %s:\n" TestName
ref ([TestName] -> TestName
forall a. Show a => a -> TestName
show [TestName]
cmd) TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> TestName
diff
upd :: ByteString -> IO ()
upd = TestName -> ByteString -> IO ()
createDirectoriesAndWriteFile TestName
ref
truncateLargeOutput
:: SizeCutoff
-> LBS.ByteString
-> LBS.ByteString
truncateLargeOutput :: SizeCutoff -> ByteString -> ByteString
truncateLargeOutput (SizeCutoff Int64
n) ByteString
str =
if ByteString -> Int64
LBS.length ByteString
str Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64
n
then ByteString
str
else
Int64 -> ByteString -> ByteString
LBS.take Int64
n ByteString
str ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"<truncated>" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>
ByteString
"\nUse --accept or increase --size-cutoff to see full output."
writeBinaryFile :: FilePath -> String -> IO ()
writeBinaryFile :: TestName -> TestName -> IO ()
writeBinaryFile TestName
f TestName
txt = TestName -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. TestName -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile TestName
f IOMode
WriteMode (\Handle
hdl -> Handle -> TestName -> IO ()
hPutStr Handle
hdl TestName
txt)
findByExtension
:: [FilePath]
-> FilePath
-> IO [FilePath]
findByExtension :: [TestName] -> TestName -> IO [TestName]
findByExtension [TestName]
extsList = TestName -> IO [TestName]
go where
exts :: Set TestName
exts = [TestName] -> Set TestName
forall a. Ord a => [a] -> Set a
Set.fromList [TestName]
extsList
go :: TestName -> IO [TestName]
go TestName
dir = do
[TestName]
allEntries <- TestName -> IO [TestName]
getDirectoryContents TestName
dir
let entries :: [TestName]
entries = (TestName -> Bool) -> [TestName] -> [TestName]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (TestName -> Bool) -> TestName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TestName -> [TestName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TestName
".", TestName
".."])) [TestName]
allEntries
([[TestName]] -> [TestName]) -> IO [[TestName]] -> IO [TestName]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[TestName]] -> [TestName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO [[TestName]] -> IO [TestName])
-> IO [[TestName]] -> IO [TestName]
forall a b. (a -> b) -> a -> b
$ [TestName] -> (TestName -> IO [TestName]) -> IO [[TestName]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [TestName]
entries ((TestName -> IO [TestName]) -> IO [[TestName]])
-> (TestName -> IO [TestName]) -> IO [[TestName]]
forall a b. (a -> b) -> a -> b
$ \TestName
e -> do
let path :: TestName
path = TestName
dir TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
"/" TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
e
Bool
isDir <- TestName -> IO Bool
doesDirectoryExist TestName
path
if Bool
isDir
then TestName -> IO [TestName]
go TestName
path
else
[TestName] -> IO [TestName]
forall (m :: * -> *) a. Monad m => a -> m a
return ([TestName] -> IO [TestName]) -> [TestName] -> IO [TestName]
forall a b. (a -> b) -> a -> b
$
if TestName -> TestName
takeExtension TestName
path TestName -> Set TestName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set TestName
exts
then [TestName
path]
else []
createDirectoriesAndWriteFile
:: FilePath
-> LBS.ByteString
-> IO ()
createDirectoriesAndWriteFile :: TestName -> ByteString -> IO ()
createDirectoriesAndWriteFile TestName
path ByteString
bs = do
let dir :: TestName
dir = TestName -> TestName
takeDirectory TestName
path
Bool -> TestName -> IO ()
createDirectoryIfMissing
Bool
True
TestName
dir
TestName -> ByteString -> IO ()
LBS.writeFile TestName
path ByteString
bs
forceLbs :: LBS.ByteString -> ()
forceLbs :: ByteString -> ()
forceLbs = (Word8 -> () -> ()) -> () -> ByteString -> ()
forall a. (Word8 -> a -> a) -> a -> ByteString -> a
LBS.foldr Word8 -> () -> ()
seq ()
readFileStrict :: FilePath -> IO LBS.ByteString
readFileStrict :: TestName -> IO ByteString
readFileStrict TestName
path = do
ByteString
s <- TestName -> IO ByteString
LBS.readFile TestName
path
() -> IO ()
forall a. a -> IO a
evaluate (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ()
forceLbs ByteString
s
ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
s
unpackUtf8 :: LBS.ByteString -> String
unpackUtf8 :: ByteString -> TestName
unpackUtf8 = Text -> TestName
LT.unpack (Text -> TestName)
-> (ByteString -> Text) -> ByteString -> TestName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
LT.decodeUtf8
runDiff
:: [String]
-> SizeCutoff
-> IO (Maybe String)
runDiff :: [TestName] -> SizeCutoff -> IO (Maybe TestName)
runDiff [TestName]
cmd SizeCutoff
sizeCutoff =
case [TestName]
cmd of
[] -> ErrorCall -> IO (Maybe TestName)
forall e a. Exception e => e -> IO a
throwIO (ErrorCall -> IO (Maybe TestName))
-> ErrorCall -> IO (Maybe TestName)
forall a b. (a -> b) -> a -> b
$ TestName -> ErrorCall
ErrorCall TestName
"tasty-golden: empty diff command"
TestName
prog : [TestName]
args -> do
let
procConf :: ProcessConfig () () ()
procConf =
StreamSpec 'STInput ()
-> ProcessConfig () () () -> ProcessConfig () () ()
forall stdin stdin0 stdout stderr.
StreamSpec 'STInput stdin
-> ProcessConfig stdin0 stdout stderr
-> ProcessConfig stdin stdout stderr
PT.setStdin StreamSpec 'STInput ()
forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
PT.closed
(ProcessConfig () () () -> ProcessConfig () () ())
-> (ProcessConfig () () () -> ProcessConfig () () ())
-> ProcessConfig () () ()
-> ProcessConfig () () ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamSpec 'STOutput ()
-> ProcessConfig () () () -> ProcessConfig () () ()
forall stderr stdin stdout stderr0.
StreamSpec 'STOutput stderr
-> ProcessConfig stdin stdout stderr0
-> ProcessConfig stdin stdout stderr
PT.setStderr StreamSpec 'STOutput ()
forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
PT.inherit
(ProcessConfig () () () -> ProcessConfig () () ())
-> ProcessConfig () () () -> ProcessConfig () () ()
forall a b. (a -> b) -> a -> b
$ TestName -> [TestName] -> ProcessConfig () () ()
PT.proc TestName
prog [TestName]
args
(ExitCode
exitCode, ByteString
out) <- ProcessConfig () () () -> IO (ExitCode, ByteString)
forall (m :: * -> *) stdin stdoutIgnored stderr.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderr
-> m (ExitCode, ByteString)
PT.readProcessStdout ProcessConfig () () ()
procConf
Maybe TestName -> IO (Maybe TestName)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe TestName -> IO (Maybe TestName))
-> Maybe TestName -> IO (Maybe TestName)
forall a b. (a -> b) -> a -> b
$ case ExitCode
exitCode of
ExitCode
ExitSuccess -> Maybe TestName
forall a. Maybe a
Nothing
ExitCode
_ -> TestName -> Maybe TestName
forall a. a -> Maybe a
Just (TestName -> Maybe TestName)
-> (ByteString -> TestName) -> ByteString -> Maybe TestName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> TestName
unpackUtf8 (ByteString -> TestName)
-> (ByteString -> ByteString) -> ByteString -> TestName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SizeCutoff -> ByteString -> ByteString
truncateLargeOutput SizeCutoff
sizeCutoff (ByteString -> Maybe TestName) -> ByteString -> Maybe TestName
forall a b. (a -> b) -> a -> b
$ ByteString
out