Algebraic effects in Racket from delimited continuations

effect.rkt

#lang racket


; these two tags should be kept private and not exposed to effect users
(define handle-effect-tag (make-continuation-prompt-tag 'handle-effect-tag))
(define global-effect-tag (make-continuation-prompt-tag 'global-effect-tag))


(define (raise-effect tag . args)
  (call-with-composable-continuation (λ (k) (apply abort-current-continuation tag k args))
                                     global-effect-tag))

(struct effect-handler (tag function) #:transparent)

(define (call/shallow-effect-handlers thunk . handlers)
  (define (run-thunk)
    (call-with-continuation-prompt thunk global-effect-tag
                                   (λ _
                                     (error 'call/captured-prompts
                                            "not allowed to abort to the global effect tag"))))
  (define run-with-handlers
    (for/fold ([run-thunk run-thunk])
              ([handler (in-list handlers)])
      (match-define (effect-handler tag handler-function) handler)
      (λ ()
        (call-with-continuation-prompt
         run-thunk
         tag
         (λ (resume-continuation . raised-values)
           (abort-current-continuation
            handle-effect-tag
            (λ () (apply handler-function resume-continuation raised-values))))))))
  (call-with-continuation-prompt run-with-handlers
                                 handle-effect-tag
                                 (λ (call-handler) (call-handler))))

(define (call/deep-effect-handlers thunk . handlers)
  (define ((wrap-resume-continuation resume-continuation) . args)
    (apply call/deep-effect-handlers (λ () (apply resume-continuation args)) handlers))
  (apply call/shallow-effect-handlers
         thunk
         (for/list ([handler (in-list handlers)])
           (match-define (effect-handler tag shallow-handler-function) handler)
           (define (handle-with-handlers-reinstalled resume-continuation . args)
             (apply shallow-handler-function (wrap-resume-continuation resume-continuation) args))
           (effect-handler tag handle-with-handlers-reinstalled))))


(define exn (make-continuation-prompt-tag 'exn))
(define yield (make-continuation-prompt-tag 'yield))
(define async (make-continuation-prompt-tag 'async))


(call/deep-effect-handlers (λ () (list (raise-effect async 42) (raise-effect yield)))
                              (effect-handler exn (λ (k e) (list 'exn e)))
                              (effect-handler yield (λ (k) (list 'yield)))
                              (effect-handler async (λ (k x) (k (+ x 1)))))