;;; Guile Knots
;;; Copyright © 2020 Christopher Baines <mail@cbaines.net>
;;;
;;; This file is part of Guile Knots.
;;;
;;; The Guile Knots is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation; either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; The Guile Knots is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with the guix-data-service.  If not, see
;;; <http://www.gnu.org/licenses/>.

(define-module (knots promise)
  #:use-module (srfi srfi-9)
  #:use-module (ice-9 atomic)
  #:use-module (fibers)
  #:use-module (fibers conditions)
  #:export (fibers-delay
            fibers-force
            fibers-promise-reset))

(define-record-type <fibers-promise>
  (make-fibers-promise thunk values-box evaluated-condition)
  fibers-promise?
  (thunk                fibers-promise-thunk)
  (values-box           fibers-promise-values-box)
  (evaluated-condition  fibers-promise-evaluated-condition))

(define (fibers-delay thunk)
  (make-fibers-promise
   thunk
   (make-atomic-box #f)
   (make-condition)))

(define (fibers-force fp)
  (let ((res (atomic-box-compare-and-swap!
              (fibers-promise-values-box fp)
              #f
              'started)))
    (if (eq? #f res)
        (call-with-values
            (lambda ()
              (with-exception-handler
                  (lambda (exn)
                    (atomic-box-set! (fibers-promise-values-box fp)
                                     exn)
                    (signal-condition!
                     (fibers-promise-evaluated-condition fp))
                    (raise-exception exn))
                (fibers-promise-thunk fp)
                #:unwind? #t))
          (lambda vals
            (atomic-box-set! (fibers-promise-values-box fp)
                             vals)
            (signal-condition!
             (fibers-promise-evaluated-condition fp))
            (apply values vals)))
        (if (eq? res 'started)
            (begin
              (wait (fibers-promise-evaluated-condition fp))
              (let ((result (atomic-box-ref (fibers-promise-values-box fp))))
                (if (exception? result)
                    (raise-exception result)
                    (apply values result))))
            (if (exception? res)
                (raise-exception res)
                (apply values res))))))

(define (fibers-promise-reset fp)
  (atomic-box-set! (fibers-promise-values-box fp)
                   #f))