diff --git a/collects/framework/private/comment-box.ss b/collects/framework/private/comment-box.ss index 92597b4f4c..f95d26172d 100644 --- a/collects/framework/private/comment-box.ss +++ b/collects/framework/private/comment-box.ss @@ -32,12 +32,6 @@ (define bm (make-object bitmap% semicolon-bitmap-path)) - (define (editor-keymap-mixin %) - (class % - (define/override (get-keymaps) - (cons (keymap:get-file) (super get-keymaps))) - (super-instantiate ()))) - (define scheme+copy-self% #f) (define (get-scheme+copy-self%) (unless scheme+copy-self% @@ -48,7 +42,9 @@ (let ([ed (new scheme+copy-self%)]) (copy-self-to ed) ed)) - (super-new)))) + (super-new) + (inherit set-max-undo-history) + (set-max-undo-history 'forever)))) scheme+copy-self%) (define -snip% diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index a7dea8f133..99dc0a430e 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -1933,6 +1933,12 @@ (λ (text evt) (send (send text get-top-level-window) search 'forward))) +(send search/replace-keymap map-function "c:return" "insert-return") +(send search/replace-keymap map-function "a:return" "insert-return") +(send search/replace-keymap add-function "insert-return" + (λ (text evt) + (send text insert "\n"))) + (send search/replace-keymap map-function "esc" "hide-search") (send search/replace-keymap add-function "hide-search" (λ (text evt) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index c527c1b5b1..fffd12ecae 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "12sep2008") +#lang scheme/base (provide stamp) (define stamp "13sep2008") diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index de41f43383..a7d9c53a47 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -23,7 +23,6 @@ improve method arity mismatch contract violation error messages? (for-syntax syntax/define) scheme/promise scheme/stxparam - scheme/stxparam-exptime mzlib/etc) (require "contract-arrow.ss" diff --git a/collects/stepper/xml-tool.ss b/collects/stepper/xml-tool.ss index f67db50bc8..c84b9ea3e6 100644 --- a/collects/stepper/xml-tool.ss +++ b/collects/stepper/xml-tool.ss @@ -203,7 +203,9 @@ (let ([t (new scheme-box-text%)]) (copy-self-to t) t)) - (super-new)))) + (super-new) + (inherit set-max-undo-history) + (set-max-undo-history 'forever)))) scheme-box-text%) (define (add-file-keymap-mixin %) @@ -311,7 +313,9 @@ (let ([t (new xml-text%)]) (copy-self-to t) t)) - (super-new)))) + (super-new) + (inherit set-max-undo-history) + (set-max-undo-history 'forever)))) xml-text%))) ;; matching-xml : (is-a?/c text) -> void diff --git a/collects/test-engine/scheme-tests.ss b/collects/test-engine/scheme-tests.ss index 3088394b70..99d0382c14 100644 --- a/collects/test-engine/scheme-tests.ss +++ b/collects/test-engine/scheme-tests.ss @@ -166,12 +166,8 @@ (send (send test-info get-info) check-failed (check->message result) (check-fail-src result) (and (incorrect-error? result) (incorrect-error-exn result))) - (list 'check-error-failed - (if (expected-error? result) - (expected-error-message result) - (incorrect-error-message result)) - error)) - (list 'check-error-succeeded error error)))) + #f) + #t))) (define (error-check pred? actual fmt) @@ -201,31 +197,10 @@ (list (maker src test-val expect range) test-val #f)])))]) (cond [(check-fail? result) (send (send test-info get-info) check-failed (check->message result) (check-fail-src result) exn?) - (render-for-stepper/fail result expect range kind)] - [else - ;; I'd like to pass the actual, but I don't have it. - (render-for-stepper/pass result-val expect range kind)]))) + #f] + [else + #t]))) -;; render-for-stepper/fail : test-fail? any/c any/c symbol? -> any/c -;; arrange the fail-result as a value that will look tolerable -;; in the stepper's list of completed expressions -(define (render-for-stepper/fail check-fail expected range kind) - (let ([displayed-result (cond [(unexpected-error? check-fail) 'error] - ;; I really want actual here, but I'm using test because the thing is - ;; created backward, afaict. - [(unequal? check-fail) (unequal-test check-fail)] - [(outofrange? check-fail) (outofrange-test check-fail)])]) - (case kind - [(check-expect) (list 'check-expect-failed displayed-result expected)] - [(check-within) (list 'check-within-failed displayed-result expected range)] - [else (error 'render-for-stepper/fail "internal error 2008052801")]))) - -;; render-for-stepper/pass : any/c any/c any/c symbol? -> any/c -(define (render-for-stepper/pass actual expected range kind) - (case kind - [(check-expect) (list 'check-expect-passed actual expected)] - [(check-within) (list 'check-within-passed actual expected range)] - [else (error 'render-for-stepper/pass "internal error 2008052802")])) (define (check->message fail) (cond diff --git a/collects/tests/stepper/through-tests.ss b/collects/tests/stepper/through-tests.ss index d99ea1d9ed..2c047807cd 100755 --- a/collects/tests/stepper/through-tests.ss +++ b/collects/tests/stepper/through-tests.ss @@ -101,7 +101,7 @@ (for-each (lambda (fn) (apply fn args)) level-fns))) (define test-mz-sequence - (lang-level-test-sequence 'scheme/base fake-mz-render-settings #t #f)) + (lang-level-test-sequence 'mzscheme fake-mz-render-settings #t #f)) (define test-beginner-sequence (lang-level-test-sequence `(lib "htdp-beginner.ss" "lang") fake-beginner-render-settings #f #t)) @@ -1354,19 +1354,14 @@ ; (custodian-shutdown-all new-custodian)) )) - (t1 check-expect - (test-bwla-to-int/lam - "(check-expect (+ 3 4) (+ 8 9)) (check-expect (+ 1 1) 2) (check-expect (+ 2 2) 4)(+ 4 5)" - `((before-after ((hilite (+ 4 5))) - ((hilite 9))) - (before-after (9 (check-expect (+ 3 4) (hilite (+ 8 9)))) - (9 (check-expect (+ 3 4) (hilite 17)))) - (before-after (9 (check-expect (hilite (+ 3 4)) 17)) - (9 (check-expect (hilite 7) 17))) - (before-after (9 (list 'check-expect-failed 7 17) (check-expect (hilite (+ 1 1)) 2)) - (9 (list 'check-expect-failed 7 17) (check-expect (hilite 2) 2))) - (before-after (9 (list 'check-expect-failed 7 17) (list 'check-expect-passed 2 2) (check-expect (hilite (+ 2 2)) 4)) - (9 (list 'check-expect-failed 7 17) (list 'check-expect-passed 2 2) (check-expect (hilite 4) 4)))))) + + (t check-expect test-bwla-to-int/lam + (check-expect (+ 3 4) (+ 8 9)) (check-expect (+ 1 1) 2) (check-expect (+ 2 2) 4) (+ 4 5) + :: {(+ 4 5)} -> {9} + :: 9 (check-expect (+ 3 4) {(+ 8 9)}) -> 9 (check-expect (+ 3 4) {17}) + :: 9 (check-expect {(+ 3 4)} 17) -> 9 (check-expect {7} 17) + :: 9 false (check-expect {(+ 1 1)} 2) -> 9 false (check-expect {2} 2) + :: 9 false true (check-expect {(+ 2 2)} 4) -> 9 false true (check-expect {4} 4)) (t1 check-within (test-bwla-to-int/lam @@ -1379,8 +1374,8 @@ (9 (check-within (+ 3 4) 18 (hilite 100)))) (before-after (9 (check-within (hilite (+ 3 4)) 18 100)) (9 (check-within (hilite 7) 18 100))) - (before-after (9 (list 'check-within-passed 7 18 100) (check-expect (hilite (+ 1 1)) 2)) - (9 (list 'check-within-passed 7 18 100) (check-expect (hilite 2) 2)))))) + (before-after (9 true (check-expect (hilite (+ 1 1)) 2)) + (9 true (check-expect (hilite 2) 2)))))) (t1 check-within-bad @@ -1392,8 +1387,8 @@ (9 (check-within (+ 3 4) (hilite 18) 0.01))) (before-after (9 (check-within (hilite (+ 3 4)) 18 0.01)) (9 (check-within (hilite 7) 18 0.01))) - (before-after (9 (list 'check-within-failed 7 18 0.01) (check-expect (hilite (+ 1 1)) 2)) - (9 (list 'check-within-failed 7 18 0.01) (check-expect (hilite 2) 2)))))) + (before-after (9 false (check-expect (hilite (+ 1 1)) 2)) + (9 false (check-expect (hilite 2) 2)))))) (let ([errmsg "rest: expected argument of type ; given ()"]) (t1 check-error @@ -1405,8 +1400,8 @@ (9 (check-error (+ (+ 3 4) (rest empty)) (hilite ,errmsg)))) (before-after (9 (check-error (+ (hilite (+ 3 4)) (rest empty)) ,errmsg)) (9 (check-error (+ (hilite 7) (rest empty)) ,errmsg))) - (before-after (9 (list 'check-error-passed ,errmsg ,errmsg) (check-expect (hilite (+ 3 1)) 4)) - (9 (list 'check-error-passed ,errmsg ,errmsg) (check-expect (hilite 4) 4))))))) + (before-after (9 true (check-expect (hilite (+ 3 1)) 4)) + (9 true (check-expect (hilite 4) 4))))))) (t1 check-error-bad (test-bwla-to-int/lam @@ -1417,8 +1412,8 @@ (9 (check-error (+ (+ 3 4) (rest empty)) (hilite "bogus")))) (before-after (9 (check-error (+ (hilite (+ 3 4)) (rest empty)) "bogus")) (9 (check-error (+ (hilite 7) (rest empty)) "bogus"))) - (before-after (9 (list 'check-error-failed "rest: expected argument of type ; given ()" "bogus") (check-expect (hilite (+ 3 1)) 4)) - (9 (list 'check-error-failed "rest: expected argument of type ; given ()" "bogus") (check-expect (hilite 4) 4)))))) + (before-after (9 false (check-expect (hilite (+ 3 1)) 4)) + (9 false (check-expect (hilite 4) 4)))))) ; uses set-render-settings! ;(reconstruct:set-render-settings! fake-beginner-render-settings) @@ -1693,4 +1688,8 @@ #;[store-steps #f] #;[show-all-steps #t]) #;(run-tests '(check-expect check-within check-within-bad check-error) #;'(#;check-expect #;check-expect-2 check-within check-within-bad check-error)) - (run-all-tests))) + (run-tests '(check-expect check-within check-error check-error-bad)) + #;(run-all-tests))) + + + diff --git a/collects/xml/text-snipclass.ss b/collects/xml/text-snipclass.ss index 345cb077c1..70a910a0d8 100644 --- a/collects/xml/text-snipclass.ss +++ b/collects/xml/text-snipclass.ss @@ -15,12 +15,25 @@ ((null? acc) (cons (car s) (chunk-string (cdr s) null))) (else (cons (list->string (reverse acc)) (cons (car s) (chunk-string (cdr s) null)))))) - (define icon - (let* ((x (make-object bitmap% 10 10)) - (y (make-object bitmap-dc% x))) - (send y set-font (make-object font% 24 'default 'normal 'normal )) - (send y draw-text "\"" 0 0) - x)) + (define get-icon + (let ([icon #f]) + (λ () + (unless icon + (let () + (define str "“”") + (define bdc (make-object bitmap-dc% (make-object bitmap% 1 1))) + (define font (send the-font-list find-or-create-font 24 'default 'normal 'normal)) + (define-values (w h _1 _2) (send bdc get-text-extent str font)) + (define bmp (make-object bitmap% (floor (inexact->exact w)) (floor (inexact->exact h)))) + (send bdc set-bitmap bmp) + (send bdc set-smoothing 'aligned) + (send bdc set-font font) + (send bdc clear) + (send bdc draw-text str 0 0) + (send bdc set-bitmap #f) + (set! icon bmp))) + icon))) + ;; marshall: writable -> string (define (marshall s) @@ -46,13 +59,15 @@ (define text-box% (class* decorated-editor-snip% (readable-snip<%>) - (define/override (make-editor) (new text:keymap%)) + (define/override (make-editor) (let ([e (new text:keymap%)]) + (send e set-max-undo-history 'forever) + e)) (define/override (make-snip) (make-object text-box%)) (inherit get-editor get-admin) (define/override (get-corner-bitmap) - icon) + (get-icon)) (define/override (get-menu) (let ([menu (new popup-menu%)])