haskal
/
crossfire
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

reimplement error-display-handler without wrapping

This commit is contained in:
xenia 2020-11-23 04:33:11 -05:00
parent 849d3a230b
commit d0784e54cd
2 changed files with 19 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
crossfire/comms.rkt
View File

@ -382,7 +382,7 @@
(match data
[(? exn?)
(define-values (ty _) (struct-info data))
(define-values (name _2 _3 _4 _5 _6 _7 _8) (struct-type-info name))
(define-values (name _2 _3 _4 _5 _6 _7 _8) (struct-type-info ty))
`('exn ,name ,(exn-message data))]
[x x]))

30
crossfire/logging.rkt
View File

@ -16,7 +16,7 @@
;; You should have received a copy of the GNU Affero General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
(require racket/bool racket/date racket/match racket/string)
(require racket/bool racket/date racket/format racket/match racket/string)
(provide global-logger install-logging!)
@ -94,20 +94,26 @@
(current-logger global-logger)
;; make uncaught exceptions go through the log
;; this uses the same (tbh, disgusting) trick as xrepl
;; ideally backtraces wouldn't be magic implemented in C using private continuation marks that
;; aren't accessible to the program (in BC) but whatever
;; perhaps it's better in CS
(define original-handler (error-display-handler))
;; install (approximate) stack trace printer
(error-display-handler
(lambda (msg ex)
(define os (open-output-string))
(parameterize ([current-error-port os])
(original-handler msg ex))
(define exn-type
(if (exn? ex)
(let*-values ([(ty _) (struct-info ex)]
[(name _2 _3 _4 _5 _6 _7 _8) (struct-type-info ty)])
(symbol->string name))
(~a ex)))
(define msg-str (~a msg))
(define stack-trace
(if (exn? ex)
(for/list ([ctx (in-list (continuation-mark-set->context (exn-continuation-marks ex)))])
(match (cdr ctx)
[#f (format " at ~a (<unknown source>)\n" (car ctx))]
[(srcloc source line column position span)
(format " at ~a (~a:~a:~a)\n" (or (car ctx) "<unknown>") source line column)]))
'("<unknown stack trace>")))
(log-message global-logger 'fatal
(format "uncaught exception: ~a" (get-output-string os))
(current-continuation-marks))))
(apply string-append exn-type ": " msg-str "\n" stack-trace))))
;; install plumber flush to stop and flush the log printer thread
(define (flush _)