-- 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
 
-- Output a line of text into browser's window.
--  tmf: boolean value instructing to output timestamp when True
--  cls: stylesheet class name
--  txt: text to output
--  doc: reference to the owner document
--  par: parent element where text will be output
 
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 function. References to the document and document body will be passed
-- to every thread for simplicity. All output goes into the document's body.
-- In our example all computations have type Cont Bool x. This makes sense
-- because Javascript event handlers are expected to return a boolean value.
 
main = (`runCont` id) $ do
  doc <- getHTMLDocument
  body <- documentBody doc
  putLine False "title" "Simple Concurrency Test with Control.Monad.Cont" doc body
 
-- Fork three pseudo-threads.
 
  forkCont $ step0 doc body
  forkCont $ step1 doc body
  forkCont $ step3 doc body
  return True
 
-- Home-grown continiation delimiter function. Passes remainder of the 
-- whole computation to a given function and forces the whole computation
-- to complete by returning a final value. Something similar to returning 
-- a final value in plain CPS instead of invoking the continuation.
--  f: function which the remainder of the program will be passed to.
--     Remainder will not be evaluated.
--  r: final value of the whole computation that the latter will be 
--     terminated with.
 
delimit f r = Cont $ \c -> runCont (return 0) $ \a -> f (runCont (return a) c) r
 
-- A primitive to fork out a thread. See the Yhc/Javascript Programmers Guide
-- for the implementation of forkAfter; briefly, it saves the continuation
-- in a global Javascript object, and calls window.setTimeout to execute
-- the saved continuation after the timeout expires. Thus effects like
-- forking parallel thread and cooperative concurrency may be achieved.
-- As follows from the function source below, it yields execution to whatever
-- given as `x' (which must return a final value of the same type as 
-- the "parent" thread), while the remained of the parent will be started
-- after a minimal timeout. The "child" thread is expected to be courteous
-- to its parent and yield execution shortly.
 
forkCont x = delimit (forkAfter 0) (runCont x id)
 
-- A primitive to yield execution for a given interval (in milliseconds).
-- It just sets the timeout desired (0 is OK, but it of course will be longer)
-- and terminates the whole computation with final value of True.
 
yield n = delimit (forkAfter n) True
 
-- Thread 0. It also features callCC to make sure it is compatible with
-- our home-grown delimiter. Within callCC's nested computation, actual
-- timeout is measured as pair timestamps before and after yield. Output
-- continues then, and finally the timeput value is passed back to callCC.
-- As output shows, line 0-3 is printed after the thread is resumed, so
-- the delimiter works from any depth.
 
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
 
-- Two other threads are nothing spectacular, only they have different
-- timeout lengths, so thread 3 will wake up first.
 
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