Skip to content

Instantly share code, notes, and snippets.

@b-studios
Last active July 17, 2024 10:49
Show Gist options
  • Save b-studios/76ff6018d339678cea5f6294439728b9 to your computer and use it in GitHub Desktop.
Save b-studios/76ff6018d339678cea5f6294439728b9 to your computer and use it in GitHub Desktop.
Effect handlers in Racket
#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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment