adjust DrRacket to offer installation of packages

based on exn:missing-module?

collects/drracket/private/debug.rkt

@@ -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?)
+        (define needs-invalidate?
-                                           (and new-grabbed? new-in-bounds?)))])
+          (or (not (equal? grabbed? new-grabbed?))
-          (set! grabbed? new-grabbed?)
+              (not (equal? new-in-bounds? in-bounds?))))
-          (set! in-bounds? new-in-bounds?)
+        (set! grabbed? new-grabbed?)
-          (when needs-invalidate?
+        (set! in-bounds? new-in-bounds?)
-            (invalidate dc))))
+        (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)])
+        (define-values (w h) (get-w/h dc))
-          (let ([in-bounds? (and (<= (- (send evt get-x) x) w)
+        (define in-bounds? (and (<= (- (send evt get-x) x) w)
-                                 (<= (- (send evt get-y) y) h))])
+                                (<= (- (send evt get-y) y) h)))
-            (cond
+        (cond
-              [(send evt button-down? 'left)
+          [(send evt button-down? 'left)
-               (set-clicked #t in-bounds? dc)]
+           (set-clicked #t in-bounds? dc)]
-              [(send evt button-up? 'left)
+          [(send evt button-up? 'left)
-               (let ([admin (send this get-admin)])
+           (let ([admin (send this get-admin)])
-                 (when admin
+             (when admin
-                   (send (send admin get-editor) set-caret-owner #f 'global)))
+               (send (send admin get-editor) set-caret-owner #f 'global)))
-               (when (and grabbed? in-bounds?)
+           (when (and grabbed? in-bounds?)
-                 (callback))
+             (callback this))
-               (set-clicked #f in-bounds? dc)]
+           (set-clicked #f in-bounds? dc)]
-              [else
+          [else
-               (set-clicked grabbed? in-bounds? dc)]))))
+           (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

collects/drracket/private/frame.rkt

@@ -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

collects/pkg/gui/by-source.rkt

@@ -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]

collects/pkg/gui/main.rkt

@@ -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)]