From d3e7dc792069724880356c4e0f8c1749b90ef1bb Mon Sep 17 00:00:00 2001
From: jao <jao@gnu.org>
Date: Fri, 21 Oct 2022 03:42:16 +0100
Subject: collecting and displaying condition locations (file, column)

---
 src/geiser/geiser.ss | 47 +++++++++++++++++++++++++++--------------------
 1 file changed, 27 insertions(+), 20 deletions(-)

(limited to 'src/geiser/geiser.ss')

diff --git a/src/geiser/geiser.ss b/src/geiser/geiser.ss
index 0d3928c..f040413 100644
--- a/src/geiser/geiser.ss
+++ b/src/geiser/geiser.ss
@@ -37,6 +37,25 @@
                    (print-vector-length #t))
       (as-string (pretty-print x))))
 
+  (define (code-location obj)
+    (let* ((i (inspect/object obj))
+           (c (and i (i 'code))))
+      (if c
+          (let ((name `("name" . ,(or (c 'name) (write-to-string obj)))))
+            (call-with-values (lambda () (c 'source-path))
+              (case-lambda
+                ((path line col)
+                 `(,name ("file" . ,path) ("line" . ,line) ("column" . ,col)))
+                ((path char)
+                 `((,name) ("file" . ,path) ("char" . ,char)))
+                (() #f))))
+          #f)))
+
+  (define (condition-location c)
+    (let ((finder (make-object-finder procedure? c (collect-maximum-generation))))
+      (let loop ((obj (finder)))
+        (if obj (or (code-location (car obj)) (loop (finder))) '()))))
+
   (define (call-with-result thunk)
     (let ((output-string (open-output-string)))
       (write
@@ -45,11 +64,12 @@
           (with-exception-handler
               (lambda (e)
                 (debug-condition e) ; save the condition for the debugger
-                (k `((result "")
-                     (output . ,(get-output-string output-string))
-                     (debug 1)
-                     (error (key . condition)
-                            (msg . ,(as-string (display-condition e)))))))
+                (let ((loc (or (condition-location e) '()))
+                      (desc (as-string (display-condition e))))
+                  (k `((result "")
+                       (output . ,(get-output-string output-string))
+                       (error (key . condition)
+                              (msg . ,(cons desc loc)))))))
             (lambda ()
               (call-with-values
                   (lambda ()
@@ -242,21 +262,8 @@
           (else (map id-autodoc ids))))
 
   (define (geiser:symbol-location id)
-    (let* ([b (try-eval id)]
-           [c (and (not (eq? not-found b))
-                   ((inspect/object b) 'code))])
-      (if c
-          (call-with-values (lambda () (c 'source-path))
-            (lambda (path line . col)
-              (let ((line (if (null? col) '() line))
-                    (char (if (null? col) line '()))
-                    (col (if (null? col) '() (car col))))
-                `(("name" . ,(c 'name))
-                  ("file" . ,path)
-                  ("line" . ,line)
-                  ("column" . ,col)
-                  ("char" . ,char)))))
-          '())))
+    (let ([b (try-eval id)])
+      (or (and (not (eq? not-found b)) (code-location b)) '())))
 
   (define (geiser:module-location id)
     (let ((obj (library-object-filename id)))
-- 
cgit v1.2.3