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