#lang racket/base
;; Some basic drivers and utilities for writing programs using os-userland.rkt

(require racket/match)
(require racket/port)
(require "os-userland.rkt")

(require (prefix-in base: racket/base))

(provide (all-from-out "os-userland.rkt")

	 ground-vm/stdlib

	 message-handlers
	 meta-message-handlers

	 rpc
	 rpc-service

	 display-driver
	 display

	 read-line-driver
	 read-line

	 current-time
	 sleep-driver
	 sleep

	 receive
	 receive/timeout)

;; BootK -> Void
;; Starts the ground VM with the given BootK and a PatternPredicate
;; appropriate for use with this library.
(define (ground-vm/stdlib boot)
  (ground-vm boot #:pattern-predicate (lambda (p m) (p m))))

;; (message-handlers [pat expr ...] ...)
;; When one of these message handlers is invoked, binds the message
;; using pat, and then invokes the exprs. The pat serves double-duty:
;; it both destructures the message and acts as a predicate
;; controlling receipt of the message.
(define-syntax message-handlers
  (syntax-rules ()
    ((_ (pattern body ...) ...)
     (list (wait-clause (match-lambda (pattern #t) (_ #f))
			(match-lambda (pattern body ...)))
	   ...))))

;; For matching *ground* events. See also ground-message-handler in
;; os-big-bang.rkt.
(define-syntax meta-message-handlers
  (syntax-rules (=>)
    ((_ [(tag-expr evt-expr => pattern) body ...] ...)
     (list (wait-clause (ground-event-pattern tag-expr evt-expr)
			(match-lambda ((ground-event-value _ pattern) body ...)))
	   ...))))

;; Any -> Any
;; Performs an RPC, according to a simple stereotypical RPC protocol.
(define (rpc req)
  (define reply-addr (gensym 'reply-addr)) ;;; !!! TODO: remove side-effect?
  (send `(request ,reply-addr ,req))
  (wait (message-handlers
	 [`(reply ,(== reply-addr) ,v)
	  v])))

;; (rpc-service (pat expr ...) ...)
;; Starts an RPC service listening for messages matching the
;; pats. When one arrives, spawns a new process that runs the
;; corresponding exprs, and goes back to listening for more requests.
(define-syntax rpc-service
  (syntax-rules ()
    [(_ [pattern body ...] ...)
     (let loop ()
       (wait (message-handlers
	      [`(request ,reply-addr ,pattern)
	       (spawn (userland (lambda ()
				  (define answer (let () body ...))
				  (send `(reply ,reply-addr ,answer)))))]
	      ...))
       (loop))]))

;; Driver wrapping output to current-output-port.
(define display-driver
  (userland
   (lambda ()
     (let loop ()
       (define message (wait (message-handlers [`(display ,message) message])))
       (meta-send (lambda ()
		    (base:display message)
		    (flush-output)))
       (loop)))))

;; Sends its argument to the display-driver.
(define (display x)
  (send `(display ,x)))

;; Driver providing an RPC read-line (from current-input-port) service.
(define read-line-driver
  (userland
   (lambda ()
     (rpc-service
      [`read-line (wait (message-handlers)
			(meta-message-handlers
			 [('read-line
			   (read-line-evt (current-input-port) 'any)
			   => line)
			  line]))]))))

;; Requests the next line of input.
(define (read-line)
  (rpc 'read-line))

;; Racket timer event - see comment on the analogous function in os-timer.rkt.
(define (time-evt msecs)
  (wrap-evt (alarm-evt msecs) (lambda (_) (current-inexact-milliseconds))))

(define (wait-mmh msecs)
  (meta-message-handlers
   [((list 'time-evt msecs)
     (time-evt msecs)
     => current-time)
    current-time]))

(define (wait-until-time msecs)
  (wait (message-handlers)
	(wait-mmh msecs)))

;; Retrieves the current-inexact-milliseconds, using the VM tree IPC mechanism.
(define (current-time)
  (wait-until-time 0))

;; RPC service that replies to you when the specified number of
;; milliseconds have elapsed.
(define sleep-driver
  (userland
   (lambda ()
     (rpc-service
      [`(sleep ,msecs)
       (send `(display (Sleeping ,msecs)))
       (define now (wait-until-time (+ (current-time) msecs)))
       (send `(display "\n"))
       now]))))

;; Invoke the sleep-driver.
(define (sleep msecs)
  (rpc `(sleep ,msecs)))

;; Syntactic sugar for a (wait (message-handlers ...)) combination.
(define-syntax receive
  (syntax-rules ()
    ((_ mh-clause ...)
     (wait (message-handlers mh-clause ...)))))

;; Syntactic sugar for a (wait (message-handlers ...)) combination
;; with an additional timeout event.
(define-syntax receive/timeout
  (syntax-rules ()
    ((_ timeout-msecs mh-clause ...)
     (wait (message-handlers mh-clause ...)
	   (wait-mmh timeout-msecs)))))