{-# LANGUAGE CPP #-}
module Test.Hspec.Core.FailureReport (
  FailureReport (..)
, writeFailureReport
, readFailureReport
) where

import           Prelude ()
import           Test.Hspec.Core.Compat

#ifndef __GHCJS__
import           System.SetEnv (setEnv)
import           Test.Hspec.Core.Util (safeTry)
#endif
import           System.IO
import           System.Directory
import           Test.Hspec.Core.Util (Path)
import           Test.Hspec.Core.Config.Options (Config(..))

data FailureReport = FailureReport {
  FailureReport -> Integer
failureReportSeed :: Integer
, FailureReport -> Int
failureReportMaxSuccess :: Int
, FailureReport -> Int
failureReportMaxSize :: Int
, FailureReport -> Int
failureReportMaxDiscardRatio :: Int
, FailureReport -> [Path]
failureReportPaths :: [Path]
} deriving (FailureReport -> FailureReport -> Bool
(FailureReport -> FailureReport -> Bool)
-> (FailureReport -> FailureReport -> Bool) -> Eq FailureReport
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FailureReport -> FailureReport -> Bool
$c/= :: FailureReport -> FailureReport -> Bool
== :: FailureReport -> FailureReport -> Bool
$c== :: FailureReport -> FailureReport -> Bool
Eq, Int -> FailureReport -> ShowS
[FailureReport] -> ShowS
FailureReport -> String
(Int -> FailureReport -> ShowS)
-> (FailureReport -> String)
-> ([FailureReport] -> ShowS)
-> Show FailureReport
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FailureReport] -> ShowS
$cshowList :: [FailureReport] -> ShowS
show :: FailureReport -> String
$cshow :: FailureReport -> String
showsPrec :: Int -> FailureReport -> ShowS
$cshowsPrec :: Int -> FailureReport -> ShowS
Show, ReadPrec [FailureReport]
ReadPrec FailureReport
Int -> ReadS FailureReport
ReadS [FailureReport]
(Int -> ReadS FailureReport)
-> ReadS [FailureReport]
-> ReadPrec FailureReport
-> ReadPrec [FailureReport]
-> Read FailureReport
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [FailureReport]
$creadListPrec :: ReadPrec [FailureReport]
readPrec :: ReadPrec FailureReport
$creadPrec :: ReadPrec FailureReport
readList :: ReadS [FailureReport]
$creadList :: ReadS [FailureReport]
readsPrec :: Int -> ReadS FailureReport
$creadsPrec :: Int -> ReadS FailureReport
Read)

writeFailureReport :: Config -> FailureReport -> IO ()
writeFailureReport :: Config -> FailureReport -> IO ()
writeFailureReport Config
config FailureReport
report = case Config -> Maybe String
configFailureReport Config
config of
  Just String
file -> String -> String -> IO ()
writeFile String
file (FailureReport -> String
forall a. Show a => a -> String
show FailureReport
report)
  Maybe String
Nothing -> do
#ifdef __GHCJS__
    -- ghcjs currently does not support setting environment variables
    -- (https://github.com/ghcjs/ghcjs/issues/263). Since writing a failure report
    -- into the environment is a non-essential feature we just disable this to be
    -- able to run hspec test-suites with ghcjs at all. Should be reverted once
    -- the issue is fixed.
    return ()
#else
    -- on Windows this can throw an exception when the input is too large, hence
    -- we use `safeTry` here
    IO () -> IO (Either SomeException ())
forall a. IO a -> IO (Either SomeException a)
safeTry (String -> String -> IO ()
setEnv String
"HSPEC_FAILURES" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ FailureReport -> String
forall a. Show a => a -> String
show FailureReport
report) IO (Either SomeException ())
-> (Either SomeException () -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SomeException -> IO ())
-> (() -> IO ()) -> Either SomeException () -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> IO ()
forall a. Show a => a -> IO ()
onError () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return
    where
      onError :: a -> IO ()
onError a
err = do
        Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"WARNING: Could not write environment variable HSPEC_FAILURES (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
err String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")")
#endif

readFailureReport :: Config -> IO (Maybe FailureReport)
readFailureReport :: Config -> IO (Maybe FailureReport)
readFailureReport Config
config = case Config -> Maybe String
configFailureReport Config
config of
  Just String
file -> do
    Bool
exists <- String -> IO Bool
doesFileExist String
file
    if Bool
exists
      then do
        String
r <- String -> IO String
readFile String
file
        let report :: Maybe FailureReport
report = String -> Maybe FailureReport
forall a. Read a => String -> Maybe a
readMaybe String
r
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe FailureReport
report Maybe FailureReport -> Maybe FailureReport -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe FailureReport
forall a. Maybe a
Nothing) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"WARNING: Could not read failure report from file " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
file String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"!")
        Maybe FailureReport -> IO (Maybe FailureReport)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FailureReport
report
      else Maybe FailureReport -> IO (Maybe FailureReport)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FailureReport
forall a. Maybe a
Nothing
  Maybe String
Nothing -> do
    Maybe String
mx <- String -> IO (Maybe String)
lookupEnv String
"HSPEC_FAILURES"
    case Maybe String
mx Maybe String
-> (String -> Maybe FailureReport) -> Maybe FailureReport
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe FailureReport
forall a. Read a => String -> Maybe a
readMaybe of
      Maybe FailureReport
Nothing -> do
        Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"WARNING: Could not read environment variable HSPEC_FAILURES; `--rerun' is ignored!"
        Maybe FailureReport -> IO (Maybe FailureReport)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FailureReport
forall a. Maybe a
Nothing
      Maybe FailureReport
report -> Maybe FailureReport -> IO (Maybe FailureReport)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FailureReport
report