Personal tools

Concurrency demos/Haskell-Javascript concurrency

From HaskellWiki

< Concurrency demos
Revision as of 04:28, 22 November 2007 by DimitryGolubovsky (Talk | contribs)

(diff) ← Older revision | Latest revision (diff) | Newer revision → (diff)
Jump to: navigation, search
-- 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