From 8e582a2d7346e5de4b31b19fc660213c69b43706 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Mon, 26 May 2025 14:45:58 +0100
Subject: [PATCH] Improve promise exception reporting

And guard against calling fibers-force not on a fibers promise record.
---
 knots/promise.scm | 86 +++++++++++++++++++++++++++++++----------------
 1 file changed, 57 insertions(+), 29 deletions(-)

diff --git a/knots/promise.scm b/knots/promise.scm
index 235640b..9df376b 100644
--- a/knots/promise.scm
+++ b/knots/promise.scm
@@ -19,10 +19,15 @@
 
 (define-module (knots promise)
   #:use-module (srfi srfi-9)
+  #:use-module (ice-9 match)
   #:use-module (ice-9 atomic)
+  #:use-module (ice-9 exceptions)
   #:use-module (fibers)
   #:use-module (fibers conditions)
-  #:export (fibers-delay
+  #:use-module (knots)
+  #:export (fibers-promise?
+
+            fibers-delay
             fibers-force
             fibers-promise-reset
             fibers-promise-result-available?))
@@ -41,38 +46,61 @@
    (make-condition)))
 
 (define (fibers-force fp)
+  (unless (fibers-promise? fp)
+    (raise-exception
+     (make-exception
+      (make-exception-with-message "fibers-force: not a fibers promise")
+      (make-exception-with-irritants 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))))))
+    (cond
+     ((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))
+              (lambda ()
+                (with-exception-handler
+                    (lambda (exn)
+                      (let ((stack
+                             (match (fluid-ref %stacks)
+                               ((stack-tag . prompt-tag)
+                                (make-stack #t
+                                            0 prompt-tag
+                                            0 (and prompt-tag 1)))
+                               (_
+                                (make-stack #t)))))
+                        (raise-exception
+                         (make-exception
+                          exn
+                          (make-knots-exception stack)))))
+                  (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))))
+      ((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)))))
+      (else
+       (if (exception? res)
+           (raise-exception res)
+           (apply values res))))))
 
 (define (fibers-promise-reset fp)
   (atomic-box-set! (fibers-promise-values-box fp)