collecting and displaying condition locations (file, column)

2 files changed, 40 insertions, 28 deletions

diff --git a/geiser-chez.el b/geiser-chez.el
index ef9f29a..9491a65 100644
--- a/geiser-chez.el
+++ b/geiser-chez.el
@@ -65,10 +65,6 @@ host."
 (define-obsolete-variable-alias 'geiser-chez-debug-on-exception-p
   'geiser-chez-debug-on-exception "0.18")
 
-(geiser-custom--defcustom geiser-chez-show-error-on-debug t
-  "Whether to issue a `show condition' command upon entering the debugger."
-  :type 'boolean)
-
 (defconst geiser-chez-minimum-version "9.4")
 
 ;;; REPL support
@@ -183,15 +179,24 @@ Return its local name."
     (geiser-repl-switch  nil 'chez)
     (compilation-forget-errors)
     (geiser-repl--send "(debug)")
-    (when geiser-chez-show-error-on-debug (geiser-repl--send "s"))
     t))
 
 (defun geiser-chez--display-error (_module key msg)
   "Display an error found during evaluation with the given KEY and message MSG."
-  (when (stringp msg)
-    (save-excursion (insert msg))
+  (when msg
+    (save-excursion
+      (insert (car msg))
+      (when-let (loc (cdr msg))
+        (let ((file (cdr (assoc "file" loc)))
+              (line (or (cdr (assoc "line" loc)) ""))
+              (col (or (cdr (assoc "column" loc)) (cdr (assoc "char" loc))))
+              (name (cdr (assoc "name" loc))))
+          (insert "\n\n" file (format ":%s" line))
+          (when col (insert (format ":%s" col)))
+          (when name (insert (format "   (%s)" name))))
+        (insert "\n")))
     (geiser-edit--buttonize-files)
-    (not (zerop (length msg)))))
+    t))
 
 ;;; Keywords and syntax
 
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)))