1{-# LANGUAGE ScopedTypeVariables, FlexibleInstances #-} 2{-# OPTIONS_GHC -fno-warn-orphans #-} -- OK because a test module 3 4module TestUtil 5 (runTests 6 ,testGen, testRaw 7 ,erroneous, erroneousIO 8 ,(====), (==>) 9 ,ASCIIString(..) 10 ,module X 11 ) where 12 13import Test.QuickCheck 14import System.IO.Unsafe 15import Text.Show.Functions() 16 17import Control.Applicative as X 18import Control.Concurrent.Extra as X 19import Control.Exception.Extra as X 20import Control.Monad.Extra as X 21import Data.Char as X 22import Data.Either.Extra as X 23import Data.Function as X 24import Data.IORef.Extra as X 25import Data.List.Extra as X hiding (union, unionBy) 26import Data.List.NonEmpty.Extra as X (NonEmpty(..), (|>), (|:), appendl, appendr, union, unionBy) 27import Data.Maybe as X 28import Data.Monoid as X 29import Data.Tuple.Extra as X 30import Data.Version.Extra as X 31import Numeric.Extra as X 32import System.Directory.Extra as X 33import System.FilePath as X 34import System.Info.Extra as X 35import System.IO.Extra as X 36import System.Process.Extra as X 37import System.Time.Extra as X 38 39 40{-# NOINLINE testCount #-} 41testCount :: IORef Int 42testCount = unsafePerformIO $ newIORef 0 43 44testGen :: Testable prop => String -> prop -> IO () 45testGen msg prop = testRaw msg $ do 46 r <- quickCheckResult prop 47 case r of 48 Success{} -> pure () 49 _ -> errorIO "Test failed" 50 51testRaw :: String -> IO () -> IO () 52testRaw msg test = do 53 putStrLn msg 54 test 55 modifyIORef testCount (+1) 56 57 58erroneous :: Show a => a -> Bool 59erroneous x = unsafePerformIO $ fmap isLeft $ try_ $ evaluate $ length $ show x 60 61erroneousIO :: Show a => IO a -> Bool 62erroneousIO x = unsafePerformIO $ fmap isLeft $ try_ $ evaluate . length . show =<< x 63 64(====) :: (Show a, Eq a) => a -> a -> Bool 65a ==== b 66 | a == b = True 67 | otherwise = error $ "Not equal!\n" ++ show a ++ "\n" ++ show b 68 69runTests :: IO () -> IO () 70runTests t = do 71 -- ensure that capturing output is robust 72 hSetBuffering stdout NoBuffering 73 hSetBuffering stderr NoBuffering 74 writeIORef testCount 0 75 t 76 n <- readIORef testCount 77 putStrLn $ "Success (" ++ show n ++ " tests)" 78 79instance Testable a => Testable (IO a) where 80 property = property . unsafePerformIO 81 82-- We only use this property to assert equality as a property 83-- And the Show instance is useless (since it may be non-deterministic) 84-- So we print out full information on failure 85instance (Show a, Eq a) => Eq (IO a) where 86 a == b = unsafePerformIO $ do 87 a <- try_ $ captureOutput a 88 b <- try_ $ captureOutput b 89 if a == b then pure True else 90 error $ show ("IO values not equal", a, b) 91 92instance Show (IO a) where 93 show _ = "<<IO>>" 94 95instance Arbitrary a => Arbitrary (IO a) where 96 arbitrary = do 97 (prnt :: Maybe Int, thrw :: Maybe Int, res) <- arbitrary 98 pure $ do 99 whenJust prnt print 100 whenJust thrw (fail . show) 101 pure res 102 103instance Eq SomeException where 104 a == b = show a == show b 105