#lang racket/base
;; Extensible Denotational Language Specifications

;; The paper "Extensible Denotational Language Specifications", by
;; Cartwright & Felleisen (1994), henceforth "EDLS", presents a
;; picture of an extensible interpreter for programming languages. The
;; interpreter can be extended with new syntactic forms (and their
;; meanings), new actions (and their effects), and new kinds of
;; resources to be placed under its control.

;; Rather than interpreting an extensible collection of syntax here,
;; we call Racket code directly. Extension at the syntactic level is
;; provided by Racket's macros. The purpose of this code is to provide
;; a structured model of the extensible actions and extensible
;; resource-management facets of the EDLS design. We use delimited
;; continuations to transfer control between the "pure" facet (the
;; interpretation of programs) and the impure or operational facets
;; (the performing of actions, and management of resources).

;; TODO: investigate continuation barriers, to avoid throws out
;; through the current interpreter/VM. Actually, think harder about
;; what even needs protecting - it's not clear.

;; TODO: what happens when an interactor, performing an action, raises
;; an exception? What should happen? In some sense it's the fault of
;; the invoker of the action, isn't it? Consider binding a UDP socket
;; to a port already in use. Alternatively, consider some internal
;; error in the interactor: then it's not the fault of the invoker at
;; all.

;; TODO: pull in scheduler and event-stream ideas from Olin's papers

;; TODO: consider splitting lookup from apply in
;; action-handlers. Consider, for instance, replicating action
;; streams: you might want to check for DNU before replicating the
;; pending action.

;; TODO: think about using a private prompt tag, and what the
;; consequences for cross-virtual-level interaction are if multiple
;; prompt tags are in play. This will force some thinking about
;; continuation barriers, too.

;; TODO: think about how a weak table might be exposed as a
;; resource. Its implementation depends on primitive weakness! (Or on
;; a transitively-provided weak service.)

#|

Things that can wake up some continuations:

 - external events (CML-style, timeouts)
 - internal events (completion of a write or similar)
 - unguarded continuations (spawned threads, basically)


Are these containery things the conversation/chatrooms of racket-ssh?

|#

;; From the fine manual: "The protocol for vs supplied to an abort is
;; specific to the prompt-tag. When abort-current-continuation is used
;; with (default-continuation-prompt-tag), generally, a single thunk
;; should be supplied that is suitable for use with the default prompt
;; handler. Similarly, when call-with-continuation-prompt is used with
;; (default-continuation-prompt-tag), the associated handler should
;; generally accept a single thunk argument."

;; Semantic framework from EDLS:
;;
;;   computation : (+ (make-value value) (make-effect action (-> value computation)))
;;   program-meaning : (-> program (* (+ value error) resources)
;;   expression-meaning : (-> expr env computation)
;;   admin : (-> (* computation resources) (* (+ value error) resources))
;;   handler : (-> computation (-> value computation) computation)
;;
;; Handler is used to stitch stack frames together into a composed
;; continuation, something that we're doing here natively with
;; Racket's composable continuations.
;;
;; If we're going to make values self-representing, then we need to
;; ensure that all effects are disjoint from values. The way to do
;; that is to control the abort/prompt-tag protocol closely, so that
;; regular values returned are distinguished from actions thrown. That
;; way, no value is forbidden to the userland, including descriptions
;; of actions.

;; Can we say that the *communications facility* in EDLS is
;; underpowered? It's point-to-point and relies on noninterference
;; between action-handling extensions. Since each extension is
;; logically managing its own resources, it feels like we have a kind
;; of network-layer here IF we enforce separation of the managed
;; resources so there are no cross-channels.
;;
;; The reason I'm interested in this approach is to get some kind of
;; objcap-oriented interface not only to the substrate but to the
;; extensions embedded in the substrate. Consider the DNS-server case,
;; where a socket needs to be opened and then straight-line
;; interactions with the socket take place. Now consider the DNS-proxy
;; case, where not only does a socket (or more than one!) need to be
;; created, but complex conversional contexts are built up as each
;; query arrives and is processed. As DJB observes, a single query can
;; in principle result in unbounded recursion as "glue" records are
;; looked up. It kind of makes sense to have each conversational
;; context as a separate entity, managing its own resources, embedded
;; in the substrate.

(require racket/match)
(require racket/class)

(define interactor<%>
  (interface ()
    perform-action))

(define action-prompt (make-continuation-prompt-tag 'interactor-action))

(define (perform-action . action-pieces)
  (call-with-composable-continuation
   (lambda (k)
     (abort-current-continuation action-prompt
       (lambda () (values action-pieces k))))
   action-prompt))

(define (run/interactor boot interactor)
  (call-with-continuation-barrier
   (lambda ()
     (let loop ((next-step-thunk (lambda () (values (boot) #f)))
		(interactor interactor))
       (define-values (computation-step-result computation-step-continuation)
	 (call-with-continuation-prompt next-step-thunk action-prompt))
       (cond
	((eq? computation-step-continuation #f)
	 ;; The computation is finished, and has yielded a result.
	 computation-step-result)
	(else
	 ;; The computation is not finished, but is waiting for an
	 ;; action to complete.
	 (send interactor perform-action
	       computation-step-result
	       (lambda (action-result-value new-interactor)
		 (loop (lambda () (computation-step-continuation action-result-value))
		       new-interactor))
	       (lambda ()
		 (error 'run/interactor "Action not interpretable by context: ~v"
			computation-step-result)))))))))

(define cells%
  (class* object% (interactor<%>)
    (init-field next-name)
    (init-field mapping)
    (super-new)
    (define/public (perform-action action k-ok k-dnu)
      (match action
	(`(new ,initial-value)
	 (k-ok next-name (make-object cells%
				      (+ next-name 1)
				      (hash-set mapping next-name initial-value))))
	(`(get ,n)
	 (if (hash-has-key? mapping n)
	     (k-ok (hash-ref mapping n) this)
	     (error 'cells% "Cell name ~v not found (on get)" n)))
	(`(set ,n ,new-value)
	 (if (hash-has-key? mapping n)
	     (k-ok new-value (make-object cells%
					  next-name
					  (hash-set mapping n new-value)))
	     (error 'cells% "Cell name ~v not found (on set)" n)))
	(else
	 (k-dnu))))))

(define (new-cell [initial-value (void)])
  (perform-action 'new initial-value))

(define (get-cell c)
  (perform-action 'get c))

(define (set-cell! c v)
  (perform-action 'set c v))

(define (empty-cells)
  (make-object cells% 0 (hash)))

(define combine%
  (class* object% (interactor<%>)
    (init-field children)
    (super-new)
    (define/public (perform-action action k-ok k-dnu)
      (let search ((remaining children)
		   (examined '()))
	(cond
	 ((null? remaining) (k-dnu))
	 (else
	  (define child (car remaining))
	  (define rest (cdr remaining))
	  (send child perform-action
		action
		(lambda (result new-child)
		  (k-ok result
			(make-object combine% (append (reverse examined) (cons new-child rest)))))
		(lambda ()
		  (search rest (cons child examined))))))))))

(define (combine-interactors is)
  (make-object combine% is))

(define udp%
  (class* object% (interactor<%>)
    (struct handle (socket)) ;; generative: new predicate etc. per udp% instance!
    (super-new)
    (define/public (perform-action action k-ok k-dnu)
      (match action
	(`(new)
	 (k-ok (handle (udp-open-socket #f #f)) this))
	(`(bind ,(handle s) ,port)
	 (k-ok (udp-bind! s #f port) this))
	(`(send ,(handle s) ,host ,port ,packet)
	 (k-ok (udp-send-to s host port packet) this))
	(`(recv ,(handle s) ,packet-size-limit)
	 (define buffer (make-bytes packet-size-limit))
	 (define-values (packet-length source-hostname source-port)
	   (udp-receive! s buffer))
	 (k-ok (list source-hostname source-port (subbytes buffer 0 packet-length)) this))
	(else (k-dnu))))))

(run/interactor (lambda () 1234)
		(empty-cells))

(run/interactor (lambda ()
		  (let ((x (new-cell)))
		    (set-cell! x 1)
		    (set-cell! x (+ 1 (get-cell x)))
		    (+ 1000 (get-cell x))))
		(empty-cells))

(run/interactor (lambda ()
		  (let ((x (new-cell 'initial-x-value))
			(y (new-cell 'initial-y-value)))
		    (set-cell! x 1)
		    (set-cell! y 1000)
		    (set-cell! x (+ 1 (get-cell x)))
		    (+ (get-cell x)
		       (get-cell y))))
		(combine-interactors (list (empty-cells))))