Ticket #1692: MainWithTiming.hs

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 = addTimerCallback tickLength (doTick2 tickLength 0)

test3 tickLength = addTimerCallback tickLength (doTick3 tickLength 0)

putTicks t = do usecs <- getUSecs; putStrLn $ "tick: " ++ show t ++ ", " ++ show usecs

doTick2 :: Timeout -> Int -> IO ()
doTick2 tickLength t = do
    putTicks t
    addTimerCallback tickLength (doTick2 tickLength (t + 1))
    
doTick3 :: Timeout -> Int -> IO ()
doTick3 tickLength t = do
   forkIO (do putTicks t
              addTimerCallback tickLength (doTick3 tickLength (t + 1)))
   yield
            
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