minesweeper-0.4: Timer.hs

module Timer
    ( Tim
    , newTimer
    , startTimer
    , stopTimer
    , resetTimer
    , isActiveTimer

    , showSeconds
    ) where

import Control.Concurrent
import Control.Concurrent.MVar

import Data.Time.Clock

-------------------------------------------

data StoppedTimerState 
    = Initial | Stopped | Halted
        deriving Eq

data Timer
    = ActiveTimer 
        ThreadId    -- which thread is responsible for the updating of the timer
        UTCTime
    | StoppedTimer 
        StoppedTimerState
        NominalDiffTime

type Action = String -> IO ()

type Tim = MVar 
    ( Action        -- this is global for this module, but Haskell has no parameterized modules..
    , Timer)

-------------------

newTimer :: Action -> IO Tim
newTimer action 
    = newMVar (action, StoppedTimer Initial 0)

startTimer :: Bool -> Tim -> IO ()
startTimer b tim = do
    a@(timeL, xx) <- takeMVar tim
    case xx of
        StoppedTimer x s | b && x == Stopped || not b && x /= Halted -> do
            tid <- forkIO $ modTime tim
            ti <- getCurrentTime
            putMVar tim (timeL, ActiveTimer tid $ addUTCTime (-s) ti)
        _ -> do
            putMVar tim a

stopTimer :: Bool -> Tim -> IO NominalDiffTime
stopTimer b tim = do
    a@(timeL, x) <- takeMVar tim
    case x of
        ActiveTimer _ ti -> do
            ti' <- getCurrentTime
            let d =  diffUTCTime ti' ti
            putMVar tim (timeL, StoppedTimer xx d)
            timeL $ (if b then "Stopped at " else "Halted at ") ++ showSeconds (round d)
            return d
        StoppedTimer _ d -> do
            putMVar tim (timeL, StoppedTimer xx d)
            return d
 where
    xx = if b then Stopped else Halted

resetTimer :: Tim -> IO ()
resetTimer tim = do
    (timeL, _) <- takeMVar tim
    timeL "Timer will start"
    putMVar tim (timeL, StoppedTimer Initial 0)
    return ()

isActiveTimer :: Tim -> IO Bool
isActiveTimer tim = do
    (_, x) <- readMVar tim
    return $ case x of
        ActiveTimer _ _ -> True
        _               -> False


-----------------

modTime ::  Tim -> IO ()
modTime tim = do
    tid <- myThreadId
    (timeL, x) <- readMVar tim
    case x of
        ActiveTimer tid' ti | tid == tid'  -> do
            ti' <- getCurrentTime
            let diff = diffUTCTime ti' ti
            timeL $ "Time: " ++ showSeconds (round diff)
            threadDelay (computeWaitTime diff)
            modTime tim
        _   ->
            return ()

computeWaitTime :: NominalDiffTime -> Int {-milliseconds-}
computeWaitTime x = 1000000 * (1 + round y) - round (1000000 * y) - 100000   where (_, y) = properFraction x :: (Integer, NominalDiffTime)

-------------

showSeconds :: Integer -> String
showSeconds s = f h ++ ":" ++ f m' ++ ":" ++ f s' where

    (m, s') = divMod s 60
    (h, m') = divMod m 60

    f :: Integer -> String
    f i = reverse $ take 2 $ reverse $ "0" ++ show i