#lang racket/base

(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)

(define (ground-vm/stdlib boot)
  (ground-vm boot #:pattern-predicate (lambda (p m) (p m))))

(define-syntax message-handlers
  (syntax-rules ()
    ((_ (pattern body ...) ...)
     (list (wait-clause (match-lambda (pattern #t) (_ #f))
			(match-lambda (pattern body ...)))
	   ...))))

(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 ...)))
	   ...))))

(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])))

(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))]))

(define display-driver
  (userland
   (lambda ()
     (let loop ()
       (define message (wait (message-handlers [`(display ,message) message])))
       (meta-send (lambda ()
		    (base:display message)
		    (flush-output)))
       (loop)))))

(define (display x)
  (send `(display ,x)))

(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]))]))))

(define (read-line)
  (rpc 'read-line))

(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)))

(define (current-time)
  (wait-until-time 0))

(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]))))

(define (sleep msecs)
  (rpc `(sleep ,msecs)))

(define-syntax receive
  (syntax-rules ()
    ((_ mh-clause ...)
     (wait (message-handlers mh-clause ...)))))

(define-syntax receive/timeout
  (syntax-rules ()
    ((_ timeout-msecs mh-clause ...)
     (wait (message-handlers mh-clause ...)
	   (wait-mmh timeout-msecs)))))