(use srfi-18)

(declare
 (disable-interrupts) ;; alternative: use `hopefully` for the 'forcible' record

 (no-bound-checks)
 (no-procedure-checks)
 (local)
 (inline)
 (safe-globals)
 (specialize)
 (strict-types)

 )

(module
 forcible
 (
  eager
  (lazy make-lazy-promise)
  (delay make-delayed-promise)
  (future make-future-promise)
  (lazy-future make-lazy-future-promise)
  demand
  force
  fulfil!
  expectable
  )
 (import (except scheme force delay))
 (import (except chicken make-promise promise?))
 (import srfi-18)

(define-type :promise: (struct forcible))
(: promise-box (:promise: -> pair))
(: promise-box-set! (:promise: pair -> *))
(: promise? (* --> boolean : :promise:))
(define-record-type forcible
  (make-promise box)
  promise?
  (box promise-box promise-box-set!))

(: eager (&rest -> :promise:))
(define (eager . vals)
  (make-promise (cons 'eager vals)))

(define (make-lazy-promise thunk)
  (make-promise (cons (make-mutex) thunk)))

(define-syntax lazy
  (syntax-rules ()
    ((_ exp) (make-lazy-promise (lambda () exp)))))

(define (make-delayed-promise thunk)
  (lazy (call-with-values thunk eager)))

(define-syntax delay
  (syntax-rules ()
    ((_ exp) (make-delayed-promise (lambda () exp)))))

(define (make-future-promise thunk)
  (let ((thread (make-thread thunk 'future)))
    (thread-start! thread)
    (make-promise (cons thread thunk))))

(define-syntax future
  (syntax-rules ()
    ((_ exp) (make-future-promise (lambda () exp)))))

(define (make-lazy-future-promise thunk)
  (let ((thread (make-thread thunk 'future)))
    (make-promise (cons thread thunk))))

(define-syntax lazy-future
  (syntax-rules ()
    ((_ exp) (make-lazy-future-promise (lambda () exp)))))

(: demand (:promise: -> boolean))
(define (demand promise)
  (let ((key (car (promise-box promise))))
    (if (and (thread? key) (eq? (thread-state key) 'created))
	(begin
	  (thread-start! key)
	  #t)
	#f)))

(: fulfil!* (:promise: boolean list -> boolean))
(define (fulfil!* promise type args)
  (let* ((content (promise-box promise))
	 (key (car content)))
    (if (symbol? key) #f
	(begin
	  (set-cdr! content args)
	  (set-car! content (if type 'eager 'failed))
	  (cond
	   ((mutex? key) (mutex-unlock! key))
	   ;; TBD: handle futures too.
	   )
	  #t))))

(: fulfil! (:promise: boolean &rest -> boolean))
(define (fulfil! promise type . args) (fulfil!* promise type args))

(: expectable (or (&rest * (procedure (*) . *) -> (procedure (true &rest) boolean) :promise:)
		  (&rest * (procedure (*) . *) -> (procedure (false *) boolean) :promise:)))
(define (expectable . name+thunk)
  (let* ((mux (make-mutex (if (pair? name+thunk) (car name+thunk) 'expectation)))
	 (thunk (and (pair? name+thunk) (pair? (cdr name+thunk)) (cadr name+thunk)))
	 (promise (make-promise (cons mux thunk))))
    (or thunk (mutex-lock! mux #f #f))
    (values
     (lambda (kind . args) (fulfil!* promise kind args))
     promise)))

(: force1! (:promise: -> :promise:))
(define (force1! promise)
  (let* ((content (promise-box promise))
	 (key (car content)))
    (cond
     ((symbol? key) promise)
     ((mutex? key)
      (if (eq? (mutex-state key) (current-thread))
	  (let* ((promise* ((cdr content)))        
		 (content  (promise-box promise))) ; * 
	    (if (not (eq? (car content) 'eager))   ; *
		(let ((content* (promise-box promise*)))
		  (set-car! content (car content*))
		  (set-cdr! content (cdr content*))
		  (promise-box-set! promise* content)))
	    (mutex-unlock! key)
	    (force1! promise))
	  (begin
	    (mutex-lock! key)
	    (force1! promise))))
     ((thread? key)
      (if (eq? (thread-state key) 'created) (thread-start! key))
      (receive vals (thread-join! key)
	       (set-car! content 'eager)
	       (set-cdr! content vals)
	       (force1! promise)))
     (else (error "forcible: unknown promise kind" key)))))

(: force (* &optional (or (procedure (*) . *) false) -> . *))
(define (force obj . fail)
  (if (promise? obj)
      (let* ((fh (and (pair? fail) (car fail)))
	     (result
	      (cond
	       ;; Result already available.
	       ((symbol? (car (promise-box obj))) obj)
	       ;; Backward compatible case does not cache exceptions.
	       ((and (pair? fail) (not fh)) (force1! obj))
	       (else (handle-exceptions
		      ex
		      (let ((ex (if (uncaught-exception? ex)
				    (uncaught-exception-reason ex)
				    ex)))
			(promise-box-set! obj (list 'failed ex))
			obj)
		      (force1! obj)))))
	     (content (promise-box result)))
	(if (eq? (car content) 'eager)
	    (apply values (cdr content))
	    (let ((ex (cadr content)))
	      (if (procedure? fh) (fh ex) (raise ex)))))
      obj))

)