module Test.QuickCheck.Text
( Str(..)
, ranges
, number
, short
, showErr
, oneLine
, isOneLine
, bold
, newTerminal
, withStdioTerminal
, withNullTerminal
, terminalOutput
, handle
, Terminal
, putTemp
, putPart
, putLine
)
where
import Control.Applicative
import System.IO
( hFlush
, hPutStr
, stdout
, stderr
, Handle
, BufferMode (..)
, hGetBuffering
, hSetBuffering
)
import Data.IORef
import Test.QuickCheck.Exception
newtype Str = MkStr String
instance Show Str where
show (MkStr s) = s
ranges :: (Show a, Integral a) => a -> a -> Str
ranges k n = MkStr (show n' ++ " -- " ++ show (n'+k1))
where
n' = k * (n `div` k)
number :: Int -> String -> String
number n s = show n ++ " " ++ s ++ if n == 1 then "" else "s"
short :: Int -> String -> String
short n s
| n < k = take (n2i) s ++ ".." ++ drop (ki) s
| otherwise = s
where
k = length s
i = if n >= 5 then 3 else 0
showErr :: Show a => a -> String
showErr = unwords . words . show
oneLine :: String -> String
oneLine = unwords . words
isOneLine :: String -> Bool
isOneLine xs = '\n' `notElem` xs
bold :: String -> String
bold s = s
data Terminal
= MkTerminal (IORef String) (IORef Int) (String -> IO ()) (String -> IO ())
newTerminal :: (String -> IO ()) -> (String -> IO ()) -> IO Terminal
newTerminal out err =
do res <- newIORef ""
tmp <- newIORef 0
return (MkTerminal res tmp out err)
withBuffering :: IO a -> IO a
withBuffering action = do
mode <- hGetBuffering stderr
hSetBuffering stderr LineBuffering
action `finally` hSetBuffering stderr mode
withStdioTerminal :: (Terminal -> IO a) -> IO a
withStdioTerminal action =
withBuffering (newTerminal (handle stdout) (handle stderr) >>= action)
withNullTerminal :: (Terminal -> IO a) -> IO a
withNullTerminal action =
newTerminal (const (return ())) (const (return ())) >>= action
terminalOutput :: Terminal -> IO String
terminalOutput (MkTerminal res _ _ _) = readIORef res
handle :: Handle -> String -> IO ()
handle h s = do
hPutStr h s
hFlush h
flush :: Terminal -> IO ()
flush (MkTerminal _ tmp _ err) =
do n <- readIORef tmp
writeIORef tmp 0
err (replicate n ' ' ++ replicate n '\b')
putPart, putTemp, putLine :: Terminal -> String -> IO ()
putPart tm@(MkTerminal res _ out _) s =
do flush tm
force s
out s
modifyIORef res (++ s)
where
force :: [a] -> IO ()
force = evaluate . seqList
seqList :: [a] -> ()
seqList [] = ()
seqList (x:xs) = x `seq` seqList xs
putLine tm s = putPart tm (s ++ "\n")
putTemp tm@(MkTerminal _ tmp _ err) s =
do flush tm
err (s ++ [ '\b' | _ <- s ])
modifyIORef tmp (+ length s)