emacs.d/elpa/racket-mode-20200402.1703/racket/error.rkt

#lang at-exp racket/base

(require (only-in pkg/db get-catalogs)
         (only-in pkg/lib pkg-catalog-suggestions-for-module)
         racket/format
         racket/match
         (only-in racket/path path-only)
         racket/runtime-path
         racket/string
         setup/collects
         setup/dirs
         "fresh-line.rkt"
         "instrument.rkt"
         "util.rkt")

(provide display-exn
         our-error-display-handler
         show-full-path-in-errors)

(module+ test
  (require rackunit))

(define (display-exn exn)
  (our-error-display-handler (exn-message exn) exn))

(define (our-error-display-handler str v)
  (cond [(exn? v)
         (unless (equal? "Check failure" (exn-message v)) ;rackunit check fails
           (fresh-line)
           (display-commented (fully-qualify-error-path str))
           (display-srclocs v)
           (unless (exn:fail:user? v)
             (display-context v))
           (maybe-suggest-packages v))]
        [else
         (fresh-line)
         (display-commented str)]))

(define (display-srclocs exn)
  (when (exn:srclocs? exn)
    (define srclocs
      (match ((exn:srclocs-accessor exn) exn)
        ;; Some exceptions like exn:fail:read? include the first
        ;; srcloc in exn-message -- don't show it again.
        [(cons _ xs)
         #:when (or (exn:fail:read? exn)
                    (exn:fail:contract:variable? exn))
         xs]
        ;; Some exceptions like exn:fail:syntax? with Typed Racket
        ;; include _all_ in exn-message -- don't show _any_.
        [_
         #:when (exn:fail:syntax? exn)
         '()]
        [xs xs]))
    (for ([s (in-list srclocs)])
      (display-commented (source-location->string s)))))

(define (display-context exn)
  (cond [(instrumenting-enabled)
         (define p (open-output-string))
         (print-error-trace p exn)
         (match (get-output-string p)
           ["" (void)]
           [s  (display-commented (string-append "Context (errortrace):"
                                                 ;; et prepends a \n
                                                 s))])]
        [else
         (match (context->string
                 (continuation-mark-set->context (exn-continuation-marks exn)))
           ["" (void)]
           [s (display-commented (string-append "Context:\n"
                                                s))])]))

(define (context->string xs)
  ;; Limit the context in two ways:
  ;; 1. Don't go beyond error-print-context-length
  ;; 2. Don't go into "system" context that's just noisy.
  (string-join (for/list ([x xs]
                          [_ (error-print-context-length)]
                          #:unless (system-context? x))
                 (context-item->string x))
               "\n"))

(define-runtime-path here "error.rkt")
(define (system-context? ci)
  (match-define (cons id src) ci)
  (or (not src)
      (let ([src (srcloc-source src)])
        (and (path? src)
             (or (equal? (path-only src) (path-only here))
                 (under-system-path? src))))))

(define (under-system-path? path)
  (match (path->collects-relative path)
    [`(collects #"mred" . ,_) #t]
    [`(collects #"racket" #"contract" . ,_) #t]
    [`(collects #"racket" #"private" . ,_) #t]
    [`(collects #"typed-racket" . ,_) #t]
    [_ #f]))

(define (context-item->string ci)
  (match-define (cons id src) ci)
  (string-append (if (or src id) " " "")
                 (if src (source-location->string src) "")
                 (if (and src id) " " "")
                 (if id (format "~a" id) "")))

;; Don't use source-location->string from syntax/srcloc. Don't want
;; the setup/path-to-relative behavior that replaces full pathnames
;; with <collects>, <pkgs> etc. Instead want full pathnames for Emacs'
;; compilation-mode. HOWEVER note that <collects> or <pkgs> might be
;; baked into exn-message string already; we handle that in
;; `fully-qualify-error-path`. Here we handle only strings we create
;; ourselves, such as for the Context "stack trace".
(define (source-location->string x)
  (define src
    ;; Although I want to find/fix this properly upstream -- is
    ;; something a path-string? when it should be a path? -- for now
    ;; just catch here the case where the source is a string like
    ;; "\"/path/to/file.rkt\"" i.e. in quotes.
    (match (srcloc-source x)
      [(pregexp "^\"(.+)\"$" (list _ unquoted)) unquoted]
      [v v]))
  (define line (or (srcloc-line x) "1"))
  (define col  (or (srcloc-column x) "1"))
  (format "~a:~a:~a" src line col))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Fully qualified pathnames in error messages, so that Emacs
;; compilation-mode can do its stuff.

;; srcloc->string uses current-directory-for-user to shorten error
;; messages. But we always want full pathnames. Setting it to
;; 'pref-dir -- very unlikely user .rkt file will be there -- is
;; least-worst way AFAIK.
(define (show-full-path-in-errors)
  (current-directory-for-user (find-system-path 'pref-dir)))

;; If this looks like a Racket error message, but the filename is
;; not fully-qualified, prepend curdir to the filename.
;;
;; This covers Racket 5.3.6 and earlier. In fact, this might be
;; sufficient for _all_ versions of Racket and we don't need the
;; `show-full-path-in-errors` thing above, at all. Not yet sure.
(define (fully-qualify-error-path s)
  (match s
    [(pregexp "^([^:]+):(\\d+)[:.](\\d+)(.*)$"
              (list _ path line col more))
     #:when (not (absolute-path? path))
     (string-append
      (string-join (list (path->string (build-path (current-directory) path))
                         line
                         col)
                   ":")
      more)]
    [s s]))

(module+ test
  (require rackunit)
  (case (system-type 'os)
    [(windows)
     (check-equal?
      (parameterize ([current-directory "c:\\tmp"])
        (fully-qualify-error-path "foo.rkt:3:0: f: unbound identifier\n   in: f"))
      "c:\\tmp\\foo.rkt:3:0: f: unbound identifier\n   in: f")
     (check-equal?
      (fully-qualify-error-path "c:\\tmp\\foo.rkt:3:0: f: unbound identifier\n   in: f")
      "c:\\tmp\\foo.rkt:3:0: f: unbound identifier\n   in: f")]
    [(macosx unix)
     (check-equal?
      (parameterize ([current-directory "/tmp/"])
        (fully-qualify-error-path "foo.rkt:3:0: f: unbound identifier\n   in: f"))
      "/tmp/foo.rkt:3:0: f: unbound identifier\n   in: f")
     (check-equal?
      (fully-qualify-error-path "/tmp/foo.rkt:3:0: f: unbound identifier\n   in: f")
      "/tmp/foo.rkt:3:0: f: unbound identifier\n   in: f")])
  (let ([o (open-output-string)])
    (parameterize ([current-error-port o])
      (display-srclocs (make-exn:fail:read "..."
                                           (current-continuation-marks)
                                           '())))
    (check-equal? (get-output-string o) "")))

(define (maybe-suggest-packages exn)
  (when (exn:missing-module? exn)
    (match (get-catalogs)
      [(list)
       (display-commented
        @~a{-----
            Can't suggest packages to install, because pkg/db get-catalogs is '().
            To configure:
            1. Start DrRacket.
            2. Choose "File | Package Manager".
            3. Click "Available from Catalog".
            4. When prompted, click "Update".
            -----})]
      [_
       (define mod ((exn:missing-module-accessor exn) exn))
       (match (pkg-catalog-suggestions-for-module mod)
         [(list) void]
         [(list p)
          (display-commented
           @~a{Try "raco pkg install @|p|" ?})]
         [(? list? ps)
          (display-commented
           @~a{Try "raco pkg install" one of @(string-join ps ", ") ?})]
         [_ void])])))