#lang racket/base

(require racket/pretty)

;; Virtualized operating system.

(require racket/match)
(require racket/list)
(require "functional-queue.rkt")

(provide
 ;; Spawning processes
 (struct-out runnable)

 ;; Waiting for messages
 (struct-out subscription)
 (struct-out message-handler)

 ;; Kernel requests
 (struct-out kernel-mode-transition)

 ;; Constructing, accessing and running VMs
 make-vm
 vm?
 run-vm

 ;; Grounding out the infinite tower of VMs
 nested-vm-inert?
 ground-vm
 )

;; Each VM hosts 0 or more *multiplexed* processes. Each process has
;; its own state record. In between schedulings, a process consists of
;; 1 or more message handlers. A message handler is a pair of a message
;; recogniser and a procedure taking a message and a process state to a
;; new process state.
;;
;; Each VM provides a *communication bus* for its processes to
;; use. The communication bus is the only form of IPC the VM provides.
;;
;; Some processes *relay* messages out from the VM to other
;; VMs. Because the "tree" of VMs so formed has to be a tree - See
;; Shivers & Might 2006 for a discussion of this - we gather together
;; all the interactions between the supervenient VM and its support VM
;; into a single channel of communication. The relaying processes are,
;; in effect, device-drivers, providing application-specific
;; communication services to other processes in the VM.
;;
;; We split processes into "user" processes, permitted only to spawn
;; other user processes and send messages on the VM's bus, and
;; "kernel" processes, permitted also to spawn other kernel processes
;; and send messages to the VM's container.
;;
;; Time plays an interesting role in a distributed system: if the
;; medium messages are sent through isn't cooperative enough to let us
;; know of a failed conversational participant, our only recourse is
;; /timeout/. Therefore, we require every level of the machine to
;; support timeouts, though we do not require such timeouts to be tied
;; to real, wall-clock time: simulated time is just fine. This helps
;; with testability.
;;
;; Racket's alarm-evt is almost the right design for timeouts: its
;; synchronisation value should be the (or some) value of the clock
;; after the asked-for time. That way it serves as timeout and
;; clock-reader in one.

;; VMs are parameterised over:
;;  - the type of messages carried on the bus, Message
;;  - the type of patterns over Messages, MessagePattern
;;  - the type of messages to other VMs, MetaMessage
;;  - the type of patterns over MetaMessages, MetaMessagePattern

;; A VTable is a (vtable (MessagePattern Message -> Boolean)
;;                       (MetaMessagePattern MetaMessage -> boolean))
;; supplying the behavioural aspects of the type-parameters of VMs.
(struct vtable (apply-message-pattern
		apply-meta-message-pattern) #:transparent)

;; A VM is a (vm ListBagOf<Subscription>
;;               QueueOf<Message> ;; TODO: make unordered?
;;               QueueOf<MetaMessage> ;; TODO: make unordered?
;;               QueueOf<Runnable>).
(struct vm (subscriptions
	    pending-messages
	    pending-meta-messages
	    pending-processes
	    vtable) #:transparent)

;; A TrapK<X> is a X -> InterruptK, representing a suspended process
;; waiting for some information from the VM before it can continue.

;; An InterruptK is a
;;   ProcessState -> KernelModeTransition
;; representing a suspended process that can run instantly without
;; waiting for more information from the VM. The input is the state of
;; the process, and the output is the information passed back to the
;; VM when the process yields the CPU.

;; A Runnable is a (runnable ProcessState InterruptK), representing a
;; temporarily-suspended runnable process.
(struct runnable (state k) #:transparent)

;; A Subscription is a
;; (subscription ProcessState
;;               Maybe<InterruptK>
;;               ListBagOf<MessageHandler>
;;               ListBagOf<MetaMessageHandler>).
;; To poll the kernel, include a non-#f InterruptK.
(struct subscription (state
		      k
		      message-handlers
		      meta-message-handlers) #:transparent)

;; A MessageHandler is one of
;; -- (message-handler MessagePattern TrapK<Message>)
(struct message-handler (matcher k) #:transparent)

;; A KernelModeTransition is a
;; (kernel-mode-transition Subscription
;;                         ListBagOf<Message>
;;			   ListBagOf<MetaMessage>
;;                         ListBagOf<Runnable>)
;; representing the subscription for the transitioning process, a list
;; of messages to emit at both this VM's and its container's level,
;; and a list of new processes to create and schedule.
(struct kernel-mode-transition (subscription
				messages
				meta-messages
				new-processes) #:transparent)

;; A ListBagOf<X> is a ListOf<X> with the additional constraint that
;; order isn't meaningful.

;; TODO: is timeout really primitive? If so, isn't presence primitive?
;; TODO: what about metatimeout?
;; TODO: what about spawn-meta-process etc? Come back to this later.
;; TODO: enforce user-mode restrictions
;; TODO: timeouts

;; ( -> KernelModeTransition ) -> VM
(define (make-vm vtable boot)
  (vm (list)
      (make-queue)
      (make-queue)
      (enqueue (make-queue) (runnable (void) (lambda (dummy) (boot))))
      vtable))

;; VM -> KernelModeTransition
;; (A kind of Meta-InterruptK)
(define (run-vm state)
  (pretty-print `(run-vm ,state))
  (let* ((state (requeue-pollers state))
	 (state (run-runnables state))
	 (state (dispatch-messages state)))
    (trap-to-metalevel state)))

(define (requeue-pollers state)
  (foldl (lambda (sub state)
	   (if (subscription-polling? sub)
	       (enqueue-runnable (runnable (subscription-state sub)
					   (subscription-k sub))
				 state)
	       (subscribe-process sub state)))
	 (struct-copy vm state [subscriptions '()])
	 (vm-subscriptions state)))

(define (run-runnables state)
  (foldl (lambda (r state)
	   (match-define (runnable process-state k) r)
	   (perform-transition (k process-state) state))
	 (struct-copy vm state [pending-processes (make-queue)])
	 (queue->list (vm-pending-processes state))))

(define (dispatch-messages state)
  (foldl dispatch-message
	 (struct-copy vm state [pending-messages (make-queue)])
	 (queue->list (vm-pending-messages state))))

;; KernelModeTransition VM -> VM
(define (perform-transition transition state)
  (pretty-print `(--> perform-transition ,transition ,state))
  (match transition
    [(kernel-mode-transition new-subscription
			     messages
			     meta-messages
			     new-processes)
     (let* ((state (foldl enqueue-message state messages))
	    (state (foldl enqueue-runnable state new-processes))
	    (state (subscribe-process new-subscription state))
	    (state (foldl enqueue-meta-message state meta-messages)))
       (pretty-print `(<-- ,state))
       state)]
    [other
     (error 'vm "Processes must return a kernel-mode-transition struct; got ~v" other)]))

(define (enqueue-message message state)
  (struct-copy vm state [pending-messages (enqueue (vm-pending-messages state) message)]))

(define (enqueue-runnable r state)
  (struct-copy vm state [pending-processes (enqueue (vm-pending-processes state) r)]))

(define (subscribe-process sub state)
  (match sub
    [(subscription _ #f '() '())
     ;; dead process because no continuations offered
     state]
    [_
     (struct-copy vm state [subscriptions (cons sub (vm-subscriptions state))])]))

(define (enqueue-meta-message message state)
  (struct-copy vm state [pending-meta-messages (enqueue (vm-pending-meta-messages state) message)]))

(define (dispatch-message message state)
  (foldl (match-subscription message
			     vtable-apply-message-pattern
			     subscription-message-handlers)
	 (struct-copy vm state [subscriptions '()])
	 (vm-subscriptions state)))

(define ((match-subscription message apply-getter handlers-getter) sub state)
  (let search-handlers ((message-handlers (handlers-getter sub)))
    (cond
     [(null? message-handlers)
      ;; No handler matched this message. Put the subscription
      ;; back on the list for some future message.
      (subscribe-process sub state)]
     [((apply-getter (vm-vtable state))
       (message-handler-matcher (car message-handlers))
       message)
      (perform-transition ((message-handler-k (car message-handlers))
			   (subscription-state sub))
			  state)]
     [else
      (search-handlers (cdr message-handlers))])))

(define (subscription-polling? sub)
  (not (eq? (subscription-k sub) #f)))

;; VM -> Boolean
;; When should a VM block? When it has no runnables, no pending
;; messages, and no polling subscriptions. Otherwise, it should poll.
(define (should-poll? state)
  (or (not (queue-empty? (vm-pending-processes state)))
      (not (queue-empty? (vm-pending-messages state)))
      (ormap subscription-polling? (vm-subscriptions state))))

(define (trap-to-metalevel state)
  (define meta-messages (queue->list (vm-pending-meta-messages state)))
  (define meta-handlers (append-map (lambda (sub)
				      (map wrap-meta-message-handler
					   (subscription-meta-message-handlers sub)))
				    (vm-subscriptions state)))
  (define final-state (struct-copy vm state [pending-meta-messages (make-queue)]))
  (kernel-mode-transition (subscription final-state
					(and (should-poll? final-state)
					     ;; only block if there's nothing left to do
					     run-vm)
					meta-handlers
					'())
			  meta-messages
			  '()
			  '()))

(define (wrap-meta-message-handler mh)
  (message-handler (message-handler-matcher mh) dispatch-meta-message))

(define ((dispatch-meta-message message) state)
  (run-vm
   (foldl (match-subscription message
			      vtable-apply-meta-message-pattern
			      subscription-meta-message-handlers)
	  (struct-copy vm state [subscriptions '()])
	  (vm-subscriptions state))))

;;---------------------------------------------------------------------------

(define (nested-vm-inert? transition)
  (match transition
    [(kernel-mode-transition (subscription (vm _
					       (? queue-empty?)
					       (? queue-empty?)
					       (? queue-empty?)
					       _)
					   #f
					   '()
					   '())
			     _
			     _
			     '())
     ;; No pending-messages within the nested VM, so no internal
     ;; activity is possible, and furthermore it is not waiting for
     ;; any outside messages.
     #t]
    [_ #f]))

;; VTable ( -> KernelModeTransition ) -> Void
;; In this context,
;;   Message = a thunk
;;   MessagePattern = evt?
;;   MetaMessage, MetaMessagePattern = not defined because there's no outer level
;; Runs its argument VM until it becomes (provably) inert.
(define (ground-vm vtable boot)
  (let loop ((transition (run-vm (make-vm vtable boot))))
    (when (not (nested-vm-inert? transition))
      (match transition
	[(kernel-mode-transition (subscription new-state
					       polling-k
					       message-handlers
					       '())
				 outbound-messages
				 '()
				 '())
	 (for-each (lambda (thunk) (thunk)) outbound-messages)
	 (define inbound-messages
	   (map (match-lambda [(message-handler e k) (wrap-evt e (lambda (v) (cons v k)))])
		message-handlers))
	 (match-define (cons inbound-message-value inbound-message-continuation)
	   (apply sync
		  (wrap-evt (if polling-k always-evt never-evt)
			    (lambda (v) (cons (void)
					      (lambda (dummy) polling-k))))
		  inbound-messages))
	 (loop ((inbound-message-continuation inbound-message-value) new-state))]
	[_
	 (error 'ground-vm
		"Outermost VM may not spawn new siblings or send or receive metamessages")]))))

;---------------------------------------------------------------------------

(define (yield k)
  (kernel-mode-transition (subscription 'none (lambda (_) (k)) '() '())
			  '()
			  '()
			  '()))
(define (quit)
  (kernel-mode-transition (subscription 'none #f '() '())
			  '()
			  '()
			  '()))
(define (print x k)
  (kernel-mode-transition (subscription 'none (lambda (_) (k)) '() '())
			  '()
			  (list (lambda () (pretty-print x)))
			  '()))
(define (super-alarm msecs)
  (wrap-evt (alarm-evt msecs) (lambda (_) (current-inexact-milliseconds))))
(define (sleep n k)
  (kernel-mode-transition (subscription 'none
					#f
					'()
					(list (message-handler
					       (super-alarm (+ (current-inexact-milliseconds) n))
					       (lambda (_) (k)))))
			  '()
			  '()
			  '()))
(ground-vm #f ;; TODO - fix this - what's a better way of correlating
	      ;; metamessages with their metamessagepatterns??
	   (lambda ()
	     (sleep 1000
		    (lambda ()
		      (yield
		       (lambda ()
			 (print "HELLO"
				quit)))))))