Effect handlers in Racket

handlers.rkt

#lang racket
(require racket/control)
(require racket/syntax)

(struct operation (name effect))

(struct effect-call (op args cont))

(define (do op . args)
  (control0-at (operation-effect op) k (effect-call op args k)))

(define return #false)

(define (build-handler effect clauses)
  (letrec ([dict (make-immutable-hash clauses)]
           [h (lambda (prog)
    (match (prompt0-at effect (prog))
      [(effect-call op args k) (if (eq? (operation-effect op) effect)
                                   (apply (hash-ref dict op) (append args (list (lambda (x) (h (lambda () (k x)))))))
                                   (error 'wrong-handler "..."))]
      [x ((hash-ref dict return) x)]))])
    h))


(define-syntax define-effect
  (syntax-rules ()
    [(define-effect eff (op ...))
     (begin
       (define eff (make-continuation-prompt-tag))
       (define op (operation (generate-temporary 'op) eff)) ...)]))

(define-syntax make-clause
  (syntax-rules ()
    [(make-clause (op k body)) (cons op (lambda (k) body))]
    [(make-clause (op x ... k body)) (cons op (lambda (x ... k) body))]))

(define-syntax handler
  (syntax-rules ()
    [(handler eff clause ...)
                   (build-handler eff (list (make-clause clause) ...))]))
    




;; User Code

(define-effect state [get put])


;(define-handler always-42 state
;         [get k (k 42)]
;         [return x x])
(define always-42
  (handler state
           [get k (k 42)]
           [return x x]))

(define with-state
  (handler state
           [get k (lambda (s) ((k s) s))]
           [put s2 k (lambda (s) ((k '()) s2))]
           [return x (lambda (s) x)]))


(always-42 (lambda () (+ (do get)
                         (do get)
                         (do get)
                         (do get))))

((with-state (lambda () (+ (do get)
                           (do get)
                           (begin (do put 1) 0)
                           (do get)
                           (do get)))) 42)


(define-effect exc [raise])

(define default-100
  (handler exc
           [raise msg k 100]
           [return x x]))

((with-state (lambda () (+ (do get)
                           (do get)
                           (default-100 (lambda ()
                                    (begin (do put 1) (do raise "abort") 10)))
                           (do get)
                           (do get)))) 42)


(define-effect amb [flip])

(define collect
  (handler amb
           [flip k (append (k #true) (k #false))]
           [return x (list x)]))

(define maybe
  (handler exc
           [raise msg k #f]
           [return x x]))

(define (drunkflip)
  (if (do flip)
      (do raise "too drunk")
      (if (do flip) "heads" "tails")))

(collect (lambda () (maybe (lambda () (drunkflip)))))
; '(#f "heads" "tails")

(maybe (lambda () (collect (lambda () (drunkflip)))))
; #f