;;; -*- mode: scheme -*-

;;;;;; SRFI o: Restarting conditions
;;;;;; Reference implementation

;;; This code is written by Taylor Campbell and placed in the Public
;;; Domain.  All warranties are disclaimed.

(define-record-type restarter
  (make-restarter tag description invoker interactor)
  restarter?
  (tag restarter-tag)
  (description restarter-description)
  (invoker restarter-invoker)
  (interactor restarter-interactor))

(define (restart spec . args)
  (let ((win (lambda (r) (apply (restarter-invoker r) args))))
    (cond ((restarter? spec) (win spec))
          ((find-restarter spec) => win)
          (else (error "invalid restarter specifier argument"
                       `(RESTART ,spec ,@args))))))

(define (restart-interactively spec)
  (let ((win (lambda (r)
               (call-with-values (restarter-interactor r)
                                 (restarter-invoker r)))))
    (cond ((restarter? spec) (win spec))
          ((find-restarter spec) => win)
          (else (error "invalid restarter specifier argument"
                       `(RESTART-INTERACTIVELY ,spec))))))

(define current-restarters (make-parameter '()))

(define (with-restarter restarter thunk)
  (parameterize ((current-restarters
                  (cons restarter (current-restarters))))
    (thunk)))

(define (find-restarter tag)
  (let loop ((restarters (current-restarters)))
    (cond ((null? restarters) #f)
          ((eqv? (restarter-tag (car restarters)) tag)
           (car restarters))
          (else (loop (cdr restarters))))))

(define (call-with-restarter tag desc invoker receiver)
  (call-with-interactive-restarter tag desc invoker #f receiver))

(define (call-with-interactive-restarter tag desc invoker interactor
          receiver)
  (let ((r (make-restarter tag desc invoker interactor)))
    (with-restarter r (lambda () (receiver r)))))

(define (with-exiting-restarter tag desc thunk)
  (call-with-exiting-restarter tag desc (lambda (r) (thunk))))

(define (call-with-exiting-restarter tag desc receiver)
  (call-with-current-continuation
    (lambda (k)
      (call-with-interactive-restarter tag desc
          (lambda () (k))               ; invoker
          (lambda () (values))          ; interactor
        receiver))))



;;; SRFI 35 extension

(define-condition-type &restartable &condition
  restartable-condition?
  (restarters condition-restarters))

(define (make-restartable-condition restarters . components)
  (apply make-compound-condition
         (make-condition &restartable 'restarters restarters)
         components))

(define (find-restarter tag . condition)
  (let loop ((restarters
              (if (or (null? condition) (not (car condition)))
                  (current-restarters)
                  (condition-restarters (car condition)))))
    (cond ((null? restarters) #f)
          ((eqv? (restarter-tag (car restarters)) tag)
           (car restarters))
          (else (loop (cdr restarters))))))

(define-syntax restartable-condition
  (syntax-rules ()
    ((RESTARTABLE-CONDITION (restarter ...)
       (condition-type (field-tag value) ...)
       ...)
     (MAKE-RESTARTABLE-CONDITION
      (LIST (RESTARTER-CLAUSE restarter) ...)
      (CONDITION (condition-type (field-tag value) ...)
                 ...)))))

(define-syntax restarter-clause
  (syntax-rules ()
    ((RESTARTER-CLAUSE (expression))
     expression)
    ((RESTARTER-CLAUSE (tag desc invoker))
     (MAKE-RESTARTER tag desc invoker #F))
    ((RESTARTER-CLAUSE (tag desc invoker interactor))
     (MAKE-RESTARTER tag desc invoker interactor))))