Ticket #1692: Main.4.hs

{-
Run with
dist/dist/tcb-bug <test> <timeout>
-}
module Main where

import Foreign
import Foreign.C
import Control.Concurrent
import Graphics.UI.GLUT

main :: IO ()
main = do
    (_,[testNo:_,tl]) <- getArgsAndInitialize
 
    initialWindowPosition $= Position 0 0
    initialWindowSize $= Size 400 400
    mainWindow <- createWindow "TCB - Bug Test"
    
    displayCallback $= return ()
      
    let tickLength = read tl

    case testNo of
      '1' -> test1 tickLength
      '2' -> test2 tickLength
      '3' -> test3 tickLength
            
    mainLoop
 
test1 tickLength = do
    addTimerCallback (tickLength * 1) (putTicks 0)
    addTimerCallback (tickLength * 2) (putTicks 1)
    addTimerCallback (tickLength * 3) (putTicks 2)
    addTimerCallback (tickLength * 4) (putTicks 3)
    addTimerCallback (tickLength * 5) (putTicks 4)
    
test2 tickLength = do
    addTimerCallback tickLength (doTick2 tickLength 0 0)
    addTimerCallback tickLength (doTick2 tickLength 0 1)
    addTimerCallback tickLength (doTick2 tickLength 0 2)
    addTimerCallback tickLength (doTick2 tickLength 0 3)
    addTimerCallback tickLength (doTick2 tickLength 0 4)
    addTimerCallback tickLength (doTick2 tickLength 0 5)
    addTimerCallback tickLength (doTick2 tickLength 0 6)
    addTimerCallback tickLength (doTick2 tickLength 0 7)
    addTimerCallback tickLength (doTick2 tickLength 0 8)
    addTimerCallback tickLength (doTick2 tickLength 0 9)

test3 tickLength = addTimerCallback tickLength (doTick3 tickLength 0)

putTicks t = do 
    usecs <- getUSecs
    let t' = show t
    let t'' = (replicate (2 - (length t')) ' ') ++ t'
    putStrLn $ "tick: " ++ t'' ++ ", " ++ show usecs

putTicks2 t l = do 
    usecs <- getUSecs
    let t' = show t
    let t'' = (replicate (2 - (length t')) ' ') ++ t'
    putStrLn $ "tick: " ++ t'' ++ ", line: " ++ (show l) ++ ", " ++ show usecs


doTick2 :: Timeout -> Int -> Int-> IO ()
doTick2 tickLength t l = do
    putTicks2 t l
    if t < 4 
        then
            addTimerCallback tickLength (doTick2 tickLength (t + 1) l)
        else
            return ()
    
doTick3 :: Timeout -> Int -> IO ()
doTick3 tickLength t = do
        if t < 5 
            then
                do
                   forkIO f
                   yield
            else
                return ()
    where
        f = do putTicks t
               addTimerCallback tickLength (doTick3 tickLength (t + 1))
            
getUSecs :: IO Integer
getUSecs = allocaArray 2 $ \buf -> do
   result <- gettimeofday buf nullPtr
   if (result == 0)
      then do tv_sec  <- peekElemOff buf 0
              tv_usec <- peekElemOff buf 1
              return $ fromIntegral tv_sec * 1000000 + fromIntegral tv_usec
      else error "gettimeofday failed"

-- slight hack, CLong is not really portable
foreign import ccall unsafe "sys/time.h gettimeofday" gettimeofday :: Ptr CLong -> Ptr () -> IO CInt