Examples of how to build control flow structures with continuations

continuation-lessons.md

Lessons in Using Continuations

This gist contains examples of how to build different kinds of control flow structures in Racket using macros and continuations. Examples include:

• Early exit from functions using a return statement.
• Early exit from arbitrary expressions using a simple exception system.
• Temporarily interrupting execution in order to check permissions.

continuations.rkt

#lang racket

(require (for-syntax syntax/parse/lib/function-header)
         racket/stxparam
         syntax/parse/define)

(define return-tag (make-continuation-prompt-tag))

(define (return-dynamically v)
  (abort-current-continuation return-tag v))

(define (call/dynamic-return thunk)
  (call-with-continuation-prompt thunk return-tag values))

(define-syntax-parameter return!
  (λ (stx) (raise-syntax-error #false "cannot be used outside a define/return function body" stx)))

(define-simple-macro (define/return header:function-header body ...)
  (define header
    (call/dynamic-return
     (syntax-parameterize ([return! (make-rename-transformer #'return-dynamically)])
       (λ () body ...)))))

(define/return (abs x)
  (when (negative? x)
    (return! (- x)))
  x)

(abs 10) ; returns 10
(abs 0) ; returns 0
(abs -10) ; returns 10

continuations2.rkt

#lang racket

(require racket/stxparam
         rebellion/base/result
         syntax/parse/define)

(define try-tag (make-continuation-prompt-tag))

(define (fail-dynamically v) (abort-current-continuation try-tag v))

(define (try-dynamically thunk)
  (call-with-continuation-prompt (λ () (success (thunk))) try-tag failure))

(define-syntax-parameter fail!
  (λ (stx) (raise-syntax-error #false "cannot be used outside a try block" stx)))

(define-simple-macro (try body ...)
  (try-dynamically
   (λ ()
     (syntax-parameterize ([fail! (make-rename-transformer #'fail-dynamically)])
       body ...))))

;; evaluates to (success 3)
(try
 (define x 1)
 (define y 2)
 (+ x y))

;; evaluates to (failure 'oops)
(try
 (define x 1)
 (define y (fail! 'oops))
 (+ x y))

continuations3.rkt

#lang racket

(require racket/stxparam
         rebellion/base/result
         syntax/parse/define)

(define permission-check-tag (make-continuation-prompt-tag 'permission-check))

(define (check-permission-dynamically permission)
  (call-with-current-continuation
   (λ (jump-back) (abort-current-continuation permission-check-tag permission jump-back))
   permission-check-tag))

(define (make-permission-check-handler granted-permissions)
  (define (handler permission jump-back)
    (if (set-member? granted-permissions permission)
        (call-with-continuation-prompt jump-back permission-check-tag handler)
        (failure permission)))
  handler)

(define (grant-permissions-dynamically permissions thunk)
  (define handler (make-permission-check-handler permissions))
  (call-with-continuation-prompt (λ () (success (thunk))) permission-check-tag handler))

(define-syntax-parameter in-grant-permissions-block? #false)

(define-simple-macro (check-permission! id:id)
  #:fail-unless (syntax-parameter-value #'in-grant-permissions-block?)
  "cannot be used outside a grant-permissions block"
  (check-permission-dynamically 'id))

(define-simple-macro (grant-permissions (~seq #:allow sym:id) ... body ...)
  (grant-permissions-dynamically
   (set 'sym ...)
   (λ ()
     (syntax-parameterize ([in-grant-permissions-block? #true])
       body ...))))

;; evaluates to (failure 'system-clock)
(grant-permissions
 #:allow filesystem
 #:allow network
 
 (displayln "Stealing secret files...")
 (check-permission! filesystem)
 (displayln "Secret files stolen!")

 (newline)

 (displayln "Contacting the NSA...")
 (check-permission! network)
 (displayln "NSA contacted!")

 (newline)

 (displayln "Changing the system clock...")
 (check-permission! system-clock)
 ;; this part is never printed
 (displayln "System clock changed!"))

(side note) Regarding the first case, one can also use a simple escape continuation ("ec"):

(define (abs x)
  (let/ec return
    (when (negative? x)
      (return (- x)))
    x))