1 files changed, 38 insertions, 0 deletions
diff --git a/testsuite/tests/concurrent/prog002/Thread.hs b/testsuite/tests/concurrent/prog002/Thread.hs
new file mode 100644
index 0000000000..9e342ac977
--- /dev/null
+++ b/testsuite/tests/concurrent/prog002/Thread.hs
@@ -0,0 +1,38 @@
+module Thread 
+( ThreadTree (..)
+, ContM (..)
+, atom
+, stop
+, buildThread
+)
+where
+
+----------------------------------
+data ThreadTree req rsp m = 
+        Atom (m (ThreadTree req rsp m))
+      | Stop
+----------------------------------
+newtype ContM req rsp m a = ContM ((a-> ThreadTree req rsp m)-> ThreadTree req rsp m)
+
+instance Monad m => Monad (ContM req rsp m) where
+   m >>= f = contmBind m f
+   return  = contmReturn
+
+contmBind :: (ContM req rsp m a) -> (a -> (ContM req rsp m b)) -> (ContM req rsp m b)
+contmBind (ContM x) f =  
+    ContM(\y-> x (\z-> let ContM f' = f z in f' y))
+contmReturn :: a -> (ContM req rsp m a)
+contmReturn x = ContM(\c -> c x)
+
+{-- how to build primitive ContM blocks... --}
+
+atom :: Monad m => (m a) -> (ContM req rsp m a)
+atom mx = ContM( \c -> Atom( do x <- mx; return (c x) ))
+
+stop :: (ContM req rsp m a)
+stop = ContM( \c -> Stop )
+
+buildThread :: (ContM req rsp m a) -> ThreadTree req rsp m
+buildThread (ContM f) = f (\c->Stop)
+
+----------------------------------