module Test.Tasty.Silver.Internal where
import Control.Applicative
import Control.Monad.Cont
import Control.Exception
import Data.Typeable (Typeable)
import Data.ByteString.Lazy as LB
import System.IO
import System.IO.Error
import Test.Tasty.Providers
import qualified Data.Text as T
import Data.Maybe
data Golden =
forall a .
Golden
(forall r . ValueGetter r (Maybe a))
(forall r . ValueGetter r a)
(a -> a -> IO GDiff)
(a -> IO GShow)
(a -> IO ())
deriving Typeable
newtype ValueGetter r a = ValueGetter
{ runValueGetter :: ContT r IO a }
deriving (Functor, Applicative, Monad, MonadCont, MonadIO)
vgReadFile :: FilePath -> ValueGetter r ByteString
vgReadFile path = fromJust <$> vgReadFile1 predFalse path
where predFalse :: IOException -> Bool
predFalse _ = False
vgReadFileMaybe :: FilePath -> ValueGetter r (Maybe ByteString)
vgReadFileMaybe = vgReadFile1 (isDoesNotExistErrorType . ioeGetErrorType)
vgReadFile1 :: Exception e
=> (e -> Bool)
-> FilePath
-> ValueGetter r (Maybe ByteString)
vgReadFile1 doCatch path = do
r <- ValueGetter $
ContT $ \k ->
catchJust (\e -> if doCatch e then Just () else Nothing)
(bracket
(openBinaryFile path ReadMode)
hClose
(\h -> LB.hGetContents h >>= (k . Just))
)
(const $ k Nothing)
return $! r
vgRun :: ValueGetter r r -> IO r
vgRun (ValueGetter a) = runContT a evaluate
data GDiff
= Equal
| DiffText { gActual :: T.Text, gExpected :: T.Text }
| ShowDiffed { gDiff :: T.Text }
data GShow
= ShowText T.Text
instance IsTest Golden where
run _ golden _ = runGolden golden
testOptions = return []
runGolden :: Golden -> IO Result
runGolden (Golden getGolden getActual cmp _ _) = do
vgRun $ do
new <- getActual
ref' <- getGolden
case ref' of
Nothing -> return $ testFailed "Missing golden value."
Just ref -> do
cmp' <- liftIO $ cmp ref new
case cmp' of
Equal -> return $ testPassed ""
_ -> return $ testFailed "Result did not match expected output. Use interactive mode to see the full output."