;;;; futures.scm

(module futures

(;export
  ;
  (future make-future)
  ;
  future?
  future-complete? future-failed?
  future-condition
  ;
  force/future)

(import scheme)
(import (chicken base))
(import (chicken type))
(import (chicken condition))
(import (srfi 18))

(define-type thunk (-> . *))
(define-type promise (struct promise))

(define-type future (struct <future>))

(: make-future (thunk -> future))
(: future? (* -> boolean : future))
(: future-failed? (future -> boolean))
(: future-complete? (future -> boolean))
(: future-condition (future -> *))

(: force/future (* -> . *))

;;

(: *make-future (list * boolean boolean (or false thread) -> future))
(: future-results (future -> list))
(: future-results-set! (future list -> void))
(: future-condition-set! (future * -> void))
(: future-failed?-set! (future true -> void))
(: future-complete?-set! (future true -> void))
(: future-thread (future -> (or false thread)))
(: future-thread-set! (future thread -> void))
;
(define-record-type <future>
  (*make-future res con fai com thr)
  future?
  (res future-results   future-results-set!)
  (con future-condition future-condition-set!)
  (fai future-failed?   future-failed?-set!)
  (com future-complete? future-complete?-set!)
  (thr future-thread    future-thread-set!) )

(define (make-future thunk)
  (assert (procedure? thunk)
          'make-future "bad argument type - not procedure" thunk)
  (let* ((f (*make-future '() #f #f #f #f))
         (t (make-thread
             (lambda ()
               (handle-exceptions ex
                 (begin
                   (future-condition-set! f ex)
                   (future-failed?-set! f #t) )
                 (future-results-set! f (receive (thunk))) )
               (future-complete?-set! f #t) ) ) ) )
    (future-thread-set! f t)
    (thread-start! t)
    f ) )

;;

(define-syntax future
  (syntax-rules ()
    ((_ ?expr0 ...) (make-future (lambda () ?expr0 ...)))))

;;

(define force/future
  (let ((top:force force))
    (lambda (f)
      (if (future? f)
          (let loop ()
            (cond ((future-failed? f)   (raise (future-condition f)))
                  ((future-complete? f) (apply values (future-results f)))
                  (else
                   (thread-join! (future-thread f))
                   (loop) ) ) )
          (top:force f) ) ) ) )

) ;module futures