module Imj.Measure.Stdout
( testStdout
, testStdoutSize -- for its doc
, Settings(..)
-- * Reexports
) where
import Imj.Prelude
import Control.Concurrent
import System.IO
data Settings = LengthTest {
_settingsLengthTestLength :: !Int
}
| OtherTests !Bool
cursorForward, cursorBackward, noop:: String
cursorForward = "\ESC[C"
cursorBackward = "\ESC[D"
noop = cursorForward ++ cursorBackward
-- | Creates a string of given length, whith one visible character,
-- a very big number of no-op escape sequences (cursor forward, cursor backward)
-- and spaces to pad the string to the desired length.
mkSmartStringToExactlyFillBufferOfSize :: Char
-- ^ the char that will be visible
-> Int
-- ^ the length of the string
-> String
mkSmartStringToExactlyFillBufferOfSize char bufferSz =
let noopSz = length noop
bufferSzMinusCharSz = pred bufferSz
countNoops = quot bufferSzMinusCharSz noopSz
remainingSize = bufferSzMinusCharSz - countNoops * noopSz
str = replicate remainingSize ' ' ++ [char] ++ concat (replicate countNoops noop)
in if length str /= bufferSz
then
error $ "test logic : " ++ show (str,bufferSz)
else
str
{- | A function to visually see if the stdout size is smaller or bigger than given numbers.
@
if you see 1, then 2, then 3,
size of stdout buffer < size
if you see 1, then 2 and 3 at the same time,
size of stdout buffer >= size
@
see 'testStdoutSize' doc to understand how to determine the size.
-}
testStdoutSizes :: Int -> IO ()
testStdoutSizes size = do
when (size <= 1) $ error $ "The size (" ++ show size ++ ") should be >= 2."
print "test stdout size :"
print " -if you see 1, then 2, then 3:"
print $ " maximum size of stdout buffer < " ++ show size
print " -if you see 1, then 2 and 3 at the same time:"
print $ " maximum size of stdout buffer >= " ++ show size
-- on my system, 8192 is the stdout max buffer size for
-- BlockBuffering and LineBuffering modes
mapM_ testStdoutSize [size]
putStrLn ""
{- | This function, when run from a process whose stdout is the console,
can be used to visually determine the maximum capacity of stdout.
If stdout capacity >= sz, then in the console we will see
> 1
then
> 1 2 3
Else we see
> 1
then
> 1 2
then
> 1 2 3
There can be "0 to length 'noop'" spaces between chars, they are used
to pad the string sent to the buffer.
-}
testStdoutSize :: Int -> IO ()
testStdoutSize sz = do
withBufferMode $ BlockBuffering $ Just sz
let str = mkSmartStringToExactlyFillBufferOfSize '1' sz
delay = 1000000
putStr str
threadDelay delay
let str' = mkSmartStringToExactlyFillBufferOfSize '2' (pred sz)
putStr str'
threadDelay delay
putChar '3'
hFlush stdout
threadDelay delay
withBufferMode :: BufferMode -> IO ()
withBufferMode b = do
setBufferModeAndVerify b
bufmode <- hShow stdout
putStrLn ""
putStrLn $ "Buffer Mode = " ++ bufmode
putStrLn ""
hFlush stdout
testStdout :: Settings -> IO ()
testStdout (LengthTest candidateLength) = testStdoutSizes candidateLength
testStdout (OtherTests False) = error "missing option (use --help to see the different possibilities)"
testStdout (OtherTests True) = do
let actions = [
-- shows that the 'n' in "BlockBuffering (Just n)" is homogenous to
-- a string length, containing both displayable characters and characters
-- of escape sequences:
-- for "BlockBuffering (Just 4)", each flush renders
-- | cursorforward
-- for "BlockBuffering (Just 5)", flush renders in alternance:
-- | cursorforward |
-- cursorforward | cursorForward
-- It also shows that the \0 for the end of the string is not stored
-- in the buffer (ie the length of the buffer used for cursorforward is 3)
(putChar '|' >> putStr cursorForward, "putChar '|' >> putStr cursorForward")
-- shows the effect of buffering on displayable characters
,(putChar '|', "putChar '|'")
-- shows the effect of explicit flushes
,(putChar '|' >> hFlush stdout, "putChar '|' >> hFlush stdout")
]
mapM_ (uncurry testAction) actions
testAction :: IO () -> String -> IO ()
testAction action desc = do
print $ "-- " ++ desc
let runTests = runActionTests action
modes =
[ -- NoBuffering -- it seems equivalent to "BlockBuffering (Just 1)"
BlockBuffering Nothing
, BlockBuffering (Just 1)
, BlockBuffering (Just 2)
, BlockBuffering (Just 4)
, BlockBuffering (Just 5)
, BlockBuffering (Just 8)
, BlockBuffering (Just 16)
, LineBuffering
]
mapM_ runTests modes
runActionTests :: IO () -> BufferMode -> IO ()
runActionTests action b = do
withBufferMode b
let tenthSecond = 400000
every tenthSecond action 16
every :: Int -> IO () -> Int -> IO ()
every period action remaining
| remaining == 0 = return ()
| otherwise = do
action
threadDelay period
every period action (pred remaining)
setBufferModeAndVerify :: BufferMode -> IO ()
setBufferModeAndVerify b = do
hSetBuffering stdout b
b' <- hGetBuffering stdout
when (b /= b') $ error $ "Failed to set buffering: " ++ show (b,b')
return ()