Delimited continuations in R7RS (chibi scheme)

shift-reset.scm

(import (scheme base)
        (scheme write)
        (scheme eval)
        (chibi show)
        (chibi match)
        (chibi test))

(define *meta-continuation*
        (lambda (value)
          (error "No top-level RESET" value)))

(define-syntax reset
  (syntax-rules ()
    ((reset body)
     (let ((mc *meta-continuation*))
       (call-with-current-continuation
         (lambda (k)
           (set! *meta-continuation*
                 (lambda (value)
                   (set! *meta-continuation* mc)
                   (k value)))
           (let ((result body))
             ;** do not beta-substitute!!
             (*meta-continuation* result))))))))

(define-syntax shift
  (syntax-rules ()
    ((shift var body)
     (call-with-current-continuation
       (lambda (k)
         (let ((result (let ((var (lambda (value)
                                    (reset (k value)))))
                         body)))
           ;** do not beta-substitute!!
           (*meta-continuation* result)))))))


(test-group "simple"
  ;; When this snippet is executed, the use of shift will bind k to the continuation (+ 1 []) where
  ;; [] represents the part of the computation that is to be filled with a value.
  (test 12
        (* 2 (reset (+ 1 (shift k (k 5))))))

  ;; Invokes (k 4) first (which returns 8), and then (k 8) (which returns 16). At this point, the
  ;; shift expression has terminated, and the rest of the reset expression is discarded. Therefore,
  ;; the final result is 16.
  (test 17
        (+ 1 (reset (* 2 (shift k (k (k 4))))))))


(test-group "call/cc"
  ;; In contrast, call/cc:
  ;;
  ;; - Does something like an early return, so it never reaches the outer (k []), or anything after
  ;; the call to (k 4).
  ;;
  ;; - Captures "the entire program up to that point", meaning that k captures all the way up to the
  ;; top-level expression and the execution context.
  ;;
  ;; - In contrast, with delimited continuations, it's delimited and it stops at the first
  ;; 'reset'. It also continues after it runs the continuation, so it would continue to execute
  ;; whatever was passed (k 4), which in this case is the outermost (k []).
  (test 9
        (+ 1 (* 2 (call/cc (lambda (k) (k (k 4)))))))

  ;; The continuation k becomes (* 3 (+ 1 (* 2 []))):
  ;; (* 3 (+ 1 (* 2 [4]))) = (* 3 (+ 1 8)) = (* 3 9) = 27.
  (test 27
        (* 3 (+ 1 (* 2 (call/cc (lambda (k) (k (k 4)))))))))


;; The context captured by shift is (begin [*] '()), where [*] is the hole where k's parameter will
;; be injected.
;;
;; The first call of k inside shift evaluates to this context with #f replacing the hole, so the
;; value of (k #f) is (begin #f '()) = '().
;;
;; The body of shift, namely (cons 1 '()) = '(1), becomes the overall value of the reset expression
;; as the final result.
(test-group "lists"
  (test '(1)
        (reset
         (begin
           (shift k (cons 1 (k #f)))
           '())))

  (test '(1 2 3)
        (reset
         (begin
           (shift k (cons 1 (k #f)))
           (shift k (cons 2 (k #f)))
           '(3)))))


(test-group "generator"
  (define (yield x) (shift k (cons x (k '()))))

  (test '(1 2 3 4)
        (reset (begin
                 (yield 1)
                 (yield 2)
                 (yield 3)
                 '(4)))))


(test-group "currying"
  (define curry_d
    (lambda (f n)
      (if (< n 0)
          (error 'curry_d "negative input: ~s" n)
          (letrec ((visit (lambda (i)
                            (if (= i 0)
                                '()
                                (cons (shift k k)
                                      (visit (- i 1)))))))
            (reset (apply f (visit n)))))))

  (test 12 (let ((curry+ (curry_d + 2)))  ; + operator with 2 args
             ((curry+ 2) 10)))

  (test 15 (let ((curry+ (curry_d + 3)))  ; + operator with 3 args
             (((curry+ 2) 3) 10)))

  (test 21 (let ((curry* (curry_d * 2)))  ; * operator with 3 args
             ((curry* 3) 7))))


;; TODO: javascript-style coroutines
#(define x
   (reset ((lambda (k) (begin (display k) "foo"))
           (shift k
                  (let* ((value "1")
                         (res (k value)))
                    (display value)
                    (newline)
                    res))))
   )
#(display x)

;; TODO: conditions and restarts
;; ...

(test-group "conditions and restarts"
  (test
   "signal"
   (string-append "Some long computation...  0%\n"
                  "Still working...  23/100%\n"
                  "Still more work...  73/100%\n"
                  "Done.  100%\n")
   (parameterize
       ((current-output-port
         (open-output-string)))
     (reset
      ((lambda (k)
         (match k
           (`(msg progress ,p)
            ;; Here, the progress for the long computation gets printed, but it could be stored in a
            ;; log file, ignored, rendered in a UI, sent to an API endpoint, tagged, etc
            (show #t (padded 2) (if (= p 1) 100 p) "%" nl))))
       (shift
        k
        (begin
          (display "Some long computation...")
          (k '(msg progress 0/100))
          (display "Still working...")
          (k '(msg progress 23/100))
          (display "Still more work...")
          (k '(msg progress 73/100))
          (display "Done.")
          (k '(msg progress 100/100))))))
     (get-output-string (current-output-port))))


  ;; An inversion of control pattern for effects. The caller providers interpreters, which could be
  ;; alternative implementations optimized for the use case, or stubs, or additional logging and
  ;; debugging, etc.
  ;;
  ;; Can add a kliesli composition operator >=>, so that (a -> m b) -> (b -> m c) -> (a -> m c),
  ;; where (m _) is (k `(effect-name ,arg)), and the full thing with the reset and continuation
  ;; handler is 'run-effect'.
  ;;
  ;; Can be used to provide inversion of control for libraries, allowing the library author to stick
  ;; to denotational semantics, while allowing the caller to describe the operational semantics and
  ;; decide which implementation of library functions and effects to import. Very useful for using
  ;; alternative implementations of algorithms or effects optimized for the use case.
  (test
   "effect interpreters"
   (string-append "...some dummy file contents...\n"
                  "Read file: /tmp/example.txt\n")
   (parameterize
       ((current-output-port
         (open-output-string)))
     (reset ((lambda (k)
               (match k
                 (`(read-file ,x)
                  (display "...some dummy file contents...")
                  (newline))
                 ((show args ...)
                  (display (apply string-append args))
                  (newline))))
             (shift
              k
              (let ((file "/tmp/example.txt"))
                (k `(read-file ,file))
                (k `(show "Read file: " ,file))))))
     (get-output-string (current-output-port))))


  (test
   "restarts"
   '(value: 5 msg: "Divide by zero: (/ 10 0), retrying...\n")
   (parameterize
       ((current-output-port
         (open-output-string)))
     (let ((result
            (reset
             ((lambda (k)
                (match k
                  (`(restart divide-by-zero ,n)
                   (show #t "Divide by zero: (/ " n " 0), retrying..." nl)
                   ;; User gets promted to try something else, passes in new args:
                   '(10 2))))
              (shift
               k
               (letrec ((div
                         ;; Example restartable div, calls the continuation
                         (lambda (args)
                           (guard
                               (condition
                                ;; Provide a retry for divide by zero
                                ((and (error-object? condition)
                                      (equal? "divide by zero"
                                              (error-object-message condition)))
                                 ;; Retry with new args passed in from k
                                 (div (k `(restart divide-by-zero ,(car args)))))
                                (else (raise condition)))
                             (/ (car args) (cadr args))))))
                 (div '(10 0))))))))
       (list 'value: result
             'msg: (get-output-string (current-output-port))))))

  (test
   "restart (replace value)"
   +inf.0
   (reset
    ((lambda (k)
       (match k
         (`(restart divide-by-zero ,n)
          (show #t "Divide by zero: (/ " n " 0), replacing value..." nl)
          ;; User gets promted to try something else, passes in replacement value:
          (if (> n 0) +inf.0 -inf.0))))
     (shift
      k
      (let ((div
             (lambda (n d)
               (guard
                   (condition
                    ;; Provide a retry for divide by zero
                    ((and (error-object? condition)
                          (equal? "divide by zero"
                                  (error-object-message condition)))
                     ;; Retry with new args passed in from k
                     (k `(restart divide-by-zero ,n)))
                    (else (raise condition)))
                 (/ n d)))))
        (div 10 0)))))))