Corrected button running into resize-box; window not closing on tab close; and
preference problem for disabling testing svn: r3141
This commit is contained in:
Kathy Gray
parent
684d69710c
commit
f72cc3c675
|
|
@ -1531,7 +1531,7 @@
|
|||
(if (eof? (get-tok next))
|
||||
(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))))
|
||||
(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)
|
||||
(cond
|
||||
((eof? tok) (parse-error "Expected a ; to end field intialization, constructor and class need }" ps pe))
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@
|
|||
(lib "tool.ss" "drscheme")
|
||||
(lib "unitsig.ss")
|
||||
(lib "framework.ss" "framework")
|
||||
(lib "string-constant.ss" "string-constants")
|
||||
(lib "class.ss")
|
||||
(lib "list.ss")
|
||||
(lib "file.ss")
|
||||
|
|
@ -289,14 +290,14 @@
|
|||
|
||||
(define buttons
|
||||
(list (make-object button%
|
||||
"Close"
|
||||
(string-constant close)
|
||||
button-panel
|
||||
(lambda (b c)
|
||||
(when (eq? 'button (send c get-event-type))
|
||||
(close-cleanup)
|
||||
(send this show #f))))
|
||||
(make-object button%
|
||||
"Close and disable testing"
|
||||
"Close and Disable Testing"
|
||||
button-panel
|
||||
(lambda (b c)
|
||||
(when (eq? 'button (send c get-event-type))
|
||||
|
|
@ -304,13 +305,15 @@
|
|||
(close-cleanup)
|
||||
(send this show #f))))
|
||||
(make-object button%
|
||||
"Dock"
|
||||
(string-constant dock)
|
||||
button-panel
|
||||
(lambda (b c)
|
||||
(when (eq? 'button (send c get-event-type))
|
||||
(send this show #f)
|
||||
(put-preferences '(profj:test-window:docked?) '(#t))
|
||||
(switch-func))))))
|
||||
(switch-func))))
|
||||
(make-object grow-box-spacer-pane% button-panel)))
|
||||
|
||||
|
||||
(define/public (update-editor e)
|
||||
(set! editor e)
|
||||
|
|
@ -341,20 +344,20 @@
|
|||
(remove))
|
||||
|
||||
(make-object button%
|
||||
"Hide"
|
||||
(string-constant hide)
|
||||
button-panel
|
||||
(lambda (b c)
|
||||
(when (eq? 'button (send c get-event-type))
|
||||
(hide))))
|
||||
(make-object button%
|
||||
"Hide and disable testing"
|
||||
"Hide and Disable Testing"
|
||||
button-panel
|
||||
(lambda (b c)
|
||||
(when (eq? 'button (send c get-event-type))
|
||||
(hide)
|
||||
(put-preferences '(profj:test-enable) '(#f)))))
|
||||
(make-object button%
|
||||
"Undock"
|
||||
(string-constant undock)
|
||||
button-panel
|
||||
(lambda (b c)
|
||||
(when (eq? 'button (send c get-event-type))
|
||||
|
|
@ -628,6 +631,8 @@
|
|||
|
||||
(define/augment (on-close)
|
||||
(when test-window
|
||||
(when (send test-window is-shown?)
|
||||
(send test-window show #f))
|
||||
(send (get-frame) deregister-test-window test-window))
|
||||
(inner (void) on-close))
|
||||
|
||||
|
|
|
|||
|
|
@ -7,7 +7,8 @@
|
|||
(lib "string-constant.ss" "string-constants")
|
||||
(lib "Object.ss" "profj" "libs" "java" "lang") (lib "array.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")
|
||||
|
||||
|
|
@ -391,8 +392,9 @@
|
|||
(send print-full set-value (profj-settings-print-full? settings)))
|
||||
(when (eq? level 'full)
|
||||
(send allow-testing set-value (profj-settings-allow-check? settings)))
|
||||
(send display-testing set-value (profj-settings-run-tests? settings))
|
||||
(if (profj-settings-run-tests? settings)
|
||||
(send display-testing set-value
|
||||
(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 enable #f))
|
||||
(install-classpath (profj-settings-classpath settings))])))
|
||||
|
|
@ -611,10 +613,10 @@
|
|||
(let inner-loop ((os objs))
|
||||
(unless (null? os)
|
||||
(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))
|
||||
(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))
|
||||
(unless (null? out)
|
||||
(write-special (car out))
|
||||
|
|
@ -679,9 +681,10 @@
|
|||
(define/public (render-value value settings port)
|
||||
(let* ((print-full? (profj-settings-print-full? 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))
|
||||
(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))
|
||||
(unless (null? out)
|
||||
(write-special (car out) port)
|
||||
|
|
@ -965,169 +968,6 @@
|
|||
(namespace-syntax-introduce ((syntax-object->datum (syntax comp))
|
||||
(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)
|
||||
(syntax-case stx (module #%plain-module-begin)
|
||||
[(module name lang (#%plain-module-begin bodies ...))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user