456 lines
16 KiB
Racket
456 lines
16 KiB
Racket
#lang racket/base
|
|
(require racket/gui/base
|
|
racket/class
|
|
racket/contract
|
|
racket/pretty
|
|
string-constants/string-constant
|
|
setup/dirs
|
|
setup/link
|
|
framework
|
|
(for-syntax racket/base
|
|
racket/list)
|
|
"buginfo.rkt"
|
|
"save-bug-report.rkt")
|
|
|
|
(provide/contract
|
|
[add-bug-report-controls
|
|
(-> (is-a?/c area-container<%>)
|
|
saved-report?
|
|
(-> any)
|
|
(-> any)
|
|
(-> any)
|
|
any)])
|
|
|
|
(define (add-bug-report-controls compose-panel init-bug-report ok cancel close-and-save)
|
|
(define top-panel (make-object vertical-panel% compose-panel))
|
|
|
|
(define lps null)
|
|
|
|
; build/label : ((union string (list-of string))
|
|
; (area-container<%> -> item<%>)
|
|
; boolean
|
|
; area-container<%>
|
|
; -> item<%>)
|
|
; constructs and arranges the gui objects for the bug report form
|
|
; effect: updates lps with the new label panel, for future alignment
|
|
(define (build/label text make-item top? #:stretch? [stretch? #f] #:top-panel [top-panel top-panel] #:vertical? [vertical? #f])
|
|
(define hp (make-object (if vertical?
|
|
vertical-panel%
|
|
horizontal-panel%)
|
|
top-panel))
|
|
(define lp (make-object vertical-panel% hp))
|
|
(define ip (make-object vertical-panel% hp))
|
|
(if (string? text)
|
|
(make-object message% text lp)
|
|
(map (lambda (s)
|
|
(make-object message% s lp))
|
|
text))
|
|
(define item (make-item ip))
|
|
(set! lps (cons lp lps))
|
|
(unless stretch?
|
|
(send hp stretchable-height #f)
|
|
(send lp stretchable-height #f)
|
|
(send ip stretchable-height #f))
|
|
(send lp stretchable-width #f)
|
|
(send lp stretchable-height #f)
|
|
(send lp set-alignment (if vertical? 'left 'right) (if top? 'top 'center))
|
|
(send ip set-alignment 'left 'top)
|
|
item)
|
|
|
|
(define (align-labels)
|
|
(send synthesized-dialog reflow-container)
|
|
(send compose-panel reflow-container)
|
|
(let ([width (apply max (map (lambda (x) (send (car (send x get-children)) get-width))
|
|
lps))])
|
|
(for ([x (in-list lps)])
|
|
(send x min-width width))))
|
|
|
|
(define name
|
|
(build/label
|
|
(string-constant bug-report-field-name)
|
|
(lambda (panel)
|
|
(keymap:call/text-keymap-initializer
|
|
(lambda ()
|
|
(make-object text-field% #f panel
|
|
(lambda (text event)
|
|
(preferences:set 'drracket:full-name (send text get-value)))
|
|
(preferences:get 'drracket:full-name)))))
|
|
#f))
|
|
|
|
(define email
|
|
(build/label
|
|
(string-constant bug-report-field-email)
|
|
(lambda (panel)
|
|
(keymap:call/text-keymap-initializer
|
|
(lambda ()
|
|
(make-object text-field% #f panel
|
|
(lambda (text event)
|
|
(preferences:set 'drracket:email (send text get-value)))
|
|
(preferences:get 'drracket:email)))))
|
|
#f))
|
|
|
|
(define summary
|
|
(build/label
|
|
(string-constant bug-report-field-summary)
|
|
(lambda (panel)
|
|
(keymap:call/text-keymap-initializer
|
|
(lambda ()
|
|
(define tf (new text-field%
|
|
[label #f]
|
|
[parent panel]
|
|
[callback (λ (a b) (bug-report-out-of-date))]))
|
|
(send tf set-value (saved-report-lookup init-bug-report 'subject))
|
|
tf)))
|
|
#f))
|
|
|
|
(define severity
|
|
(build/label
|
|
(string-constant bug-report-field-severity)
|
|
(lambda (panel)
|
|
(define choice
|
|
(make-object choice%
|
|
#f
|
|
bug-severities
|
|
panel
|
|
(λ (a b) (bug-report-out-of-date))))
|
|
(send choice set-string-selection (saved-report-lookup init-bug-report 'severity))
|
|
choice)
|
|
#f))
|
|
|
|
(define bug-class
|
|
(build/label
|
|
(string-constant bug-report-field-class)
|
|
(lambda (panel)
|
|
(define choice (make-object choice%
|
|
#f
|
|
(map car bug-classes)
|
|
panel
|
|
(λ (a b) (bug-report-out-of-date))))
|
|
(send choice set-string-selection
|
|
(saved-report-lookup init-bug-report 'class))
|
|
choice)
|
|
#f))
|
|
|
|
(define save-text%
|
|
(class text:basic%
|
|
(define initialized? #f)
|
|
(define/public (initialized) (set! initialized? #t))
|
|
(define/augment (after-insert a b)
|
|
(when initialized?
|
|
(bug-report-out-of-date))
|
|
(inner (void) after-insert a b))
|
|
(define/augment (after-delete a b)
|
|
(when initialized?
|
|
(bug-report-out-of-date))
|
|
(inner (void) after-delete a b))
|
|
(super-new)))
|
|
|
|
(define (make-big-text label #:key [key #f] #:stretch? [stretch? #f] #:top-panel [top-panel top-panel] #:vertical? [vertical? #f])
|
|
(let ([canvas
|
|
(build/label
|
|
label
|
|
(lambda (panel)
|
|
(let* ([text (new (editor:standard-style-list-mixin
|
|
(editor:keymap-mixin
|
|
(if key
|
|
save-text%
|
|
text:basic%))))]
|
|
[canvas (new canvas:basic%
|
|
(style '(hide-hscroll))
|
|
(parent panel)
|
|
(editor text))])
|
|
(send text set-paste-text-only #t)
|
|
(send text auto-wrap #t)
|
|
(send text set-max-undo-history 'forever)
|
|
(send text set-styles-fixed #t)
|
|
(when key
|
|
(send text insert (saved-report-lookup init-bug-report key))
|
|
(send text set-position 0 0)
|
|
(send text initialized))
|
|
canvas))
|
|
#t
|
|
#:stretch? stretch?
|
|
#:top-panel top-panel
|
|
#:vertical? vertical?)])
|
|
(send canvas min-width 500)
|
|
(send canvas min-height 130)
|
|
(send canvas get-editor)
|
|
(send canvas allow-tab-exit #t)
|
|
canvas))
|
|
|
|
(define description (make-big-text (string-constant bug-report-field-description)
|
|
#:key 'description
|
|
#:stretch? #t))
|
|
(define reproduce (make-big-text (list (string-constant bug-report-field-reproduce1)
|
|
(string-constant bug-report-field-reproduce2))
|
|
#:key 'how-to-repeat
|
|
#:stretch? #t))
|
|
|
|
(define synthesized-dialog (make-object dialog% (string-constant bug-report-synthesized-information)))
|
|
(define synthesized-panel (make-object vertical-panel% synthesized-dialog))
|
|
(define synthesized-button-panel
|
|
(new horizontal-panel% [parent synthesized-dialog]
|
|
[alignment '(right center)] [stretchable-height #f]))
|
|
(define synthesized-ok-button (make-object button% (string-constant ok) synthesized-button-panel
|
|
(lambda (x y)
|
|
(send synthesized-dialog show #f))))
|
|
(define synthesized-info-shown? #t)
|
|
(define (show-synthesized-info)
|
|
(send synthesized-dialog show #t))
|
|
|
|
(define version-tf
|
|
(build/label
|
|
(string-constant bug-report-field-version)
|
|
(lambda (panel)
|
|
(keymap:call/text-keymap-initializer
|
|
(lambda ()
|
|
(make-object text-field% #f panel void ""))))
|
|
#f
|
|
#:top-panel synthesized-panel))
|
|
(define environment
|
|
(build/label
|
|
(string-constant bug-report-field-environment)
|
|
(lambda (panel)
|
|
(keymap:call/text-keymap-initializer
|
|
(lambda ()
|
|
(make-object text-field% #f panel void ""))))
|
|
#f
|
|
#:top-panel synthesized-panel))
|
|
|
|
(define human-language
|
|
(build/label
|
|
(string-constant bug-report-field-human-language)
|
|
(lambda (panel)
|
|
(keymap:call/text-keymap-initializer
|
|
(lambda ()
|
|
(make-object text-field% #f panel void ""))))
|
|
#f
|
|
#:top-panel synthesized-panel))
|
|
|
|
(define memory-use
|
|
(build/label
|
|
(string-constant bug-report-field-memory-use)
|
|
(lambda (panel)
|
|
(keymap:call/text-keymap-initializer
|
|
(lambda ()
|
|
(make-object text-field% #f panel void ""))))
|
|
#f
|
|
#:top-panel synthesized-panel))
|
|
|
|
(define links-ctrl
|
|
(build/label
|
|
(string-constant bug-report-field-links)
|
|
(lambda (panel)
|
|
(keymap:call/text-keymap-initializer
|
|
(lambda ()
|
|
(make-object text-field% #f panel void ""))))
|
|
#f
|
|
#:top-panel synthesized-panel))
|
|
|
|
(define collections
|
|
(make-big-text
|
|
(string-constant bug-report-field-collections)
|
|
#:stretch? #t
|
|
#:top-panel synthesized-panel))
|
|
|
|
(send synthesized-dialog reflow-container) ;; help out the editor by resizing the container to a reasonable width (and thus make word-wrapping easier)
|
|
|
|
(define extras
|
|
(map (lambda (bri)
|
|
(let ([label (bri-label bri)])
|
|
(cons
|
|
label
|
|
(build/label
|
|
label
|
|
(lambda (panel)
|
|
(let ([field
|
|
(keymap:call/text-keymap-initializer
|
|
(lambda ()
|
|
(make-object text-field% #f panel void "")))])
|
|
(send field set-value (bri-value bri))
|
|
field))
|
|
#f
|
|
#:top-panel synthesized-panel))))
|
|
(get-bug-report-infos)))
|
|
|
|
(define still-save? #t)
|
|
(define (no-more-saving) (set! still-save? #f))
|
|
|
|
(define (save-this-bug-report)
|
|
(when still-save?
|
|
(save-bug-report
|
|
(saved-report-id init-bug-report)
|
|
#:severity (send severity get-string-selection)
|
|
#:class (send bug-class get-string-selection)
|
|
#:subject (send summary get-value)
|
|
#:description (get-content description)
|
|
#:how-to-repeat (get-content reproduce))))
|
|
|
|
(define timer
|
|
(new timer%
|
|
[notify-callback save-this-bug-report]
|
|
[just-once? #t]))
|
|
(define (bug-report-out-of-date)
|
|
(send timer stop)
|
|
(send timer start 200 #t))
|
|
|
|
(define (get-query)
|
|
(append (list (cons 'help-desk "true")
|
|
(cons 'replyto (preferences:get 'drracket:email))
|
|
(cons 'originator (preferences:get 'drracket:full-name))
|
|
(cons 'subject (send summary get-value))
|
|
(cons 'severity (send severity get-string-selection))
|
|
(cons 'class (translate-class (send bug-class get-string-selection)))
|
|
(cons 'release (send version-tf get-value))
|
|
(cons 'description (get-content description))
|
|
(cons 'how-to-repeat (get-content reproduce))
|
|
(cons 'platform (get-environment)))
|
|
(map (λ (bri) (cons (string->symbol (format "~a" (bri-label bri)))
|
|
(bri-value bri)))
|
|
(get-bug-report-infos))))
|
|
|
|
(define (get-environment)
|
|
(string-append (send environment get-value)
|
|
"\n"
|
|
(format "Human Language: ~a\n" (send human-language get-value))
|
|
(format "(current-memory-use) ~a\n" (send memory-use get-value))
|
|
(format "Links: ~a\n" (send links-ctrl get-value))
|
|
"\n"
|
|
"\nCollections:\n"
|
|
(format "~a" (send (send collections get-editor) get-text))
|
|
"\n"
|
|
(apply
|
|
string-append
|
|
(map (lambda (extra)
|
|
(format "~a: ~a\n"
|
|
(car extra)
|
|
(send (cdr extra) get-value)))
|
|
extras))))
|
|
|
|
(define (get-content canvas)
|
|
(define t (send canvas get-editor))
|
|
(send t get-text 0 (send t last-position)))
|
|
|
|
(define (set-content canvas str)
|
|
(define t (send canvas get-editor))
|
|
(send t begin-edit-sequence)
|
|
(send t erase)
|
|
(send t insert str)
|
|
(send t end-edit-sequence))
|
|
|
|
(define (compose-view-focus)
|
|
(send (if (string=? "" (preferences:get 'drracket:full-name))
|
|
name
|
|
summary)
|
|
focus))
|
|
|
|
(define button-panel
|
|
(new horizontal-panel% [parent compose-panel]
|
|
[alignment '(right center)] [stretchable-height #f]))
|
|
(define synthesized-button
|
|
(make-object button%
|
|
(string-constant bug-report-show-synthesized-info)
|
|
button-panel (lambda x (show-synthesized-info))))
|
|
(new button%
|
|
[parent button-panel]
|
|
[label (string-constant close-and-save)]
|
|
[callback (λ (a b) (close-and-save))])
|
|
(new horizontal-pane% (parent button-panel))
|
|
(gui-utils:ok/cancel-buttons button-panel
|
|
(λ (a b) (ok))
|
|
(λ (a b) (cancel))
|
|
(string-constant bug-report-submit)
|
|
#:confirm-style '())
|
|
(new grow-box-spacer-pane% [parent button-panel])
|
|
|
|
|
|
(define (sanity-checking)
|
|
(let ([no-value?
|
|
(lambda (f)
|
|
(cond
|
|
[(is-a? f editor-canvas%)
|
|
(= 0 (send (send f get-editor) last-position))]
|
|
[else (string=? "" (send f get-value))]))])
|
|
(let/ec done-checking
|
|
(for-each
|
|
(lambda (field field-name)
|
|
(when (no-value? field)
|
|
(message-box (string-constant illegal-bug-report)
|
|
(format (string-constant pls-fill-in-field) field-name))
|
|
(done-checking #f)))
|
|
(list name summary)
|
|
(list (string-constant bug-report-field-name)
|
|
(string-constant bug-report-field-summary)))
|
|
|
|
(when (and (no-value? description)
|
|
(no-value? reproduce))
|
|
(message-box (string-constant illegal-bug-report)
|
|
(string-constant pls-fill-in-either-description-or-reproduce))
|
|
(done-checking #f))
|
|
|
|
(unless (regexp-match #rx"@" (or (preferences:get 'drracket:email) ""))
|
|
(message-box (string-constant illegal-bug-report)
|
|
(string-constant malformed-email-address))
|
|
(done-checking #f))
|
|
(done-checking #t))))
|
|
|
|
(send version-tf set-value (format "~a" (version:version)))
|
|
|
|
(send environment set-value
|
|
(format "~a ~s (~a) (get-display-depth) = ~a"
|
|
(system-type)
|
|
(system-type 'machine)
|
|
(system-library-subpath)
|
|
(get-display-depth)))
|
|
|
|
(send (send collections get-editor)
|
|
insert
|
|
(apply
|
|
string-append
|
|
(for/list ([d (get-collects-search-dirs)])
|
|
(format "(~s\n ~s)\n"
|
|
(path->string d)
|
|
(if (directory-exists? d)
|
|
(map path->string (directory-list d))
|
|
'(non-existent-path))))))
|
|
|
|
(define-syntax (links-calls stx)
|
|
(syntax-case stx ()
|
|
[(_ calls ...)
|
|
(let ([str
|
|
(apply
|
|
string-append
|
|
(add-between (map (λ (x) "~s = ~s")
|
|
(syntax->list #'(calls ...)))
|
|
"; "))])
|
|
#`(format #,str #,@(apply append (map (λ (x) (list #`'#,x x))
|
|
(syntax->list #'(calls ...))))))]))
|
|
(send (send links-ctrl get-editor)
|
|
insert
|
|
(links-calls (links)
|
|
(links #:user? #f)
|
|
(links #:root? #t)
|
|
(links #:user? #f #:root? #t)))
|
|
|
|
(send human-language set-value (format "~a" (this-language)))
|
|
(send memory-use set-value (format "~a" (current-memory-use)))
|
|
|
|
(send (send collections get-editor) auto-wrap #t)
|
|
(align-labels)
|
|
|
|
(define (empty-bug-report?)
|
|
(define (empty-editor? c)
|
|
(define t (send c get-editor))
|
|
(zero? (send t last-position)))
|
|
(and (empty-editor? reproduce)
|
|
(empty-editor? description)
|
|
(empty-editor? summary)
|
|
(equal? (send severity get-selection) default-severity)
|
|
(equal? (send bug-class get-selection) default-class)))
|
|
|
|
(values compose-view-focus
|
|
get-query
|
|
sanity-checking
|
|
no-more-saving
|
|
empty-bug-report?))
|