[QuickCheck] [PATCH] Fix a performance issue

[Simon Hengel]

---
 Test/QuickCheck/Test.hs |    3 +--
 Test/QuickCheck/Text.hs |   17 +++++++++++++++++
 2 files changed, 18 insertions(+), 2 deletions(-)

diff --git a/Test/QuickCheck/Test.hs b/Test/QuickCheck/Test.hs
index 04a0fca..2c76d22 100644
--- a/Test/QuickCheck/Test.hs
+++ b/Test/QuickCheck/Test.hs
@@ -100,8 +100,7 @@ quickCheckResult p = quickCheckWithResult stdArgs p
 
 -- | Tests a property, using test arguments, produces a test result, and prints the results to 'stdout'.
 quickCheckWithResult :: Testable prop => Args -> prop -> IO Result
-quickCheckWithResult a p =
-  do tm <- if chatty a then newStdioTerminal else newNullTerminal
+quickCheckWithResult a p = (if chatty a then withStdioTerminal else withNullTerminal) $ \tm -> do
      rnd <- case replay a of
               Nothing      -> newStdGen
               Just (rnd,_) -> return rnd
diff --git a/Test/QuickCheck/Text.hs b/Test/QuickCheck/Text.hs
index 4fa8ad7..e572dbf 100644
--- a/Test/QuickCheck/Text.hs
+++ b/Test/QuickCheck/Text.hs
@@ -11,7 +11,9 @@ module Test.QuickCheck.Text
 
   , newTerminal
   , newStdioTerminal
+  , withStdioTerminal
   , newNullTerminal
+  , withNullTerminal
   , terminalOutput
   , handle
   , Terminal
@@ -24,12 +26,16 @@ module Test.QuickCheck.Text
 --------------------------------------------------------------------------
 -- imports
 
+import Control.Applicative
 import System.IO
   ( hFlush
   , hPutStr
   , stdout
   , stderr
   , Handle
+  , BufferMode (..)
+  , hGetBuffering
+  , hSetBuffering
   )
 
 import Data.IORef
@@ -89,12 +95,23 @@ newTerminal out err =
   do ref <- newIORef (return ())
      return (MkTerminal ref out err)
 
+withStdioTerminal :: (Terminal -> IO a) -> IO a
+withStdioTerminal action = do
+  mode <- hGetBuffering stderr
+  -- By default stdout is unbuffered.  This is very slow, hence we explicitly
+  -- enable line buffering.
+  hSetBuffering stderr LineBuffering
+  (newStdioTerminal >>= action) <* hSetBuffering stderr mode
+
 newStdioTerminal :: IO Terminal
 newStdioTerminal = do
   out <- output (handle stdout)
   err <- output (handle stderr)
   newTerminal out err
 
+withNullTerminal :: (Terminal -> IO a) -> IO a
+withNullTerminal = (newNullTerminal >>=)
+
 newNullTerminal :: IO Terminal
 newNullTerminal = do
   out <- output (const (return ()))
-- 
1.7.9.5