; Author: Juergen Lorenz
; ju (at) jugilo (dot) de
;
; Copyright (c) 2013-2019, Juergen Lorenz
; All rights reserved.
; 
; Redistribution and use in source and binary forms, with or without
; modification, are permitted provided that the following conditions are
; met:
; 
; Redistributions of source code must retain the above copyright
; notice, this list of conditions and the following disclaimer.
; 
; Redistributions in binary form must reproduce the above copyright
; notice, this list of conditions and the following disclaimer in the
; documentation and/or other materials provided with the distribution.
; 
; Neither the name of the author nor the names of its contributors may be
; used to endorse or promote products derived from this software without
; specific prior written permission. 
; 
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
; HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
; 
; Last update: Jun 14, 2019
;
;;; simplifying Marc Feeley's continuation interface with some additions,
;;; i.a. by  Matt Might

(module continuations (
  continuations
  call
  capture
  catch
  continuation
  continuation?
  continuation->procedure
  ;current
  escape-procedure
  escape-procedure?
  goto
  graft
  throw
  )

  (import scheme
          (only (chicken base)
                define-values
                case-lambda
                print
                gensym)
          (rename (only (chicken continuation)
                        continuation-capture
                        continuation-graft
                        continuation-return
                        continuation?)
                  (continuation-capture capture)
                  (continuation-graft graft)
                  (continuation-return throw))
          (only (chicken memory representation)
                extend-procedure
                procedure-data
                extended-procedure?))

(define-syntax catch
  (syntax-rules ()
    ((_ cont xpr . xprs)
     (capture (lambda (cont) xpr . xprs)))))

(define (continuation->procedure cont)
  (lambda vals (apply throw cont vals)))

(define (call receiver)
  (capture (lambda (cc)
             (receiver (continuation->procedure cc)))))

;(define (current)
;  (capture (lambda (cc) (throw cc cc))))

(define (continuation)
  (capture (lambda (cc) (throw cc cc))))

(define (goto cc) (throw cc cc))

;;; Matt Wright's functional interface
(define-values (escape-procedure escape-procedure?)
  (let ((type (gensym 'escape-procedure)))
    (values
      (lambda ()
        (call-with-current-continuation
          (lambda (cc)
                   (cc (extend-procedure cc type)))))
      (lambda (xpr)
        (and (extended-procedure? xpr)
             (eq? (procedure-data xpr) type)))
      )))

(define continuations
  (let ((alist '(
          (continuations
            procedure:
            (continuations sym ..)
            "documentation procedure")
          (catch
            macro:
            (catch cc xpr ....)
            "catches cc as a continuation"
            "and evaluates xpr .... in this context")
          (capture
            procedure:
            (capture receiver)
             "alias for continuation-capture")
          (continuation
            procedure:
            (continuation)
            "captures the current continuation as a continuation")
          (continuation?
            procedure:
            (continuation xpr)
            "tests if xpr is a continuation")
          (continuation->procedure
            procedure:
            (continuation->procedure cc)
            "transforms a continuation into a procedure")
          (call
            procedure:
            (call receiver)
            "the same as call/cc, but implemented via capture")
          (graft
            procedure:
            (graft cc thunk)
            "alias for continuation-graft")
          (goto
            procedure:
            (goto cc)
            "jumps to the continuation cc")
          (throw
            procedure:
            (throw cc val ...)
            "alias for continuation-return")
          (escape-procedure
            procedure:
            (escape-procedure)
            "captures the current continuation as an escape procedure")
          (escape-procedure?
            procedure:
            (escape-procedure? xpr)
            "checks if xpr is an escape procedure")
          )))
    (case-lambda
      (() (map car alist))
      ((sym)
       (let ((result (assq sym alist)))
         (if result
           (for-each print result)
           (begin
             (print "choose one of "
                    (map car alist)))))))))

) ; end continuations