operational-0.2.0.0: docs/web/examples/PoorMansConcurrency.hs.html
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html>
<head>
<!-- Generated by HsColour, http://www.cs.york.ac.uk/fp/darcs/hscolour/ -->
<title>examples/PoorMansConcurrency.hs</title>
<link type='text/css' rel='stylesheet' href='hscolour.css' />
</head>
<body>
<pre><span class='hs-comment'>{------------------------------------------------------------------------------
Control.Monad.Operational
Example:
Koen Claessen's Poor Man's Concurrency Monad
<a href="http://www.cs.chalmers.se/~koen/pubs/entry-jfp99-monad.html">http://www.cs.chalmers.se/~koen/pubs/entry-jfp99-monad.html</a>
------------------------------------------------------------------------------}</span>
<span class='hs-comment'>{-# LANGUAGE GADTs, Rank2Types #-}</span>
<span class='hs-keyword'>module</span> <span class='hs-conid'>PoorMansConcurrency</span> <span class='hs-keyword'>where</span>
<span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Monad</span>
<span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Monad</span><span class='hs-varop'>.</span><span class='hs-conid'>Operational</span>
<span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Monad</span><span class='hs-varop'>.</span><span class='hs-conid'>Trans</span> <span class='hs-varid'>hiding</span> <span class='hs-layout'>(</span><span class='hs-varid'>lift</span><span class='hs-layout'>)</span>
<span class='hs-comment'>{------------------------------------------------------------------------------
A concurrency monad runs several processes in parallel
and supports two operations
fork -- fork a new process
stop -- halt the current one
We want this to be a monad transformer, so we also need a function lift
This time, however, we cannot use the monad transformer version ProgramT
because this will leave no room for interleaving different computations
of the base monad.
------------------------------------------------------------------------------}</span>
<span class='hs-keyword'>data</span> <span class='hs-conid'>ProcessI</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span> <span class='hs-keyword'>where</span>
<span class='hs-conid'>Lift</span> <span class='hs-keyglyph'>::</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ProcessI</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span>
<span class='hs-conid'>Stop</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ProcessI</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span>
<span class='hs-conid'>Fork</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Process</span> <span class='hs-varid'>m</span> <span class='hs-conid'>()</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ProcessI</span> <span class='hs-varid'>m</span> <span class='hs-conid'>()</span>
<span class='hs-keyword'>type</span> <span class='hs-conid'>Process</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Program</span> <span class='hs-layout'>(</span><span class='hs-conid'>ProcessI</span> <span class='hs-varid'>m</span><span class='hs-layout'>)</span> <span class='hs-varid'>a</span>
<span class='hs-definition'>stop</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>singleton</span> <span class='hs-conid'>Stop</span>
<span class='hs-definition'>fork</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>singleton</span> <span class='hs-varop'>.</span> <span class='hs-conid'>Fork</span>
<span class='hs-definition'>lift</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>singleton</span> <span class='hs-varop'>.</span> <span class='hs-conid'>Lift</span>
<span class='hs-comment'>-- interpreter</span>
<span class='hs-definition'>runProcess</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Monad</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>Process</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>m</span> <span class='hs-conid'>()</span>
<span class='hs-definition'>runProcess</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>schedule</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>m</span><span class='hs-keyglyph'>]</span>
<span class='hs-keyword'>where</span>
<span class='hs-varid'>schedule</span> <span class='hs-layout'>(</span><span class='hs-varid'>x</span><span class='hs-conop'>:</span><span class='hs-varid'>xs</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>run</span> <span class='hs-layout'>(</span><span class='hs-varid'>view</span> <span class='hs-varid'>x</span><span class='hs-layout'>)</span> <span class='hs-varid'>xs</span>
<span class='hs-varid'>run</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Monad</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>ProgramView</span> <span class='hs-layout'>(</span><span class='hs-conid'>ProcessI</span> <span class='hs-varid'>m</span><span class='hs-layout'>)</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Process</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>m</span> <span class='hs-conid'>()</span>
<span class='hs-varid'>run</span> <span class='hs-layout'>(</span><span class='hs-conid'>Return</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-varid'>xs</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>return</span> <span class='hs-conid'>()</span> <span class='hs-comment'>-- process finished</span>
<span class='hs-varid'>run</span> <span class='hs-layout'>(</span><span class='hs-conid'>Lift</span> <span class='hs-varid'>m</span> <span class='hs-conop'>:>>=</span> <span class='hs-varid'>k</span><span class='hs-layout'>)</span> <span class='hs-varid'>xs</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>m</span> <span class='hs-varop'>>>=</span> <span class='hs-keyglyph'>\</span><span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-comment'>-- switch process</span>
<span class='hs-varid'>schedule</span> <span class='hs-layout'>(</span><span class='hs-varid'>xs</span> <span class='hs-varop'>++</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>k</span> <span class='hs-varid'>a</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
<span class='hs-varid'>run</span> <span class='hs-layout'>(</span><span class='hs-conid'>Stop</span> <span class='hs-conop'>:>>=</span> <span class='hs-varid'>k</span><span class='hs-layout'>)</span> <span class='hs-varid'>xs</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>schedule</span> <span class='hs-varid'>xs</span> <span class='hs-comment'>-- process halts</span>
<span class='hs-varid'>run</span> <span class='hs-layout'>(</span><span class='hs-conid'>Fork</span> <span class='hs-varid'>p</span> <span class='hs-conop'>:>>=</span> <span class='hs-varid'>k</span><span class='hs-layout'>)</span> <span class='hs-varid'>xs</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>schedule</span> <span class='hs-layout'>(</span><span class='hs-varid'>xs</span> <span class='hs-varop'>++</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>x2</span><span class='hs-layout'>,</span><span class='hs-varid'>x1</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- fork new process</span>
<span class='hs-keyword'>where</span> <span class='hs-varid'>x1</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>k</span> <span class='hs-conid'>()</span><span class='hs-layout'>;</span> <span class='hs-varid'>x2</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>p</span> <span class='hs-varop'>>>=</span> <span class='hs-varid'>k</span>
<span class='hs-comment'>-- example</span>
<span class='hs-comment'>-- > runProcess example -- warning: runs indefinitely</span>
<span class='hs-definition'>example</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Process</span> <span class='hs-conid'>IO</span> <span class='hs-conid'>()</span>
<span class='hs-definition'>example</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<span class='hs-varid'>write</span> <span class='hs-str'>"Start!"</span>
<span class='hs-varid'>fork</span> <span class='hs-layout'>(</span><span class='hs-varid'>loop</span> <span class='hs-str'>"fish"</span><span class='hs-layout'>)</span>
<span class='hs-varid'>loop</span> <span class='hs-str'>"cat"</span>
<span class='hs-definition'>write</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>lift</span> <span class='hs-varop'>.</span> <span class='hs-varid'>putStr</span>
<span class='hs-definition'>loop</span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>write</span> <span class='hs-varid'>s</span> <span class='hs-varop'>>></span> <span class='hs-varid'>loop</span> <span class='hs-varid'>s</span>
</pre></body>
</html>