module Main where


------------------------------------------------------------------------------
-- Basic concurrency monad
------------------------------------------------------------------------------

-- A Thread represents a process. It is really just a stream of primitive
-- "atomic" operations. Thus it is easy to interleave Threads, thus achieving
-- a form of concurrency. Note that a Thread represents the entire rest of a
-- computation. This is unlike a monad where each computation has a result
-- and computations can be sequenced.

data Thread = Print Char Thread
            | Fork Thread Thread
            | End
            deriving Show


type Output = [Char]
type ThreadQueue = [Thread]
type State = (Output, ThreadQueue)


-- Let us introduce a monad representing "interleavable computations".
-- At this stage, it is amounts to little more than a convenient way
-- to construct Threads by sequential composition.
--
-- How can we arrange so that threads can be composed sequentially?
-- The only way is really to parameterize thread fragments (really
-- thread prefixes) on the rest of the thread. This leads directly
-- to *continuations*.

newtype CM a = CM ((a -> Thread) -> Thread)


fromCM :: CM a -> ((a -> Thread) -> Thread)
fromCM (CM x) = x


thread :: CM a -> Thread
thread m = fromCM m (const End)


instance Monad CM where
    return x = CM (\k -> k x)
    m >>= f  = CM (\k -> fromCM m (\x -> fromCM (f x) k))


cPrint :: Char -> CM ()
cPrint c = CM (\k -> Print c (k ()))

cFork :: CM a -> CM ()
cFork m = CM (\k -> Fork (thread m) (k ()))


cEnd :: CM a
cEnd = CM (\_ -> End)


{-
runCM :: CM a -> Output
runCM m = runHlp ("", []) (thread m)
    where
	runHlp s t =
	    case dispatch s t of
		Left (s', t) -> runHlp s' t
		Right o      -> o


-- Dispatch on the operation of the currently running thread.
-- Then call the scheduler.

dispatch :: State -> Thread -> Either (State, Thread) Output
dispatch (o, rq) (Print c t)  = schedule (o ++ [c], rq ++ [t])
dispatch (o, rq) (Fork t1 t2) = schedule (o, rq ++ [t1, t2])
dispatch (o, rq) End          = schedule (o, rq)


-- Selects next thread to run, if any.

schedule :: State -> Either (State, Thread) Output
schedule (o, [])   = Right o
schedule (o, t:ts) = Left ((o, ts), t)
-}

runCM :: CM a -> Output
runCM m = dispatch [] (thread m)


-- Dispatch on the operation of the currently running thread.
-- Then call the scheduler.

dispatch :: ThreadQueue -> Thread -> Output
dispatch rq (Print c t)  = c : schedule (rq ++ [t])
dispatch rq (Fork t1 t2) = schedule (rq ++ [t1, t2])
dispatch rq End          = schedule rq


-- Selects next thread to run, if any.

schedule :: ThreadQueue -> Output
schedule []     = []
schedule (t:ts) = dispatch ts t


-- Couldn't we do without the Thread type?
--
-- Yes and no. It serves to give a handle on each step. Otherwise, when
-- applying a continuation, one would get the end result directly. We need a
-- VALUE which represents the rest of the computation. But of course, this
-- value could ba a continuation function: just fuse the monadic operations
-- with "dispatch" and "schedule".


------------------------------------------------------------------------------
-- Tests
------------------------------------------------------------------------------

p1 :: CM ()
p1 =
    do
	cPrint 'a'
	cPrint 'b'
	cPrint 'c'
	cPrint 'd'
	cPrint 'e'
	cPrint 'f'
	cPrint 'g'
	cPrint 'h'
	cPrint 'i'
	cPrint 'j'

{-
p2 :: CM ()
p2 =
    do
	cPrint '1'
	cPrint '2'
	cPrint '3'
	cPrint '4'
	cPrint '5'
	cPrint '6'
	cPrint '7'
	cPrint '8'
	cPrint '9'
	cPrint '0'
-}

p2 :: CM ()
p2 =
    do
	cPrint '1'
        undefined
	cPrint '2'
	cPrint '3'
	cPrint '4'
	cPrint '5'
	cPrint '6'
	cPrint '7'
	cPrint '8'
	cPrint '9'
	cPrint '0'
        undefined

p3 :: CM ()
p3 =
    do
	cFork p1
	cPrint 'A'
	cFork p2
	cPrint 'B'

main = print (runCM p3)