suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

adjust DrRacket's online compilation to recognize exn:missing-module?

Browse Source 
exceptions and offer to install
This commit is contained in:
Robby Findler 2013-05-25 21:18:52 -05:00
parent b9b1eb14ba
commit 3474d09138
3 changed files with 73 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/drracket/private/expanding-place.rkt
View File

@ -7,6 +7,8 @@
syntax/readerr) syntax/readerr)
(provide start) (provide start)
(struct exn-info (str src-vecs exn-stack missing-mods) #:prefab)
(struct job (cust response-pc working-thd stop-watching-abnormal-termination)) (struct job (cust response-pc working-thd stop-watching-abnormal-termination))
;; key : any (used by equal? for comparision, but back in the main place) ;; key : any (used by equal? for comparision, but back in the main place)
@ -275,7 +277,7 @@
(define exn-infos (define exn-infos
(for/list ([an-exn (in-list (cons main-exn extra-exns))]) (for/list ([an-exn (in-list (cons main-exn extra-exns))])
(vector (exn-info
(trim-message (trim-message
(if (exn? an-exn) (if (exn? an-exn)
(regexp-replace* #rx"[ \t]*\n[ \t]*" (exn-message an-exn) " ") (regexp-replace* #rx"[ \t]*\n[ \t]*" (exn-message an-exn) " ")
@ -305,7 +307,9 @@
[(not name) (format-srcloc loc)] [(not name) (format-srcloc loc)]
[(not loc) (format "~a" name)] [(not loc) (format "~a" name)]
[else (format "~a:~a" (format-srcloc loc) name)]))) [else (format "~a:~a" (format-srcloc loc) name)])))
'())))) '())
(and (exn:missing-module? an-exn)
((exn:missing-module-accessor an-exn) an-exn)))))
(place-channel-put (place-channel-put
response-pc response-pc
(vector (vector

94
collects/drracket/private/module-language.rkt
View File

@ -25,7 +25,11 @@
"eval-helpers.rkt" "eval-helpers.rkt"
"local-member-names.rkt" "local-member-names.rkt"
"rectangle-intersect.rkt" "rectangle-intersect.rkt"
framework/private/logging-timer) pkg/lib
framework/private/logging-timer
(submod "frame.rkt" install-pkg))
(struct exn-info (str src-vecs exn-stack missing-mods) #:prefab)
;; submodule to make these accessible to the test suite ;; submodule to make these accessible to the test suite
(module oc-status-structs racket/base (module oc-status-structs racket/base
@ -995,7 +999,7 @@
(send (get-defs) set-margin-error-ranges (send (get-defs) set-margin-error-ranges
(set->list (set->list
(for*/set ([error-message+loc (in-list error-messages+locs)] (for*/set ([error-message+loc (in-list error-messages+locs)]
[range (in-list (vector-ref error-message+loc 1))]) [range (in-list (exn-info-src-vecs error-message+loc))])
(define pos (vector-ref range 0)) (define pos (vector-ref range 0))
(define span (vector-ref range 1)) (define span (vector-ref range 1))
(error-range (- pos 1) (+ pos span -1) #f))))] (error-range (- pos 1) (+ pos span -1) #f))))]
@ -1006,7 +1010,7 @@
(send (get-ints) set-error-ranges (send (get-ints) set-error-ranges
(set->list (set->list
(for*/set ([error-message+loc (in-list error-messages+locs)] (for*/set ([error-message+loc (in-list error-messages+locs)]
[range (in-list (vector-ref error-message+loc 1))]) [range (in-list (exn-info-src-vecs error-message+loc))])
(define pos (vector-ref range 0)) (define pos (vector-ref range 0))
(define span (vector-ref range 1)) (define span (vector-ref range 1))
(srcloc (get-defs) #f #f pos span)))))) (srcloc (get-defs) #f #f pos span))))))
@ -1019,24 +1023,26 @@
[(and (dirty? running-status) our-turn?) [(and (dirty? running-status) our-turn?)
(set-bottom-bar-status/pending)] (set-bottom-bar-status/pending)]
[(and (dirty? running-status) (not our-turn?)) [(and (dirty? running-status) (not our-turn?))
(send (get-defs) set-bottom-bar-status (list (vector "" '() '())) #f #f)] (send (get-defs) set-bottom-bar-status (list (exn-info "" '() '() #f)) #f #f)]
[(clean? running-status) [(clean? running-status)
(if (clean-error-messages+locs running-status) (if (clean-error-messages+locs running-status)
(send (get-defs) set-bottom-bar-status (send (get-defs) set-bottom-bar-status
(clean-error-messages+locs running-status) (clean-error-messages+locs running-status)
#t #t) #t #t)
(send (get-defs) set-bottom-bar-status (send (get-defs) set-bottom-bar-status
(list (vector (string-constant online-expansion-finished) (list (exn-info (string-constant online-expansion-finished)
'() '()
'())) '()
#f))
#f #f
#f))])) #f))]))
(define/private (set-bottom-bar-status/pending) (define/private (set-bottom-bar-status/pending)
(send (get-defs) set-bottom-bar-status (send (get-defs) set-bottom-bar-status
(list (vector (string-constant online-expansion-pending) (list (exn-info (string-constant online-expansion-pending)
'() '()
'())) '()
#f))
#f #f
#f)) #f))
@ -1072,7 +1078,7 @@
[(clean? running-status) [(clean? running-status)
(if (clean-error-messages+locs running-status) (if (clean-error-messages+locs running-status)
(for/list ([pr (clean-error-messages+locs running-status)]) (for/list ([pr (clean-error-messages+locs running-status)])
(vector-ref pr 0)) (exn-info-str pr))
(list sc-finished-successfully))])) (list sc-finished-successfully))]))
(define bkg-colors '()) (define bkg-colors '())
@ -1152,8 +1158,8 @@
(update-frame-expand-error)) (update-frame-expand-error))
(define/public (set-bottom-bar-status new-error/status-message-strs+srclocs message-err? force-visible?) (define/public (set-bottom-bar-status new-error/status-message-strs+srclocs message-err? force-visible?)
(define new-error/status-message-str (vector-ref (car new-error/status-message-strs+srclocs) 0)) (define new-error/status-message-str (exn-info-str (car new-error/status-message-strs+srclocs)))
(define srclocs (vector-ref (car new-error/status-message-strs+srclocs) 1)) (define srclocs (exn-info-src-vecs (car new-error/status-message-strs+srclocs)))
(unless (string? new-error/status-message-str) (unless (string? new-error/status-message-str)
(error 'set-bottom-bar-status "expected a string, got ~s" new-error/status-message-str)) (error 'set-bottom-bar-status "expected a string, got ~s" new-error/status-message-str))
(when (or (not (and (equal? error/status-message-strs+srclocs new-error/status-message-strs+srclocs) (when (or (not (and (equal? error/status-message-strs+srclocs new-error/status-message-strs+srclocs)
@ -1173,7 +1179,7 @@
(define/public (update-frame-expand-error) (define/public (update-frame-expand-error)
(when (eq? (get-tab) (send (send (get-tab) get-frame) get-current-tab)) (when (eq? (get-tab) (send (send (get-tab) get-frame) get-current-tab))
(define (matching-srcloc error/status-message-str+srcloc) (define (matching-srcloc error/status-message-str+srcloc)
(for/or ([pos+span-vec (vector-ref error/status-message-str+srcloc 1)]) (for/or ([pos+span-vec (exn-info-src-vecs error/status-message-str+srcloc 1)])
(define pos (vector-ref pos+span-vec 0)) (define pos (vector-ref pos+span-vec 0))
(define span (vector-ref pos+span-vec 1)) (define span (vector-ref pos+span-vec 1))
(and (equal? (send (get-tab) get-defs) (and (equal? (send (get-tab) get-defs)
@ -1187,12 +1193,19 @@
[bottom-bar-most-recent-jumped-to-loc [bottom-bar-most-recent-jumped-to-loc
(for/list ([error/status-message-str+srcloc (in-list error/status-message-strs+srclocs)] (for/list ([error/status-message-str+srcloc (in-list error/status-message-strs+srclocs)]
#:when (matching-srcloc error/status-message-str+srcloc)) #:when (matching-srcloc error/status-message-str+srcloc))
(vector-ref error/status-message-str+srcloc 0))] (exn-info-str error/status-message-str+srcloc 0))]
[else [else
(list (vector-ref (list-ref error/status-message-strs+srclocs error/status-index) 0))])) (list (exn-info-str (list-ref error/status-message-strs+srclocs error/status-index)))]))
(define install-suggestions
(apply
append
(for/list ([error/status-message-str+srcloc (in-list error/status-message-strs+srclocs)]
#:when (exn-info-missing-mods error/status-message-str+srcloc))
(pkg-catalog-suggestions-for-module
(exn-info-missing-mods error/status-message-str+srcloc)))))
(define (combine-msg vec) (define (combine-msg vec)
(define msg (vector-ref vec 0)) (define msg (exn-info-str vec))
(define stack (vector-ref vec 2)) (define stack (exn-info-src-vecs vec))
(apply (apply
string-append string-append
(cons (cons
@ -1215,16 +1228,17 @@
(cond (cond
[(null? error/status-message-strs+srclocs) 0] [(null? error/status-message-strs+srclocs) 0]
[(null? (cdr error/status-message-strs+srclocs)) [(null? (cdr error/status-message-strs+srclocs))
(length (vector-ref (car error/status-message-strs+srclocs) 1))] (length (exn-info-src-vecs (car error/status-message-strs+srclocs)))]
[else [else
(for/sum ([error/status-message-str+srcloc (in-list error/status-message-strs+srclocs)]) (for/sum ([error/status-message-str+srcloc (in-list error/status-message-strs+srclocs)])
(max 1 (length (vector-ref error/status-message-str+srcloc 1))))])))) (max 1 (length (exn-info-src-vecs error/status-message-str+srcloc))))])
install-suggestions)))
(define/public (hide-module-language-error-panel) (define/public (hide-module-language-error-panel)
(set! error/status-message-hidden? #t) (set! error/status-message-hidden? #t)
(update-frame-expand-error)) (update-frame-expand-error))
(define/public (expand-error-next) (define/public (expand-error-next)
(define current-srclocs (vector-ref (list-ref error/status-message-strs+srclocs error/status-index) 1)) (define current-srclocs (exn-info-src-vecs (list-ref error/status-message-strs+srclocs error/status-index)))
(define candidates (filter (λ (error-message-srcloc) (define candidates (filter (λ (error-message-srcloc)
(> (- (vector-ref error-message-srcloc 0) 1) (> (- (vector-ref error-message-srcloc 0) 1)
(get-end-position))) (get-end-position)))
@ -1238,7 +1252,7 @@
(jump-to (car candidates))])) (jump-to (car candidates))]))
(define/public (expand-error-prev) (define/public (expand-error-prev)
(define current-srclocs (vector-ref (list-ref error/status-message-strs+srclocs error/status-index) 1)) (define current-srclocs (exn-info-src-vecs (list-ref error/status-message-strs+srclocs error/status-index)))
(define candidates (filter (λ (error-message-srcloc) (define candidates (filter (λ (error-message-srcloc)
(< (+ (vector-ref error-message-srcloc 0) (< (+ (vector-ref error-message-srcloc 0)
(vector-ref error-message-srcloc 1) (vector-ref error-message-srcloc 1)
@ -1255,7 +1269,7 @@
(define/private (jump-to-new-index new-error/status-index which) (define/private (jump-to-new-index new-error/status-index which)
(set! error/status-index new-error/status-index) (set! error/status-index new-error/status-index)
(define current-srclocs (vector-ref (list-ref error/status-message-strs+srclocs error/status-index) 1)) (define current-srclocs (exn-info-src-vecs (list-ref error/status-message-strs+srclocs error/status-index)))
(unless (null? current-srclocs) (jump-to (which current-srclocs))) (unless (null? current-srclocs) (jump-to (which current-srclocs)))
(update-frame-expand-error)) (update-frame-expand-error))
@ -1470,6 +1484,7 @@
(define expand-error-panel #f) (define expand-error-panel #f)
(define expand-error-message #f) (define expand-error-message #f)
(define expand-error-button-parent-panel #f) (define expand-error-button-parent-panel #f)
(define expand-error-install-suggestions-panel #f)
(define expand-error-single-child #f) (define expand-error-single-child #f)
(define expand-error-multiple-child #f) (define expand-error-multiple-child #f)
(define expand-error-zero-child #f) (define expand-error-zero-child #f)
@ -1500,6 +1515,11 @@
[stretchable-width #f] [stretchable-width #f]
[stretchable-height #f] [stretchable-height #f]
[parent expand-error-panel])) [parent expand-error-panel]))
(set! expand-error-install-suggestions-panel
(new horizontal-panel%
[stretchable-width #f]
[stretchable-height #f]
[parent expand-error-panel]))
(set! expand-error-single-child (set! expand-error-single-child
(new button% (new button%
[parent expand-error-button-parent-panel] [parent expand-error-button-parent-panel]
@ -1550,8 +1570,9 @@
(define expand-error-msg-is-err? #f) (define expand-error-msg-is-err? #f)
(define expand-error-srcloc-count 0) (define expand-error-srcloc-count 0)
(define expand-error-hidden? #f) (define expand-error-hidden? #f)
(define expand-error-install-suggestions '())
(define/public (set-expand-error/status hidden? msgs msgs+stacks err? srcloc-count) (define/public (set-expand-error/status hidden? msgs msgs+stacks err? srcloc-count install-suggestions)
(unless (and (equal? expand-error-hidden? hidden?) (unless (and (equal? expand-error-hidden? hidden?)
(equal? expand-error-msgs msgs) (equal? expand-error-msgs msgs)
(equal? expand-error-msgs+stack msgs+stacks) (equal? expand-error-msgs+stack msgs+stacks)
@ -1562,6 +1583,7 @@
(set! expand-error-msgs+stack msgs+stacks) (set! expand-error-msgs+stack msgs+stacks)
(set! expand-error-msg-is-err? err?) (set! expand-error-msg-is-err? err?)
(set! expand-error-srcloc-count srcloc-count) (set! expand-error-srcloc-count srcloc-count)
(set! expand-error-install-suggestions install-suggestions)
(when expand-error-message (when expand-error-message
(send expand-error-parent-panel change-children (send expand-error-parent-panel change-children
(λ (l) (if hidden? (λ (l) (if hidden?
@ -1572,6 +1594,21 @@
l l
(append l (list expand-error-panel)))))) (append l (list expand-error-panel))))))
(send expand-error-message set-msgs expand-error-msgs expand-error-msg-is-err? expand-error-msgs+stack) (send expand-error-message set-msgs expand-error-msgs expand-error-msg-is-err? expand-error-msgs+stack)
(send expand-error-install-suggestions-panel change-children (λ (l) '()))
(for ([suggestion-pkg (in-list expand-error-install-suggestions)])
(new button%
[parent expand-error-install-suggestions-panel]
[callback
(λ (_1 _2)
(install-pkg
(send expand-error-install-suggestions-panel get-top-level-window)
(lambda (thunk)
(parameterize ([error-display-handler drracket:init:original-error-display-handler])
(thunk)))
#:package-to-offer suggestion-pkg))]
[font small-control-font]
[label (format (string-constant install-package-button)
suggestion-pkg)]))
(send expand-error-button-parent-panel change-children (send expand-error-button-parent-panel change-children
(λ (l) (λ (l)
(list (cond (list (cond
@ -2041,9 +2078,10 @@
(line-of-interest) (line-of-interest)
(send dirty/pending-tab set-oc-status (send dirty/pending-tab set-oc-status
(clean 'exn (clean 'exn
(list (vector sc-only-raw-text-files-supported (list (exn-info sc-only-raw-text-files-supported
(list (vector (+ filename/loc 1) 1)) (list (vector (+ filename/loc 1) 1))
'())))) '()
#f))))
(oc-maybe-start-something)]))) (oc-maybe-start-something)])))
(define/oc-log (oc-finished res) (define/oc-log (oc-finished res)
@ -2071,7 +2109,7 @@
(send running-tab set-oc-status (send running-tab set-oc-status
(clean (vector-ref res 0) (clean (vector-ref res 0)
(if (eq? (vector-ref res 0) 'abnormal-termination) (if (eq? (vector-ref res 0) 'abnormal-termination)
(list (vector sc-abnormal-termination '() '())) (list (exn-info sc-abnormal-termination '() '() #f))
(vector-ref res 1)))) (vector-ref res 1))))
(send running-tab set-dep-paths (list->set (vector-ref res 2)) #t)]) (send running-tab set-dep-paths (list->set (vector-ref res 2)) #t)])
(oc-maybe-start-something))) (oc-maybe-start-something)))

1
collects/string-constants/private/english-string-constants.rkt
View File

@ -274,6 +274,7 @@ please adhere to these guidelines:
(running "running") (running "running")
(not-running "not running") (not-running "not running")
(install-package-button "Install ~a") ;; button label: ~a is filled with the name of a pkg
;;; misc ;;; misc
(welcome-to-something "Welcome to ~a") (welcome-to-something "Welcome to ~a")