shallow-effect-handler.rkt

#lang racket

(require racket/control)

(struct spwn (val p) #:prefab #:extra-name Spwn)

(define (fcontrol-at p v)
  (fcontrol (spwn v p)))

(define (%-at p th handler)
  (% (th) (λ (x k)
          (match x
            [(Spwn v p~) #:when (eqv? p p~)
                         (handler v k)]
            [(Spwn v p~)
             (let [(res (fcontrol-at p~ v))]
               (%-at p (λ () (k res)) handler))]))))

(define (perform eff v)
  (fcontrol-at eff v))

(define (new-effect) (make-continuation-prompt-tag))

(define ((call-with-shallow-handler eff vh effh) th)
    (let* [(p (make-continuation-prompt-tag 'return))
           (const (λ (x _) x))
           (effh~ (λ (x k)
                     (fcontrol-at p (effh x k))))]
      (%-at p (λ () (vh (%-at eff (λ () (th)) effh~))) const)))

; --------
(let* [(eff (new-effect))
       (handle- (λ (effh th)
                   ((call-with-shallow-handler eff
                                               (λ (x) (+ x 3 ))
                                               effh)
                    th)))]
  (handle-
    (λ (v k) (k (+ v 10000000)))
    (λ () (handle-
            (λ (v k) (k (+ v 10000)))
            (λ ()
               (+ (perform eff 11) (perform eff 13)))))))

(struct coroutine ([it #:mutable]) #:extra-name Coroutine)

(define Yield (new-effect))
(define (yield v)
  (perform Yield v))

(define (resume co v)
  ((call-with-shallow-handler Yield
                              (λ (x) x)
                              (λ (u k)
                                 (begin
                                   (set-coroutine-it! co k)
                                   u)))
   (λ () ((coroutine-it co) v))))

(let [(co (coroutine
           (λ (_)
              (begin
                (display "hello,")
                (displayln (yield '()))
                ))))]
  (begin
    (resume co '())
    (resume co "world")))