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