Concurrency demos/Haskell-Javascript concurrency: Difference between revisions

From HaskellWiki
(Code comments portion 1)
m (Link to example HTML/JS page dead)
 
(10 intermediate revisions by one other user not shown)
Line 1: Line 1:
__TOC__
==Introduction==
This piece of code is intended for compilation to Javascript via [[Yhc/Javascript|Yhc Javascript Backend]] and loading into a web browser.
This piece of code is intended for compilation to Javascript via [[Yhc/Javascript|Yhc Javascript Backend]] and loading into a web browser.


The program is written in monadic style, but it is based on the [[Continuation|Continuation Monad]].
The program is written based on the [[Continuation|plain CPS notation]].


When started, the <hask>main</hask> function forks out three pseudo-threads, and exits. Each thread outputs some lines of text and terminates. Each line printed contains absolute timestamp obtined via Javascript function <code>newDate.getTime()</code>. Explicit delays are used to yield control to other threads.
When started, the <hask>main</hask> function forks out three pseudo-threads, and exits. Each thread outputs some lines of text and terminates. Each line printed contains absolute timestamp obtined via Javascript function <code>newDate.getTime()</code>. Explicit delays are used to yield control to other threads. This test also demonstrates the use of message boxes that may be used for Javascript threads to interact with each other.


==Program==
<haskell>
<haskell>
-- Test of Control.Monad.Cont in Javascript
-- Test of plain CPS based concurrency in Javascript


module ContTest where
module ContTest where


import CPS
import UnsafeJS
import UnsafeJS
import Control.Monad
import Data.JSRef
import Control.Monad.Cont
import Control.Concurrent.JSThreads
import CDOM.Level2.DomUtils
import CDOM.Level2.DomUtils
import DOM.Level2.Dom
import DOM.Level2.Dom
Line 20: Line 25:
import Debug.Profiling
import Debug.Profiling


-- Output a line of text into browser's window.
putLineTm = putLine0 True
--  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 = putLine0 False


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


-- Main function. References to the cdocument and document body will be passed
main = getHTMLDocument $ \doc ->
-- to every thread for simplicity. All output goes into the document's body.
      documentBody doc $ \body ->
-- In our example all computations have type Cont Bool x. This makes sense
      putLine "title" "Simple Concurrency Test with Plain CPS" doc body $ \_ ->
-- because Javascript event handlers are expected to return a boolean value.
      forkThread (step1 doc body) $
      forkThread (step3 doc body) $
      msgBox $ \mb ->
      forkThread (thr1 doc body mb) $
      forkThread (thr2 doc body mb) $
      True
 
 
step1 doc body =
  putLineTm "" "Line 1-5" doc body |>>|
  putLineTm "" "Line 1-6" doc body |>>|
  getTimeStamp $ \t1 ->
  yieldMs 1000 $
  getTimeDiff t1 $ \tmm ->
  putLineTm "" ("Actual timeout was " ++ show tmm ++ "ms") doc body |>>|
  putLineTm "" "Line 1-7" doc body |>>|
  putLineTm "" "Line 1-8" doc body |>>|
  True
 
step3 doc body =
  putLineTm "" "Line 3-9" doc body |>>|
  putLineTm "" "Line 3-A" doc body |>>|
  yieldMs 500 $
  putLineTm "" "Line 3-B" doc body |>>|
  putLineTm "" "Line 3-C" doc body |>>|
  True
 
 


main = (`runCont` id) $ do
showresp r doc body = case r of
  doc <- getHTMLDocument
    Nothing -> putLine "" "Failed" doc body
  body <- documentBody doc
    Just m -> putLine "" ("Success") doc body
  putLine False "title" "Simple Concurrency Test with Control.Monad.Cont" doc body


-- Fork three pseudo-threads.
showmsg t m doc body =
  case m of
    Nothing -> putLine "" (t ++ " " ++ "No message") doc body
    Just m' -> putLine "" (t ++ " " ++ "Message: " ++ show m') doc body


   forkCont $ step0 doc body
thr1 doc body mb =
   forkCont $ step1 doc body
  putLine "" "Thread 1 started" doc body |>>|
   forkCont $ step3 doc body
  putLine "" "Thread 1 waiting" doc body |>>|
   return True
   recvMsg mb $ \m ->
  showmsg "T1:" m doc body |>>|
  putLine "" "Thread 1 resumed" doc body |>>|
  putLine "" "Thread 1 sending" doc body |>>|
   sendMsg mb "123" $ \x ->
  showresp x doc body |>>|
   putLine "" "Thread 1 finishing" doc body |>>|
   True


-- Home-grown continiation delimiter function. Passes remainder of the
thr2 doc body mb =
-- whole computation to a given function and forces the whole computation
  putLine "" "Thread 2 started" doc body |>>|
-- to complete by returning a final value. Something similar to returning
  putLine "" "Thread 2 sending" doc body |>>|
-- a final value in plain CPS instead of invoking the continuation.
  sendMsg mb "abc" $ \x ->
--  f: function which the remainder of the program will be passed to.
  showresp x doc body |>>|
--    Remainder will not be evaluated.
  putLine "" "Thread 2 has sent message" doc body |>>|
--  r: final value of the whole computation that the latter will be
  putLine "" "Thread 2 waiting" doc body |>>|
--    terminated with.
  recvMsg mb $ \m ->
  showmsg "T2:" m doc body |>>|
  putLine "" "Thread 2 finishing" doc body |>>|
  True
</haskell>


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


-- A primitive to fork out a thread. See the Yhc/Javascript Programmers Guide
The figure below shows contents of the web browser window after running the test program above. Actual timeout value is of course different in each run of the program.
-- 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 functin 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)


yield n = delimit (forkAfter n) True
<center>
[[Image:ContTest.jpg]]


step0 doc body = do
<small>'''Fig. 1:''' Web browser window showing output of the test program</small>
  putLineTm "" "Line 0-1" doc body
</center>
  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
==Try it out==
  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
The compiled HTML page of this demo program is accessible at:
  putLineTm "" "Line 3-9" doc body
 
  putLineTm "" "Line 3-A" doc body
http://darcs.haskell.org/yhc/web/jsdemos/ContTest.html
  yield 500
 
  putLineTm "" "Line 3-B" doc body
[[Category:Pages with broken file links]]
  putLineTm "" "Line 3-C" doc body
  return True
</haskell>

Latest revision as of 04:59, 26 April 2021

Introduction

This piece of code is intended for compilation to Javascript via Yhc Javascript Backend and loading into a web browser.

The program is written based on the plain CPS notation.

When started, the main function forks out three pseudo-threads, and exits. Each thread outputs some lines of text and terminates. Each line printed contains absolute timestamp obtined via Javascript function newDate.getTime(). Explicit delays are used to yield control to other threads. This test also demonstrates the use of message boxes that may be used for Javascript threads to interact with each other.

Program

-- Test of plain CPS based concurrency in Javascript

module ContTest where

import CPS
import UnsafeJS
import Data.JSRef
import Control.Concurrent.JSThreads
import CDOM.Level2.DomUtils
import DOM.Level2.Dom
import DOM.Level2.Html2
import DOM.Level2.HTMLElement
import DOM.Level2.HTMLDivElement
import Debug.Profiling

putLineTm = putLine0 True

putLine = putLine0 False

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

main = getHTMLDocument $ \doc ->
       documentBody doc $ \body ->
       putLine "title" "Simple Concurrency Test with Plain CPS" doc body $ \_ ->
       forkThread (step1 doc body) $
       forkThread (step3 doc body) $
       msgBox $ \mb ->
       forkThread (thr1 doc body mb) $
       forkThread (thr2 doc body mb) $
       True


step1 doc body =
  putLineTm "" "Line 1-5" doc body |>>|
  putLineTm "" "Line 1-6" doc body |>>|
  getTimeStamp $ \t1 ->
  yieldMs 1000 $
  getTimeDiff t1 $ \tmm ->
  putLineTm "" ("Actual timeout was " ++ show tmm ++ "ms") doc body |>>|
  putLineTm "" "Line 1-7" doc body |>>|
  putLineTm "" "Line 1-8" doc body |>>|
  True

step3 doc body =
  putLineTm "" "Line 3-9" doc body |>>|
  putLineTm "" "Line 3-A" doc body |>>|
  yieldMs 500 $
  putLineTm "" "Line 3-B" doc body |>>|
  putLineTm "" "Line 3-C" doc body |>>|
  True



showresp r doc body =  case r of
    Nothing -> putLine "" "Failed" doc body
    Just m -> putLine "" ("Success") doc body

showmsg t m doc body =
  case m of
    Nothing -> putLine "" (t ++ " " ++ "No message") doc body
    Just m' -> putLine "" (t ++ " " ++ "Message: " ++ show m') doc body

thr1 doc body mb =
  putLine "" "Thread 1 started" doc body |>>|
  putLine "" "Thread 1 waiting" doc body |>>|
  recvMsg mb $ \m ->
  showmsg "T1:" m doc body |>>|
  putLine "" "Thread 1 resumed" doc body |>>|
  putLine "" "Thread 1 sending" doc body |>>|
  sendMsg mb "123" $ \x ->
  showresp x doc body |>>|
  putLine "" "Thread 1 finishing" doc body |>>|
  True

thr2 doc body mb =
  putLine "" "Thread 2 started" doc body |>>|
  putLine "" "Thread 2 sending" doc body |>>|
  sendMsg mb "abc" $ \x ->
  showresp x doc body |>>|
  putLine "" "Thread 2 has sent message" doc body |>>|
  putLine "" "Thread 2 waiting" doc body |>>|
  recvMsg mb $ \m ->
  showmsg "T2:" m doc body |>>|
  putLine "" "Thread 2 finishing" doc body |>>|
  True

Output

The figure below shows contents of the web browser window after running the test program above. Actual timeout value is of course different in each run of the program.


Fig. 1: Web browser window showing output of the test program

Try it out

The compiled HTML page of this demo program is accessible at:

http://darcs.haskell.org/yhc/web/jsdemos/ContTest.html

Retrieved from "https://wiki.haskell.org/index.php?title=Concurrency_demos/Haskell-Javascript_concurrency&oldid=64378"