world as value

[Fergus Henderson]

On 23-Jun-1999, Fergus Henderson <fjh@cs.mu.OZ.AU> wrote:
> See the code at the end of this mail.

Sorry, I forgot to attach the code.  Here it is.

	import Prelude hiding (IO, getChar, putChar)

	-- this is just like the usual stream I/O technique,
	-- except that I've added process ids and timestamps
	data IO t = MkIO (  (Pid, InfiniteTree Timestamp, [Response])
			 -> (t, [Request]) )

	-- we take as input an infinite tree of time stamps
	data InfiniteTree t = MkTree t (InfiniteTree t) (InfiniteTree t)
	type Timestamp = Integer

	-- requests are annotated with timestamps, so that they can
	-- be sorted in the appropriate order.
	-- requests and responses are both annotated with a process id,
	-- so that each response can be sent to the proper sub-process
	type Request = (Pid, Timestamp, RequestType)
	data RequestType
		= ReqGetChar
		| ReqPutChar Char
		-- other IO operations go here ...

	type Response = (Pid, ResponseType)
	data ResponseType
		= RespGetChar Char
		| RespPutChar
		-- other responses from IO operations go here ...

	-- each process id is repesented as a path from the main process
	-- to that sub-process, specifying whether the sub-process was on the
	-- left hand side or the right hand side of each fork.
	type Pid = [Fork]
	data Fork = ForkLeft | ForkRight

	-- here's the standard stream I/O stuff

	-- define the basic I/O operations using do_io_action
	my_putChar :: Char -> IO ()
	my_putChar c = do_io_action (ReqPutChar c) (\ ~(RespPutChar) -> ())

	getChar :: IO Char
	getChar = do_io_action (ReqGetChar) (\ ~(RespGetChar c) -> c)

	-- do_io_action marks each request with the pid and a timestamp
	do_io_action :: RequestType -> (ResponseType -> t) -> IO t
	do_io_action request_type response_handler = MkIO action where
	    action (pid, timestamps, ~(resp:_)) = (result, [request]) where
		(resp_pid, resp_type) = resp
		(MkTree timestamp _ _) = timestamps
		request = (pid, timestamp, request_type)
		result = response_handler resp_type

	instance Monad IO where
	    (MkIO action1) >>= io_action2 = MkIO action where
		action (pid, timestamps, resps) = (x, reqs) where
		    (MkTree _ timestamps1 timestamps2) = timestamps
		    (y, reqs1) = action1 (pid, timestamps1, resps)
		    resps2 = drop (length reqs1) resps
		    (MkIO action2) = io_action2 y
		    (x, reqs2) = action2 (pid, timestamps2, resps2)
		    reqs = reqs1 ++ reqs2
	    return x = MkIO action where
		action _ = (x, [])
			
	forkIO (MkIO action1) (MkIO action2) = MkIO action where
	   action (pid, timestamps, responses) = (x, requests)
		where child_pid1 = pid ++ [ForkLeft]
		      child_pid2 = pid ++ [ForkRight]
		      (MkTree _ ts1 ts2) = timestamps
		      (responses1, responses2) = split_responses responses
		      (x1, requests1) = action1 (child_pid1, ts1, responses1)
		      (x2, requests2) = action2 (child_pid2, ts2, responses2)
		      requests = merge_requests requests1 requests2
		      x = (x1, x2)

	-- split a list of responses based on their attached process ids
	split_responses (r:rs) =
		let	((fork:forks), resp) = r
			r' = (forks, resp)
			(rs1, rs2) = split_responses rs
		in	case fork of
				ForkLeft  -> ((r':rs1), rs2)
				ForkRight -> (rs1, (r':rs2))

	-- do a sorted merge of requests, based on their time stamps
	merge_requests (x:xs) (y:ys) =
		if get_timestamp x < get_timestamp y
			then x : merge_requests xs (y:ys)
			else y : merge_requests (x:xs) ys
		where get_timestamp (_, timestamp, _) = timestamp

-- 
Fergus Henderson <fjh@cs.mu.oz.au>  |  "I have always known that the pursuit
WWW: <http://www.cs.mu.oz.au/~fjh>  |  of excellence is a lethal habit"
PGP: finger fjh@128.250.37.3        |     -- the last words of T. S. Garp.