monad-par-0.3.4: tests/TestHelpers.hs

{-# LANGUAGE BangPatterns #-}

module TestHelpers where

import Data.List
import Prelude hiding (catch)
import Control.Exception 
import System.IO.Unsafe (unsafePerformIO)
import Data.IORef
import Data.Time.Clock

import Control.Monad.Par.Class

------------------------------------------------------------
-- Helpers

-- _unsafeio :: IO a -> Par a
_unsafeio :: ParFuture iv p => IO a -> p a
_unsafeio io = let x = unsafePerformIO io in
	        x `seq` return x

_waste_time :: Int -> Double
_waste_time n = loop n 1.00111
  where 
    loop 0  !x             = x
    loop !n !x | x > 100.0 = loop (n-1) (x / 2)
    loop !n !x             = loop (n-1) (x + x * 0.5011)

-- This version watches the clock so it uses a constant amount of time
-- regadless of compile/interpret mode an opt lvl.
waste_time :: Double -> IO Double
waste_time seconds = 
    do strt <- getCurrentTime
       let loop !x | x > 100.0 = chk (x / 2)
	   loop !x             = chk (x + x * 0.5011)
	   chk  !x = do t <- getCurrentTime
			if diffUTCTime t strt >= realToFrac seconds
			 then return x
			 else loop x
       loop  1.00111

-- Obviously this takes a lot longer if it's interpreted:
--awhile = 300000000
awhile :: Integer
awhile = 3 * 1000 * 1000
-- awhile = 300000

atomicModifyIORef_ :: IORef a -> (a -> a) -> IO ()
atomicModifyIORef_ rf fn = atomicModifyIORef rf (\x -> (fn x, ()))


-- | Haskell doesn't offer a way to create a Handle for in-memory output.
--   So here we use IORefs instead...
collectOutput :: (IORef [String] -> IO ()) -> IO String
collectOutput fn = 
  do c <- newIORef []
     fn c
     ls <- readIORef c
     return (unlines (reverse ls))

prnt :: IORef [String] -> String -> IO ()
prnt ref str = atomicModifyIORef_ ref (str:)

-- _prnt :: IORef [String] -> String -> Par ()
_prnt :: ParFuture iv p => IORef [String] -> String -> p ()
_prnt ref = _unsafeio . prnt ref
     


-- -----------------------------------------------------------------------------

-- assertException :: (Exception e, Eq e) => e -> IO a -> IO ()
-- assertException ex action =
--     handleJust isWanted (const $ return ()) $ do
--         action
--         assertFailure $ "Expected exception: " ++ show ex
--   where isWanted = guard . (== ex)

-- | Ensure that evaluating an expression returns an exception
--   containing one of the expected messages.
assertException  :: [String] -> a -> IO ()
assertException msgs val = do
 x <- catch (do evaluate val; return Nothing) 
            (\e -> do putStrLn$ "Good.  Caught exception: " ++ show (e :: SomeException)
                      return (Just$ show e))
 case x of 
  Nothing -> error "Failed to get an exception!"
  Just s -> 
   if  any (`isInfixOf` s) msgs
   then return () 
   else error$ "Got the wrong exception, expected to one of the strings: "++ show msgs
	       ++ "\nInstead got this exception:\n  " ++ show s