import Control.Concurrent
import Control.Monad
import Data.Time
import Text.Printf

type Microsecond = Int
type Scheduler = TimeOfDay -> Microsecond

-- Scheduling
--------------

getTime :: TimeZone -> IO TimeOfDay
getTime tz = do
    t  <- getCurrentTime
    return $ localTimeOfDay $ utcToLocalTime tz t

getGMTTime   = getTime utc
getLocalTime = getCurrentTimeZone >>= getTime

-- Returns the difference between 'y' and the closest higher multiple of 'x'
nextInterval x y
    | x > y = x - y
    | mod y x > 0 = x - mod y x
    | otherwise = 0

-- Given a interval in seconds, this function returns time delta in microseconds.
onInterval :: Int -> Scheduler
onInterval interval time = toNext dMS
  where
    toNext = nextInterval (1000000 * interval)
    tDelta = timeOfDayToTime time
    dMS    = truncate $ 1000000 * tDelta

doWithScheduler :: Scheduler -> (Int -> IO ()) -> IO ThreadId
doWithScheduler sched task = forkIO $ forM_ [0..] exec
  where
    exec n = do
        t <- getLocalTime
        threadDelay $ sched t
        task n

-- Output
---------

watchNames = words "Middle Morning Forenoon Afternoon Dog First"
countWords = words "One Two Three Four Five Six Seven Eight"

-- Executes IO action and then waits for n microseconds
postDelay n fn = fn >> threadDelay n

termBell        = putStr "\a"
termBells n     = replicateM_ n $ postDelay 100000 termBell
termBellSeq seq = forM_ seq $ postDelay 500000 . termBells

toNoteGlyph 1 = "♪"
toNoteGlyph 2 = "♫"
toNoteGlyph _ = ""

ringBells :: Int -> IO ()
ringBells n = do
    t <- getLocalTime
    let numBells    = 1 + (mod n 8)
        watch       = watchNames!!(mod (div n 8) 8)
        count       = countWords!!(numBells - 1)
        (twos,ones) = quotRem numBells 2
        pattern     = (replicate twos 2) ++ (replicate ones 1)
        notes       = unwords $ map toNoteGlyph pattern
        plural       = if numBells > 1 then "s" else ""
        strFMT      = show t ++ ": %s watch, %5s bell%s:  " ++ notes ++ "\n"
    printf strFMT watch count plural
    termBellSeq pattern

-- Usage
---------

bellRinger :: IO ThreadId
bellRinger = doWithScheduler (onInterval (30*60)) ringBells