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

adjust DrRacket to offer installation of packages

Browse Source 
based on exn:missing-module?
This commit is contained in:
Robby Findler 2013-05-25 17:07:03 -05:00
parent 01a88f8db1
commit b929b73590
4 changed files with 107 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

121
collects/drracket/private/debug.rkt
View File

@ -27,8 +27,10 @@ profile todo:
racket/match
mrlib/include-bitmap
images/compile-time
pkg/lib
(for-syntax images/icons/misc images/icons/style images/icons/control images/logos)
(for-syntax racket/base))
(for-syntax racket/base)
(submod "frame.rkt" install-pkg))
(define orig (current-output-port))
(define (oprintf . args) (apply fprintf orig args))
@ -102,16 +104,17 @@ profile todo:
(define/public (set-callback cb) (set! callback cb))
(define/public (get-callback) callback)
(define in-bounds? #f)
(define grabbed? #f)
(define in-bounds? #f)
(define (set-clicked new-grabbed? new-in-bounds? dc)
(let ([needs-invalidate? (not (eq? (and grabbed? in-bounds?)
(and new-grabbed? new-in-bounds?)))])
(set! grabbed? new-grabbed?)
(set! in-bounds? new-in-bounds?)
(when needs-invalidate?
(invalidate dc))))
(define needs-invalidate?
(or (not (equal? grabbed? new-grabbed?))
(not (equal? new-in-bounds? in-bounds?))))
(set! grabbed? new-grabbed?)
(set! in-bounds? new-in-bounds?)
(when needs-invalidate?
(invalidate dc)))
(define/override (draw dc x y left top right bottom dx dy draw-caret)
(super draw dc x y left top right bottom dx dy draw-caret)
@ -126,21 +129,21 @@ profile todo:
(send dc set-brush brush)))))
(define/override (on-event dc x y editorx editory evt)
(let-values ([(w h) (get-w/h dc)])
(let ([in-bounds? (and (<= (- (send evt get-x) x) w)
(<= (- (send evt get-y) y) h))])
(cond
[(send evt button-down? 'left)
(set-clicked #t in-bounds? dc)]
[(send evt button-up? 'left)
(let ([admin (send this get-admin)])
(when admin
(send (send admin get-editor) set-caret-owner #f 'global)))
(when (and grabbed? in-bounds?)
(callback))
(set-clicked #f in-bounds? dc)]
[else
(set-clicked grabbed? in-bounds? dc)]))))
(define-values (w h) (get-w/h dc))
(define in-bounds? (and (<= (- (send evt get-x) x) w)
(<= (- (send evt get-y) y) h)))
(cond
[(send evt button-down? 'left)
(set-clicked #t in-bounds? dc)]
[(send evt button-up? 'left)
(let ([admin (send this get-admin)])
(when admin
(send (send admin get-editor) set-caret-owner #f 'global)))
(when (and grabbed? in-bounds?)
(callback this))
(set-clicked #f in-bounds? dc)]
[else
(set-clicked grabbed? in-bounds? dc)]))
(define/private (invalidate dc)
(let ([admin (get-admin)])
@ -165,14 +168,38 @@ profile todo:
(define clickable-image-snip% (clickable-snip-mixin image-snip%))
(define clickable-string-snip%
(class (clickable-snip-mixin string-snip%)
(class (clickable-snip-mixin snip%)
(define/override (get-extent dc x y wb hb db sb lb rb)
(define-values (w h d a) (send dc get-text-extent str))
(set-box/f wb w)
(set-box/f hb h)
(set-box/f db d)
(set-box/f sb a)
(set-box/f lb 0)
(set-box/f rb 0))
(define/override (draw dc x y left top right bottom dx dy draw-caret)
(define font (send dc get-font))
(send dc set-font (send the-font-list find-or-create-font
(send font get-point-size)
(send font get-face)
(send font get-family)
(send font get-style)
(send font get-weight)
#t
(send font get-smoothing)
#f
(send font get-hinting)))
(send dc draw-text str x y)
(send dc set-font font))
(inherit get-callback set-callback)
(init-field str)
(define/override (copy)
(let ([n (new clickable-string-snip% [str str])])
(send n set-callback (get-callback))
n))
(super-make-object str)))
(super-new)))
(define (set-box/f b v) (when (box? b) (set-box! b v)))
;; make-note% : string -> (union class #f)
(define (make-note% filename bitmap)
@ -196,6 +223,14 @@ profile todo:
(define mf-note% (make-note% "mf.gif" (include-bitmap (lib "icons/mf.gif") 'gif)))
(define small-planet-bitmap (compiled-bitmap (planet-logo #:height (default-icon-height))))
(define planet-note% (make-note% "small-planet.png" small-planet-bitmap))
(define install-note%
(class clickable-image-snip%
(inherit get-callback)
(define/override (copy)
(let ([n (new install-note%)])
(send n set-callback (get-callback))
n))
(super-new)))
;; display-stats : (syntax -> syntax)
;; count the number of syntax expressions & number of with-continuation-marks in an
@ -316,6 +351,7 @@ profile todo:
(when (exn:fail:syntax? exn)
(unless (error-print-source-location)
(show-syntax-error-context (current-error-port) exn)))
(print-pkg-icon-to-stderr exn)
(newline (current-error-port))
(flush-output (current-error-port))
(when (and ints
@ -373,7 +409,7 @@ profile todo:
(when planet-note%
(when (port-writes-special? (current-error-port))
(let ([note (new planet-note%)])
(send note set-callback (λ ()
(send note set-callback (λ (snp)
;; =Kernel= =Handler=
(drracket:unit:forget-saved-bug-report table)
(send-url (url->string gp-url))))
@ -384,6 +420,7 @@ profile todo:
(write-special note (current-error-port))
(display #\space (current-error-port))))))))))
;; =Kernel= =User=
(define (bug-info->ticket-url table)
(make-url
@ -414,6 +451,34 @@ profile todo:
(cons 'description (exn->trace exn)))]
[else #f]))
;; =User=
(define (print-pkg-icon-to-stderr exn)
(when (exn:missing-module? exn)
(define mod ((exn:missing-module-accessor exn) exn))
(define pkgs (pkg-catalog-suggestions-for-module mod))
(unless (null? pkgs)
(display "\n" (current-error-port))
(display " packages that provide the missing module:" (current-error-port))
(for ([pkg (in-list pkgs)])
(eprintf "\n ~a" pkg)
(when (port-writes-special? (current-error-port))
(define note (new clickable-string-snip% [str "[install]"]))
(send note set-callback
(λ (snp)
;; =Kernel= =Handler=
(define admin (send snp get-admin))
(define canvas (and admin (send (send admin get-editor) get-canvas)))
(define tlw (and canvas (send canvas get-top-level-window)))
(install-pkg
tlw
(lambda (thunk)
(parameterize ([error-display-handler drracket:init:original-error-display-handler])
(thunk)))
#:package-to-offer pkg)))
(eprintf " ")
(write-special note (current-error-port)))))))
;; =User=
(define (exn->trace exn)
(let ([sp (open-output-string)])
@ -427,7 +492,7 @@ profile todo:
(let ([note% (if (mf-bday?) mf-note% bug-note%)])
(when note%
(let ([note (new note%)])
(send note set-callback (λ () (show-backtrace-window/edition-pairs/two msg cms1 editions1 cms2 editions2 defs ints)))
(send note set-callback (λ (snp) (show-backtrace-window/edition-pairs/two msg cms1 editions1 cms2 editions2 defs ints)))
(write-special note (current-error-port))
(display #\space (current-error-port)))))))
@ -447,7 +512,7 @@ profile todo:
(when (port-writes-special? (current-error-port))
(let ([note (new file-note%)])
(send note set-callback
(λ () (open-and-highlight-in-file srcs-to-display edition-pair)))
(λ (snp) (open-and-highlight-in-file srcs-to-display edition-pair)))
(write-special note (current-error-port))
(display #\space (current-error-port))))))]
[do-src

6
collects/drracket/private/frame.rkt
View File

@ -13,9 +13,11 @@
(send pkg-gui show #t)
(set! pkg-gui (make-pkg-gui #:wrap-terminal-action wrap-terminal-action))))
(define (install-pkg parent wrap-terminal-action)
(define (install-pkg parent wrap-terminal-action
#:package-to-offer [package-to-offer #f])
(make-pkg-installer #:parent parent
#:wrap-terminal-action wrap-terminal-action)))
#:wrap-terminal-action wrap-terminal-action
#:package-to-offer package-to-offer)))
(require string-constants
racket/match

4
collects/pkg/gui/by-source.rkt
View File

@ -49,7 +49,7 @@
(define by-source-panel%
(class vertical-panel%
(init-field [in-terminal in-terminal])
(init [text-field-initial-value #f])
(super-new)
(inherit get-top-level-window)
@ -65,7 +65,7 @@
[callback (λ (_1 _2)
(preferences:set 'drracket:gui-installer-pkg-source (send tf get-value))
(adjust-all))]))
(send tf set-value (preferences:get 'drracket:gui-installer-pkg-source))
(send tf set-value (or text-field-initial-value (preferences:get 'drracket:gui-installer-pkg-source)))
(define browse-button (new button%
[parent source-panel]

11
collects/pkg/gui/main.rkt
View File

@ -23,7 +23,9 @@
(#:parent
(or/c #f (is-a?/c top-level-window<%>))
#:wrap-terminal-action
(-> (-> any) any))
(-> (-> any) any)
#:package-to-offer
(or/c #f string?))
(is-a?/c top-level-window<%>))]))
(define pkg-gui-frame%
@ -37,7 +39,9 @@
(define (make-pkg-installer #:parent
[parent #f]
#:wrap-terminal-action
[wrap-terminal-action (λ (t) (t))])
[wrap-terminal-action (λ (t) (t))]
#:package-to-offer
[package-to-offer #f])
(define allow-close? #t)
@ -78,7 +82,8 @@
(define by-source-panel
(new by-source-panel%
[parent dlg]
[in-terminal in-terminal-panel]))
[in-terminal in-terminal-panel]
[text-field-initial-value package-to-offer]))
(define close (new button%
[label (string-constant close)]