1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
|
module Test.QuickCheck.Text
( Str(..)
, ranges
, number
, short
, showErr
, bold
, newTerminal
, Terminal
, putTemp
, putPart
, putLine
)
where
--------------------------------------------------------------------------
-- imports
import System.IO
( hFlush
, hPutStr
, stdout
, stderr
)
import Data.IORef
--------------------------------------------------------------------------
-- literal string
newtype Str = MkStr String
instance Show Str where
show (MkStr s) = s
ranges :: Integral a => a -> a -> Str
ranges k n = MkStr (show n' ++ " -- " ++ show (n'+k-1))
where
n' = k * (n `div` k)
--------------------------------------------------------------------------
-- formatting
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 (n-2-i) s ++ ".." ++ drop (k-i) s
| otherwise = s
where
k = length s
i = if n >= 5 then 3 else 0
showErr :: Show a => a -> String
showErr = unwords . words . show
bold :: String -> String
-- not portable:
--bold s = "\ESC[1m" ++ s ++ "\ESC[0m"
bold s = s -- for now
--------------------------------------------------------------------------
-- putting strings
newtype Terminal
= MkTerminal (IORef (IO ()))
newTerminal :: IO Terminal
newTerminal =
do hFlush stdout
hFlush stderr
ref <- newIORef (return ())
return (MkTerminal ref)
flush :: Terminal -> IO ()
flush (MkTerminal ref) =
do io <- readIORef ref
writeIORef ref (return ())
io
postpone :: Terminal -> IO () -> IO ()
postpone (MkTerminal ref) io' =
do io <- readIORef ref
writeIORef ref (io >> io')
putPart, putTemp, putLine :: Terminal -> String -> IO ()
putPart tm s =
do flush tm
putStr s
hFlush stdout
putTemp tm s =
do flush tm
hPutStr h s
hPutStr h [ '\b' | _ <- s ]
hFlush h
postpone tm $
do hPutStr h ( [ ' ' | _ <- s ]
++ [ '\b' | _ <- s ]
)
where
--h = stdout
h = stderr
putLine tm s =
do flush tm
putStrLn s
hFlush stdout
--------------------------------------------------------------------------
-- the end.
|
