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

Corrected button running into resize-box; window not closing on tab close; and

Browse Source 
preference problem for disabling testing 

svn: r3141
This commit is contained in:
Kathy Gray 2006-05-30 22:34:45 +00:00
parent 684d69710c
commit f72cc3c675
3 changed files with 23 additions and 178 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/profj/parsers/parse-error.ss
View File

@ -1531,7 +1531,7 @@
(if (eof? (get-tok next)) (if (eof? (get-tok next))
(parse-error "Expected an expression after = for field initialization" start end) (parse-error "Expected an expression after = for field initialization" start end)
(parse-beginner-ctor-body cur-tok (parse-expression null next 'start getter #f #f) 'assign-end getter)))) (parse-beginner-ctor-body cur-tok (parse-expression null next 'start getter #f #f) 'assign-end getter))))
(else (parse-error (format "Expected = to be used in initializing the field, found ~a" out) start end)))) (else (parse-error (format "Expected = to be used in initializing the field in this constructor, found ~a" out) start end))))
((assign-end) ((assign-end)
(cond (cond
((eof? tok) (parse-error "Expected a ; to end field intialization, constructor and class need }" ps pe)) ((eof? tok) (parse-error "Expected a ; to end field intialization, constructor and class need }" ps pe))

19
collects/profj/tester.scm
View File

@ -4,6 +4,7 @@
(lib "tool.ss" "drscheme") (lib "tool.ss" "drscheme")
(lib "unitsig.ss") (lib "unitsig.ss")
(lib "framework.ss" "framework") (lib "framework.ss" "framework")
(lib "string-constant.ss" "string-constants")
(lib "class.ss") (lib "class.ss")
(lib "list.ss") (lib "list.ss")
(lib "file.ss") (lib "file.ss")
@ -289,14 +290,14 @@
(define buttons (define buttons
(list (make-object button% (list (make-object button%
"Close" (string-constant close)
button-panel button-panel
(lambda (b c) (lambda (b c)
(when (eq? 'button (send c get-event-type)) (when (eq? 'button (send c get-event-type))
(close-cleanup) (close-cleanup)
(send this show #f)))) (send this show #f))))
(make-object button% (make-object button%
"Close and disable testing" "Close and Disable Testing"
button-panel button-panel
(lambda (b c) (lambda (b c)
(when (eq? 'button (send c get-event-type)) (when (eq? 'button (send c get-event-type))
@ -304,13 +305,15 @@
(close-cleanup) (close-cleanup)
(send this show #f)))) (send this show #f))))
(make-object button% (make-object button%
"Dock" (string-constant dock)
button-panel button-panel
(lambda (b c) (lambda (b c)
(when (eq? 'button (send c get-event-type)) (when (eq? 'button (send c get-event-type))
(send this show #f) (send this show #f)
(put-preferences '(profj:test-window:docked?) '(#t)) (put-preferences '(profj:test-window:docked?) '(#t))
(switch-func)))))) (switch-func))))
(make-object grow-box-spacer-pane% button-panel)))
(define/public (update-editor e) (define/public (update-editor e)
(set! editor e) (set! editor e)
@ -341,20 +344,20 @@
(remove)) (remove))
(make-object button% (make-object button%
"Hide" (string-constant hide)
button-panel button-panel
(lambda (b c) (lambda (b c)
(when (eq? 'button (send c get-event-type)) (when (eq? 'button (send c get-event-type))
(hide)))) (hide))))
(make-object button% (make-object button%
"Hide and disable testing" "Hide and Disable Testing"
button-panel button-panel
(lambda (b c) (lambda (b c)
(when (eq? 'button (send c get-event-type)) (when (eq? 'button (send c get-event-type))
(hide) (hide)
(put-preferences '(profj:test-enable) '(#f))))) (put-preferences '(profj:test-enable) '(#f)))))
(make-object button% (make-object button%
"Undock" (string-constant undock)
button-panel button-panel
(lambda (b c) (lambda (b c)
(when (eq? 'button (send c get-event-type)) (when (eq? 'button (send c get-event-type))
@ -628,6 +631,8 @@
(define/augment (on-close) (define/augment (on-close)
(when test-window (when test-window
(when (send test-window is-shown?)
(send test-window show #f))
(send (get-frame) deregister-test-window test-window)) (send (get-frame) deregister-test-window test-window))
(inner (void) on-close)) (inner (void) on-close))

180
collects/profj/tool.ss
View File

@ -7,7 +7,8 @@
(lib "string-constant.ss" "string-constants") (lib "string-constant.ss" "string-constants")
(lib "Object.ss" "profj" "libs" "java" "lang") (lib "array.ss" "profj" "libs" "java" "lang") (lib "Object.ss" "profj" "libs" "java" "lang") (lib "array.ss" "profj" "libs" "java" "lang")
(lib "String.ss" "profj" "libs" "java" "lang")) (lib "String.ss" "profj" "libs" "java" "lang"))
(require "compile.ss" "parameters.ss" "parsers/lexer.ss" "parser.ss" "ast.ss" "tester.scm") (require "compile.ss" "parameters.ss" "parsers/lexer.ss" "parser.ss" "ast.ss" "tester.scm"
"display-java.ss")
(require-for-syntax "compile.ss") (require-for-syntax "compile.ss")
@ -391,8 +392,9 @@
(send print-full set-value (profj-settings-print-full? settings))) (send print-full set-value (profj-settings-print-full? settings)))
(when (eq? level 'full) (when (eq? level 'full)
(send allow-testing set-value (profj-settings-allow-check? settings))) (send allow-testing set-value (profj-settings-allow-check? settings)))
(send display-testing set-value (profj-settings-run-tests? settings)) (send display-testing set-value
(if (profj-settings-run-tests? settings) (get-preference 'profj:test-enable (lambda () (profj-settings-run-tests? settings))))
(if (send display-testing get-value)
(send collect-coverage set-value (profj-settings-coverage? settings)) (send collect-coverage set-value (profj-settings-coverage? settings))
(send collect-coverage enable #f)) (send collect-coverage enable #f))
(install-classpath (profj-settings-classpath settings))]))) (install-classpath (profj-settings-classpath settings))])))
@ -611,10 +613,10 @@
(let inner-loop ((os objs)) (let inner-loop ((os objs))
(unless (null? os) (unless (null? os)
(let ((formatted (let ((formatted
(format-java-list (car os) #t 'field null #f 0))) (format-java-value (car os) (make-format-style #t 'field #f))))
(when (< 24 (total-length formatted)) (when (< 24 (total-length formatted))
(set! formatted (set! formatted
(format-java-list (car os) #t 'field null #t 0))) (format-java-value (car os) (make-format-style #t 'field #t))))
(let loop ((out formatted)) (let loop ((out formatted))
(unless (null? out) (unless (null? out)
(write-special (car out)) (write-special (car out))
@ -679,9 +681,10 @@
(define/public (render-value value settings port) (define/public (render-value value settings port)
(let* ((print-full? (profj-settings-print-full? settings)) (let* ((print-full? (profj-settings-print-full? settings))
(style (profj-settings-print-style settings)) (style (profj-settings-print-style settings))
(formatted (format-java-list value print-full? style null #f 0))) (formatted (format-java-value value
(make-format-style print-full? style #f))))
(when (< 24 (total-length formatted)) (when (< 24 (total-length formatted))
(set! formatted (format-java-list value print-full? style null #t 0))) (set! formatted (format-java-value value (make-format-style print-full? style #t))))
(let loop ((out formatted)) (let loop ((out formatted))
(unless (null? out) (unless (null? out)
(write-special (car out) port) (write-special (car out) port)
@ -965,169 +968,6 @@
(namespace-syntax-introduce ((syntax-object->datum (syntax comp)) (namespace-syntax-introduce ((syntax-object->datum (syntax comp))
(syntax-object->datum (syntax ast))))))) (syntax-object->datum (syntax ast)))))))
(define (supports-printable-interface? o)
(and (is-a? o object%)
(method-in-interface? 'my-name (object-interface o))
(method-in-interface? 'fields-for-display (object-interface o))))
(provide format-java)
;formats a java value (number, character or Object) into a string
;format-java: java-value bool symbol (list value) -> string
(define (format-java value full-print? style already-printed newline? num-tabs)
(cond
((null? value) "null")
((number? value) (format "~a" value))
((char? value) (format "'~a'" value))
((boolean? value) (if value "true" "false"))
((is-java-array? value)
(if full-print?
(array->string value (send value length) -1 #t style already-printed newline? num-tabs)
(array->string value 3 (- (send value length) 3) #f style already-printed newline? num-tabs)))
((is-a? value String) (format "~v" (send value get-mzscheme-string)))
((string? value) (format "~v" value))
((or (is-a? value ObjectI) (supports-printable-interface? value))
(case style
((type) (send value my-name))
((field)
(let* ((retrieve-fields (send value fields-for-display))
(st (format "~a(" (send value my-name)))
(new-tabs (+ num-tabs 3));(string-length st)))
(fields ""))
(let loop ((current (retrieve-fields)))
(let ((next (retrieve-fields)))
(when current
(set! fields
(string-append fields
(format "~a~a = ~a~a~a"
(if newline? (if (equal? fields "")
(format "~n~a" (get-n-spaces new-tabs)); ""
(get-n-spaces new-tabs)) "")
(car current)
(if (memq (cadr current) already-printed)
(format-java (cadr current) full-print? 'type already-printed #f 0)
(format-java (cadr current) full-print? style
(cons value already-printed) newline?
(if newline?
(+ new-tabs (string-length (car current)) 3)
num-tabs)))
(if next "," "")
(if newline? (format "~n") " "))))
(loop next))))
(string-append st
(if (> (string-length fields) 1)
(substring fields 0 (sub1 (string-length fields))) "") ")")))
(else (send value my-name))))
(else (format "~a" value))))
(define (format-java-list value full-print? style already-printed newline? num-tabs)
(cond
((null? value) '("null"))
((number? value) (list (format "~a" value)))
((char? value) (list (format "'~a'" value)))
((boolean? value) (list (if value "true" "false")))
((is-java-array? value)
(if full-print?
(format-array->list value (send value length) -1 #t style already-printed newline? num-tabs)
(format-array->list value 3 (- (send value length) 3) #f style already-printed newline? num-tabs)))
((is-a? value String) (list (format "~v" (send value get-mzscheme-string))))
((string? value) (list (format "~v" value)))
((or (is-a? value ObjectI) (supports-printable-interface? value))
(cond
((and (equal? "Image" (send value my-name))
(object-method-arity-includes? value 'Image-constructor-dynamic 1)
(object-method-arity-includes? value 'movePinhole-graphics.Posn 1))
;(printf "~a~n" ((send value fields-for-display)))
(list (cadr ((send value fields-for-display)))))
(else
(if (memq value already-printed)
(list (send value my-name))
(case style
((type) (list (send value my-name)))
((field)
(let* ((retrieve-fields (send value fields-for-display))
(st (format "~a(" (send value my-name)))
(new-tabs (+ num-tabs 3))
(fields null))
(let loop ((current (retrieve-fields)))
(let ((next (retrieve-fields)))
(when current
(set! fields
(append fields
(cons
(format "~a~a = "
(if newline? (if (eq? fields null)
(format "~n~a" (get-n-spaces new-tabs))
(get-n-spaces new-tabs)) "")
(car current))
(append
(if (memq (cadr current) already-printed)
(format-java-list (cadr current) full-print? 'type already-printed #f 0)
(format-java-list (cadr current) full-print? style
(cons value already-printed) newline?
(if newline?
(+ new-tabs (if (string? (car current))
(string-length (car current)) 1) 3)
num-tabs)))
(list (format "~a~a"
(if next "," "")
(if newline? (format "~n") " ")))))))
(loop next))))
(cons st
(append
(if (> (length fields) 1)
(reverse (cdr (reverse fields))) null) (list ")")))))
(else (list (send value my-name))))))))
(else (list value))))
;format-array->list: java-value int int bool symbol (list value) -> (list val)
(define (format-array->list value stop restart full-print? style already-printed nl? nt)
(letrec ((len (send value length))
(make-partial-string
(lambda (idx first-test second-test)
(cond
((first-test idx) "")
((second-test idx)
(string-append (format-java (send value access idx) full-print? style already-printed nl? nt)
(make-partial-string (add1 idx) first-test second-test)))
(else
(string-append (format-java (send value access idx) full-print? style already-printed nl? nt)
" "
(make-partial-string (add1 idx) first-test second-test)))))))
(if (or full-print? (< restart stop))
(list (format "[~a]" (make-partial-string 0 (lambda (i) (>= i len)) (lambda (i) (= i (sub1 len))))))
(list (format "[~a~a~a]"
(make-partial-string 0 (lambda (i) (or (>= i stop) (>= i len))) (lambda (i) (= i (sub1 stop))))
" ... "
(make-partial-string restart (lambda (i) (>= i len)) (lambda (i) (= i (sub1 len)))))))))
;array->string: java-value int int bool symbol (list value) -> string
(define (array->string value stop restart full-print? style already-printed nl? nt)
(letrec ((len (send value length))
(make-partial-string
(lambda (idx first-test second-test)
(cond
((first-test idx) "")
((second-test idx)
(string-append (format-java (send value access idx) full-print? style already-printed nl? nt)
(make-partial-string (add1 idx) first-test second-test)))
(else
(string-append (format-java (send value access idx) full-print? style already-printed nl? nt)
" "
(make-partial-string (add1 idx) first-test second-test)))))))
(if (or full-print? (< restart stop))
(format "[~a]" (make-partial-string 0 (lambda (i) (>= i len)) (lambda (i) (= i (sub1 len)))))
(format "[~a~a~a]"
(make-partial-string 0 (lambda (i) (or (>= i stop) (>= i len))) (lambda (i) (= i (sub1 stop))))
" ... "
(make-partial-string restart (lambda (i) (>= i len)) (lambda (i) (= i (sub1 len))))))))
(define (get-n-spaces n)
(cond
((= n 0) "")
(else (string-append " " (get-n-spaces (sub1 n))))))
(define (get-module-name stx) (define (get-module-name stx)
(syntax-case stx (module #%plain-module-begin) (syntax-case stx (module #%plain-module-begin)
[(module name lang (#%plain-module-begin bodies ...)) [(module name lang (#%plain-module-begin bodies ...))