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

Rackety

Browse Source
This commit is contained in:
Robby Findler 2010-12-09 11:03:05 -06:00
parent 18dacad6c8
commit 08d7a43c08
1 changed files with 513 additions and 517 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
collects/help/bug-report.rkt
View File

@ -1,12 +1,9 @@
#lang racket/base
(module bug-report mzscheme
(require string-constants (require string-constants
net/head net/head
mred racket/gui/base
framework framework
mzlib/class racket/class
mzlib/etc
mzlib/list
net/url net/url
net/uri-codec net/uri-codec
browser/htmltext browser/htmltext
@ -22,8 +19,8 @@
(define frame-mixin (define frame-mixin
(namespace-variable-value 'help-desk:frame-mixin #f (lambda () (lambda (x) x)))) (namespace-variable-value 'help-desk:frame-mixin #f (lambda () (lambda (x) x))))
(preferences:set-default 'drscheme:email "" string?) (preferences:set-default 'drracket:email "" string? #:aliases '(drscheme:email))
(preferences:set-default 'drscheme:full-name "" string?) (preferences:set-default 'drracket:full-name "" string? #:aliases '(drscheme:full-name))
(define bug-frame% (define bug-frame%
(class (frame-mixin (frame:standard-menus-mixin frame:basic%)) (class (frame-mixin (frame:standard-menus-mixin frame:basic%))
@ -83,8 +80,7 @@
(enabled #f) (enabled #f)
(callback (lambda (x y) (cleanup-frame))) (callback (lambda (x y) (cleanup-frame)))
(label (string-constant close)))) (label (string-constant close))))
(define stupid-internal-define-syntax1 (new grow-box-spacer-pane% (parent response-button-panel))
(new grow-box-spacer-pane% (parent response-button-panel)))
(define top-panel (make-object vertical-panel% outermost-panel)) (define top-panel (make-object vertical-panel% outermost-panel))
@ -99,7 +95,7 @@
(send single active-child response-panel)) (send single active-child response-panel))
(define (switch-to-compose-view) (define (switch-to-compose-view)
(send single active-child outermost-panel) (send single active-child outermost-panel)
(send (if (string=? "" (preferences:get 'drscheme:full-name)) (send (if (string=? "" (preferences:get 'drracket:full-name))
name name
summary) summary)
focus)) focus))
@ -114,19 +110,19 @@
; constructs and arranges the gui objects for the bug report form ; constructs and arranges the gui objects for the bug report form
; effect: updates lps with the new label panel, for future alignment ; effect: updates lps with the new label panel, for future alignment
(define build/label (define build/label
(opt-lambda (text make-item top? [stretch? #f] [top-panel top-panel] [vertical? #f]) (lambda (text make-item top? [stretch? #f] [top-panel top-panel] [vertical? #f])
(let*-values ([(hp) (make-object (if vertical? (define hp (make-object (if vertical?
vertical-panel% vertical-panel%
horizontal-panel%) horizontal-panel%)
top-panel)] top-panel))
[(lp) (make-object vertical-panel% hp)] (define lp (make-object vertical-panel% hp))
[(ip) (make-object vertical-panel% hp)] (define ip (make-object vertical-panel% hp))
[(label/s) (if (string? text) (if (string? text)
(make-object message% text lp) (make-object message% text lp)
(map (lambda (s) (map (lambda (s)
(make-object message% s lp)) (make-object message% s lp))
text))] text))
[(item) (make-item ip)]) (define item (make-item ip))
(set! lps (cons lp lps)) (set! lps (cons lp lps))
(unless stretch? (unless stretch?
(send hp stretchable-height #f) (send hp stretchable-height #f)
@ -136,7 +132,7 @@
(send lp stretchable-height #f) (send lp stretchable-height #f)
(send lp set-alignment (if vertical? 'left 'right) (if top? 'top 'center)) (send lp set-alignment (if vertical? 'left 'right) (if top? 'top 'center))
(send ip set-alignment 'left 'top) (send ip set-alignment 'left 'top)
item))) item))
(define (align-labels) (define (align-labels)
(let ([width (apply max (map (lambda (x) (send (car (send x get-children)) min-width)) (let ([width (apply max (map (lambda (x) (send (car (send x get-children)) min-width))
@ -151,8 +147,8 @@
(lambda () (lambda ()
(make-object text-field% #f panel (make-object text-field% #f panel
(lambda (text event) (lambda (text event)
(preferences:set 'drscheme:full-name (send text get-value))) (preferences:set 'drracket:full-name (send text get-value)))
(preferences:get 'drscheme:full-name))))) (preferences:get 'drracket:full-name)))))
#f)) #f))
(define email (define email
@ -163,8 +159,8 @@
(lambda () (lambda ()
(make-object text-field% #f panel (make-object text-field% #f panel
(lambda (text event) (lambda (text event)
(preferences:set 'drscheme:email (send text get-value))) (preferences:set 'drracket:email (send text get-value)))
(preferences:get 'drscheme:email))))) (preferences:get 'drracket:email)))))
#f)) #f))
(define summary (define summary
@ -333,8 +329,8 @@
(define (get-query) (define (get-query)
(append (list (cons 'help-desk "true") (append (list (cons 'help-desk "true")
(cons 'replyto (preferences:get 'drscheme:email)) (cons 'replyto (preferences:get 'drracket:email))
(cons 'originator (preferences:get 'drscheme:full-name)) (cons 'originator (preferences:get 'drracket:full-name))
(cons 'subject (send summary get-value)) (cons 'subject (send summary get-value))
(cons 'severity (send severity get-string-selection)) (cons 'severity (send severity get-string-selection))
(cons 'class (translate-class (send bug-class get-string-selection))) (cons 'class (translate-class (send bug-class get-string-selection)))
@ -450,7 +446,7 @@
(string-constant pls-fill-in-either-description-or-reproduce)) (string-constant pls-fill-in-either-description-or-reproduce))
(done-checking #f)) (done-checking #f))
(unless (regexp-match #rx"@" (or (preferences:get 'drscheme:email) "")) (unless (regexp-match #rx"@" (or (preferences:get 'drracket:email) ""))
(message-box (string-constant illegal-bug-report) (message-box (string-constant illegal-bug-report)
(string-constant malformed-email-address)) (string-constant malformed-email-address))
(done-checking #f)) (done-checking #f))
@ -528,4 +524,4 @@
(string-constant no) (string-constant no)
title title
#f #f
parent))) parent))