Concurrency demos/Haskell-Javascript concurrency

-- Test of Control.Monad.Cont in Javascript

module ContTest where

import UnsafeJS
import Control.Monad
import Control.Monad.Cont
import CDOM.Level2.DomUtils
import DOM.Level2.Dom
import DOM.Level2.Html2
import DOM.Level2.HTMLElement
import DOM.Level2.HTMLDivElement
import Debug.Profiling

putLineTm = putLine True

putLine tmf cls txt doc par = do
  tm <- getTimeStamp 0
  t <- mkText doc $ (if tmf then (show tm ++ ": ") else "") ++ txt
  d <- mkDiv doc >>= set'className cls
  addChild t d
  addChild d par

main = (`runCont` id) $ do
  doc <- getHTMLDocument
  body <- documentBody doc
  putLine False "title" "Simple Concurrency Test with Control.Monad.Cont" doc body
  forkCont $ step0 doc body
  forkCont $ step1 doc body
  forkCont $ step3 doc body
  return True

delimit f r = Cont $ \c -> runCont (return 0) $ \a -> f (runCont (return a) c) r

forkCont x = delimit (forkAfter 0) (runCont x id)

yield n = delimit (forkAfter n) True

step0 doc body = do
  putLineTm "" "Line 0-1" doc body
  tmm <- callCC $ \tdiff -> do
    putLineTm "" "Line 0-2" doc body
    t1 <- getTimeStamp 0
    yield 1000
    t2 <- getTimeStamp t1
    putLineTm "" "Line 0-3" doc body
    tdiff t2
  putLineTm "" "Line 0-4" doc body
  putLineTm "" ("Actual timeout was " ++ show tmm ++ "ms") doc body
  return True

step1 doc body = do
  putLineTm "" "Line 1-5" doc body
  putLineTm "" "Line 1-6" doc body
  yield 1000
  putLineTm "" "Line 1-7" doc body
  putLineTm "" "Line 1-8" doc body
  return True

step3 doc body = do
  putLineTm "" "Line 3-9" doc body
  putLineTm "" "Line 3-A" doc body
  yield 500
  putLineTm "" "Line 3-B" doc body
  putLineTm "" "Line 3-C" doc body
  return True