From 4dcb8ccdff1ec4df913b882d9e0b9241dccacb94 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 18 Feb 2009 23:14:18 +0000 Subject: [PATCH 01/66] add and use at-exp meta-language svn: r13731 original commit: 128d5287f7791c69634519438af43c0b29c35f1c --- collects/framework/main.ss | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/collects/framework/main.ss b/collects/framework/main.ss index 13817b08..f3617ea5 100644 --- a/collects/framework/main.ss +++ b/collects/framework/main.ss @@ -1,5 +1,4 @@ -#reader scribble/reader -#lang scheme/gui +#lang at-exp scheme/gui (require mred/mred-unit mred/mred-sig From fa1e88c03d193079e86f82aa5e9e7874a7d09eb2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 21 Feb 2009 13:30:01 +0000 Subject: [PATCH 02/66] fix swiatchble-button to lose its hilite state when its hidden svn: r13764 original commit: 5c7b1221186a05a9a257fccd6289357be89fc1e5 --- collects/mrlib/switchable-button.ss | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/collects/mrlib/switchable-button.ss b/collects/mrlib/switchable-button.ss index 4b56ab61..b5563438 100644 --- a/collects/mrlib/switchable-button.ss +++ b/collects/mrlib/switchable-button.ss @@ -76,8 +76,16 @@ (define/override (enable e?) (unless (equal? disabled? (not e?)) (set! disabled? (not e?)) + (set! down? #f) + (set! in? #f) (refresh))) (define/override (is-enabled?) (not disabled?)) + + (define/override (on-superwindow-show show?) + (unless show? + (set! in? #f) + (set! down? #f)) + (super on-superwindow-show show?)) (define/override (on-event evt) (cond From e9b311d060731c970b9568c5733bf1bf9829de92 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 25 Feb 2009 13:18:49 +0000 Subject: [PATCH 03/66] avoid planet dependency svn: r13832 original commit: b901c9769f85c8589fd494b570e6d57f0f1e7506 --- collects/tests/xml/info.ss | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 collects/tests/xml/info.ss diff --git a/collects/tests/xml/info.ss b/collects/tests/xml/info.ss new file mode 100644 index 00000000..a073420a --- /dev/null +++ b/collects/tests/xml/info.ss @@ -0,0 +1,3 @@ +#lang setup/infotab + +(define compile-omit-paths 'all) From 7941bc4c3e1bc02542a61659c9e0f84bc4c4440e Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 5 Mar 2009 13:29:25 +0000 Subject: [PATCH 04/66] PR 10115 svn: r13969 original commit: c063b4305c9e943ec1b1277e2872a4fe2964953d --- collects/redex/private/dot.ss | 22 ++++++++++++++++------ collects/tests/web-server/info.ss | 3 --- 2 files changed, 16 insertions(+), 9 deletions(-) delete mode 100644 collects/tests/web-server/info.ss diff --git a/collects/redex/private/dot.ss b/collects/redex/private/dot.ss index a8877dc7..3c9e770d 100644 --- a/collects/redex/private/dot.ss +++ b/collects/redex/private/dot.ss @@ -1,7 +1,7 @@ #lang scheme/gui (provide/contract [dot-positioning (-> (is-a?/c pasteboard%) string? boolean? void?)] - [find-dot (-> (or/c string? false/c))]) + [find-dot (-> (or/c path? false/c))]) (require scheme/system) @@ -11,6 +11,9 @@ (define neato-hier-label "neato – hier") (define neato-ipsep-label "neato – ipsep") +;; these paths are explicitly checked (when find-executable-path +;; fails) because starting drscheme from the finder (or the doc) +;; under mac os x generally does not get the path right. (define dot-paths '("/usr/bin" "/bin" @@ -18,10 +21,17 @@ "/opt/local/bin/")) (define (find-dot [neato? #f]) - (ormap (λ (x) (and (file-exists? (build-path x "dot")) - (file-exists? (build-path x "neato")) - (path->string (build-path x (if neato? "neato" "dot"))))) - dot-paths)) + (cond + [(and (find-executable-path "dot") + (find-executable-path "neato")) + (if neato? + (find-executable-path "neato") + (find-executable-path "dot"))] + [else + (ormap (λ (x) (and (file-exists? (build-path x "dot")) + (file-exists? (build-path x "neato")) + (build-path x (if neato? "neato" "dot")))) + dot-paths)])) (define (dot-positioning pb option overlap?) (let ([info (snip-info pb)]) @@ -92,7 +102,7 @@ (λ () (parameterize ([current-input-port in1] [current-output-port out2]) - (system (format "~a -Tplain" (find-dot (regexp-match #rx"neato" option))))) + (system (format "~a -Tplain" (path->string (find-dot (regexp-match #rx"neato" option)))))) (close-output-port out2) (close-input-port in1))) (parse-plain in2))) diff --git a/collects/tests/web-server/info.ss b/collects/tests/web-server/info.ss deleted file mode 100644 index a073420a..00000000 --- a/collects/tests/web-server/info.ss +++ /dev/null @@ -1,3 +0,0 @@ -#lang setup/infotab - -(define compile-omit-paths 'all) From 809f38a3c9c8faa54ce167cb29d8265226e95e18 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 6 Mar 2009 16:35:04 +0000 Subject: [PATCH 05/66] a bunch of improvements to the splash screen (loads less code before the splash appears, got rid of a bunch of dynamic-requires that were not necessary, fixed the lack of special screen on prince kuhio and king kamehameha days, got rid of the flicker in the tools icons) svn: r13980 original commit: 283c1819a92df7e6949ece8eebf659aac777583c --- collects/framework/private/bday.ss | 7 +- collects/framework/private/decode.ss | 43 +++ collects/framework/private/encode.ss | 67 ++++ collects/framework/splash.ss | 554 +++++++++++++++------------ 4 files changed, 426 insertions(+), 245 deletions(-) create mode 100644 collects/framework/private/decode.ss create mode 100644 collects/framework/private/encode.ss diff --git a/collects/framework/private/bday.ss b/collects/framework/private/bday.ss index 82dbf747..72b3d33c 100644 --- a/collects/framework/private/bday.ss +++ b/collects/framework/private/bday.ss @@ -1,7 +1,6 @@ -#lang mzscheme - - (require framework/private/encode-decode) - (decode +#lang scheme/base +(require "decode.ss") +(decode \5d8f4 \10ec22010 \45aff297b02 diff --git a/collects/framework/private/decode.ss b/collects/framework/private/decode.ss new file mode 100644 index 00000000..da5f0861 --- /dev/null +++ b/collects/framework/private/decode.ss @@ -0,0 +1,43 @@ +#lang scheme/base +(require (for-syntax mzlib/inflate + scheme/base)) + +(provide decode) + +(define-syntax (decode stx) + (syntax-case stx () + [(_ arg ...) + (andmap identifier? (syntax->list (syntax (arg ...)))) + (let () + (define (decode-sexp str) + (let* ([loc + (let loop ([chars (string->list str)]) + (cond + [(null? chars) '()] + [(null? (cdr chars)) (error 'to-sexp "missing digit somewhere")] + [else (let ([fst (to-digit (car chars))] + [snd (to-digit (cadr chars))]) + (cons + (+ (* fst 16) snd) + (loop (cddr chars))))]))]) + (let-values ([(p-in p-out) (make-pipe)]) + (inflate (open-input-bytes (apply bytes loc)) p-out) + (read p-in)))) + + (define (to-digit char) + (cond + [(char<=? #\0 char #\9) + (- (char->integer char) + (char->integer #\0))] + [(char<=? #\a char #\f) + (+ 10 (- (char->integer char) + (char->integer #\a)))])) + + (define decoded + (decode-sexp + (apply + string-append + (map (λ (x) (symbol->string (syntax-e x))) + (syntax->list (syntax (arg ...))))))) + + (datum->syntax stx decoded stx))])) diff --git a/collects/framework/private/encode.ss b/collects/framework/private/encode.ss new file mode 100644 index 00000000..45084ac2 --- /dev/null +++ b/collects/framework/private/encode.ss @@ -0,0 +1,67 @@ +#lang scheme/base +(require mzlib/deflate + mzlib/match + mzlib/pretty) +(require (for-syntax mzlib/inflate + mzlib/string)) + +(provide encode-sexp + encode-module) + +(define (encode-module in-filename out-filename) + (call-with-input-file in-filename + (λ (port) + (let ([mod (read port)]) + (unless (eof-object? (read port)) + (error 'encode-module "found an extra expression")) + (match mod + [`(module ,m mzscheme ,@(bodies ...)) + (call-with-output-file out-filename + (λ (oport) + (let ([chopped (chop-up (encode-sexp `(begin ,@bodies)))]) + (fprintf oport "(module ~a mzscheme\n" m) + (fprintf oport " (require framework/private/decode)\n") + (fprintf oport " (decode ~a" (car chopped)) + (for-each (lambda (chopped) + (fprintf oport "\n ~a" chopped)) + (cdr chopped)) + (fprintf oport "))\n"))) + 'truncate 'text)] + [else (error 'encode-module "cannot parse module")]))))) + +(define (chop-up sym) + (let ([chopping-point 50]) + (let loop ([str (symbol->string sym)]) + (cond + [(<= (string-length str) chopping-point) + (list (string->symbol str))] + [else + (cons (string->symbol (substring str 0 chopping-point)) + (loop (substring str chopping-point (string-length str))))])))) + +(define (encode-sexp sexp) + (define (str->sym string) + (string->symbol + (apply + string-append + (map + (λ (x) + (to-hex x)) + (bytes->list string))))) + + (define (to-hex n) + (let ([digit->hex + (λ (d) + (cond + [(<= d 9) d] + [else (integer->char (+ d -10 (char->integer #\a)))]))]) + (cond + [(< n 16) (format "0~a" (digit->hex n))] + [else (format "~a~a" + (digit->hex (quotient n 16)) + (digit->hex (modulo n 16)))]))) + + (let ([in (open-input-string (format "~s" sexp))] + [out (open-output-bytes)]) + (deflate in out) + (str->sym (get-output-bytes out)))) diff --git a/collects/framework/splash.ss b/collects/framework/splash.ss index 656ba271..240059e0 100644 --- a/collects/framework/splash.ss +++ b/collects/framework/splash.ss @@ -1,253 +1,325 @@ +#lang scheme/base -(module splash mzscheme - (require mzlib/class - mzlib/file - mred) - - (provide get-splash-bitmap - set-splash-bitmap - get-splash-canvas - get-splash-eventspace - start-splash - shutdown-splash - close-splash - add-splash-icon - set-splash-char-observer - set-splash-paint-callback - get-splash-paint-callback - set-splash-event-callback) - - (define splash-filename #f) - (define splash-bitmap #f) - (define splash-eventspace (make-eventspace)) - - (define (get-splash-bitmap) splash-bitmap) - (define (set-splash-bitmap bm) - (set! splash-bitmap bm) - (send splash-canvas on-paint)) - (define (get-splash-canvas) splash-canvas) - (define (get-splash-eventspace) splash-eventspace) +(require scheme/class + scheme/file + scheme/gui/base) - (define (set-splash-paint-callback pc) (set! splash-paint-callback pc)) - (define (get-splash-paint-callback) splash-paint-callback) - (define (set-splash-event-callback ec) (set! splash-event-callback ec)) +(provide get-splash-bitmap + set-splash-bitmap + get-splash-canvas + get-splash-eventspace + get-splash-paint-callback + set-splash-paint-callback + start-splash + shutdown-splash + close-splash + add-splash-icon + set-splash-progress-bar? + set-splash-char-observer + set-splash-event-callback + get-splash-event-callback + get-splash-width + get-splash-height) + +(define splash-bitmap #f) +(define splash-cache-bitmap #f) +(define splash-cache-dc (make-object bitmap-dc%)) +(define splash-eventspace (make-eventspace)) + +(define (get-splash-bitmap) splash-bitmap) +(define (set-splash-bitmap bm) + (set! splash-bitmap bm) + (send splash-canvas on-paint)) +(define (get-splash-canvas) splash-canvas) +(define (get-splash-eventspace) splash-eventspace) + +(define (get-splash-paint-callback) splash-paint-callback) +(define (set-splash-paint-callback sp) + (set! splash-paint-callback sp) + (refresh-splash)) + +(define (get-splash-width) (send splash-canvas get-width)) +(define (get-splash-height) (send splash-canvas get-height)) + +(define (set-splash-event-callback cb) (set! splash-event-callback cb)) +(define (get-splash-event-callback cb) splash-event-callback) + +(define (refresh-splash) - (define (splash-paint-callback dc) - (if splash-bitmap - (send dc draw-bitmap splash-bitmap 0 0) - (send dc clear)) - (for-each (λ (icon) - (send dc draw-bitmap - (icon-bm icon) - (icon-x icon) - (icon-y icon) - 'solid - (make-object color% "black") - (send (icon-bm icon) get-loaded-mask))) - icons)) - (define (splash-event-callback evt) (void)) - - (define char-observer void) - (define (set-splash-char-observer proc) - (set! char-observer proc)) - - (define-struct icon (bm x y)) - (define icons null) - (define (add-splash-icon bm x y) - (set! icons (cons (make-icon bm x y) icons)) + (define (recompute-bitmap/refresh) + (send splash-cache-dc set-bitmap splash-cache-bitmap) + (call-splash-paint-callback splash-cache-dc) + (send splash-cache-dc set-bitmap #f) (send splash-canvas on-paint)) - (define (start-splash _splash-filename _splash-title width-default) - (set! splash-title _splash-title) - (set! splash-filename _splash-filename) - (set! splash-max-width (max 1 (splash-get-preference (get-splash-width-preference-name) width-default))) - (send gauge set-range splash-max-width) - (send splash-frame set-label splash-title) - (let/ec k - (define (no-splash) - (set! splash-bitmap #f) - (set! splash-canvas #f) - (set! splash-eventspace #f) - (k (void))) - - (unless splash-filename - (no-splash)) - (unless (file-exists? splash-filename) - (fprintf (current-error-port) "WARNING: bitmap path ~s not found~n" splash-filename) - (no-splash)) - - (set! splash-bitmap (make-object bitmap% splash-filename)) - (unless (send splash-bitmap ok?) - (fprintf (current-error-port) "WARNING: bad bitmap ~s~n" splash-filename) - (no-splash)) - - (send splash-canvas min-width (send splash-bitmap get-width)) - (send splash-canvas min-height (send splash-bitmap get-height)) - (send splash-frame center 'both) - (send splash-frame show #t) - (flush-display) (yield) (sleep) - (flush-display) (yield) (sleep))) + (cond + [(not (is-a? splash-cache-bitmap bitmap%)) (void)] + [(eq? (current-thread) (eventspace-handler-thread splash-eventspace)) + (recompute-bitmap/refresh)] + [else + (parameterize ([current-eventspace splash-eventspace]) + (queue-callback + recompute-bitmap/refresh))])) + +(define (call-splash-paint-callback dc) + (cond + [(equal? 1 (procedure-arity splash-paint-callback)) + (splash-paint-callback dc)] + [else + (splash-paint-callback dc + (send gauge get-value) + (send gauge get-range) + (get-splash-width) + (get-splash-height))]) + (for-each (λ (icon) + (send dc draw-bitmap + (icon-bm icon) + (icon-x icon) + (icon-y icon) + 'solid + (make-object color% "black") + (send (icon-bm icon) get-loaded-mask))) + icons)) + +(define (set-splash-progress-bar? b?) + (send gauge-panel change-children + (λ (l) (if b? (list gauge) '())))) + +(define (splash-paint-callback dc) + (if splash-bitmap + (send dc draw-bitmap splash-bitmap 0 0) + (send dc clear))) + +(define (splash-event-callback evt) (void)) + +(define char-observer void) +(define (set-splash-char-observer proc) + (set! char-observer proc)) + +(define-struct icon (bm x y)) +(define icons null) +(define (add-splash-icon bm x y) + (set! icons (cons (make-icon bm x y) icons)) + (refresh-splash)) + +(define (start-splash splash-draw-spec _splash-title width-default) + (set! splash-title _splash-title) + (set! splash-max-width (max 1 (splash-get-preference (get-splash-width-preference-name) width-default))) + (send gauge set-range splash-max-width) + (send splash-frame set-label splash-title) + (let/ec k + (define (no-splash) + (set! splash-bitmap #f) + (set! splash-canvas #f) + (set! splash-eventspace #f) + (k (void))) - (define splash-title "no title") - - (define splash-current-width 0) - - (define (get-splash-width-preference-name) - (string->symbol (format "plt:~a-splash-max-width" splash-title))) - (define splash-max-width 1) - - (define (close-splash) - (unless (= splash-max-width splash-current-width) - (splash-set-preference (get-splash-width-preference-name) (max 1 splash-current-width))) - (set! quit-on-close? #f) - (when splash-frame - (send splash-frame show #f))) - - (define (shutdown-splash) - (set! splash-load-handler (λ (old-load f expected) (old-load f expected)))) - - (define funny? - (let ([date (seconds->date (current-seconds))]) - (and (with-handlers ([exn:fail:filesystem? (λ (x) #f)]) - (collection-path "icons") - #t) - (= (date-day date) 25) - (= (date-month date) 12)))) - - (define (splash-load-handler old-load f expected) - (let ([finalf (splitup-path f)]) - (set! splash-current-width (+ splash-current-width 1)) - (when (<= splash-current-width splash-max-width) - (send gauge set-value splash-current-width)) - (old-load f expected))) - - (let-values ([(make-compilation-manager-load/use-compiled-handler - manager-trace-handler) - (if (or (getenv "PLTDRCM") - (getenv "PLTDRDEBUG")) - (parameterize ([current-namespace (make-namespace)]) - (values - (dynamic-require 'compiler/cm 'make-compilation-manager-load/use-compiled-handler) - (dynamic-require 'compiler/cm 'manager-trace-handler))) - (values #f #f))]) + (cond + [(or (path? splash-draw-spec) + (string? splash-draw-spec)) + (unless (file-exists? splash-draw-spec) + (fprintf (current-error-port) "WARNING: bitmap path ~s not found~n" splash-draw-spec) + (no-splash)) + + (set! splash-bitmap (make-object bitmap% splash-draw-spec)) + (unless (send splash-bitmap ok?) + (fprintf (current-error-port) "WARNING: bad bitmap ~s~n" splash-draw-spec) + (no-splash)) + + (send splash-canvas min-width (send splash-bitmap get-width)) + (send splash-canvas min-height (send splash-bitmap get-height)) + (set! splash-cache-bitmap (make-object bitmap% + (send splash-bitmap get-width) + (send splash-bitmap get-height)))] + [(and (vector? splash-draw-spec) + (procedure? (vector-ref splash-draw-spec 0)) + (number? (vector-ref splash-draw-spec 1)) + (number? (vector-ref splash-draw-spec 2))) + (set! splash-paint-callback (vector-ref splash-draw-spec 0)) + (send splash-canvas min-width (vector-ref splash-draw-spec 1)) + (send splash-canvas min-height (vector-ref splash-draw-spec 2)) + (set! splash-cache-bitmap (make-object bitmap% + (vector-ref splash-draw-spec 1) + (vector-ref splash-draw-spec 2)))] + [(not splash-draw-spec) + (no-splash)] + [else + (fprintf (current-error-port) + "WARNING: unknown splash spec: ~s" splash-draw-spec) + (no-splash)]) - (current-load - (let ([old-load (current-load)]) - (λ (f expected) - (splash-load-handler old-load f expected)))) - - (when (and make-compilation-manager-load/use-compiled-handler + (refresh-splash) + (send splash-frame center 'both) + (send splash-frame show #t) + (flush-display) (yield) (sleep) + (flush-display) (yield) (sleep))) + +(define splash-title "no title") + +(define splash-current-width 0) + +(define (get-splash-width-preference-name) + (string->symbol (format "plt:~a-splash-max-width" splash-title))) +(define splash-max-width 1) + +(define (close-splash) + (unless (= splash-max-width splash-current-width) + (splash-set-preference (get-splash-width-preference-name) (max 1 splash-current-width))) + (set! quit-on-close? #f) + (when splash-frame + (send splash-frame show #f))) + +(define (shutdown-splash) + (set! splash-load-handler (λ (old-load f expected) (old-load f expected)))) + +(define funny? + (let ([date (seconds->date (current-seconds))]) + (and (with-handlers ([exn:fail:filesystem? (λ (x) #f)]) + (collection-path "icons") + #t) + (= (date-day date) 25) + (= (date-month date) 12)))) + +(define (splash-load-handler old-load f expected) + (let ([finalf (splitup-path f)]) + (set! splash-current-width (+ splash-current-width 1)) + (when (<= splash-current-width splash-max-width) + (send gauge set-value splash-current-width) + (unless (member gauge (send gauge-panel get-children)) + ;; when the gauge is not visible, we'll redraw the canvas + (refresh-splash))) + (old-load f expected))) + +(let-values ([(make-compilation-manager-load/use-compiled-handler manager-trace-handler) - (printf "PLTDRCM/PLTDRDEBUG: reinstalling CM load handler after setting splash load handler\n") - (current-load/use-compiled (make-compilation-manager-load/use-compiled-handler)) - (when (or (equal? (getenv "PLTDRCM") "trace") - (equal? (getenv "PLTDRDEBUG") "trace")) - (printf "PLTDRCM/PLTDRDEBUG: reinstalling CM trace handler after setting splash load handler\n") - (manager-trace-handler - (λ (x) (display "2: ") (display x) (newline)))))) + (if (or (getenv "PLTDRCM") + (getenv "PLTDRDEBUG")) + (parameterize ([current-namespace (make-base-namespace)]) + (values + (dynamic-require 'compiler/cm 'make-compilation-manager-load/use-compiled-handler) + (dynamic-require 'compiler/cm 'manager-trace-handler))) + (values #f #f))]) - (define funny-gauge% - (class canvas% - (inherit get-dc min-width min-height stretchable-width stretchable-height) - (field - [funny-value 0] - [funny-bitmap - (make-object bitmap% (build-path (collection-path "icons") "touch.bmp"))] - [max-value 1]) + (current-load + (let ([old-load (current-load)]) + (λ (f expected) + (splash-load-handler old-load f expected)))) + + (when (and make-compilation-manager-load/use-compiled-handler + manager-trace-handler) + (printf "PLTDRCM/PLTDRDEBUG: reinstalling CM load handler after setting splash load handler\n") + (current-load/use-compiled (make-compilation-manager-load/use-compiled-handler)) + (when (or (equal? (getenv "PLTDRCM") "trace") + (equal? (getenv "PLTDRDEBUG") "trace")) + (printf "PLTDRCM/PLTDRDEBUG: reinstalling CM trace handler after setting splash load handler\n") + (manager-trace-handler + (λ (x) (display "2: ") (display x) (newline)))))) - [define/public set-range (λ (r) (set! max-value r))] - [define/public set-value - (λ (new-value) - (let* ([before-x - (floor (* (send funny-bitmap get-width) (/ funny-value max-value)))] - [after-x - (ceiling (* (send funny-bitmap get-width) (/ new-value max-value)))] - [width (- after-x before-x)]) - (send (get-dc) draw-line - (+ before-x 2) 0 - (+ width 2) 0) - (send (get-dc) draw-line - (+ before-x 2) (+ (send funny-bitmap get-height) 4) - (+ width 2) (+ (send funny-bitmap get-height) 4)) - (send (get-dc) draw-bitmap-section funny-bitmap - (+ 2 before-x) 2 - before-x 0 - width (send funny-bitmap get-height))) - (set! funny-value new-value))] +(define funny-gauge% + (class canvas% + (inherit get-dc min-width min-height stretchable-width stretchable-height) + (field + [funny-value 0] + [funny-bitmap + (make-object bitmap% (build-path (collection-path "icons") "touch.bmp"))] + [max-value 1]) + + (define/public (get-range) max-value) + (define/public (get-value) funny-value) + + [define/public set-range (λ (r) (set! max-value r))] + [define/public set-value + (λ (new-value) + (let* ([before-x + (floor (* (send funny-bitmap get-width) (/ funny-value max-value)))] + [after-x + (ceiling (* (send funny-bitmap get-width) (/ new-value max-value)))] + [width (- after-x before-x)]) + (send (get-dc) draw-line + (+ before-x 2) 0 + (+ width 2) 0) + (send (get-dc) draw-line + (+ before-x 2) (+ (send funny-bitmap get-height) 4) + (+ width 2) (+ (send funny-bitmap get-height) 4)) + (send (get-dc) draw-bitmap-section funny-bitmap + (+ 2 before-x) 2 + before-x 0 + width (send funny-bitmap get-height))) + (set! funny-value new-value))] + + [define/override (on-paint) + (let ([dc (get-dc)]) + (send dc clear) + (send dc draw-rectangle 0 0 + (+ (send funny-bitmap get-width) 4) + (+ (send funny-bitmap get-height) 4)) + (send dc draw-bitmap-section funny-bitmap + 2 2 0 0 + (* (send funny-bitmap get-width) (/ funny-value max-value)) + (send funny-bitmap get-height)))] + + (super-instantiate ()) + (min-width (+ (send funny-bitmap get-width) 4)) + (min-height (+ (send funny-bitmap get-height) 4)) + (stretchable-width #f) + (stretchable-height #f))) - [define/override (on-paint) - (let ([dc (get-dc)]) - (send dc clear) - (send dc draw-rectangle 0 0 - (+ (send funny-bitmap get-width) 4) - (+ (send funny-bitmap get-height) 4)) - (send dc draw-bitmap-section funny-bitmap - 2 2 0 0 - (* (send funny-bitmap get-width) (/ funny-value max-value)) - (send funny-bitmap get-height)))] +(define (splash-get-preference name default) + (get-preference + name + (λ () + default))) +(define (splash-set-preference name value) + (put-preferences (list name) (list value))) - (super-instantiate ()) - (min-width (+ (send funny-bitmap get-width) 4)) - (min-height (+ (send funny-bitmap get-height) 4)) - (stretchable-width #f) - (stretchable-height #f))) - - (define (splash-get-preference name default) - (get-preference - name - (λ () - default))) - (define (splash-set-preference name value) - (put-preferences (list name) (list value))) - - (define (splitup-path f) - (let*-values ([(absf) (if (relative-path? f) - (build-path (current-directory) f) - f)] - [(base name _1) (split-path absf)]) - - (if base - (let-values ([(base2 name2 _2) (split-path base)]) - (if base2 - (let-values ([(base3 name3 _2) (split-path base2)]) - (build-path name3 name2 name)) - (build-path name2 name))) - name))) - - (define quit-on-close? #t) - - (define splash-frame% - (class frame% - (define/augment (on-close) - (when quit-on-close? - (exit))) - (super-new))) - - (define splash-canvas% - (class canvas% - (inherit get-dc) - (define/override (on-char evt) (char-observer evt)) - (define/override (on-paint) (splash-paint-callback (get-dc))) - (define/override (on-event evt) (splash-event-callback evt)) - (super-new))) - - (define splash-frame - (parameterize ([current-eventspace splash-eventspace]) - (instantiate splash-frame% () - (label splash-title) - (style '(no-resize-border))))) - (send splash-frame set-alignment 'center 'center) - - (define panel (make-object vertical-pane% splash-frame)) - (define splash-canvas (make-object splash-canvas% panel)) - (define h-panel (make-object horizontal-pane% panel)) - (define gauge - (if funny? - (make-object funny-gauge% h-panel) - (make-object gauge% #f splash-max-width h-panel '(horizontal)))) - (send panel stretchable-width #f) - (send panel stretchable-height #f) - (send h-panel set-alignment 'center 'top) - (send splash-canvas focus) - (send splash-canvas stretchable-width #f) - (send splash-canvas stretchable-height #f)) +(define (splitup-path f) + (let*-values ([(absf) (if (relative-path? f) + (build-path (current-directory) f) + f)] + [(base name _1) (split-path absf)]) + + (if base + (let-values ([(base2 name2 _2) (split-path base)]) + (if base2 + (let-values ([(base3 name3 _2) (split-path base2)]) + (build-path name3 name2 name)) + (build-path name2 name))) + name))) + +(define quit-on-close? #t) + +(define splash-frame% + (class frame% + (define/augment (on-close) + (when quit-on-close? + (exit))) + (super-new))) + +(define splash-canvas% + (class canvas% + (inherit get-client-size get-dc) + (define/override (on-char evt) (char-observer evt)) + (define/override (on-paint) (send (get-dc) draw-bitmap splash-cache-bitmap 0 0)) + (define/override (on-event evt) (splash-event-callback evt)) + (super-new))) + +(define splash-frame + (parameterize ([current-eventspace splash-eventspace]) + (instantiate splash-frame% () + (label splash-title) + (style '(no-resize-border))))) +(send splash-frame set-alignment 'center 'center) + +(define panel (make-object vertical-pane% splash-frame)) +(define splash-canvas (new splash-canvas% [parent panel] [style '(no-autoclear)])) +(define gauge-panel (make-object horizontal-pane% panel)) +(define gauge + (if funny? + (make-object funny-gauge% gauge-panel) + (make-object gauge% #f splash-max-width gauge-panel '(horizontal)))) +(send panel stretchable-width #f) +(send panel stretchable-height #f) +(send gauge-panel set-alignment 'center 'top) +(send splash-canvas focus) +(send splash-canvas stretchable-width #f) +(send splash-canvas stretchable-height #f) From 0230ff84e8c178732fb1ca7ecb49832be98081d8 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 10 Mar 2009 14:38:19 +0000 Subject: [PATCH 06/66] svn: r14027 original commit: ca2dd05eca1588351b6c668865b9c334b40ee607 --- collects/framework/test.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/framework/test.ss b/collects/framework/test.ss index ce91d13b..860fe61b 100644 --- a/collects/framework/test.ss +++ b/collects/framework/test.ss @@ -352,7 +352,7 @@ [(zero? n) (error 'test:set-radio-box! "did not find ~e as a label for ~e; labels: ~a" state in-cb - (build-labels in-cb))] + (build-labels rb))] [else (let ([i (- total n)]) (if (or (string=? state (send rb get-item-label i)) (string=? state (send rb get-item-plain-label i))) From 9f376a354d011d8291ce7ed363703bd5ceca2bcb Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 10 Mar 2009 23:14:53 +0000 Subject: [PATCH 07/66] fix defclass and some scheme/gui argument schemevarfont binding svn: r14042 original commit: d8d25debcd12d27588f31015d128b4b874ca3b8d --- collects/scribblings/gui/blurbs.ss | 71 ++++++++----------- collects/scribblings/gui/button-class.scrbl | 4 +- collects/scribblings/gui/canvas-class.scrbl | 2 +- .../scribblings/gui/check-box-class.scrbl | 4 +- collects/scribblings/gui/choice-class.scrbl | 4 +- .../gui/clipboard-client-class.scrbl | 6 +- .../scribblings/gui/combo-field-class.scrbl | 4 +- collects/scribblings/gui/dialog-class.scrbl | 2 +- collects/scribblings/gui/dialog-funcs.scrbl | 8 +-- .../scribblings/gui/editor-canvas-class.scrbl | 2 +- collects/scribblings/gui/frame-class.scrbl | 2 +- collects/scribblings/gui/gauge-class.scrbl | 4 +- .../gui/group-box-panel-class.scrbl | 4 +- .../gui/horizontal-panel-class.scrbl | 4 +- collects/scribblings/gui/list-box-class.scrbl | 4 +- collects/scribblings/gui/message-class.scrbl | 4 +- collects/scribblings/gui/panel-class.scrbl | 4 +- .../scribblings/gui/pasteboard-class.scrbl | 2 +- .../scribblings/gui/radio-box-class.scrbl | 4 +- collects/scribblings/gui/slider-class.scrbl | 4 +- .../scribblings/gui/tab-panel-class.scrbl | 4 +- collects/scribblings/gui/text-class.scrbl | 2 +- .../scribblings/gui/text-field-class.scrbl | 6 +- .../gui/vertical-panel-class.scrbl | 4 +- 24 files changed, 77 insertions(+), 82 deletions(-) diff --git a/collects/scribblings/gui/blurbs.ss b/collects/scribblings/gui/blurbs.ss index d9f21aa0..9472e539 100644 --- a/collects/scribblings/gui/blurbs.ss +++ b/collects/scribblings/gui/blurbs.ss @@ -4,16 +4,18 @@ scribble/manual scribble/scheme scribble/decode - (for-label scheme/gui/base)) + (for-label scheme/gui/base) + (for-syntax scheme/base)) - (provide (except-out (all-defined-out) p)) + (provide (except-out (all-defined-out) p define-inline)) + + (define-syntax-rule (define-inline (name) body) + (define-syntax (name stx) + (datum->syntax stx 'body stx))) (define (p . l) (decode-paragraph l)) - (define (itemstyleinfo) - @elem{The @scheme[style] argument is reserved for future use.}) - (define (labelsimplestripped where what) @elem{If @litchar{&} occurs in @|where|, it is specially parsed; under Windows and X, the character @@ -83,13 +85,6 @@ (define (insertscrolldetails what) @elem{@|what| editor's display is scrolled to show the new selection @techlink{position}.}) - (define (insertdetails what) - @elem{If @scheme[end] is - not @scheme['same], then the region from @scheme[start] to @scheme[end] is - replaced with the text. @insertmovedetails[@scheme[end]]. If @scheme[scroll-ok?] is not @scheme[#f] - @insertscrolldetails[@elem{and @scheme[start] is the same as the - current caret @techlink{position}, then the}]}) - (define (insertmovedetails what) @elem{If the insertion @techlink{position} is before or equal to the selection's start/end @techlink{position}, then the selection's @@ -143,13 +138,6 @@ information@|details|, even if the editor currently has delayed refreshing (see (define seesniporderdiscuss @elem{See @secref["tb:miaoverview"] for information about snip order in pasteboards.}) - (define (clipboardtypes) - @elem{The @scheme[format] string is typically four capital letters. (Under - Mac OS X, only four characters for @scheme[format] are ever used.) For - example, @scheme["TEXT"] is the name of the UTF-8-encoded string format. New - format names can be used to communicate application- and - platform-specific data formats.}) - (define PrintNote (make-splice (list @@ -170,37 +158,40 @@ information@|details|, even if the editor currently has delayed refreshing (see (define LineNumbering @elem{Lines are numbered starting with @scheme[0].}) (define ParagraphNumbering @elem{Paragraphs are numbered starting with @scheme[0].}) - (define (italicptyStyleNote) - @elem{The @scheme[style] argument is provided for future extensions. Currently, @scheme[style] must be the empty list.}) + (define (italicptyStyleNote style) + @elem{The @|style| argument is provided for future extensions. Currently, @|style| must be the empty list.}) - (define (HVLabelNote what) - @elem{If @scheme[style] includes @scheme['vertical-label], then the @|what| is - created with a label above the control; if @scheme[style] does not include + (define (HVLabelNote style what) + @elem{If @|style| includes @scheme['vertical-label], then the @|what| is + created with a label above the control; if @|style| does not include @scheme['vertical-label] (and optionally includes @scheme['horizontal-label]), then the label is created to the left of the @|what|.}) - (define (DeletedStyleNote what) - @elem{If @scheme[style] includes @scheme['deleted], then the @|what| is created as hidden, + (define (DeletedStyleNote style parent what) + @elem{If @|style| includes @scheme['deleted], then the @|what| is created as hidden, and it does not affect its parent's geometry; the @|what| can be made active later by calling - @scheme[parent]'s @method[area-container<%> add-child] method.}) + @|parent|'s @method[area-container<%> add-child] method.}) - (define (InStyleListNote) - @elem{The editor's style list must contain @scheme[style], otherwise + (define (InStyleListNote style) + @elem{The editor's style list must contain @style, otherwise the style is not changed. See also @xmethod[style-list% convert].}) - (define (FontKWs) @elem{The @scheme[font] argument determines the font for the control.}) - (define (FontLabelKWs) @elem{The @scheme[font] argument determines the font for the control content, - and @scheme[label-font] determines the font for the control label.}) + (define (FontKWs font) @elem{The @|font| argument determines the font for the control.}) + (define (FontLabelKWs font label-font) @elem{The @|font| argument determines the font for the control content, + and @|label-font| determines the font for the control label.}) - (define (WindowKWs) @elem{For information about the @scheme[enabled] argument, see @scheme[window<%>].}) - (define (SubareaKWs) @elem{For information about the @scheme[horiz-margin] and @scheme[vert-margin] - arguments, see @scheme[subarea<%>].}) - (define (AreaContKWs) @elem{For information about the @scheme[border], @scheme[spacing], and @scheme[alignment] - arguments, see @scheme[area-container<%>].}) + (define (WindowKWs enabled) @elem{For information about the @|enabled| argument, see @scheme[window<%>].}) + (define-inline (SubareaKWs) + @elem{For information about the @scheme[horiz-margin] and @scheme[vert-margin] + arguments, see @scheme[subarea<%>].}) + (define-inline (AreaContKWs) + @elem{For information about the @scheme[border], @scheme[spacing], and @scheme[alignment] + arguments, see @scheme[area-container<%>].}) - (define (AreaKWs) @elem{For information about the - @scheme[min-width], @scheme[min-height], @scheme[stretchable-width], and - @scheme[stretchable-height] arguments, see @scheme[area<%>].}) + (define-inline (AreaKWs) + @elem{For information about the + @scheme[min-width], @scheme[min-height], @scheme[stretchable-width], and + @scheme[stretchable-height] arguments, see @scheme[area<%>].}) (define MismatchExn @elem{an @scheme[exn:fail:contract] exception is raised}) diff --git a/collects/scribblings/gui/button-class.scrbl b/collects/scribblings/gui/button-class.scrbl index 6065cf4b..fc145c38 100644 --- a/collects/scribblings/gui/button-class.scrbl +++ b/collects/scribblings/gui/button-class.scrbl @@ -50,9 +50,9 @@ The @scheme[callback] procedure is called (with the event type If @scheme[style] includes @scheme['border], the button is drawn with a special border that indicates to the user that it is the default action button (see @method[top-level-window<%> -on-traverse-char]). @DeletedStyleNote{button} +on-traverse-char]). @DeletedStyleNote[@scheme[style] @scheme[parent]]{button} -@FontKWs[] @WindowKWs[] @SubareaKWs[] @AreaKWs[]} +@FontKWs[@scheme[font]] @WindowKWs[@scheme[enabled]] @SubareaKWs[] @AreaKWs[]} @defmethod[#:mode override diff --git a/collects/scribblings/gui/canvas-class.scrbl b/collects/scribblings/gui/canvas-class.scrbl index b82ee55d..027b591e 100644 --- a/collects/scribblings/gui/canvas-class.scrbl +++ b/collects/scribblings/gui/canvas-class.scrbl @@ -86,7 +86,7 @@ The @scheme[gl-config] argument determines properties of an OpenGL @xmethod[dc<%> get-gl-context]. -@WindowKWs[] @SubareaKWs[] @AreaKWs[] +@WindowKWs[@scheme[enabled]] @SubareaKWs[] @AreaKWs[] } diff --git a/collects/scribblings/gui/check-box-class.scrbl b/collects/scribblings/gui/check-box-class.scrbl index c701b94a..a2e9c760 100644 --- a/collects/scribblings/gui/check-box-class.scrbl +++ b/collects/scribblings/gui/check-box-class.scrbl @@ -35,12 +35,12 @@ Creates a check box with a string or bitmap label. @bitmaplabeluse[label] The @scheme[callback] procedure is called (with the event type @indexed-scheme['check-box]) whenever the user clicks the check box. -@DeletedStyleNote{check box} +@DeletedStyleNote[@scheme[style] @scheme[parent]]{check box} If @scheme[value] is true, it is passed to @method[check-box% set-value] so that the box is initially checked. -@FontKWs[] @WindowKWs[] @SubareaKWs[] @AreaKWs[] +@FontKWs[@scheme[font]] @WindowKWs[@scheme[enabled]] @SubareaKWs[] @AreaKWs[] diff --git a/collects/scribblings/gui/choice-class.scrbl b/collects/scribblings/gui/choice-class.scrbl index 356013f9..ee8d405f 100644 --- a/collects/scribblings/gui/choice-class.scrbl +++ b/collects/scribblings/gui/choice-class.scrbl @@ -49,7 +49,7 @@ The @scheme[callback] procedure is called (with the event type @indexed-scheme['choice]) when the user selects a choice item (or re-selects the currently selected item). -@HVLabelNote{choice item} @DeletedStyleNote{choice item} +@HVLabelNote[@scheme[style]]{choice item} @DeletedStyleNote[@scheme[style] @scheme[parent]]{choice item} By default, the first choice (if any) is initially selected. If @scheme[selection] is positive, it is passed to @@ -57,7 +57,7 @@ By default, the first choice (if any) is initially selected. If must be less than the length of @scheme[choices], it can be @scheme[0] when @scheme[choices] is empty. -@FontKWs[] @WindowKWs[] @SubareaKWs[] @AreaKWs[] +@FontKWs[@scheme[font]] @WindowKWs[@scheme[enabled]] @SubareaKWs[] @AreaKWs[] }} diff --git a/collects/scribblings/gui/clipboard-client-class.scrbl b/collects/scribblings/gui/clipboard-client-class.scrbl index 3ad8deab..60d6dd78 100644 --- a/collects/scribblings/gui/clipboard-client-class.scrbl +++ b/collects/scribblings/gui/clipboard-client-class.scrbl @@ -24,7 +24,11 @@ Creates a clipboard client that supports no data formats. Adds a new data format name to the list supported by the clipboard client. -@clipboardtypes[] +The @scheme[format] string is typically four capital letters. (Under + Mac OS X, only four characters for @scheme[format] are ever used.) + For example, @scheme["TEXT"] is the name of the UTF-8-encoded string + format. New format names can be used to communicate application- and + platform-specific data formats. } diff --git a/collects/scribblings/gui/combo-field-class.scrbl b/collects/scribblings/gui/combo-field-class.scrbl index fcbbbe41..c2b0a74f 100644 --- a/collects/scribblings/gui/combo-field-class.scrbl +++ b/collects/scribblings/gui/combo-field-class.scrbl @@ -55,9 +55,9 @@ If @scheme[init-value] is not @scheme[""], the minimum width of the text item is made wide enough to show @scheme[init-value]. Otherwise, a built-in default width is selected. -@HVLabelNote{combo} @DeletedStyleNote{combo}. +@HVLabelNote[@scheme[style]]{combo} @DeletedStyleNote[@scheme[style] @scheme[parent]]{combo}. -@FontKWs[] @WindowKWs[] @SubareaKWs[] @AreaKWs[] +@FontKWs[@scheme[font]] @WindowKWs[@scheme[enabled]] @SubareaKWs[] @AreaKWs[] } diff --git a/collects/scribblings/gui/dialog-class.scrbl b/collects/scribblings/gui/dialog-class.scrbl index 4cb1ca73..6cebd990 100644 --- a/collects/scribblings/gui/dialog-class.scrbl +++ b/collects/scribblings/gui/dialog-class.scrbl @@ -75,7 +75,7 @@ Even if the dialog is not shown, a few notification events may be resources (e.g., memory) cannot be reclaimed until some events are handled, or the dialog's eventspace is shut down. -@WindowKWs[] @AreaContKWs[] @AreaKWs[] +@WindowKWs[@scheme[enabled]] @AreaContKWs[] @AreaKWs[] } @defmethod[#:mode override diff --git a/collects/scribblings/gui/dialog-funcs.scrbl b/collects/scribblings/gui/dialog-funcs.scrbl index b5e60df5..9392e74f 100644 --- a/collects/scribblings/gui/dialog-funcs.scrbl +++ b/collects/scribblings/gui/dialog-funcs.scrbl @@ -422,7 +422,7 @@ Lets the user select a color though the platform-specific dialog if possible. If @scheme[init-color] is provided, the dialog is initialized to the given color. -@italicptyStyleNote[] +@italicptyStyleNote[@scheme[style]] The result is @scheme[#f] if the user cancels the dialog, the selected color otherwise. @@ -443,7 +443,7 @@ Lets the user select a font though the platform-specific dialog if possible. If @scheme[init-font] is provided, the dialog is initialized to the given font. -@italicptyStyleNote[] +@italicptyStyleNote[@scheme[style]] The result is @scheme[#f] if the user cancels the dialog, the selected font otherwise. @@ -465,7 +465,7 @@ Lets the user select a PostScript configuration though a (modal) the given configuration, otherwise the current configuration from @scheme[current-ps-setup] is used. -@italicptyStyleNote[] +@italicptyStyleNote[@scheme[style]] The result is @scheme[#f] if the user cancels the dialog, , a @scheme[ps-setup%] object that encapsulates the selected PostScript @@ -494,7 +494,7 @@ The @scheme[parent] argument is used as the parent window for a dialog if configuration from @scheme[current-ps-setup] is used. -@italicptyStyleNote[] +@italicptyStyleNote[@scheme[style]] The result is @scheme[#f] if the user cancels the dialog, a @scheme[ps-setup%] object that encapsulates the selected diff --git a/collects/scribblings/gui/editor-canvas-class.scrbl b/collects/scribblings/gui/editor-canvas-class.scrbl index c9991181..1048923f 100644 --- a/collects/scribblings/gui/editor-canvas-class.scrbl +++ b/collects/scribblings/gui/editor-canvas-class.scrbl @@ -93,7 +93,7 @@ If @scheme[horizontal-inset] is not @scheme[5], it is passed on to the @scheme[vertical-inset] is not @scheme[5], it is passed on to the @method[editor-canvas% vertical-inset] method. -@WindowKWs[] @SubareaKWs[] @AreaKWs[] +@WindowKWs[@scheme[enabled]] @SubareaKWs[] @AreaKWs[] } diff --git a/collects/scribblings/gui/frame-class.scrbl b/collects/scribblings/gui/frame-class.scrbl index 421afeb3..8ad79d40 100644 --- a/collects/scribblings/gui/frame-class.scrbl +++ b/collects/scribblings/gui/frame-class.scrbl @@ -112,7 +112,7 @@ Even if the frame is not shown, a few notification events may be resources (e.g., memory) cannot be reclaimed until some events are handled, or the frame's eventspace is shut down. -@WindowKWs[] @AreaContKWs[] @AreaKWs[] +@WindowKWs[@scheme[enabled]] @AreaContKWs[] @AreaKWs[] } diff --git a/collects/scribblings/gui/gauge-class.scrbl b/collects/scribblings/gui/gauge-class.scrbl index a9f1f4a0..a5f1ea3d 100644 --- a/collects/scribblings/gui/gauge-class.scrbl +++ b/collects/scribblings/gui/gauge-class.scrbl @@ -37,9 +37,9 @@ The @scheme[range] argument is an integer specifying the maximum value of The @scheme[style] list must include either @scheme['horizontal], specifying a horizontal gauge, or @scheme['vertical], specifying - a vertical gauge. @HVLabelNote{gauge} @DeletedStyleNote{gauge} + a vertical gauge. @HVLabelNote[@scheme[style]]{gauge} @DeletedStyleNote[@scheme[style] @scheme[parent]]{gauge} -@FontKWs[] @WindowKWs[] @SubareaKWs[] @AreaKWs[] +@FontKWs[@scheme[font]] @WindowKWs[@scheme[enabled]] @SubareaKWs[] @AreaKWs[] diff --git a/collects/scribblings/gui/group-box-panel-class.scrbl b/collects/scribblings/gui/group-box-panel-class.scrbl index 4f7593ef..ad813385 100644 --- a/collects/scribblings/gui/group-box-panel-class.scrbl +++ b/collects/scribblings/gui/group-box-panel-class.scrbl @@ -31,9 +31,9 @@ Unlike most panel classes, a group-box panel's horizontal and vertical Creates a group pane whose title is @scheme[label]. -@DeletedStyleNote{group panel} +@DeletedStyleNote[@scheme[style] @scheme[parent]]{group panel} -@FontKWs[] @WindowKWs[] @SubareaKWs[] @AreaKWs[] +@FontKWs[@scheme[font]] @WindowKWs[@scheme[enabled]] @SubareaKWs[] @AreaKWs[] }} diff --git a/collects/scribblings/gui/horizontal-panel-class.scrbl b/collects/scribblings/gui/horizontal-panel-class.scrbl index 19cfdaf9..03e61668 100644 --- a/collects/scribblings/gui/horizontal-panel-class.scrbl +++ b/collects/scribblings/gui/horizontal-panel-class.scrbl @@ -24,9 +24,9 @@ A horizontal panel arranges its subwindows in a single row. See also If the @scheme['border] style is specified, the window is created with a thin border (only in this case, the client size of the panel may be - less than its total size). @DeletedStyleNote{panel} + less than its total size). @DeletedStyleNote[@scheme[style] @scheme[parent]]{panel} -@WindowKWs[] @SubareaKWs[] @AreaContKWs[] @AreaKWs[] +@WindowKWs[@scheme[enabled]] @SubareaKWs[] @AreaContKWs[] @AreaKWs[] } @defmethod[(set-orientation [horizontal? boolean?]) void?]{ diff --git a/collects/scribblings/gui/list-box-class.scrbl b/collects/scribblings/gui/list-box-class.scrbl index 486872ec..15c940f7 100644 --- a/collects/scribblings/gui/list-box-class.scrbl +++ b/collects/scribblings/gui/list-box-class.scrbl @@ -83,13 +83,13 @@ The @scheme['multiple] and @scheme['extended] styles determine a user can deselect the (sole) selected item in a @scheme['single] list box. -@HVLabelNote{list box} @DeletedStyleNote{list box} +@HVLabelNote[@scheme[style]]{list box} @DeletedStyleNote[@scheme[style] @scheme[parent]]{list box} If @scheme[selection] is an integer, it is passed to @method[list-control<%> set-selection] to set the initial selection. The @scheme[selection] must be less than the length of @scheme[choices]. -@FontLabelKWs[] @WindowKWs[] @SubareaKWs[] @AreaKWs[] +@FontLabelKWs[@scheme[font] @scheme[label-font]] @WindowKWs[@scheme[enabled]] @SubareaKWs[] @AreaKWs[] } diff --git a/collects/scribblings/gui/message-class.scrbl b/collects/scribblings/gui/message-class.scrbl index f3aa0693..fbde073e 100644 --- a/collects/scribblings/gui/message-class.scrbl +++ b/collects/scribblings/gui/message-class.scrbl @@ -33,9 +33,9 @@ Creates a string or bitmap message initially showing @scheme[label]. @labelsimplestripped[(scheme label) @elem{message}] -@DeletedStyleNote{message} +@DeletedStyleNote[@scheme[style] @scheme[parent]]{message} -@FontKWs[] @WindowKWs[] @SubareaKWs[] @AreaKWs[] +@FontKWs[@scheme[font]] @WindowKWs[@scheme[enabled]] @SubareaKWs[] @AreaKWs[] If @scheme[auto-resize] is not @scheme[#f], then automatic resizing is initially enanbled (see @method[message% auto-resize]), and the diff --git a/collects/scribblings/gui/panel-class.scrbl b/collects/scribblings/gui/panel-class.scrbl index 35c703da..5b0e3333 100644 --- a/collects/scribblings/gui/panel-class.scrbl +++ b/collects/scribblings/gui/panel-class.scrbl @@ -33,9 +33,9 @@ A @scheme[panel%] object has a degenerate placement strategy for If the @scheme['border] style is specified, the window is created with a thin border (only in this case, the client size of the panel may be - less than its total size). @DeletedStyleNote{panel} + less than its total size). @DeletedStyleNote[@scheme[style] @scheme[parent]]{panel} -@WindowKWs[] @SubareaKWs[] @AreaContKWs[] @AreaKWs[] +@WindowKWs[@scheme[enabled]] @SubareaKWs[] @AreaContKWs[] @AreaKWs[] }} diff --git a/collects/scribblings/gui/pasteboard-class.scrbl b/collects/scribblings/gui/pasteboard-class.scrbl index a836a968..3b602137 100644 --- a/collects/scribblings/gui/pasteboard-class.scrbl +++ b/collects/scribblings/gui/pasteboard-class.scrbl @@ -468,7 +468,7 @@ Changes the style of @scheme[style] to a specific style or by applying a style delta. If @scheme[snip] is @scheme[#f], then all currently selected snips are changed. See also @xmethod[editor<%> change-style]. -When a @scheme[style] is provided: @InStyleListNote[] +When a @scheme[style] is provided: @InStyleListNote[@scheme[style]] } diff --git a/collects/scribblings/gui/radio-box-class.scrbl b/collects/scribblings/gui/radio-box-class.scrbl index 323b38e9..a9bc3275 100644 --- a/collects/scribblings/gui/radio-box-class.scrbl +++ b/collects/scribblings/gui/radio-box-class.scrbl @@ -61,13 +61,13 @@ The @scheme[callback] procedure is called (with the event type The @scheme[style] argument must include either @scheme['vertical] for a collection of radio buttons vertically arranged, or @scheme['horizontal] for a horizontal arrangement. - @HVLabelNote{radio box} @DeletedStyleNote{radio box} + @HVLabelNote[@scheme[style]]{radio box} @DeletedStyleNote[@scheme[style] @scheme[parent]]{radio box} By default, the first radio button is initially selected. If @scheme[selection] is positive, it is passed to @method[radio-box% set-selection] to set the initial radio button selection. -@FontKWs[] @WindowKWs[] @SubareaKWs[] @AreaKWs[] +@FontKWs[@scheme[font]] @WindowKWs[@scheme[enabled]] @SubareaKWs[] @AreaKWs[] } diff --git a/collects/scribblings/gui/slider-class.scrbl b/collects/scribblings/gui/slider-class.scrbl index e547dd6f..d0dfc059 100644 --- a/collects/scribblings/gui/slider-class.scrbl +++ b/collects/scribblings/gui/slider-class.scrbl @@ -52,9 +52,9 @@ The @scheme[style] argument must include either @scheme['vertical] for a vertical slider, or @scheme['horizontal] for a horizontal slider. If @scheme[style] includes @scheme['plain], the slider does not display numbers for its range and current value to the user. - @HVLabelNote{slider} @DeletedStyleNote{slider} + @HVLabelNote[@scheme[style]]{slider} @DeletedStyleNote[@scheme[style] @scheme[parent]]{slider} -@FontKWs[] @WindowKWs[] @SubareaKWs[] @AreaKWs[] +@FontKWs[@scheme[font]] @WindowKWs[@scheme[enabled]] @SubareaKWs[] @AreaKWs[] } diff --git a/collects/scribblings/gui/tab-panel-class.scrbl b/collects/scribblings/gui/tab-panel-class.scrbl index 6743928c..524126b1 100644 --- a/collects/scribblings/gui/tab-panel-class.scrbl +++ b/collects/scribblings/gui/tab-panel-class.scrbl @@ -47,9 +47,9 @@ The @scheme[callback] procedure is called (with the event type @indexed-scheme['tab-panel]) when the user changes the tab selection. If the @scheme[style] list includes @scheme['no-border], no border is - drawn around the panel content. @DeletedStyleNote{tab panel} + drawn around the panel content. @DeletedStyleNote[@scheme[style] @scheme[parent]]{tab panel} -@FontKWs[] @WindowKWs[] @SubareaKWs[] @AreaKWs[] +@FontKWs[@scheme[font]] @WindowKWs[@scheme[enabled]] @SubareaKWs[] @AreaKWs[] diff --git a/collects/scribblings/gui/text-class.scrbl b/collects/scribblings/gui/text-class.scrbl index 8f0f46d3..4f5b7890 100644 --- a/collects/scribblings/gui/text-class.scrbl +++ b/collects/scribblings/gui/text-class.scrbl @@ -344,7 +344,7 @@ Changes the style for a region in the editor by applying a style delta then @method[editor<%> set-modified] is not called after applying the style change. -When @scheme[style] is provided: @InStyleListNote[] +When @scheme[style] is provided: @InStyleListNote[@scheme[style]] } diff --git a/collects/scribblings/gui/text-field-class.scrbl b/collects/scribblings/gui/text-field-class.scrbl index 3456d20a..408395d2 100644 --- a/collects/scribblings/gui/text-field-class.scrbl +++ b/collects/scribblings/gui/text-field-class.scrbl @@ -86,10 +86,10 @@ The style must contain exactly one of @scheme['single] or autowrapping is enabled. A multiple-line text field always has a vertical scrollbar. The @scheme['password] style indicates that the field should draw each character of its content using a generic - symbol instead of the actual character. @HVLabelNote{text field} - @DeletedStyleNote{text field}. + symbol instead of the actual character. @HVLabelNote[@scheme[style]]{text field} + @DeletedStyleNote[@scheme[style] @scheme[parent]]{text field}. -@FontKWs[] @WindowKWs[] @SubareaKWs[] @AreaKWs[] +@FontKWs[@scheme[font]] @WindowKWs[@scheme[enabled]] @SubareaKWs[] @AreaKWs[] } diff --git a/collects/scribblings/gui/vertical-panel-class.scrbl b/collects/scribblings/gui/vertical-panel-class.scrbl index 9397854f..2a92ee9f 100644 --- a/collects/scribblings/gui/vertical-panel-class.scrbl +++ b/collects/scribblings/gui/vertical-panel-class.scrbl @@ -27,9 +27,9 @@ A vertical panel arranges its subwindows in a single column. See If the @scheme['border] style is specified, the window is created with a thin border (only in this case, the client size of the panel may be - less than its total size). @DeletedStyleNote{panel} + less than its total size). @DeletedStyleNote[@scheme[style] @scheme[parent]]{panel} -@WindowKWs[] @SubareaKWs[] @AreaContKWs[] @AreaKWs[] +@WindowKWs[@scheme[enabled]] @SubareaKWs[] @AreaContKWs[] @AreaKWs[] } @defmethod[(set-orientation [horizontal? boolean?]) void?]{ From 5dad29321fc683149afdfdcee635a7c15a686f89 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 17 Mar 2009 19:57:04 +0000 Subject: [PATCH 08/66] HISTORY updates through 4.1.5: merge to 4.1.5 svn: r14157 original commit: 19196868769ce178df2746952151baf6de6ab9bb --- doc/release-notes/mred/HISTORY.txt | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/doc/release-notes/mred/HISTORY.txt b/doc/release-notes/mred/HISTORY.txt index 5776acfd..1fa020db 100644 --- a/doc/release-notes/mred/HISTORY.txt +++ b/doc/release-notes/mred/HISTORY.txt @@ -1,4 +1,10 @@ -Version 4.1.4, January 2008 +Version 4.1.5, March 2009 + +Minor bug fixes + +---------------------------------------------------------------------- + +Version 4.1.4, January 2009 Changed image-snip% to implement equal<%> From 840fc6a46ab7b5357432ce8b6f99e961cfdb829d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 25 Mar 2009 20:28:33 +0000 Subject: [PATCH 09/66] fix doc typos svn: r14280 original commit: f9190e5c1cdc140cb62cea6bee6b35f1305013dc --- collects/scribblings/framework/text.scrbl | 4 ++-- collects/scribblings/gui/pasteboard-class.scrbl | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/scribblings/framework/text.scrbl b/collects/scribblings/framework/text.scrbl index b60f88e1..cece0eb2 100644 --- a/collects/scribblings/framework/text.scrbl +++ b/collects/scribblings/framework/text.scrbl @@ -444,7 +444,7 @@ changes. Ensures the snip is as wide as the viewing area. This method should only be called by - @method[canvas:wide-snip<%> add-tall-snip]. + @xmethod[canvas:wide-snip<%> add-wide-snip]. } @defmethod*[(((add-tall-snip (snip (is-a?/c snip%))) void))]{ @@ -452,7 +452,7 @@ viewing area of the editor changes. This method should only be called by - @method[canvas:wide-snip<%> add-tall-snip]. + @xmethod[canvas:wide-snip<%> add-tall-snip]. } } diff --git a/collects/scribblings/gui/pasteboard-class.scrbl b/collects/scribblings/gui/pasteboard-class.scrbl index 3b602137..71279086 100644 --- a/collects/scribblings/gui/pasteboard-class.scrbl +++ b/collects/scribblings/gui/pasteboard-class.scrbl @@ -667,7 +667,7 @@ Returns whether selection dots are drawn around the edge of selected Inserts @scheme[snip] at @techlink{location} @math{(@scheme[x], @scheme[y])} just in front of - @scheme[before]. (@|seesniporderdiscuss|) If @scheme[before] is nor + @scheme[before]. (@|seesniporderdiscuss|) If @scheme[before] is not provided or is @scheme[#f], then @scheme[snip] is inserted behind all other snips. If @scheme[x] and @scheme[y] are not provided, the snip is added at @math{(0, 0)}. From 039107441091af0b17b895a408e4db2b2749e8df Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 26 Mar 2009 12:00:13 +0000 Subject: [PATCH 10/66] typo svn: r14288 original commit: 34c14d27f55e08c3d47882b7f7334dd2fada1343 --- collects/scribblings/gui/text-class.scrbl | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/collects/scribblings/gui/text-class.scrbl b/collects/scribblings/gui/text-class.scrbl index 4f5b7890..038d2b90 100644 --- a/collects/scribblings/gui/text-class.scrbl +++ b/collects/scribblings/gui/text-class.scrbl @@ -350,8 +350,8 @@ When @scheme[style] is provided: @InStyleListNote[@scheme[style]] @defmethod[#:mode extend - (copy [extend? any/c] - [time (and/c exact? integer?)] + (copy [extend? any/c #f] + [time (and/c exact? integer?) 0] [start (or/c exact-nonnegative-integer? (one/of 'start)) 'start] [end (or/c exact-nonnegative-integer? (one/of 'end)) 'end]) void?]{ @@ -381,8 +381,8 @@ In addition to the default @xmethod[editor<%> copy-self-to] work, @defmethod[#:mode override - (cut [extend? any/c] - [time (and/c exact? integer?)] + (cut [extend? any/c #f] + [time (and/c exact? integer?) 0] [start (or/c exact-nonnegative-integer? (one/of 'start)) 'start] [end (or/c exact-nonnegative-integer? (one/of 'end)) 'end]) void?]{ @@ -1547,7 +1547,7 @@ If the paragraph starts with invisible @techlink{item}s and @scheme[visible?] is @defmethod[#:mode override - (paste [time (and/c exact? integer?)] + (paste [time (and/c exact? integer?) 0] [start (or/c exact-nonnegative-integer? (one/of 'end)) 'end] [end (or/c exact-nonnegative-integer? (one/of 'same)) 'same]) void?]{ From d10ddc1348d9d4f15912aa5edb17c993a025d748 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 27 Mar 2009 13:47:12 +0000 Subject: [PATCH 11/66] Sam and I did some work to allow automatic inferred linking in (define-values/)invoke-unit/infer. svn: r14315 original commit: 99aac7d7455c3ce9189d038f781558b6bd696424 --- collects/framework/main.ss | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/collects/framework/main.ss b/collects/framework/main.ss index f3617ea5..5b23fcfc 100644 --- a/collects/framework/main.ss +++ b/collects/framework/main.ss @@ -49,13 +49,10 @@ (prefix scheme: framework:scheme-class^) (prefix main: framework:main-class^)) -(define-compound-unit/infer framework+mred@ - (import) +(define-values/invoke-unit/infer (export framework^) (link standard-mred@ framework@)) -(define-values/invoke-unit/infer framework+mred@) - (provide/doc (parameter-doc text:autocomplete-append-after From a3e487d90a82c4ddad60b974787e8c053a91bb40 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 31 Mar 2009 04:53:23 +0000 Subject: [PATCH 12/66] always keep the lables right-side-up svn: r14373 original commit: fb3846cb4367b04ce42794c729162a5aa5c4f337 --- collects/mrlib/graph.ss | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/collects/mrlib/graph.ss b/collects/mrlib/graph.ss index 9a36a277..0382e89a 100644 --- a/collects/mrlib/graph.ss +++ b/collects/mrlib/graph.ss @@ -614,9 +614,12 @@ [arrow-end-y (send point3 get-y)] [arrowhead-end (make-rectangular arrow-end-x arrow-end-y)] [vec (- arrowhead-end from-pt)] + [angle (- (angle vec))] + [flip? (not (< (/ pi -2) angle (/ pi 2)))] + [angle (if flip? (+ angle pi) angle)] [middle (+ from-pt (- (* 1/2 vec) - (make-polar (/ text-len 2) (angle vec))))]) + (make-polar (/ text-len 2) (- angle))))]) (when (> (sqrt (+ (sqr (- arrow-end-x from-x)) (sqr (- arrow-end-y from-y)))) text-len) @@ -625,7 +628,7 @@ (+ dy (imag-part middle)) #f 0 - (- (angle vec)))))))])))))))) + angle)))))])))))))) (define (set-pen/brush from-link dark-lines?) (send dc set-brush From 774ed881a7672cb51562f5f7b46804d56aabfa5d Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 31 Mar 2009 05:57:44 +0000 Subject: [PATCH 13/66] added set-links-label! to change a link label svn: r14374 original commit: 202134e45c35f9e83d6c802e987c043990087d1e --- collects/mrlib/graph.ss | 19 ++++++++++++++++++- 1 file changed, 18 insertions(+), 1 deletion(-) diff --git a/collects/mrlib/graph.ss b/collects/mrlib/graph.ss index 0382e89a..92368275 100644 --- a/collects/mrlib/graph.ss +++ b/collects/mrlib/graph.ss @@ -83,7 +83,13 @@ number? (or/c false/c string?) . -> . - void?))) + void?)) + (set-links-label! + ((is-a?/c graph-snip<%>) + (is-a?/c graph-snip<%>) + (or/c false/c string?) + . -> . + void?))) (define self-offset 10) @@ -140,6 +146,8 @@ label) (send parent add-child child) (send child add-parent parent dark-pen light-pen dark-brush light-brush dark-text light-text dx dy label)) + (define (set-links-label! parent child label) + (send child set-parent-link-label parent label)) (define graph-snip-mixin (mixin ((class->interface snip%)) (graph-snip<%>) @@ -155,6 +163,15 @@ (field (parent-links null)) (define/public (get-parent-links) parent-links) (define/public (get-parents) (map link-snip parent-links)) + (define/public (set-parent-link-label parent label) + (let ([parent-link + (cond [(memf (lambda (parent-link) + (eq? (link-snip parent-link) parent)) + parent-links) + => car] + [else #f])]) + (when parent-link + (set-link-label! parent-link label)))) (define/public add-parent (case-lambda [(parent) (add-parent parent #f #f #f #f)] From 391108e3b98081ab5b822c7c473f2ea212a922c9 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 31 Mar 2009 12:13:47 +0000 Subject: [PATCH 14/66] document set-links-label! svn: r14381 original commit: 33c30e7dd7a7c70685efc4502b473c5a00f7b2a5 --- collects/mrlib/graph.ss | 21 ++++++++++--------- .../scribblings/graph/graph-snip-intf.scrbl | 14 ++++++++++++- collects/mrlib/scribblings/graph/graph.scrbl | 9 ++++++++ 3 files changed, 33 insertions(+), 11 deletions(-) diff --git a/collects/mrlib/graph.ss b/collects/mrlib/graph.ss index 92368275..a2517c29 100644 --- a/collects/mrlib/graph.ss +++ b/collects/mrlib/graph.ss @@ -146,9 +146,10 @@ label) (send parent add-child child) (send child add-parent parent dark-pen light-pen dark-brush light-brush dark-text light-text dx dy label)) + (define (set-links-label! parent child label) (send child set-parent-link-label parent label)) - + (define graph-snip-mixin (mixin ((class->interface snip%)) (graph-snip<%>) (field (children null)) @@ -163,15 +164,6 @@ (field (parent-links null)) (define/public (get-parent-links) parent-links) (define/public (get-parents) (map link-snip parent-links)) - (define/public (set-parent-link-label parent label) - (let ([parent-link - (cond [(memf (lambda (parent-link) - (eq? (link-snip parent-link) parent)) - parent-links) - => car] - [else #f])]) - (when parent-link - (set-link-label! parent-link label)))) (define/public add-parent (case-lambda [(parent) (add-parent parent #f #f #f #f)] @@ -202,6 +194,15 @@ parent parent-links (lambda (parent parent-link) (eq? (link-snip parent-link) parent)))))) + (define/public (set-parent-link-label parent label) + (let ([parent-link + (cond [(memf (lambda (parent-link) + (eq? (link-snip parent-link) parent)) + parent-links) + => car] + [else #f])]) + (when parent-link + (set-link-label! parent-link label)))) (define/public (has-self-loop?) (memq this (get-children))) diff --git a/collects/mrlib/scribblings/graph/graph-snip-intf.scrbl b/collects/mrlib/scribblings/graph/graph-snip-intf.scrbl index ef630047..c31ca443 100644 --- a/collects/mrlib/scribblings/graph/graph-snip-intf.scrbl +++ b/collects/mrlib/scribblings/graph/graph-snip-intf.scrbl @@ -60,4 +60,16 @@ this snip. Removes a parent snip from this snip. Be sure to remove this snip as a child from the argument, too. -}} +} + + +@defmethod[(set-parent-link-label [parent (is-a?/c graph-snip<%>)] + [label (or/c false/c string/)]) + void?]{ + + Changes the label on the edge going to the @scheme[parent] to be + @scheme[label]. Ignored if no such egde exists. + +} + +} diff --git a/collects/mrlib/scribblings/graph/graph.scrbl b/collects/mrlib/scribblings/graph/graph.scrbl index ecb08768..46b28cbb 100644 --- a/collects/mrlib/scribblings/graph/graph.scrbl +++ b/collects/mrlib/scribblings/graph/graph.scrbl @@ -74,3 +74,12 @@ used.} Like @scheme[add-links], but with extra @scheme[dark-text] and @scheme[light-text] arguments to set the colors of the label.} + +@defproc[(set-links-label! [parent (is-a?/c graph-snip<%>)] + [child (is-a?/c graph-snip<%>)] + [label (or/c string? false/c)]) + void?]{ + +Changes the label on the edge going from @scheme[child] to +@scheme[parent] to be @scheme[label]. If there is no existing edge +between the two nodes, then nothing happens.} From a70f5f39b10cdded3edcb487874f76171f83f641 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 31 Mar 2009 12:16:39 +0000 Subject: [PATCH 15/66] set-links-label! -> set-link-label svn: r14382 original commit: 3d04c4ce109bcf1c960d4663f28423613b1f053a --- collects/mrlib/graph.ss | 4 ++-- collects/mrlib/scribblings/graph/graph.scrbl | 6 +++--- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/collects/mrlib/graph.ss b/collects/mrlib/graph.ss index a2517c29..cd3d368f 100644 --- a/collects/mrlib/graph.ss +++ b/collects/mrlib/graph.ss @@ -84,7 +84,7 @@ (or/c false/c string?) . -> . void?)) - (set-links-label! + (set-link-label ((is-a?/c graph-snip<%>) (is-a?/c graph-snip<%>) (or/c false/c string?) @@ -147,7 +147,7 @@ (send parent add-child child) (send child add-parent parent dark-pen light-pen dark-brush light-brush dark-text light-text dx dy label)) - (define (set-links-label! parent child label) + (define (set-link-label parent child label) (send child set-parent-link-label parent label)) (define graph-snip-mixin diff --git a/collects/mrlib/scribblings/graph/graph.scrbl b/collects/mrlib/scribblings/graph/graph.scrbl index 46b28cbb..3f568925 100644 --- a/collects/mrlib/scribblings/graph/graph.scrbl +++ b/collects/mrlib/scribblings/graph/graph.scrbl @@ -75,9 +75,9 @@ used.} Like @scheme[add-links], but with extra @scheme[dark-text] and @scheme[light-text] arguments to set the colors of the label.} -@defproc[(set-links-label! [parent (is-a?/c graph-snip<%>)] - [child (is-a?/c graph-snip<%>)] - [label (or/c string? false/c)]) +@defproc[(set-link-label [parent (is-a?/c graph-snip<%>)] + [child (is-a?/c graph-snip<%>)] + [label (or/c string? false/c)]) void?]{ Changes the label on the edge going from @scheme[child] to From 5fb3efd7d029c1cf2dc608b90085345f175c1667 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 31 Mar 2009 12:22:29 +0000 Subject: [PATCH 16/66] added remove-links svn: r14383 original commit: a58ba38c52e81c6bc710ca4c5db00b287388d4b6 --- collects/mrlib/graph.ss | 13 ++++++++++++- .../mrlib/scribblings/graph/graph-snip-intf.scrbl | 6 ++++-- collects/mrlib/scribblings/graph/graph.scrbl | 6 ++++++ 3 files changed, 22 insertions(+), 3 deletions(-) diff --git a/collects/mrlib/graph.ss b/collects/mrlib/graph.ss index cd3d368f..0da08986 100644 --- a/collects/mrlib/graph.ss +++ b/collects/mrlib/graph.ss @@ -21,7 +21,9 @@ add-parent remove-parent has-self-loop? - + + set-parent-link-label + find-shortest-path)) (define-local-member-name get-parent-links) @@ -84,6 +86,11 @@ (or/c false/c string?) . -> . void?)) + (remove-links + ((is-a?/c graph-snip<%>) + (is-a?/c graph-snip<%>) + . -> . + void?)) (set-link-label ((is-a?/c graph-snip<%>) (is-a?/c graph-snip<%>) @@ -147,6 +154,10 @@ (send parent add-child child) (send child add-parent parent dark-pen light-pen dark-brush light-brush dark-text light-text dx dy label)) + (define (remove-links parent child) + (send parent remove-child child) + (send child remove-parent parent)) + (define (set-link-label parent child label) (send child set-parent-link-label parent label)) diff --git a/collects/mrlib/scribblings/graph/graph-snip-intf.scrbl b/collects/mrlib/scribblings/graph/graph-snip-intf.scrbl index c31ca443..6f5827d7 100644 --- a/collects/mrlib/scribblings/graph/graph-snip-intf.scrbl +++ b/collects/mrlib/scribblings/graph/graph-snip-intf.scrbl @@ -51,6 +51,8 @@ this snip. Removes a child snip from this snip. Be sure to remove this snip as a parent from the argument, too. + Instead of calling this method, consider using the + @scheme[remove-links] function. } @@ -59,7 +61,8 @@ this snip. Removes a parent snip from this snip. Be sure to remove this snip as a child from the argument, too. - + Instead of calling this method, consider using the + @scheme[remove-links] function. } @@ -69,7 +72,6 @@ this snip. Changes the label on the edge going to the @scheme[parent] to be @scheme[label]. Ignored if no such egde exists. - } } diff --git a/collects/mrlib/scribblings/graph/graph.scrbl b/collects/mrlib/scribblings/graph/graph.scrbl index 3f568925..d5c3324c 100644 --- a/collects/mrlib/scribblings/graph/graph.scrbl +++ b/collects/mrlib/scribblings/graph/graph.scrbl @@ -75,6 +75,12 @@ used.} Like @scheme[add-links], but with extra @scheme[dark-text] and @scheme[light-text] arguments to set the colors of the label.} +@defproc[(remove-links [parent (is-a?/c graph-snip<%>)] + [child (is-a?/c graph-snip<%>)]) + void?]{ + +Disconnects a parent snip from a child snip within a pasteboard.} + @defproc[(set-link-label [parent (is-a?/c graph-snip<%>)] [child (is-a?/c graph-snip<%>)] [label (or/c string? false/c)]) From c995b241b31c57e9591546c423de1cf5eb7ce5e7 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 31 Mar 2009 14:54:40 +0000 Subject: [PATCH 17/66] added set-flip-labels? svn: r14386 original commit: c5d2342999d2e1c4ab0de7df04b90a8678a25e67 --- collects/mrlib/graph.ss | 26 +++++++++---------- .../graph/graph-pasteboard-intf.scrbl | 11 ++++++++ 2 files changed, 24 insertions(+), 13 deletions(-) diff --git a/collects/mrlib/graph.ss b/collects/mrlib/graph.ss index 0da08986..0bf6e091 100644 --- a/collects/mrlib/graph.ss +++ b/collects/mrlib/graph.ss @@ -252,6 +252,7 @@ set-arrowhead-params get-arrowhead-params set-draw-arrow-heads? + set-flip-labels? draw-edges)) (define-struct rect (left top right bottom)) @@ -264,23 +265,21 @@ [edge-labels? #t]) (define draw-arrow-heads? #t) + (define flip-labels? #t) (inherit refresh get-admin) - (define/public (set-draw-arrow-heads? x) - (set! draw-arrow-heads? x) + (define (refresh*) (let ([admin (get-admin)]) (when admin - (let ([xb (box 0)] - [yb (box 0)] - [wb (box 0)] - [hb (box 0)]) + (let ([xb (box 0)] [yb (box 0)] [wb (box 0)] [hb (box 0)]) (send admin get-view xb yb wb hb) (send admin needs-update - (unbox xb) - (unbox yb) - (unbox wb) - (unbox hb)))))) - - + (unbox xb) (unbox yb) (unbox wb) (unbox hb)))))) + (define/public (set-draw-arrow-heads? x) + (set! draw-arrow-heads? x) + (refresh*)) + (define/public (set-flip-labels? x) + (set! flip-labels? x) + (refresh*)) (define arrowhead-angle-width (* 1/4 pi)) (define arrowhead-short-side 8) @@ -644,7 +643,8 @@ [arrowhead-end (make-rectangular arrow-end-x arrow-end-y)] [vec (- arrowhead-end from-pt)] [angle (- (angle vec))] - [flip? (not (< (/ pi -2) angle (/ pi 2)))] + [flip? (and flip-labels? + (not (< (/ pi -2) angle (/ pi 2))))] [angle (if flip? (+ angle pi) angle)] [middle (+ from-pt (- (* 1/2 vec) diff --git a/collects/mrlib/scribblings/graph/graph-pasteboard-intf.scrbl b/collects/mrlib/scribblings/graph/graph-pasteboard-intf.scrbl index c1ef5629..a55866f0 100644 --- a/collects/mrlib/scribblings/graph/graph-pasteboard-intf.scrbl +++ b/collects/mrlib/scribblings/graph/graph-pasteboard-intf.scrbl @@ -45,6 +45,17 @@ different nodes. } +@defmethod[(set-draw-arrow-heads? [flip-labels? any/c]) + void?]{ + +Sets a boolean controlling whether or not arrow labels are flipped so +the are always right-side-up. + +This setting does not affect self-links---only links between two +different nodes. + +} + @defmethod[(draw-edges [dc (is-a?/c dc<%>)] [left real?] [top real?] From e5e234462cc5df48535502bcee1d66e390328c4f Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 31 Mar 2009 14:56:55 +0000 Subject: [PATCH 18/66] clarification svn: r14388 original commit: 0adc7a50f2ace401f74851c07780d09c526b4784 --- collects/mrlib/scribblings/graph/graph-pasteboard-intf.scrbl | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/collects/mrlib/scribblings/graph/graph-pasteboard-intf.scrbl b/collects/mrlib/scribblings/graph/graph-pasteboard-intf.scrbl index a55866f0..77e49104 100644 --- a/collects/mrlib/scribblings/graph/graph-pasteboard-intf.scrbl +++ b/collects/mrlib/scribblings/graph/graph-pasteboard-intf.scrbl @@ -49,7 +49,10 @@ different nodes. void?]{ Sets a boolean controlling whether or not arrow labels are flipped so -the are always right-side-up. +the are always right-side-up. Note that if there are two nodes with +edges going from the first to the second, and from the second to the +first, and the two have labels, then this should be turned off or the +labels will appear in the same space. This setting does not affect self-links---only links between two different nodes. From abd9eaa6b95417ba3af577b1394e50349ae49b51 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 1 Apr 2009 06:10:22 +0000 Subject: [PATCH 19/66] typo svn: r14397 original commit: 28d35ebb6acaef8b30242aff237e23d99c2823fa --- collects/mrlib/scribblings/graph/graph-pasteboard-intf.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mrlib/scribblings/graph/graph-pasteboard-intf.scrbl b/collects/mrlib/scribblings/graph/graph-pasteboard-intf.scrbl index 77e49104..00b32bbe 100644 --- a/collects/mrlib/scribblings/graph/graph-pasteboard-intf.scrbl +++ b/collects/mrlib/scribblings/graph/graph-pasteboard-intf.scrbl @@ -45,7 +45,7 @@ different nodes. } -@defmethod[(set-draw-arrow-heads? [flip-labels? any/c]) +@defmethod[(set-flip-labels? [flip-labels? any/c]) void?]{ Sets a boolean controlling whether or not arrow labels are flipped so From 9d63c4e0723c52ed18835fa896faeb765d18c805 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 5 Apr 2009 17:46:20 +0000 Subject: [PATCH 20/66] Changed @itemize{...} to @itemize[...] (done after comparing the doc tree and verifying that there are no changes). (Also fixed a few bugs that were in the code) svn: r14427 original commit: c0a8a0122200209e38dff1959d79b58f847814db --- collects/framework/main.ss | 30 +++++----- .../mrlib/scribblings/hierlist/hierlist.scrbl | 4 +- .../scribblings/interactive-value-port.scrbl | 4 +- collects/mrlib/scribblings/path-dialog.scrbl | 4 +- collects/scribblings/framework/color.scrbl | 8 +-- collects/scribblings/framework/frame.scrbl | 4 +- .../scribblings/framework/framework.scrbl | 8 +-- .../scribblings/gui/area-container-intf.scrbl | 4 +- collects/scribblings/gui/area-intf.scrbl | 4 +- collects/scribblings/gui/blurbs.ss | 4 +- collects/scribblings/gui/canvas-class.scrbl | 4 +- collects/scribblings/gui/canvas-intf.scrbl | 4 +- .../scribblings/gui/control-event-class.scrbl | 4 +- collects/scribblings/gui/control-intf.scrbl | 4 +- collects/scribblings/gui/cursor-class.scrbl | 4 +- collects/scribblings/gui/dialog-class.scrbl | 4 +- collects/scribblings/gui/dialog-funcs.scrbl | 16 ++--- .../scribblings/gui/editor-admin-class.scrbl | 4 +- .../scribblings/gui/editor-canvas-class.scrbl | 8 +-- collects/scribblings/gui/editor-funcs.scrbl | 8 +-- collects/scribblings/gui/editor-intf.scrbl | 20 +++---- .../scribblings/gui/editor-overview.scrbl | 48 +++++++-------- .../gui/editor-wordbreak-map-class.scrbl | 4 +- .../scribblings/gui/eventspace-funcs.scrbl | 4 +- collects/scribblings/gui/frame-class.scrbl | 8 +-- collects/scribblings/gui/guide.scrbl | 4 +- .../scribblings/gui/key-event-class.scrbl | 8 +-- collects/scribblings/gui/keymap-class.scrbl | 16 ++--- collects/scribblings/gui/list-box-class.scrbl | 4 +- .../scribblings/gui/list-control-intf.scrbl | 4 +- collects/scribblings/gui/miscwin-funcs.scrbl | 16 ++--- .../scribblings/gui/mouse-event-class.scrbl | 4 +- .../scribblings/gui/pasteboard-class.scrbl | 4 +- collects/scribblings/gui/prefs.scrbl | 4 +- .../scribblings/gui/scroll-event-class.scrbl | 4 +- .../gui/selectable-menu-item-intf.scrbl | 4 +- .../scribblings/gui/snip-admin-class.scrbl | 4 +- .../scribblings/gui/snip-class-class.scrbl | 4 +- collects/scribblings/gui/snip-class.scrbl | 16 ++--- .../scribblings/gui/style-delta-class.scrbl | 48 +++++++-------- collects/scribblings/gui/subarea-intf.scrbl | 4 +- collects/scribblings/gui/text-class.scrbl | 40 ++++++------- .../scribblings/gui/text-field-class.scrbl | 8 +-- .../gui/top-level-window-intf.scrbl | 8 +-- collects/scribblings/gui/win-overview.scrbl | 60 +++++++++---------- collects/scribblings/gui/window-intf.scrbl | 8 +-- 46 files changed, 245 insertions(+), 245 deletions(-) diff --git a/collects/framework/main.ss b/collects/framework/main.ss index 5b23fcfc..0f16c0fc 100644 --- a/collects/framework/main.ss +++ b/collects/framework/main.ss @@ -151,14 +151,14 @@ (name-list val-list) @{Like @scheme[put-preferences], but has more sophisticated error handling. In particular, it - @itemize{ + @itemize[ @item{waits for three consecutive failures before informing the user} @item{gives the user the opportunity to ``steal'' the lockfile after the third failure, and} @item{when failures occur, it remembers what its arguments were and if any preference save eventually succeeds, all of the - past failures are also written at that point.}}}) + past failures are also written at that point.}]}) (proc-doc/names preferences:add-panel @@ -351,7 +351,7 @@ (-> any) () @{@scheme[exit:exit] performs four actions: - @itemize{ + @itemize[ @item{sets the result of the @scheme[exit:exiting?] function to @scheme[#t].} @item{invokes the exit-callbacks, with @scheme[exit:can-exit?] if @@ -359,7 +359,7 @@ @item{invokes @scheme[exit:on-exit] and then} @item{queues a callback that calls @scheme[exit] (a mzscheme procedure) and (if @scheme[exit] returns) sets the result of - @scheme[exit:exiting?] back to @scheme[#t].}}}) + @scheme[exit:exiting?] back to @scheme[#t].}]}) (proc-doc/names exit:user-oks-exit @@ -719,22 +719,22 @@ Otherwise, it invokes the appropriate format handler to open the file (see @scheme[handler:insert-format-handler]). - @itemize{ + @itemize[ @item{If @scheme[filename] is a string, this function checks the result of @scheme[group:get-the-frame-group] to see if the @scheme[filename] is already open by a frame in the group. - @itemize{ + @itemize[ @item{If so, it returns the frame.} @item{If not, this function calls @scheme[handler:find-format-handler] with @scheme[filename]. - @itemize{ + @itemize[ @item{If a handler is found, it is applied to @scheme[filename] and it's result is the final result.} - @item{If not, @scheme[make-default] is used.}}}}} + @item{If not, @scheme[make-default] is used.}]}]} @item{If @scheme[filename] is @scheme[#f], @scheme[make-default] - is used.}}}) + is used.}]}) (parameter-doc handler:current-create-new-window @@ -966,13 +966,13 @@ @{This returns a keymap for handling standard editing operations. It binds these keys: - @itemize{ + @itemize[ @item{@scheme["z"]: undo} @item{@scheme["y"]: redo} @item{@scheme["x"]: cut} @item{@scheme["c"]: copy} @item{@scheme["v"]: paste} - @item{@scheme["a"]: select all}} + @item{@scheme["a"]: select all}] where each key is prefixed with the menu-shortcut key, based on the platform. Under unix, the shortcut is @scheme["a:"]; under windows the shortcut key is @scheme["c:"] and under MacOS, the shortcut key @@ -1055,7 +1055,7 @@ This function extends a @scheme[keymap%] with the following functions: - @itemize{ + @itemize[ @item{@mapdesc[ring-bell any] --- Rings the bell (using @scheme[bell]) and removes the search panel from the frame, if there.} @@ -1128,12 +1128,12 @@ @item{@mapdesc[end-macro key] --- Stops building a keyboard macro} @item{@mapdesc[do-macro key] --- Executes the last keyboard macro} @item{@mapdesc[toggle-overwrite key] --- Toggles overwriting - mode}} + mode}] These functions are bound to the following keys (C = control, S = shift, A = alt, M = ``meta'', D = command): - @itemize{ + @itemize[ @item{C-g : ``ring-bell''} @item{M-C-g : ``ring-bell''} @item{C-c C-g : ``ring-bell''} @@ -1213,7 +1213,7 @@ @item{MIDDLEBUTTON : ``paste-click-region''} @item{C-RIGHTBUTTON : ``copy-clipboard''} @item{INSERT : ``toggle-overwrite''} - @item{M-o : ``toggle-overwrite''}}}) + @item{M-o : ``toggle-overwrite''}]}) (proc-doc/names keymap:setup-search diff --git a/collects/mrlib/scribblings/hierlist/hierlist.scrbl b/collects/mrlib/scribblings/hierlist/hierlist.scrbl index b6af86f7..96d99afc 100644 --- a/collects/mrlib/scribblings/hierlist/hierlist.scrbl +++ b/collects/mrlib/scribblings/hierlist/hierlist.scrbl @@ -12,7 +12,7 @@ arrow that the user can click to hide or show the sub-list's items. The list control supports the following default keystrokes: -@itemize{ +@itemize[ @item{Down: move to the next entry at the current level (skipping lower levels).} @@ -24,7 +24,7 @@ The list control supports the following default keystrokes: @item{Return: open/close the current selected level (only valid for lists).} -} +] @local-table-of-contents[] diff --git a/collects/mrlib/scribblings/interactive-value-port.scrbl b/collects/mrlib/scribblings/interactive-value-port.scrbl index a4548c8c..46330874 100644 --- a/collects/mrlib/scribblings/interactive-value-port.scrbl +++ b/collects/mrlib/scribblings/interactive-value-port.scrbl @@ -14,13 +14,13 @@ Sets @scheme[port]'s display handler (via @scheme[port-display-handler]) so that when it encounters these values: -@itemize{ +@itemize[ @item{exact, real, non-integral numbers} @item{syntax objects} -} +] it uses @scheme[write-special] to send snips to the port, instead of those values. Otherwise, it behaves like the diff --git a/collects/mrlib/scribblings/path-dialog.scrbl b/collects/mrlib/scribblings/path-dialog.scrbl index 8439e536..0ab2690b 100644 --- a/collects/mrlib/scribblings/path-dialog.scrbl +++ b/collects/mrlib/scribblings/path-dialog.scrbl @@ -72,7 +72,7 @@ user to create a new directory. The @scheme[filters] argument is one of: -@itemize{ +@itemize[ @item{@scheme[(list (list _filter-name _filter-glob) ...)] --- a list of pattern names (e.g., @scheme["Scheme Files"]) and glob @@ -89,7 +89,7 @@ The @scheme[filters] argument is one of: @scheme["*.*"] under Windows and @scheme["*"] on other platforms.} -} +] The @scheme[show-file?] predicate is used to filter file paths that are shown in the dialog. The predicate is applied to the file name as diff --git a/collects/scribblings/framework/color.scrbl b/collects/scribblings/framework/color.scrbl index 48cb6018..59b53cda 100644 --- a/collects/scribblings/framework/color.scrbl +++ b/collects/scribblings/framework/color.scrbl @@ -16,7 +16,7 @@ and should return the style-name that the token should be colored. get-token takes an input port and returns the next token as 5 values: - @itemize{ + @itemize[ @item{ An unused value. This value is intended to represent the textual component of the token and may be used as such in the future.} @@ -34,12 +34,12 @@ @item{ The starting position of the token.} @item{ - The ending position of the token.}} + The ending position of the token.}] get-token will usually be implemented with a lexer using the @scheme[parser-tools/lex] library. get-token must obey the following invariants: - @itemize{ + @itemize[ @item{ Every position in the buffer must be accounted for in exactly one token.} @@ -58,7 +58,7 @@ @verbatim{" 1 2 3"} would result in a single string token modifying previous tokens. To handle these situations, get-token must treat the first line as a - single token.}} + single token.}] @scheme[pairs] is a list of different kinds of matching parens. The second value returned by get-token is compared to this list to see how the diff --git a/collects/scribblings/framework/frame.scrbl b/collects/scribblings/framework/frame.scrbl index a4ef62fd..85387802 100644 --- a/collects/scribblings/framework/frame.scrbl +++ b/collects/scribblings/framework/frame.scrbl @@ -223,7 +223,7 @@ framework)) @(require (for-label scheme/gui)) @(require If that returns @scheme[#t], it checks for one of the these three conditions: - @itemize{ + @itemize[ @item{ @scheme[exit:exiting?] returns @scheme[#t]} @@ -233,7 +233,7 @@ framework)) @(require (for-label scheme/gui)) @(require @scheme[group:get-the-frame-group], or} @item{the procedure @scheme[exit:user-oks-exit] - returns @scheme[#t].}} + returns @scheme[#t].}] If any of those conditions hold, the method returns @scheme[#t]. } diff --git a/collects/scribblings/framework/framework.scrbl b/collects/scribblings/framework/framework.scrbl index 1cf8bb46..514b3cf9 100644 --- a/collects/scribblings/framework/framework.scrbl +++ b/collects/scribblings/framework/framework.scrbl @@ -12,10 +12,10 @@ The framework provides a number of mixins, classes and functions designed to help you build a complete application program on top of the @scheme[scheme/gui] library. -@itemize{ +@itemize[ @item{@bold{Entire Framework} -@itemize{ +@itemize[ @item{@scheme[(require #, @schememodname[framework])] @@ -41,7 +41,7 @@ program on top of the @scheme[scheme/gui] library. @scheme[framework^]. It imports the @scheme[mred^] signature. } -}} +]} @item{ @bold{Test Suite Engine} @@ -85,7 +85,7 @@ This library is here for backwards compatibility. The functionality in it has moved into the framework proper, in the @secref["editor-snip"] section. } -} +] @bold{Thanks} diff --git a/collects/scribblings/gui/area-container-intf.scrbl b/collects/scribblings/gui/area-container-intf.scrbl index 75e3cc16..ae381152 100644 --- a/collects/scribblings/gui/area-container-intf.scrbl +++ b/collects/scribblings/gui/area-container-intf.scrbl @@ -7,7 +7,7 @@ An @scheme[area-container<%>] is a container @scheme[area<%>]. All @scheme[area-container<%>] classes accept the following named instantiation arguments: -@itemize{ +@itemize[ @item{@indexed-scheme[border] --- default is @scheme[0]; passed to @method[area-container<%> border]} @@ -17,7 +17,7 @@ All @scheme[area-container<%>] classes accept the following named @scheme['(center top)] for @scheme[vertical-panel%]; the list elements are passed to @method[area-container<%> set-alignment]} -} +] diff --git a/collects/scribblings/gui/area-intf.scrbl b/collects/scribblings/gui/area-intf.scrbl index 55d2a8c3..84b241fa 100644 --- a/collects/scribblings/gui/area-intf.scrbl +++ b/collects/scribblings/gui/area-intf.scrbl @@ -10,7 +10,7 @@ An @scheme[area<%>] object is either a window or a windowless All @scheme[area<%>] classes accept the following named instantiation arguments: -@itemize{ +@itemize[ @item{@indexed-scheme[min-width] --- default is the initial graphical minimum width; passed to @method[area<%> min-width]} @@ -20,7 +20,7 @@ All @scheme[area<%>] classes accept the following named instantiation @method[area<%> stretchable-width]} @item{@indexed-scheme[stretchable-height] --- default is class-specific; passed to @method[area<%> stretchable-height]} -} +] diff --git a/collects/scribblings/gui/blurbs.ss b/collects/scribblings/gui/blurbs.ss index 9472e539..72800aaa 100644 --- a/collects/scribblings/gui/blurbs.ss +++ b/collects/scribblings/gui/blurbs.ss @@ -142,10 +142,10 @@ information@|details|, even if the editor currently has delayed refreshing (see (make-splice (list @p{Be sure to use the following methods to start/end drawing:} - @itemize{@item{@method[dc<%> start-doc]} + @itemize[@item{@method[dc<%> start-doc]} @item{@method[dc<%> start-page]} @item{@method[dc<%> end-page]} - @item{@method[dc<%> end-doc]}} + @item{@method[dc<%> end-doc]}] @p{Attempts to use a drawing method outside of an active page raises an exception.}))) (define reference-doc '(lib "scribblings/reference/reference.scrbl")) diff --git a/collects/scribblings/gui/canvas-class.scrbl b/collects/scribblings/gui/canvas-class.scrbl index 027b591e..e64cfb96 100644 --- a/collects/scribblings/gui/canvas-class.scrbl +++ b/collects/scribblings/gui/canvas-class.scrbl @@ -26,7 +26,7 @@ A @scheme[canvas%] object is a general-purpose window for drawing The @scheme[style] argument indicates one or more of the following styles: -@itemize{ +@itemize[ @item{@scheme['border] --- gives the canvas a thin border} @@ -63,7 +63,7 @@ The @scheme[style] argument indicates one or more of the following styles: later by calling @scheme[parent]'s @method[area-container<%> add-child] method} -} +] The @scheme['hscroll] and @scheme['vscroll] styles create a canvas with an initially inactive scrollbar. The scrollbars are diff --git a/collects/scribblings/gui/canvas-intf.scrbl b/collects/scribblings/gui/canvas-intf.scrbl index 63a0180c..c8d3ce4f 100644 --- a/collects/scribblings/gui/canvas-intf.scrbl +++ b/collects/scribblings/gui/canvas-intf.scrbl @@ -10,7 +10,7 @@ To draw onto a canvas, get its device context (see @method[canvas<%> get-dc]). The @scheme[canvas<%>] interface is implemented by two classes: -@itemize{ +@itemize[ @item{@scheme[canvas%] --- a canvas for arbitrary drawing and event handling} @@ -18,7 +18,7 @@ The @scheme[canvas<%>] interface is implemented by two classes: @item{@scheme[editor-canvas%] --- a canvas for displaying @scheme[editor<%>] objects} -} +] @defmethod[(get-canvas-background) diff --git a/collects/scribblings/gui/control-event-class.scrbl b/collects/scribblings/gui/control-event-class.scrbl index d042473a..19123337 100644 --- a/collects/scribblings/gui/control-event-class.scrbl +++ b/collects/scribblings/gui/control-event-class.scrbl @@ -14,7 +14,7 @@ A @scheme[control-event%] object contains information about a [time-stamp (and/c exact? integer?) 0])]{ The @scheme[event-type] argument is one of the following: -@itemize{ +@itemize[ @item{@scheme['button] --- for @scheme[button%] clicks} @item{@scheme['check-box] --- for @scheme[check-box%] toggles} @item{@scheme['choice] --- for @scheme[choice%] item selections} @@ -28,7 +28,7 @@ The @scheme[event-type] argument is one of the following: @item{@scheme['menu-popdown] --- for @scheme[popup-menu%] callbacks (item selected)} @item{@scheme['menu-popdown-none] --- for @scheme[popup-menu%] callbacks (no item selected)} @item{@scheme['tab-panel] --- for @scheme[tab-panel%] tab changes} -} +] This value is extracted out of a @scheme[control-event%] object with the diff --git a/collects/scribblings/gui/control-intf.scrbl b/collects/scribblings/gui/control-intf.scrbl index d845868c..51c55a1b 100644 --- a/collects/scribblings/gui/control-intf.scrbl +++ b/collects/scribblings/gui/control-intf.scrbl @@ -5,7 +5,7 @@ The @scheme[control<%>] interface is implemented by the built-in control window classes: -@itemize{ +@itemize[ @item{@scheme[message%]} @item{@scheme[button%]} @item{@scheme[check-box%]} @@ -15,7 +15,7 @@ The @scheme[control<%>] interface is implemented by the built-in @item{@scheme[radio-box%]} @item{@scheme[choice%]} @item{@scheme[list-box%]} -} +] diff --git a/collects/scribblings/gui/cursor-class.scrbl b/collects/scribblings/gui/cursor-class.scrbl index f13b3ee3..9c24c4af 100644 --- a/collects/scribblings/gui/cursor-class.scrbl +++ b/collects/scribblings/gui/cursor-class.scrbl @@ -30,7 +30,7 @@ relative to its top-left corner. The second case creates a cursor using a stock cursor, specified as one of the following: -@itemize{ +@itemize[ @item{@scheme['arrow] --- the default cursor} @@ -60,7 +60,7 @@ as one of the following: @item{@scheme['size-nw/se] --- arrows up-left and down-right} -} +] If the cursor is created successfully, @method[cursor% ok?] returns @scheme[#t], otherwise the cursor object cannot be diff --git a/collects/scribblings/gui/dialog-class.scrbl b/collects/scribblings/gui/dialog-class.scrbl index 6cebd990..98f5e55d 100644 --- a/collects/scribblings/gui/dialog-class.scrbl +++ b/collects/scribblings/gui/dialog-class.scrbl @@ -56,7 +56,7 @@ If the @scheme[x] or @scheme[y] argument is not @scheme[#f], it The @scheme[style] flags adjust the appearance of the dialog on some platforms: -@itemize{ +@itemize[ @item{@scheme['no-caption] --- omits the title bar for the dialog (Windows)} @@ -68,7 +68,7 @@ The @scheme[style] flags adjust the appearance of the dialog on some @item{@scheme['no-sheet] --- uses a movable window for the dialog, even if a parent window is provided (Mac OS X)} -} +] Even if the dialog is not shown, a few notification events may be queued for the dialog on creation. Consequently, the new dialog's diff --git a/collects/scribblings/gui/dialog-funcs.scrbl b/collects/scribblings/gui/dialog-funcs.scrbl index 9392e74f..b1bba81d 100644 --- a/collects/scribblings/gui/dialog-funcs.scrbl +++ b/collects/scribblings/gui/dialog-funcs.scrbl @@ -190,7 +190,7 @@ Displays a message to the user in a (modal) dialog, using breaking lines. The style must include exactly one of the following: -@itemize{ +@itemize[ @item{@scheme['ok] --- the dialog only has an @onscreen{OK} button and always returns @scheme['ok].} @@ -208,7 +208,7 @@ The style must include exactly one of the following: labels, so that the user does not have to read the message text carefully to make a selection.} -} +] In addition, @scheme[style] can contain @scheme['caution] to make the dialog use a caution icon instead of the application (or generic @@ -262,7 +262,7 @@ If the user clicks the button labelled @scheme[button1-label], a @scheme[1] If @scheme[style] does not include @scheme['number-order], the order of the buttons is platform-specific, and labels should be assigned to the buttons based on their role: -@itemize{ +@itemize[ @item{Button 1 is the normal action, and it is usually the default button. For example, if the dialog has an @onscreen{OK} button, it is @@ -279,7 +279,7 @@ If @scheme[style] does not include @scheme['number-order], the order of Mac OS X, it is left-aligned in the dialog). Use this button only for three-button dialogs.} -} +] Despite the above guidelines, any combination of visible buttons is allowed in the dialog. @@ -323,13 +323,13 @@ See also @scheme[message+check-box/custom]. Like @scheme[message-box], except that -@itemize{ +@itemize[ @item{the dialog contains a check box whose label is @scheme[check-label];} @item{the result is two values: the @scheme[message-box] result, and a boolean indicating whether the box was checked; and} @item{@scheme[style] can contain @scheme['checked] to indicate that the check box should be initially checked.} -}} +]} @defproc[(message+check-box/custom [title label-string?] [message string] @@ -346,13 +346,13 @@ Like @scheme[message-box], except that (one-of/c 1 2 3 close-result)]{ Like @scheme[message-box/custom], except that -@itemize{ +@itemize[ @item{the dialog contains a check box whose label is @scheme[check-label];} @item{the result is two values: the @scheme[message-box] result, and a boolean indicating whether the box was checked; and} @item{@scheme[style] can contain @scheme['checked] to indicate that the check box should be initially checked.} -} +] diff --git a/collects/scribblings/gui/editor-admin-class.scrbl b/collects/scribblings/gui/editor-admin-class.scrbl index de64b6f3..2f6c74ef 100644 --- a/collects/scribblings/gui/editor-admin-class.scrbl +++ b/collects/scribblings/gui/editor-admin-class.scrbl @@ -264,11 +264,11 @@ If @scheme[refresh?] is not @scheme[#f], then the editor is requesting to be updated immediately. The @scheme[bias] argument is one of: -@itemize{ +@itemize[ @item{@scheme['start] --- if the range doesn't fit in the visible area, show the top-left region} @item{@scheme['none] --- no special scrolling instructions} @item{@scheme['end] --- if the range doesn't fit in the visible area, show the bottom-right region} -} +] The return value is @scheme[#t] if the @techlink{display} is scrolled, @scheme[#f] if not (either because the requested region is already diff --git a/collects/scribblings/gui/editor-canvas-class.scrbl b/collects/scribblings/gui/editor-canvas-class.scrbl index 1048923f..4f3493aa 100644 --- a/collects/scribblings/gui/editor-canvas-class.scrbl +++ b/collects/scribblings/gui/editor-canvas-class.scrbl @@ -34,7 +34,7 @@ If a canvas is initialized with @scheme[#f] for @scheme[editor], The @scheme[style] list can contain the following flags: -@itemize{ +@itemize[ @item{@scheme['no-border] --- omits a border around the canvas} @@ -73,7 +73,7 @@ The @scheme[style] list can contain the following flags: @item{@scheme['transparent] --- the canvas is ``erased'' before an update using it's parent window's background} -} +] While vertical scrolling of text editors is based on lines, horizontal scrolling and pasteboard vertical scrolling is based on a @@ -276,7 +276,7 @@ If @scheme[refresh?] is not @scheme[#f], then the editor is updated immediately after a successful scroll. The @scheme[bias] argument is one of: -@itemize{ +@itemize[ @item{@scheme['start] --- if the range doesn't fit in the visible area, show the top-left region} @@ -286,7 +286,7 @@ The @scheme[bias] argument is one of: @item{@scheme['end] --- if the range doesn't fit in the visible area, show the bottom-right region} -} +] The return value is @scheme[#t] if the @techlink{display} is scrolled, @scheme[#f] if not (either because the requested region is already visible, diff --git a/collects/scribblings/gui/editor-funcs.scrbl b/collects/scribblings/gui/editor-funcs.scrbl index 5764e33d..a735ade7 100644 --- a/collects/scribblings/gui/editor-funcs.scrbl +++ b/collects/scribblings/gui/editor-funcs.scrbl @@ -11,7 +11,7 @@ Given a @scheme[keymap%] object, the keymap is loaded with mappable functions that apply to all @scheme[editor<%>] objects: -@itemize{ +@itemize[ @item{@scheme["copy-clipboard"]} @item{@scheme["copy-append-clipboard"]} @item{@scheme["cut-clipboard"]} @@ -23,7 +23,7 @@ Given a @scheme[keymap%] object, the keymap is loaded with mappable @item{@scheme["undo"]} @item{@scheme["redo"]} @item{@scheme["select-all"]} -} +] } @@ -44,7 +44,7 @@ See also Given a @scheme[keymap%] object, the table is loaded with functions that apply to all @scheme[text%] objects: -@itemize{ +@itemize[ @item{@scheme["forward-character"]} @item{@scheme["backward-character"]} @item{@scheme["previous-line"]} @@ -85,7 +85,7 @@ Given a @scheme[keymap%] object, the table is loaded with functions @item{@scheme["delete-line"]} @item{@scheme["undo"]} @item{@scheme["redo"]} -} +] See also @scheme[add-editor-keymap-functions]. diff --git a/collects/scribblings/gui/editor-intf.scrbl b/collects/scribblings/gui/editor-intf.scrbl index 0b4e7714..1e975675 100644 --- a/collects/scribblings/gui/editor-intf.scrbl +++ b/collects/scribblings/gui/editor-intf.scrbl @@ -466,7 +466,7 @@ Returns the name of a style to be used for newly inserted text, Performs a generic edit command. The @scheme[op] argument must be a valid edit command, one of: -@itemize{ +@itemize[ @item{@scheme['undo] --- undoes the last operation} @item{@scheme['redo] --- undoes the last undo} @item{@scheme['clear] --- deletes the current selection} @@ -481,7 +481,7 @@ valid edit command, one of: @method[editor<%> on-new-box] .} @item{@scheme['insert-image] --- gets a filename from the user and inserts the image as an @techlink{item} in this editor; see also @method[editor<%> on-new-image-snip] .} -} +] If @scheme[recursive?] is not @scheme[#f], then the command is passed on to any active snips of this editor (i.e., snips which own the caret). @@ -1074,7 +1074,7 @@ prompted for a name. The possible values for @scheme[format] are listed below. A single set of @scheme[format] values are used for loading and saving files: -@itemize{ +@itemize[ @item{@scheme['guess] --- guess the format based on extension and/or contents; when saving a file, this is the same as @@ -1097,7 +1097,7 @@ extension and/or contents; when saving a file, this is the same as (@scheme[text%] only); when writing, change automatic newlines (from word-wrapping) into real carriage returns} -} +] In a @scheme[text%] instance, the format returned from @method[text% get-file-format] is always one of @scheme['standard], @scheme['text], @@ -1713,7 +1713,7 @@ The @scheme[output-mode] setting is used for Windows and Mac OS X. It using the platform-specific standard printing mechanism. The possible values are -@itemize{ +@itemize[ @item{@scheme['standard] --- print using the platform-standard mechanism (via a @scheme[printer-dc%]) under Windows and @@ -1722,7 +1722,7 @@ The @scheme[output-mode] setting is used for Windows and Mac OS X. It @item{@scheme['postscript] --- print to a PostScript file (via a @scheme[post-script-dc%])} -} +] If @scheme[parent] is not @scheme[#f], it is used as the parent window for configuration dialogs (for either PostScript or platform-standard @@ -1807,7 +1807,7 @@ The stream provides either new mappings for names in the editor's when the editor was written to the stream; see also @method[editor<%> write-to-file]). -@itemize{ +@itemize[ @item{In the former case, if the @scheme[overwrite-styles?] argument is @scheme[#f], then each style name in the loaded file that is already @@ -1818,7 +1818,7 @@ The stream provides either new mappings for names in the editor's @item{In the latter case, the editor's style list will be changed to the previously-read list.} -} +] } @@ -2105,7 +2105,7 @@ If @scheme[#f] is provided as the new owner, then the local focus is The domain of focus-setting is one of: -@itemize{ +@itemize[ @item{@scheme['immediate] --- only set the focus owner within the editor} @@ -2117,7 +2117,7 @@ The domain of focus-setting is one of: @item{@scheme['global] --- make this editor or the new focus owner get the keyboard focus among all elements in the editor's frame} -} +] @MonitorMethod[@elem{The focus state of an editor} @elem{by the system} @elem{@method[editor<%> on-focus]} @elem{focus}] diff --git a/collects/scribblings/gui/editor-overview.scrbl b/collects/scribblings/gui/editor-overview.scrbl index 896971f0..dcbb0602 100644 --- a/collects/scribblings/gui/editor-overview.scrbl +++ b/collects/scribblings/gui/editor-overview.scrbl @@ -7,7 +7,7 @@ The editor toolbox provides a foundation for two common kinds of applications: -@itemize{ +@itemize[ @item{@italic{Programs that need a sophisticated text editor} --- The simple text field control is inadequate for text-intensive @@ -19,7 +19,7 @@ The editor toolbox provides a foundation for two common kinds of lines and boxes, but many applications need an interactive canvas, where the user can drag and resize individual objects.} -} +] Both kinds of applications need an extensible editor that can handle text, images, programmer-defined items, and even embedded @@ -27,7 +27,7 @@ Both kinds of applications need an extensible editor that can handle editor toolbox therefore provides two kinds of editors via two classes: -@itemize{ +@itemize[ @item{@scheme[text%] --- in a @deftech{text editor}, items are automatically positioned in a paragraph flow.} @@ -35,7 +35,7 @@ Both kinds of applications need an extensible editor that can handle @item{@scheme[pasteboard%] --- in a @deftech{pasteboard editor}, items are explicitly positioned and dragable.} -} +] This editor architecture addresses the full range of real-world issues for an editor---including cut-and-paste, extensible file @@ -160,7 +160,7 @@ Applications that use the editor classes typically derive new versions The editor toolbox supports extensible and nestable editors by decomposing an editor assembly into three functional parts: -@itemize{ +@itemize[ @item{The @deftech{editor} itself stores the state of the text or pasteboard and handles most events and editing operations. The @@ -183,7 +183,7 @@ The editor toolbox supports extensible and nestable editors by @scheme[editor-snip%] class also acts as a display for embedded editors.} -} +] These three parts are illustrated by a simple word processor. The editor corresponds to the text document. The editor object receives @@ -275,7 +275,7 @@ Styles are hierarchical: each style is defined in terms of another style is encoded in a @deftech{style delta} (or simply @deftech{delta}). A delta encodes changes such as -@itemize{ +@itemize[ @item{change the font family to @italic{X};} @@ -285,7 +285,7 @@ Styles are hierarchical: each style is defined in terms of another @item{change everything to match the style description @italic{Z}.} -} +] Style objects are never created separately; rather, they are always created through a @deftech{style list}, an instance of the @@ -298,7 +298,7 @@ Style objects are never created separately; rather, they are always Each new style is defined in one of two ways: -@itemize{ +@itemize[ @item{A @deftech{derived style} is defined in terms of a base style and a delta. Every style (except for the root style) has a base @@ -317,7 +317,7 @@ Each new style is defined in one of two ways: character style is the shift style. However, FrameMaker allows only those two levels; with join styles support any number of levels.)} -} +] @index*['("Standard style") (list @elem{@scheme["Standard"] style})]{Usually}, when text is inserted into a text editor, it @@ -383,7 +383,7 @@ The editor file data format can be embedded within another file, and Graceful and extensible encoding of snips requires that two issues are addressed: -@itemize{ +@itemize[ @item{The encoding function for a snip can be associated with the snip itself. To convert a snip from an encoded representation (e.g., as @@ -407,7 +407,7 @@ Graceful and extensible encoding of snips requires that each editor data object has an @deftech{editor data class}, which is an instance of the @scheme[editor-data-class%] class.} -} +] Snip classes, snip data, and snip data classes solve problems related to encoding and decoding snips. In an application that has no need @@ -472,7 +472,7 @@ Just as a snip must be associated with a snip class to be decoded (see To store and load information about a snip or region in an editor: -@itemize{ +@itemize[ @item{derive new classes from @scheme[editor-data%] and @scheme[editor-data-class%].} @@ -488,7 +488,7 @@ To store and load information about a snip or region in an editor: not for file-saving encoding; see @|globaleditordatadiscuss| for information on extending the file format.} -} +] @subsection[#:tag "globaleditordata"]{Global Data: Headers and Footers} @@ -497,7 +497,7 @@ The editor file format provides for adding extra global data in special header and footer sections. To save and load special header and/or footer records: -@itemize{ +@itemize[ @item{Pick a name for each header/footer record. This name should not conflict with any other header/footer record name in use, and no one @@ -512,7 +512,7 @@ The editor file format provides for adding extra global data in @method[editor<%> read-header-from-file] and/or @method[editor<%> read-footer-from-file] methods.} -} +] When an editor is saved, the methods @method[editor<%> write-headers-to-file] and @method[editor<%> write-footers-to-file] @@ -564,7 +564,7 @@ In plain text editors, there is a simple correlation between Text can be extracted from an editor in either of two forms: -@itemize{ +@itemize[ @item{@deftech{Simple text}, where there is one character per @techlink{item}. @techlink{Item}s that are characters are mapped to @@ -582,7 +582,7 @@ Text can be extracted from an editor in either of two forms: ``flattened'' because the editor's @techlink{item}s have been reduced to a linear sequence of characters.} -} +] @section[#:tag "drawcaretinfo"]{Caret Ownership} @@ -604,7 +604,7 @@ When an editor or snip is drawn, an argument to the drawing method specifies whether the caret should be drawn with the data. This argument can be any of (in increasing order): -@itemize{ +@itemize[ @item{@indexed-scheme['no-caret] --- The caret should not be drawn at all.} @@ -616,7 +616,7 @@ When an editor or snip is drawn, an argument to the drawing method @item{@indexed-scheme['show-caret] --- The caret should be drawn to show keyboard focus ownership.} -} +] The @scheme['show-inactive-caret] display mode is useful for showing selection ranges in text editors that do not have the focus. This @@ -668,7 +668,7 @@ Note that there is no attempt to save clickback information when a Instances of @scheme[editor<%>] have three levels of internal locking: -@itemize{ +@itemize[ @item{write locking --- When an editor is internally locked for writing, the abstract content of the editor cannot be changed (e.g., @@ -696,7 +696,7 @@ Instances of @scheme[editor<%>] have three levels of internal snips. The @method[editor<%> locked-for-read?] method reports whether an editor is currently locked for reading.} -} +] The internal lock for an editor is @italic{not} affected by calls to @method[editor<%> lock]. @@ -727,7 +727,7 @@ Nevertheless, the editor supports certain concurrent patterns refreshes do not prevent editor modifications, the following are guaranteed: -@itemize{ +@itemize[ @item{When an editor's @method[editor<%> refresh] method is called during an edit sequence (which is started by @@ -749,7 +749,7 @@ Nevertheless, the editor supports certain concurrent patterns delegated to the edit-sequence thread, to be called when the edit sequence is complete.} -} +] Thus, disabling an @scheme[editor-canvas%] object (using @method[window<%> enable]) is sufficient to ensure that a diff --git a/collects/scribblings/gui/editor-wordbreak-map-class.scrbl b/collects/scribblings/gui/editor-wordbreak-map-class.scrbl index 85d739cd..7451f555 100644 --- a/collects/scribblings/gui/editor-wordbreak-map-class.scrbl +++ b/collects/scribblings/gui/editor-wordbreak-map-class.scrbl @@ -16,13 +16,13 @@ A global object @scheme[the-editor-wordbreak-map] is created A wordbreak objects implements a mapping from each character to a list of symbols. The following symbols are legal elements of the list: -@itemize{ +@itemize[ @item{@indexed-scheme['caret]} @item{@indexed-scheme['line]} @item{@indexed-scheme['selection]} @item{@indexed-scheme['user1]} @item{@indexed-scheme['user2]} -} +] The presence of a flag in a character's value indicates that the character does not break a word when searching for breaks using the diff --git a/collects/scribblings/gui/eventspace-funcs.scrbl b/collects/scribblings/gui/eventspace-funcs.scrbl index 195b899c..397e4392 100644 --- a/collects/scribblings/gui/eventspace-funcs.scrbl +++ b/collects/scribblings/gui/eventspace-funcs.scrbl @@ -158,7 +158,7 @@ If @scheme[v] is @indexed-scheme['wait], and @scheme[yield] is called in the handler thread of an eventspace, then @scheme[yield] starts processing events in that eventspace until -@itemize{ +@itemize[ @item{no top-level windows in the eventspace are visible;} @@ -170,7 +170,7 @@ If @scheme[v] is @indexed-scheme['wait], and @scheme[yield] is called with @scheme['root] (i.e., creating a @scheme['root] menu bar prevents an eventspace from ever unblocking).} -} +] When called in a non-handler thread, @scheme[yield] returns immediately. In either case, the result is @scheme[#t]. diff --git a/collects/scribblings/gui/frame-class.scrbl b/collects/scribblings/gui/frame-class.scrbl index 8ad79d40..ae784988 100644 --- a/collects/scribblings/gui/frame-class.scrbl +++ b/collects/scribblings/gui/frame-class.scrbl @@ -60,7 +60,7 @@ they are created). The @scheme[style] flags adjust the appearance of the frame on some platforms: -@itemize{ +@itemize[ @item{@scheme['no-resize-border] --- omits the resizeable border around the window (Windows, X MWM) or grow box in the bottom right @@ -102,7 +102,7 @@ some platforms: background (Mac OS X); this style is ignored when @scheme['no-caption] is specified} -} +] If the @scheme['mdi-child] style is specified, the @scheme[parent] must be a frame with the @scheme['mdi-parent] style, otherwise @|MismatchExn|. @@ -274,7 +274,7 @@ Sets the large or small icon bitmap for this frame. Future changes to The icon is used in a platform-specific way: -@itemize{ +@itemize[ @item{Windows --- the small icon is used for the frame's icon (in the top-left) and in the task bar, and the large icon is used for @@ -286,7 +286,7 @@ The icon is used in a platform-specific way: as Windows, and others use the small icon when iconifying the frame; the large icon is ignored.} -} +] The bitmap for either icon can be any size, but most platforms scale the small bitmap to 16 by 16 pixels and the large bitmap to 32 by 32 diff --git a/collects/scribblings/gui/guide.scrbl b/collects/scribblings/gui/guide.scrbl index b006f8ec..451958a3 100644 --- a/collects/scribblings/gui/guide.scrbl +++ b/collects/scribblings/gui/guide.scrbl @@ -6,7 +6,7 @@ For documentation purposes, the graphics toolbox is organized into three parts: -@itemize{ +@itemize[ @item{The @deftech{windowing toolbox}, for implementing form-filling GUI programs (such as a database query window) using buttons, menus, @@ -24,7 +24,7 @@ For documentation purposes, the graphics toolbox is organized into browser). The editor toolbox is described in @secref["editor-overview"].} -} +] These three parts roughly represent layers of increasing sophistication. Simple GUI programs access only the windowing toolbox diff --git a/collects/scribblings/gui/key-event-class.scrbl b/collects/scribblings/gui/key-event-class.scrbl index 3923044b..197798ec 100644 --- a/collects/scribblings/gui/key-event-class.scrbl +++ b/collects/scribblings/gui/key-event-class.scrbl @@ -67,7 +67,7 @@ Under Mac OS X, if a control-key press is combined with a mouse button Gets the virtual key code for the key event. The virtual key code is either a character or a special key symbol, one of the following: -@itemize{ +@itemize[ @item{@indexed-scheme['start]} @item{@indexed-scheme['cancel]} @item{@indexed-scheme['clear]} @@ -138,13 +138,13 @@ Gets the virtual key code for the key event. The virtual key code is @item{@indexed-scheme['wheel-down] --- mouse wheel down one notch} @item{@indexed-scheme['release] --- indicates a key-release event} @item{@indexed-scheme['press] --- indicates a key-press event; usually only from @scheme[get-key-release-code]} -} +] The special key symbols attempt to capture useful keys that have no standard ASCII representation. A few keys have standard representations that are not obvious: -@itemize{ +@itemize[ @item{@scheme[#\space] --- the space bar} @@ -159,7 +159,7 @@ The special key symbols attempt to capture useful keys that have no @item{@scheme[#\rubout] --- the delete key} -} +] If a suitable special key symbol or ASCII representation is not available, @scheme[#\nul] (the NUL character) is reported. diff --git a/collects/scribblings/gui/keymap-class.scrbl b/collects/scribblings/gui/keymap-class.scrbl index 8ad4977d..34a01e03 100644 --- a/collects/scribblings/gui/keymap-class.scrbl +++ b/collects/scribblings/gui/keymap-class.scrbl @@ -8,13 +8,13 @@ A @scheme[keymap%] object is used by @scheme[editor<%>] objects to extensible way. Keymaps can be used without editors, as well. A @scheme[keymap%] object contains -@itemize{ +@itemize[ @item{a mapping from function names to event-handling procedures; and} @item{a mapping from key and mouse sequences to function names.} -} +] A handler procedure in a keymap is invoked with a @scheme[key-event%] object or a @scheme[mouse-event%] object. It is also given another @@ -163,7 +163,7 @@ Maps an input state sequence to a function name using a string-encoded The modifier identifiers are: -@itemize{ +@itemize[ @item{@litchar{s:} --- All platforms: Shift} @@ -181,7 +181,7 @@ The modifier identifiers are: @item{@litchar{?:} --- All platforms: allow match to character produced by opposite use of Shift, AltGr/Option, and/or Caps Lock, when available; see @xmethod[key-event% get-other-shift-key-code]} -} +] If a particular modifier is not mentioned in a state string, it matches states whether that modifier is pressed or not pressed. A @@ -195,7 +195,7 @@ A key identifier can be either a character on the keyboard (e.g., @litchar{a}, @litchar{2}, @litchar{?}) or a special name. The special names are as follows: -@itemize{ +@itemize[ @item{@litchar{leftbutton} (button down)} @item{@litchar{rightbutton}} @item{@litchar{middlebutton}} @@ -270,7 +270,7 @@ A key identifier can be either a character on the keyboard (e.g., @item{@litchar{f22}} @item{@litchar{f23}} @item{@litchar{f24}} -} +] For a special keyword, the capitalization does not matter. However, capitalization is important for single-letter keynames. Furthermore, @@ -297,7 +297,7 @@ A state can match multiple state strings mapped in a keymap (or keymap Examples: -@itemize{ +@itemize[ @item{@scheme["space"] --- matches whenever the space bar is pressed, regardless of the state of modifiers keys.} @@ -322,7 +322,7 @@ Examples: that produces @litchar{+}, even if producing @litchar{+} normally requires pressing Shift.} -} +] A call to @method[keymap% map-function] that would map a particular key sequence both as a prefix and as a complete sequence raises an diff --git a/collects/scribblings/gui/list-box-class.scrbl b/collects/scribblings/gui/list-box-class.scrbl index 15c940f7..de1351e6 100644 --- a/collects/scribblings/gui/list-box-class.scrbl +++ b/collects/scribblings/gui/list-box-class.scrbl @@ -59,7 +59,7 @@ The @scheme[callback] procedure is called when the user changes the list The @scheme[style] specification must include exactly one of the following: -@itemize{ +@itemize[ @item{@scheme['single] --- Creates a single-selection list.} @@ -73,7 +73,7 @@ The @scheme[style] specification must include exactly one of the clicked item. Use this style for a list when multiple selections are the rule rather than the exception.} -} +] The @scheme['multiple] and @scheme['extended] styles determine a platform-independent interpretation of unmodified mouse clicks, but dragging, shift-clicking, control-clicking, etc. have diff --git a/collects/scribblings/gui/list-control-intf.scrbl b/collects/scribblings/gui/list-control-intf.scrbl index c04e1e34..e5d4fbe5 100644 --- a/collects/scribblings/gui/list-control-intf.scrbl +++ b/collects/scribblings/gui/list-control-intf.scrbl @@ -6,7 +6,7 @@ A list control gives the user a list of string items to choose from. There are two built-in classes that implement @scheme[list-control<%>]: -@itemize{ +@itemize[ @item{@scheme[choice%] --- presents the list in a popup menu (so the user can choose only one item at a time)} @@ -15,7 +15,7 @@ A list control gives the user a list of string items to choose from. allowing the use to choose one item (if the style includes @scheme['single]) or any number of items} -} +] In either case, the set of user-selectable items can be changed dynamically. diff --git a/collects/scribblings/gui/miscwin-funcs.scrbl b/collects/scribblings/gui/miscwin-funcs.scrbl index 46bc4159..8ea9a038 100644 --- a/collects/scribblings/gui/miscwin-funcs.scrbl +++ b/collects/scribblings/gui/miscwin-funcs.scrbl @@ -81,19 +81,19 @@ Finds a platform-specific (and possibly user- or machine-specific) The result depends on @scheme[what], and a @scheme[#f] result is only possible when @scheme[what] is @scheme['x-display]: -@itemize{ +@itemize[ @item{@scheme['init-file] returns the path to the user-specific initialization file (containing Scheme code). The directory part of the path is the same path as returned for @scheme['init-dir] by MzScheme's @scheme[find-system-path]. The file name is platform-specific: - @itemize{ + @itemize[ @item{@|AllUnix|: @indexed-file{.mredrc}} @item{Windows: @indexed-file{mredrc.ss}} - }} + ]} @item{@scheme['setup-file] returns the path to the file containing resources used by @scheme[get-resource]; obsolete.} @@ -104,7 +104,7 @@ The result depends on @scheme[what], and a @scheme[#f] result is only other platforms, or when neither @Flag{display} nor @envvar{DISPLAY} was specified, the result is @scheme[#f].} -} +] @@ -161,7 +161,7 @@ The format of a resource entry depends on the platform. Windows @scheme[section] is one of the following strings, then @scheme[file] is ignored, and @scheme[entry] is used as a resource path: -@itemize{ +@itemize[ @item{@indexed-scheme["HKEY_CLASSES_ROOT"]} @item{@indexed-scheme["HKEY_CURRENT_CONFIG"]} @@ -169,7 +169,7 @@ The format of a resource entry depends on the platform. Windows @item{@indexed-scheme["HKEY_LOCAL_MACHINE"]} @item{@indexed-scheme["HKEY_USERS"]} -} +] In that case, the @scheme[entry] argument is parsed as a resource entry path, followed by a backslash, followed by a value name. To get the @@ -222,13 +222,13 @@ If no eventspace is provided, or if @scheme[#f] is provided, an When @scheme[redirect-ports?] is true, the following parameters are initialized in the created eventspace's handler thread: -@itemize{ +@itemize[ @item{@scheme[current-output-port] --- writes to the frame} @item{@scheme[current-error-port] --- writes to the frame} @item{@scheme[current-input-port] --- always returns @scheme[eof]} -} +] The keymap for the read-eval-print loop's editor is initialized by calling the current keymap initializer procedure, which is determined diff --git a/collects/scribblings/gui/mouse-event-class.scrbl b/collects/scribblings/gui/mouse-event-class.scrbl index 6827dce5..aeebd2ca 100644 --- a/collects/scribblings/gui/mouse-event-class.scrbl +++ b/collects/scribblings/gui/mouse-event-class.scrbl @@ -31,7 +31,7 @@ See also @|mousekeydiscuss|. Creates a mouse event for a particular type of event. The event types are: -@itemize{ +@itemize[ @item{@scheme['enter] --- mouse pointer entered the window} @item{@scheme['leave] --- mouse pointer left the window} @item{@scheme['left-down] --- left mouse button pressed} @@ -41,7 +41,7 @@ Creates a mouse event for a particular type of event. The event types @item{@scheme['right-down] --- right mouse button pressed (Mac OS X: click with control key pressed)} @item{@scheme['right-up] --- right mouse button released (Mac OS X: release with control key pressed)} @item{@scheme['motion] --- mouse moved, with or without button(s) pressed} -} +] See the corresponding @schemeidfont{get-} and @schemeidfont{set-} methods for information about @scheme[left-down], diff --git a/collects/scribblings/gui/pasteboard-class.scrbl b/collects/scribblings/gui/pasteboard-class.scrbl index 71279086..d4e58bc6 100644 --- a/collects/scribblings/gui/pasteboard-class.scrbl +++ b/collects/scribblings/gui/pasteboard-class.scrbl @@ -812,7 +812,7 @@ Deselects all selected snips in the editor. Selects, drags, and resizes snips: -@itemize{ +@itemize[ @item{Clicking on a snip selects the snip. Shift-clicking extends the current selection with the snip.} @@ -831,7 +831,7 @@ with the new snips.} @item{Clicking on a hiliting tab for a selected object resizes the object.} -} +] } diff --git a/collects/scribblings/gui/prefs.scrbl b/collects/scribblings/gui/prefs.scrbl index 38375e70..a469d098 100644 --- a/collects/scribblings/gui/prefs.scrbl +++ b/collects/scribblings/gui/prefs.scrbl @@ -14,7 +14,7 @@ MrEd supports a number of preferences for global configuration. The The following are the (case-sensitive) preference names used by MrEd: -@itemize{ +@itemize[ @item{@ResourceFirst{default-font-size} --- sets the default font size the basic style in a style list, and thus the default font size for @@ -79,7 +79,7 @@ The following are the (case-sensitive) preference names used by MrEd: @scheme[clipboard<%>].} -} +] In addition, preference names built from font face names can provide or override default entries for the @scheme[font-name-directory<%>]; diff --git a/collects/scribblings/gui/scroll-event-class.scrbl b/collects/scribblings/gui/scroll-event-class.scrbl index 0bd1ab41..26a8dbae 100644 --- a/collects/scribblings/gui/scroll-event-class.scrbl +++ b/collects/scribblings/gui/scroll-event-class.scrbl @@ -41,7 +41,7 @@ Gets the identity of the scrollbar that was modified by the event, Returns the type of the event, one of the following: -@itemize{ +@itemize[ @item{@scheme['top] --- user clicked a scroll-to-top button} @item{@scheme['bottom] --- user clicked a scroll-to-bottom button} @item{@scheme['line-up] --- user clicked an arrow to scroll up or left one step} @@ -49,7 +49,7 @@ Returns the type of the event, one of the following: @item{@scheme['page-up] --- user clicked an arrow to scroll up or left one page} @item{@scheme['page-down] --- user clicked an arrow to scroll down or right one page} @item{@scheme['thumb] --- user dragged the scroll position indicator} -} +] } diff --git a/collects/scribblings/gui/selectable-menu-item-intf.scrbl b/collects/scribblings/gui/selectable-menu-item-intf.scrbl index 4e21788e..1fd10d0a 100644 --- a/collects/scribblings/gui/selectable-menu-item-intf.scrbl +++ b/collects/scribblings/gui/selectable-menu-item-intf.scrbl @@ -45,14 +45,14 @@ For a list of allowed key symbols, see @xmethod[key-event% Returns a list of symbols that indicates the keyboard prefix used for the menu item's keyboard shortcut. The allowed symbols for the list are the following: -@itemize{ +@itemize[ @item{@scheme['alt] --- Meta (Windows and X only)} @item{@scheme['cmd] --- Command (Mac OS X only)} @item{@scheme['meta] --- Meta (X only)} @item{@scheme['ctl] --- Control} @item{@scheme['shift] --- Shift} @item{@scheme['option] --- Option (Mac OS X only)} -} +] Under X, at most one of @scheme['alt] and @scheme['meta] can be supplied; the only difference between @scheme['alt] and diff --git a/collects/scribblings/gui/snip-admin-class.scrbl b/collects/scribblings/gui/snip-admin-class.scrbl index c63868b7..2ac83df1 100644 --- a/collects/scribblings/gui/snip-admin-class.scrbl +++ b/collects/scribblings/gui/snip-admin-class.scrbl @@ -259,7 +259,7 @@ If @scheme[refresh?] is not @scheme[#f], then the editor is requesting to be updated immediately. The @scheme[bias] argument is one of: -@itemize{ +@itemize[ @item{@scheme['start] --- if the range doesn't fit in the visible area, show the top-left region} @@ -267,7 +267,7 @@ The @scheme[bias] argument is one of: @item{@scheme['end] --- if the range doesn't fit in the visible area, show the bottom-right region} -} +] The result is @scheme[#t] if the editor is scrolled, @scheme[#f] otherwise. diff --git a/collects/scribblings/gui/snip-class-class.scrbl b/collects/scribblings/gui/snip-class-class.scrbl index 3681dc3a..9bf2ecc6 100644 --- a/collects/scribblings/gui/snip-class-class.scrbl +++ b/collects/scribblings/gui/snip-class-class.scrbl @@ -13,7 +13,7 @@ In deriving a new @scheme[snip-class%] class, override the derived class (where each instance corresponds to a single snip class): -@itemize{ +@itemize[ @item{Set the classname using @method[snip-class% set-classname].} @@ -26,7 +26,7 @@ In deriving a new @scheme[snip-class%] class, override the name is inserted into the same class list multiple times, all but the first insertion is ignored.} -} +] See also @|snipclassdiscuss|. diff --git a/collects/scribblings/gui/snip-class.scrbl b/collects/scribblings/gui/snip-class.scrbl index 50a7c764..2a9faf18 100644 --- a/collects/scribblings/gui/snip-class.scrbl +++ b/collects/scribblings/gui/snip-class.scrbl @@ -10,7 +10,7 @@ A direct instance of @scheme[snip%] is uninteresting. Useful snips are In deriving a new snip class, these methods must be overridden to create a useful snip: -@itemize{ +@itemize[ @item{@method[snip% get-extent]} @@ -37,14 +37,14 @@ create a useful snip: in the snip's administrator when the state changes the first time} -} +] If a snip can contain more than one @techlink{item}, then the snip's @techlink{count} must be maintained as well. To define a class of snips that can be saved or cut-and-pasted: -@itemize{ +@itemize[ @item{Create an instance of @scheme[snip-class%], implementing the @method[snip-class% read] method. Export the @@ -59,18 +59,18 @@ To define a class of snips that can be saved or cut-and-pasted: @item{Override the @method[snip% write] method.} -} +] To define a class of snips that read specially with @scheme[open-input-text-editor]: -@itemize{ +@itemize[ @item{Make your @scheme[snip%] class implement @scheme[readable-snip<%>].} @item{Implement the @method[readable-snip<%> read-special] method.} -} +] @@ -320,7 +320,7 @@ Fills in all boxes with @scheme[0.0]. Returns flags defining the behavior of the snip, a list of the following symbols: -@itemize{ +@itemize[ @item{@indexed-scheme['is-text] --- this is a text snip derived from @scheme[string-snip%]; do not set this flag} @@ -357,7 +357,7 @@ following symbols: notification is given as a redundant call to @method[snip% set-admin]} -}} +]} @defmethod[(get-num-scroll-steps) diff --git a/collects/scribblings/gui/style-delta-class.scrbl b/collects/scribblings/gui/style-delta-class.scrbl index e104e105..10744cf9 100644 --- a/collects/scribblings/gui/style-delta-class.scrbl +++ b/collects/scribblings/gui/style-delta-class.scrbl @@ -5,7 +5,7 @@ A @scheme[style-delta%] object encapsulates a style change. The changes expressible by a delta include: -@itemize{ +@itemize[ @item{changing the font family} @item{changing the font face} @item{changing the font size to a new value} @@ -21,7 +21,7 @@ by a delta include: @item{dimming or brightening the foreground color, etc.} @item{changing the background color, etc.} @item{changing text backing transparency} -} +] The @method[style-delta% set-delta] method is convenient for most style delta settings; it takes a high-level delta specification and @@ -36,7 +36,7 @@ turns on a weight setting when it is not present and @scheme[weight-off] turns off a weight setting when it is present. These two interact precisely in the following way: -@itemize{ +@itemize[ @item{If both @scheme[weight-on] and @scheme[weight-off] are set to @scheme['base], then the font weight is not changed.} @item{If @scheme[weight-on] is not @scheme['base], then the weight is set to @@ -51,65 +51,65 @@ the base style has the weight @scheme[weight-on], then weight is changed to @item{If both @scheme[weight-on] and @scheme[weight-off] are set, but to different values, then the weight is changed to @scheme[weight-on] only when the base style has the weight @scheme[weight-off].} -} +] Font styles, smoothing, underlining, and alignment work in an analogous manner. The possible values for @scheme[alignment-on] and @scheme[alignment-off] are: -@itemize{ +@itemize[ @item{@indexed-scheme['base]} @item{@indexed-scheme['top]} @item{@indexed-scheme['center]} @item{@indexed-scheme['bottom]} -} +] The possible values for @scheme[style-on] and @scheme[style-off] are: -@itemize{ +@itemize[ @item{@indexed-scheme['base]} @item{@indexed-scheme['normal]} @item{@indexed-scheme['italic]} @item{@indexed-scheme['slant]} -} +] The possible values for @scheme[smoothing-on] and @scheme[smoothing-off] are: -@itemize{ +@itemize[ @item{@indexed-scheme['base]} @item{@indexed-scheme['default]} @item{@indexed-scheme['partly-smoothed]} @item{@indexed-scheme['smoothed]} @item{@indexed-scheme['unsmoothed]} -} +] The possible values for @scheme[underlined-on] and @scheme[underlined-off] are: -@itemize{ +@itemize[ @item{@scheme[#f] (acts like @scheme['base])} @item{@scheme[#t]} -} +] The possible values for @scheme[size-in-pixels-on] and @scheme[size-in-pixels-off] are: -@itemize{ +@itemize[ @item{@scheme[#f] (acts like @scheme['base])} @item{@scheme[#t]} -} +] The possible values for @scheme[transparent-text-backing-on] and @scheme[transparent-text-backing-off] are: -@itemize{ +@itemize[ @item{@scheme[#f] (acts like @scheme['base])} @item{@scheme[#t]} -} +] The possible values for @scheme[weight-on] and @scheme[weight-off] are: -@itemize{ +@itemize[ @item{@indexed-scheme['base]} @item{@indexed-scheme['normal]} @item{@indexed-scheme['bold]} @item{@indexed-scheme['light]} -} +] The family and face settings in a style delta are interdependent: -@itemize{ +@itemize[ @item{When a delta's face is @scheme[#f] and its family is @scheme['base], then neither the face nor family are modified by @@ -124,7 +124,7 @@ The family and face settings in a style delta are interdependent: @scheme[#f], so that the family setting prevails in choosing a font.} -} +] @@ -236,7 +236,7 @@ See also @method[style-delta% get-family]. 'swiss 'modern 'symbol 'system)]{ Returns the delta's font family. The possible values are -@itemize{ +@itemize[ @item{@indexed-scheme['base] --- no change to family} @item{@indexed-scheme['default]} @item{@indexed-scheme['decorative]} @@ -246,7 +246,7 @@ Returns the delta's font family. The possible values are @item{@indexed-scheme['modern] (fixed width)} @item{@indexed-scheme['symbol] (Greek letters)} @item{@indexed-scheme['system] (used to draw control labels)} -} +] See also @method[style-delta% get-face]. @@ -401,7 +401,7 @@ Except for @scheme['change-nothing] and The @scheme[change-command] argument specifies how the delta is changed; the possible values are: -@itemize{ +@itemize[ @item{@scheme['change-nothing] --- reset all changes} @item{@scheme['change-normal] --- turn off all styles and resizings} @item{@scheme['change-toggle-underline] --- underline regions that are currently not underlined, and vice-versa} @@ -430,7 +430,7 @@ the possible values are: @item{@scheme['change-smaller] --- make the text smaller (@scheme[param] is an additive amount)} @item{@scheme['change-underline] --- set the underline status to either underlined or plain} @item{@scheme['change-size-in-pixels] --- set the size interpretation to pixels or points} -} +] } diff --git a/collects/scribblings/gui/subarea-intf.scrbl b/collects/scribblings/gui/subarea-intf.scrbl index 75081601..2462c88e 100644 --- a/collects/scribblings/gui/subarea-intf.scrbl +++ b/collects/scribblings/gui/subarea-intf.scrbl @@ -7,7 +7,7 @@ A @scheme[subarea<%>] is a containee @scheme[area<%>]. All @scheme[subarea<%>] classes accept the following named instantiation arguments: -@itemize{ +@itemize[ @item{@indexed-scheme[horiz-margin] --- default is @scheme[2] for @scheme[control<%>] classes and @scheme[group-box-panel%], @@ -17,7 +17,7 @@ All @scheme[subarea<%>] classes accept the following named @scheme[control<%>] classes and @scheme[group-box-panel%], @scheme[0] for others; passed to @method[subarea<%> vert-margin]} -} +] diff --git a/collects/scribblings/gui/text-class.scrbl b/collects/scribblings/gui/text-class.scrbl index 038d2b90..1b0f04dd 100644 --- a/collects/scribblings/gui/text-class.scrbl +++ b/collects/scribblings/gui/text-class.scrbl @@ -588,7 +588,7 @@ Returns the snip at a given @techlink{position}, or @scheme[#f] if an appropriat If the @techlink{position} @scheme[pos] is between two snips, @scheme[direction] specifies which snip to return; @scheme[direction] can be any of the following: -@itemize{ +@itemize[ @item{@scheme['before-or-none] --- returns the snip before the @techlink{position}, or @scheme[#f] if @scheme[pos] is @scheme[0]} @@ -602,7 +602,7 @@ can be any of the following: @item{@scheme['after-or-none] -- returns the snip after the @techlink{position}, or @scheme[#f] if @scheme[pos] is the last @techlink{position} or larger} -} +] @boxisfillnull[(scheme s-pos) @elem{the @techlink{position} where the returned snip starts}] @@ -679,13 +679,13 @@ The @scheme[reason] argument specifies more information about what the caret may be different from the wordbreaks used to break lines. The possible values of @scheme[reason] are: -@itemize{ +@itemize[ @item{@scheme['caret] --- find a wordbreak suitable for moving the caret} @item{@scheme['line] --- find a wordbreak suitable for breaking lines} @item{@scheme['selection] --- find a wordbreak suitable for selecting the closest word} @item{@scheme['user1] --- for other (not built-in) uses} @item{@scheme['user2] --- for other (not built-in) uses} -} +] The actual handling of @scheme[reason] is controlled by the current wordbreak procedure; see @method[text% set-wordbreak-func]for @@ -1227,7 +1227,7 @@ If the line starts with invisible @techlink{item}s and @scheme[visible?] is not @|FCAMW| To calculate lines, if the following are true: -@itemize{ +@itemize[ @item{the editor is not displayed (see @secref["tb:miaoverview"]),} @@ -1235,7 +1235,7 @@ To calculate lines, if the following are true: @item{the editor has never been viewed} -} +] then this method ignores the editor's maximum width and any automatic line breaks it might imply. If the first two of the above conditions @@ -1256,14 +1256,14 @@ Moves the current selection. The possible values for @scheme[code] are: -@itemize{ +@itemize[ @item{@scheme['home] --- go to start of file} @item{@scheme['end] --- go to end of file} @item{@scheme['right] --- move right} @item{@scheme['left] --- move left} @item{@scheme['up] --- move up} @item{@scheme['down] --- move down} -} +] If @scheme[extend?] is not @scheme[#f], the selection range is extended instead of moved. If anchoring is on (see @method[text% @@ -1272,12 +1272,12 @@ If @scheme[extend?] is not @scheme[#f], the selection range is The possible values for @scheme[kind] are: -@itemize{ +@itemize[ @item{@scheme['simple] --- move one item or line} @item{@scheme['word] --- works with @scheme['right] or @scheme['left]} @item{@scheme['page] --- works with @scheme['up] or @scheme['down]} @item{@scheme['line] --- works with @scheme['right] or @scheme['left]; moves to the start or end of the line} -} +] See also @method[text% set-position]. @@ -1317,7 +1317,7 @@ Does nothing. Handles the following: -@itemize{ +@itemize[ @item{Delete and Backspace --- calls @method[text% delete].} @@ -1329,7 +1329,7 @@ Handles the following: @scheme[(integer->char 255)] --- inserts the character into the editor.} -} +] Note that an editor's @scheme[editor-canvas%] normally handles mouse wheel events (see also @method[editor-canvas% on-char] ). @@ -1346,7 +1346,7 @@ Tracks clicks on a clickback (see @method[text% set-clickback]) of dispatches to a caret-owning snip and detects a click on an event-handling snip before calling to this method. -@itemize{ +@itemize[ @item{Clicking on a clickback region starts clickback tracking. See @method[text% set-clickback] for more information. Moving over a @@ -1358,7 +1358,7 @@ Tracks clicks on a clickback (see @method[text% set-clickback]) of @item{Dragging extends the selection, scrolling if possible when the selection is dragged outside the editor's visible region.} -} +] } @@ -1821,11 +1821,11 @@ Set the format of the file saved from this editor. The legal formats are: -@itemize{ +@itemize[ @item{@scheme['standard] --- a standard editor file} @item{@scheme['text] --- a text file} @item{@scheme['text-force-cr] --- a text file; when writing, change automatic newlines (from word-wrapping) into real carriage returns} -} +] @MonitorMethod[@elem{The file format of an editor} @elem{the system in response to file loading and saving @@ -1910,7 +1910,7 @@ See @|ateoldiscuss| for a discussion of @scheme[at-eol?]. If The @scheme[seltype] argument is only used when the X Window System selection mechanism is enabled. The possible values are: -@itemize{ +@itemize[ @item{@scheme['default] --- if this window has the keyboard focus and given selection is non-empty, make it the current X selection} @@ -1921,7 +1921,7 @@ The @scheme[seltype] argument is only used when the X Window System @item{@scheme['local] --- do not change the current X selection} -} +] Setting the @techlink{position} is disallowed when the editor is internally locked for reflowing (see also @|lockdiscuss|). @@ -1945,13 +1945,13 @@ See also @scheme[editor-set-x-selection-mode]. Like @method[text% set-position], but a scrolling bias can be specified. The possible values for @scheme[bias] are: -@itemize{ +@itemize[ @item{@scheme['start-only] --- only insure that the starting @techlink{position} is visible} @item{@scheme['start] --- if the range doesn't fit in the visible area, show the starting @techlink{position}} @item{@scheme['none] --- no special scrolling instructions} @item{@scheme['end] --- if the range doesn't fit in the visible area, show the ending @techlink{position}} @item{@scheme['end-only] --- only insure that the ending @techlink{position} is visible} -} +] See also @method[text% scroll-to-position]. diff --git a/collects/scribblings/gui/text-field-class.scrbl b/collects/scribblings/gui/text-field-class.scrbl index 408395d2..555e1bef 100644 --- a/collects/scribblings/gui/text-field-class.scrbl +++ b/collects/scribblings/gui/text-field-class.scrbl @@ -7,7 +7,7 @@ A @scheme[text-field%] object is an editable text field with an optional label displayed in front of it. There are two text field styles: -@itemize{ +@itemize[ @item{A single line of text is visible, and a special control event is generated when the user presses Enter (when the text field has the @@ -17,7 +17,7 @@ A @scheme[text-field%] object is an editable text field with an @item{Multiple lines of text are visible, and Enter is not handled specially.} -} +] Whenever the user changes the content of a text field, its callback procedure is invoked. A callback procedure is provided as an @@ -101,7 +101,7 @@ Returns the editor used to implement the text field. For a text field, the most useful methods of a @scheme[text%] object are the following: -@itemize{ +@itemize[ @item{@scheme[(send a-text #, @method[text% get-text])] returns the current text of the editor.} @@ -112,7 +112,7 @@ For a text field, the most useful methods of a @scheme[text%] object @item{@scheme[(send a-text #, @method[text% insert] _str)] inserts @scheme[_str] into the editor at the current caret position.} -} +] } diff --git a/collects/scribblings/gui/top-level-window-intf.scrbl b/collects/scribblings/gui/top-level-window-intf.scrbl index 2e0db90e..ea915c78 100644 --- a/collects/scribblings/gui/top-level-window-intf.scrbl +++ b/collects/scribblings/gui/top-level-window-intf.scrbl @@ -208,13 +208,13 @@ Returns @|void-const|. The following rules determine, in order, whether and how @scheme[event] is handled: -@itemize{ +@itemize[ @item{ If the window that currently owns the focus specifically handles the event, then @scheme[#f] is returned. The following describes window types and the keyboard events they specifically handle: -@itemize{ +@itemize[ @item{@scheme[editor-canvas%] --- tab-exit is disabled (see @method[editor-canvas% allow-tab-exit]): all keyboard events, except alphanumeric key events when the Meta @@ -242,7 +242,7 @@ If the window that currently owns the focus specifically handles the @item{@scheme[list-box%] --- arrow key events and alphanumeric key events when the Meta (X) or Alt (Windows) key is not pressed} -}} +]} @item{ If @scheme[event] is a Tab or arrow key event, the keyboard focus is @@ -288,7 +288,7 @@ If @scheme[event] is an alphanumeric key event and the current top-level @item{ Otherwise, @scheme[#f] is returned.} -} +] }} @defmethod[(on-system-menu-char [event (is-a?/c key-event%)]) diff --git a/collects/scribblings/gui/win-overview.scrbl b/collects/scribblings/gui/win-overview.scrbl index a187e14f..30d3195c 100644 --- a/collects/scribblings/gui/win-overview.scrbl +++ b/collects/scribblings/gui/win-overview.scrbl @@ -134,12 +134,12 @@ The fundamental graphical element in the windowing toolbox is an @deftech{area}. The following classes implement the different types of areas in the windowing toolbox: -@itemize{ +@itemize[ @item{@deftech{Containers} --- areas that can contain other areas: - @itemize{ + @itemize[ @item{@scheme[frame%] --- a @deftech{frame} is a top-level window that the user can move and resize.} @@ -159,12 +159,12 @@ The fundamental graphical element in the windowing toolbox is an @scheme[vertical-pane%], @scheme[horizontal-pane%], and @scheme[grow-box-spacer-pane%].} - }} + ]} @item{@deftech{Containees} --- areas that must be contained within other areas: - @itemize{ + @itemize[ @item{@scheme[panel%] --- a panel is a containee as well as a container.} @@ -182,7 +182,7 @@ The fundamental graphical element in the windowing toolbox is an @item{@deftech{Controls} --- containees that the user can manipulate: - @itemize{ + @itemize[ @item{@scheme[message%] --- a @deftech{message} is a static text field or bitmap with no user interaction.} @@ -219,11 +219,11 @@ The fundamental graphical element in the windowing toolbox is an control (the user cannot change the value) for reporting an integer value within a fixed range.} - }} + ]} - }} + ]} -} +] As suggested by the above listing, certain @tech{areas}, called @tech{containers}, manage certain other areas, called @@ -268,11 +268,11 @@ Menu bars, menus, and menu items are graphical elements, but not areas areas, such as an adjustable graphical size). Instead, the menu classes form a separate container--containee hierarchy: -@itemize{ +@itemize[ @item{@deftech{Menu Item Containers} - @itemize{ + @itemize[ @item{@scheme[menu-bar%] --- a @deftech{menu bar} is a top-level collection of menus that are associated with a frame.} @@ -285,11 +285,11 @@ Menu bars, menus, and menu items are graphical elements, but not areas top-level menu that is dynamically displayed in a canvas or editor canvas.} - }} + ]} @item{@deftech{Menu Items} - @itemize{ + @itemize[ @item{@scheme[separator-menu-item%] --- a @deftech{separator} is an unselectable line in a menu or popup menu.} @@ -305,9 +305,9 @@ Menu bars, menus, and menu items are graphical elements, but not areas @item{@scheme[menu%] --- a menu is a menu item as well as a menu item container.} - }} + ]} -} +] The following diagram shows the complete type hierarchy for the menu system: @@ -395,7 +395,7 @@ The following subsections describe the container system in detail, Each @tech{containee}, or child, has the following properties: -@itemize{ +@itemize[ @item{a @deftech{graphical minimum width} and a @deftech{graphical minimum height};} @@ -405,7 +405,7 @@ Each @tech{containee}, or child, has the following properties: @item{horizontal and vertical @tech{margins}.} -} +] A @tech{container} arranges its children based on these four properties of each @tech{containee}. A @tech{containee}'s parent @@ -464,7 +464,7 @@ In practice, the @tech{requested minimum size} and @tech{margin} of a A container has the following properties: -@itemize{ +@itemize[ @item{a list of (non-deleted) children containees;} @@ -478,7 +478,7 @@ A container has the following properties: @item{an alignment setting for positioning leftover space.} -} +] These properties are factored into the container's calculation of its own size and the arrangement of its children. For a container that is @@ -491,7 +491,7 @@ A containee's parent container is specified when the containee is container (but a non-window containee cannot be @tech{hidden} or @tech{deleted}): -@itemize{ +@itemize[ @item{A @deftech{hidden} child is invisible to the user, but space is still allocated for each hidden child within a container. To hide or @@ -504,7 +504,7 @@ A containee's parent container is specified when the containee is delete-child] or @method[area-container<%> add-child] method (which calls the child's @method[window<%> show] method).} -} +] When a child is created, it is initially shown and non-deleted. A deleted child is subject to garbage collection when no external @@ -588,22 +588,22 @@ Although nested horizontal and vertical containers can express most An input size specification is a list of four values: -@itemize{ +@itemize[ @item{the child's minimum width;} @item{the child's minimum height;} @item{the child's horizontal stretchability (@scheme[#t] means stretchable, @scheme[#f] means not stretchable); and} @item{the child's vertical stretchability.} -} +] For @method[area-container<%> place-children], an output position and size specification is a list of four values: -@itemize{ +@itemize[ @item{the child's new horizontal position (relative to the parent);} @item{the child's new vertical position;} @item{the child's new actual width;} @item{the child's new actual height.} -} +] The widths and heights for both the input and output include the children's margins. The returned position for each child is @@ -618,7 +618,7 @@ Whenever the user moves the mouse, clicks or releases a mouse button, window. The window that receives the event depends on the current state of the graphic display: -@itemize{ +@itemize[ @item{@index['("mouse events" "overview")]{The} receiving window of a mouse event is usually the window under the cursor when the mouse is @@ -665,7 +665,7 @@ Whenever the user moves the mouse, clicks or releases a mouse button, event, however, key-release events sometimes get dropped (e.g., due to the appearance of a modal dialog).} -} +] Controls, such as buttons and list boxes, handle keyboard and mouse events automatically, eventually invoking the callback procedure that @@ -715,7 +715,7 @@ Despite the programming convenience provided by a purely sequential event queue, certain situations require a less rigid dialog with the user: -@itemize{ +@itemize[ @item{@italic{Nested event handling:} In the process of handling an event, it may be necessary to obtain further information from the @@ -738,7 +738,7 @@ Despite the programming convenience provided by a purely sequential the application needs a separate event queue for each window, and a separate event-handling thread for each event queue.} -} +] An @deftech{eventspace} is a context for processing GUI events. Each eventspace maintains its own queue of events, and events @@ -795,7 +795,7 @@ An eventspace's event queue is actually a priority queue with events sorted according to their kind, from highest-priority (dispatched first) to lowest-priority (dispatched last): -@itemize{ +@itemize[ @item{The highest-priority events are high-priority events installed with @scheme[queue-callback].} @@ -808,7 +808,7 @@ An eventspace's event queue is actually a priority queue with events @item{The lowest-priority events are low-priority events installed with @scheme[queue-callback].} -} +] Although a programmer has no direct control over the order in which events are dispatched, a programmer can control the timing of diff --git a/collects/scribblings/gui/window-intf.scrbl b/collects/scribblings/gui/window-intf.scrbl index 25777c8e..668d7ee4 100644 --- a/collects/scribblings/gui/window-intf.scrbl +++ b/collects/scribblings/gui/window-intf.scrbl @@ -8,12 +8,12 @@ A @scheme[window<%>] object is an @scheme[area<%>] with a graphical All @scheme[window<%>] classes accept the following named instantiation arguments: -@itemize{ +@itemize[ @item{@indexed-scheme[enabled] --- default is @scheme[#t]; passed to @method[window<%> enable] if @scheme[#f]} -} +] @@ -113,7 +113,7 @@ Returns an exact integer representing a handle to the window in the current platform's GUI toolbox. Cast this number from a C @tt{long} to a platform-specific C type: -@itemize{ +@itemize[ @item{Windows: @tt{HWND}} @@ -122,7 +122,7 @@ to a platform-specific C type: @item{X: @tt{Widget*}} -} +] Some windows may not have a representation in the platform's GUI level, in which case the result of this method is @scheme[0]. From bbf44e7a56b3f82c29d4ff7ef47366b8d2711f4e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 7 Apr 2009 17:12:22 +0000 Subject: [PATCH 21/66] Scheme-implemented editor classes; on-demand instantiation of module phases svn: r14445 original commit: 1d26e97a35e7c2bd67130b70680a7870b41ef45c --- collects/framework/private/editor.ss | 1 + collects/mred/edit.ss | 2 +- collects/mred/mred.ss | 15 +- collects/mred/private/editor.ss | 17 +- collects/mred/private/filedialog.ss | 6 +- collects/mred/private/helper.ss | 1 + collects/mred/private/kernel.ss | 852 +-- collects/mred/private/moredialogs.ss | 1 + collects/mred/private/mrmenu.ss | 8 +- collects/mred/private/mrpopup.ss | 5 +- collects/mred/private/path-dialog.ss | 1 + collects/mred/private/repl.ss | 1 + collects/mred/private/seqcontract.ss | 2 +- collects/mred/private/snipfile.ss | 6 +- collects/mred/private/syntax.ss | 266 + collects/mred/private/wxcanvas.ss | 13 +- collects/mred/private/wxme/const.ss | 5 + collects/mred/private/wxme/cycle.ss | 27 + collects/mred/private/wxme/editor-admin.ss | 57 + collects/mred/private/wxme/editor-canvas.ss | 1133 ++++ collects/mred/private/wxme/editor-snip.ss | 716 +++ collects/mred/private/wxme/editor.ss | 1819 ++++++ collects/mred/private/wxme/keymap.ss | 737 +++ collects/mred/private/wxme/mline.ss | 1192 ++++ collects/mred/private/wxme/pasteboard.ss | 2122 +++++++ collects/mred/private/wxme/private.ss | 140 + collects/mred/private/wxme/snip-admin.ss | 147 + collects/mred/private/wxme/stream.ss | 761 +++ collects/mred/private/wxme/text.ss | 5482 +++++++++++++++++ collects/mred/private/wxme/undo.ss | 307 + collects/mred/private/wxme/wordbreak.ss | 151 + collects/mred/private/wxme/wx.ss | 63 + collects/mred/private/wxmenu.ss | 1 + collects/mred/private/wxtextfield.ss | 2 + collects/mred/private/wxtop.ss | 2 + collects/scribblings/gui/clipboard-intf.scrbl | 8 + collects/scribblings/gui/editor-intf.scrbl | 124 +- .../gui/editor-stream-in-base-class.scrbl | 16 +- .../gui/editor-stream-out-base-class.scrbl | 10 +- .../gui/editor-stream-out-class.scrbl | 14 +- .../scribblings/gui/pasteboard-class.scrbl | 11 +- collects/scribblings/gui/text-class.scrbl | 130 +- collects/tests/mred/media8.mre | 66 +- collects/tests/mred/test-editor-admin.ss | 44 + collects/tests/mred/wxme.ss | 1337 ++++ 45 files changed, 16804 insertions(+), 1017 deletions(-) create mode 100644 collects/mred/private/syntax.ss create mode 100644 collects/mred/private/wxme/const.ss create mode 100644 collects/mred/private/wxme/cycle.ss create mode 100644 collects/mred/private/wxme/editor-admin.ss create mode 100644 collects/mred/private/wxme/editor-canvas.ss create mode 100644 collects/mred/private/wxme/editor-snip.ss create mode 100644 collects/mred/private/wxme/editor.ss create mode 100644 collects/mred/private/wxme/keymap.ss create mode 100644 collects/mred/private/wxme/mline.ss create mode 100644 collects/mred/private/wxme/pasteboard.ss create mode 100644 collects/mred/private/wxme/private.ss create mode 100644 collects/mred/private/wxme/snip-admin.ss create mode 100644 collects/mred/private/wxme/stream.ss create mode 100644 collects/mred/private/wxme/text.ss create mode 100644 collects/mred/private/wxme/undo.ss create mode 100644 collects/mred/private/wxme/wordbreak.ss create mode 100644 collects/mred/private/wxme/wx.ss create mode 100644 collects/tests/mred/test-editor-admin.ss create mode 100644 collects/tests/mred/wxme.ss diff --git a/collects/framework/private/editor.ss b/collects/framework/private/editor.ss index a5ae252a..d76cd944 100644 --- a/collects/framework/private/editor.ss +++ b/collects/framework/private/editor.ss @@ -321,6 +321,7 @@ (define/override (on-new-image-snip filename kind relative-path? inline?) (super on-new-image-snip + filename (if (eq? kind 'unknown) 'unknown/mask kind) relative-path? inline?)) diff --git a/collects/mred/edit.ss b/collects/mred/edit.ss index c81e38eb..cc887bd7 100644 --- a/collects/mred/edit.ss +++ b/collects/mred/edit.ss @@ -158,7 +158,7 @@ (send c set-editor e) (when file - (if (regexp-match "[.](gif|bmp|jpe?g|xbm|xpm|png)$" file) + (if (regexp-match "[.](gif|bmp|jpe?g|xbm|xpm|png)$" (string-downcase file)) (send e insert (make-object image-snip% file)) (send e load-file file))) diff --git a/collects/mred/mred.ss b/collects/mred/mred.ss index d4397a54..0ba30ed8 100644 --- a/collects/mred/mred.ss +++ b/collects/mred/mred.ss @@ -6,6 +6,17 @@ scheme/class mzlib/etc (prefix wx: "private/kernel.ss") + (prefix wx: "private/wxme/style.ss") + (prefix wx: "private/wxme/editor.ss") + (prefix wx: "private/wxme/text.ss") + (prefix wx: "private/wxme/pasteboard.ss") + (prefix wx: "private/wxme/snip.ss") + (prefix wx: "private/wxme/keymap.ss") + (prefix wx: "private/wxme/editor-admin.ss") + (prefix wx: "private/wxme/editor-snip.ss") + (prefix wx: "private/wxme/stream.ss") + (prefix wx: "private/wxme/wordbreak.ss") + (prefix wx: "private/wxme/snip-admin.ss") "private/wxtop.ss" "private/app.ss" "private/misc.ss" @@ -182,8 +193,8 @@ (define the-font-list (wx:get-the-font-list)) (define the-pen-list (wx:get-the-pen-list)) (define the-brush-list (wx:get-the-brush-list)) - (define the-style-list (wx:get-the-style-list)) - (define the-editor-wordbreak-map (wx:get-the-editor-wordbreak-map)) + (define the-style-list wx:the-style-list) + (define the-editor-wordbreak-map wx:the-editor-wordbreak-map) (provide button% canvas% diff --git a/collects/mred/private/editor.ss b/collects/mred/private/editor.ss index 1ecb655e..7740a207 100644 --- a/collects/mred/private/editor.ss +++ b/collects/mred/private/editor.ss @@ -5,6 +5,15 @@ mzlib/list mzlib/file (prefix wx: "kernel.ss") + (prefix wx: "wxme/style.ss") + (prefix wx: "wxme/keymap.ss") + (prefix wx: "wxme/editor.ss") + (prefix wx: "wxme/text.ss") + (prefix wx: "wxme/pasteboard.ss") + (prefix wx: "wxme/editor-snip.ss") + (rename "wxme/cycle.ss" wx:set-extended-editor-snip%! set-extended-editor-snip%!) + (rename "wxme/cycle.ss" wx:set-extended-text%! set-extended-text%!) + (rename "wxme/cycle.ss" wx:set-extended-pasteboard%! set-extended-pasteboard%!) "seqcontract.ss" "lock.ss" "check.ss" @@ -324,7 +333,7 @@ (when (and can-wrap? auto-set-wrap?) (let-values ([(current-width) (as-exit (lambda () (get-max-width)))] [(new-width new-height) (max-view-size)]) - (when (and (not (= current-width new-width)) + (when (and (not (equal? current-width new-width)) (< 0 new-width)) (as-exit (lambda () (set-max-width new-width))))))) (as-exit (lambda () (inner (void) on-display-size)))))]) @@ -481,9 +490,9 @@ min-height max-height)))) - (wx:set-editor-snip-maker (lambda args (apply make-object editor-snip% args))) - (wx:set-text-editor-maker (lambda () (make-object text%))) - (wx:set-pasteboard-editor-maker (lambda () (make-object pasteboard%))) + (wx:set-extended-editor-snip%! editor-snip%) + (wx:set-extended-text%! text%) + (wx:set-extended-pasteboard%! pasteboard%) ;; ----------------------- Keymap ---------------------------------------- diff --git a/collects/mred/private/filedialog.ss b/collects/mred/private/filedialog.ss index 8b2e4229..a3d06564 100644 --- a/collects/mred/private/filedialog.ss +++ b/collects/mred/private/filedialog.ss @@ -3,6 +3,8 @@ mzlib/etc mzlib/list (prefix wx: "kernel.ss") + (prefix wx: "wxme/style.ss") + (prefix wx: "wxme/cycle.ss") "lock.ss" "wx.ss" "cycle.ss" @@ -105,4 +107,6 @@ ((mk-file-selector 'get-directory #f #f #t) message parent directory #f #f style null))) - (set-get-file! get-file)) + (set-get-file! get-file) + (wx:set-editor-get-file! get-file) + (wx:set-editor-put-file! put-file)) diff --git a/collects/mred/private/helper.ss b/collects/mred/private/helper.ss index 2be01a71..b11e0718 100644 --- a/collects/mred/private/helper.ss +++ b/collects/mred/private/helper.ss @@ -1,6 +1,7 @@ (module helper mzscheme (require mzlib/class (prefix wx: "kernel.ss") + (prefix wx: "wxme/style.ss") "lock.ss") (provide (protect (struct child-info (x-min y-min x-margin y-margin x-stretch y-stretch)) diff --git a/collects/mred/private/kernel.ss b/collects/mred/private/kernel.ss index f448c678..794007f5 100644 --- a/collects/mred/private/kernel.ss +++ b/collects/mred/private/kernel.ss @@ -160,147 +160,6 @@ on-size on-set-focus on-kill-focus) - (define-private-class editor% editor<%> object% () #f - dc-location-to-editor-location - editor-location-to-dc-location - set-inactive-caret-threshold - get-inactive-caret-threshold - get-focus-snip - end-write-header-footer-to-file - begin-write-header-footer-to-file - print - insert-image - insert-box - get-filename - is-modified? - is-locked? - lock - set-cursor - get-paste-text-only - set-paste-text-only - get-load-overwrites-styles - set-load-overwrites-styles - set-style-list - get-style-list - get-keymap - set-keymap - can-do-edit-operation? - do-edit-operation - get-max-undo-history - set-max-undo-history - add-undo - clear-undos - redo - undo - select-all - clear - get-view-size - get-dc - local-to-global - global-to-local - locked-for-flow? - locked-for-write? - locked-for-read? - set-admin - get-admin - print-to-dc - find-scroll-line - num-scroll-lines - scroll-line-location - get-snip-location - locations-computed? - in-edit-sequence? - refresh-delayed? - end-edit-sequence - begin-edit-sequence - style-has-changed - set-min-height - set-max-height - get-min-height - get-max-height - set-min-width - set-max-width - get-min-width - get-max-width - insert-file - load-file - insert-port - save-port - default-style-name - get-flattened-text - put-file - get-file - after-edit-sequence - on-edit-sequence - after-load-file - on-load-file - can-load-file? - after-save-file - on-save-file - can-save-file? - on-new-box - on-new-image-snip - size-cache-invalid - invalidate-bitmap-cache - on-paint - write-footers-to-file - write-headers-to-file - read-footer-from-file - read-header-from-file - write-to-file - read-from-file - set-filename - release-snip - on-snip-modified - set-modified - scroll-editor-to - set-snip-data - get-snip-data - needs-update - resized - set-caret-owner - scroll-to - on-display-size-when-ready - on-display-size - on-change - on-focus - on-default-char - on-default-event - on-local-char - on-local-event - find-first-snip - get-space - get-descent - get-extent - blink-caret - own-caret - refresh - adjust-cursor - on-char - on-event - copy-self-to - copy-self - kill - paste-x-selection - paste - copy - cut - insert - change-style) - (define-function get-the-editor-data-class-list) - (define-function get-the-snip-class-list) - (define-function editor-set-x-selection-mode) - (define-function add-pasteboard-keymap-functions) - (define-function add-text-keymap-functions) - (define-function add-editor-keymap-functions) - (define-function write-editor-global-footer) - (define-function write-editor-global-header) - (define-function read-editor-global-footer) - (define-function read-editor-global-header) - (define-function read-editor-version) - (define-function write-editor-version) - (define-function set-editor-print-margin) - (define-function get-editor-print-margin) (define-class bitmap% object% () #f get-argb-pixels get-gl-config @@ -375,6 +234,7 @@ on-event on-paint) (define-private-class dc% dc<%> object% () #f + cache-font-metrics-key get-alpha set-alpha glyph-exists? @@ -711,255 +571,6 @@ on-size on-set-focus on-kill-focus) - (define-class editor-canvas% canvas% () #f - on-char - on-event - on-paint - on-drop-file - pre-on-event - pre-on-char - on-size - on-set-focus - on-kill-focus - popup-for-editor - call-as-primary-owner - get-canvas-background - set-canvas-background - set-y-margin - set-x-margin - get-y-margin - get-x-margin - clear-margins - scroll-to - set-lazy-refresh - get-lazy-refresh - scroll-with-bottom-base - allow-scroll-to-last - force-display-focus - is-focus-on? - on-scroll-on-change - get-editor - set-editor - get-wheel-step - set-wheel-step) - (define-class editor-admin% object% () #f - modified - refresh-delayed? - popup-menu - update-cursor - needs-update - resized - grab-caret - scroll-to - get-max-view - get-view - get-dc) - (define-private-class editor-snip-editor-admin% editor-snip-editor-admin<%> editor-admin% () #f - get-snip) - (define-class snip-admin% object% () #f - modified - popup-menu - update-cursor - release-snip - needs-update - recounted - resized - set-caret-owner - scroll-to - get-view - get-view-size - get-dc - get-editor) - (define-class snip-class% object% () #f - reading-version - write-header - read-header - read - get-classname - set-classname - get-version - set-version) - (define-private-class snip-class-list% snip-class-list<%> object% () #f - nth - number - add - find-position - find) - (define-class keymap% object% () #f - remove-chained-keymap - chain-to-keymap - set-break-sequence-callback - call-function - remove-grab-mouse-function - set-grab-mouse-function - remove-grab-key-function - set-grab-key-function - add-function - map-function - break-sequence - handle-mouse-event - handle-key-event - set-double-click-interval - get-double-click-interval) - (define-class editor-wordbreak-map% object% () #f - get-map - set-map) - (define-function get-the-editor-wordbreak-map) - (define-class text% editor% () #f - call-clickback - remove-clickback - set-clickback - set-wordbreak-func - set-autowrap-bitmap - on-reflow - on-new-tab-snip - on-new-string-snip - caret-hidden? - hide-caret - get-wordbreak-map - set-wordbreak-map - find-wordbreak - set-region-data - get-region-data - get-revision-number - after-merge-snips - after-split-snip - after-set-size-constraint - on-set-size-constraint - can-set-size-constraint? - after-set-position - after-change-style - on-change-style - can-change-style? - after-delete - on-delete - can-delete? - after-insert - on-insert - can-insert? - set-tabs - get-tabs - set-overwrite-mode - get-overwrite-mode - set-file-format - get-file-format - write-to-file - read-from-file - get-character - get-text - find-next-non-string-snip - get-snip-position - get-snip-position-and-location - find-snip - find-string-all - find-string - set-styles-sticky - get-styles-sticky - set-line-spacing - get-line-spacing - set-paragraph-alignment - set-paragraph-margins - last-paragraph - paragraph-end-line - paragraph-start-line - line-paragraph - paragraph-end-position - paragraph-start-position - position-paragraph - last-line - last-position - line-length - line-end-position - line-start-position - line-location - position-locations - position-location - position-line - set-between-threshold - get-between-threshold - find-position-in-line - find-line - find-position - split-snip - change-style - do-paste-x-selection - do-paste - do-copy - kill - paste-next - paste-x-selection - paste - copy - cut - erase - delete - insert - get-top-line-base - flash-off - flash-on - get-anchor - set-anchor - get-visible-line-range - get-visible-position-range - scroll-to-position - move-position - set-position-bias-scroll - set-position - get-end-position - get-start-position - get-position - default-style-name - get-flattened-text - put-file - get-file - after-edit-sequence - on-edit-sequence - after-load-file - on-load-file - can-load-file? - after-save-file - on-save-file - can-save-file? - on-new-box - on-new-image-snip - size-cache-invalid - invalidate-bitmap-cache - on-paint - write-footers-to-file - write-headers-to-file - read-footer-from-file - read-header-from-file - set-filename - release-snip - on-snip-modified - set-modified - scroll-editor-to - set-snip-data - get-snip-data - needs-update - resized - set-caret-owner - scroll-to - on-display-size-when-ready - on-display-size - on-change - on-focus - on-default-char - on-default-event - on-local-char - on-local-event - find-first-snip - get-space - get-descent - get-extent - blink-caret - own-caret - refresh - adjust-cursor - on-char - on-event - copy-self-to - copy-self) (define-class menu% object% () #f select get-font @@ -984,46 +595,13 @@ (define-class menu-item% object% () #f id) (define-function id-to-menu-item) - (define-class editor-stream-in-base% object% () #f - read - bad? - skip - seek - tell) - (define-class editor-stream-out-base% object% () #f - write - bad? - seek - tell) - (define-class editor-stream-in-bytes-base% editor-stream-in-base% () #f) - (define-class editor-stream-out-bytes-base% editor-stream-out-base% () #f - get-bytes) - (define-class editor-stream-in% object% () #f - ok? - jump-to - tell - skip - remove-boundary - set-boundary - get-inexact - get-exact - get-fixed - get-unterminated-bytes - get-bytes - get) - (define-class editor-stream-out% object% () #f - ok? - pretty-finish - jump-to - tell - put-fixed - put) (define-class timer% object% () () stop start notify interval) (define-private-class clipboard% clipboard<%> object% () #f + same-clipboard-client? get-clipboard-bitmap set-clipboard-bitmap get-clipboard-data @@ -1033,6 +611,7 @@ (define-function get-the-x-selection) (define-function get-the-clipboard) (define-class clipboard-client% object% () () + same-eventspace? get-types add-type get-data @@ -1063,123 +642,6 @@ get-command) (define-function show-print-setup) (define-function can-show-print-setup?) - (define-class pasteboard% editor% () #f - set-scroll-step - get-scroll-step - set-selection-visible - get-selection-visible - set-dragable - get-dragable - after-interactive-resize - on-interactive-resize - can-interactive-resize? - after-interactive-move - on-interactive-move - can-interactive-move? - interactive-adjust-resize - interactive-adjust-move - interactive-adjust-mouse - on-double-click - after-select - on-select - can-select? - after-reorder - on-reorder - can-reorder? - after-resize - on-resize - can-resize? - after-move-to - on-move-to - can-move-to? - after-delete - on-delete - can-delete? - after-insert - on-insert - can-insert? - find-next-selected-snip - is-selected? - find-snip - get-center - remove-selected - no-selected - add-selected - set-selected - change-style - set-after - set-before - lower - raise - resize - move - move-to - remove - erase - do-paste-x-selection - do-paste - do-copy - delete - insert - default-style-name - get-flattened-text - put-file - get-file - after-edit-sequence - on-edit-sequence - after-load-file - on-load-file - can-load-file? - after-save-file - on-save-file - can-save-file? - on-new-box - on-new-image-snip - size-cache-invalid - invalidate-bitmap-cache - on-paint - write-footers-to-file - write-headers-to-file - read-footer-from-file - read-header-from-file - write-to-file - read-from-file - set-filename - release-snip - on-snip-modified - set-modified - scroll-editor-to - set-snip-data - get-snip-data - needs-update - resized - set-caret-owner - scroll-to - on-display-size-when-ready - on-display-size - on-change - on-focus - on-default-char - on-default-event - on-local-char - on-local-event - find-first-snip - get-space - get-descent - get-extent - blink-caret - own-caret - refresh - adjust-cursor - on-char - on-event - copy-self-to - copy-self - kill - paste-x-selection - paste - copy - cut) (define-class panel% window% () #f get-label-position set-label-position @@ -1227,302 +689,6 @@ on-size on-set-focus on-kill-focus) - (define-class snip% object% () #f - previous - next - set-unmodified - get-scroll-step-offset - find-scroll-step - get-num-scroll-steps - set-admin - resize - write - match? - can-do-edit-operation? - do-edit-operation - blink-caret - own-caret - adjust-cursor - on-char - on-event - size-cache-invalid - copy - get-text! - get-text - merge-with - split - draw - partial-offset - get-extent - release-from-owner - is-owned? - set-style - set-flags - set-count - get-admin - get-count - get-flags - get-style - get-snipclass - set-snipclass) - (define-class string-snip% snip% () #f - read - insert - set-unmodified - get-scroll-step-offset - find-scroll-step - get-num-scroll-steps - set-admin - resize - write - match? - can-do-edit-operation? - do-edit-operation - blink-caret - own-caret - adjust-cursor - on-char - on-event - size-cache-invalid - copy - get-text! - get-text - merge-with - split - draw - partial-offset - get-extent) - (define-class tab-snip% string-snip% () #f - set-unmodified - get-scroll-step-offset - find-scroll-step - get-num-scroll-steps - set-admin - resize - write - match? - can-do-edit-operation? - do-edit-operation - blink-caret - own-caret - adjust-cursor - on-char - on-event - size-cache-invalid - copy - get-text! - get-text - merge-with - split - draw - partial-offset - get-extent) - (define-class image-snip% snip% (equal<%>) #f - equal-secondary-hash-code-of - equal-hash-code-of - other-equal-to? - equal-to? - set-offset - get-bitmap-mask - get-bitmap - set-bitmap - get-filetype - get-filename - load-file - set-unmodified - get-scroll-step-offset - find-scroll-step - get-num-scroll-steps - set-admin - resize - write - match? - can-do-edit-operation? - do-edit-operation - blink-caret - own-caret - adjust-cursor - on-char - on-event - size-cache-invalid - copy - get-text! - get-text - merge-with - split - draw - partial-offset - get-extent) - (define-class editor-snip% snip% () #f - get-inset - set-inset - get-margin - set-margin - style-background-used? - use-style-background - border-visible? - show-border - set-align-top-line - get-align-top-line - set-tight-text-fit - get-tight-text-fit - get-min-height - get-min-width - set-min-height - set-min-width - get-max-height - get-max-width - set-max-height - set-max-width - set-unmodified - get-scroll-step-offset - find-scroll-step - get-num-scroll-steps - set-admin - resize - write - match? - can-do-edit-operation? - do-edit-operation - blink-caret - own-caret - adjust-cursor - on-char - on-event - size-cache-invalid - copy - get-text! - get-text - merge-with - split - draw - partial-offset - get-extent - set-editor - get-editor) - (define-class editor-data-class% object% () #f - read - get-classname - set-classname) - (define-private-class editor-data-class-list% editor-data-class-list<%> object% () #f - nth - number - add - find-position - find) - (define-class editor-data% object% () #f - set-next - write - get-dataclass - set-dataclass - get-next) - (define-private-class mult-color% mult-color<%> object% () #f - set - get - get-r - set-r - get-g - set-g - get-b - set-b) - (define-private-class add-color% add-color<%> object% () #f - set - get - get-r - set-r - get-g - set-g - get-b - set-b) - (define-class style-delta% object% () #f - copy - collapse - equal? - set-delta-foreground - set-delta-background - set-delta-face - set-delta - get-family - set-family - get-face - set-face - get-size-mult - set-size-mult - get-size-add - set-size-add - get-weight-on - set-weight-on - get-weight-off - set-weight-off - get-smoothing-on - set-smoothing-on - get-smoothing-off - set-smoothing-off - get-style-on - set-style-on - get-style-off - set-style-off - get-underlined-on - set-underlined-on - get-underlined-off - set-underlined-off - get-size-in-pixels-on - set-size-in-pixels-on - get-size-in-pixels-off - set-size-in-pixels-off - get-transparent-text-backing-on - set-transparent-text-backing-on - get-transparent-text-backing-off - set-transparent-text-backing-off - get-foreground-mult - get-background-mult - get-foreground-add - get-background-add - get-alignment-on - set-alignment-on - get-alignment-off - set-alignment-off) - (define-private-class style% style<%> object% () #f - switch-to - set-shift-style - get-shift-style - is-join? - set-delta - get-delta - set-base-style - get-base-style - get-text-width - get-text-space - get-text-descent - get-text-height - get-transparent-text-backing - get-alignment - get-background - get-foreground - get-font - get-size-in-pixels - get-underlined - get-smoothing - get-style - get-weight - get-size - get-face - get-family - get-name) - (define-class style-list% object% () #f - forget-notification - notify-on-change - style-to-index - index-to-style - convert - replace-named-style - new-named-style - find-named-style - find-or-create-join-style - find-or-create-style - number - basic-style) - (define-function get-the-style-list) (define-class tab-group% item% () #f button-focus set @@ -1551,7 +717,6 @@ (define-functions special-control-key special-option-key - map-command-as-meta-key application-file-handler application-quit-handler application-about-handler @@ -1576,20 +741,19 @@ shortcut-visible-in-label? eventspace-shutdown? in-atomic-region - set-editor-snip-maker - set-text-editor-maker - set-pasteboard-editor-maker set-menu-tester location->window set-dialogs set-executer send-event file-creator-and-type - set-snip-class-getter - set-editor-data-class-getter set-ps-procs main-eventspace? - eventspace-handler-thread) + eventspace-handler-thread + begin-refresh-sequence + end-refresh-sequence + run-printout + get-double-click-time) ) ;; end diff --git a/collects/mred/private/moredialogs.ss b/collects/mred/private/moredialogs.ss index 6dbc0e9c..3f9b1fc5 100644 --- a/collects/mred/private/moredialogs.ss +++ b/collects/mred/private/moredialogs.ss @@ -3,6 +3,7 @@ mzlib/etc mzlib/list (prefix wx: "kernel.ss") + (prefix wx: "wxme/style.ss") "lock.ss" "const.ss" "check.ss" diff --git a/collects/mred/private/mrmenu.ss b/collects/mred/private/mrmenu.ss index e04f6250..907e4250 100644 --- a/collects/mred/private/mrmenu.ss +++ b/collects/mred/private/mrmenu.ss @@ -3,6 +3,7 @@ mzlib/class100 mzlib/list (prefix wx: "kernel.ss") + (prefix wx: "wxme/keymap.ss") "lock.ss" "const.ss" "helper.ss" @@ -285,11 +286,12 @@ ":" "")]) (case (system-type) - [(unix windows) (format "~a~a~a~a~a?:~a" + [(unix windows) (format "~a~a~a~a?:~a" exact (if (memq 'shift prefix) "s:" "") - (if (memq 'meta prefix) "m:" "~m:") - (if (memq 'alt prefix) "m:" "~m:") + (if (or (memq 'meta prefix) + (memq 'alt prefix)) + "m:" "~m:") (if (memq 'ctl prefix) "c:" "") base)] [(macosx) (format "~a~a~a~a~a?:~a" diff --git a/collects/mred/private/mrpopup.ss b/collects/mred/private/mrpopup.ss index b9b7f77e..81a75c62 100644 --- a/collects/mred/private/mrpopup.ss +++ b/collects/mred/private/mrpopup.ss @@ -3,6 +3,7 @@ mzlib/class100 mzlib/list (prefix wx: "kernel.ss") + (prefix wx: "wxme/cycle.ss") "lock.ss" "const.ss" "helper.ss" @@ -63,4 +64,6 @@ (wx:queue-callback go wx:middle-queue-key) (go)))) (no-val->#f font))) - (super-init wx))))))) + (super-init wx)))))) + + (wx:set-popup-menu%! popup-menu%)) diff --git a/collects/mred/private/path-dialog.ss b/collects/mred/private/path-dialog.ss index 464eedc8..9b81def8 100644 --- a/collects/mred/private/path-dialog.ss +++ b/collects/mred/private/path-dialog.ss @@ -1,6 +1,7 @@ (module path-dialog mzscheme (require mzlib/class mzlib/list mzlib/string mzlib/file (prefix wx: "kernel.ss") + (prefix wx: "wxme/style.ss") "helper.ss" "mrtop.ss" "mritem.ss" "mrpanel.ss" "mrtextfield.ss" "messagebox.ss" "mrmenu.ss" (only scheme/base compose)) (provide path-dialog%) diff --git a/collects/mred/private/repl.ss b/collects/mred/private/repl.ss index f5c9b7f2..8f406c19 100644 --- a/collects/mred/private/repl.ss +++ b/collects/mred/private/repl.ss @@ -2,6 +2,7 @@ (require mzlib/class mzlib/class100 (prefix wx: "kernel.ss") + (prefix wx: "wxme/style.ss") "editor.ss" "app.ss" "mrtop.ss" diff --git a/collects/mred/private/seqcontract.ss b/collects/mred/private/seqcontract.ss index c16fd39c..0bfe0b5b 100644 --- a/collects/mred/private/seqcontract.ss +++ b/collects/mred/private/seqcontract.ss @@ -245,7 +245,7 @@ Matthew (not (locked-for-read?))) (set-position [(x) (x y) (x y z) (x y z p) (x y z p q)] unlocked) (set-autowrap-bitmap [(bitmap)] unlocked) - (print-to-dc [(dc)] unlocked) + (print-to-dc [(dc) (dc page)] unlocked) (move-position [(code?) (code? extend) (code? extend kind)] unlocked) (split-snip [(pos)] unlocked) (set-line-spacing [(space)] unlocked) diff --git a/collects/mred/private/snipfile.ss b/collects/mred/private/snipfile.ss index 11379e41..bd8ba41f 100644 --- a/collects/mred/private/snipfile.ss +++ b/collects/mred/private/snipfile.ss @@ -4,6 +4,8 @@ mzlib/port syntax/moddep (prefix wx: "kernel.ss") + (prefix wx: "wxme/snip.ss") + (prefix wx: "wxme/cycle.ss") "check.ss" "editor.ss") @@ -50,10 +52,10 @@ (error 'load-class "not a ~a% instance" id)))) #f)))]) ;; install the getters: - (wx:set-snip-class-getter + (wx:set-get-snip-class! (lambda (name) (load-one name 'snip-class wx:snip-class%))) - (wx:set-editor-data-class-getter + (wx:set-get-editor-data-class! (lambda (name) (load-one name 'editor-data-class wx:editor-data-class%)))) diff --git a/collects/mred/private/syntax.ss b/collects/mred/private/syntax.ss new file mode 100644 index 00000000..c195293b --- /dev/null +++ b/collects/mred/private/syntax.ss @@ -0,0 +1,266 @@ +#lang scheme/base +(require scheme/class + scheme/stxparam + (for-syntax scheme/base)) + +(provide defclass defclass* + def/public def/override define/top case-args + maybe-box? any? bool? nonnegative-real? make-or-false make-box make-list make-alts + make-literal symbol-in make-procedure + method-name init-name + let-boxes + properties field-properties init-properties + ->long) + +(define-syntax-parameter class-name #f) + +(define-syntax-rule (defclass name super . body) + (defclass* name super () . body)) +(define-syntax-rule (defclass* name super intfs . body) + (define name + (syntax-parameterize ([class-name 'name]) + (class* super intfs . body)))) + +(define-syntax (def/public stx) + #`(def/thing define/public #,stx)) +(define-syntax (def/override stx) + #`(def/thing define/override #,stx)) +(define-syntax (define/top stx) + #`(def/thing define #,stx)) + +(define (method-name class method) + (string->symbol (format "~a in ~a" method class))) +(define (init-name class) + (string->symbol (format "initialization for ~a" class))) + +(define-syntax just-id + (syntax-rules () + [(_ [id default]) id] + [(_ id) id])) + +(define-struct named-pred (pred make-name) + #:property prop:procedure (struct-field-index pred)) + +(define (apply-pred pred val) + (cond + [(procedure? pred) (pred val)] + [(class? pred) (val . is-a? . pred)] + [(interface? pred) (val . is-a? . pred)] + [else (error 'check-arg "unknown predicate type: ~e" pred)])) + +(define (make-or-false pred) + (make-named-pred (lambda (v) + (or (not v) (apply-pred pred v))) + (lambda () + (string-append (predicate-name pred) + " or #f")))) + +(define (make-box pred) + (make-named-pred (lambda (v) + (and (box? v) (apply-pred pred (unbox v)))) + (lambda () + (string-append "boxed " (predicate-name pred))))) + +(define (make-list pred) + (make-named-pred (lambda (v) + (and (list? v) (andmap (lambda (v) (apply-pred pred v)) v))) + (lambda () + (string-append "list of " (predicate-name pred))))) + +(define (make-alts a b) + (make-named-pred (lambda (v) + (or (apply-pred a v) (apply-pred b v))) + (lambda () + (string-append (predicate-name a) + " or " + (predicate-name b))))) + +(define (make-literal lit) + (make-named-pred (lambda (v) (equal? v lit)) + (lambda () (if (symbol? lit) + (format "'~s" lit) + (format "~s" lit))))) + +(define (make-symbol syms) + (make-named-pred (lambda (v) (memq v syms)) + (lambda () + (let loop ([syms syms]) + (cond + [(null? (cdr syms)) + (format "'~s" (car syms))] + [(null? (cddr syms)) + (format "'~s, or '~s" (car syms) (cadr syms))] + [else + (format "'~s, ~a" (car syms) (loop (cdr syms)))]))))) +(define-syntax-rule (symbol-in sym ...) + (make-symbol '(sym ...))) + +(define (make-procedure arity) + (make-named-pred (lambda (p) + (and (procedure? p) + (procedure-arity-includes? p arity))) + (lambda () + (format "procedure (arity ~a)" arity)))) + +(define (check-arg val pred pos) + (if (apply-pred pred val) + #f + (cons (predicate-name pred) + pos))) + +(define (predicate-name pred) + (cond + [(named-pred? pred) ((named-pred-make-name pred))] + [(procedure? pred) (let ([s (symbol->string (object-name pred))]) + (substring s 0 (sub1 (string-length s))))] + [(or (class? pred) (interface? pred)) + (format "~a instance" (object-name pred))] + [else "???"])) + +(define maybe-box? (make-named-pred (lambda (v) (or (not v) (box? v))) + (lambda () "box or #f"))) +(define (any? v) #t) +(define (bool? v) #t) +(define (nonnegative-real? v) (and (real? v) (v . >= . 0))) + +(define (method-of cls nam) + (if cls + (string->symbol (format "~a method of ~a" nam cls)) + nam)) + +(define-syntax (def/thing stx) + (syntax-case stx () + [(_ define/orig (_ (id [arg-type arg] ...))) + (raise-syntax-error #f "missing body" stx)] + [(_ define/orig (_ (id [arg-type arg] ...) . body)) + (with-syntax ([(_ _ orig-stx) stx] + [(pos ...) (for/list ([i (in-range (length (syntax->list #'(arg ...))))]) + i)] + [cname (syntax-parameter-value #'class-name)]) + (syntax/loc #'orig-stx + (define/orig (id arg ...) + (let ([bad (or (check-arg (just-id arg) arg-type pos) + ...)]) + (when bad + (raise-type-error (method-of 'cname 'id) (car bad) (cdr bad) (just-id arg) ...))) + (let () + . body))))])) + +(define-for-syntax lifted (make-hash)) +(define-syntax (lift-predicate stx) + (syntax-case stx () + [(_ id) (identifier? #'id) #'id] + [(_ expr) + (let ([d (syntax->datum #'expr)]) + (or (hash-ref lifted d #f) + (let ([id (syntax-local-lift-expression #'expr)]) + (hash-set! lifted d id) + id)))])) + +(define-syntax (case-args stx) + (syntax-case stx () + [(_ expr [([arg-type arg] ...) rhs ...] ... who) + (with-syntax ([((min-args-len . max-args-len) ...) + (map (lambda (args) + (let ([args (syntax->list args)]) + (cons (let loop ([args args]) + (if (or (null? args) + (not (identifier? (car args)))) + 0 + (add1 (loop (cdr args))))) + (length args)))) + (syntax->list #'((arg ...) ...)))]) + #'(let* ([args expr] + [len (length args)]) + (find-match + (lambda (next) + (if (and (len . >= . min-args-len) + (len . <= . max-args-len)) + (apply + (lambda (arg ...) + (if (and (not (check-arg (just-id arg) (lift-predicate arg-type) 0)) ...) + (lambda () rhs ...) + next)) + args) + next)) + ... + (lambda (next) + (bad-args who args)))))])) + +(define (bad-args who args) + (error who "bad argument combination:~a" + (apply string-append (map (lambda (x) (format " ~e" x)) + args)))) + +(define-syntax find-match + (syntax-rules () + [(_ proc) + ((proc #f))] + [(_ proc1 proc ...) + ((proc1 (lambda () (find-match proc ...))))])) + +(define-syntax-rule (let-boxes ([id init] ...) + call + body ...) + (let ([id (box init)] ...) + call + (let ([id (unbox id)] ...) + body ...))) + +(define-syntax (do-properties stx) + (syntax-case stx () + [(_ define-base check-immutable [[type id] expr] ...) + (let ([ids (syntax->list #'(id ...))]) + (with-syntax ([(getter ...) + (map (lambda (id) + (datum->syntax id + (string->symbol + (format "get-~a" (syntax-e id))) + id)) + ids)] + [(setter ...) + (map (lambda (id) + (datum->syntax id + (string->symbol + (format "set-~a" (syntax-e id))) + id)) + ids)]) + #'(begin + (define-base id expr) ... + (define/public (getter) id) ... + (def/public (setter [type v]) (check-immutable 'setter) (set! id (coerce type v))) ...)))])) + +(define-syntax coerce + (syntax-rules (bool?) + [(_ bool? v) (and v #t)] + [(_ _ v) v])) + +(define-syntax properties + (syntax-rules () + [(_ #:check-immutable check-immutable . props) + (do-properties define check-immutable . props)] + [(_ . props) + (do-properties define void . props)])) +(define-syntax field-properties + (syntax-rules () + [(_ #:check-immutable check-immutable . props) + (do-properties define-field check-immutable . props)] + [(_ . props) + (do-properties define-field void . props)])) +(define-syntax-rule (define-field id val) (field [id val])) +(define-syntax init-properties + (syntax-rules () + [(_ #:check-immutable check-immutable . props) + (do-properties define-init check-immutable . props)] + [(_ . props) + (do-properties define-init void . props)])) +(define-syntax-rule (define-init id val) (begin + (init [(internal id) val]) + (define id internal))) + +(define (->long i) + (cond + [(eqv? -inf.0 i) (- (expt 2 64))] + [(eqv? +inf.0 i) (expt 2 64)] + [(eqv? +nan.0 i) 0] + [else (inexact->exact (floor i))])) diff --git a/collects/mred/private/wxcanvas.ss b/collects/mred/private/wxcanvas.ss index 8f926a6b..2bef5bab 100644 --- a/collects/mred/private/wxcanvas.ss +++ b/collects/mred/private/wxcanvas.ss @@ -2,6 +2,8 @@ (require mzlib/class mzlib/class100 (prefix wx: "kernel.ss") + (prefix wx: "wxme/text.ss") + (prefix wx: "wxme/editor-canvas.ss") "lock.ss" "helper.ss" "wx.ss" @@ -216,6 +218,11 @@ (when mred (as-exit (lambda () (send init-buffer add-canvas mred))))))))) - (define wx-editor-canvas% (make-canvas-glue% - (make-editor-canvas% (make-control% wx:editor-canvas% - 0 0 #t #t))))) + (define wx-editor-canvas% + (class (make-canvas-glue% + (make-editor-canvas% (make-control% wx:editor-canvas% + 0 0 #t #t))) + (inherit editor-canvas-on-scroll) + (define/override (on-scroll e) + (editor-canvas-on-scroll)) + (super-new)))) diff --git a/collects/mred/private/wxme/const.ss b/collects/mred/private/wxme/const.ss new file mode 100644 index 00000000..37c0eb4a --- /dev/null +++ b/collects/mred/private/wxme/const.ss @@ -0,0 +1,5 @@ +#lang scheme/base + +(provide (all-defined-out)) + +(define CURSOR-WIDTH 2) diff --git a/collects/mred/private/wxme/cycle.ss b/collects/mred/private/wxme/cycle.ss new file mode 100644 index 00000000..7bc95563 --- /dev/null +++ b/collects/mred/private/wxme/cycle.ss @@ -0,0 +1,27 @@ +#lang scheme/base + +(define-syntax-rule (decl id set-id) + (begin + (provide id set-id) + (define id #f) + (define (set-id v) (set! id v)))) + +(decl text% set-text%!) +(decl pasteboard% set-pasteboard%!) +(decl snip-admin% set-snip-admin%!) +(decl editor-stream-in% set-editor-stream-in%!) +(decl editor-stream-out% set-editor-stream-out%!) +(decl editor-snip% set-editor-snip%!) +(decl editor-snip-editor-admin% set-editor-snip-editor-admin%!) + +(decl extended-editor-snip% set-extended-editor-snip%!) +(decl extended-text% set-extended-text%!) +(decl extended-pasteboard% set-extended-pasteboard%!) + +(decl get-snip-class set-get-snip-class!) +(decl get-editor-data-class set-get-editor-data-class!) + +(decl editor-get-file set-editor-get-file!) +(decl editor-put-file set-editor-put-file!) + +(decl popup-menu% set-popup-menu%!) diff --git a/collects/mred/private/wxme/editor-admin.ss b/collects/mred/private/wxme/editor-admin.ss new file mode 100644 index 00000000..8ece0cf2 --- /dev/null +++ b/collects/mred/private/wxme/editor-admin.ss @@ -0,0 +1,57 @@ +#lang scheme/base +(require scheme/class + "../syntax.ss" + "snip.ss" + "private.ss" + (only-in "cycle.ss" popup-menu%)) + +(provide editor-admin%) + +(defclass editor-admin% object% + (super-new) + + (define standard 0) ; used to recognize standard display + (define/public (get-s-standard) standard) + (define/public (set-s-standard v) (set! standard v)) + + (def/public (get-dc [maybe-box? [x #f]] [maybe-box? [y #f]]) + (when x (set-box! x 0.0)) + (when y (set-box! y 0.0)) + #f) + + (define/private (do-get-view x y w h) + (when x (set-box! x 0.0)) + (when y (set-box! y 0.0)) + (when w (set-box! w 0.0)) + (when h (set-box! h 0.0))) + + (def/public (get-view [maybe-box? x] [maybe-box? y] + [maybe-box? w] [maybe-box? h] + [any? [full? #f]]) + (do-get-view x y w h)) + + (def/public (get-max-view [maybe-box? x] [maybe-box? y] + [maybe-box? w] [maybe-box? h] + [any? [full? #f]]) + (get-view x y w h)) + + (def/public (scroll-to [real? localx] [real? localy] [real? w] [real? h] [any? [refresh? #t]] + [(symbol-in start none end) [bias 'none]]) + (void)) + + (def/public (grab-caret [(symbol-in immediate display global) dist]) + (void)) + + (def/public (resized [any? redraw-now]) (void)) + + (def/public (needs-update [real? x] [real? y] + [nonnegative-real? w] [nonnegative-real? h]) + (void)) + + (def/public (update-cursor) (void)) + + (def/public (delay-refresh?) #f) + + (def/public (popup-menu [popup-menu% m] [real? x] [real? y]) #f) + + (def/public (modified [any? mod?]) (void))) diff --git a/collects/mred/private/wxme/editor-canvas.ss b/collects/mred/private/wxme/editor-canvas.ss new file mode 100644 index 00000000..cec33592 --- /dev/null +++ b/collects/mred/private/wxme/editor-canvas.ss @@ -0,0 +1,1133 @@ +#lang scheme/base +(require scheme/class + "../syntax.ss" + "editor.ss" + "editor-admin.ss" + "private.ss" + (only-in "cycle.ss" popup-menu%) + "wx.ss") + +(provide editor-canvas%) + +;; FIXME: need contracts on public classes + +;; ---------------------------------------- + +(define simple-scroll% + (class object% + (define horizontal #f) + (define count 0) + (define page-step 0) + (define value 0) + + (init canvas + style + length + steps-per-page + position) + + (super-new) + + (set! count length) + (set! page-step steps-per-page) + (set! value position) + + (set! horizontal (and (memq 'horizontal style) #t)) + (set-scroll length steps-per-page position) + + (define/public (set-value position) + (set! value (max 0 (min count position)))) + + (define/public (set-scroll length steps-per-page position) + (when (length . > . -1) + (set! count length)) + (when (steps-per-page . > . 0) + (set! page-step steps-per-page)) + (when (position . > . -1) + (set! value position)) + + (when (value . < . 0) + (set! value 0)) + (when (value . > . count) + (set! value count))) + + (define/public (get-value) + value))) + +;; ---------------------------------------- + +(define update-cursor-timer% + (class timer% + (inherit start stop) + (init-field admin) + + (super-new) + + (define/override (notify) + (stop) + (when admin + (send admin clear-update-cursor-timer) + (send (send admin get-canvas) update-cursor-now))) + + (define/public (cancel) + (set! admin #f)))) + +;; ---------------------------------------- + +(define BLINK-DELAY 500) + +(define blink-timer% + (class timer% + (inherit stop) + (init-field canvas) + + (super-new) + + (define/override (notify) + (when canvas + (send canvas blink-caret))) + + (define/public (kill) + (set! canvas #f) + (stop)))) + +;; ---------------------------------------- + +(define AUTO-DRAG-DELAY 100) + +(define auto-drag-timer% + (class timer% + (inherit start stop) + (init-field canvas event) + + (super-new) + + (start AUTO-DRAG-DELAY #t) + + (define/override (notify) + (when canvas + (let ([e (make-object mouse-event% (send event get-event-type))]) + (send e set-alt-down (send event get-alt-down)) + (send e set-caps-down (send event get-caps-down)) + (send e set-control-down (send event get-control-down)) + (send e set-left-down (send event get-left-down)) + (send e set-meta-down (send event get-meta-down)) + (send e set-middle-down (send event get-middle-down)) + (send e set-right-down (send event get-right-down)) + (send e set-shift-down (send event get-shift-down)) + (send e set-x (send event get-x)) + (send e set-y (send event get-y)) + (send e set-time-stamp + (+ (send e get-time-stamp) AUTO-DRAG-DELAY)) + (send canvas on-event event)))) + + (define/public (kill) + (set! canvas #f) + (stop)))) + +;; ---------------------------------------- + +(define default-wheel-amt 3) + +(define (INIT-SB style) + (append + (if (or (memq 'no-hscroll style) + (memq 'hide-hscroll style)) + null + '(hscroll)) + (if (or (memq 'no-vscroll style) + (memq 'hide-vscroll style)) + null + '(vscroll)))) + +(define (memq? s l) (and (memq s l) #t)) + +(define (keep-style l s) (if (memq s l) (list s) null)) + +(defclass editor-canvas% canvas% + + (inherit refresh get-canvas-background get-dc + get-client-size get-size set-cursor + get-scroll-pos set-scroll-pos + get-scroll-page set-scroll-page + get-scroll-range set-scroll-range + is-shown-to-root? + show-scrollbars) + + (define blink-timer #f) + (define noloop? #f) + + (define focuson? #f) + (define focusforcedon? #f) + (define/public (get-focusforcedon?) focusforcedon?) + (define lazy-refresh? #f) + (define need-refresh? #f) + + (define auto-dragger #f) + + (define custom-cursor #f) + (define custom-cursor-on? #f) + + (define scroll-to-last? #f) + (define scroll-bottom-based? #f) + (define scroll-offset 0) + + (define lastwidth -1) + (define lastheight -1) + + (define last-x 0) + (define last-y 0) + + (define bg-color #f) + + (define wheel-amt default-wheel-amt) + (define xmargin 5) + (define ymargin 5) + + (set! noloop? #t) + (init parent x y width height + name style + [scrolls-per-page 100] + [editor #f] + [gl-config #f]) + + (super-make-object parent + x y width height + (append (keep-style style 'border) + (INIT-SB style) + (keep-style style 'invisible) + (if (memq 'transparent style) + '(transparent) + '(no-autoclear)) + (keep-style style 'control-border) + (keep-style style 'combo-side) + (keep-style style 'resize-corner)) + name + gl-config) + + (define given-h-scrolls-per-page scrolls-per-page) + + (define allow-x-scroll? (not (memq 'no-hscroll style))) + (define allow-y-scroll? (not (memq 'no-vscroll style))) + + (define fake-x-scroll? (or (not allow-x-scroll?) + (memq? 'hide-hscroll style))) + (define fake-y-scroll? (or (not allow-y-scroll?) + (memq? 'hide-vscroll style))) + + (define auto-x? (and (not fake-x-scroll?) + (memq? 'auto-hscroll style))) + (define auto-y? (and (not fake-y-scroll?) + (memq? 'auto-vscroll style))) + + (define xscroll-on? (and (not fake-x-scroll?) (not auto-x?))) + (define yscroll-on? (and (not fake-y-scroll?) (not auto-y?))) + + (show-scrollbars xscroll-on? yscroll-on?) + (super set-scrollbars + 1 1 ;; Windows fake-{x,y}-scroll => -1 instead of 1 !? + 1 1 ;; + 1 1 0 0 #f) + + (define hscroll + (if fake-x-scroll? + (new simple-scroll% + [canvas this] + [style '(horizontal)] + [length 0] + [steps-per-page 1] + [position 0]) + #f)) + (define vscroll + (if fake-y-scroll? + (new simple-scroll% + [canvas this] + [style '(vertical)] + [length 0] + [steps-per-page 1] + [position 0]) + #f)) + + (define scroll-width (if fake-x-scroll? 1 1)) ;; else used to be 0 + (define scroll-height (if fake-y-scroll? 1 1)) + + (define hscrolls-per-page 1) + (define vscrolls-per-page 1) + (define hpixels-per-scroll 0) + + (set! noloop? #f) + + (define admin (new canvas-editor-admin% + [canvas this])) + (send admin adjust-std-flag) + + (define media editor) + (when media (set-editor media)) + + ;; FIXME: needed? + (define/public (~) + (when auto-dragger + (send auto-dragger kill) + (set! auto-dragger #f)) + (when blink-timer + (send blink-timer kill) + (set! blink-timer #f)) + (send admin set-canvas #f) + #;(super ~)) + + (define/override (on-size w h) + (unless noloop? + (unless (and (= w lastwidth) + (= h lastheight)) + (unless (and media + (send media get-printing)) + (reset-size))))) + + (define/private (reset-size) + (reset-visual #f) + (refresh)) + + (define/public (set-x-margin x) + (unless (= x xmargin) + (set! xmargin x) + (reset-size))) + (define/public (set-y-margin y) + (unless (= y ymargin) + (set! ymargin y) + (reset-size))) + (define/public (get-x-margin) xmargin) + (define/public (get-y-margin) ymargin) + + (define/override (set-canvas-background c) + (super set-canvas-background c) + (refresh)) + + (define-syntax-rule (using-admin body ...) + (let ([oldadmin (send media get-admin)]) + (unless (eq? admin oldadmin) + (send media set-admin admin)) + (begin0 + (begin body ...) + (when media + (unless (eq? admin oldadmin) + ;; FIXME: how do we know that this adminstrator + ;; still wants the editor? + (send media set-admin oldadmin)))))) + + (define/private (get-eventspace) + (send (send this get-top-level) get-eventspace)) + + (define/private (on-focus focus?) + (unless (eq? focus? focuson?) + (set! focuson? focus?) + (when (and media + (not (send media get-printing))) + (using-admin + (when media + (send media own-caret focus?)))) + (when focuson? + (unless blink-timer + (set! blink-timer (parameterize ([current-eventspace (get-eventspace)]) + (new blink-timer% [canvas this])))) + (send blink-timer start BLINK-DELAY #t)))) + + (define/public (blink-caret) + (when focuson? + (when media + (using-admin + (when media + (send media blink-caret)))) + (send blink-timer start BLINK-DELAY #t))) + + (define/public (call-as-primary-owner thunk) + (if media + (using-admin + (thunk)) + (thunk))) + + (define/override (on-set-focus) + (on-focus #t)) + (define/override (on-kill-focus) + (on-focus #f)) + + (define/public (is-focus-on?) focuson?) + + (define (force-display-focus on?) + (let ([old-on? focusforcedon?]) + (set! focusforcedon? on?) + (send admin adjust-std-flag) + (when (not (equal? (or focuson? focusforcedon?) + (or focuson? old-on?))) + (refresh)))) + + + (define/override (on-event event) + ;; Turn off auto-dragger, if there is one + (when auto-dragger + (send auto-dragger kill) + (set! auto-dragger #f)) + + (let ([x (send event get-x)] + [y (send event get-y)]) + (set! last-x x) + (set! last-y y) + + (when (and media + (not (send media get-printing))) + (using-admin + (when media + (set-custom-cursor + (send media adjust-cursor event))) + (when media + (send media on-event event)))) + + (when (send event dragging?) + (let-boxes ([cw 0] + [ch 0]) + (get-client-size cw ch) + (when (or (x . < . 0) + (y . < . 0) + (x . > . cw) + (y . > . ch)) + ;; Dragging outside the canvas: auto-generate more events because the buffer + ;; is probably scrolling. But make sure we're shown. + (when (is-shown-to-root?) + (set! auto-dragger (parameterize ([current-eventspace (get-eventspace)]) + (new auto-drag-timer% + [canvas this] + [event event]))))))))) + + (define/private (update-cursor-now) + (when media + (let ([e (new mouse-event% [type 'motion])]) + (send e set-x last-x) + (send e set-y last-y) + (send e set-timestamp 0) + + (using-admin + (when media + (set-custom-cursor (send media adjust-cursor e))))))) + + (define/public (popup-for-editor b m) #f) + + (define/override (on-char event) + (let ([code (send event get-key-code)]) + (case (and (positive? wheel-amt) + code) + [(wheel-up wheel-down) + (when (and allow-y-scroll? + (not fake-y-scroll?)) + (let-boxes ([x 0] + [y 0]) + (get-scroll x y) + (let ([y (max (+ y + (if (eq? code 'wheel-up) + -1 + 1)) + 0)]) + (scroll x y #t))))] + [else + (when (and media (not (send media get-printing))) + (using-admin + (when media + (send media on-char event))))]))) + + (define/public (clear-margins) + ;; This method is called by `on-paint' in `editor-canvas%' + ;; before it calls the `on-paint' in `canvas%'. It's + ;; essentially a compromise between autoclear mode and + ;; no-autoclear mode. + + (when (or (positive? xmargin) + (positive? ymargin)) + (let ([bg (get-canvas-background)]) + (when bg + (let ([cw (box 0)] + [ch (box 0)] + [b (send the-brush-list find-or-create-brush bg 'solid)] + [p (send the-pen-list find-or-create-pen "BLACK" 0 'transparent)] + [dc (get-dc)]) + (get-client-size cw ch) + (let ([ob (send dc get-brush)] + [op (send dc get-pen)] + [cw (unbox cw)] + [ch (unbox ch)]) + (send dc set-brush b) + (send dc set-pen p) + + (send dc draw-rectangle 0 0 xmargin ch) + (send dc draw-rectangle (- cw xmargin) 0 cw ch) + (send dc draw-rectangle 0 0 cw ymargin) + (send dc draw-rectangle 0 (- ch ymargin) cw ch) + + (send dc set-brush ob) + (send dc set-pen op))))))) + + (define/override (on-paint) + (set! need-refresh? #f) + (if media + (when (not (send media get-printing)) + (let-boxes ([x 0][y 0][w 0][h 0]) + (get-view x y w h) + (redraw x y w h))) + (let ([bg (get-canvas-background)]) + (when bg + (let ([adc (get-dc)]) + (send adc set-background bg) + (send adc clear))))) + (super on-paint)) + + (define/public (repaint) + (unless need-refresh? + (if (or lazy-refresh? (not (get-canvas-background))) + (begin + (set! need-refresh? #t) + (refresh)) + (on-paint)))) + + (define/private (paint-scrolls) (void)) + + (define/public (set-lazy-refresh on?) + (set! lazy-refresh? on?) + (when (and (not on?) + need-refresh?) + (on-paint))) + + (define (get-lazy-refresh) lazy-refresh?) + + (define/public (set-custom-cursor cursor) + (if (not cursor) + (no-custom-cursor) + (begin + (set! custom-cursor-on? #t) + (set! custom-cursor cursor) + (set-cursor custom-cursor)))) + + (define arrow #f) + (define/public (no-custom-cursor) + (when (not arrow) + (set! arrow (make-object cursor% 'arrow))) + (when custom-cursor-on? + (set! custom-cursor-on? #f) + (set-cursor arrow))) + + + (define/public (get-dc-and-offset fx fy) + (when (or fx fy) + (let-boxes ([x 0] + [y 0]) + (get-scroll x y) + (when fx + (set-box! fx (- (* x hpixels-per-scroll) xmargin))) + (when fy + (if (and media + (or (positive? y) + scroll-bottom-based?)) + (let ([v (- (send media scroll-line-location (+ y scroll-offset)) + ymargin)]) + (set-box! fy v) + (when (and scroll-bottom-based? + (or (positive? scroll-height) + scroll-to-last?)) + (let-boxes ([w 0] [h 0]) + (get-client-size w h) + (let ([h (max (- h (* 2 ymargin)) + 0)]) + (set-box! fy (- (unbox fy) h)))))) + (set-box! fy (- ymargin)))))) + (get-dc)) + + (define/public (get-view fx fy fw fh [unused-full? #f]) + (let ([w (box 0)] + [h (box 0)]) + (get-client-size w h) + (get-dc-and-offset fx fy) + (when fx + (set-box! fx (+ (unbox fx) xmargin))) + (when fy + (set-box! fy (+ (unbox fy) ymargin))) + (when fh + (set-box! fh (max 0 (- (unbox h) (* 2 ymargin))))) + (when fw + (set-box! fw (max 0 (- (unbox w) (* 2 xmargin))))))) + + (define/public (redraw localx localy fw fh) + (when (and media + (not (send media get-printing))) + (begin-refresh-sequence) + (let ([x (box 0)] + [y (box 0)] + [w (box 0)] + [h (box 0)]) + (get-view x y w h) + (let ([x (unbox x)] + [y (unbox y)] + [w (unbox w)] + [h (unbox h)]) + (let ([right (+ x w)] + [bottom (+ y h)]) + (let ([x (max x localx)] + [y (max y localy)] + [right (min right (+ localx fw))] + [bottom (min bottom (+ localy fh))]) + (let ([w (max 0 (- right x))] + [h (max 0 (- bottom y))]) + (when (or (positive? w) + (positive? h)) + (using-admin + (when media + (send media refresh + x y w h + (if (or focuson? focusforcedon?) + 'show-caret + 'show-inactive-caret) + (get-canvas-background)))))))))) + (end-refresh-sequence))) + + + (def/public (scroll-to [real? localx] [real? localy] [real? fw] [real? fh] [any? refresh?] + [(symbol-in start none end) [bias 'none]]) + (let ([med media]) + (if (or (not med) + (send med get-printing) + (and (not allow-x-scroll?) + (not allow-y-scroll?))) + #f + (let-boxes ([x 0] + [y 0] + [iw 0] + [ih 0]) + (get-view x y iw ih) + (if (or (zero? iw) + (zero? ih)) + #f + (let ([find-dy (if scroll-bottom-based? + ih + 0)]) + (let-boxes ([cx 0] + [cy 0]) + (get-scroll cx cy) + (let ([sy + (if allow-y-scroll? + (cond + [(or + ;; doesn't fit and bias is set: + (and (eq? bias 'start) (fh . > . ih)) + ;; fits, need to shift down into view: + (and (fh . <= . ih) (localy . < . y) ) + ;; doesn't fit, no conflicting bias, can shift up to see more: + (and (fh . > . ih) (not (eq? bias 'end)) (localy . < . y))) + (- (send med find-scroll-line (+ find-dy localy)) + scroll-offset)] + [(or + ;; doesn't fit, bias is set: + (and (eq? bias 'end) (fh . > . ih)) + ;; fits, need to shift up into view: + (and (fh . <= . ih) ((+ y ih) . < . (+ localy fh)))) + (let ([l (+ find-dy localy (- fh ih))]) + ;; find scroll pos for top of region to show: + (let ([sy (send med find-scroll-line l)]) + ;; unless l is exactly the top of a line, move down to the next whole line: + (let ([sy (if (= (send med scroll-line-location sy) l) + sy + (+ sy 1))]) + (- sy scroll-offset))))] + [(or + ;; doesn't fit, no conflicting bias, maybe shift down to see more: + (and (fh . > . ih) + (not (eq? bias 'start)) + ((+ localy fh) . > . (+ y ih)))) + ;; shift to one more than the first scroll position that shows last line + (let ([my (+ (send med find-scroll-line (+ find-dy localy (- fh ih))) + (- 1 scroll-offset))]) + ;; but only shift down the extra line if doing so doesn't skip the whole area + (cond + [((send med scroll-line-location my) . < . (+ find-dy localy fh)) + my] + [(my . > . 0) + (- my 1)] + [else 0]))] + [else cy]) + cy)] + [sx + (if allow-x-scroll? + (if (positive? hpixels-per-scroll) + (cond + [(or (and (eq? bias 'start) (fw . > . iw)) + (and (fw . < . iw) (localx . < . x)) + (and (fw . > . iw) (not (eq? bias 'end)) (localx . < . x))) + (quotient localx hpixels-per-scroll)] + [(or (and (eq? bias 'end) (fw . > . iw)) + (and (fw . < . iw) ((+ x iw) . < . (+ localx fw))) + (and (fw . > . iw) (not (eq? bias 'start)) ((+ localx fw) . > . (+ x iw)))) + (+ (quotient (+ localx (- fw iw)) hpixels-per-scroll) 1)] + [else cx]) + 0) + cx)]) + (if (or (not (= sy cy)) + (not (= sx cx))) + (begin + (when hscroll + (send hscroll set-value sx)) + (when vscroll + (send vscroll set-value sy)) + (scroll sx sy refresh?) + #t) + #f))))))))) + + (define/public (reset-visual reset-scroll?) + (if (given-h-scrolls-per-page . < . 0) + (begin + (set! given-h-scrolls-per-page -2) + #f) + (let loop ([retval #f]) + (let-boxes ([sx 0] + [sy 0]) + (get-scroll sx sy) + (let-boxes ([lw 0] + [lh 0]) + (get-size lw lh) + (set! lastwidth lw) + (set! lastheight lh) + + (let-values ([(x y vnum-scrolls hnum-scrolls vspp hspp) + (if (and media (or allow-x-scroll? allow-y-scroll?)) + + (let ([med media]) + (let-values ([(x y) + (if reset-scroll? + (values 0 0) + (values sx sy))]) + + (let-boxes ([w 0.0] + [h 0.0]) + (get-view #f #f w h) + (let-boxes ([total-width 0.0] + [total-height 0.0]) + (send med get-extent total-width total-height) + + (let-values ([(vnum-scrolls scroll-offset) + (if (or (zero? h) + (and (not scroll-to-last?) + (h . >= . total-height))) + (values 0 0) + + (if scroll-bottom-based? + (let ([vnum-scrolls (- (send med num-scroll-lines) 1)]) + (if scroll-to-last? + (values vnum-scrolls 1) + (let ([start (- (send med find-scroll-line (+ h 1)) 1)]) + (values (- vnum-scrolls start) + (+ scroll-offset start))))) + (let ([top (max 0 + (- (->long (- total-height + (if scroll-to-last? + 0 + h))) + 1))]) + (let ([vnum-scrolls (+ (send med find-scroll-line top) 1)] + [nsl (send med num-scroll-lines)]) + (values (if (vnum-scrolls . >= . nsl) + (- nsl 1) + vnum-scrolls) + 0)))))]) + + (let-values ([(num-scrolls vspp) + (if (positive? vnum-scrolls) + (let ([num-lines (- (send med num-scroll-lines) 1)]) + (values vnum-scrolls + (max 1 + (- (->long + (/ (* h num-lines) + total-height)) + 1)))) + (values 0 1))]) + + (let-values ([(hnum-scrolls hspp) + (if (total-width . >= . w) + (let ([tw (->long (- total-width w))]) + (set! hpixels-per-scroll + (let ([v (->long (/ w given-h-scrolls-per-page))]) + (if (zero? v) 2 v))) + (let ([tw + (if (modulo tw hpixels-per-scroll) + (+ tw (- hpixels-per-scroll (modulo tw hpixels-per-scroll))) + tw)]) + (values (quotient tw hpixels-per-scroll) + given-h-scrolls-per-page))) + (values 0 1))]) + + (values x y vnum-scrolls hnum-scrolls vspp hspp)))))))) + + (begin0 + (values 0 0 0 0 1 1) + (when (not media) + (let ([dc (get-dc)]) + (send dc set-background (get-canvas-background)) + (send dc clear)))))]) + + (if (not (and (= scroll-width hnum-scrolls) + (= scroll-height vnum-scrolls) + (= vspp vscrolls-per-page) + (= hspp hscrolls-per-page) + (= x sx) + (= y sy))) + (begin + (when hscroll + (send hscroll set-scroll hnum-scrolls hspp x)) + (when vscroll + (send vscroll set-scroll vnum-scrolls vspp y)) + (let ([savenoloop? noloop?] + [save-h-s-p-p given-h-scrolls-per-page]) + (set! noloop? #t) + (set! given-h-scrolls-per-page -1) + + (let ([xon? (and (not fake-x-scroll?) (not (zero? hnum-scrolls)))] + [yon? (and (not fake-y-scroll?) (not (zero? vnum-scrolls)))]) + (let ([go-again? + (if (or (and auto-x? (not (eq? xon? xscroll-on?))) + (and auto-y? (not (eq? yon? yscroll-on?)))) + (begin + (when auto-x? + (set! xscroll-on? xon?)) + (when auto-y? + (set! yscroll-on? yon?)) + (show-scrollbars xscroll-on? yscroll-on?) + (on-scroll-on-change) + #t) + #f)]) + + (unless fake-x-scroll? + (let ([x (min x hnum-scrolls)]) + (when (hspp . < . hscrolls-per-page) + (set-scroll-page 'horizontal hspp)) + (when (x . < . sx) + (set-scroll-pos 'horizontal x)) + (when (not (= scroll-width hnum-scrolls)) + (set-scroll-range 'horizontal hnum-scrolls)) + (when (x . > . sx) + (set-scroll-pos 'horizontal x)) + (when (hspp . > . hscrolls-per-page) + (set-scroll-page 'horizontal hspp)))) + + (unless fake-y-scroll? + (let ([y (min y vnum-scrolls)]) + (when (vspp . < . vscrolls-per-page) + (set-scroll-page 'vertical vspp)) + (when (y . < . sy) + (set-scroll-pos 'vertical y)) + (when (not (= scroll-height vnum-scrolls)) + (set-scroll-range 'vertical vnum-scrolls)) + (when (y . > . sy) + (set-scroll-pos 'vertical y)) + (when (vspp . > . vscrolls-per-page) + (set-scroll-page 'vertical vspp)))) + + (let ([go-again? (or go-again? + (given-h-scrolls-per-page . < . -1))]) + (set! given-h-scrolls-per-page save-h-s-p-p) + (set! noloop? savenoloop?) + (set! hscrolls-per-page hspp) + (set! vscrolls-per-page vspp) + (set! scroll-width hnum-scrolls) + (set! scroll-height vnum-scrolls) + + (if go-again? + (loop #t) + #t)))))) + + retval))))))) + + (define/override scroll + (case-lambda + [(x y refresh?) + (let ([savenoloop? noloop?]) + (set! noloop? #t) + + (when (and (x . > . -1) + (not fake-x-scroll?)) + (when (positive? scroll-width) + (set-scroll-pos 'horizontal (->long (min x scroll-width))))) + + (when (and (y . > . -1) + (not fake-y-scroll?)) + (when (positive? scroll-height) + (set-scroll-pos 'vertical (->long (min y scroll-height))))) + + (set! noloop? savenoloop?) + + (when refresh? (repaint)))] + [(scroll x y) (void)])) + + (define/override (set-scrollbars x y x2 y2 x3 y3 x4 y4 ?) (void)) + + (define/public (get-scroll x y) + ;; get fake scroll values if available + (set-box! x (if hscroll + (send hscroll get-value) + (get-scroll-pos 'horizontal))) + (set-box! y (if vscroll + (send vscroll get-value) + (get-scroll-pos 'vertical)))) + + (define/public (editor-canvas-on-scroll) + (unless noloop? + (repaint))) + + (define/public (on-scroll-on-change) + (void)) + + (define/public (get-editor) media) + + (define/public (set-editor m update?) + (unless (eq? media m) + (when media + (when (eq? admin (send media get-admin)) + (send media set-admin + (or (send admin get-nextadmin) + (send admin get-prevadmin)))) + + (let ([a (send admin get-nextadmin)]) + (when a + (send a set-prevadmin (send admin get-prevadmin)) + (send a adjust-std-flag))) + (let ([a (send admin get-prevadmin)]) + (when a + (send a set-nextadmin (send admin get-nextadmin)) + (send a adjust-std-flag))) + (send admin set-nextadmin #f) + (send admin set-prevadmin #f) + (when custom-cursor + (no-custom-cursor) + (set! custom-cursor #f))) + (set! media m) + (when media + (let ([oldadmin (send media get-admin)]) + (if (and oldadmin + (not (send oldadmin get-s-standard))) + (set! media #f) + (if oldadmin + (begin + (send admin set-nextadmin oldadmin) + (send admin set-prevadmin (send oldadmin get-prevadmin)) + (send oldadmin set-prevadmin admin) + (send oldadmin adjust-std-flag) + (let ([a (send admin get-prevadmin)]) + (when a + (send a set-nextadmin admin) + (send a adjust-std-flag))) + ;; get the right cursor: + (send admin update-cursor)) + (begin + (send admin set-nextadmin #f) + (send admin set-prevadmin #f) + (send media set-admin admin) + (send media own-caret focuson?)))))) + (send admin adjust-std-flag) + (reset-visual #t) + (when update? + (repaint)))) + + (define/public (allow-scroll-to-last to-last?) + (set! scroll-to-last? to-last?) + (reset-visual #f) + (repaint)) + + (define (scroll-with-bottom-base bottom?) + (set! scroll-bottom-based? bottom?) + (reset-visual #f) + (repaint))) + +;; ---------------------------------------- + +(defclass canvas-editor-admin% editor-admin% + (init-field canvas) + + (super-new) + + (inherit set-s-standard) + + (define reset? #f) + (properties [[any? nextadmin] #f] + [[any? prevadmin] #f]) + + (define update-cursor-timer #f) + + (define update-block? #f) + (define resized-block? #f) + + ;; FIXME: needed? + (define/private (~) + (when update-cursor-timer + (send update-cursor-timer cancel) + (set! update-cursor-timer #f)) + (set! canvas #f)) + + (define/public (do-get-canvas) canvas) + + (define canvasless-offscreen #f) + + (define/override (get-dc [fx #f] [fy #f]) + (cond + [(not canvas) + (unless canvasless-offscreen + (set! canvasless-offscreen (new bitmap-dc%))) + (when fx (set-box! fx 0)) + (when fy (set-box! fy 0)) + canvasless-offscreen] + [(let ([m (send canvas get-editor)]) + (and m (send m get-printing))) + => (lambda (p) + (when fx (set-box! fx 0)) + (when fy (set-box! fy 0)) + p)] + [else + (send canvas get-dc-and-offset fx fy)])) + + (define/override (get-view fx fy fh fw [full? #f]) + (cond + [(not canvas) + (when fx (set-box! fx 0)) + (when fy (set-box! fy 0)) + (when fh (set-box! fh 1)) + (when fw (set-box! fw 1))] + [(let ([m (send canvas get-editor)]) + (and m (send m get-printing))) + (when fx (set-box! fx 0)) + (when fy (set-box! fy 0)) + (when fh (set-box! fh 10000)) + (when fw (set-box! fw 10000))] + [else + (send canvas get-view fx fy fh fw full?)])) + + (define/override (get-max-view fx fy fw fh [full? #f]) + (if (or (and (not nextadmin) + (not prevadmin)) + (not canvas) + (and (let ([m (send canvas get-editor)]) + (and m (send m get-printing))))) + (get-view fx fy fw fh full?) + (let ([a (let loop ([a this]) + (let ([a2 (send a get-prevadmin)]) + (if a2 + (loop a2) + a)))]) + (let-boxes ([cx 0] [cy 0] [cw 0] [ch 0]) + (send a get-view cx cy cw ch) + (let loop ([a (send a get-nextadmin)] + [cx cx][cy cy][cr (+ cx cw)][cb (+ cy ch)]) + (if (not a) + (let ([cw (- cr cx)] + [ch (- cb cy)]) + (when fx (set-box! fx cx)) + (when fy (set-box! fy cy)) + (when fw (set-box! fw cw)) + (when fh (set-box! fh ch))) + (let-boxes ([x 0] [y 0] [w 0] [h 0]) + (send a get-view x y w h) + (loop (send a get-nextadmin) + (min x cx) + (min y cy) + (max (+ x w) cr) + (max (+ y h) cb))))))))) + + (def/override (scroll-to [real? localx] [real? localy] [real? w] [real? h] [any? [refresh? #t]] + [(symbol-in start none end) [bias 'none]]) + (let ([v (do-scroll-to localx localy w h refresh? bias #t #t #f)]) + (and v (car v)))) + + (define/private (do-scroll-to localx localy w h refresh? bias prev? next? only-focus?) + (and canvas + (or (and (not (send canvas is-focus-on?)) + (or + (and prev? + prevadmin + (send prevadmin do-scroll-to localx localy w h refresh? bias #t #f #t)) + (and next? + nextadmin + (send nextadmin do-scroll-to localx localy w h refresh? bias #f #t #t)))) + (and (or (not only-focus?) + (send canvas is-focus-on?)) + (list (send canvas scroll-to localx localy w h refresh? bias)))))) + + (def/override (grab-caret [(symbol-in immediate display global) dist]) + (when canvas + (when (eq? dist 'global) + (send canvas set-focus)))) + + (define/public all-in-chain + (case-lambda + [(proc) (all-in-chain proc #t #t)] + [(proc backward? forward?) + (proc this) + (when (and forward? nextadmin) + (send nextadmin all-in-chain proc #f #t)) + (when (and backward? prevadmin) + (send prevadmin all-in-chain proc #t #f))])) + + (def/override (needs-update [real? localx] [real? localy] + [nonnegative-real? w] [nonnegative-real? h]) + (all-in-chain (lambda (a) (send a do-needs-update localx localy w h)))) + + (define/public (do-needs-update localx localy w h) + (when canvas + (let ([is-shown? (send canvas is-shown-to-root?)]) + + (cond + [reset? + (when is-shown? (send canvas repaint)) + (set! reset? #f)] + [is-shown? + (if (not (send canvas get-canvas-background)) + (send canvas repaint) + (send canvas redraw localx localy w h))])))) + + (define/override (resized update?) + (all-in-chain (lambda (a) (send a do-resized update?)))) + + (define/public (do-resized update?) + (when canvas + (when (send canvas reset-visual #f) + (set! reset? #t)) + + (when update? + (send canvas repaint) + (set! reset? #f)))) + + (define/override (update-cursor) + (all-in-chain (lambda (a) (send a do-update-cursor)))) + + (define/public (do-update-cursor) + (when (not update-cursor-timer) + (set! update-cursor-timer (new update-cursor-timer% [admin this])))) + + (def/override (popup-menu [popup-menu% m] [real? x] [real? y]) + (and canvas + (let ([e (send canvas get-editor)]) + (and e + (let ([m (send canvas popup-for-editor e m)]) + (let-boxes ([dx 0.0] + [dy 0.0]) + (send canvas get-dc-and-offset dx dy) + (send canvas popup-menu m (->long (- x dx)) (->long (- y dy))))))))) + + (define/public (adjust-std-flag) + ;; 1 indicates that this is the sole, main admin. + ;; this info is used for quick (xor) caret refreshing + ;; by an editor buffer + (set-s-standard (if (or nextadmin + prevadmin + (and canvas (send canvas get-focusforcedon?))) + -1 + 1))) + + (def/override (modified [bool? modified?]) (void))) + + +;; For editor-admin%: +#;( + (define/override (get-max-view fx fy fw fh full?) + (get-view fx fy fh fw full?)) + + (define/override (delay-refresh?) #f) +) diff --git a/collects/mred/private/wxme/editor-snip.ss b/collects/mred/private/wxme/editor-snip.ss new file mode 100644 index 00000000..791925d1 --- /dev/null +++ b/collects/mred/private/wxme/editor-snip.ss @@ -0,0 +1,716 @@ +#lang scheme/base +(require scheme/class + "../syntax.ss" + "private.ss" + "const.ss" + "snip.ss" + "snip-flags.ss" + "editor.ss" + "editor-admin.ss" + "snip-admin.ss" + "text.ss" + "pasteboard.ss" + "wx.ss" + (except-in "cycle.ss" + text% + pasteboard% + editor-snip% + editor-snip-editor-admin% + snip-admin%)) + +(provide editor-snip% + editor-snip-editor-admin<%>) + +;; FIXME: use "type"s +(define-syntax-rule (private-inits [[type id] val] ...) + (begin + (define-init id val) + ...)) +(define-syntax-rule (define-init id v) + (begin + (init [(init-tmp id) v]) + (define id init-tmp))) + +;; see also "private.ss" +(define-local-member-name + with-dc + do-get-left-margin do-get-right-margin do-get-bottom-margin do-get-top-margin + do-get-extent) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass editor-snip% snip% + (private-inits + [[(make-or-false editor<%>) editor] #f] + [[bool? with-border?] #t] + [[exact-nonnegative-integer? left-margin] 5] + [[exact-nonnegative-integer? top-margin] 5] + [[exact-nonnegative-integer? right-margin] 5] + [[exact-nonnegative-integer? bottom-margin] 5] + [[exact-nonnegative-integer? left-inset] 1] + [[exact-nonnegative-integer? top-inset] 1] + [[exact-nonnegative-integer? right-inset] 1] + [[exact-nonnegative-integer? bottom-inset] 1] + [[(make-alts (symbol-in none) nonnegative-real?) min-width] 'none] + [[(make-alts (symbol-in none) nonnegative-real?) max-width] 'none] + [[(make-alts (symbol-in none) nonnegative-real?) min-height] 'none] + [[(make-alts (symbol-in none) nonnegative-real?) max-height] 'none]) + + (unless (symbol? min-width) (set! min-width (exact->inexact min-width))) + (unless (symbol? max-width) (set! max-width (exact->inexact max-width))) + (unless (symbol? min-height) (set! min-height (exact->inexact min-height))) + (unless (symbol? max-height) (set! max-height (exact->inexact max-height))) + + (define align-top-line? #f) + (define tight-fit? #f) + (define use-style-bg? #f) + + (super-new) + + (inherit set-snipclass + do-copy-to) + (inherit-field s-admin + s-flags + s-style) + + (set-snipclass the-editor-snip-class) + + (when (and editor (send editor get-admin)) + (set! editor #f)) + (unless editor + (set! editor (new extended-text%))) + + (define my-admin (new editor-snip-editor-admin% [owner this])) + + (set! s-flags (add-flag s-flags HANDLES-EVENTS)) + (when (no-permanent-filename? editor) + (set! s-flags (add-flag s-flags USES-BUFFER-PATH))) + + (send editor own-caret #f) + + ;; ---------------------------------------- + + (define/private (no-permanent-filename? editor) + (let ([temp (box #f)]) + (let ([fn (send editor get-filename temp)]) + (or (not fn) (unbox temp))))) + + (def/override (set-admin [(make-or-false snip-admin%) a]) + + (when (not (eq? a s-admin)) + (super set-admin a) + (when editor + (if a + (begin + (when (send editor get-admin) + ;; traitor! - get rid of it + (set! editor #f)) + (send editor set-admin my-admin)) + (send editor set-admin #f)))) + + (when (and s-admin + (has-flag? s-flags USES-BUFFER-PATH)) + ;; propogate a filename change: + (if (and editor + (no-permanent-filename? editor)) + (let ([b (send s-admin get-editor)]) + (when b + (let ([fn (send b get-filename)]) + (when fn + (send editor set-filename fn #t))))) + (set! s-flags (remove-flag s-flags USES-BUFFER-PATH)))) ;; turn off the flag; not needed + + (void)) + + (def/public (set-editor [editor<%> b]) + (unless (eq? editor b) + (when (and editor s-admin) + (send editor set-admin #f)) + (set! editor b) + (when b + (cond + [(send b get-admin) + (set! editor #f)] + [s-admin + (send editor set-admin my-admin)])) + (when s-admin + (send s-admin resized this #t)))) + + (def/public (get-editor) + editor) + + (def/override (adjust-cursor [dc<%> dc] [real? x] [real? y] [real? ex] [real? ey] [mouse-event% event]) + (if (not editor) + #f + (send my-admin + with-dc + dc x y + (lambda () + (send editor adjust-cursor event))))) + + (def/override (on-event [dc<%> dc] [real? x] [real? y] [real? ex] [real? ey] [mouse-event% event]) + (when editor + (send my-admin + with-dc + dc x y + (lambda () + (send editor on-event event))))) + + (def/override (on-char [dc<%> dc] [real? x] [real? y] [real? ex] [real? ey] [key-event% event]) + (when editor + (send my-admin + with-dc + dc x y + (lambda () + (send editor on-char event))))) + + (def/override (own-caret [bool? own?]) + (when editor + (send editor own-caret own?))) + + (def/override (blink-caret [dc<%> dc] [real? x] [real? y]) + (when editor + (send my-admin + with-dc + dc x y + (lambda () + (send editor blink-caret))))) + + (def/override (do-edit-operation [symbol? op] [any? [recur? #t]] [exact-integer? [timestamp 0]]) + (when editor + (send editor do-edit-operation op recur? timestamp))) + + (def/override (can-do-edit-operation? [symbol? op] [any? [recur? #t]]) + (and editor + (send editor can-do-edit-operation? op recur?))) + + (def/override (match [snip% s]) + #f) + + (def/override (size-cache-invalid) + (when editor + (send editor size-cache-invalid))) + + (def/override (get-text [exact-nonnegative-integer? offset] [exact-integer? num] + [any? [flattened? #f]]) + (cond + [(or (offset . >= . 1) + (zero? num)) + ""] + [(not flattened?) + "."] + [editor + (send editor get-flattened-text)] + [else ""])) + + (define/public (do-get-extent dc x y w h -descent -space lspace rspace) + (send my-admin + with-dc + dc x y + (lambda () + (let ([h2 (or h (box 0.0))]) + (if editor + (send editor get-extent w h2) + (begin + (when w (set-box! w 0.0)) + (set-box! h2 0.0))) + (let ([orig-h (if align-top-line? + (unbox h2) + 0.0)]) + + (when w + (when (editor . is-a? . text%) + (set-box! + w + (- (unbox w) + (if tight-fit? + CURSOR-WIDTH + 1)))) ;; it still looks better to subtract 1 + (when ((unbox w) . < . (if (symbol? min-width) -inf.0 min-width)) + (set-box! w min-width)) + (when ((unbox w) . > . (if (symbol? max-width) +inf.0 max-width)) + (set-box! w max-width)) + (set-box! w (+ (unbox w) (+ right-margin left-margin)))) + + (when h + (when (editor . is-a? . text%) + (when tight-fit? + (set-box! h + (max 0.0 + (- (unbox h) + (send editor get-line-spacing)))))) + (when ((unbox h) . < . (if (symbol? min-height) -inf.0 min-height)) + (set-box! h min-height)) + (when ((unbox h) . > . (if (symbol? max-height) +inf.0 max-height)) + (set-box! h max-height)) + (set-box! h (+ (unbox h) (+ top-margin bottom-margin)))) + + (let* ([descent (+ (if editor + (send editor get-descent) + 0.0) + bottom-margin)] + [descent + (if (editor . is-a? . text%) + (let ([descent (if align-top-line? + (- orig-h + (+ (send editor get-top-line-base) + bottom-margin)) + descent)]) + (if tight-fit? + (max (- descent (send editor get-line-spacing)) 0.0) + descent)) + descent)] + [space (+ (if editor + (send editor get-space) + 0.0) + top-margin)]) + (let-values ([(space descent) + (if (and (not (symbol? max-height)) + ((+ descent space) . >= . (+ max-height top-margin bottom-margin))) + ;; just give up on spaces in this case: + (values top-margin bottom-margin) + (values space descent))]) + (when -descent (set-box! -descent descent)) + (when -space (set-box! -space space)))) + + (when lspace (set-box! lspace left-margin)) + (when rspace (set-box! rspace right-margin))))))) + + (def/override (get-extent [dc<%> dc] [real? x] [real? y] + [maybe-box? [w #f]] [maybe-box? [h #f]] + [maybe-box? [-descent #f]] [maybe-box? [-space #f]] + [maybe-box? [lspace #f]] [maybe-box? [rspace #f]]) + (do-get-extent dc x y w h -descent -space lspace rspace)) + + (def/override (draw [dc<%> dc] [real? x] [real? y] + [real? left] [real? top] [real? right] [real? bottom] + [real? dx] [real? dy] [symbol? caret]) + (send my-admin + with-dc + dc x y + (lambda () + (let-boxes ([w 0.0] + [h 0.0]) + (when editor + (send editor get-extent w h) + (when (editor . is-a? . text%) + (set-box! w (max 0.0 + (- (unbox w) + (if tight-fit? + CURSOR-WIDTH + 1)))) ;; it still looks better to subtract 1 + (when tight-fit? + (set-box! h (max 0.0 + (- (unbox h) + (send editor get-line-spacing))))))) + (let* ([w (min (max w (if (symbol? min-width) -inf.0 min-width)) + (if (symbol? max-width) +inf.0 max-width))] + [h (min (max h (if (symbol? min-height) -inf.0 min-height)) + (if (symbol? max-height) +inf.0 max-height))] + [orig-x x] + [orig-y y] + [x (+ x left-margin)] + [y (+ y top-margin)] + [r (+ x w)] + [b (+ y h)] + [l (max x left)] + [t (max y top)] + [r (min r right)] + [b (min b bottom)]) + + (let ([bg-color + (cond + [(not use-style-bg?) + (make-object color% 255 255 255)] + [(send s-style get-transparent-text-backing) + #f] + [else + (let ([bg-color (send s-style get-background)]) + (let ([l (+ orig-x left-inset)] + [t (+ orig-y top-inset)] + [r (+ l w left-margin right-margin + (- (+ left-inset right-inset)) + -1)] + [b (+ t h top-margin bottom-margin + (- (+ top-inset bottom-inset)) + -1)]) + (let ([trans-pen (send the-pen-list + find-or-create-pen + bg-color 0 'transparent)] + [fill (send the-brush-list + find-or-create-brush + bg-color 'solid)] + [savep (send dc get-pen)] + [saveb (send dc get-brush)]) + (send dc set-pen trans-pen) + (send dc set-brush fill) + + (send dc draw-rectangle l t (- r l) (- b t)) + + (send dc set-brush saveb) + (send dc set-pen savep))) + bg-color)])]) + + (when editor + (send editor refresh + (- l x) (- t y) (max 0.0 (- r l)) (max 0.0 (- b t)) + caret bg-color)) + + (when with-border? + (let* ([l (+ orig-x left-inset)] + [t (+ orig-y top-inset)] + [r (+ l w left-margin right-margin + (- (+ left-inset right-inset)) + -1)] + [b (+ t h top-margin bottom-margin + (- (+ top-inset bottom-inset)) + -1)]) + (let ([ml (max (min l right) left)] + [mr (max (min r right) left)] + [mt (max (min t bottom) top)] + [mb (max (min b bottom) top)]) + (when (and (l . >= . left) + (l . < . right) + (mt . < . mb)) + (send dc draw-line l mt l mb)) + (when (and (r . >= . left) + (r . < . right) + (mt . < . mb)) + (send dc draw-line r mt r mb)) + (when (and (t . >= . top) + (t . < . bottom) + (ml . < . mr)) + (send dc draw-line ml t mr t)) + (when (and (b . >= . top) + (b . < . bottom) + (ml . < . mr)) + (send dc draw-line ml b mr b))))))))))) + + (def/override (copy) + (let* ([mb (and editor + (send editor copy-self))] + [ms (make-object extended-editor-snip% + mb + with-border? + left-margin top-margin + right-margin bottom-margin + left-inset top-inset + right-inset bottom-inset + min-width max-width + min-height max-height)]) + (do-copy-to ms) + + (send ms do-set-graphics tight-fit? align-top-line? use-style-bg?) + (when (not editor) + (send ms set-editor #f)) + ms)) + + (define/public (do-set-graphics tf? atl? usb?) + (set! tight-fit? tf?) + (set! align-top-line? atl?) + (set! use-style-bg? usb?)) + + (def/override (write [editor-stream-out% f]) + (send f put (if editor + (if (editor . is-a? . pasteboard%) 2 1) + 0)) + (send f put (if with-border? 1 0)) + (send f put left-margin) + (send f put top-margin) + (send f put right-margin) + (send f put bottom-margin) + (send f put left-inset) + (send f put top-inset) + (send f put right-inset) + (send f put bottom-inset) + (send f put (if (symbol? min-width) -1.0 min-width)) + (send f put (if (symbol? max-width) -1.0 max-width)) + (send f put (if (symbol? min-height) -1.0 min-height)) + (send f put (if (symbol? max-height) -1.0 max-height)) + (send f put (if tight-fit? 1 0)) + (send f put (if align-top-line? 1 0)) + (send f put (if use-style-bg? 1 0)) + (when editor + (send editor write-to-file f))) + + (define/private (resize-me) + (when s-admin (send s-admin resized this #t))) + + (def/public (set-max-width [(make-alts (symbol-in none) nonnegative-real?) w]) + (set! max-width w) + (resize-me)) + + (def/public (set-min-width [(make-alts (symbol-in none) nonnegative-real?) w]) + (set! min-width w) + (resize-me)) + + (def/public (set-max-height [(make-alts (symbol-in none) nonnegative-real?) h]) + (set! max-height h) + (resize-me)) + + (def/public (set-min-height [(make-alts (symbol-in none) nonnegative-real?) h]) + (set! min-height h) + (resize-me)) + + (def/public (get-max-width) max-width) + (def/public (get-min-width) min-width) + (def/public (get-max-height) max-height) + (def/public (get-min-height) min-height) + + (def/public (get-tight-text-fit) + tight-fit?) + (def/public (set-tight-text-fit [bool? t]) + (set! tight-fit? t) + (resize-me)) + + (def/public (get-align-top-line) + align-top-line?) + (def/public (set-align-top-line [bool? t]) + (set! align-top-line? t) + (resize-me)) + + (def/public (style-background-used?) + use-style-bg?) + (def/public (use-style-background [bool? u]) + (unless (eq? use-style-bg? u) + (set! use-style-bg? u) + (request-refresh))) + + (def/override (resize [real? w] [real? h]) + (let ([w (max 0.0 (- w (+ left-margin right-margin)))] + [h (max 0.0 (- h (+ top-margin bottom-margin)))]) + (set! min-width w) + (set! max-width w) + (set! min-height h) + (set! max-height h) + + (when editor + (send editor set-max-width w) + (send editor set-min-width w)) + + (resize-me) + #t)) + + (define/private (request-refresh) + (when s-admin + (let ([dc (send s-admin get-dc)]) + (when dc + (let-boxes ([w 0.0] + [h 0.0]) + (get-extent dc 0 0 w h) + (send s-admin needs-update + this left-inset top-inset + (+ w (- right-margin right-inset)) + (+ h (- bottom-margin bottom-inset)))))))) + + (def/public (show-border [bool? show]) + (unless (eq? with-border? show) + (set! with-border? show) + (request-refresh))) + (def/public (border-visible?) + with-border?) + + (def/public (set-margin [exact-nonnegative-integer? lm] + [exact-nonnegative-integer? tm] + [exact-nonnegative-integer? rm] + [exact-nonnegative-integer? bm]) + (set! left-margin lm) + (set! top-margin tm) + (set! right-margin rm) + (set! bottom-margin bm) + (resize-me)) + + (def/public (get-margin [box? lm] [box? tm] [box? rm] [box? bm]) + (set-box! lm left-margin) + (set-box! tm top-margin) + (set-box! rm right-margin) + (set-box! bm bottom-margin)) + + (def/public (set-inset [exact-nonnegative-integer? lm] + [exact-nonnegative-integer? tm] + [exact-nonnegative-integer? rm] + [exact-nonnegative-integer? bm]) + (set! left-margin lm) + (set! top-margin tm) + (set! right-margin rm) + (set! bottom-margin bm) + (request-refresh)) + + (def/public (get-inset [box? lm] [box? tm] [box? rm] [box? bm]) + (set-box! lm left-inset) + (set-box! tm top-inset) + (set-box! rm right-inset) + (set-box! bm bottom-inset)) + + (def/override (get-num-scroll-steps) + (if editor + (send editor num-scroll-lines) + 1)) + + (def/override (find-scroll-step [real? y]) + (if editor + (send editor find-scroll-line (- y top-margin)) + 0)) + + (def/override (get-scroll-step-offset [exact-integer? n]) + (if editor + (+ (send editor scroll-line-location n) top-margin) + 0)) + + (def/override (set-unmodified) + (when editor + (send editor set-modified #f))) + + (def/public (do-get-left-margin) left-margin) + (def/public (do-get-right-margin) right-margin) + (def/public (do-get-bottom-margin) bottom-margin) + (def/public (do-get-top-margin) top-margin)) + +(set-editor-snip%! editor-snip%) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-struct state (dc x y)) + +(defclass editor-snip-editor-admin% editor-admin% + (init owner) + (define snip owner) + (define state #f) + + (super-new) + + (define/public (get-snip) snip) + + (define/public (with-dc dc x y thunk) + (let* ([other (make-state dc + (+ x (send snip do-get-left-margin)) + (+ y (send snip do-get-top-margin)))] + [swap (lambda () + (let ([s state]) + (set! state other) + (set! other s)))]) + (dynamic-wind swap thunk swap))) + + (def/override (get-dc [maybe-box? [x #f]] [maybe-box? [y #f]]) + (let-values ([(xv yv) + (if state + (values (- (state-x state)) + (- (state-y state))) + (values 0 0))]) + (when x (set-box! x xv)) + (when y (set-box! y yv)) + (if state + (state-dc state) + (let ([sadmin (send snip get-admin)]) + (if sadmin + (send sadmin get-dc) + #f))))) + + (def/override (get-view [maybe-box? x] [maybe-box? y] + [maybe-box? w] [maybe-box? h] + [any? [full? #f]]) + (let ([sadmin (send snip get-admin)]) + (cond + [(not sadmin) + (when x (set-box! x 0.0)) + (when y (set-box! y 0.0)) + (when w (set-box! w 0.0)) + (when h (set-box! h 0.0))] + [full? + (send sadmin get-view x y w h #f)] + [else + (let-boxes ([sx 0.0] + [sy 0.0] + [sw 0.0] + [sh 0.0]) + (send sadmin get-view sx sy sw sh snip) + (when x + (set-box! x (max 0.0 (- sx (send snip do-get-left-margin))))) + (when y + (set-box! y (max 0.0 (- sy (send snip do-get-top-margin))))) + (when (or w h) + (if (or (positive? sw) (positive? sh)) + ;; w and h might be too big due to margins - but + ;; they might be small enough already because + ;; part of the snip itself is not viewed + (let-boxes ([rw 0.0] + [rh 0.0]) + ;; we want the internal, non-overridden method: + (send snip do-get-extent (and state (state-dc state)) 0 0 rw rh #f #f #f #f) + + ;; remember: sx and sy are in snip coordinates + + (when w + (let* ([left-margin (max 0.0 (- (send snip do-get-left-margin) sx))] + [sw (- sw left-margin)] + [rw (- rw (send snip do-get-left-margin))] + [right-margin (max 0.0 (- (send snip do-get-right-margin) (- rw sw)))] + [sw (max 0.0 (- sw right-margin))]) + (set-box! w sw))) + + (when h + (let* ([top-margin (max 0.0 (- (send snip do-get-top-margin) sy))] + [sh (- sh top-margin)] + [rh (- rh (send snip do-get-top-margin))] + [bottom-margin (max 0.0 (- (send snip do-get-bottom-margin) (- rh sh)))] + [sh (max 0.0 (- sh bottom-margin))]) + (set-box! h sh)))) + + (begin + (when w (set-box! w 0.0)) + (when h (set-box! h 0.0))))))]))) + + (def/override (scroll-to [real? localx] [real? localy] [real? w] [real? h] [any? [refresh? #t]] + [(symbol-in start none end) [bias 'none]]) + (let ([sadmin (send snip get-admin)]) + (and sadmin + (send sadmin scroll-to snip (+ localx (send snip do-get-left-margin)) + (+ localy (send snip do-get-top-margin)) + w h refresh? bias)))) + + (def/override (grab-caret [(symbol-in immediate display global) dist]) + (let ([sadmin (send snip get-admin)]) + (when sadmin + (send sadmin set-caret-owner snip dist)))) + + (def/override (resized [any? redraw-now]) + (let ([sadmin (send snip get-admin)]) + (when sadmin + (send sadmin resized snip redraw-now)))) + + (def/override (needs-update [real? localx] [real? localy] + [nonnegative-real? w] [nonnegative-real? h]) + (let ([sadmin (send snip get-admin)]) + (when sadmin + (send sadmin needs-update snip + (+ localx (send snip do-get-left-margin)) + (+ localy (send snip do-get-top-margin)) + w h)))) + + (def/override (update-cursor) + (let ([sadmin (send snip get-admin)]) + (when sadmin + (send sadmin update-cursor)))) + + (def/override (popup-menu [popup-menu% m] [real? x] [real? y]) + (let ([sadmin (send snip get-admin)]) + (and sadmin + (send sadmin popup-menu m snip + (+ x (send snip do-get-left-margin)) + (+ y (send snip do-get-top-margin)))))) + + (def/override (delay-refresh?) + (let ([sadmin (send snip get-admin)]) + (or (not sadmin) + (and (sadmin . is-a? . standard-snip-admin%) + (send (send sadmin get-editor) refresh-delayed?))))) + + (def/override (modified [any? mod?]) + (let ([sadmin (send snip get-admin)]) + (when sadmin + (send sadmin modified snip mod?))))) + +(set-editor-snip-editor-admin%! editor-snip-editor-admin%) + +(define editor-snip-editor-admin<%> (class->interface editor-snip-editor-admin%)) + diff --git a/collects/mred/private/wxme/editor.ss b/collects/mred/private/wxme/editor.ss new file mode 100644 index 00000000..6e191f86 --- /dev/null +++ b/collects/mred/private/wxme/editor.ss @@ -0,0 +1,1819 @@ +#lang scheme/base +(require scheme/class + (for-syntax scheme/base) + scheme/file + "../syntax.ss" + "private.ss" + "style.ss" + "snip.ss" + "snip-flags.ss" + "editor-admin.ss" + "stream.ss" + "undo.ss" + "keymap.ss" + (only-in "cycle.ss" + text% + pasteboard% + editor-snip% + editor-snip-editor-admin% + editor-get-file + editor-put-file) + "wx.ss") + +(provide editor% + editor<%> + add-editor-keymap-functions + ALLOW-X-STYLE-SELECTION? + copy-style-list + set-common-copy-region-data! + cons-common-copy-buffer! + cons-common-copy-buffer2! + editor-set-x-selection-mode + editor-x-selection-allowed + editor-x-selection-mode? + editor-x-selection-owner + detect-wxme-file + read-editor-version + read-editor-global-header + read-editor-global-footer + write-editor-version + write-editor-global-header + write-editor-global-footer + write-snips-to-file + get-default-print-size) + +;; ---------------------------------------- + +(define RIDICULOUS-SIZE 2000) +(define ALLOW-X-STYLE-SELECTION? (eq? 'unix (system-type))) + +(defclass offscreen% object% + (define bitmap #f) + (define dc (make-object bitmap-dc%)) + (define bm-width 0) + (define bm-height 0) + (define in-use? #f) + (define last-used #f) + + (define/public (is-in-use?) in-use?) + (define/public (set-in-use v) (set! in-use? (and v #t))) + (define/public (get-bitmap) bitmap) + (define/public (get-dc) dc) + (define/public (get-last-used) last-used) + (define/public (set-last-used v) (set! last-used v)) + + (define/public (ready-offscreen width height) + (if (or (width . > . RIDICULOUS-SIZE) + (height . > . RIDICULOUS-SIZE) + (eq? (system-type) 'macosx)) + #f + (if (and (not in-use?) + (or (height . > . bm-height) + (width . > . bm-width))) + (let ([oldbm bitmap]) + (set! bm-height (max (add1 (->long height)) bm-height)) + (set! bm-width (max (add1 (->long width)) bm-width)) + (set! bitmap (make-object bitmap% bm-width bm-height)) + (send dc set-bitmap #f) + (when (send bitmap ok?) + (send dc set-bitmap bitmap)) + #t) + #f))) + + (super-new)) + +(define the-offscreen (new offscreen%)) + +;; ---------------------------------------- + +;; 8.5" x 11" paper, 0.5" margin; usually not used +(define PAGE-WIDTH 612) +(define PAGE-HEIGHT 792) + +(define (get-printer-orientation) + (send (current-ps-setup) get-orientation)) + +(define (get-default-print-size w h) + (set-box! w PAGE-WIDTH) + (set-box! h PAGE-HEIGHT) + (when (eq? (get-printer-orientation) 'landscape) + (let ([tmp h]) + (set! h w) + (set! w tmp)))) + +;; ---------------------------------------- + +(define emacs-style-undo? (and (get-preference 'MrEd:emacs-undo) #t)) +(define (max-undo-value? v) (or (exact-nonnegative-integer? v) + (eq? v 'forever))) + +(define global-lock (make-semaphore 1)) + +(defclass editor% object% + + (field [s-offscreen the-offscreen] + [s-admin #f] + [s-keymap (new keymap%)] + [s-own-caret? #f] + [s-temp-filename? #f] + [s-user-locked? #f] + [s-modified? #f] + [s-noundomode 0]) + (def/public (is-modified?) s-modified?) + + (define undomode? #f) + (define redomode? #f) + (define interceptmode? #f) + (define loadoverwritesstyles? #f) + + (field [s-custom-cursor-overrides? #f] + [s-need-on-display-size? #f]) + (define paste-text-only? #f) + + (define num-parts-modified 0) + + (field [s-caret-snip #f] + [s-style-list (new style-list%)]) + (define/public (get-focus-snip) s-caret-snip) + (define/public (get-s-style-list) s-style-list) + + (send s-style-list new-named-style "Standard" (send s-style-list basic-style)) + (define notify-id + (send s-style-list notify-on-change (lambda (which) (style-has-changed which)))) + + (field [s-filename #f]) ; last loaded file + + (define max-undos 0) + + (define changes #()) + (define changes-start 0) + (define changes-end 0) + (define changes-size 0) + + (define redochanges #()) + (define redochanges-start 0) + (define redochanges-end 0) + (define redochanges-size 0) + + (define savedchanges #f) ;; for emacs-style undo + (define intercepted null) + + (field [s-custom-cursor #f] + [s-inactive-caret-threshold 'show-inactive-caret]) + + (define printing #f) + (define/public (get-printing) printing) + + (define num-extra-headers 0) + (define seq-lock #f) + + (super-new) + + (define/public (~) + (send s-style-list forget-notification notify-id) + (clear-undos)) + + (define/public (is-printing?) (and printing #t)) + + ;; ---------------------------------------- + + (def/public (blink-caret) (void)) + + (def/public (size-cache-invalid) (void)) + (def/public (locked-for-read?) #f) + (def/public (locked-for-write?) #f) + + (def/public (resized) (void)) + (def/public (recounted) (void)) + (define/public (invalidate-bitmap-cache) (void)) + (def/public (needs-update) (void)) + (def/public (release-snip) (void)) + + (def/public (scroll-line-location) (void)) + (def/public (num-scroll-lines) (void)) + (def/public (find-scroll-line) (void)) + + ;; ---------------------------------------- + + (define/public (on-event event) (void)) + (define/public (on-char event) (void)) + + (def/public (on-local-event [mouse-event% event]) + (unless (and s-keymap + (or (send s-keymap handle-mouse-event this event) + (begin + (when (not (send event moving?)) + (send s-keymap break-sequence)) + #f))) + (on-default-event event))) + + (def/public (on-local-char [key-event% event]) + (unless (and s-keymap + (or (send s-keymap handle-key-event this event) + (begin + (send s-keymap break-sequence) + #f))) + (on-default-char event))) + + (define/public (on-default-event event) (void)) + (define/public (on-default-char event) (void)) + + (def/public (on-focus [any? on?]) (void)) + + ;; ---------------------------------------- + + (def/public (set-admin [(make-or-false editor-admin%) administrator]) + (setting-admin administrator) + + (set! s-admin administrator) + (when (not s-admin) + (set! s-own-caret? #f)) + (when s-admin + (init-new-admin))) + + (def/public (setting-admin [(make-or-false editor-admin%) a]) (void)) + + (def/public (init-new-admin) (void)) + + (def/public (get-admin) s-admin) + + ;; ---------------------------------------- + + (def/public (own-caret [any? ownit?]) (void)) + + (def/public (do-own-caret [any? ownit?]) + (let ([ownint? (and ownit? #t)]) + (let ([refresh? (and (not s-caret-snip) + (not (eq? s-own-caret? ownit?)))]) + (set! s-own-caret? ownit?) + (when s-caret-snip + (send s-caret-snip own-caret ownit?)) + (when (and s-keymap (not ownint?) refresh?) + (send s-keymap break-sequence)) + + (when ALLOW-X-STYLE-SELECTION? + (cond + [(and ownit? (not s-caret-snip)) + (set! editor-x-selection-allowed this)] + [(eq? editor-x-selection-allowed this) + (set! editor-x-selection-allowed #f)])) + + (when s-admin + (send s-admin update-cursor)) + + refresh?))) + + (def/public (get-dc) + ;; this can be called by snips to get a DC appropriate for + ;; sizing text, etc., outside of draws. it isn't the destination + ;; for draws, though + (if s-admin + (send s-admin get-dc #f #f) + #f)) + + (def/public (get-view-size [(make-or-false box?) w][(make-or-false box?) h]) + (if s-admin + (send s-admin get-view #f #f w h) + (begin + (when w (set-box! w 0.0)) + (when h (set-box! h 0.0))))) + + (define/public (get-snip-location snip x y) + (when x (set-box! x 0.0)) + (when y (set-box! y 0.0)) + #t) + + (def/public (do-set-caret-owner [(make-or-false snip%) snip] [symbol? dist]) + (let ([same? (eq? snip s-caret-snip)]) + (if (and same? + (or (not s-admin) (eq? dist 'immediate))) + #f + (begin + (when same? + (send s-admin grab-caret dist)) + + (let ([vis-caret? s-own-caret?]) + (cond + [(or (not snip) + (not (has-flag? (snip->flags snip) HANDLES-EVENTS))) + + (let ([old-caret s-caret-snip] + [refresh? #f]) + (set! s-caret-snip #f) + (when old-caret + (send old-caret own-caret #f) + (when vis-caret? + (set! refresh? #t))) + (when ALLOW-X-STYLE-SELECTION? + (set! editor-x-selection-allowed this)) + (when s-admin + (send s-admin update-cursor)) + refresh?)] + [(not (get-snip-location snip #f #f)) #f] + [else + (let ([had-caret? (and s-own-caret? + (not s-caret-snip))] + [old-caret s-caret-snip] + [refresh? #f]) + + (set! s-caret-snip snip) + + (begin-edit-sequence) + (cond + [old-caret (send old-caret own-caret #f)] + [vis-caret? (set! refresh? #t)]) + (send snip own-caret s-own-caret?) + (end-edit-sequence) + + (when (and s-admin + (not (eq? dist 'immediate))) + (send s-admin grab-caret dist)) + + (when s-admin + (send s-admin update-cursor)) + + refresh?)])))))) + + (define/private (convert-coords admin x y to-local?) + (let-values ([(lx ly) + (if admin + (if (admin . is-a? . editor-snip-editor-admin%) + (let* ([snip (send admin get-snip)] + [sa (send snip get-admin)]) + (if sa + (let ([mbuf (send sa get-editor)]) + (if mbuf + (let-boxes ([bx 0.0][by 0.0] + [lx 0.0][ly 0.0] + [l 0.0][t 0.0][r 0.0][b 0.0]) + (begin + (send mbuf local-to-global bx by) + (send mbuf get-snip-location snip lx ly #f) + (send snip get-margin l t r b)) + (values (+ lx bx l) + (+ ly by t))) + (values 0.0 0.0))) + (values 0.0 0.0))) + (let-boxes ([lx 0.0][ly 0.0]) + (send admin get-dc lx ly) + (values (- lx) (- ly)))) + (values 0.0 0.0))]) + (when x (set-box! x (+ (unbox x) (if to-local? (- lx) lx)))) + (when y (set-box! y (+ (unbox y) (if to-local? (- ly) ly)))))) + + (def/public (editor-location-to-dc-location [real? x] [real? y]) + (let-boxes ([x x] [y y]) + (local-to-global x y) + (values x y))) + + (def/public (dc-location-to-editor-location [real? x] [real? y]) + (let-boxes ([x x] [y y]) + (global-to-local x y) + (values x y))) + + (def/public (global-to-local [maybe-box? x] [maybe-box? y]) + (convert-coords s-admin x y #t)) + + (def/public (local-to-global [maybe-box? x] [maybe-box? y]) + (convert-coords s-admin x y #f)) + + (def/public (set-cursor [(make-or-false cursor%) c] [any? [override? #t]]) + (set! s-custom-cursor c) + (set! s-custom-cursor-overrides? override?) + (when s-admin + (send s-admin update-cursor))) + + (def/public (adjust-cursor [mouse-event% event]) (void)) + + ;; ---------------------------------------- + + (def/public (set-keymap [keymap% k]) + (set! s-keymap k)) + (def/public (get-keymap) s-keymap) + (def/public (get-style-list) s-style-list) + + (def/public (set-style-list [style-list% new-list]) + (send s-style-list forget-notification notify-id) + (set! notify-id + (send new-list notify-on-change (lambda (which) (style-has-changed which)))) + (set! s-style-list new-list) + ;; create "Standard" if it's not there: + (send s-style-list new-named-style "Standard" (send s-style-list basic-style))) + + (define/public (style-has-changed which) (void)) + + (def/public (default-style-name) "Standard") + + (def/public (get-default-style) + (send s-style-list find-named-style (default-style-name))) + + ;; ---------------------------------------- + + (define/public (set-max-width w) (void)) + (define/public (set-min-width v) (void)) + (define/public (get-max-width) 0.0) + (define/public (get-min-width) 0.0) + (define/public (set-min-height w) (void)) + (define/public (set-max-height w) (void)) + (define/public (get-min-height) 0.0) + (define/public (get-max-height) 0.0) + + (define/public (find-first-snip) #f) + + (define/public (get-extent) (void)) + (define/public (get-descent) (void)) + (define/public (get-space) (void)) + + (define/public (get-flattened-text) (void)) + + ;; ---------------------------------------- + + (define/public (clear) (void)) + (define/public (cut ? time) (void)) + (define/public (copy ? time) (void)) + (define/public (paste time) (void)) + (define/public (paste-x-selection time) (void)) + (define/public (kill time) (void)) + (define/public (select-all) (void)) + (define/public (insert snip) (void)) + (define/public (insert-paste-snip snip) (void)) + (define/public (insert-paste-string str) (void)) + (define/public (do-read-insert snip) (void)) + (define/public (set-caret-owner snip focus) (void)) + (define/public (read-from-file mf) #f) + + (define/public (do-copy time) (void)) + (define/public (do-paste time) (void)) + (define/public (do-paste-x-selection time) (void)) + + (def/public (do-edit-operation [symbol? op] [any? [recursive? #t]] [exact-integer? [time 0]]) + (if (and recursive? + s-caret-snip) + (send s-caret-snip do-edit-operation op #t time) + (case op + [(undo) (undo)] + [(redo) (redo)] + [(clear) (clear)] + [(cut) (cut #f time)] + [(copy) (copy #f time)] + [(paste) (paste time)] + [(kill) (kill time)] + [(insert-text-box) (insert-box 'text)] + [(insert-pasteboard-box) (insert-box 'pasteboard)] + [(insert-image) (insert-image)] + [(select-all) (select-all)]))) + + (def/public (can-do-edit-operation? [symbol? op] [any? [recursive? #t]]) + (if (and recursive? + s-caret-snip) + (send s-caret-snip can-do-edit-operation? op #t) + (cond + [(and (is-locked?) + (not (or (eq? op 'copy) (eq? op 'select-all)))) + #f] + [(and (eq? op 'undo) + (= changes-start changes-end)) + #f] + [(and (eq? op 'redo) + (= redochanges-start redochanges-end)) + #f] + [else (really-can-edit? op)]))) + + (define/public (really-can-edit?) #f) + + (def/public (insert-box [symbol? type]) + (let ([snip (on-new-box type)]) + (when snip + (let ([sname (default-style-name)]) + + (begin-edit-sequence) + (send snip set-s-style (or (send s-style-list find-named-style sname) + (send s-style-list basic-style))) + (insert snip) + (set-caret-owner snip) + (end-edit-sequence))))) + + (def/public (on-new-box [symbol? type]) + (let* ([media (if (eq? type 'text) + (new text%) + (new pasteboard%))] + [snip (make-object editor-snip% media)]) + (send media set-keymap s-keymap) + (send media set-style-list s-style-list) + snip)) + + (def/public (insert-image [(make-or-false path-string?) [filename #f]] + [symbol? [type 'unknown]] + [any? [relative? #f]] + [any? [inline-img? #t]]) + (let ([filename (or filename + (get-file #f))]) + (when filename + (let ([snip (on-new-image-snip filename type + (and relative? #t) + (and inline-img? #t))]) + (insert snip))))) + + (def/public (on-new-image-snip [path-string? filename] + [symbol? type] + [any? relative?] + [any? inline-img?]) + (make-object image-snip% filename type relative? inline-img?)) + + ;; ---------------------------------------- + + (def/public (get-snip-data [snip% s]) #f) + (def/public (set-snip-data [snip% s] [editor-data% v]) (void)) + + ;; ---------------------------------------- + + (def/public (read-header-from-file [editor-stream-in% f] [string? header-name]) + (error 'read-header-from-file "unknown header data: ~s" header-name)) + (def/public (read-footer-from-file [editor-stream-in% f] [string? header-name]) + (error 'read-header-from-file "unknown footer data: ~s" header-name)) + (def/public (write-headers-to-file [editor-stream-out% f]) #t) + (def/public (write-footers-to-file [editor-stream-out% f]) #t) + + (def/public (begin-write-header-footer-to-file [editor-stream-out% f] + [string? header-name] + [box? data-buffer]) + (set-box! data-buffer (send f tell)) + (send f put-fixed 0) + (send f put-bytes (string->bytes/utf-8 header-name)) + #t) + + (def/public (end-write-header-footer-to-file [editor-stream-out% f] + [exact-integer? data]) + (let ([end (send f tell)]) + (send f jump-to data) + (send f put-fixed 0) + (let ([pos (send f tell)]) + (send f jump-to data) + (send f put-fixed (- end pos)) + (send f jump-to end) + (set! num-extra-headers (add1 num-extra-headers)) + #t))) + + (def/public (read-headers-footers [editor-stream-in% f] [any? headers?]) + (let-boxes ([num-headers 0]) + (send f get-fixed num-headers) + (for/fold ([ok? #t]) ([i (in-range num-headers)] #:when ok?) + (let-boxes ([len 0]) + (send f get-fixed len) + (and (send f ok?) + (if (positive? len) + (let ([pos (send f tell)]) + (send f set-boundary len) + (let ([header-name (bytes->string/utf-8 (send f get-unterminated-bytes) #\?)]) + (and (if headers? + (read-header-from-file f header-name) + (read-footer-from-file f header-name)) + (send f ok?) + (begin + (send f remove-boundary) + (let ([len (- len (- (send f tell) pos))]) + (when (positive? len) + (send f skip len)) + (send f ok?)))))) + #t)))))) + + (define/public (do-write-headers-footers f headers?) + (let ([all-start (send f tell)]) + (send f put-fixed 0) + (set! num-extra-headers 0) + + (and + (if headers? + (write-headers-to-file f) + (write-footers-to-file f)) + (begin + (when (positive? num-extra-headers) + (let ([all-end (send f tell)]) + (send f jump-to all-start) + (send f put-fixed num-extra-headers) + (send f jump-to all-end)) + #t))))) + + ;; ---------------------------------------- + + (def/public (read-snips-from-file [editor-stream-in% f] + [any? overwritestylename?]) + (and (read-headers-footers f #t) + (let* ([list-id (box 0)] + [new-list (read-styles-from-file s-style-list f overwritestylename? list-id)]) + (and new-list + (begin + (unless (eq? new-list s-style-list) + (set-style-list new-list)) + (let-boxes ([num-headers 0]) + (send f get-fixed num-headers) + (and + ;; Read headers + (for/and ([i (in-range num-headers)]) + (let-boxes ([n 0] + [len 0]) + (begin + (send f get n) + (send f get-fixed len)) + (and (send f ok?) + (or (zero? len) + (let ([sclass (send (send f get-s-scl) find-by-map-position f n)]) + (and + (if sclass + (let ([start (send f tell)]) + (send f set-boundary len) + (and (send sclass read-header f) + (send f ok?) + (begin + (send f do-set-header-flag sclass) + (let ([rcount (- (send f tell) start)]) + (when (rcount . < . len) + (error 'read-snips-from-file "underread (caused by file corruption?)")) + (send f skip (- len rcount))) + (send f remove-boundary) + #t))) + (begin (send f skip len) #t)) + (send f ok?))))))) + ;; Read snips + (let-boxes ([num-snips 0]) + (send f get num-snips) + (let ([accum? (this . is-a? . text%)]) + (let ([accum + (for/fold ([accum null]) ([i (in-range num-snips)] #:when accum) + (let-boxes ([n 0]) + (send f get n) + (let ([sclass (if (n . >= . 0) + (send (send f get-s-scl) find-by-map-position f n) + #f)]) ; -1 => unknown + (let-boxes ([len 0]) + (if (or (not sclass) + (not (send sclass get-s-required?))) + (send f get-fixed len) + (set-box! len -1)) + (and (send f ok?) + (or (and (zero? len) accum) + (and + (if sclass + (let ([start (send f tell)]) + (when (len . >= . 0) + (send f set-boundary len)) + (let-boxes ([style-index 0]) + (send f get style-index) + (let ([snip (send sclass read f)]) + (and + snip + (begin + (when (has-flag? (snip->flags snip) OWNED) + (send snip set-s-flags (remove-flag (snip->flags snip) OWNED))) + (send snip set-s-style + (or + (send s-style-list map-index-to-style f style-index (unbox list-id)) + (send s-style-list basic-style))) + (let ([accum + (if accum? + (cons snip accum) + (do-read-insert snip))]) + (and + accum + (let ([data (read-buffer-data f)]) + (and + (send f ok?) + (let ([accum + (if accum? + (cons (cons (car accum) data) (cdr accum)) + (when data + (set-snip-data snip data)))]) + (and + accum + (begin + (when (len . >= . 0) + (let ([rcount (- (send f tell) start)]) + (when (rcount . < . len) + (error 'read-snips-from-file + "underread (caused by file corruption?)")) + (send f skip (- len rcount)) + (send f remove-boundary))) + accum)))))))))))) + (begin + (send f skip len) + (and (send f ok?) + accum))))))))))]) + (and accum + (begin + (when accum? + (let ([accum (reverse accum)]) + (send this do-read-insert (map car accum)) + (for ([p (in-list accum)]) + (when (cdr p) + (set-snip-data (car p) (cdr p)))))) + + (read-headers-footers f #f))))))))))))) + + ;; ---------------------------------------- + + (define/public (insert-port) (void)) + (define/public (insert-file) (void)) + (define/public (save-port) (void)) + (define/public (load-file) (void)) + (define/public (set-filename) (void)) + (define/public (write-to-file) (void)) + + (def/public (get-filename [(make-or-false box?) [temp #f]]) + (when temp (set-box! temp s-temp-filename?)) + s-filename) + + (define/private (extract-parent) + (and s-admin + ((send s-admin get-s-standard) . > . 0) + (let ([w (send s-admin do-get-canvas)]) + (send w get-top-level)))) + + (define/public (do-begin-print) (void)) + (define/public (print-to-dc) (void)) + (define/public (do-end-print) (void)) + (define/public (do-has-print-page?) (void)) + + (def/public (print [bool? [interactive? #t]] + [bool? [fit-to-page? #t]] + [(symbol-in standard postscript) [output-mode 'standard]] + [any? [parent #f]] ; checked in ../editor.ss + [bool? [force-page-bbox? #t]] + [bool? [as-eps? #f]]) + (let ([ps? (case (system-type) + [(macosx windows) (eq? output-mode 'postscript)] + [else #t])] + [parent (or parent + (extract-parent))]) + (cond + [ps? + (let ([dc (make-object post-script-dc% interactive? parent force-page-bbox? as-eps?)]) + (when (send dc ok?) + (send dc start-doc "printing buffer") + (set! printing dc) + (let ([data (do-begin-print dc fit-to-page?)]) + (print-to-dc dc) + (set! printing #f) + (do-end-print dc data) + (send dc end-doc) + (invalidate-bitmap-cache 0.0 0.0 'end 'end))))] + [else + (let ([data #f]) + (run-printout ;; from wx + parent + interactive? + fit-to-page? + ;; begin-doc: + (lambda (dc) + (set! printing dc) + (set! data (do-begin-print printing fit-to-page?))) + ;; has page?: + (lambda (dc n) (do-has-print-page? dc n)) + ;; print-page: + (lambda (dc n) (print-to-dc dc n)) + ;; end-doc + (lambda () + (let ([pr printing]) + (set! printing #f) + (do-end-print printing data)) + (invalidate-bitmap-cache 0.0 0.0 'end 'end))))]))) + + (def/public (undo) + (when (and (not undomode?) + (not redomode?)) + (set! undomode? #t) + (perform-undos #f) + (set! undomode? #f))) + + (def/public (redo) + (when (and (not undomode?) + (not redomode?)) + (set! redomode? #t) + (perform-undos #t) + (set! redomode? #f))) + + (define/private (do-clear-undos changes start end size) + (let loop ([i start]) + (unless (= i end) + (send (vector-ref changes i) cancel) + (vector-set! changes i #f) + (loop (modulo (+ i 1) size))))) + + (define/public (add-undo-rec rec) + (cond + [interceptmode? + (send intercepted append rec)] + [undomode? + (append-undo rec #t)] + [(zero? s-noundomode) + (when (not redomode?) + (cond + [emacs-style-undo? + (when (not (= redochanges-start redochanges-end)) + (let loop ([e redochanges-end]) + (unless (= redochanges-start e) + (let ([e (modulo (+ e -1 redochanges-size) redochanges-size)]) + (append-undo (vector-ref redochanges (send (vector-ref redochanges e) inverse)) #f) + (loop e)))) + (let loop () + (unless (= redochanges-start redochanges-end) + (append-undo (vector-ref redochanges redochanges-start) #f) + (vector-set! redochanges redochanges-start #f) + (set! redochanges-start (modulo (add1 redochanges-start) redochanges-size)))) + (set! redochanges-start 0) + (set! redochanges-end 0))] + [else + (do-clear-undos redochanges redochanges-start redochanges-end redochanges-size) + (set! redochanges-start 0) + (set! redochanges-end 0)])) + (append-undo rec #f)] + [else (send rec cancel)])) + + (def/public (add-undo [(make-procedure 0) proc]) + (add-undo-rec (new proc-record% [proc proc]))) + + (define/private (append-undo rec redos?) + (if (or (eq? max-undos 'forever) (positive? max-undos)) + (let-values ([(start end size c) (get-undos redos?)]) + (let-values ([(size c) (if (zero? size) + (let ([size (min 128 (if (eq? max-undos 'forever) 128 max-undos))]) + (values size + (make-vector size #f))) + (values size c))]) + (vector-set! c end rec) + (let ([end (modulo (add1 end) size)]) + (let-values ([(start end size c) + (if (= end start) + (if (or (eq? max-undos 'forever) + (size . < . max-undos) + emacs-style-undo?) + ;; make more room + (let* ([s (min (* size 2) (if (eq? max-undos 'forever) (* size 2) max-undos))] + [naya (make-vector s #f)]) + (for ([j (in-range size)]) + (vector-set! naya j (vector-ref c (modulo (+ start j) size)))) + (values 0 size s naya)) + ;; no room to grow, so drop an undo record + (begin + (send c cancel) + (vector-set! c start #f) + (values (modulo (add1 start) size) + end + size + c))) + (values start end size c))]) + (put-undos-back redos? start end size c))))) + (send rec cancel))) + + (define/private (get-undos redos?) + (if redos? + (values redochanges-start redochanges-end redochanges-size redochanges) + (values changes-start changes-end changes-size changes))) + + (define/private (put-undos-back redos? start end size c) + (if redos? + (begin + (set! redochanges-start start) + (set! redochanges-end end) + (set! redochanges-size size) + (set! redochanges c)) + (begin + (set! changes-start start) + (set! changes-end end) + (set! changes-size size) + (set! changes c)))) + + (def/public (begin-edit-sequence) (void)) + (def/public (end-edit-sequence) (void)) + (def/public (in-edit-sequence?) #f) + (def/public (refresh-delayed?) #f) + (def/public (locations-computed?) #f) + + (define/private (perform-undos redos?) + (let ([id #f] [parity #f]) + (let-values ([(start end size c) (get-undos redos?)]) + (begin-edit-sequence) + (let loop ([end end]) + (unless (= start end) + (let ([end (modulo (+ end -1 size) size)]) + (let ([rec (vector-ref c end)]) + (vector-set! c end #f) + (put-undos-back redos? start end size c) + (when emacs-style-undo? + (set! id (send rec get-id)) + (set! parity (send rec get-parity))) + (when (send rec undo this) + (loop end)))))) + (end-edit-sequence) + (when (and emacs-style-undo? + (not redos?)) + ;; combine all new steps into one undo record, and + ;; set/generate id + (let-values ([(start end size c) (get-undos #t)]) + (unless (= start end) + (let ([cnt (let loop ([e end][cnt 0]) + (if (= start e) + cnt + (let ([e (modulo (+ e -1 size) size)]) + (if (send (vector-ref c e) is-composite?) + cnt + (loop e (add1 cnt))))))]) + (when (positive? cnt) + (let ([cu (new composite-record% [cnt cnt] [id id] [parity (not parity)])]) + (for ([i (in-range cnt)]) + (let ([e (modulo (+ (- end cnt) i size) size)]) + (send cu add-undo i (vector-ref c e)) + (vector-set! c e #f))) + (let ([e (modulo (+ (- end cnt) cnt size) size)]) + (vector-set! c e cu) + (set! redochanges-end (modulo (add1 e) size)))))))))))) + + (define/public (perform-undo-list changes) + (begin-edit-sequence) + (let loop ([changes changes]) + (unless (null? changes) + (when (send (car changes) undo this) + (loop (cdr changes))))) + (end-edit-sequence)) + + (define/public (clear-undos) + (do-clear-undos changes changes-start changes-end changes-size) + (set! changes-start 0) + (set! changes-end 0) + (do-clear-undos redochanges redochanges-start redochanges-end redochanges-size) + (set! redochanges-start 0) + (set! redochanges-end 0)) + + (def/public (set-max-undo-history [max-undo-value? v]) + (unless (or undomode? + redomode? + (eq? v max-undos)) + (when (equal? 0 v) + (clear-undos) + (set! changes #f) + (set! redochanges #f) + (set! changes-size 0) + (set! redochanges-size 0)) + ;; should we bother downsizing if max-undos gets smaller but stays + ;; non-0? + (set! max-undos v))) + + (def/public (get-max-undo-history) max-undos) + + (def/public (s-start-intercept) + (set! interceptmode? #t) + (set! intercepted null)) + + (def/public (s-end-intercept) + (begin0 + intercepted + (set! interceptmode? #f) + (set! intercepted null))) + + ;; ---------------------------------------- + + ;; see top-level functions below, at "copy ring" + + (define/public (copy-ring-next) + (vector-set! copy-ring-buffer1 copy-ring-pos common-copy-buffer) + (vector-set! copy-ring-buffer2 copy-ring-pos common-copy-buffer2) + (vector-set! copy-ring-data copy-ring-pos common-copy-region-data) + (vector-set! copy-ring-style copy-ring-pos copy-style-list) + + (set! copy-ring-pos (sub1 copy-ring-pos)) + (when (copy-ring-pos . < . 0) + (set! copy-ring-pos (sub1 copy-ring-max))) + + (set! common-copy-buffer (vector-ref copy-ring-buffer1 copy-ring-pos)) + (set! common-copy-buffer2 (vector-ref copy-ring-buffer2 copy-ring-pos)) + (set! common-copy-region-data (vector-ref copy-ring-data copy-ring-pos)) + (set! copy-style-list (vector-ref copy-ring-style copy-ring-pos))) + + (define/public (begin-copy-buffer) + (set! copy-depth (add1 copy-depth))) + (define/public (end-copy-buffer) + (set! copy-depth (sub1 copy-depth))) + + (define/public (free-old-copies) + (when copy-style-list + (if (copy-depth . > . 1) + ;; delete current "ring" occupant: + (begin + (set! common-copy-buffer null) + (set! common-copy-buffer2 null) + (set! common-copy-region-data #f) + (set! copy-style-list #f)) + + (begin + (vector-set! copy-ring-buffer1 copy-ring-pos common-copy-buffer) + (vector-set! copy-ring-buffer2 copy-ring-pos common-copy-buffer2) + (vector-set! copy-ring-data copy-ring-pos common-copy-region-data) + (vector-set! copy-ring-style copy-ring-pos copy-style-list) + + (when (copy-ring-max . > . copy-ring-dest) + ;; no more space: delete current ring occupant: + (vector-set! copy-ring-buffer1 copy-ring-dest #f) + (vector-set! copy-ring-buffer2 copy-ring-dest #f) + (vector-set! copy-ring-data copy-ring-dest #f)) + + (set! common-copy-buffer null) + (set! common-copy-buffer2 null) + (set! common-copy-region-data #f) + (set! copy-style-list #f) + (set! copy-ring-pos copy-ring-dest) + + (set! copy-ring-dest (add1 copy-ring-dest)) + (when (copy-ring-max . < . copy-ring-dest) + (set! copy-ring-max copy-ring-dest)) + (when (copy-ring-dest . >= . copy-ring-size) + (set! copy-ring-dest 0)))))) + + (define/public (install-copy-buffer time sl) + (set! copy-style-list sl) + + (when (not (= copying-self copy-depth)) + (when (or (not ALLOW-X-STYLE-SELECTION?) + (not x-clipboard-hack?)) + (send the-clipboard set-clipboard-client the-editor-clipboard-client time)))) + + (define/public (do-buffer-paste cb time local?) + ;; cut and paste to ourself? (same eventspace?) + (if (or local? + (and (not paste-text-only?) + (send cb same-clipboard-client? the-editor-clipboard-client) + (send the-editor-clipboard-client same-eventspace? (current-eventspace)))) + ;; local direct copy: + (begin + (set! copy-depth (add1 copy-depth)) + (map (lambda (snip bd) + (insert-paste-snip (send snip copy) bd)) + (reverse common-copy-buffer) + (reverse common-copy-buffer2)) + (set! copy-depth (sub1 copy-depth)) + (when (and common-copy-region-data + (this . is-a? . text%)) + (send this paste-region-data common-copy-region-data))) + ;; general paste: + (or + (and (not paste-text-only?) + (let ([str (send cb get-clipboard-data "WXME" time)]) + (and str + (let* ([b (make-object editor-stream-in-bytes-base% str)] + [mf (make-object editor-stream-in% b)]) + (and (read-editor-version mf b #t #f) + (begin + (when (read-editor-global-header mf) + (when (send mf ok?) + (when (read-from-file mf) + (let ([data (read-buffer-data mf)]) + (and data + (this . is-a? . text%) + (send this paste-region-data data)))))) + (read-editor-global-footer mf) + #t)))))) + (and (not paste-text-only?) + (let ([bm (send cb get-clipboard-bitmap time)]) + (and bm + (begin + (insert-paste-snip (make-object image-snip% bm) #f) + #t)))) + (let ([str (send cb get-clipboard-string time)]) + ;; no data => empty string + (insert-paste-string str))))) + + (def/public (copy-self) (void)) + + (def/public (copy-self-to [editor<%> m]) + ;; copy style list + (send (send m get-s-style-list) copy s-style-list) + ;; copy all the snips: + (let ([save-buffer common-copy-buffer] + [save-buffer2 common-copy-buffer2] + [save-styles copy-style-list] + [save-data common-copy-region-data] + [save-cs copying-self]) + + (send m begin-edit-sequence) + + (set! common-copy-buffer null) + (set! common-copy-buffer2 null) + (set! copy-style-list #f) + (set! common-copy-region-data #f) + (set! copying-self (add1 copy-depth)) + + (cond + [(this . is-a? . text%) + (send this copy #t 0 0 (send this last-position))] + [(this . is-a? . pasteboard%) + (begin-edit-sequence) + (let ([unselect + (let loop ([s (send this find-first-snip)]) + (if s + (if (send this is-selected? s) + (begin + (send this add-selected s) + (cons s (loop (snip->next s)))) + (loop (snip->next s))) + null))]) + (send this copy #t 0) + (for-each (lambda (s) + (send this remove-selected s)) + unselect)) + (end-edit-sequence)]) + + (let ([copy-snips (reverse common-copy-buffer)] + [copy-snips2 (reverse common-copy-buffer2)]) + + (set! common-copy-buffer save-buffer) + (set! common-copy-buffer2 save-buffer2) + (set! copy-style-list save-styles) + (set! common-copy-region-data save-data) + (set! copying-self save-cs) + + (when (this . is-a? . text%) + (send m do-insert-snips copy-snips 0)) + + (for-each (lambda (s bfd) + (unless (this . is-a? . text%) + (send m insert s s)) ;; before itself -> at end + (when bfd + (send m set-snip-data s bfd))) + copy-snips + copy-snips2) + + (send m size-cache-invalid) + + (send m set-min-width (get-min-width)) + (send m set-max-width (get-max-width)) + (send m set-min-height (get-min-height)) + (send m set-max-height (get-max-height)) + + (let-boxes ([temp? (box #f)] + [f (box #f)]) + (set-box! f (get-filename temp?)) + (send m set-filename f temp?)) + + (send m set-max-undo-history (get-max-undo-history)) + + (send m set-keymap (get-keymap)) + + (send m set-inactive-caret-threshold (get-inactive-caret-threshold)) + (send m set-load-overwrites-styles (get-load-overwrites-styles)) + + (send m end-edit-sequence)))) + + ;; ---------------------------------------- + + (define/public (own-x-selection) (void)) + + (define/public (do-own-x-selection on? force?) + (if on? + (if (and (not force?) + (not (eq? editor-x-selection-allowed this))) + #f + (begin + (when editor-x-selection-owner + (send editor-x-selection-owner own-x-selection #f #t #f) + (set! editor-x-selection-owner #f)) + (set! x-selection-copied? #f) + (send the-x-selection-clipboard set-clipboard-client the-editor-x-clipboard-client 0) + (set! editor-x-selection-owner this) + #t)) + (begin + (when (eq? this editor-x-selection-owner) + (set! editor-x-selection-owner #f) + (when (and (not x-selection-copied?) + (send the-x-selection-clipboard same-clipboard-client? + the-editor-x-clipboard-client)) + (send the-x-selection-clipboard set-clipboard-string "" 0))) + #t))) + + (define/public (copy-out-x-selection) + (when (eq? this editor-x-selection-owner) + (copy-into-selection) + (set! x-selection-copied? #t))) + + (def/public (get-paste-text-only) + paste-text-only?) + + (def/public (set-paste-text-only [any? pto?]) + (set! paste-text-only? (and pto? #t))) + + ;; ---------------------------------------- + + (def/public (lock [any? lock?]) + (set! s-user-locked? (and lock? #t))) + + (def/public (is-locked?) s-user-locked?) + + (def/public (modified?) s-modified?) + + (def/public (set-modified [any? mod?]) + (let ([mod? (and mod? #t)]) + (unless (eq? mod? s-modified?) + (set! s-modified? mod?) + (when mod? + (set! num-parts-modified 1)) + + (when (and (not mod?) + (not undomode?)) + ;; get rid of undos that reset the modification state + (set! num-parts-modified 0) + (let loop ([i changes-end]) + (unless (= i changes-start) + (let ([i (modulo (+ i -1 changes-size) changes-size)]) + (send (vector-ref changes i) drop-set-unmodified) + (loop i)))) + (let loop ([i redochanges-end]) + (unless (= i redochanges-start) + (let ([i (modulo (+ i -1 redochanges-size) redochanges-size)]) + (send (vector-ref redochanges i) drop-set-unmodified) + (loop i))))) + + (when s-admin + (send s-admin modified s-modified?)) + + (when (and (not mod?) (not undomode?)) + ;; tell all snips that they should now consider themselves unmodified: + (let loop ([snip (find-first-snip)]) + (when snip + (send snip set-unmodified) + (loop (snip->next snip)))))))) + + (def/public (on-snip-modified [snip% s] [any? mod?]) + (if (not mod?) + (when (= num-parts-modified 1) + (set! num-parts-modified 0) + (when s-modified? + (set-modified #f))) + (if s-modified? + (set! num-parts-modified (add1 num-parts-modified)) + (set-modified #t)))) + + (def/public (get-inactive-caret-threshold) + s-inactive-caret-threshold) + + (def/public (set-inactive-caret-threshold [(symbol-in no-caret show-inactive-caret show-caret) v]) + (set! s-inactive-caret-threshold v)) + + (define/public (scroll-editor-to localx localy w h refresh? bias) + (if s-admin + (send s-admin scroll-to localx localy w h refresh? bias) + #f)) + + (def/public (refresh [real? left] [real? top] [nonnegative-real? width] [nonnegative-real? height] + [(symbol-in no-caret show-inactive-caret show-caret) show-caret] + [(make-or-false color%) bg-color]) + (void)) + + (def/public (on-paint [any? pre?] [dc<%> dc] + [real? l] [real? t] [real? r] [real? b] + [real? dx] [real? dy] + [(symbol-in no-caret show-inactive-caret show-caret) show-caret]) + (void)) + + (def/public (can-save-file? [path-string? filename] + [symbol? format]) + #t) + + (def/public (on-save-file [path-string? filename] + [symbol? format]) + (void)) + + (def/public (after-save-file [any? ok?]) + (void)) + + (def/public (can-load-file? [path-string? filename] + [symbol? format]) + #t) + + (def/public (on-load-file [path-string? filename] + [symbol? format]) + (void)) + + (def/public (after-load-file [any? ok?]) + (void)) + + (def/public (on-edit-sequence) (void)) + + (def/public (after-edit-sequence) (void)) + + (def/public (on-display-size) (void)) + + (def/public (on-change) (void)) + + (def/public (on-display-size-when-ready) + (cond + [(in-edit-sequence?) + (set! s-need-on-display-size? #t)] + [(or (not seq-lock) + (semaphore-try-wait? seq-lock)) + (when seq-lock + (semaphore-post seq-lock)) + (on-display-size)] + [else (set! s-need-on-display-size? #t)])) + + (def/public (begin-sequence-lock) + (call-with-semaphore + global-lock + (lambda () + (unless seq-lock + (set! seq-lock (make-semaphore 1))))) + + ;; "Try" really should succeed, because multiple refreshes are + ;; prevented through other flags. Still, we don't want to block if + ;; someone previously escaped from a repaint. + (void (semaphore-try-wait? seq-lock))) + + (def/public (end-sequence-lock) + (semaphore-post seq-lock)) + + (def/public (wait-sequence-lock) + (when seq-lock + (sync seq-lock) + (semaphore-post seq-lock))) + + (def/public (get-file [(make-or-false path-string?) path]) + (editor-get-file "choose a file" (extract-parent) #f path)) + + (def/public (put-file [(make-or-false path-string?) dir] + [(make-or-false string?) suggested-name]) + (editor-put-file "save file as" (extract-parent) dir suggested-name)) + + (def/public (set-load-overwrites-styles [any? b?]) + (set! loadoverwritesstyles? (and b? #t))) + + (def/public (get-load-overwrites-styles) loadoverwritesstyles?)) + +(define editor<%> (class->interface editor%)) + +;; ------------------------------------------------------------ + +(define/top (add-editor-keymap-functions [keymap% tab]) + (let ([add (lambda (n f) + (send tab add-function n f))]) + (add "copy-clipboard" (lambda (e event) (send e copy #f (send event get-time-stamp)))) + (add "copy-append-clipboard" (lambda (e event) (send e copy #t (send event get-time-stamp)))) + (add "paste-clipboard" (lambda (e event) (send e paste (send event get-time-stamp)))) + (add "paste-x-selection" (lambda (e event) (send e paste-x-selection (send event get-time-stamp)))) + (add "cut-clipboard" (lambda (e event) (send e cut #f (send event get-time-stamp)))) + (add "cut-append-clipboard" (lambda (e event) (send e cut #t (send event get-time-stamp)))) + (add "delete-to-end-of-line" (lambda (e event) (send e kill (send event get-time-stamp)))) + (add "undo" (lambda (e event) (send e undo))) + (add "redo" (lambda (e event) (send e redo))) + (add "delete-selection" (lambda (e event) (send e clear))) + (add "clear-selection" (lambda (e event) (send e clear))) + (add "select-all" (lambda (e event) (send e select-all))))) + +;; ------------------------------------------------------------ + +(define (write-buffer-data f data) + (let loop ([data data]) + (if data + (let ([mp (send f do-map-position (send data get-s-dataclass))]) + (send f put mp) + (let ([req? (send (send data get-s-dataclass) get-s-required?)]) + (let-values ([(data-start data-pos) + (if req? + (values #f #f) + (values (send f tell) + (begin + (send f put-fixed 0) + (send f tell))))]) + (if (not (send data write f)) + #f + (begin + (unless req? + (let ([data-end (send f tell)]) + (send f jump-to data-start) + (send f put-fixed (- data-end data-pos)) + (send f jump-to data-end))) + (loop (send data get-s-next))))))) + (begin + (send f put 0) + #t)))) + +(define (write-snips-to-file f style-list snip-list + start-snip end-snip + extra-data buffer) + (and + (write-styles-to-file style-list f) + (let ([all-start (send f tell)]) + (send f put-fixed 0) + + (let ([snip-list + (if snip-list + (reverse snip-list) + (let loop ([snip start-snip]) + (if (and snip + (not (eq? snip end-snip))) + (cons snip (loop (snip->next snip))) + null)))]) + + (let ([num-headers + (let loop ([num-headers 0] + [snips snip-list]) + (if (null? snips) + num-headers + (let ([snip (car snips)]) + (let ([sclass (snip->snipclass snip)]) + (unless sclass + (error 'write-snips-to-file "snip has no snipclass")) + (if (send f do-get-header-flag sclass) + (begin + (send f put (send f do-map-position sclass)) + (let ([header-start (send f tell)]) + (send f put-fixed 0) + (let ([header-pos (send f tell)]) + (if (not (send sclass write-header f)) + #f + (begin + (send f do-set-header-flag sclass) + (let ([header-end (send f tell)]) + (send f jump-to header-start) + (send f put-fixed (- header-end header-pos)) + (send f jump-to header-end) + (if (send f ok?) + (loop (add1 num-headers) + (cdr snips)) + #f))))))) + (loop num-headers (cdr snips)))))))]) + + (and + num-headers + (let ([all-end (send f tell)]) + (send f jump-to all-start) + (send f put-fixed num-headers) + (send f jump-to all-end) + + (send f put (length snip-list)) + + (andmap + (lambda (snip data) + (let ([sclass (snip->snipclass snip)]) + (if sclass + (send f put (send f do-map-position sclass)) + (send f put -1)) + (let-values ([(snip-start snip-pos) + (if (or (not sclass) + (not (send sclass get-s-required?))) + (values (send f tell) + (begin + (send f put-fixed 0) + (send f tell))) + (values #f #f))]) + (let ([style-index (send style-list style-to-index (snip->style snip))]) + (when (not style-index) + (error 'write-snips-to-file "bad style discovered")) + (send f put style-index)) + (send snip write f) + (and (write-buffer-data f data) + (begin + (when snip-start + (let ([snip-end (send f tell)]) + (send f jump-to snip-start) + (send f put-fixed (- snip-end snip-pos)) + (send f jump-to snip-end))) + (send f ok?)))))) + snip-list + (if extra-data + (reverse extra-data) + (map (lambda (snip) + (send buffer get-snip-data snip)) + snip-list)))))))))) + +;; ------------------------------------------------------------ + +;; Copy and the copy ring: the current clipboard content is stored in +;; common-copy-buffer, etc. to implement the copy ring, then when a +;; copy is started, we moved the wxmb_common-copy-buffer, etc. values +;; into a copy ring. yanking from the ring swaps the values in +;; wxmb_common-copy-buffer, etc. and the ring values and adjust the +;; pointer into the ring. + +(define copy-depth 0) + +(define copy-ring-size 30) +(define copy-ring-pos 0) +(define copy-ring-max 1) +(define copy-ring-dest 1) + +(define copy-ring-buffer1 (make-vector copy-ring-size #f)) +(define copy-ring-buffer2 (make-vector copy-ring-size #f)) + +(define copy-ring-style (make-vector copy-ring-size #f)) +(define copy-ring-data (make-vector copy-ring-size #f)) + +(define common-copy-buffer null) +(define common-copy-buffer2 null) +(define copy-style-list #f) +(define common-copy-region-data #f) + +(define selection-copy-buffer #f) +(define selection-copy-buffer2 #f) +(define selection-copy-style-list #f) +(define selection-copy-region-data #f) + +(define (set-common-copy-region-data! v) (set! common-copy-region-data v)) +(define (cons-common-copy-buffer! v) (set! common-copy-buffer (cons v common-copy-buffer))) +(define (cons-common-copy-buffer2! v) (set! common-copy-buffer2 (cons v common-copy-buffer2))) + +(define copying-self 0) + +(define editor-x-selection-mode? ALLOW-X-STYLE-SELECTION?) +(define editor-x-selection-owner #f) +(define editor-x-selection-allowed #f) +(define x-selection-copied? #f) +(define x-clipboard-hack? #f) + +(define (generic-get-data fformat copy-buffer copy-buffer2 copy-styles copy-region-data) + (cond + [(equal? fformat "TEXT") + (string->bytes/utf-8 + (let ([out (open-output-string)]) + (for-each (lambda (snip) + (let ([s (send snip get-text 0 (snip->count snip) #t)]) + (display s out))) + (reverse copy-buffer)) + (let ([s (get-output-string out)]) + (cond + [(eq? 'macosx (system-type)) + ;; change newline to return + (regexp-replace* #rx"\r" s "\n")] + [(eq? 'windows (system-type)) + ;; change newline to return-newline: + (regexp-replace* #rx"\n" s "\r\n")] + [else s]))))] + [(equal? fformat "WXME") + (let* ([b (make-object editor-stream-out-bytes-base%)] + [mf (make-object editor-stream-out% b)]) + (write-editor-version mf b) + (write-editor-global-header mf) + (and (send mf ok?) + (begin + (send mf put-fixed 0) + (and (write-snips-to-file mf copy-styles copy-buffer #f #f copy-buffer2 #f) + (begin + (send mf put-fixed 0) + (write-buffer-data mf copy-region-data)))) + (write-editor-global-footer mf) + (send b get-bytes)))] + [else #""])) + +(defclass editor-clipboard-client% clipboard-client% + (inherit add-type) + (super-new) + (add-type "TEXT") + (add-type "WXME") + (define/override (get-data format) + (generic-get-data format + common-copy-buffer + common-copy-buffer2 + copy-style-list + common-copy-region-data)) + (define/override (on-replaced) + (void))) + +(defclass editor-x-clipboard-client% clipboard-client% + (inherit add-type) + (super-new) + (add-type "TEXT") + (add-type "WXME") + (define/override (get-data format) + (cond + [(and (not x-selection-copied?) + (not editor-x-selection-owner)) + ""] + [else + (when (or (not x-selection-copied?) + editor-x-selection-owner) + (copy-into-selection)) + + ;; if nothing is copied (e.g., do-copy is overriden to not copy anything + ;; or copies directly to clipboard): + (if (not selection-copy-style-list) + (if (send the-x-selection-clipboard same-clipboard-client? this) + #f + (send the-x-selection-clipboard get-clipboard-data format 0)) + (generic-get-data format + selection-copy-buffer + selection-copy-buffer2 + selection-copy-style-list + selection-copy-region-data))])) + (define/override (on-replaced) + (if editor-x-selection-owner + ;; in case this client replaced itself somewhere along the way: + (when (not (send the-x-selection-clipboard same-clipboard-client? this)) + (let ([b editor-x-selection-owner]) + (set! editor-x-selection-owner #f) + (set! x-selection-copied? #f) + (send b own-x-selection #f #t #f))) + (set! x-selection-copied? #f)))) + +(define the-editor-clipboard-client + (new editor-clipboard-client%)) +(define the-editor-x-clipboard-client + (new editor-x-clipboard-client%)) + +(define/top (editor-set-x-selection-mode [any? on?]) + (when ALLOW-X-STYLE-SELECTION? + (set! editor-x-selection-mode? (and on? #t)) + (when (and (not on?) + (send the-x-selection-clipboard same-clipboard-client? + the-editor-x-clipboard-client)) + (send the-x-selection-clipboard set-clipboard-string "" 0)))) + +(define (copy-into-selection) + ;; copy all the snips: + (set! x-clipboard-hack? #t) + + ;; save normal buffers: + (let ([save-buffer common-copy-buffer] + [save-buffer2 common-copy-buffer2] + [save-styles copy-style-list] + [save-data common-copy-region-data]) + + ;; set up new selection buffers, and redirect: + (set! common-copy-buffer null) + (set! common-copy-buffer2 null) + (set! copy-style-list #f) + (set! common-copy-region-data #f) + + (send editor-x-selection-owner copy #f 0) + + ;; move "normal" buffers to selection: + (set! selection-copy-buffer common-copy-buffer) + (set! selection-copy-buffer2 common-copy-buffer2) + (set! selection-copy-style-list copy-style-list) + (set! selection-copy-region-data common-copy-region-data) + + ;; restore normal buffers: + (set! common-copy-buffer save-buffer) + (set! common-copy-buffer2 save-buffer2) + (set! copy-style-list save-styles) + (set! common-copy-region-data save-data)) + + (set! x-clipboard-hack? #f)) + +;; ------------------------------------------------------------ + +(define (read-buffer-data f) + (let loop ([data #f]) + (let-boxes ([extra-data-index 0]) + (send f get extra-data-index) + (if (zero? extra-data-index) + data + (let ([dclass (send (send f get-s-bdl) find-by-map-position f extra-data-index)]) + (let ([datalen (if (or (not dclass) + (not (send dclass get-s-required?))) + (let-boxes ([datalen 0]) + (send f get datalen) + datalen) + -1)]) + (if dclass + (let ([start (send f tell)]) + (when (datalen . >= . 0) + (send f set-boundary datalen)) + (let ([newdata (send dclass read f)]) + (and + newdata + (begin + (send newdata set-s-next data) + (let ([data newdata]) + (when (datalen . >= . 0) + (let ([rcount (- (send f tell) start)]) + (when (rcount . < . datalen) + (error 'read-buffer-data "underread (caused by file corruption?)")) + (send f skip (- datalen rcount))) + (send f remove-boundary)) + (and (send f ok?) + (loop data))))))) + ;; unknown extra data + (begin + (send f skip datalen) + (and (send f ok?) + (loop data)))))))))) + +;; ------------------------------------------------------------ + +(define MRED-READER-STR #"#reader(lib\"read.ss\"\"wxme\")") +(define MRED-START-STR #"WXME") +(define MRED-FORMAT-STR #"01") +(define MRED-VERSION-STR #"08") +(define MRED-VERSION-RX #rx"^0[1-8]$") + +(define (write-editor-version f b) + (send b write-bytes MRED-READER-STR) + (send b write-bytes MRED-START-STR) + (send b write-bytes MRED-FORMAT-STR) + (send b write-bytes MRED-VERSION-STR) + (send b write-bytes #" ## ") + (not (send b bad?))) + +(define MRED-READER+START-STR (bytes-append MRED-READER-STR MRED-START-STR)) + +(define (detect-wxme-file who f peek?) + (let* ([l1 (bytes-length MRED-START-STR)] + [s (if peek? + (peek-bytes l1 0 f) + (read-bytes l1 f))]) + (or (equal? s MRED-START-STR) + (and (equal? s (subbytes MRED-READER-STR 0 l1)) + (let ([s (bytes-append + s + (let ([v (if peek? + (peek-bytes (- (bytes-length MRED-READER+START-STR) l1) l1 f) + (read-bytes (- (bytes-length MRED-READER+START-STR) l1) f))]) + (if (eof-object? v) + "" + v)))]) + (equal? s MRED-READER+START-STR)))))) + +(define (read-editor-version mf b parse-format? show-errors?) + (and + (or + (not parse-format?) + (let* ([n1 (bytes-length MRED-START-STR)] + [vbuf (make-vector n1)]) + (let ([n (send b read vbuf)]) + (or (and (= n (vector-length vbuf)) + (bytes=? MRED-START-STR (string->bytes/latin-1 (list->string (vector->list vbuf))))) + ;; maybe we have a #reader... prefix? + (let* ([n2 (bytes-length MRED-READER-STR)] + [vbuf2 (make-vector (- n2 n1))]) + (let ([n (send b read vbuf2)]) + (and (= n (- n2 n1)) + (bytes=? MRED-READER-STR + (string->bytes/latin-1 + (string-append (list->string (vector->list vbuf)) + (list->string (vector->list vbuf2))))) + ;; yes, so try reading start again. + (let ([n (send b read vbuf)]) + (and (= n (vector-length vbuf)) + (bytes=? MRED-START-STR (string->bytes/latin-1 (list->string (vector->list vbuf))))))))) + (if show-errors? + (error (method-name 'pasteboard%: 'insert-file) "not a WXME file") + #f))))) + (begin + (let* ([n1 (bytes-length MRED-FORMAT-STR)] + [vbuf (make-vector n1)]) + (let ([n (send b read vbuf)]) + (send mf set-s-read-format (string->bytes/latin-1 (list->string (vector->list vbuf)))))) + (let* ([n1 (bytes-length MRED-VERSION-STR)] + [vbuf (make-vector n1)]) + (let ([n (send b read vbuf)]) + (and (= n n1) + (send mf set-s-read-version (string->bytes/latin-1 (list->string (vector->list vbuf))))))) + (check-format-and-version mf b show-errors?)))) + +(define (read-editor-global-header f) + (send (send f get-s-scl) reset-header-flags f) + (if (not (send (send f get-s-scl) read f)) + #f + (begin + (setup-style-reads-writes f) + (send (send f get-s-bdl) read f)))) + +(define (read-editor-global-footer f) + (done-style-reads-writes f) + (send (send f get-s-scl) reset-header-flags f) + #t) + +(define (write-editor-global-header f) + (send f pretty-start) + (send (send f get-s-scl) reset-header-flags f) + (if (not (send (send f get-s-scl) write f)) + #f + (begin + (setup-style-reads-writes f) + (send (send f get-s-bdl) write f)))) + +(define (write-editor-global-footer f) + (done-style-reads-writes f) + (send (send f get-s-scl) reset-header-flags f) + (send f pretty-finish) + #t) + +(define (check-format-and-version s b show-errors?) + (and + (or (bytes=? (send s get-s-read-format) MRED-FORMAT-STR) + (if show-errors? + (error 'load-file "unknown format number in WXME file format: ~s" + (send s get-s-read-format)) + #f)) + (or (regexp-match MRED-VERSION-RX (send s get-s-read-format)) + (if show-errors? + (error 'load-file "unknown version number in WXME file format") + #f)) + (if ((send s get-wxme-version) . > . 3) + ;; need to skip " ## " + (let* ([v (make-vector 4)] + [n (send b read v)]) + (or (and (= n 4) + (char=? (vector-ref v 0) #\space) + (char=? (vector-ref v 1) #\#) + (char=? (vector-ref v 2) #\#) + (member (vector-ref v 3) '(#\space #\return #\newline))) + (if show-errors? + (error 'load-file "WXME file missing ' ## ' mark") + #f))) + #t))) diff --git a/collects/mred/private/wxme/keymap.ss b/collects/mred/private/wxme/keymap.ss new file mode 100644 index 00000000..4f2f66a9 --- /dev/null +++ b/collects/mred/private/wxme/keymap.ss @@ -0,0 +1,737 @@ +#lang scheme/base +(require scheme/class + "../syntax.ss" + "wx.ss") + +(provide keymap% + map-command-as-meta-key) + +(define map-command-as-meta? #f) + +(define/top (map-command-as-meta-key [bool? v]) + (set! map-command-as-meta? v)) + +(define (as-meta-key k) + (case (system-type) + [(macosx) (if map-command-as-meta? + k + #f)] + [else k])) + +(define (as-cmd-key k) + (case (system-type) + [(macosx) k] + [else #f])) + +(define keylist + #hash(("leftbutton" . mouse-left) + ("rightbutton" . mouse-right) + ("middlebutton" . mouse-middle) + ("leftbuttondouble" . mouse-left-double) + ("rightbuttondouble" . mouse-right-double) + ("middlebuttondouble" . mouse-middle-double) + ("leftbuttontriple" . mouse-left-triple) + ("rightbuttontriple" . mouse-right-triple) + ("middlebuttontriple" . mouse-middle-triple) + ("leftbuttonseq" . mouse-left) + ("rightbuttonseq" . mouse-right) + ("middlebuttonseq" . mouse-middle) + ("wheelup" . wheel-up) + ("wheeldown" . wheel-down) + ("esc" . escape) + ("delete" . delete) + ("del" . #\rubout) + ("insert" . insert) + ("ins" . insert) + ("add" . add) + ("subtract" . subtract) + ("multiply" . multiply) + ("divide" . divide) + ("backspace" . back) + ("back" . back) + ("return" . #\return) + ("enter" . #\return) + ("tab" . #\tab) + ("space" . #\space) + ("right" . right) + ("left" . left) + ("up" . up) + ("down" . down) + ("home" . home) + ("end" . end) + ("pageup" . prior) + ("pagedown" . next) + ("semicolon" . #\;) + ("colon" . #\:) + ("numpad0" . numpad0) + ("numpad1" . numpad1) + ("numpad2" . numpad2) + ("numpad3" . numpad3) + ("numpad4" . numpad4) + ("numpad5" . numpad5) + ("numpad6" . numpad6) + ("numpad7" . numpad7) + ("numpad8" . numpad8) + ("numpad9" . numpad9) + ("numpadenter" . #\u3) + ("f1" . f1) + ("f2" . f2) + ("f3" . f3) + ("f4" . f4) + ("f5" . f5) + ("f6" . f6) + ("f7" . f7) + ("f8" . f8) + ("f9" . f9) + ("f10" . f10) + ("f11" . f11) + ("f12" . f12) + ("f13" . f13) + ("f14" . f14) + ("f15" . f15) + ("f16" . f16) + ("f17" . f17) + ("f18" . f18) + ("f19" . f19) + ("f20" . f20) + ("f21" . f21) + ("f22" . f22) + ("f23" . f23) + ("f24" . f24))) +(define rev-keylist + (make-immutable-hash + (hash-map keylist (lambda (k v) (cons v k))))) + +(define-struct kmfunc (name f)) + +(define-struct key (code + + shift-on? + shift-off? + ctrl-on? + ctrl-off? + alt-on? + alt-off? + meta-on? + meta-off? + cmd-on? + cmd-off? + caps-on? + caps-off? + + score + + check-other? + fullset? + + [fname #:mutable] + + isprefix? + seqprefix)) + +(define-local-member-name + chain-handle-key-event + get-best-score + chain-handle-mouse-event + get-best-mouse-score + cycle-check) + +(defclass keymap% object% + + (super-new) + + (define functions (make-hash)) + (define keys (make-hash)) + + (define prefix #f) + (define prefixed? #f) + + (define active-mouse-function #f) + + (define grab-key-function #f) + (define grab-mouse-function #f) + (define on-break #f) + + (define chain-to null) + + (define last-time 0) + (define last-x 0) + (define last-y 0) + (define click-count 0) + (define last-code #f) + (define last-button #f) + + (define double-interval (get-double-click-threshold)) + + (def/public (reset) + (set! prefix #f) + (set! prefixed? #f) + + (for-each (lambda (c) + (send c reset)) + chain-to)) + + (def/public (break-sequence) + (set! prefix #f) + + (when on-break + (let ([f on-break]) + (set! on-break #f) + (f))) + + (for-each (lambda (c) + (send c break-sequence)) + chain-to)) + + (def/public (set-break-sequence-callback [(make-procedure 0) f]) + (let ([old on-break]) + (set! on-break f) + (when old (old)))) + + (define/private (find-key code other-code alt-code other-alt-code caps-code + shift? ctrl? alt? meta? cmd? caps? + prefix) + (for*/fold ([best-key #f] + [best-score -1]) + ([findk (in-list (list code other-code alt-code other-alt-code caps-code))] + [key (in-list (hash-ref keys findk null))]) + (if (and (or (eqv? (key-code key) code) + (and (key-check-other? key) + (or (eqv? (key-code key) other-code) + (eqv? (key-code key) alt-code) + (eqv? (key-code key) other-alt-code) + (eqv? (key-code key) caps-code)))) + (or (and (key-shift-on? key) shift?) + (and (key-shift-off? key) (not shift?)) + (and (not (key-shift-on? key)) (not (key-shift-off? key)))) + (or (and (key-ctrl-on? key) ctrl?) + (and (key-ctrl-off? key) (not ctrl?)) + (and (not (key-ctrl-on? key)) (not (key-ctrl-off? key)))) + (or (and (key-alt-on? key) alt?) + (and (key-alt-off? key) (not alt?)) + (and (not (key-alt-on? key)) (not (key-alt-off? key)))) + (or (and (key-meta-on? key) meta?) + (and (key-meta-off? key) (not meta?)) + (and (not (key-meta-on? key)) (not (key-meta-off? key)))) + (or (and (key-cmd-on? key) cmd?) + (and (key-cmd-off? key) (not cmd?)) + (and (not (key-cmd-on? key)) (not (key-cmd-off? key)))) + (or (and (key-caps-on? key) caps?) + (and (key-caps-off? key) (not caps?)) + (and (not (key-caps-on? key)) (not (key-caps-off? key)))) + (eq? (key-seqprefix key) prefix)) + (let ([score (+ (key-score key) + (if (eqv? (key-code key) code) + 0 + (if (eqv? (key-code key) other-alt-code) + -4 + -2)))]) + (if (score . > . best-score) + (values key score) + (values best-key best-score))) + (values best-key best-score)))) + + (define/private (do-map-function code shift ctrl alt meta cmd caps check-other? + fname prev isprefix? fullset?) + ;; look for existing key mapping: + (let ([key + (ormap (lambda (key) + (and (eqv? (key-code key) code) + (eq? (key-shift-on? key) (shift . > . 0)) + (eq? (key-shift-off? key) (shift . < . 0)) + (eq? (key-ctrl-on? key) (ctrl . > . 0)) + (eq? (key-ctrl-off? key) (ctrl . < . 0)) + (eq? (key-alt-on? key) (alt . > . 0)) + (eq? (key-alt-off? key) (alt . < . 0)) + (eq? (key-meta-on? key) (meta . > . 0)) + (eq? (key-meta-off? key) (meta . < . 0)) + (eq? (key-cmd-on? key) (cmd . > . 0)) + (eq? (key-cmd-off? key) (cmd . < . 0)) + (eq? (key-caps-on? key) (caps . > . 0)) + (eq? (key-caps-off? key) (caps . < . 0)) + (eq? (key-check-other? key) check-other?) + (eq? (key-seqprefix key) prev) + key)) + (hash-ref keys code null))]) + + (if key + ;; Found existing + (if (not (eq? isprefix? (key-isprefix? key))) + ;; prefix vs no-prefix mismatch: + (let ([s + (string-append + (if (meta . > . 0) "m:" "") + (if (meta . < . 0) "~m:" "") + (if (cmd . > . 0) "d:" "") + (if (cmd . < . 0) "~d:" "") + (if (alt . > . 0) "a:" "") + (if (alt . < . 0) "~a:" "") + (if (ctrl . > . 0) "c:" "") + (if (ctrl . < . 0) "~c:" "") + (if (shift . > . 0) "s:" "") + (if (shift . < . 0) "~s:" "") + (or (hash-ref rev-keylist code) + (format "~c" code)))]) + (error (method-name 'keymap% 'map-function) + "~s is already mapped as a ~aprefix key" + s (if isprefix? "non-" ""))) + (begin + (set-key-fname! key (string->immutable-string fname)) + key)) + ;; Create new + (let ([newkey (make-key + code + (shift . > . 0) (shift . < . 0) + (ctrl . > . 0) (ctrl . < . 0) + (alt . > . 0) (alt . < . 0) + (meta . > . 0) (meta . < . 0) + (cmd . > . 0) (cmd . < . 0) + (caps . > . 0) (caps . < . 0) + (+ (if (shift . > . 0) 1 0) + (if (shift . < . 0) 5 0) + (if (ctrl . > . 0) 1 0) + (if (ctrl . < . 0) 5 0) + (if (alt . > . 0) 1 0) + (if (alt . < . 0) 5 0) + (if (meta . > . 0) 1 0) + (if (meta . < . 0) 5 0) + (if (cmd . > . 0) 1 0) + (if (cmd . < . 0) 5 0) + (if (caps . > . 0) 1 0) + (if (caps . < . 0) 5 0) + (if check-other? 6 30)) + check-other? + fullset? + (string->immutable-string fname) + isprefix? + prev)]) + (hash-set! keys code (cons newkey (hash-ref keys code null))) + newkey)))) + + (define/private (get-code str) + (let ([code (hash-ref keylist (string-downcase str) #f)]) + (if code + (values code (member str '("leftbuttonseq" + "middlebuttonseq" + "rightbuttonseq"))) + (if (= 1 (string-length str)) + (values (string-ref str 0) + #f) + (values #f #f))))) + + (def/public (map-function [string? keys] + [string? fname]) + (if (string=? keys "") + (error (method-name 'keymap% 'map-function) + "bad key string: ~e" + keys) + (let loop ([seq (regexp-split #rx";" keys)] + [prev-key #f]) + (let ([str (car seq)]) + (define (bad-string msg) + (error (method-name 'keymap% 'map-function) + "bad keymap string: ~e~a: ~a" + str + (if (equal? str keys) + "" + (format " within ~e" keys)) + msg)) + (let-values ([(str default-off?) + (if (regexp-match? #rx"^:" str) + (values (substring str 1) #t) + (values str #f))]) + (let sloop ([str str] + [downs null] + [ups null] + [others? #f]) + (cond + [(regexp-match? #rx"^[?]:" str) + (sloop (substring str 2) downs ups #t)] + [(regexp-match? #rx"^~[SsCcAaMmDdLl]:" str) + (let ([c (char-downcase (string-ref str 1))]) + (if (memv c downs) + (bad-string (format "inconsistent ~a: modifier state" c)) + (sloop (substring str 3) downs (cons c ups) others?)))] + [(regexp-match? #rx"^[SsCcAaMmDdLl]:" str) + (let ([c (char-downcase (string-ref str 0))]) + (if (memv c ups) + (bad-string (format "inconsistent ~a: modifier state" c)) + (sloop (substring str 2) (cons c downs) ups others?)))] + [else + (let-values ([(code fullset?) (get-code str)]) + (if (not code) + (bad-string "unrecognized key name") + (let-values ([(downs code) + (if (and (char? code) + ((char->integer code) . > . 0) + ((char->integer code) . < . 127) + (char-alphabetic? code)) + (cond + [(memq #\s downs) + (if (or (and (eq? (system-type) 'macosx) + (not (memq #\m downs)) + (not (memq #\d downs))) + (and (eq? (system-type) 'windows) + (or (not (memq #\c downs)) + (memq #\m downs)))) + (values downs (char-upcase code)) + (values downs code))] + [(char-upper-case? code) + (values (cons #\s downs) code)] + [else + (values downs code)]) + (values downs code))]) + (let ([newkey + (let ([modval (lambda (c) + (cond + [(memq c downs) 1] + [(memq c ups) -1] + [else (if default-off? -1 0)]))]) + (do-map-function code + (modval #\s) + (modval #\c) + (modval #\a) + (modval #\m) + (modval #\d) + (modval #\l) + others? + fname + prev-key + (not (null? (cdr seq))) + fullset?))]) + (if (null? (cdr seq)) + (void) + (loop (cdr seq) newkey))))))]))))))) + + (define/private (handle-event code other-code alt-code other-alt-code caps-code + shift? ctrl? alt? meta? cmd? caps? + score) + (let-values ([(key found-score) + (find-key code other-code alt-code other-alt-code caps-code + shift? ctrl? alt? meta? cmd? caps? prefix)]) + (set! prefix #f) + + (if (and key (found-score . >= . score)) + (if (key-isprefix? key) + (begin + (set! prefix key) + (values #t #f #f)) + (values #t + (key-fname key) + (key-fullset? key))) + (values #f #f #f)))) + + (define/public (get-best-score code other-code alt-code other-alt-code caps-code + shift? ctrl? alt? meta? cmd? caps?) + (let-values ([(key score) + (find-key code other-code alt-code other-alt-code caps-code + shift? ctrl? alt? meta? cmd? caps? prefix)]) + (for/fold ([s (if key score -1)]) + ([c (in-list chain-to)]) + (max s + (send c get-best-score code other-code alt-code other-alt-code caps-code + shift? ctrl? alt? meta? cmd? caps?))))) + + (def/public (set-grab-key-function [(make-procedure 4) grab]) + (set! grab-key-function grab)) + + (def/public (remove-grab-key-function) + (set! grab-key-function #f)) + + (def/public (handle-key-event [any? obj] [key-event% event]) + (let ([code (send event get-key-code)]) + (or (eq? code 'shift) + (eq? code 'control) + (eq? code 'release) + (let ([score (get-best-score + code + (send event get-other-shift-key-code) + (send event get-other-altgr-key-code) + (send event get-other-shift-altgr-key-code) + (send event get-other-caps-key-code) + (send event get-shift-down) + (send event get-control-down) + (send event get-alt-down) + (as-meta-key (send event get-meta-down)) + (as-cmd-key (send event get-meta-down)) + (send event get-caps-down))]) + (let ([was-prefixed? prefixed?]) + + (let* ([r (chain-handle-key-event obj event #f prefixed? score)] + [r (if (and (zero? r) + was-prefixed?) + (begin + (reset) + ;; try again without prefix: + (chain-handle-key-event obj event #f #f score)) + r)]) + (when (r . >= . 0) + (reset)) + (not (zero? r)))))))) + + (define/private (other-handle-key-event obj event grab try-prefixed? score) + (for/fold ([r 0]) + ([c (in-list chain-to)] + #:when (r . <= . 0)) + (let ([r (send c chain-handle-key-event obj event grab try-prefixed? score)]) + (if (r . > . 0) + (begin + (reset) + r) + r)))) + + (define/public (chain-handle-key-event obj event grab only-prefixed? score) + ;; results: 0 = no match, 1 = match, -1 = matched prefix + (set! last-time (send event get-time-stamp)) + (set! last-button #f) + (let ([grab (or grab-key-function + grab)]) + (if (and only-prefixed? (not prefixed?)) + 0 + (let ([sub-result (other-handle-key-event obj event grab only-prefixed? score)]) + (if (sub-result . > . 0) + sub-result + (let-values ([(h? fname fullset?) + (handle-event (send event get-key-code) + (send event get-other-shift-key-code) + (send event get-other-altgr-key-code) + (send event get-other-shift-altgr-key-code) + (send event get-other-caps-key-code) + (send event get-shift-down) + (send event get-control-down) + (send event get-alt-down) + (as-meta-key (send event get-meta-down)) + (as-cmd-key (send event get-meta-down)) + (send event get-caps-down) + score)]) + (if h? + (if fname + (begin + (reset) + (if (and grab + (grab fname this obj event)) + 1 + (if (call-function fname obj event) + 1 + 0))) + (if prefix + (begin + (set! prefixed? #t) + -1) + ;; shouldn't get here + 0)) + (let ([result + (if (sub-result . < . 0) + (begin + (set! prefixed? #t) + -1) + 0)]) + (if (and (zero? result) + grab-key-function + (grab-key-function #f this obj event)) + 1 + result))))))))) + + (def/public (set-grab-mouse-function [(make-procedure 4) grab]) + (set! grab-mouse-function grab)) + + (def/public (remove-grab-mouse-function) + (set! grab-mouse-function #f)) + + (define/private (adjust-button-code code click-count) + (case click-count + [(0) code] + [(1) (case code + [(mouse-right) 'mouse-right-double] + [(mouse-left) 'mouse-left-double] + [(mouse-middle) 'mouse-middle-double])] + [else (case code + [(mouse-right) 'mouse-right-triple] + [(mouse-left) 'mouse-left-triple] + [(mouse-middle) 'mouse-middle-triple])])) + + (def/public (handle-mouse-event [any? obj][mouse-event% event]) + (let ([score (get-best-mouse-score event)]) + (not (zero? (chain-handle-mouse-event obj event #f 0 score))))) + + (define/public (get-best-mouse-score event) + (cond + [(not (send event button-down?)) + (if active-mouse-function + 100 + (or (ormap (lambda (c) + (and (not (zero? (send c get-best-mouse-score event))) + 100)) + chain-to) + -1))] + [else + (let ([code (cond + [(send event get-right-down) 'mouse-right] + [(send event get-left-down) 'mouse-left] + [(send event get-middle-down) 'mouse-middle] + [else #f])]) + (if (not code) + -1 + (let ([code + (if (and (eq? code last-button) + (= (send event get-x) last-x) + (= (send event get-y) last-y) + ((abs (- (send event get-time-stamp) last-time)) . < . double-interval)) + (adjust-button-code code click-count) + code)]) + (get-best-score code #f #f #f #f + (send event get-shift-down) + (send event get-control-down) + (send event get-alt-down) + (as-meta-key (send event get-meta-down)) + (as-cmd-key (send event get-meta-down)) + (send event get-caps-down)))))])) + + (define/private (other-handle-mouse-event obj event grab try-state score) + (for/fold ([result 0]) + ([c (in-list chain-to)] + #:when (result . <= . 0)) + (let ([r (send c chain-handle-mouse-event obj event grab try-state score)]) + (cond + [(r . > . 0) + (reset) + r] + [(zero? r) result] + [else r])))) + + (define/public (chain-handle-mouse-event obj event grab try-state score) + (let ([grab (or grab-mouse-function grab)]) + (define (step1) + (cond + [(and (not prefix) + (try-state . >= . 0)) + (let ([r (other-handle-mouse-event obj event grab 1 score)]) + (cond + [(r . > . 0) r] + [(try-state . > . 0) r] + [else (step2 -1)]))] + [(and prefix (try-state . < . 0)) + (other-handle-mouse-event obj event grab -1 score)] + [else (step2 try-state)])) + (define (step2 try-state) + (cond + [(not (send event button-down?)) + (when (and (not (send event dragging?)) + (not (send event button-up?))) + ;; we must have missed the button-up + (set! active-mouse-function #f)) + (if (not active-mouse-function) + (other-handle-mouse-event obj event grab -1 score) + (let ([v (if (and grab + (grab active-mouse-function this obj event)) + 1 + (if (call-function active-mouse-function obj event) + 1 + 0))]) + (when (send event button-up?) + (set! active-mouse-function #f)) + v))] + [else + (let ([code (cond + [(send event get-right-down) 'mouse-right] + [(send event get-left-down) 'mouse-left] + [(send event get-middle-down) 'mouse-middle] + [else #f])]) + (if (not code) + 0 ;; FIXME: should we call grab here? + (let ([orig-code code] + [code + (if (and (eq? code last-button) + (= (send event get-x) last-x) + (= (send event get-y) last-y)) + (if ((abs (- (send event get-time-stamp) last-time)) . < . double-interval) + (begin0 + (adjust-button-code code click-count) + (set! click-count (add1 click-count))) + (begin + (set! click-count 1) + code)) + (begin + (set! last-button code) + (set! click-count 1) + code))]) + (set! last-time (send event get-time-stamp)) + (set! last-x (send event get-x)) + (set! last-y (send event get-y)) + + (let loop ([code code]) + (let-values ([(h? fname fullset?) (handle-event code + #f #f #f #f + (send event get-shift-down) + (send event get-control-down) + (send event get-alt-down) + (as-meta-key (send event get-meta-down)) + (as-cmd-key (send event get-meta-down)) + (send event get-caps-down) + score)]) + (cond + [(and h? fname) + (reset) + (when fullset? + (set! active-mouse-function fname)) + (cond + [(and grab (grab fname this obj event)) 1] + [(call-function fname obj event) 1] + [else 0])] + [h? + (let ([r (other-handle-mouse-event obj event grab try-state score)]) + (if (r . > . 0) + r + -1))] + [else + (set! last-code code) + (if (not (eqv? last-code orig-code)) + (loop orig-code) + (let ([result (other-handle-mouse-event obj event grab try-state score)]) + (if (and (zero? result) + grab-mouse-function + (grab-mouse-function #f this obj event)) + 1 + result)))]))))))])) + (step1))) + + (def/public (add-function [string? name] [(make-procedure 2) f]) + (hash-set! functions + (string->immutable-string name) + f)) + + (def/public (call-function [string? name] [any? obj] [event% event] [any? [try-chained? #f]]) + (let ([f (hash-ref functions name #f)]) + (cond + [f + (f obj event) + #t] + [try-chained? + (ormap (lambda (c) + (send c call-function name obj event #t)) + chain-to)] + [else + (error 'keymap "no function ~e" name)]))) + + (def/public (get-double-click-interval) + double-interval) + + (def/public (set-double-click-interval [exact-positive-integer? d]) + (set! double-interval d)) + + (define/public (cycle-check km) + (ormap (lambda (c) + (or (eq? km c) + (send c cycle-check km))) + chain-to)) + + (def/public (chain-to-keymap [keymap% km] [any? prefix?]) + (unless (or (eq? km this) + (cycle-check km) + (send km cycle-check this)) + (set! chain-to (if prefix? + (cons km chain-to) + (append chain-to (list km)))))) + + (def/public (remove-chained-keymap [keymap% km]) + (set! chain-to (remq km chain-to)))) diff --git a/collects/mred/private/wxme/mline.ss b/collects/mred/private/wxme/mline.ss new file mode 100644 index 00000000..1af464b9 --- /dev/null +++ b/collects/mred/private/wxme/mline.ss @@ -0,0 +1,1192 @@ +#lang scheme/base +(require scheme/class + "../syntax.ss" + "const.ss" + "snip.ss" + "snip-flags.ss" + "private.ss") + +(provide create-mline + (struct-out mline) + (struct-out paragraph) + mline-next + mline-prev + (prefix-out + mline- + (for-meta + 0 + NIL + clone-paragraph + get-line-max-width + adjust-offsets + deadjust-offsets + move-parent! + rotate-left + rotate-right + insert + delete + find-line + find-position + find-scroll + find-location + find-paragraph + get-line + get-position + get-scroll + get-location + get-paragraph + get-paragraph-style + set-length + set-scroll-length + set-height + calc-line-length + set-starts-paragraph + starts-paragraph + adjust-max-width + set-width + scroll-offset + find-extra-scroll + mark-recalculate + adjust-need-calc + mark-check-flow + adjust-need-flow + update-flow + update-graphics + get-root + check-consistent + first + last + get-left-location + get-right-location + number))) + +(define RED #x1) +(define BLACK #x2) +(define MAX-W-HERE #x4) +(define MAX-W-LEFT #x8) +(define MAX-W-RIGHT #x10) +(define CALC-HERE #x20) +(define CALC-LEFT #x40) +(define CALC-RIGHT #x80) +(define FLOW-HERE #x100) +(define FLOW-LEFT #x200) +(define FLOW-RIGHT #x400) +(define STARTS-PARA #x800) + +(define MAX-W-MASK (bitwise-ior MAX-W-HERE MAX-W-LEFT MAX-W-RIGHT)) +(define COLOR-MASK (bitwise-ior RED BLACK)) +(define CALC-MASK (bitwise-ior CALC-HERE CALC-LEFT CALC-RIGHT)) +(define FLOW-MASK (bitwise-ior FLOW-HERE FLOW-LEFT FLOW-RIGHT)) + +(define-struct mline (prev next parent left right + + flags paragraph + + ;; relative values: + line pos scroll parno y + + max-width + + snip last-snip scroll-snip + + len numscrolls + last-h last-w ;; height/width of last snip in line + h w ;; height/width of line + bottombase topbase ;; bottom baseline, top baseline (relative) + ) + #:mutable #:transparent) + +(define NIL #f) + +(define (create-mline) + (make-mline #f #f NIL NIL NIL + (bitwise-ior BLACK MAX-W-HERE CALC-HERE) #f + 0 0 0 0 0.0 + 0.0 + #f #f #f + 0 1 + 0.0 0.0 + 0.0 0.0 + 0.0 0.0)) + +(set! NIL (create-mline)) +(set-mline-parent! NIL NIL) +(set-mline-left! NIL NIL) +(set-mline-right! NIL NIL) + +(define (mline-destroy! m) + ;; Doesn't need to to anything, but this may be helpful for debugging + (begin + (set-mline-prev! m 'BAD) + (set-mline-parent! m 'BAD) + (set-mline-left! m 'BAD) + (set-mline-right! m 'BAD) + (set-mline-flags! m 'BAD) + (set-mline-paragraph! m 'BAD) + (set-mline-line! m 'BAD) + (set-mline-pos! m 'BAD) + (set-mline-scroll! m 'BAD) + (set-mline-parno! m 'BAD) + (set-mline-y! m 'BAD) + (set-mline-max-width! m 'BAD) + (set-mline-snip! m 'BAD) + (set-mline-last-snip! m 'BAD) + (set-mline-scroll-snip! m 'BAD) + (set-mline-len! m 'BAD) + (set-mline-numscrolls! m 'BAD) + (set-mline-last-h! m 'BAD) + (set-mline-last-w! m 'BAD) + (set-mline-h! m 'BAD) + (set-mline-w! m 'BAD) + (set-mline-bottombase! m 'BAD) + (set-mline-topbase! m 'BAD)) + (void)) + +(define (set-red! mline) + (set-mline-flags! mline (bitwise-ior RED (bitwise-and (mline-flags mline) + (bitwise-not COLOR-MASK))))) +(define (set-black! mline) + (set-mline-flags! mline (bitwise-ior BLACK (bitwise-and (mline-flags mline) + (bitwise-not COLOR-MASK))))) + +(define (bit-overlap? a b) + (not (zero? (bitwise-and a b)))) + +(define (red? mline) + (bit-overlap? (mline-flags mline) RED)) +(define (black? mline) + (bit-overlap? (mline-flags mline) BLACK)) + +(define (starts-paragraph mline) + (if (bit-overlap? STARTS-PARA (mline-flags mline)) + 1 + 0)) + +;; ---------------------------------------- + +(define-struct paragraph (left-margin-first + left-margin + right-margin + alignment) + #:mutable) + +(define plain-paragraph (make-paragraph 0.0 0.0 0.0 'left)) + +(define (clone-paragraph p) + (make-paragraph (paragraph-left-margin-first p) + (paragraph-left-margin p) + (paragraph-right-margin p) + (paragraph-alignment p))) + +(define (get-line-max-width p max-width first?) + (if (max-width . <= . 0) + max-width + (max 1 + (- max-width + (if first? + (paragraph-left-margin-first p) + (paragraph-left-margin p)) + (paragraph-right-margin p))))) + +;; ---------------------------------------- + +(define (adjust-offsets mline newchild) + (unless (eq? newchild NIL) + ;; Adjust relative values: + (set-mline-line! newchild (- (mline-line newchild) (+ (mline-line mline) 1))) + (set-mline-pos! newchild (- (mline-pos newchild) (+ (mline-pos mline) (mline-len mline)))) + (set-mline-scroll! newchild (- (mline-scroll newchild) (+ (mline-scroll mline) (mline-numscrolls mline)))) + (set-mline-y! newchild (- (mline-y newchild) (+ (mline-y mline) (mline-h mline)))) + (set-mline-parno! newchild (- (mline-parno newchild) (+ (mline-parno mline) (starts-paragraph mline)))))) + +(define (deadjust-offsets mline oldchild) + (unless (eq? oldchild NIL) + ;; Adjust relative values: + (set-mline-line! oldchild (+ (mline-line oldchild) (+ (mline-line mline) 1))) + (set-mline-pos! oldchild (+ (mline-pos oldchild) (+ (mline-pos mline) (mline-len mline)))) + (set-mline-scroll! oldchild (+ (mline-scroll oldchild) (+ (mline-scroll mline) (mline-numscrolls mline)))) + (set-mline-y! oldchild (+ (mline-y oldchild) (+ (mline-y mline) (mline-h mline)))) + (set-mline-parno! oldchild (+ (mline-parno oldchild) (+ (mline-parno mline) (starts-paragraph mline)))))) + +(define (move-parent! v x root-box) + ;; replace v with x + (let ([parent (mline-parent v)]) + (set-mline-parent! x parent) ; x can be NIL! + (cond + [(eq? parent NIL) + (set-box! root-box x)] + [(eq? v (mline-left parent)) + (set-mline-left! parent x)] + [else + (set-mline-right! parent x)]))) + +(define (rotate-left mline root-box) + (let ([oldright (mline-right mline)]) + (deadjust-offsets mline oldright) + + (let ([right (mline-left oldright)]) + (set-mline-right! mline right) + (unless (eq? right NIL) + (set-mline-parent! right mline))) + + (move-parent! mline oldright root-box) + + (set-mline-left! oldright mline) + (set-mline-parent! mline oldright) + + (adjust-max-width mline) + (adjust-need-calc mline) + (adjust-need-flow mline) + (adjust-max-width oldright) + (adjust-need-calc oldright) + (adjust-need-flow oldright))) + +(define (rotate-right mline root-box) + (let ([oldleft (mline-left mline)]) + (adjust-offsets oldleft mline) + + (let ([left (mline-right oldleft)]) + (set-mline-left! mline left) + (unless (eq? left NIL) + (set-mline-parent! left mline))) + + (move-parent! mline oldleft root-box) + + (set-mline-right! oldleft mline) + (set-mline-parent! mline oldleft) + + (adjust-max-width mline) + (adjust-need-calc mline) + (adjust-need-flow mline) + (adjust-max-width oldleft) + (adjust-need-calc oldleft) + (adjust-need-flow oldleft))) + +(define (insert mline root-box before?) + (let ([newline (create-mline)]) + (if (eq? (unbox root-box) NIL) + (begin + (set-box! root-box newline) + newline) + (begin + (set-red! newline) + + (if before? + (let ([prev (mline-prev mline)]) + (set-mline-prev! newline prev) + (when prev + (set-mline-next! prev newline)) + (set-mline-next! newline mline) + (set-mline-prev! mline newline)) + (let ([next (mline-next mline)]) + (set-mline-prev! newline mline) + (set-mline-next! newline next) + (when next + (set-mline-prev! next newline)) + (set-mline-next! mline newline))) + + (let ([node + (if before? + (let ([left (mline-left mline)]) + (if (eq? left NIL) + (begin + (set-mline-left! mline newline) + mline) + (let loop ([node left]) + (let ([right (mline-right node)]) + (if (not (eq? right NIL)) + (loop right) + (begin + (set-mline-right! node newline) + node)))))) + (let ([right (mline-right mline)]) + (if (eq? right NIL) + (begin + (set-mline-right! mline newline) + mline) + (let loop ([node right]) + (let ([left (mline-left node)]) + (if (not (eq? left NIL)) + (loop left) + (begin + (set-mline-left! node newline) + node)))))))]) + (set-mline-parent! newline node) + (adjust-need-calc node #t)) + + (let loop ([node newline]) + (let ([parent (mline-parent node)]) + (unless (eq? parent NIL) + (when (eq? node (mline-left parent)) + (deadjust-offsets newline parent)) + (loop parent)))) + + (let loop ([node newline]) + (when (and (not (eq? node (unbox root-box))) + (red? (mline-parent node))) + (let ([parent (mline-parent node)]) + (if (eq? parent (mline-left (mline-parent parent))) + (let ([v (mline-right (mline-parent parent))]) + (if (red? v) + (begin + (set-black! parent) + (set-black! v) + (let ([node (mline-parent parent)]) + (set-red! node) + (loop node))) + (let* ([node (if (eq? node (mline-right parent)) + (begin + (rotate-left parent root-box) + parent) + node)] + [parent (mline-parent node)]) + (set-black! parent) + (let ([node (mline-parent parent)]) + (set-red! node) + (rotate-right node root-box) + (loop node))))) + (let ([v (mline-left (mline-parent parent))]) + (if (red? v) + (begin + (set-black! parent) + (set-black! v) + (let ([node (mline-parent parent)]) + (set-red! node) + (loop node))) + (let* ([node (if (eq? node (mline-left parent)) + (begin + (rotate-right parent root-box) + parent) + node)] + [parent (mline-parent node)]) + (set-black! parent) + (let ([node (mline-parent parent)]) + (set-red! node) + (rotate-left node root-box) + (loop node))))))))) + + (set-black! (unbox root-box)) + + newline)))) + +(define (delete mline root-box) + + ;; adjust ancestor offsets + (let ([len (mline-len mline)] + [numscrolls (mline-numscrolls mline)] + [h (mline-h mline)]) + (let loop ([v mline]) + (let ([parent (mline-parent v)]) + (unless (eq? parent NIL) + (if (eq? v (mline-right parent)) + (loop parent) + (let ([v parent]) + (set-mline-line! v (- (mline-line v) 1)) + (set-mline-pos! v (- (mline-pos v) len)) + (set-mline-scroll! v (- (mline-scroll v) numscrolls)) + (set-mline-y! v (- (mline-y v) h)) + (set-mline-parno! v (- (mline-parno v) (starts-paragraph mline))) + (loop v))))))) + + (let ([v (if (or (eq? (mline-left mline) NIL) + (eq? (mline-right mline) NIL)) + mline + (let ([v (mline-next mline)]) + (let loop ([x v]) + (unless (eq? mline (mline-parent x)) + (let ([parent (mline-parent x)]) + (if (eq? x (mline-right parent)) + (loop parent) + (let ([x parent]) + (set-mline-line! x (- (mline-line x) 1)) + (set-mline-pos! x (- (mline-pos x) (mline-len v))) + (set-mline-scroll! x (- (mline-scroll x) (mline-numscrolls v))) + (set-mline-y! x (- (mline-y x) (mline-h v))) + (set-mline-parno! x (- (mline-parno x) (starts-paragraph v))) + (loop x)))))) + v))]) + + (let ([x (if (eq? (mline-left v) NIL) + (mline-right v) + (mline-left v))]) + (move-parent! v x root-box) + + (let ([was-black? (black? v)]) + + (if (not (eq? v mline)) + (let ([oldparent (mline-parent v)]) + (if (black? mline) + (set-black! v) + (set-red! v)) + + (let ([left (mline-left mline)]) + (set-mline-left! v left) + (unless (eq? left NIL) + (set-mline-parent! left v))) + (let ([right (mline-right mline)]) + (set-mline-right! v right) + (unless (eq? right NIL) + (set-mline-parent! right v))) + (move-parent! mline v root-box) + (let ([prev (mline-prev mline)]) + (set-mline-prev! v prev) + (when prev + (set-mline-next! prev v))) + + (set-mline-line! v (mline-line mline)) + (set-mline-pos! v (mline-pos mline)) + (set-mline-scroll! v (mline-scroll mline)) + (set-mline-y! v (mline-y mline)) + (set-mline-parno! v (mline-parno mline)) + + (adjust-max-width oldparent #t) + (adjust-need-calc oldparent #t) + (adjust-need-flow oldparent #t) + + (adjust-max-width v #t) + (adjust-need-calc v #t) + (adjust-need-flow v #t) + + (when (eq? (mline-parent x) mline) + (set-mline-parent! x v))) + (begin + (let ([prev (mline-prev mline)] + [next (mline-next mline)]) + (when prev + (set-mline-next! prev next)) + (when next + (set-mline-prev! next prev))))) + + (when was-black? + ;; fixup + (let loop ([x x]) + (if (and (not (eq? x (unbox root-box))) + (black? x)) + (let ([parent (mline-parent x)]) + (if (eq? x (mline-left parent)) + (let* ([z (mline-right parent)] + [z (if (red? z) + (begin + (set-black! z) + (set-red! parent) + (rotate-left parent root-box) + (mline-right (mline-parent x))) + z)] + [x (if (and (black? (mline-left z)) + (black? (mline-right z))) + (begin + (set-red! z) + (mline-parent x)) + (let ([z (if (black? (mline-right z)) + (begin + (set-black! (mline-left z)) + (set-red! z) + (rotate-right z root-box) + (mline-right (mline-parent x))) + z)]) + (if (red? (mline-parent x)) + (set-red! z) + (set-black! z)) + (set-black! (mline-parent x)) + (set-black! (mline-right z)) + (rotate-left (mline-parent x) root-box) + (unbox root-box)))]) + (loop x)) + (let* ([z (mline-left parent)] + [z (if (red? z) + (begin + (set-black! z) + (set-red! parent) + (rotate-right parent root-box) + (mline-left (mline-parent x))) + z)] + [x (if (and (black? (mline-right z)) + (black? (mline-left z))) + (begin + (set-red! z) + (mline-parent x)) + (let ([z (if (black? (mline-left z)) + (begin + (set-black! (mline-right z)) + (set-red! z) + (rotate-left z root-box) + (mline-left (mline-parent x))) + z)]) + (if (red? (mline-parent x)) + (set-red! z) + (set-black! z)) + (set-black! (mline-parent x)) + (set-black! (mline-left z)) + (rotate-right (mline-parent x) root-box) + (unbox root-box)))]) + (loop x)))) + (set-black! x))))))) + + ;; In case we set the parent of NIL: + (set-mline-parent! NIL NIL) + + (mline-destroy! mline)) + +;; ---------------------------------------- + +(define (search mline v v-sel size-sel) + (let loop ([v v][node mline][prev #f]) + (if (not (eq? node NIL)) + (let ([v2 (v-sel node)] + [size (size-sel node)]) + (cond + [(v . < . v2) + (loop v (mline-left node) node)] + [(v . >= . (+ v2 size)) + (loop (- v (+ v2 size)) + (mline-right node) node)] + [else node])) + prev))) + + (define (find-line mline line) + (search mline line mline-line (lambda (mline) 1))) + +(define (find-position mline pos) + (search mline pos mline-pos mline-len)) + +(define (find-scroll mline scroll) + (search mline scroll mline-scroll mline-numscrolls)) + +(define (find-location mline y) + (search mline y mline-y mline-h)) + +(define (find-paragraph mline parno) + (search mline parno mline-parno starts-paragraph)) + +;; ---------------------------------------- + +(define (sum mline v-sel size-sel) + (let loop ([node mline][v (v-sel mline)]) + (let ([parent (mline-parent node)]) + (if (not (eq? parent NIL)) + (if (eq? node (mline-left parent)) + (loop parent v) + (loop parent (+ v (v-sel parent) (size-sel parent)))) + v)))) + +(define (get-line mline) + (sum mline mline-line (lambda (mline) 1))) + +(define (get-position mline) + (sum mline mline-pos mline-len)) + +(define (get-scroll mline) + (sum mline mline-scroll mline-numscrolls)) + +(define (get-location mline) + (sum mline mline-y mline-h)) + +(define (get-paragraph mline) + (+ (sum mline mline-parno starts-paragraph) + (sub1 (starts-paragraph mline)))) + +(define (get-paragraph-style mline [first-box #f]) + (if (bit-overlap? (mline-flags mline) STARTS-PARA) + (begin + (when first-box (set-box! first-box #t)) + (mline-paragraph mline)) + (begin + (when first-box (set-box! first-box #f)) + (let ([root (get-root mline)] + [p (get-paragraph mline)]) + (let ([pstart (find-paragraph root p)]) + (mline-paragraph pstart)))))) + +;; ---------------------------------------- + +(define (adjust mline new-val val-sel val-mut! sel mut!) + (let ([delta (- new-val (val-sel mline))]) + (val-mut! mline new-val) + (let loop ([node mline]) + (let ([parent (mline-parent node)]) + (unless (eq? parent NIL) + (if (eq? node (mline-left parent)) + (begin + (mut! parent (+ delta (sel parent))) + (loop parent)) + (loop parent))))))) + +(define (set-length mline len) + (adjust mline + len mline-len set-mline-len! + mline-pos set-mline-pos!)) + +(define (set-scroll-length mline numscrolls) + (adjust mline + numscrolls mline-numscrolls set-mline-numscrolls! + mline-scroll set-mline-scroll!)) + +(define (set-height mline h) + (adjust mline + h mline-h set-mline-h! + mline-y set-mline-y!)) + +(define (calc-line-length mline) + (let ([l + (let ([nexts (snip->next (mline-last-snip mline))]) + (let loop ([asnip (mline-snip mline)][l 0]) + (if (eq? asnip nexts) + l + (let ([l (+ l (snip->count asnip))]) + (when (has-flag? (snip->count asnip) WIDTH-DEPENDS-ON-X) + (send asnip size-cache-invalid)) + (loop (snip->next asnip) l)))))]) + + (when (not (= l (mline-len mline))) + (set-length mline l))) + + (let ([next (mline-next mline)]) + (cond + [(and next + (has-flag? (snip->flags (mline-last-snip mline)) + HARD-NEWLINE)) + (when (zero? (starts-paragraph next)) + (set-starts-paragraph next #t))] + [next + (when (starts-paragraph next) + (set-starts-paragraph next #f))])) + + (let ([prev (mline-prev mline)]) + (cond + [(or (not prev) + (has-flag? (snip->flags (mline-last-snip prev)) + HARD-NEWLINE)) + (when (zero? (starts-paragraph mline)) + (set-starts-paragraph mline #t))] + [(positive? (starts-paragraph mline)) + (set-starts-paragraph mline #f)]))) + +(define (set-starts-paragraph mline starts?) + (unless (= (if starts? 1 0) (starts-paragraph mline)) + (if starts? + (begin + (set-mline-flags! mline + (bitwise-ior (mline-flags mline) STARTS-PARA)) + (unless (mline-paragraph mline) + (set-mline-paragraph! mline plain-paragraph))) + (begin + (set-mline-flags! mline (- (mline-flags mline) STARTS-PARA)) + (set-mline-paragraph! mline #f))) + + (let loop ([node mline]) + (let ([parent (mline-parent node)]) + (unless (eq? parent NIL) + (when (eq? node (mline-left parent)) + (set-mline-parno! parent (+ (mline-parno parent) + (if starts? 1 -1)))) + (loop parent)))))) + +;; ------------------------------------------------------------ + +(define (adjust-max-width mline [recur? #f]) + (when (not (eq? mline NIL)) + (let loop ([node mline]) + (let ([old (bitwise-and (mline-flags node) MAX-W-MASK)]) + (let ([which + (cond + [(and (not (eq? (mline-right node) NIL)) + ((mline-max-width (mline-right node)) . > . (mline-w node)) + (or (eq? (mline-left node) NIL) + ((mline-max-width (mline-right node)) . > . (mline-max-width (mline-left node))))) + (set-mline-max-width! node (mline-max-width (mline-right node))) + MAX-W-RIGHT] + [(and (not (eq? (mline-left node) NIL)) + ((mline-max-width (mline-left node)) . > . (mline-w node))) + (set-mline-max-width! node (mline-max-width (mline-left node))) + MAX-W-LEFT] + [else + (set-mline-max-width! node (mline-w node)) + MAX-W-HERE])]) + (unless (= old which) + (set-mline-flags! node + (bitwise-ior + (bitwise-and (mline-flags node) + (bitwise-not MAX-W-MASK)) + which))) + (when recur? + (let ([parent (mline-parent node)]) + (unless (eq? parent NIL) + (loop parent))))))))) + +(define (set-width mline w) + (set-mline-w! mline w) + (adjust-max-width mline #t)) + +;; ---------------------------------------- + +(define (scroll-offset mline p) + (let ([scroll-snip (mline-scroll-snip mline)]) + (cond + [(not scroll-snip) + 0.0] + [(p . >= . (mline-numscrolls mline)) + (mline-h mline)] + [else + (send scroll-snip get-scroll-step-offset p)]))) + +(define (find-extra-scroll mline y) + (cond + [(y . >= . (mline-h mline)) + (mline-numscrolls mline)] + [(y . <= . 0) + 0] + [else + (let ([scroll-snip (mline-scroll-snip mline)]) + (if (not scroll-snip) + 0 + (send scroll-snip find-scroll-step y)))])) + +;; ---------------------------------------- + +(define (mark-need mline HERE recur) + (unless (bit-overlap? (mline-flags mline) HERE) + (set-mline-flags! mline (bitwise-ior (mline-flags mline) HERE)) + (let ([parent (mline-parent mline)]) + (unless (eq? parent NIL) + (recur parent #t))))) + +(define (adjust-need-flag mline MASK HERE RIGHT LEFT recur?) + (let loop ([node mline]) + (let ([old (bitwise-and (mline-flags node) MASK)]) + (let* ([which (bitwise-and old HERE)] + [which (if (and (not (eq? (mline-right node) NIL)) + (bit-overlap? (mline-flags (mline-right node)) MASK)) + (bitwise-ior which RIGHT) + which)] + [which (if (and (not (eq? (mline-left node) NIL)) + (bit-overlap? (mline-flags (mline-left node)) MASK)) + (bitwise-ior which LEFT) + which)]) + (when (not (= old which)) + (set-mline-flags! node + (bitwise-ior + (bitwise-and (mline-flags node) + (bitwise-not MASK)) + which)) + (when recur? + (let ([parent (mline-parent node)]) + (unless (eq? parent NIL) + (loop parent))))))))) + +(define (mark-recalculate mline) + (mark-need mline CALC-HERE adjust-need-calc)) + +(define (adjust-need-calc mline [recur? #f]) + (adjust-need-flag mline CALC-MASK CALC-HERE CALC-RIGHT CALC-LEFT recur?)) + +(define (mark-check-flow mline) + (mark-need mline FLOW-HERE adjust-need-flow)) + +(define (adjust-need-flow mline [recur? #f]) + (adjust-need-flag mline FLOW-MASK FLOW-HERE FLOW-RIGHT FLOW-LEFT recur?)) + +;; ---------------------------------------- + +(define (get-root mline) + (let ([parent (mline-parent mline)]) + (if (not (eq? parent NIL)) + (get-root parent) + mline))) + +;; ---------------------------------------- + +(define (check-consistent root) + (unless (black? root) + (error "root is not black")) + (let ([l1 (let loop ([mline root]) + (if (eq? mline NIL) + null + (begin + (when (red? mline) + (unless (black? (mline-left mline)) + (error "red left child is not black")) + (unless (black? (mline-right mline)) + (error "red right child is not black"))) + (unless (or (eq? (mline-left mline) NIL) + (eq? (mline-parent (mline-left mline)) mline)) + (error "left and up doesn't work")) + (unless (or (eq? (mline-right mline) NIL) + (eq? (mline-parent (mline-right mline)) mline)) + (error "right and up doesn't work")) + (append + (loop (mline-left mline)) + (list mline) + (loop (mline-right mline))))))] + [l2 (let loop ([mline root]) + (let ([prev (mline-prev mline)]) + (if prev + (begin + (unless (eq? (mline-next prev) mline) + (error "back doesn't go forward")) + (loop prev)) + (let loop ([mline mline]) + (if mline + (cons mline (loop (mline-next mline))) + null)))))]) + (unless (= (length l1) (length l2)) + (error 'check-consistent "different lengths: ~s ~s" (length l1) (length l2))) + (unless (andmap eq? l1 l2) + (error "different elems"))) + (let loop ([mline root]) + (if (eq? mline NIL) + 0 + (let ([left (loop (mline-left mline))] + [right (loop (mline-right mline))]) + (unless (= left right) + (error "different black counts:" left right)) + (if (black? mline) + (+ 1 left) + left)))) + (unless (eq? (mline-parent root) NIL) + (error "root has non-NIL parent")) + (unless (black? NIL) + (error "NIL is non-black")) + (unless (eq? NIL (mline-parent NIL)) + (error "NIL parent changed")) + (unless (eq? NIL (mline-left NIL)) + (error "NIL left changed")) + (unless (eq? NIL (mline-left NIL)) + (error "NIL right changed"))) + +#| + +Debugging tools: + +(define (draw p) + (for-each (lambda (l) + (display l) + (newline)) + (paint p))) + +(define (paint p) + (if (eq? p NIL) + '("*") + (let ([l (paint (mline-left p))] + [r (paint (mline-right p))]) + (let ([ll (string-length (car l))] + [rl (string-length (car r))] + [s ((if (red? p) string-upcase values) (format "~s" (mline-sym p)))]) + (cons + (string-append (make-string ll #\space) + s + (make-string rl #\space)) + (let loop ([l l][r r]) + (cond + [(null? l) (if (null? r) + null + (map (lambda (r) + (string-append + (make-string (+ ll (string-length s)) #\space) + r)) + r))] + [(null? r) (map (lambda (l) + (string-append + l + (make-string (+ rl (string-length s)) #\space))) + l)] + [else (cons (string-append (car l) + (make-string (string-length s) #\space) + (car r)) + (loop (cdr l) (cdr r)))]))))))) + +(define (find? root m) + (or (eq? root m) + (if (eq? root NIL) + #f + (or (find? (mline-left root) m) + (find? (mline-right root) m))))) + +|# + +;; ------------------------------------------------------------ + +(define (update-flow mline root-box media max-width dc) + (define (flow-left) + (if (bit-overlap? (mline-flags mline) FLOW-LEFT) + (if (and (not (eq? (mline-left mline) NIL)) + (update-flow (mline-left mline) root-box media max-width dc)) + #t + (begin + (set-mline-flags! mline (- (mline-flags mline) FLOW-LEFT)) + (flow-here))) + (flow-here))) + (define (flow-here) + (if (bit-overlap? (mline-flags mline) FLOW-HERE) + (begin + (set-mline-flags! mline (- (mline-flags mline) FLOW-HERE)) + (let* ([first-line (box #f)] + [para (get-paragraph-style mline first-line)] + [line-max-width (get-line-max-width para max-width (unbox first-line))]) + (if (send media check-flow line-max-width dc (get-location mline) (get-position mline) (mline-snip mline)) + (do-flow) + (flow-right)))) + (flow-right))) + (define (flow-right) + (if (bit-overlap? (mline-flags mline) FLOW-RIGHT) + (if (and (not (eq? (mline-right mline) NIL)) + (update-flow (mline-right mline) root-box media max-width dc)) + #t + (begin + (set-mline-flags! mline (- (mline-flags mline) FLOW-RIGHT)) + #f)) + #f)) + (define (do-flow) + (let loop ([asnip (mline-snip mline)]) + (if (eq? asnip (mline-last-snip mline)) + (begin + (do-extend-line asnip) + #t) + (if (has-flag? (snip->flags asnip) NEWLINE) + (begin + (do-new-line asnip) + #t) + (begin + (set-snip-line! asnip mline) + (loop (snip->next asnip))))))) + (define (do-new-line asnip) + ;; items pushed to next line or new line was inserted + (let ([next (mline-next mline)]) + (let ([nextsnip (if next + (let loop ([nextsnip (snip->next asnip)]) + (if (and nextsnip + (not (eq? nextsnip (mline-last-snip next))) + (not (has-flag? (snip->flags nextsnip) NEWLINE))) + (loop (snip->next nextsnip)) + nextsnip)) + #f)]) + (if (or (not next) + (not (eq? nextsnip (mline-last-snip next)))) + ;; it was a new line + (let ([newline (insert mline root-box #f)]) + (set-mline-snip! newline (snip->next asnip)) + (set-mline-last-snip! newline (mline-last-snip mline)) + (set-mline-last-snip! mline asnip) + + (snips-to-line! newline)) + ;; just pushed to next line + (begin + (set-mline-last-snip! mline asnip) + (set-snip-line! asnip mline) + + (set-mline-snip! next (snip->next asnip)) + + (snips-to-line! next))) + + (calc-line-length mline) + (mark-recalculate mline)))) + (define (snips-to-line! next) + (let ([nextsnip (snip->next (mline-last-snip next))]) + (let loop ([asnip (mline-snip next)]) + (unless (eq? asnip nextsnip) + (set-snip-line! asnip next) + (loop (snip->next asnip))))) + (mark-check-flow next) + (mark-recalculate next) + (calc-line-length next)) + (define (maybe-delete-line! asnip mline) + (if (and (mline-next mline) + (eq? asnip (mline-last-snip (mline-next mline)))) + ;; a line was deleted + (begin (delete (mline-next mline) root-box) #t) + #f)) + (define (do-extend-line asnip) + ;; this line was extended + (let ([asnip + (if asnip + (let loop ([asnip asnip]) + (if (and (snip->next asnip) + (not (has-flag? (snip->flags asnip) NEWLINE))) + (begin + (set-snip-line! asnip mline) + (maybe-delete-line! asnip mline) + (loop (snip->next asnip))) + (begin + (maybe-delete-line! asnip mline) + (set-mline-last-snip! mline asnip) + asnip))) + (begin + (set-mline-last-snip! mline (send media get-s-last-snip)) + (let loop () + (let ([next (mline-next mline)]) + (when next + (delete next root-box) + (loop)))) + #f))]) + + (set-snip-line! (mline-last-snip mline) mline) + + (when (mline-next mline) + (let ([asnip (snip->next asnip)] + [next (mline-next mline)]) + (when (or (not (eq? (mline-snip next) asnip)) + (not (has-flag? (snip->flags (mline-last-snip next)) NEWLINE))) + ;; Effect can propogate to more lines, merging the + ;; next several. (Handle prefixing the remains of the source of + ;; the extension to this line onto the next line. Implemented + ;; as the next line eating the next->next line.) + (set-mline-snip! next asnip) + (let ([asnip + (let loop ([asnip asnip]) + (if (and (snip->next asnip) + (not (has-flag? (snip->flags asnip) NEWLINE))) + (begin + (maybe-delete-line! asnip next) + (set-snip-line! asnip next) + (loop (snip->next asnip))) + asnip))]) + (set-snip-line! asnip next) + (set-mline-last-snip! next asnip) + (when (mline-next next) + (unless (maybe-delete-line! asnip next) + (set-mline-snip! (mline-next next) (snip->next asnip)))) + (calc-line-length next) + (mark-recalculate next) + (mark-check-flow next))))) + + (calc-line-length mline) + (mark-recalculate mline))) + ;; Try left first.... + (flow-left)) + +;; ---------------------------------------- + +(define (update-graphics mline media dc) + (define (update-left) + (and (bit-overlap? (mline-flags mline) CALC-LEFT) + (not (eq? (mline-left mline) NIL)) + (update-graphics (mline-left mline) media dc))) + (define (update-here) + (and + (bit-overlap? (mline-flags mline) CALC-HERE) + (let ([y (get-location mline)] + [nextsnip (snip->next (mline-last-snip mline))]) + (let loop ([asnip (mline-snip mline)] + [maxbase 0.0] + [maxdescent 0.0] + [maxspace 0.0] + [maxantidescent 0.0] + [maxantispace 0.0] + [totalwidth 0.0] + [maxscroll 1] + [scroll-snip #f] + [last-w 0.0] + [last-h 0.0]) + (if (not (eq? asnip nextsnip)) + (let-boxes ([w 0.0] + [h 0.0] + [descent 0.0] + [space 0.0]) + (send asnip get-extent dc totalwidth y w h descent space #f #f) + (let* ([align (send (snip->style asnip) get-alignment)] + [scroll (send asnip get-num-scroll-steps)] + [maxbase (max maxbase (- h descent space))] + [maxdescent (if (eq? align 'bottom) + (max maxdescent descent) + maxdescent)] + [maxantispace (if (eq? align 'bottom) + maxantispace + (max maxantispace (- h space)))] + [maxspace (if (eq? align 'top) + (max maxspace space) + maxspace)] + [maxantidescent (if (eq? align 'top) + maxantidescent + (max maxantidescent (- h descent)))] + [scroll-snip (if (scroll . > . maxscroll) + asnip + scroll-snip)] + [maxscroll (max maxscroll scroll)] + [totalwidth (+ w totalwidth)]) + (loop (snip->next asnip) + maxbase maxdescent maxspace maxantidescent maxantispace + totalwidth maxscroll scroll-snip + w h))) + (let ([maxspace (max maxspace (- maxantidescent maxbase))] + [maxdescent (max maxdescent (- maxantispace maxbase))]) + (set-mline-scroll-snip! mline scroll-snip) + (set-mline-last-h! mline last-h) + (set-mline-last-w! mline last-w) + (set-mline-topbase! mline maxspace) + (set-mline-bottombase! mline (+ maxspace maxbase)) + (let ([maxh (+ maxbase + maxdescent + maxspace + (send media get-s-line-spacing))] + [bigwidth (+ (if ((mline-w mline) . > . totalwidth) + (mline-w mline) + totalwidth) + CURSOR-WIDTH + (let-boxes ([is-first? #f] + [para #f]) + (set-box! para (get-paragraph-style mline is-first?)) + (if is-first? + (paragraph-left-margin-first para) + (paragraph-left-margin para))))]) + (set-width mline totalwidth) + (unless (= maxscroll (mline-numscrolls mline)) + (set-scroll-length mline maxscroll)) + (if (= maxh (mline-h mline)) + (send media refresh-box 0 y bigwidth maxh) + (begin + (set-height mline maxh) + (let ([bigwidth (max 1e5 ;; really want viewable width, but > ok + (send media get-s-total-width))] + [bigheight (+ maxh (send media get-s-total-height))]) + (send media refresh-box 0 y bigwidth bigheight)))))))) + #t))) + (define (update-right) + (and (bit-overlap? (mline-flags mline) CALC-RIGHT) + (not (eq? (mline-right mline) NIL)) + (update-graphics (mline-right mline) media dc))) + + (let ([left? (update-left)] + [here? (update-here)] + [right? (update-right)]) + (set-mline-flags! mline (bitwise-and + (mline-flags mline) + (bitwise-not CALC-MASK))) + (or left? here? right?))) + +;; ------------------------------------------------------------ + +(define (number mline) + (add1 (get-line (last mline)))) + +(define (first mline) + (let ([left (mline-left mline)]) + (if (eq? left NIL) + mline + (first left)))) + +(define (last mline) + (let ([right (mline-right mline)]) + (if (eq? right NIL) + mline + (last right)))) + +;; ------------------------------------------------------------ + +(define (get-left-location mline max-width) + (let-values ([(para left) + (if (bit-overlap? (mline-flags mline) STARTS-PARA) + (let ([para (mline-paragraph mline)]) + (values para + (paragraph-left-margin-first para))) + (let ([para (get-paragraph-style mline)]) + (values para + (paragraph-left-margin para))))]) + (if (and (max-width . > . 0) + (not (eq? (paragraph-alignment para) 'left))) + (let ([delta (max 0 (- max-width (mline-w mline)))]) + (if (eq? (paragraph-alignment para) 'right) + (+ left delta) + (+ left (/ delta 2)))) + left))) + +(define (get-right-location mline max-width) + (+ (get-left-location mline max-width) (mline-w mline))) diff --git a/collects/mred/private/wxme/pasteboard.ss b/collects/mred/private/wxme/pasteboard.ss new file mode 100644 index 00000000..98366e7d --- /dev/null +++ b/collects/mred/private/wxme/pasteboard.ss @@ -0,0 +1,2122 @@ +#lang scheme/base +(require scheme/class + scheme/port + scheme/file + "../syntax.ss" + "const.ss" + "private.ss" + "editor.ss" + "undo.ss" + "style.ss" + "snip.ss" + "snip-flags.ss" + "snip-admin.ss" + "keymap.ss" + (only-in "cycle.ss" set-pasteboard%!) + "wordbreak.ss" + "stream.ss" + "wx.ss") + +(provide pasteboard% + add-pasteboard-keymap-functions) + +;; ---------------------------------------- + +(define LINE-HEIGHT 16.0) + +(define DOT-WIDTH 5.0) +(define HALF-DOT-WIDTH 2.0) + +(define (inbox? lx x) + (and ((- lx HALF-DOT-WIDTH) . <= . x) + ((+ (- lx HALF-DOT-WIDTH) DOT-WIDTH) . >= . x))) + +(define black-brush (send the-brush-list find-or-create-brush "black" 'xor)) +(define white-brush (send the-brush-list find-or-create-brush "white" 'solid)) +(define invisi-pen (send the-pen-list find-or-create-pen "black" 1 'transparent)) +(define rb-brush (send the-brush-list find-or-create-brush "black" 'transparent)) +(define rb-pen (send the-pen-list find-or-create-pen "black" 1 'xor-dot)) + +(define arrow (make-object cursor% 'arrow)) + +;; ---------------------------------------- + +(define-struct loc (x y w h r b hm vm + startx starty + selected? need-resize? + snip) + #:mutable) + +;; ---------------------------------------- + +(defclass pasteboard% editor% + (inherit-field s-admin + s-custom-cursor + s-custom-cursor-overrides? + s-own-caret? + s-caret-snip + s-keymap + s-style-list + s-noundomode + s-modified? + s-offscreen + s-filename + s-temp-filename? + s-user-locked? + s-need-on-display-size?) + (inherit on-change + get-default-style + set-modified + on-paint + wait-sequence-lock + begin-sequence-lock + end-sequence-lock + do-own-caret + on-focus + scroll-editor-to + do-set-caret-owner + install-copy-buffer + begin-copy-buffer + end-copy-buffer + free-old-copies + do-write-headers-footers + read-snips-from-file + do-own-x-selection + do-buffer-paste + add-undo-rec + get-dc + on-local-event + on-local-char + on-edit-sequence + after-edit-sequence + on-display-size) + + (define dragable? #t) + (define selection-visible? #t) + + (define snips #f) + (define last-snip #f) + + (define snip-location-list (make-hasheq)) + (define/private (snip-loc snip) (hash-ref snip-location-list snip #f)) + + (define snip-admin (new standard-snip-admin% [editor this])) + + (define last-time 0) + (define start-x 0.0) + (define start-y 0.0) + (define last-x 0.0) + (define last-y 0.0) + + (define orig-x 0.0) + (define orig-y 0.0) + (define orig-w 0.0) + (define orig-h 0.0) + + (define max-width 'none) + (define min-width 'none) + (define max-height 'none) + (define min-height 'none) + + (define keep-size? #f) + (define dragging? #f) + (define rubberband? #f) + + (define need-resize? #f) + + (define resizing #f) ; a snip + (define sizedxm 0.0) + (define sizedym 0.0) + + (define scroll-step LINE-HEIGHT) + + (define total-width 0.0) + (define total-height 0.0) + (define real-width 0.0) + (define real-height 0.0) + + (define update-left 0.0) + (define update-right 0.0) + (define update-top 0.0) + (define update-bottom 0.0) + (define update-nonempty? #f) + (define no-implicit-update? #f) + + (define size-cache-invalid? #f) + (define write-locked 0) + (define flow-locked? #f) + + (define sequence 0) + + (define delayedscrollbias 'none) + (define delayedscrollsnip #f) + (define delayedscroll-x 0.0) + (define delayedscroll-y 0.0) + (define delayedscroll-w 0.0) + (define delayedscroll-h 0.0) + + (define sequence-streak? #f) + + (define changed? #f) + + + (super-new) + + ;; ---------------------------------------- + + (define/private (rubber-band x y w h) + (when (and s-admin + (positive? w) + (positive? h)) + (let-values ([(x w) + (if (w . < . 0) + (values (+ x w) (- w)) + (values x w))] + [(y h) + (if (h . < . 0) + (values (+ y h) (- h)) + (values y h))]) + (let ([r (+ x w)] + [b (+ y h)]) + (let-boxes ([vx 0.0] + [vy 0.0] + [vw 0.0] + [vh 0.0]) + (send s-admin get-view vx vy vw vh) + (let ([x (max x vx)] + [y (max y vy)] + [r (min r (+ vx vw))] + [b (min b (+ vy vh))]) + (unless (or (x . >= . r) + (y . >= . b)) + (let-boxes ([dc #f] + [dx 0.0] + [dy 0.0]) + (set-box! dc (send s-admin get-dc dx dy)) + (let ([old-pen (send dc get-pen)] + [old-brush (send dc get-brush)]) + (send dc set-pen rb-pen) + (send dc set-brush rb-brush) + + (send dc draw-rectangle + (- x dx) (- y dy) + (- r x) + (- b y)) + + (send dc set-pen old-pen) + (send dc set-brush old-brush)))))))))) + + (def/override (adjust-cursor [mouse-event% event]) + (if (not s-admin) + #f + (let-boxes ([scrollx 0.0] + [scrolly 0.0] + [dc #f]) + (set-box! dc (send s-admin get-dc scrollx scrolly)) + (if (not dc) + #f + (let ([x (+ (send event get-x) scrollx)] + [y (+ (send event get-y) scrolly)]) + (or (and (not s-custom-cursor-overrides?) + (or (and s-caret-snip (send event dragging?) + (let-boxes ([x 0.0] + [y 0.0]) + (get-snip-location s-caret-snip x y) + (let ([c (send s-caret-snip adjust-cursor dc + (- x scrollx) (- y scrolly) + x y event)]) + c))) + ;; find snip: + (let ([snip (find-snip x y)]) + (and snip + (eq? snip s-caret-snip) + (let-boxes ([x 0.0] [y 0.0]) + (get-snip-location snip x y) + (let ([c (send snip adjust-cursor dc (- x scrollx) (- y scrolly) + x y event)]) + c)))))) + s-custom-cursor + arrow)))))) + + (def/override (on-event [mouse-event% event]) + (when s-admin + (let-values ([(dc x y scrollx scrolly) + (if (or (send event button-down?) s-caret-snip) + ;; first, find clicked-on snip: + (let ([x (send event get-x)] + [y (send event get-y)]) + (let-boxes ([scrollx 0.0] + [scrolly 0.0] + [dc #f]) + (set-box! dc (send s-admin get-dc scrollx scrolly)) + ;; FIXME: old code returned if !dc + (values dc (+ x scrollx) (+ y scrolly) scrollx scrolly))) + (values #f 0.0 0.0 0.0 0.0))]) + (let ([snip (if (send event button-down?) + (find-snip x y) + s-caret-snip)]) + (if (and snip + (eq? snip s-caret-snip)) + (let ([loc (snip-loc snip)]) + (send s-caret-snip on-event + dc (- (loc-x loc) scrollx) (- (loc-y loc) scrolly) + (loc-x loc) (loc-y loc) + event)) + (on-local-event event)))))) + + (def/override (on-default-event [mouse-event% event]) + (when s-admin + (let-boxes ([scrollx 0.0] + [scrolly 0.0] + [dc #f]) + (set-box! dc (send s-admin get-dc scrollx scrolly)) + (when dc + (let-boxes ([x (+ (send event get-x) scrollx)] + [y (+ (send event get-y) scrolly)]) + + (interactive-adjust-mouse x y) + + (when (or (send event button-down?) + (and (send event moving?) (not (send event dragging?))) + (send event button-up?)) + (set! keep-size? #f) + + (when dragging? + (if resizing + (begin + (begin-edit-sequence) + ;; move & resize back without undo + (when (or (sizedxm . < . 0.0) + (sizedym . < . 0.0)) + (move-to resizing orig-x orig-y)) + (resize resizing orig-w orig-h) + (set! dragging? #f) + ;; re-move and re-size with undo: + (do-event-resize last-x last-y) + (after-interactive-resize resizing) + (end-edit-sequence) + (set! resizing #f)) + (finish-dragging event))) + + (when rubberband? + (set! rubberband? #f) + (rubber-band start-x start-y (- last-x start-x) (- last-y start-y)) + (add-selected start-x start-y (- last-x start-x) (- last-y start-y)) + (update-all))) + + (if (or (send event button-down?) + (and (send event dragging?) + (not dragging?) + (not rubberband?))) + + (let ([snip (find-snip x y)]) + (if dragable? + (begin + (if snip + (let ([loc (snip-loc snip)]) + (set! orig-x (loc-x loc)) + (set! orig-y (loc-y loc)) + (set! orig-w (loc-w loc)) + (set! orig-h (loc-h loc)) + (if (not (loc-selected? loc)) + (begin + (unless (send event get-shift-down) + (no-selected)) + (set-caret-owner #f) + (add-selected snip) + (init-dragging event)) + (let ([interval (abs (- (send event get-time-stamp) + last-time))]) + (if (and (send event button-down?) + (interval . < . (if s-keymap + (send s-keymap get-double-click-interval) + (get-double-click-threshold)))) + (on-double-click snip event) + (let-boxes ([dx sizedxm] + [dy sizedym] + [f? #f]) + (set-box! f? (find-dot loc x y dx dy)) + (set! sizedxm dx) + (set! sizedxm dy) + (when f? + (set! resizing snip)) + (init-dragging event))))) + (when (send event button-down?) + (set! last-time (send event get-time-stamp)))) + (begin + (unless (send event get-shift-down) + (no-selected)) + (set-caret-owner #f) + (set! rubberband? #t))) + (set! start-x x) + (set! last-x x) + (set! start-y y) + (set! last-y y)) + ;; not dragable: + (set-caret-owner snip))) + + ;; not a new click: + (when dragable? + (when (send event dragging?) + (cond + [rubberband? + ;; erase old + (rubber-band start-x start-y (- last-x start-x) (- last-y start-y)) + ;; draw new: + (rubber-band start-x start-y (- x start-x) (- y start-y))] + [resizing + (do-event-resize x y)] + [else + (do-event-move x y)])) + (set! last-x x) + (set! last-y y)))))))) + + (def/public (on-double-click [snip% snip] [mouse-event% evt]) + (when (has-flag? (snip->flags snip) HANDLES-EVENTS) + (no-selected) + (set-caret-owner snip))) + + (def/override (on-char [key-event% event]) + (when s-admin + (let-boxes ([scrollx 0.0] + [scrolly 0.0] + [dc #f]) + (set-box! dc (send s-admin get-dc scrollx scrolly)) + (when dc + (let ([x (+ (send event get-x) scrollx)] + [y (+ (send event get-y) scrolly)]) + (if s-caret-snip + (let ([loc (snip-loc s-caret-snip)]) + (send s-caret-snip on-char + dc (loc-x loc) (loc-y loc) (- x scrollx) (- y scrolly) + event)) + (on-local-char event))))))) + + (def/override (on-default-char [key-event% event]) + (when s-admin + (let ([code (send event get-key-code)]) + (case code + [(#\rubout #\backspace) + (delete)] + [(right) + (move 1 0)] + [(left) + (move -1 0)] + [(up) + (move 0 -1)] + [(down) + (move 0 1)])))) + + (define/private (init-dragging e) + (define (phase1) + (if resizing + (if (not (can-interactive-resize? resizing)) + (set! resizing #f) + (begin + (on-interactive-resize resizing) + (phase2))) + (when (can-interactive-move? e) + (on-interactive-move e) + (phase2)))) + (define (phase2) + (set! dragging? #t) + (set! keep-size? #t) + (let loop ([s #f]) + (let ([s (find-next-selected-snip s)]) + (when s + (let ([loc (snip-loc s)]) + (set-loc-startx! loc (loc-x loc)) + (set-loc-starty! loc (loc-y loc))) + (loop s))))) + (phase1)) + + (define/private (finish-dragging e) + (begin-edit-sequence) + + ;; move back without undo and remember final + (let loop ([s #f]) + (let ([s (find-next-selected-snip s)]) + (when s + (let* ([loc (snip-loc s)] + [x (loc-startx loc)] + [y (loc-starty loc)]) + (set-loc-startx! loc (loc-x loc)) + (set-loc-starty! loc (loc-y loc)) + (move-to s x y)) + (loop s)))) + + (set! dragging? #f) + + ;; move to final position with undo: + (let loop ([s #f]) + (let ([s (find-next-selected-snip s)]) + (when s + (let* ([loc (snip-loc s)]) + (move-to s (loc-startx loc) (loc-starty loc))) + (loop s)))) + + (after-interactive-move e) + (end-edit-sequence)) + + (define/private (do-event-move event-x event-y) + (let ([dx (- event-x start-x)] + [dy (- event-y start-y)]) + (begin-edit-sequence) + + (let loop ([s #f]) + (let ([s (find-next-selected-snip s)]) + (when s + (let ([loc (snip-loc s)]) + (let-boxes ([x (+ (loc-startx loc) dx)] + [y (+ (loc-starty loc) dy)]) + (interactive-adjust-move s x y) + (move-to s x y))) + (loop s)))) + + (end-edit-sequence))) + + (define/private (do-event-resize event-x event-y) + (let ([dx (- event-x start-x)] + [dy (- event-y start-y)]) + (let-boxes ([w (max 0.0 (+ orig-w (* dx sizedxm)))] + [h (max 0.0 (+ orig-h (* dy sizedym)))]) + (interactive-adjust-resize resizing w h) + (let ([w (max 0.0 w)] + [h (max 0.0 h)]) + (let ([x (+ orig-x + (if (sizedxm . < . 0) + (- orig-w w) + 0.0))] + [y (+ orig-y + (if (sizedym . < . 0) + (- orig-h h) + 0.0))]) + + (begin-edit-sequence) + + (when (resize resizing w h) + (when (or (sizedxm . < . 0) + (sizedym . < . 0)) + (move-to resizing x y))) + + (end-edit-sequence)))))) + + (def/public (interactive-adjust-mouse [(make-box real?) x] [(make-box real?) y]) + (set-box! x (max 0.0 (unbox x))) + (set-box! y (max 0.0 (unbox y)))) + + (def/public (interactive-adjust-resize [snip% s] [(make-box real?) w] [(make-box real?) h]) + (void)) + + (def/public (interactive-adjust-move [snip% s][(make-box real?) x] [(make-box real?) y]) + (set-box! x (max 0.0 (unbox x))) + (set-box! y (max 0.0 (unbox y)))) + + ;; ---------------------------------------- + + (def/public (set-selected [snip% snip]) + (begin-edit-sequence) + (no-selected) + (add-selected snip) + (end-edit-sequence)) + + (define/private (do-select snip on?) + (let ([loc (snip-loc snip)]) + (when (and loc + (not (eq? (loc-selected? loc) on?))) + (set! write-locked (add1 write-locked)) + (if (can-select? snip on?) + (begin + (on-select snip on?) + (set! write-locked (sub1 write-locked)) + (set-loc-selected?! loc on?) + (after-select snip on?) + (update-location loc)) + (set! write-locked (sub1 write-locked)))))) + + (def/public (remove-selected [snip% snip]) + (do-select snip #f)) + + (define/private (add-selected-region x y w h) + (let-values ([(x w) + (if (w . < . 0) + (values (+ x w) (- w)) + (values x w))] + [(y h) + (if (h . < . 0) + (values (+ y h) (- h)) + (values y h))]) + (let ([r (+ x w)] + [b (+ y h)]) + + (begin-edit-sequence) + + (let loop ([s snips]) + (when s + (let ([loc (snip-loc s)]) + (when (and + loc + (not (loc-selected? loc)) + ((loc-x loc) . <= . r) + ((loc-y loc) . <= . b) + ((loc-r loc) . >= . x) + ((loc-b loc) . >= . y)) + (add-selected s))) + (loop (snip->next s)))) + + (end-edit-sequence)))) + + (define/public (add-selected . args) + (case-args + args + [([real? x] [real? y] [real? w] [real? h]) + (add-selected-region x y w h)] + [([snip% snip]) + (do-select snip #t)] + (method-name 'pasteboard% 'add-selected))) + + (def/override (select-all) + (begin-edit-sequence) + (let loop ([s snips]) + (when s + (add-selected s) + (loop (snip->next s)))) + (end-edit-sequence)) + + (def/public (no-selected) + (begin-edit-sequence) + (let loop ([s snips]) + (when s + (remove-selected s) + (loop (snip->next s)))) + (end-edit-sequence)) + + ;; ---------------------------------------- + + (define/private (do-insert snip before x y) + (unless (or s-user-locked? + (not (zero? write-locked)) + (send snip is-owned?)) + (when (not (snip->snipclass snip)) + (error (method-name 'pasteboard% 'insert) + "cannot insert a snip without a snipclass: ~e" + snip)) + + (set! write-locked (add1 write-locked)) + (begin-edit-sequence) + (let ([ok? + (or (can-insert? snip before x y) + (begin + (end-edit-sequence) + (set! write-locked (sub1 write-locked)) + #f))]) + (when ok? + (on-insert snip before x y) + (set! write-locked (sub1 write-locked)) + + (let ([snip (if (send snip is-owned?) + ;; disaster: can/on-insert made the snip owned + (new image-snip%) + snip)]) + + (let ([search (and (snip-loc before) + before)]) + + (set-snip-next! snip search) + (if search + (begin + (set-snip-prev! snip (snip->prev search)) + (set-snip-prev! search snip)) + (begin + (set-snip-prev! snip last-snip) + (set! last-snip snip))) + (if (snip->prev snip) + (set-snip-next! (snip->prev snip) snip) + (set! snips snip))) + + (let ([loc (make-loc + x y 0.0 0.0 0.0 0.0 0.0 0.0 + 0.0 0.0 + #f #t + snip)]) + (hash-set! snip-location-list snip loc) + + (set-snip-style! snip (send s-style-list convert (snip->style snip))) + (when (eq? (snip->style snip) + (send s-style-list basic-style)) + (let ([s (get-default-style)]) + (when s + (set-snip-style! snip s)))) + + (send snip size-cache-invalid) + + (snip-set-admin snip snip-admin) + + (when (zero? s-noundomode) + (let ([is (make-object insert-snip-record% snip sequence-streak?)]) + (add-undo-rec is))) + (when (positive? sequence) + (set! sequence-streak? #t)) + + (set! changed? #t) + + (unless s-modified? + (set-modified #t)) + + (set! need-resize? #t) + (update-location loc) + + (set! write-locked (add1 write-locked)) + (end-edit-sequence) + (set! write-locked (sub1 write-locked)) + + (when (zero? sequence) + (update-needed)) + + (after-insert snip before x y))))))) + + (define/override (insert . args) + (case-args + args + [([snip% snip] [(make-or-false snip%) [before #f]]) + (let-values ([(x y) (get-center)]) + (do-insert snip before x y))] + [([snip% snip] [(make-or-false snip%) before] [real? x] [real? y]) + (do-insert snip before x y)] + [([snip% snip] [real? x] [real? y]) + (do-insert snip #f x y)] + (method-name 'pasteboard% 'insert))) + + (define/private (delete-some del?) + (unless (or s-user-locked? + (not (zero? write-locked))) + (let ([del (make-object delete-snip-record% sequence-streak?)]) + (when (positive? sequence) + (set! sequence-streak? #t)) + + (begin-edit-sequence) + + (let loop ([s snips]) + (when s + (let ([next (snip->next s)]) + (when (del? s) + (-delete s del)) + (loop next)))) + + (when (zero? s-noundomode) + (add-undo-rec del)) + + (end-edit-sequence)))) + + (define/public (delete . args) + (case-args + args + [() + (delete-some (lambda (s) (loc-selected? (snip-loc s))))] + [([snip% s]) + (unless (or s-user-locked? + (not (zero? write-locked))) + (let ([del (make-object delete-snip-record% sequence-streak?)]) + (when (positive? sequence) + (set! sequence-streak? #t)) + (-delete s del) + (when (zero? s-noundomode) + (add-undo-rec del))))] + (method-name 'pasteboard% 'insert))) + + (def/public (erase) + (delete-some (lambda (s) #t))) + + (define/private (-delete del-snip del) + (when (snip-loc del-snip) + (set! write-locked (add1 write-locked)) + (begin-edit-sequence) + (let ([ok? (or (can-delete? del-snip) + (begin + (end-edit-sequence) + (set! write-locked (sub1 write-locked)) + #f))]) + (and + ok? + (begin + (on-delete del-snip) + (set! write-locked (sub1 write-locked)) + + (let ([update-cursor? + (and (eq? del-snip s-caret-snip) + (begin + (send s-caret-snip own-caret #f) + (set! s-caret-snip #f) + #t))]) + + (update-snip del-snip) + + (if (snip->prev del-snip) + (set-snip-next! (snip->prev del-snip) (snip->next del-snip)) + (set! snips (snip->next del-snip))) + (if (snip->next del-snip) + (set-snip-prev! (snip->next del-snip) (snip->prev del-snip)) + (set! last-snip (snip->prev del-snip))) + + (let ([loc (snip-loc del-snip)]) + (hash-remove! snip-location-list del-snip) + (when del + (send del insert-snip del-snip (snip->next del-snip) (loc-x loc) (loc-y loc)))) + + (set-snip-next! del-snip #f) + (set-snip-prev! del-snip #f) + + (set-snip-flags! del-snip (add-flag CAN-DISOWN (snip->flags del-snip))) + (snip-set-admin del-snip #f) + (set-snip-flags! del-snip (remove-flag CAN-DISOWN (snip->flags del-snip))) + (unless del + (when (send del-snip get-admin) + (set-snip-flags! del-snip (remove-flag OWNED (snip->flags del-snip))))) + + (unless s-modified? + (set-modified #t)) + + (after-delete del-snip) + (set! changed? #t) + + (set! need-resize? #t) + + (set! write-locked (add1 write-locked)) + (end-edit-sequence) + (set! write-locked (sub1 write-locked)) + + (when (zero? sequence) + (update-needed)) + + (when update-cursor? + (when s-admin + (send s-admin update-cursor))) + + #t)))))) + + (def/public (remove [snip% del-snip]) + (unless (or s-user-locked? + (not (zero? write-locked))) + (-delete del-snip #f))) + + ;; ---------------------------------------- + + + (def/public (move-to [snip% snip] [real? x] [real? y]) + (unless (or s-user-locked? + (not (zero? write-locked))) + (let ([loc (snip-loc snip)]) + (when (and loc + (not (and + (= (loc-x loc) x) + (= (loc-y loc) y)))) + (set! write-locked (add1 write-locked)) + (begin-edit-sequence) + (if (not (can-move-to? snip x y dragging?)) + (begin + (end-edit-sequence) + (set! write-locked (sub1 write-locked))) + (begin + (on-move-to snip x y dragging?) + (set! write-locked (sub1 write-locked)) + + (update-location loc) + + (unless dragging? + (let ([rec (make-object move-snip-record% + snip + (loc-x loc) + (loc-y loc) + #f + sequence-streak?)]) + (when (positive? sequence) + (set! sequence-streak? #t)) + (when (zero? s-noundomode) + (add-undo-rec rec)))) + + (set-loc-x! loc x) + (set-loc-y! loc y) + (set-loc-r! loc (+ x (loc-w loc))) + (set-loc-b! loc (+ y (loc-h loc))) + (set-loc-hm! loc (+ x (/ (loc-w loc) 2))) + (set-loc-vm! loc (+ y (/ (loc-h loc) 2))) + (update-location loc) + + (when (and (not dragging?) + (not s-modified?)) + (set-modified #t)) + + (after-move-to snip x y dragging?) + + (set! need-resize? #t) + + (set! write-locked (add1 write-locked)) + (end-edit-sequence) + (set! write-locked (sub1 write-locked)) + + (set! changed? #t) + + (when (zero? sequence) + (update-needed)))))))) + + (define/public (move . args) + (case-args + args + [([snip% snip] [real? dx] [real? dy]) + (unless (or s-user-locked? + (not (zero? write-locked))) + (let ([loc (snip-loc snip)]) + (when loc + (move-to snip (+ (loc-x loc) dx) (+ (loc-y loc) dy)))))] + [([real? dx] [real? dy]) + (unless (or s-user-locked? + (not (zero? write-locked))) + (begin-edit-sequence) + (for ([loc (in-hash-values snip-location-list)]) + (when (loc-selected? loc) + (move (loc-snip loc) dx dy))) + (end-edit-sequence))] + (method-name 'pasteboard% 'move))) + + (def/public (resize [snip% snip] [real? w] [real? h]) + (if (not s-admin) + #f + (let ([loc (snip-loc snip)]) + (if (not loc) + #f + (let ([oldw (loc-w loc)] + [oldh (loc-h loc)]) + (set! write-locked (add1 write-locked)) + (begin-edit-sequence) + (if (not (can-resize? snip w h)) + (begin + (end-edit-sequence) + (set! write-locked (sub1 write-locked)) + #f) + (begin + (on-resize snip w h) + (set! write-locked (sub1 write-locked)) + + (let ([rv? + (and (send snip resize w h) + (begin + (when (not dragging?) + (when (zero? s-noundomode) + (let ([rs (make-object resize-snip-record% + snip oldw oldh + sequence-streak?)]) + (add-undo-rec rs)) + (when (positive? sequence) + (set! sequence-streak? #t)))) + #t))]) + (when (and rv? + (not dragging?) + (not s-modified?)) + (set-modified #t)) + + (after-resize snip w h rv?) + + (set! write-locked (add1 write-locked)) + (end-edit-sequence) + (set! write-locked (sub1 write-locked)) + + (set! changed? #t) + + (when (zero? sequence) + (update-needed)) + + rv?)))))))) + + ;; ---------------------------------------- + + (define/private (do-change-style style delta snip) + (unless (or s-user-locked? + (not (zero? write-locked))) + (let ([rec (make-object style-change-snip-record% sequence-streak?)]) + (when (positive? sequence) + (set! sequence-streak? #t)) + + (let ([style (or style + (and (not delta) + (or (get-default-style) + (send s-style-list basic-style))))]) + + (begin-edit-sequence) + + (let ([didit? + (if snip + (begin + (send rec add-style-change snip (snip->style snip)) + (set-snip-style! + snip + (or style + (send s-style-list find-or-create-style (snip->style snip) delta))) + (send snip size-cache-invalid) + (update-snip snip) + #t) + (for/fold ([didit? #f]) + ([loc (in-hash-keys snip-location-list)]) + (if (loc-selected? loc) + (let ([snip (loc-snip loc)]) + (send rec add-style-change (loc-snip loc) (snip->style snip)) + (set-snip-style! + snip + (or style + (send s-style-list find-or-create-style (snip->style snip) delta))) + (send snip size-cache-invalid) + (set-loc-need-resize?! loc #t) + (set! need-resize? #t) + (update-location loc) + #t) + didit?)))]) + + (when didit? + (when (zero? s-noundomode) + (add-undo-rec rec)) + + (set! changed? #t) + (when (not s-modified?) + (set-modified #t)))) + + (end-edit-sequence))))) + + (define/public (change-style . args) + (case-args + args + [([style-delta% delta]) + (do-change-style #f delta #f)] + [([style-delta% delta] [snip% snip]) + (do-change-style #f delta snip)] + [([style<%> style] [snip% snip]) + (do-change-style style #f snip)] + (method-name 'pasteboard% 'change-style))) + + ;; ---------------------------------------- + + (define/private (set-between snip before after) + (unless (or s-user-locked? + (not (zero? write-locked)) + (not (snip-loc snip)) + (eq? snip before) + (eq? snip after) + (and before (not (snip-loc before))) + (and after (not (snip-loc after)))) + (set! write-locked (add1 write-locked)) + (if (not (can-reorder? snip (or before after) (and before #t))) + (set! write-locked (sub1 write-locked)) + (begin + (on-reorder snip (or before after) (and before #t)) + (set! write-locked (sub1 write-locked)) + + ;; remove snip from current pos: + (if (snip->prev snip) + (set-snip-next! (snip->prev snip) (snip->next snip)) + (set! snips (snip->next snip))) + (if (snip->next snip) + (set-snip-prev! (snip->next snip) (snip->prev snip)) + (set! last-snip (snip->prev snip))) + + ;; insert before `before' or after `after': + (if before + (begin + (set-snip-prev! snip (snip->prev before)) + (set-snip-next! snip before) + (set-snip-prev! before snip) + (if (snip->prev snip) + (set-snip-next! (snip->prev snip) snip) + (set! snips snip))) + (begin + (set-snip-next! snip (snip->next after)) + (set-snip-prev! snip after) + (set-snip-next! after snip) + (if (snip->next snip) + (set-snip-prev! (snip->next snip) snip) + (set! last-snip snip)))) + + (set! changed? #t) + (unless s-modified? + (set-modified #t)) + + (update-snip snip) + + (after-reorder snip (or before after) (and before #t)))))) + + (def/public (set-before [snip% snip] [(make-or-false snip%) before]) + (set-between snip (or before snips) #f)) + + (def/public (set-after [snip% snip] [(make-or-false snip%) after]) + (set-between snip #f (or after last-snip))) + + (def/public (raise [snip% snip]) + (set-between snip (snip->prev snip) #f)) + + (def/public (lower [snip% snip]) + (set-between snip #f (snip->next snip))) + + ;; ---------------------------------------- + + (define/private (snip-set-admin snip a) + (let ([orig-admin (snip->admin snip)]) + ;; lock during set-admin! [???] + (send snip set-admin a) + + (if (not (eq? (send snip get-admin) a)) + ;; something went wrong + (cond + [(and (not a) + (eq? (snip->admin snip) orig-admin)) + ;; force admin to null + (set-snip-admin! snip #f) + snip] + [a + ;; snip didn't accept membership into this editor; give up on it + (let ([naya (new snip%)]) + (set-snip-prev! naya (snip->prev snip)) + (set-snip-next! naya (snip->next snip)) + (if (snip->prev snip) + (set-snip-next! (snip->prev naya) naya) + (set! snips naya)) + (if (snip->next snip) + (set-snip-prev! (snip->next naya) naya) + (set! last-snip naya)) + (set-snip-admin! snip #f) + (send naya set-admin a) + naya)] + [else snip]) + snip))) + + ;; ---------------------------------------- + + (define/override (really-can-edit? op) + (if (and (not (eq? op 'copy)) + (positive? write-locked)) + #f + (case op + [(clear cut copy kill) + (and (find-next-selected-snip #f) + #t)] + [(select-all) + (and snips #t)] + [else #t]))) + + ;; ---------------------------------------- + + (define/private (find-dot loc x y dxm dym) + (define (check-y) + (cond + [(inbox? (loc-y loc) y) + (set-box! dym -1) #t] + [(inbox? (loc-vm loc) y) + (set-box! dym 0) #t] + [(inbox? (loc-b loc) y) + (set-box! dym 1) #t] + [else #f])) + (cond + [(inbox? (loc-x loc) x) + (set-box! dxm -1) + (check-y)] + [(inbox? (loc-hm loc) x) + (set-box! dxm 0) + (check-y)] + [(inbox? (loc-r loc) x) + (set-box! dxm 1) + (check-y)] + [else #f])) + + (def/public (find-snip [real? x] [real? y] [(make-or-false snip%) [after #f]]) + (let ([dummy (box 0)]) + (let loop ([s (if after + (if (snip-loc after) + (snip->next after) + #f) + snips)]) + (and s + (let ([loc (snip-loc s)]) + (cond + [(and ((loc-x loc) . <= . x) + ((loc-y loc) . <= . y) + ((loc-r loc) . >= . x) + ((loc-b loc) . >= . y)) + s] + [(and (loc-selected? loc) + (find-dot loc x y dummy dummy)) + s] + [else (loop (snip->next s))])))))) + + (def/override (find-first-snip) snips) + + (def/public (is-selected? [snip% asnip]) + (let ([loc (snip-loc asnip)]) + (and loc + (loc-selected? loc)))) + + (def/public (find-next-selected-snip [(make-or-false snip%) start]) + (let loop ([s (if start + (if (snip-loc start) + (snip->next start) + #f) + snips)]) + (and s + (if (loc-selected? (snip-loc s)) + s + (loop (snip->next s)))))) + + ;; ---------------------------------------- + + (define/private (draw dc dx dy cx cy cw ch show-caret bg-color) + (when s-admin + (set! write-locked (add1 write-locked)) + (set! flow-locked? #t) + + (let ([dcx (+ cx dx)] + [dcy (+ cy dy)] + [cr (+ cx cw)] + [cb (+ cy ch)]) + (let ([dcr (+ dcx cw)] + [dcb (+ dcy ch)]) + + (when bg-color + (let ([save-pen (send dc get-pen)] + [save-brush (send dc get-brush)]) + + (let ([wb (if (and (= 255 (send bg-color red)) + (= 255 (send bg-color green)) + (= 255 (send bg-color blue))) + white-brush + (send the-brush-list find-or-create-brush bg-color 'solid))]) + (send dc set-brush wb) + (send dc set-pen invisi-pen) + (send dc draw-rectangle dcx dcy cw ch) + (send dc set-brush save-brush) + (send dc set-pen save-pen)))) + + (on-paint #t dc cx cy cr cb dx dy + (if (not s-caret-snip) + show-caret + 'no-caret)) + + (let loop ([snip last-snip] + [old-style #f]) + (if snip + (let ([loc (snip-loc snip)]) + (when (and ((loc-x loc) . <= . cr) + ((loc-y loc) . <= . cb) + ((loc-r loc) . >= . cx) + ((loc-b loc) . >= . cy)) + (send (snip->style snip) switch-to dc old-style) + (let ([old-style (snip->style snip)]) + (let ([x (+ (loc-x loc) dx)] + [y (+ (loc-y loc) dy)]) + + (send snip draw + dc x y dcx dcy dcr dcb dx dy + (if (eq? snip s-caret-snip) + show-caret + 'no-caret)) + + (when (and (eq? show-caret 'show-caret) + s-own-caret? + selection-visible? + (loc-selected? loc)) + (let ([oldbrush (send dc get-brush)] + [oldpen (send dc get-pen)]) + (send dc set-brush black-brush) + (send dc set-pen invisi-pen) + + (let ([r (+ (loc-r loc) dx)] + [b (+ (loc-b loc) dy)] + [hm (+ (loc-hm loc) dx)] + [vm (+ (loc-vm loc) dy)] + [rect + (lambda (x y) + (send dc draw-rectangle + (- x HALF-DOT-WIDTH) (- y HALF-DOT-WIDTH) + DOT-WIDTH DOT-WIDTH))]) + (rect x y) + (rect hm y) + (rect r y) + (rect r vm) + (rect r b) + (rect hm b) + (rect x b) + (rect x vm)) + + (send dc set-pen oldpen) + (send dc set-brush oldbrush)))))) + + (loop (snip->prev snip) old-style)) + (let ([bs (send s-style-list basic-style)]) + (send bs switch-to dc old-style)))) + + (on-paint #f dc cx cy cr cb dx dy + (if (not s-caret-snip) + show-caret + 'no-caret)) + + (set! flow-locked? #f) + (set! write-locked (sub1 write-locked)))))) + + ;; called by the administrator to trigger a redraw + (def/override (refresh [real? left] [real? top] [nonnegative-real? width] [nonnegative-real? height] + [(symbol-in no-caret show-inactive-caret show-caret) show-caret] + [(make-or-false color%) bg-color]) + + (cond + [(not s-admin) (void)] + [(or (width . <= . 0) (height . <= . 0)) (void)] + [(or flow-locked? (positive? sequence)) + ;; we're busy. invalidate so that everything is refreshed later. + (update left top width height)] + [else + (let-boxes ([x 0.0] + [y 0.0] + [dc #f]) + (set-box! dc (send s-admin get-dc x y)) + (when dc + (begin-sequence-lock) + + (send s-offscreen ready-offscreen width height) + + ;; make sure all location information is integral, + ;; so we can shift the coordinate system and generally + ;; update on pixel boundaries + (let ([x (->long (floor x))] + [y (->long (floor y))] + [bottom (->long (ceiling (+ top height)))] + [right (->long (ceiling (+ left width)))] + [top (->long (floor top))] + [left (->long (floor left))]) + (let ([width (- right left)] + [height (- bottom top)] + [ps? (or (dc . is-a? . post-script-dc%) + (dc . is-a? . printer-dc%))]) + + (if (and bg-color + (not (send s-offscreen is-in-use?)) + (send s-offscreen get-bitmap) + (send (send s-offscreen get-bitmap) ok?) + (send (send s-offscreen get-dc) ok?) + (not ps?)) + ;; draw to offscreen + (begin + (draw (send s-offscreen get-dc) (- left) (- top) left top width height show-caret bg-color) + + (send dc draw-bitmap-section + (send (send s-offscreen get-dc) get-bitmap) + (- left x) (- top y) + 0 0 width height 'solid) + + (send s-offscreen set-last-used #f) + (send s-offscreen set-in-use #f)) + ;; draw directly + (let ([pen (send dc get-pen)] + [brush (send dc get-brush)] + [font (send dc get-font)] + [fg (send dc get-text-foreground)] + [bg (send dc get-text-background)] + [bgmode (send dc get-text-mode)] + [rgn (send dc get-clipping-region)]) + + (send dc set-clipping-rect (- left x) (- top y) width height) + + (draw dc (- x) (- y) left top width height show-caret bg-color) + + (send dc set-clipping-region rgn) + + (send dc set-brush brush) + (send dc set-pen pen) + (send dc set-font font) + (send dc set-text-foreground fg) + (send dc set-text-background bg) + (send dc set-text-mode bgmode))))) + + (end-sequence-lock)))])) + ;; ---------------------------------------- + + (define/private (loc-resize loc dc) + (let-boxes ([ww 0.0] + [hh 0.0]) + (send (loc-snip loc) get-extent dc (loc-x loc) (loc-y loc) ww hh #f #f #f #f) + (set-loc-w! loc ww) + (set-loc-h! loc hh) + (set-loc-r! loc (+ (loc-x loc) ww)) + (set-loc-b! loc (+ (loc-y loc) hh)) + (set-loc-hm! loc (+ (loc-x loc) (/ ww 2))) + (set-loc-vm! loc (+ (loc-y loc) (/ hh 2))) + (set-loc-need-resize?! loc #f))) + + (define/private (check-recalc) + (when s-admin + (let ([dc (send s-admin get-dc)]) + (when dc + (when need-resize? + (let-values ([(r b) + (for/fold ([r 0.0] + [b 0.0]) + ([loc (in-hash-values snip-location-list)]) + (when size-cache-invalid? + (send (loc-snip loc) size-cache-invalid) + (set-loc-need-resize?! loc #t)) + (when (loc-need-resize? loc) + (loc-resize loc dc)) + (values (max r (+ (loc-r loc) HALF-DOT-WIDTH)) + (max b (+ (loc-b loc) HALF-DOT-WIDTH))))]) + + (set! real-width (max (min r (if (symbol? max-width) +inf.0 max-width)) + (if (symbol? min-width) -inf.0 min-width))) + (set! real-height (max (min b (if (symbol? max-height) +inf.0 max-height)) + (if (symbol? min-height) -inf.0 min-height))) + + (set! need-resize? #f))) + + (set! size-cache-invalid? #f) + + (when (not keep-size?) + (when (or (not (= real-width total-width)) + (not (= real-height total-height))) + (set! total-width real-width) + (set! total-height real-height) + (send s-admin resized #f))))))) + + (define/private (update x y w h) + (unless (and delayedscrollsnip + (zero? sequence) + (not flow-locked?) + (let ([s delayedscrollsnip]) + (set! delayedscrollsnip #f) + (scroll-to s + delayedscroll-x delayedscroll-y + delayedscroll-w delayedscroll-h + #t delayedscrollbias))) + (let ([r (+ x w)] + [b (+ y h)]) + (let ([x (max x 0.0)] + [y (max y 0.0)] + [r (max r 0.0)] + [b (max b 0.0)]) + + (set! no-implicit-update? #f) + + (if (not update-nonempty?) + (begin + (set! update-top y) + (set! update-left x) + (set! update-bottom (if (h . < . 0) h b)) + (set! update-right (if (w . < . 0) w r)) + (set! update-nonempty? #t)) + (begin + (set! update-top (min y update-top)) + (set! update-left (min x update-left)) + (let ([ub (if (and (h . < . 0) (update-bottom . > . 0)) + (- update-bottom) + update-bottom)]) + (set! update-bottom + (if (ub . < . 0) + (if (and (h . < . 0) (h . < . ub)) + h + (if (and (h . > . 0) + ((- b) . < . ub)) + (- b) + ub)) + (max b ub)))) + (let ([ur (if (and (w . < . 0) (update-right . > . 0)) + (- update-right) + update-right)]) + (set! update-right + (if (ur . < . 0) + (if (and (w . < . 0) (w . < . ur)) + w + (if (and (w . > . 0) + ((- r) . < . ur)) + (- r) + ur)) + (max r ur)))))) + + (unless (or (positive? sequence) + (not s-admin) + flow-locked?) + (check-recalc) + + (when (update-bottom . < . 0) + (set! update-bottom (- update-bottom)) + (when (update-bottom . < . real-height) + (set! update-bottom real-height))) + + (when (update-right . < . 0) + (set! update-right (- update-right)) + (when (update-right . < . real-width) + (set! update-right real-width))) + + (set! update-nonempty? #f) + + (when changed? + (set! changed? #f) + (set! write-locked (add1 write-locked)) + (on-change) + (set! write-locked (sub1 write-locked))) + + (when (or (not (= update-top update-bottom)) + (not (= update-left update-right))) + (let ([w (+ (- update-right update-left) 1)] + [h (+ (- update-bottom update-top) 1)]) + (when (and (w . > . 0) (h . > . 0)) + (send s-admin needs-update update-left update-top w h))))))))) + + + (define/private (update-location loc) + (when s-admin + (when (loc-need-resize? loc) + (let ([dc (send s-admin get-dc)]) + (when dc + (loc-resize loc dc)) + ;; otherwise, still need resize... + )) + (update (- (loc-x loc) HALF-DOT-WIDTH) + (- (loc-y loc) HALF-DOT-WIDTH) + (+ (loc-w loc) DOT-WIDTH) + (+ (loc-h loc) DOT-WIDTH)))) + + (define/private (update-snip snip) + (let ([loc (snip-loc snip)]) + (when loc + (update-location loc)))) + + (define/private (update-selected) + (begin-edit-sequence) + (for ([loc (in-hash-values snip-location-list)]) + (when (loc-selected? loc) + (update-location loc))) + (end-edit-sequence)) + + (define/private (update-all) + (update 0.0 0.0 -1.0 -1.0)) + + (define/private (update-needed) + (when (or (and update-nonempty? + (not no-implicit-update?)) + delayedscrollsnip) + (update update-left update-top 0 0))) + + (def/override (invalidate-bitmap-cache [real? [x 0.0]] + [real? [y 0.0]] + [(make-alts nonnegative-real? (symbol-in end)) [w 'end]] + [(make-alts nonnegative-real? (symbol-in end)) [h 'end]]) + (update x y (if (symbol? w) -1.0 w) (if (symbol? h) -1.0 h))) + + ;; ---------------------------------------- + + (def/override (own-caret [any? ownit?]) + (when (do-own-caret ownit?) + (update-selected) + (on-focus ownit?))) + + (def/override (blink-caret) + (when s-caret-snip + (let-boxes ([dc #f] + [dx 0.0] + [dy 0.0]) + (set-box! dc (send s-admin get-dc dx dy)) + (when dc + (let-boxes ([x 0.0] + [y 0.0] + [ok? #f]) + (set-box! ok? (get-snip-location s-caret-snip y)) + (when ok? + (send s-caret-snip blink-caret dc (- x dx) (- y dy)))))))) + + (def/override (size-cache-invalid) + (set! size-cache-invalid? #t) + (set! need-resize? #t)) + + (def/override (get-extent [maybe-box? w] [maybe-box? h]) + (check-recalc) + (when w (set-box! w total-width)) + (when h (set-box! h total-height))) + + ;; ---------------------------------------- + + (def/public (scroll-to [snip% snip] [real? localx] [real? localy] + [nonnegative-real? w] [nonnegative-real? h] + [any? refresh?] + [(symbol-in start end none) [bias 'none]]) + (cond + [(positive? sequence) + (set! delayedscrollsnip snip) + (set! delayedscroll-x localx) + (set! delayedscroll-y localy) + (set! delayedscroll-w w) + (set! delayedscroll-h h) + #f] + [s-admin + (let-boxes ([x 0.0] + [y 0.0]) + (get-snip-location snip x y) + (if (scroll-editor-to (+ x localx) (+ y localy) w h refresh? bias) + (begin + (set! update-top 0.0) + (set! update-left 0.0) + (set! update-bottom -1.0) + (set! update-right -1.0) + (set! update-nonempty? #t) + #t) + #f))] + [else #f])) + + (def/override (set-caret-owner [(make-or-false snip%) snip] + [(symbol-in immediate display global) [dist 'immediate]]) + (when (do-set-caret-owner snip dist) + (update-all) + (on-focus (not snip)))) + + (def/override (resized [snip% snip] [any? redraw-now?]) + (let ([loc (snip-loc snip)]) + (when (and loc + (not (loc-need-resize? loc))) + (set! changed? #t) + + (let ([niu? (or (not update-nonempty?) + no-implicit-update?)]) + + (when (not redraw-now?) + (set! sequence (add1 sequence))) + (begin-edit-sequence) + + (update-location loc) + + (set-loc-need-resize?! loc #t) + (set! need-resize? #t) + + (update-location loc) + + (end-edit-sequence) + (when (not redraw-now?) + (set! sequence (sub1 sequence))) + (when niu? + (set! no-implicit-update? #t)))))) + + (def/override (recounted [snip% snip] [any? redraw-now?]) + (resized snip redraw-now?) + #t) + + (def/override (needs-update [snip% snip] + [real? localx] [real? localy] + [nonnegative-real? w] [nonnegative-real? h]) + (let-boxes ([x 0.0] + [y 0.0]) + (get-snip-location snip x y) + (update (+ x localx) (+ y localy) w h))) + + (def/override (release-snip [snip% snip]) + (if (-delete snip #f) + (begin + (when (and (not (snip->admin snip)) + (has-flag? (snip->flags snip) OWNED)) + (set-snip-flags! snip (remove-flag (snip->flags snip) OWNED))) + #t) + #f)) + + ;; ---------------------------------------- + + (def/override (scroll-line-location [exact-integer? line]) + (* line scroll-step)) + + (def/override (num-scroll-lines) + (->long (/ (- (+ total-height scroll-step) 1) scroll-step))) + + (def/override (find-scroll-line [real? y]) + (->long (/ y scroll-step))) + + (def/public (set-scroll-step [real? s]) + (unless (= scroll-step s) + (set! scroll-step s) + (when s-admin + (send s-admin resized #t)))) + + (def/public (get-scroll-step) + scroll-step) + + ;; ---------------------------------------- + + (def/override (set-min-width [real? w]) + (set! min-width (if (w . <= . 0) 'none w)) + (set! need-resize? #t) + (update-all)) + + (def/override (set-max-width [real? w]) + (set! max-width (if (w . <= . 0) 'none w)) + (set! need-resize? #t) + (update-all)) + + (def/override (set-min-height [real? h]) + (set! min-height (if (h . <= . 0) 'none h)) + (set! need-resize? #t) + (update-all)) + + (def/override (set-max-height [real? h]) + (set! max-height (if (h . <= . 0) 'none h)) + (set! need-resize? #t) + (update-all)) + + (def/override (get-min-width) min-width) + (def/override (get-max-width) max-width) + (def/override (get-min-height) min-height) + (def/override (get-max-height) max-height) + + ;; ---------------------------------------- + + (def/override (copy-self) + (let ([pb (new pasteboard%)]) + (copy-self-to pb) + pb)) + + (def/override (copy-self-to [editor<%> pb]) + (when (pb . is-a? . pasteboard%) + (super copy-self-to pb) + (send pb set-dragable (get-dragable)) + (send pb set-selection-visible (get-selection-visible)) + (send pb set-scroll-step (get-scroll-step)))) + + ;; ---------------------------------------- + + (def/override (get-descent) 0.0) + (def/override (get-space) 0.0) + + (define/private (get-center) + (let-boxes ([x 0.0] + [y 0.0] + [w 0.0] + [h 0.0]) + (if (not s-admin) + (begin + (set-box! w total-width) + (set-box! h total-height)) + (send s-admin get-view x y w h #t)) + (let ([w (if (w . > . 1000.0) + 500.0 ; don't belive it + w)] + [h (if (h . > . 1000.0) + 500.0 ; don't belive it + h)]) + (values (/ w 2) + (/ h 2))))) + + ;; ---------------------------------------- + + (def/override (get-flattened-text) + (let ([p (open-output-string)]) + (let loop ([s snips]) + (when s + (display (send s get-text 0 (snip->count s) #t) p) + (loop (snip->next s)))) + (get-output-string p))) + + (def/override (clear) (delete)) + + (def/override (cut [any? [extend? #f]] [exact-integer? [time 0]]) + (copy extend? time) + (clear)) + + (def/override (do-copy [exact-integer? time] [bool? extend?]) + (set-common-copy-region-data! #f) + (let ([sl (if (and extend? + copy-style-list) + copy-style-list + s-style-list)]) + (let loop ([snip snips]) + (when snip + (let ([loc (snip-loc snip)]) + (when (loc-selected? loc) + (let ([asnip (send snip copy)]) + (send asnip set-admin #f) + (set-snip-style! asnip (send sl convert (snip->style asnip))) + (cons-common-copy-buffer! asnip) + (cons-common-copy-buffer2! (get-snip-data snip))))) + (loop (snip->next snip)))) + (install-copy-buffer time sl))) + + (def/override (copy [bool? extend?] [exact-integer? time]) + (begin-copy-buffer) + (when (not extend?) + (free-old-copies)) + (do-copy time extend?) + (end-copy-buffer)) + + (define/private (do-generic-paste cb time) + (unless (or s-user-locked? + (positive? write-locked)) + (let-values ([(start) snips] + [(cx cy) (get-center)]) + + (do-buffer-paste cb time) + + (if (and s-admin + (not (eq? snips start))) + (let ([dc (get-dc)]) + (when dc + ;; get top/left/bottom/right of pasted group: + (let loop ([snip snips] + [left +inf.0] + [top +inf.0] + [right -inf.0] + [bottom -inf.0]) + (if (eq? snip start) + (let ([dx (- cx (/ (left + right) 2))] + [dy (- cy (/ (top + bottom) 2))]) + ;; shift the pasted group to center: + (move dx dy)) + (let ([loc (snip-loc snip)]) + (add-selected snip) + (when (loc-need-resize? loc) + (loc-resize loc dc)) + (loop (snip->next snip) + (min (loc-x loc) left) + (min (loc-y loc) top) + (max (loc-r loc) right) + (max (loc-b loc) bottom))))))) + ;; just select them: + (let loop ([snip snips]) + (unless (eq? snip start) + (add-selected snip) + (loop (snip->next snip)))))))) + + (def/override (do-paste [exact-integer? time]) + (do-generic-paste the-clipboard time)) + + (def/override (do-paste-x-selection [exact-integer? time]) + (do-generic-paste the-x-selection-clipboard time)) + + (define/private (generic-paste x-sel? time) + (unless (or s-user-locked? + (positive? write-locked)) + (begin-edit-sequence) + (no-selected) + (if x-sel? + (do-paste-x-selection time) + (do-paste time)) + (end-edit-sequence))) + + (def/override (paste [exact-integer? time]) + (generic-paste #f time)) + + (def/override (paste-x-selection [exact-integer? time]) + (generic-paste #t time)) + + (define/override (insert-paste-snip snip data) + (insert snip snip) + (set-snip-data snip data)) + + (define/override (insert-paste-string str) + (let ([snip (new string-snip%)]) + (set-snip-style! snip (or (get-default-style) + (send s-style-list basic-style))) + (send snip insert str) + (insert-paste-snip snip #f))) + + (def/override (kill [exact-integer? time]) + (cut time)) + + (define/override (own-x-selection on? update? force?) + (do-own-x-selection on? force?)) + + ;; ---------------------------------------- + + (def/override (get-snip-location [snip% thesnip] + [maybe-box? [x #f]] + [maybe-box? [y #f]] + [bool? [bottom-right? #f]]) + (if (and bottom-right? + (not s-admin)) + #f + (begin + (when bottom-right? + (check-recalc)) + + (let ([loc (snip-loc thesnip)]) + (and loc + (begin + (when x (set-box! x (+ (loc-x loc) + (if bottom-right? + (loc-w loc) + 0.0)))) + (when y (set-box! y (+ (loc-y loc) + (if bottom-right? + (loc-h loc) + 0.0)))) + #t)))))) + + ;; ---------------------------------------- + + (def/override (get-snip-data [snip% snip]) + (let ([loc (snip-loc snip)] + [sup (super get-snip-data snip)]) + (if (not loc) + sup + (let ([data (new location-editor-data% + [x (loc-x loc)] + [y (loc-y loc)])]) + (send data set-next sup) + data)))) + + (def/override (set-snip-data [snip% snip] [editor-data% data]) + (let loop ([data data]) + (when data + (let ([c (send data get-dataclass)]) + (when c + (let ([name (send c get-classname)]) + (when (equal? name "wxloc") + (move-to snip (send data get-x) (send data get-y)))))) + (loop (send data get-next))))) + + (def/override (insert-port [input-port? f] + [(symbol-in guess same copy standard text text-force-cr) [format 'guess]] + [any? [replace-styles? #f]]) + (if (or s-user-locked? + (not (zero? write-locked))) + 'guess ;; FIXME: docs say that this is more specific + (do-insert-file (method-name 'pasteboard% 'insert-file) f replace-styles?))) + + (define/private (do-insert-file who f clear-styles?) + (when (not (detect-wxme-file who f #f)) + (error who "not a WXME file")) + (let* ([b (make-object editor-stream-in-file-base% f)] + [mf (make-object editor-stream-in% b)]) + (when (not (and (read-editor-version mf b #f #t) + (read-editor-global-header mf) + (send mf ok?) + (read-from-file mf clear-styles?) + (read-editor-global-footer mf) + (begin + ;; if STD-STYLE wasn't loaded, re-create it: + (send s-style-list new-named-style "Standard" (send s-style-list basic-style)) + (send mf ok?)))) + (error who "error loading the file"))) + 'standard) + + (def/override (save-port [output-port? f] + [(symbol-in guess same copy standard text text-force-cr) [format 'same]] + [any? [show-errors? #t]]) + + (let* ([b (make-object editor-stream-out-file-base% f)] + [mf (make-object editor-stream-out% b)]) + (when (not (and (write-editor-version mf b) + (write-editor-global-header mf) + (send mf ok?) + (write-to-file mf) + (write-editor-global-footer mf) + (send mf ok?))) + (error (method-name 'pasteboard% 'save-port) "error writing the file")) + #t)) + + (def/override (write-to-file [editor-stream-out% f]) + (and (do-write-headers-footers f #t) + (write-snips-to-file f s-style-list #f snips #f #f this) + (do-write-headers-footers f #f))) + + (def/override (read-from-file [editor-stream-in% f] [bool? overwritestyle?]) + (if (or s-user-locked? + (not (zero? write-locked))) + #f + (read-snips-from-file f overwritestyle?))) + + (define/override (do-read-insert snip) + (insert snip #f) + #t) + + (def/override (set-filename [(make-or-false path-string?) name][any? [temp? #f]]) + (set! s-filename (if (string? name) + (string->path name) + name)) + (set! s-temp-filename? temp?) + (let loop ([snip snips]) + (when snip + (when (has-flag? (snip->flags snip) USES-BUFFER-PATH) + ;; just a notification + (send snip set-admin snip-admin)) + (loop (snip->next snip))))) + + ;; ---------------------------------------- + + (def/override (style-has-changed [(make-or-false style<%>) style]) + (when (not style) + (set! changed? #t) + (update-all))) + + ;; ---------------------------------------- + + (def/override (begin-edit-sequence [any? [undoable? #t]] [any? [interrupt-seqs? #t]]) + (wait-sequence-lock) + (when (or (positive? s-noundomode) + (not undoable?)) + (set! s-noundomode (add1 s-noundomode))) + (when (and (zero? sequence) + (zero? write-locked)) + (on-edit-sequence)) + (set! sequence (add1 sequence))) + + (def/override (end-edit-sequence) + (set! sequence (sub1 sequence)) + (when (and (zero? sequence) + (zero? write-locked)) + (set! sequence-streak? #f) + (update-needed) + (after-edit-sequence)) + (when (positive? s-noundomode) + (set! s-noundomode (sub1 s-noundomode))) + (when (and (zero? sequence) + s-need-on-display-size?) + (set! s-need-on-display-size? #f) + (on-display-size))) + + (def/override (refresh-delayed?) + (or (positive? sequence) + (not s-admin) + (send s-admin delay-refresh?))) + + (def/override (in-edit-sequence?) + (positive? sequence)) + + (def/override (locations-computed?) + (not need-resize?)) + + ;; ---------------------------------------- + + (def/public (get-dragable) dragable?) + + (def/public (set-dragable [bool? d?]) + (set! dragable? d?)) + + (def/public (get-selection-visible) selection-visible?) + + (def/public (set-selection-visible [bool? v]) + (set! selection-visible? v)) + + ;; ---------------------------------------- + + (def/public (can-insert? [snip% a] [(make-or-false snip%) b] [real? x] [real? y]) + #t) + (def/public (on-insert [snip% a] [(make-or-false snip%) b] [real? x] [real? y]) + (void)) + (def/public (after-insert [snip% a] [(make-or-false snip%) b] [real? x] [real? y]) + (void)) + + (def/public (can-delete? [snip% s]) + #t) + (def/public (on-delete [snip% s]) + (void)) + (def/public (after-delete [snip% s]) + (void)) + + (def/public (can-move-to? [snip% s] [real? x] [real? y] [bool? dragging?]) + #t) + (def/public (on-move-to [snip% s] [real? x] [real? y] [bool? dragging?]) + (void)) + (def/public (after-move-to [snip% s] [real? x] [real? y] [bool? dragging?]) + (void)) + + (def/public (can-resize? [snip% s] [real? w] [real? h]) + #t) + (def/public (on-resize [snip% s] [real? w] [real? h]) + (void)) + (def/public (after-resize [snip% s] [real? w] [real? h] [any? resized?]) + (void)) + + (def/public (can-select? [snip% s] [bool? on?]) + #t) + (def/public (on-select [snip% s] [bool? on?]) + (void)) + (def/public (after-select [snip% s] [bool? on?]) + (void)) + + (def/public (can-reorder? [snip% s] [(make-or-false snip%) other] [bool? before?]) + #t) + (def/public (on-reorder [snip% s] [(make-or-false snip%) other] [bool? before?]) + (void)) + (def/public (after-reorder [snip% s] [(make-or-false snip%) other] [bool? before?]) + (void)) + + (def/public (can-interactive-move? [mouse-event% e]) + #t) + (def/public (on-interactive-move [mouse-event% e]) + (void)) + (def/public (after-interactive-move [mouse-event% e]) + (void)) + + (def/public (can-interactive-resize? [snip% s]) + #t) + (def/public (on-interactive-resize [snip% s]) + (void)) + (def/public (after-interactive-resize [snip% s]) + (void)) + + (define/override (do-begin-print dc fit?) + (size-cache-invalid) + (set! write-locked (add1 write-locked)) + (on-change) + (set! write-locked (sub1 write-locked)) + #f) + + (define/override (do-end-print dc data) + (size-cache-invalid) + (set! write-locked (add1 write-locked)) + (on-change) + (set! write-locked (sub1 write-locked))) + + (define/override (do-has-print-page? dc page) + (do-has/print-page dc page #f)) + + (def/override (print-to-dc [dc<%> dc] [exact-integer? [page -1]]) + (do-has/print-page dc page #t) + (void)) + + (define/private (do-has/print-page dc page print?) + (check-recalc) + + (let-values ([(w h) (send dc get-size)]) + (let-boxes ([w w] + [h h] + [hm 0] + [vm 0]) + (begin + (when (or (zero? (unbox w)) + (zero? (unbox h))) + (get-default-print-size w h)) + (send (current-ps-setup) get-editor-marginhm vm)) + (let ([W (- w (* 2 hm))] + [H (- h (* 2 vm))]) + (let-boxes ([w 0.0] + [h 0.0]) + (get-extent w h) + + (let ([hcount (->long (ceiling (/ W w)))] + [vcount (->long (ceiling (/ H h)))]) + + (if (not print?) + (page . <= . (* hcount vcount)) + (let-values ([(start end) + (if (negative? page) + (values 1 (* hcount vcount)) + (values page page))]) + (for ([p (in-range start end)]) + (let ([vpos (quotient (- p 1) hcount)] + [hpos (modulo (- p 1) hcount)]) + (let ([x (* hpos w)] + [y (* vpos h)]) + (when (negative? page) + (send dc start-page) + + (draw dc (+ (- x) hm) (+ (- y) vm) + x y (+ x w) (+ y h) + #f + #f) + (when (negative? page) + (send dc end-page)))))))))))))) + + ;; ---------------------------------------- + ) + +(set-pasteboard%! pasteboard%) + +;; ------------------------------------------------------------ + +(define/top (add-pasteboard-keymap-functions [keymap% tab]) + (void)) diff --git a/collects/mred/private/wxme/private.ss b/collects/mred/private/wxme/private.ss new file mode 100644 index 00000000..816cf7c2 --- /dev/null +++ b/collects/mred/private/wxme/private.ss @@ -0,0 +1,140 @@ +#lang scheme/base +(require scheme/class) + +(provide (all-defined-out)) + +;; snip% and editor% +(define-local-member-name + s-admin) + +;; snip% +(define-local-member-name + s-prev set-s-prev + s-next set-s-next + s-count + s-style set-s-style + s-line set-s-line + s-snipclass set-s-snipclass + s-flags set-s-flags + s-dtext get-s-dtext + s-buffer get-s-buffer + str-w set-str-w + s-set-flags + do-copy-to) + +;; string-snip% +(define-local-member-name + insert-with-offset) + +;; snip-class% +(define-local-member-name + get-s-required?) + +;; editor-data% +(define-local-member-name + get-s-dataclass + get-s-next) + +;; standard-snip-class-list%, editor-data-class-list% +(define-local-member-name + reset-header-flags + find-by-map-position) + +;; editor% +(define-local-member-name + s-offscreen + s-custom-cursor + s-custom-cursor-overrides? + s-keymap + s-style-list + get-s-style-list + s-user-locked? + s-modified? + s-noundomode + s-caret-snip + s-inactive-caret-threshold + s-filename + s-need-on-display-size? + really-can-edit? + copy-out-x-selection + own-x-selection + do-own-x-selection + perform-undo-list + copy-ring-next + begin-copy-buffer + end-copy-buffer + free-old-copies + install-copy-buffer + add-undo-rec + read-snips-from-file + admin-scroll-to + do-buffer-paste + insert-paste-snip + insert-paste-string + paste-region-data + setting-admin + init-new-admin + do-read-insert + do-set-caret-owner + do-own-caret + s-start-intercept + s-end-intercept + wait-sequence-lock + begin-sequence-lock + end-sequence-lock + check-flow + get-printing + is-printing? + do-begin-print + do-end-print + do-has-print-page?) + +;; text% +(define-local-member-name + get-s-line-spacing + get-s-last-snip + get-s-total-width + get-s-total-height + refresh-box + add-back-clickback + do-insert-snips) + +;; editor-admin% +(define-local-member-name + get-s-standard + set-s-standard) + +;; editor-canvas-editor-admin% +(define-local-member-name + do-get-canvas) + +;; editor-stream% +(define-local-member-name + get-sl + get-dl + set-sl + set-dl + add-sl + add-dl + set-s-sll + get-s-sll + get-s-scl + get-s-bdl + get-s-style-count + set-s-style-count + do-reading-version + do-map-position + do-get-header-flag + do-set-header-flag) + +;; editor-stream-in% +(define-local-member-name + set-s-read-format + get-s-read-format + set-s-read-version + get-wxme-version) + +;; editor-snip% +(define-local-member-name + do-set-graphics) + diff --git a/collects/mred/private/wxme/snip-admin.ss b/collects/mred/private/wxme/snip-admin.ss new file mode 100644 index 00000000..73a23f3a --- /dev/null +++ b/collects/mred/private/wxme/snip-admin.ss @@ -0,0 +1,147 @@ +#lang scheme/base +(require scheme/class + "../syntax.ss" + "snip.ss" + (only-in "cycle.ss" + set-snip-admin%! + popup-menu%) + "wx.ss") + +(provide snip-admin% + standard-snip-admin%) + +(defclass snip-admin% object% + (super-new) + + (def/public (get-editor) #f) + (def/public (get-dc) #f) + (def/public (get-view-size [maybe-box? w] [maybe-box? h]) + #f) + + (def/public (get-view [maybe-box? x] [maybe-box? y] [maybe-box? w] [maybe-box? h] + [(make-or-false snip%) snip]) + #f) + + (def/public (scroll-to [snip% s] + [real? x] [real? y] + [nonnegative-real? w] [nonnegative-real? h] + [any? refresh?] + [(symbol-in start end none) [bias 'none]]) + #f) + + (def/public (set-caret-owner [snip% s] [(symbol-in imeditorte display global) dist]) + (void)) + + (def/public (resized [snip% s] [any? redraw?]) (void)) + + (def/public (recounted [snip% s] [any? redraw?]) (void)) + + (def/public (needs-update [snip% s] [real? x] [real? y] + [nonnegative-real? w] [nonnegative-real? h]) + (void)) + + (def/public (release-snip [snip% s]) #f) + + (def/public (update-cursor) (void)) + + (def/public (popup-menu [popup-menu% p][snip% snip][real? x][real? y]) + #f) + + (def/public (modified [snip% s] [any? modified?]) + (void))) + +(set-snip-admin%! snip-admin%) + +(defclass standard-snip-admin% snip-admin% + (init-field editor) + + (super-new) + + (def/override (get-editor) editor) + (def/override (get-dc) (send editor get-dc)) + (def/override (get-view-size [maybe-box? w] [maybe-box? h]) + (get-view #f #f w h #f)) + + (def/override (get-view [maybe-box? x] [maybe-box? y] [maybe-box? w] [maybe-box? h] + [(make-or-false snip%) snip]) + (let ([admin (send editor get-admin)] + [zeros (lambda () + (when x (set-box! x 0.0)) + (when y (set-box! y 0.0)) + (when w (set-box! w 0.0)) + (when h (set-box! h 0.0)))]) + (if snip + (if admin + (let-boxes ([mx 0.0] [my 0.0] + [mw 0.0] [mh 0.0]) + (send admin get-view mx my mw mh #f) + (let ([mb (+ my mh)] + [mr (+ mx mw)]) + (let-boxes ([ok? #f] + [sl 0.0] + [st 0.0]) + (set-box! ok? (send editor get-snip-location snip sl st #f)) + (if ok? + (let-boxes ([sr 0.0][sb 0.0]) + (send editor get-snip-location snip sr sb #t) + (let ([l (max mx sl)] + [t (max my st)] + [r (min mr sr)] + [b (min mb sb)]) + (when x (set-box! x (- l sl))) + (when y (set-box! y (- t st))) + (when w (set-box! w (max 0 (- r l)))) + (when h (set-box! h (max 0 (- b t)))))) + (zeros))))) + (zeros)) + (if admin + (send admin get-view x y w h #t) + (zeros))))) + + (def/override (scroll-to [snip% s] + [real? localx] [real? localy] + [nonnegative-real? w] [nonnegative-real? h] + [any? [refresh? #t]] + [(symbol-in start end none) [bias 'none]]) + (and (eq? (send s get-admin) this) + (send editor scroll-to s localx localy w h refresh? bias))) + + (def/override (set-caret-owner [snip% s] [(symbol-in imeditorte display global) dist]) + (when (eq? (send s get-admin) this) + (send editor set-caret-owner s dist))) + + (def/override (resized [snip% s] [any? redraw?]) + (when (eq? (send s get-admin) this) + (send editor resized s redraw?))) + + (def/override (recounted [snip% s] [any? redraw?]) + (when (eq? (send s get-admin) this) + (send editor recounted s redraw?))) + + (def/override (needs-update [snip% s] [real? localx] [real? localy] + [nonnegative-real? w] [nonnegative-real? h]) + (when (eq? (send s get-admin) this) + (send editor needs-update s localx localy w h))) + + (def/override (release-snip [snip% s]) + (and (eq? (send s get-admin) this) + (send editor release-snip s))) + + (def/override (update-cursor) + (let ([admin (send editor get-admin)]) + (when admin + (send admin update-cursor)))) + + (def/override (popup-menu [popup-menu% m][snip% snip][real? x][real? y]) + (let ([admin (send editor get-admin)]) + (and admin + (let-boxes ([sl 0.0] + [st 0.0] + [ok? #f]) + (set-box! ok? (send editor get-snip-location snip sl st #f)) + (and ok? + (send admin popup-menu m (+ x sl) (+ y st))))))) + + (def/override (modified [snip% s] [any? modified?]) + (when (eq? (send s get-admin) this) + (send editor on-snip-modified s modified?)))) \ No newline at end of file diff --git a/collects/mred/private/wxme/stream.ss b/collects/mred/private/wxme/stream.ss new file mode 100644 index 00000000..10aa45c1 --- /dev/null +++ b/collects/mred/private/wxme/stream.ss @@ -0,0 +1,761 @@ +#lang scheme/base +(require scheme/class + "../syntax.ss" + "private.ss" + "snip.ss" + (only-in "cycle.ss" + set-editor-stream-in%! + set-editor-stream-out%!)) + +(provide editor-stream-in% + editor-stream-out% + editor-stream-in-base% + editor-stream-in-bytes-base% + editor-stream-in-file-base% + editor-stream-out-base% + editor-stream-out-bytes-base% + editor-stream-out-file-base%) + +;; ---------------------------------------- + +(defclass editor-stream% object% + + (super-new) + + (define scl (get-the-snip-class-list)) + (define bdl (get-the-editor-data-class-list)) + (define/public (get-s-scl) scl) + (define/public (get-s-bdl) bdl) + + (define sl null) + (define dl null) + + (define/public (get-sl) sl) + (define/public (get-dl) dl) + (define/public (set-sl n) (set! sl n)) + (define/public (set-dl n) (set! dl n)) + (define/public (add-sl v) (set! sl (cons v sl))) + (define/public (add-dl v) (set! dl (cons v dl))) + + (define sll null) + (define style-count 0) + (define/public (get-s-sll) sll) + (define/public (set-s-sll v) (set! sll v)) + (define/public (get-s-style-count) style-count) + (define/public (set-s-style-count v) (set! style-count v)) + + (define/public (do-reading-version sclass) + (or (ormap (lambda (scl) + (and (eq? (snip-class-link-c scl) sclass) + (snip-class-link-reading-version scl))) + sl) + ;; Class didn't show up in the header? + ;; Assume we're reading the current version. + (send sclass get-version))) + + (define/public (do-map-position sclass-or-dclass) + (if (sclass-or-dclass . is-a? . snip-class%) + (or (ormap (lambda (scl) + (and (eq? (snip-class-link-c scl) sclass-or-dclass) + (snip-class-link-map-position scl))) + sl) + -1) + (or (ormap (lambda (dcl) + (and (eq? (editor-data-class-link-c dcl) sclass-or-dclass) + (editor-data-class-link-map-position dcl))) + dl) + -1))) + + (define/public (do-get-header-flag sclass) + (or (ormap (lambda (scl) + (and (eq? (snip-class-link-c scl) sclass) + (snip-class-link-header-flag scl))) + sl) + 0)) + + (define/public (do-set-header-flag sclass) + (ormap (lambda (scl) + (and (eq? (snip-class-link-c scl) sclass) + (begin + (set-snip-class-link-header-flag! scl #t) + #t))) + sl) + (void))) + +;; ---------------------------------------- + +(defclass editor-stream-in-base% object% + (super-new) + (def/public (tell) 0) + (def/public (seek [exact-nonnegative-integer? i]) (void)) + (def/public (skip [exact-nonnegative-integer? i]) (void)) + (def/public (bad?) #t) + (def/public (read [vector? v]) + (let ([s (make-bytes (vector-length v))]) + (let ([n (read-bytes s)]) + (for ([i (in-range n)]) + (vector-set! v i (integer->char (bytes-ref s i)))) + n))) + (def/public (read-bytes [bytes? v] + [exact-nonnegative-integer? [start 0]] + [exact-nonnegative-integer? [end (bytes-length v)]]) + 0)) + +(defclass editor-stream-out-base% object% + (super-new) + (def/public (tell) 0) + (def/public (seek [exact-nonnegative-integer? i]) (void)) + (def/public (skip [exact-nonnegative-integer? i]) (void)) + (def/public (bad?) #t) + (def/public (write [(make-list char?) v]) + (write-bytes (string->bytes/latin-1 (list->string v) (char->integer #\?)))) + (def/public (write-bytes [bytes? v] + [exact-nonnegative-integer? [start 0]] + [exact-nonnegative-integer? [end (bytes-length v)]]) + (void))) + +;; ---------------------------------------- + +(defclass editor-stream-in-port-base% editor-stream-in-base% + (init-field port) + (super-new) + + (def/override (tell) + (file-position port)) + + (def/override (seek [exact-nonnegative-integer? i]) + (file-position port i)) + + (def/override (skip [exact-nonnegative-integer? i]) + (file-position port (+ i (file-position port)))) + + (def/override (bad?) #f) + + (def/override (read-bytes [bytes? v] + [exact-nonnegative-integer? [start 0]] + [exact-nonnegative-integer? [end (bytes-length v)]]) + (let ([r (read-bytes! v port start end)]) + (if (eof-object? r) + 0 + r)))) + +(defclass editor-stream-in-file-base% editor-stream-in-port-base% + (super-new)) + +(defclass editor-stream-in-bytes-base% editor-stream-in-port-base% + (init s) + (super-new [port (open-input-bytes s)])) + +;; ---------------------------------------- + +(define write-bytes-proc write-bytes) + +(defclass editor-stream-out-port-base% editor-stream-out-base% + (init-field port) + (super-new) + + (def/override (tell) + (file-position port)) + + (def/override (seek [exact-nonnegative-integer? i]) + (file-position port i)) + + (def/override (skip [exact-nonnegative-integer? i]) + (file-position port (+ i (file-position port)))) + + (def/override (bad?) #f) + + (def/override (write-bytes [bytes? v] + [exact-nonnegative-integer? [start 0]] + [exact-nonnegative-integer? [end (bytes-length v)]]) + (write-bytes-proc v port start end))) + +(defclass editor-stream-out-file-base% editor-stream-out-port-base% + (super-new)) + +(defclass editor-stream-out-bytes-base% editor-stream-out-port-base% + (define s (open-output-bytes)) + (super-new [port s]) + + (def/public (get-bytes) + (get-output-bytes s))) + +;; ---------------------------------------- + +(defclass editor-stream-in% editor-stream% + (init-rest args) + + (define f + (case-args + args + [([editor-stream-in-base% base]) base] + (init-name 'editor-stream-in%))) + + (define boundaries null) + (define is-bad? #f) + (define items 0) + (define pos-map (make-hash)) + + (define read-version 8) + (define s-read-version #"08") + + (super-new) + + (define/public (set-s-read-version bstr) + (set! s-read-version bstr) + (set! read-version (or (string->number (bytes->string/utf-8 bstr)) 0))) + (define/public (get-wxme-version) read-version) + + (define s-read-format #"WXME") + (define/public (set-s-read-format bstr) + (set! s-read-format bstr)) + (define/public (get-s-read-format) + s-read-format) + + (define/private (do-skip-whitespace) + (define (bad!) (set! is-bad? #t) 0) + (if is-bad? + 0 + (let ([s (make-bytes 1)]) + (let loop ([prev-byte 0]) + (if (not (= 1 (send f read-bytes s))) + (bad!) + (let ([b (bytes-ref s 0)]) + (case (integer->char b) + [(#\#) + (let ([pos (send f tell)]) + (if (and (= 1 (send f read-bytes s)) + (= (bytes-ref s 0) (char->integer #\|))) + ;; skip to end of comment + (let cloop ([saw-bar? #f] + [saw-hash? #f] + [nesting 0]) + (if (not (= 1 (send f read-bytes s))) + (bad!) + (cond + [(and saw-bar? (= (bytes-ref s 0) (char->integer #\#))) + (if (zero? nesting) + (loop (char->integer #\space)) + (cloop #f #f (sub1 nesting)))] + [(and saw-hash? (= (bytes-ref s 0) (char->integer #\|))) + (cloop #t #f (add1 nesting))] + [else (cloop (= (bytes-ref s 0) (char->integer #\|)) + (= (bytes-ref s 0) (char->integer #\#)) + nesting)]))) + (begin + (send f seek pos) + (char->integer #\#))))] + [(#\;) + ;; skip to end of comment + (let cloop () + (if (not (= 1 (send f read-bytes s))) + (bad!) + (if (or (= (bytes-ref s 0) (char->integer #\newline)) + (= (bytes-ref s 0) (char->integer #\return))) + (loop (char->integer #\space)) + (cloop))))] + [else + (if (char-whitespace? (integer->char b)) + (loop b) + b)]))))))) + + (define/private (skip-whitespace [buf #f]) + (let ([c (do-skip-whitespace)]) + (when buf + (bytes-set! buf 0 c)) + c)) + + (define/private (is-delim? b) + (cond + [(char-whitespace? (integer->char b)) #t] + [(= b (char->integer #\#)) + (let ([pos (send f tell)] + [s (make-bytes 1)]) + (send f read-bytes s) + (let ([d? (= (bytes-ref s 0) (char->integer #\|))]) + (send f seek (if d? (sub1 pos) pos)) + d?))] + [(= b (char->integer #\;)) + (send f seek (sub1 (send f tell))) + #t] + [else #f])) + + (define/private (get-number get-exact?) + (let ([c0 (skip-whitespace)]) + (if (check-boundary) + (if get-exact? 0 0.0) + (let* ([s (make-bytes 1)] + [l (cons (integer->char c0) + (let loop ([counter 50]) + (if (zero? counter) + null + (if (= 1 (send f read-bytes s)) + (let ([s (bytes-ref s 0)]) + (if (is-delim? s) + null + (cons (integer->char s) + (loop (sub1 counter))))) + null))))]) + (inc-item-count) + (let ([n (string->number (list->string l))]) + (cond + [(or (not n) + (not (real? n)) + (and get-exact? (not (exact-integer? n)))) + (set! is-bad? #t) + (if get-exact? 0 0.0)] + [get-exact? n] + [else + (exact->inexact n)])))))) + + (define/private (get-a-string limit recur?) + (let* ([orig-len (if recur? + (if (limit . < . 16) + limit + 16) + (get-exact))] + [buf (make-bytes 32)] + [fail (lambda () + (set! is-bad? #t) + #"")]) + (if recur? + (bytes-set! buf 0 (char->integer #\#)) + (begin + (skip-whitespace buf) + (when is-bad? + (bytes-set! buf 0 0)))) + (cond + [(= (bytes-ref buf 0) (char->integer #\#)) + (if (and (= (send f read-bytes buf 1 2) 1) + (= (bytes-ref buf 1) (char->integer #\"))) + (let-values ([(si s) (make-pipe)] + [(tmp) (make-bytes (+ orig-len 2))]) + (display "#\"" s) + (let loop ([get-amt (add1 orig-len)]) ;; add 1 for closing quote + (let ([got-amt (send f read-bytes tmp 0 get-amt)]) + (if (not (= got-amt get-amt)) + (fail) + (begin + (write-bytes tmp s 0 got-amt) + (let ([done? + (let loop ([i 0]) + (cond + [(= i got-amt) #f] + [(= (bytes-ref tmp i) (char->integer #\")) #t] + [(= (bytes-ref tmp i) (char->integer #\\)) + (if (= (add1 i) got-amt) + ;; need to read escaped character + (if (not (= (send f read-bytes tmp got-amt (add1 got-amt)) 1)) + (fail) + (begin + (write-bytes tmp s got-amt (add1 got-amt)) + #f)) + (loop (+ i 2)))] + [else (loop (+ i 1))]))]) + (if done? + (begin + (close-output-port s) + (unless recur? (inc-item-count)) + (let ([s (with-handlers ([exn:fail:read? (lambda (x) #f)]) + (read si))]) + (if (or (not s) + (not (eof-object? (read-byte si)))) + (fail) + (if (if recur? + ((bytes-length s) . <= . limit) + (= (bytes-length s) orig-len)) + s + (fail))))) + (loop 1)))))))) + (fail))] + [(and (not recur?) (= (bytes-ref buf 0) (char->integer #\())) + ;; read a sequence of strings + (let loop ([accum null] + [left-to-get orig-len]) + (skip-whitespace buf) + (if (or is-bad? + (negative? left-to-get)) + (fail) + (cond + [(= (bytes-ref buf 0) (char->integer #\))) + ;; got all byte strings + (if (zero? left-to-get) + (begin + (inc-item-count) + (apply bytes-append (reverse accum))) + (fail))] + [(= (bytes-ref buf 0) (char->integer #\#)) + (let ([v (get-a-string left-to-get #t)]) + (if is-bad? + (fail) + (loop (cons v accum) + (- left-to-get (bytes-length v)))))] + [else (fail)])))] + [else (fail)]))) + + (define/private (inc-item-count) + (set! items (add1 items)) + (tell)) + + (define/private (skip-one recur?) + (let ([buf (make-bytes 1)] + [fail (lambda () (set! is-bad? #t) (void))] + [success (lambda () (unless recur? (inc-item-count)))]) + (if recur? + (bytes-set! buf 0 (char->integer #\#)) + (skip-whitespace buf)) + (unless is-bad? + (cond + [(= (bytes-ref buf 0) (char->integer #\#)) + ;; byte string + (if (and (= 1 (send f read-bytes buf)) + (= (bytes-ref buf 0) (char->integer #\"))) + (let loop () + (if (= 1 (send f read-bytes buf)) + (cond + [(= (bytes-ref buf 0) (char->integer #\\)) + (if (= 1 (send f read-bytes buf)) + (loop) + (fail))] + [(= (bytes-ref buf 0) (char->integer #\")) + (success)] + [else (loop)]) + (fail))) + (fail))] + [(= (bytes-ref buf 0) (char->integer #\))) + ;; list of byte strings + (let loop () + (if is-bad? + (fail) + (if (not (= (send f read-bytes buf) 1)) + (fail) + (if (is-delim? (bytes-ref buf 0)) + (cond + [(= (bytes-ref buf 0) (char->integer #\))) + (success)] + [(= (bytes-ref buf 0) (char->integer #\#)) + (skip-one #t) + (loop)] + [else (fail)]) + (loop)))))] + [else + ;; number -- skip anything delimited + (let loop () + (if (not (= (send f read-bytes buf) 1)) + (fail) + (if (is-delim? (bytes-ref buf 0)) + (success) + (loop))))])))) + + (def/public (get-fixed [box? vb]) + (let ([v (if (check-boundary) + 0 + (if (read-version . < . 8) + (let ([buf (make-bytes 4)]) + (send f read-bytes buf) + (integer-bytes->integer + buf + #t + (if (= read-version 1) + (system-big-endian?) + #t))) + (get-exact)))]) + (set-box! vb v))) + + #| + integer format specified by first byte: + bit 8: 0 - read 7-bit (positive) number + bit 8: 1 - ... + bit 7: 0 - read abother byte for 15-bit (positive) number + bit 7: 1 - negative and long numbers... + bit 1: 1 - read another 8-bit (signed) number + bit 1: 0 - ... + bit 2: 1 - read another 16-bit (signed) number + bit 2: 0 - read another 32-bit (signed) number + |# + + (def/public (get-exact) + (if (check-boundary) + 0 + (if (read-version . < . 8) + (let ([buf (make-bytes 4)] + [fail (lambda () (set! is-bad? #t) 0)]) + (if (not (= 1 (send f read-bytes buf 0 1))) + (fail) + (let ([b (bytes-ref buf 0)]) + (if (positive? (bitwise-and b #x80)) + (if (positive? (bitwise-and b #x40)) + (cond + [(positive? (bitwise-and b #x01)) + (if (= 1 (send f read-bytes buf 0 1)) + (let ([b (bytes-ref buf 0)]) + (if (b . > . 127) + (- b 256) + b)) + (fail))] + [(positive? (bitwise-and b #x02)) + (if (= 2 (send f read-bytes buf 0 2)) + (integer-bytes->integer b #t #t) + (fail))] + [else + (if (= 4 (send f read-bytes buf 0 2)) + (integer-bytes->integer buf #t #t) + (fail))]) + (if (= 1 (send f read-bytes buf 0 1)) + (+ (arithmetic-shift (bitwise-and b #x3F) 8) + (bytes-ref buf 0)) + (fail))) + b)))) + (get-number #t)))) + + (def/public (get-inexact) + (if (check-boundary) + 0 + (if (read-version . < . 8) + (let ([buf (make-bytes 8)]) + (send f read-bytes buf) + (floating-point-bytes->real + buf + (if (= read-version 1) + (system-big-endian?) + #t))) + (get-number #f)))) + + (define/private (do-get-bytes) + (if (check-boundary) + #"" + (if (read-version . < . 8) + (let* ([len (get-exact)] + [s (make-bytes len)]) + (send f read-bytes s) + s) + (get-a-string #f #f)))) + + (def/public (get-bytes [maybe-box? [len #f]]) + (let ([s (do-get-bytes)]) + (when len + (set-box! len (max 1 (bytes-length s)))) + (subbytes s 0 (max 0 (sub1 (bytes-length s)))))) + + (def/public (get-unterminated-bytes [maybe-box? [len #f]]) + (let ([s (do-get-bytes)]) + (when len + (set-box! len (bytes-length s))) + s)) + + (def/public (get-unterminated-bytes! [(make-box exact-nonnegative-integer?) len] + [(lambda (s) (and (bytes? s) (not (immutable? s)))) s]) + (let ([s2 (do-get-bytes)]) + (if ((bytes-length s2) . <= . (unbox len)) + (begin + (bytes-copy! s 0 s2) + (set-box! len (bytes-length s2))) + (set! is-bad? #t)))) + + (def/public (get [(make-box real?) b]) + (unless (check-boundary) + (if (exact-integer? (unbox b)) + (set-box! b (get-exact)) + (set-box! b (get-inexact))))) + + (def/public (set-boundary [exact-nonnegative-integer? n]) + (set! boundaries (cons (+ (tell) n) boundaries))) + + (def/public (remove-boundary) + (set! boundaries (cdr boundaries))) + + (define/private (check-boundary) + (if is-bad? + #t + (cond + [(and (pair? boundaries) + ((tell) . > . (car boundaries))) + (set! is-bad? #t) + (error 'editor-stream-in% + "overread (caused by file corruption?; ~a vs ~a)" (tell) (car boundaries))] + [(send f bad?) + (set! is-bad? #t) + (error 'editor-stream-in% "stream error")] + [else #f]))) + + (def/public (skip [exact-nonnegative-integer? n]) + (if (read-version . < . 8) + (send f skip n) + (jump-to (+ n items)))) + + (def/public (tell) + (if (read-version . < . 8) + (send f tell) + (let ([pos (send f tell)]) + (hash-set! pos-map items pos) + items))) + + (def/public (jump-to [exact-nonnegative-integer? pos]) + (if (read-version . < . 8) + (send f seek pos) + (let ([p (hash-ref pos-map pos #f)]) + (if (not p) + (begin + (let loop () + (when (and (items . < . pos) (not is-bad?)) + (skip-one #f) + (loop))) + (unless (= items pos) + (set! is-bad? #t))) + (begin + (send f seek p) + (set! items pos)))))) + + (def/public (ok?) (not is-bad?))) + +(set-editor-stream-in%! editor-stream-in%) + +;; ---------------------------------------- + +(defclass editor-stream-out% editor-stream% + (init-rest args) + + (define f + (case-args + args + [([editor-stream-out-base% base]) base] + (init-name 'editor-stream-out%))) + + (define is-bad? #f) + (define col 72) + (define items 0) + (define pos-map (make-hash)) + + (super-new) + + (define/private (check-ok) + (unless is-bad? + (when (send f bad?) + (error 'editor-stream-out% "stream error")))) + + (def/public (put-fixed [exact-integer? v]) + (check-ok) + (let-values ([(new-col spc) + (if ((+ col 12) . > . 72) + (values 11 #"\n") + (values (+ col 12) #" "))]) + (let ([s (number->string v)]) + (send f + write-bytes + (bytes-append spc + (make-bytes (- 11 (string-length s)) (char->integer #\space)) + (string->bytes/latin-1 s)))) + (set! items (add1 items))) + this) + + (define/public (put . args) + (case-args + args + [([exact-nonnegative-integer? n][bytes? s]) + (do-put-bytes (subbytes s 0 n))] + [([bytes? s]) + (do-put-bytes (bytes-append s #"\0"))] + [([exact-integer? n]) + (do-put-number n)] + [([real? n]) + (do-put-number (exact->inexact n))] + (method-name 'editor-stream-out% 'put))) + + (def/public (put-unterminated [bytes? s]) + (do-put-bytes s)) + + (define/private (do-put-bytes orig-s) + (define (single-string) + (if ((bytes-length orig-s) . < . 72) + (let ([s (open-output-bytes)]) + (write orig-s s) + (let* ([v (get-output-bytes s)] + [len (bytes-length v)]) + (if (len . >= . 72) + (multiple-strings) + (begin + (if ((+ col len 1) . > . 72) + (send f write-bytes #"\n") + (send f write-bytes #" ")) + (send f write-bytes v) + (set! col 72))))) ;; forcing a newline after every string makes the file more readable + (multiple-strings))) + (define (multiple-strings) + (send f write-bytes #"\n(") + (let loop ([offset 0][remain (bytes-length orig-s)]) + (unless (zero? remain) + (let lloop ([amt (min 50 remain)][retry? #t]) + (let ([s (open-output-bytes)]) + (write (subbytes orig-s offset (+ offset amt)) s) + (let* ([v (get-output-bytes s)] + [len (bytes-length v)]) + (if (len . <= . 71) + (if (and (len . < . 71) + retry? + (amt . < . remain)) + (lloop (add1 amt) #t) + (begin + (send f write-bytes #"\n ") + (send f write-bytes v) + (loop (+ offset amt) (- remain amt)))) + (lloop (sub1 amt) #f))))))) + (send f write-bytes #"\n)") + (set! col 1)) + + (check-ok) + (do-put-number (bytes-length orig-s)) + (single-string) + (set! items (add1 items)) + this) + + (define/private (do-put-number v) + (check-ok) + (let* ([s (string->bytes/latin-1 (format " ~a" v))] + [len (bytes-length s)]) + (if ((+ col len) . > . 72) + (begin + (set! col (sub1 len)) + (bytes-set! s 0 (char->integer #\newline))) + (set! col (+ col len))) + (send f write-bytes s) + (set! items (add1 items)) + this)) + + (def/public (tell) + (let ([pos (send f tell)]) + (hash-set! pos-map items (cons pos col)) + items)) + + (def/public (jump-to [exact-nonnegative-integer? icount]) + (unless is-bad? + (let ([p (hash-ref pos-map icount #f)]) + (when p + (send f seek (car p)) + (set! col (cdr p)) + (set! items icount))))) + + (def/public (ok?) (not is-bad?)) + + (def/public (pretty-finish) + (unless is-bad? + (when (positive? col) + (send f write-bytes #"\n") + (set! col 0)))) + + (def/public (pretty-start) + (define (show s) + (send f write-bytes (if (string? s) (string->bytes/latin-1 s) s))) + (when (positive? col) + (show #"\n")) + (show #"#|\n This file is in plt scheme editor format.\n") + (show (format " Open this file in dr-scheme version ~a or later to read it.\n" (version))) + (show #"\n") + (show #" Most likely, it was created by saving a program in DrScheme,\n") + (show #" and it probably contains a program with non-text elements\n") + (show #" (such as images or comment boxes).\n") + (show #"\n") + (show #" http://www.plt-scheme.org\n|#\n") + (set! col 0))) + +(set-editor-stream-out%! editor-stream-out%) + diff --git a/collects/mred/private/wxme/text.ss b/collects/mred/private/wxme/text.ss new file mode 100644 index 00000000..037fdfc5 --- /dev/null +++ b/collects/mred/private/wxme/text.ss @@ -0,0 +1,5482 @@ +#lang scheme/base +(require scheme/class + scheme/port + scheme/file + (for-syntax scheme/base) + "../syntax.ss" + "const.ss" + "mline.ss" + "private.ss" + "editor.ss" + "undo.ss" + "style.ss" + "snip.ss" + "snip-flags.ss" + "snip-admin.ss" + "keymap.ss" + (only-in "cycle.ss" set-text%!) + "wordbreak.ss" + "stream.ss" + "wx.ss") + +(provide text% + add-text-keymap-functions) + +;; ---------------------------------------- + +(define flash-timer% + (class timer% + (init editor) + (define for-editor editor) + (super-new) + (define/override (notify) + (send for-editor flash-off)))) + +;; ---------------------------------------- + +(define arrow (make-object cursor% 'arrow)) +(define i-beam (make-object cursor% 'ibeam)) + +(define MAX-COUNT-FOR-SNIP 500) +(define A-VERY-BIG-NUMBER 1e50) + +(define TAB-WIDTH 20.0) + +(define show-outline-for-inactive? + (and (get-preference 'MrEd:outline-inactive-selection) #t)) + +(define caret-pen (send the-pen-list find-or-create-pen "BLACK" 1 'xor)) +(define outline-pen (send the-pen-list find-or-create-pen "BLACK" 0 'transparent)) +(define outline-inactive-pen (send the-pen-list find-or-create-pen "BLACK" 1 'hilite)) +(define outline-brush (send the-brush-list find-or-create-brush "BLACK" 'hilite)) +(define xpattern #"\x88\x88\0\0\x22\x22\0\0\x88\x88\0\0\x22\x22\0\0\x88\x88\0\0\x22\x22\0\0\x88\x88\0\0\x22\x22\0\0") +(define outline-nonowner-brush (let ([b (new brush%)]) + (send b set-color "BLACK") + (send b set-stipple (make-object bitmap% xpattern 16 16)) + (send b set-style 'xor) + b)) +(define clear-brush (send the-brush-list find-or-create-brush "WHITE" 'solid)) + +(define (showcaret>= a b) + (memq a (memq b '(no-caret show-inactive-caret show-caret)))) + +(define-struct clickback (start end f call-on-down? delta hilited? unhilite) #:mutable) + +(defclass text% editor% + (inherit-field s-admin + s-offscreen + s-custom-cursor + s-custom-cursor-overrides? + s-keymap + s-own-caret? + s-style-list + s-user-locked? + s-modified? + s-noundomode + s-caret-snip + s-inactive-caret-threshold + s-filename + s-temp-filename? + s-need-on-display-size?) + (inherit on-change + on-local-event + on-local-char + scroll-editor-to + free-old-copies + install-copy-buffer + begin-copy-buffer + end-copy-buffer + do-buffer-paste + copy-ring-next + do-write-headers-footers + do-set-caret-owner + perform-undo-list + s-start-intercept + s-end-intercept + do-own-x-selection + copy-out-x-selection + add-undo-rec + set-modified + get-default-style + get-snip-data + set-snip-data + read-snips-from-file + on-paint + on-focus + default-style-name + wait-sequence-lock + begin-sequence-lock + end-sequence-lock + do-own-caret + on-edit-sequence + after-edit-sequence + on-display-size) + + (define is-locked-for-read? #f) + (define is-locked-for-flow? #f) + (define is-locked-for-write? #f) + + (define read-locked? #f) + (define flow-locked? #f) + (define write-locked? #f) + + (define hilite-on? #t) + + (define changed? #f) ;; set if on-change() needs to be called + + (define flash? #f) + (define flashautoreset? #f) + (define flashdirectoff? #f) + + (define posateol? #f) ;; display the caret at the end of a line? + (define flashposateol? #f) + (define flashscroll? #f) ;; scroll back after unflashing? + + (define graphics-invalid? #f) + (define flow-invalid? #f) + (define snip-cache-invalid? #f) + (define graphic-maybe-invalid? #f) + (define graphic-maybe-invalid-force? #f) + + (define typing-streak? #f) + (define deletion-streak? #f) + (define delayed-streak? #f) + (define vcursor-streak? #f) + (define kill-streak? #f) + (define anchor-streak? #f) + (define extend-streak? #f) + (define insert-force-streak? #f) + (define delete-force-streak? #f) + + (define keep-anchor-streak? #f) + + (define streaks-pushed? #f) + (define save-typing-streak? #f) + (define save-deletion-streak? #f) + (define save-delayed-streak? #f) + (define save-vcursor-streak? #f) + (define save-kill-streak? #f) + (define save-anchor-streak? #f) + (define save-extend-streak? #f) + + (define dragging? #f) + (define tracking? #f) + (define extra-line? #f) ;; empty line at end of file with no representative + + (define delayedscrollateol? #f) + (define delayedscrollbox? #f) + (define draw-cached-in-bitmap? #f) + (define refresh-unset? #f) + (define refresh-box-unset? #f) + (define refresh-all? #f) + + (define tab-space-in-units? #f) + (define sticky-styles? #t) + (define overwrite-mode? #f) + + (def/public (set-styles-sticky [bool? s?]) (set! sticky-styles? s?)) + (def/public (get-styles-sticky) sticky-styles?) + + (def/public (get-overwrite-mode) overwrite-mode?) + (def/public (set-overwrite-mode [bool? v]) (set! overwrite-mode? v)) + + (def/public (get-sticky-styles) sticky-styles?) + (def/public (set-sticky-styles [bool? v]) (set! sticky-styles? v)) + + (define need-x-copy? #f) + + (define caret-blinked? #f) ;; whether we want to hide an active caret or not + + (define initial-style-needed? #t) + + (define last-draw-caret 0) + (define last-draw-x-sel? #f) + + (define max-width 0.0) + (define min-width 0.0) + (define max-height 0.0) + (define min-height 0.0) + (define wrap-bitmap-width 0.0) + + (define auto-wrap-bitmap #f) + + (define delay-refresh 0) + + (define len 0) ; total length in "characters" == number of positions - 1 + + (define startpos 0) + (define endpos 0) + (define extendstartpos 0) + (define extendendpos 0) ; for extendstreak + (define vcursorloc 0.0) ; for vcursor-streak + + (define flash-timer #f) + (define flashstartpos 0) + (define flashendpos 0) + + (define snips #f) + (define last-snip #f) ; the contents of this edit session + (define snip-count 0) + + (define snip-admin (new standard-snip-admin% [editor this])) + + (define line-root-box (box #f)) + (define first-line #f) + (define last-line #f) + (define num-valid-lines 0) + + (define extra-line-h 0.0) + + (define total-height 0.0) ; total height/width in canvas units + (define total-width 0.0) + (define final-descent 0.0) ; descent of last line + (define initial-space 0.0) ; space from first line + (define initial-line-base 0.0) ; inverse descent from first line + + (define/public (get-s-last-snip) last-snip) + (define/public (get-s-total-width) total-width) + (define/public (get-s-total-height) total-height) + + (define caret-style #f) + + (define dragstart 0) + + (define track-clickback #f) + + (define refresh-start 0) + (define refresh-end 0) + (define refresh-l 0.0) + (define refresh-t 0.0) + (define refresh-r 0.0) + (define refresh-b 0.0) + + (define last-draw-l 0.0) + (define last-draw-t 0.0) + (define last-draw-r 0.0) + (define last-draw-b 0.0) + (define last-draw-red 0) + (define last-draw-green 0) + (define last-draw-blue 0) + + (define delayedscroll -1) + (define delayedscrollend 0) + (define delayedscrollbias 'none) + (define delayedscrollsnip #f) + (define delayedscroll-x 0.0) + (define delayedscroll-y 0.0) + (define delayedscroll-w 0.0) + (define delayedscroll-h 0.0) + + (define clickbacks null) + + (define file-format 'standard) + + (define between-threshold 2.0) + + (define tab-space TAB-WIDTH) ; inexact + + (define read-insert 0) + (define read-insert-start 0) + + (define prev-paste-start 0) + (define prev-paste-end 0) + (define save-prev-paste-start 0) + (define save-prev-paste-end 0) + + (define revision-count 0.0) + + (define word-break standard-wordbreak) + (define word-break-map the-editor-wordbreak-map) + + (define offscreen-key (gensym)) + + (init [(ls line-spacing) 1.0] + [tab-stops null] + [auto-wrap #f]) + + (super-new) + + (define line-spacing ls) + (define/public (get-s-line-spacing) line-spacing) + (define tabs (list->vector tab-stops)) + + (make-only-snip) + + (def/override (~) + (set! word-break-map standard-wordbreak) + (let loop ([snip snips]) + (when snip + (let ([next (snip->next snip)]) + (send snip ~) + (loop next)))) + (set! snips #f) + (set! clickbacks null)) + + (def/override (copy-self) + (let ([m (new text% [line-spacing line-spacing])]) + (copy-self-to m) + m)) + + (def/override (copy-self-to [editor<%> m]) + (when (m . is-a? . text%) + ;; copy parameters, such as tab settings: */ + (send m set-tabs (vector->list tabs) tab-space tab-space-in-units?) + (super copy-self-to m) + (when (zero? (send m last-position)) + ;; make sure only snip in m has a good style (since we called + ;; (send m->style-list copy) in copy-self-to). + (let* ([sname (default-style-name)] + [bs (send (send m get-s-style-list) find-named-style sname)]) + (set-snip-style! (send m get-s-snips) + (or bs + (send (send m get-s-style-list) basic-style))))) + + (send m set-file-format (get-file-format)) + + (send m set-wordbreak-func word-break) + (send m set-wordbreak-map (get-wordbreak-map)) + (send m set-between-threshold (get-between-threshold)) + (send m hide-caret (caret-hidden)) + (send m set-overwrite-mode (get-overwrite-mode)) + + (send m set-autowrap-bitmap auto-wrap-bitmap) + + (send m set-sticky-styles sticky-styles?))) + + ;; ---------------------------------------- + + (def/override (adjust-cursor [mouse-event% event]) + (if (not s-admin) + #f + (let-boxes ([scrollx 0.0] + [scrolly 0.0] + [dc #f]) + (set-box! dc (send s-admin get-dc scrollx scrolly)) + (if (not dc) + #f + (let ([x (+ (send event get-x) scrollx)] + [y (+ (send event get-y) scrolly)]) + (if tracking? + (or s-custom-cursor arrow) + (if (too-busy-to-refresh?) + ;; we're too busy; ask again later + (or (and s-custom-cursor-overrides? s-custom-cursor) + i-beam) + (begin + (begin-sequence-lock) + (begin0 + (or (and (not s-custom-cursor-overrides?) + (or (and s-caret-snip (send event dragging?) + (let-boxes ([x 0.0] + [y 0.0]) + (get-snip-position-and-location s-caret-snip #f x y) + (let ([c (send s-caret-snip adjust-cursor dc + (- x scrollx) (- y scrolly) + x y event)]) + c))) + ;; find snip: + (let-boxes ([onit? #f] + [how-close 0.0] + [pos 0]) + (set-box! pos (find-position x y #f onit? how-close)) + ;; FIXME: the following refinement of `onit?' seems pointless + (let ([onit? (and onit? + (not (zero? how-close)) + ((abs how-close) . > . between-threshold))]) + (let ([snip (and onit? + (find-snip pos 'after))]) + (and snip + (let-boxes ([x 0.0] [y 0.0]) + (get-snip-position-and-location snip #f x y) + (let ([c (send snip adjust-cursor dc (- x scrollx) (- y scrolly) + x y event)]) + c)))))))) + s-custom-cursor + (if (x . >= . 0) + (let ([cb? (find-clickback (find-position x y #f) y)]) + (if cb? arrow i-beam)) + i-beam)) + (end-sequence-lock)))))))))) + + (def/override (on-event [mouse-event% event]) + (when s-admin + (when (and (not (send event moving?)) + (not (send event entering?)) + (not (send event leaving?))) + (end-streaks '(except-key-sequence cursor delayed))) + (let-values ([(dc x y scrollx scrolly) + (if (or (send event button-down?) s-caret-snip) + ;; first, find clicked-on snip: + (let ([x (send event get-x)] + [y (send event get-y)]) + (let-boxes ([scrollx 0.0] + [scrolly 0.0] + [dc #f]) + (set-box! dc (send s-admin get-dc scrollx scrolly)) + ;; FIXME: old code returned if !dc + (values dc (+ x scrollx) (+ y scrolly) scrollx scrolly))) + (values #f 0.0 0.0 0.0 0.0))]) + (when (send event button-down?) + (let ([snip + (let-boxes ([onit? #f] + [how-close 0.0] + [now 0]) + (set-box! now (find-position x y #f onit? how-close)) + ;; FIXME: the following refinement of `onit?' seems pointless + (let ([onit? (and onit? + (not (zero? how-close)) + ((abs how-close) . > . between-threshold))]) + (if onit? + ;; we're in the snip's horizontal region... + (let ([snip (find-snip now 'after)]) + ;; ... but maybe the mouse is above or below it. + (let-boxes ([top 0.0] + [bottom 0.0] + [dummy 0.0]) + (begin + (get-snip-location snip dummy top #f) + (get-snip-location snip dummy bottom #t)) + (if (or (top . > . y) (y . > . bottom)) + #f + snip))) + #f)))]) + (set-caret-owner snip))) + (if (and s-caret-snip (has-flag? (snip->flags s-caret-snip) HANDLES-EVENTS)) + (let-boxes ([x 0.0] [y 0.0]) + (get-snip-position-and-location s-caret-snip #f x y) + (send s-caret-snip on-event dc (- x scrollx) (- y scrolly) x y event)) + (on-local-event event))))) + + (def/override (on-default-event [mouse-event% event]) + (when s-admin + (let-boxes ([scrollx 0.0] + [scrolly 0.0] + [dc #f]) + (set-box! dc (send s-admin get-dc scrollx scrolly)) + (let ([x (+ (send event get-x) scrollx)] + [y (+ (send event get-y) scrolly)]) + (when dc + + (let-boxes ([now 0] + [ateol? #f] + [how-close 0.0]) + (set-box! now (find-position x y ateol? #f how-close)) + (let ([now (if (and (how-close . > . 0) + (how-close . <= . between-threshold)) + (add1 now) + now)]) + (cond + [(send event button-down?) + (set! tracking? #f) + (let ([click (and (x . >= . 0) (find-clickback now y))]) + (if click + (if (clickback-call-on-down? click) + ((clickback-f click) this (clickback-start click) (clickback-end click)) + (begin + (set! tracking? #t) + (set! track-clickback click) + (when s-admin + (send s-admin update-cursor)) + (set-clickback-hilited?! track-clickback #t))) + (begin + (set! dragstart now) + (set! dragging? #t) + (when (send event get-shift-down) + (if (dragstart . > . startpos) + (set! dragstart startpos) + (set! dragstart endpos))) + (if (now . < . dragstart) + (set-position-bias-scroll 'start-only now dragstart ateol?) + (set-position-bias-scroll 'end-only dragstart now ateol?)))))] + [(send event dragging?) + (cond + [dragging? + (if (now . < . dragstart) + (when (or (not (= startpos now)) (not (= endpos dragstart))) + (set-position-bias-scroll 'start-only now dragstart ateol?)) + (when (or (not (= endpos now)) (not (= startpos dragstart))) + (set-position-bias-scroll 'end-only dragstart now ateol?)))] + [tracking? + (let ([cb (if (x . >= . 0) + (find-clickback now y) + #f)]) + (set-clickback-hilited?! track-clickback (eq? cb track-clickback)))])] + [(send event button-up?) + (cond + [dragging? + (set! dragging? #f)] + [tracking? + (set! tracking? #f) + (when (clickback-hilited? track-clickback) + (set-clickback-hilited?! track-clickback #f) + (let ([click track-clickback]) + ((clickback-f click) this (clickback-start click) (clickback-end click)))) + (when s-admin + (send s-admin update-cursor))])] + [(send event moving?) + (set! dragging? #f) + (when tracking? + (set! tracking? #f) + (when (clickback-hilited? track-clickback) + (set-clickback-hilited?! track-clickback #f) + (let ([click track-clickback]) + ((clickback-f click) this (clickback-start click) (clickback-end click))))) + (when s-admin + (send s-admin update-cursor))])))))))) + + (def/override (on-char [key-event% event]) + (when s-admin + (if (and s-caret-snip + (has-flag? (snip->flags s-caret-snip) HANDLES-EVENTS)) + (let-boxes ([scrollx 0.0] + [scrolly 0.0] + [dc #f]) + (set-box! dc (send s-admin get-dc scrollx scrolly)) + (let-boxes ([x 0.0] [y 0.0]) + (get-snip-position-and-location s-caret-snip #f x y) + (send s-caret-snip on-char dc (- x scrollx) (- y scrolly) x y event))) + (let ([code (send event get-key-code)]) + (when (and (not (eq? 'release code)) + (not (eq? 'shift code)) + (not (eq? 'control code)) + (not (eq? 'menu code)) + (not (equal? code #\nul))) + (hide-cursor)) + (on-local-char event))))) + + (def/override (on-default-char [key-event% event]) + (when s-admin + (let ([code (send event get-key-code)] + [ins (lambda (ch) + (if (and overwrite-mode? (= endpos startpos)) + (insert ch startpos (add1 startpos)) + (insert ch)))]) + (case code + [(#\backspace) (delete)] + [(#\rubout) + (if (= endpos startpos) + (when (endpos . < . len) + (delete endpos (add1 endpos))) + (delete))] + [(right left up down home end prior next) + (move-position code (send event get-shift-down))] + [(numpad0) (ins #\0)] + [(numpad1) (ins #\1)] + [(numpad2) (ins #\2)] + [(numpad3) (ins #\3)] + [(numpad4) (ins #\4)] + [(numpad5) (ins #\5)] + [(numpad6) (ins #\6)] + [(numpad7) (ins #\7)] + [(numpad8) (ins #\8)] + [(numpad9) (ins #\9)] + [(multiply) (ins #\*)] + [(divide) (ins #\/)] + [(add) (ins #\+)] + [(subtract) (ins #\-)] + [(decimal) (ins #\.)] + [(#\u3) (ins #\return)] ; NUMPAD-ENTER + [(#\return #\tab) (ins code)] + [else + (let ([vcode (if (char? code) + (char->integer code) + 0)]) + (when (and (vcode . >= . 32) + (or (vcode . <= . #xd800) + (vcode . > . #xdf00))) + (ins code)))])))) + + (def/override (own-caret [any? ownit?]) + (when (do-own-caret (and ownit? #t)) + (need-caret-refresh) + (on-focus (and ownit? #t)))) + + (def/override (blink-caret) + (if s-caret-snip + (let-boxes ([dx 0.0] + [dy 0.0] + [dc #f]) + (set-box! dc (send s-admin get-dc dx dy)) + (when dc + (let-boxes ([x 0.0] [y 0.0]) + (get-snip-location s-caret-snip x y) + (send s-caret-snip blink-caret dc (- x dx) (- y dy))))) + (if (too-busy-to-refresh?) + ;; we're busy; go away + (void) + (when (and (= endpos startpos) + (not flash?) + hilite-on?) + (set! caret-blinked? (not caret-blinked?)) + (need-caret-refresh))))) + + (def/override (size-cache-invalid) + (set! graphic-maybe-invalid? #t) + (set! graphics-invalid? #t) + (when (max-width . > . 0.0) + (set! flow-invalid? #t)) + (set! snip-cache-invalid? #t)) + + (def/override (locked-for-read?) + read-locked?) + (def/public (locked-for-flow?) + flow-locked?) + (def/override (locked-for-write?) + write-locked?) + + ;; ---------------------------------------- + + (def/public (can-insert? [exact-nonnegative-integer? start] + [exact-nonnegative-integer? len]) + #t) + (def/public (on-insert [exact-nonnegative-integer? start] + [exact-nonnegative-integer? len]) + (void)) + (def/public (after-insert [exact-nonnegative-integer? start] + [exact-nonnegative-integer? len]) + (void)) + + (def/public (can-delete? [exact-nonnegative-integer? start] + [exact-nonnegative-integer? len]) + #t) + (def/public (on-delete [exact-nonnegative-integer? start] + [exact-nonnegative-integer? len]) + (void)) + (def/public (after-delete [exact-nonnegative-integer? start] + [exact-nonnegative-integer? len]) + (void)) + + (def/public (can-change-style? [exact-nonnegative-integer? start] + [exact-nonnegative-integer? len]) + #t) + (def/public (on-change-style [exact-nonnegative-integer? start] + [exact-nonnegative-integer? len]) + (void)) + (def/public (after-change-style [exact-nonnegative-integer? start] + [exact-nonnegative-integer? len]) + (void)) + + (def/public (after-set-position) (void)) + + (def/public (can-set-size-constraint?) #t) + (def/public (on-set-size-constraint) (void)) + (def/public (after-set-size-constraint) (void)) + + (def/public (after-split-snip [exact-nonnegative-integer? pos]) (void)) + (def/public (after-merge-snips [exact-nonnegative-integer? pos]) (void)) + + ;; ---------------------------------------- + + (def/override (begin-edit-sequence [any? [undoable? #t]] [any? [interrupt-seqs? #t]]) + (wait-sequence-lock) + + (when (and (zero? delay-refresh) + (not interrupt-seqs?)) + (push-streaks)) + + (end-streaks '(delayed)) + + (when (or (positive? s-noundomode) + (not undoable?)) + (set! s-noundomode (add1 s-noundomode))) + + (if (zero? delay-refresh) + (begin + (when ALLOW-X-STYLE-SELECTION? + (set! need-x-copy? #t)) + (set! delay-refresh 1) + (on-edit-sequence)) + (set! delay-refresh (add1 delay-refresh)))) + + (def/override (end-edit-sequence) + (if (zero? delay-refresh) + (log-error "end-edit-sequence without begin-edit-sequence") + (begin + (set! delay-refresh (sub1 delay-refresh)) + (when (zero? delay-refresh) + (end-streaks null) + (pop-streaks) + (redraw) + (when ALLOW-X-STYLE-SELECTION? + (set! need-x-copy? #f)) + (after-edit-sequence)) + (when (positive? s-noundomode) + (set! s-noundomode (sub1 s-noundomode))) + (when (and (zero? delay-refresh) + s-need-on-display-size?) + (set! s-need-on-display-size? #f) + (on-display-size))))) + + (def/override (refresh-delayed?) + (or (delay-refresh . > . 0) + (not s-admin) + (send s-admin delay-refresh?))) + + (def/override (in-edit-sequence?) + (delay-refresh . > . 0)) + + (def/override (locations-computed?) + (not graphic-maybe-invalid?)) + + (def/public (recalculate) (void)) + + (def/public (get-position [maybe-box? start] [maybe-box? [end #f]]) + (when start (set-box! start startpos)) + (when end (set-box! end endpos))) + + (def/public (get-start-position) startpos) + (def/public (get-end-position) endpos) + + (def/public (set-position [exact-nonnegative-integer? start] + [(make-alts exact-nonnegative-integer? (make-literal 'same)) [end 'same]] + [any? [ateol? #f]] + [any? [scroll? #t]] + [(symbol-in default x local) [seltype 'default]]) + (do-set-position #f 'none start end ateol? scroll? seltype)) + + (def/public (set-position-bias-scroll [symbol? bias] + [exact-nonnegative-integer? start] + [(make-alts exact-nonnegative-integer? (make-literal 'same)) [end 'same]] + [any? [ateol? #f]] + [any? [scroll? #t]] + [(symbol-in default x local) [seltype 'default]]) + (do-set-position #f bias start end ateol? scroll? seltype)) + + (define/private (do-set-position setflash? bias start end ateol? scroll? seltype) + (unless flow-locked? + (when (and (not setflash?) + (or (not flash?) (not flashautoreset?) (not flashdirectoff?))) + (end-streaks '(delayed))) + + (unless (or (start . < . 0) + (and (number? end) + (start . > . end))) + (let* ([start (min start len)] + [end (if (symbol? end) + start + (min end len))] + [ateol? + (and ateol? + (= end start) + (let-values ([(snip s-pos) + (find-snip/pos start 'before)]) + (and (has-flag? (snip->flags snip) NEWLINE) + (not (has-flag? (snip->flags snip) INVISIBLE)) + (= start (+ s-pos (snip->count snip))))))]) + (let-values ([(oldstart oldend oldateol?) + (if flash? + (values flashstartpos flashendpos flashposateol?) + (values startpos endpos posateol?))]) + (when (and (not setflash?) + flash? + flashautoreset?) + (set! flash? #f) + (when flash-timer + (send flash-timer stop) + (set! flash-timer #f))) + (let* ([need-refresh? (not (and (= oldstart start) + (= oldend end) + (eq? oldateol? ateol?)))] + [changed-pos? need-refresh?]) + + (if setflash? + (begin + (set! flashstartpos start) + (set! flashendpos end) + (set! flashposateol? ateol?)) + (begin + (when ALLOW-X-STYLE-SELECTION? + (when (or (= end start) + (not (eq? editor-x-selection-allowed this)) + (eq? 'local seltype)) + (when (or (zero? delay-refresh) need-x-copy?) + (set! need-x-copy? #f) + (copy-out-x-selection)))) + + (check-merge-snips startpos) + (check-merge-snips endpos) + + (set! caret-style #f) + (set! startpos start) + (set! endpos end) + (set! posateol? ateol?))) + + (let-values ([(need-refresh? need-full-refresh?) + (let ([refresh? (and ALLOW-X-STYLE-SELECTION? + (not setflash?) + editor-x-selection-mode? + (or (and (not (eq? 'local seltype)) + (not (= start end )) + (not (eq? editor-x-selection-owner this)) + (eq? (own-x-selection #t #f seltype) 'x)) + (and (or (= start end) + (not (eq? editor-x-selection-allowed this)) + (eq? 'local seltype)) + (eq? editor-x-selection-owner this) + (own-x-selection #f #f #f))))]) + (values (or refresh? need-refresh?) + refresh?))]) + (when setflash? + (set! flash? #t)) + + (let ([need-refresh? + (or + (and scroll? + (let-values ([(scroll-start scroll-end bias) + (cond + [(eq? bias 'start-only) + (values start start 'none)] + [(eq? bias 'end-only) + (values end end 'none)] + [else + (values start end bias)])]) + (let ([was-blinked? caret-blinked?]) + (set! caret-blinked? #f) + (if (scroll-to-position/refresh scroll-start posateol? #t scroll-end bias) + #t + (begin + (set! caret-blinked? was-blinked?) + #f))))) + need-refresh?)]) + + (when need-refresh? + (set! caret-blinked? #f) + (if (or (start . >= . oldend) + (end . <= . oldstart) + need-full-refresh?) + (begin + ;; no overlap: + (need-refresh oldstart oldend) + (need-refresh start end)) + (begin + (when (start . < . oldstart) + (need-refresh start oldstart)) + (when (oldstart . < . start) + (need-refresh oldstart start)) + (when (end . < . oldend) + (need-refresh end oldend)) + (when (oldend . < . end) + (need-refresh oldend end))))))) + + (when (and changed-pos? (not setflash?)) + (after-set-position)))))))) + + (define/private (scroll-to-position/refresh start + [ateol? #f] + [refresh? #t] + [end 'same] + [bias 'none]) + (and + (not flow-locked?) + (let ([end (if (eq? end 'same) start (max start end))]) + (cond + [(positive? delay-refresh) + (when s-admin + (set! delayedscrollbox? #f) + (set! delayedscroll start) + (set! delayedscrollend end) + (set! delayedscrollateol? ateol?) + (set! delayedscrollbias bias)) + #f] + [(not (check-recalc #t #f)) + #f] + [else + (set! delayedscroll -1) + + (let-boxes ([topx 0.0] [topy 0.0] + [botx 0.0] [boty 0.0]) + (begin + (position-location start topx topy #t ateol? #t) + (position-location end botx boty #f ateol? #t)) + (let-values ([(topx botx) + (if (botx . < . topx) + ;; when the end position is to the left of the start position + (values 0 total-width) + (values topx botx))]) + (scroll-editor-to topx topy (- botx topx) (- boty topy) refresh? bias)))])))) + + (def/public (scroll-to-position [exact-nonnegative-integer? start] + [any? [ateol? #f]] + [(make-alts exact-nonnegative-integer? (make-literal 'same)) [end 'same]] + [(symbol-in start end none) [bias 'none]]) + (scroll-to-position/refresh start ateol? #t end bias)) + + (define/private (get-visible-X-range start end all? find) + (when (check-recalc #t #f) + (let-boxes ([x 0.0] [y 0.0] [w 0.0] [h 0.0]) + (if all? + (send s-admin get-max-view x y w h) + (send s-admin get-view x y w h)) + (begin + (when start + (set-box! start (find x y))) + (when end + (set-box! end (find (+ x w) (+ y h)))))))) + + (def/public (get-visible-position-range [maybe-box? start] [maybe-box? end] [any? [all? #t]]) + (get-visible-X-range start end all? (lambda (x y) (find-position x y)))) + + (def/public (get-visible-line-range [maybe-box? start] [maybe-box? end] [any? [all? #t]]) + (get-visible-X-range start end all? (lambda (x y) (find-line y)))) + + ;; ---------------------------------------- + + (def/public (move-position [(make-alts symbol? char?) code] + [any? [extend-selection? #f]] + [(symbol-in simple word page line) [kind 'simple]]) + (unless (or flow-locked? + (not (check-recalc (max-width . > . 0.0) #f #t))) + + (let-values ([(anchor?) anchor-streak?] + [(vcursor?) vcursor-streak?] + [(extendstart extendend) + (if (or extend-streak? anchor-streak?) + (values extendstartpos extendendpos) + (values startpos endpos))] + [(kas?) keep-anchor-streak?]) + + (set! keep-anchor-streak? anchor-streak?) + + (end-streaks '(delayed)) + + (let* ([extend? (or anchor? extend-selection?)] + ;; rightshrink: motion to right shrinks the selected region + [rightshrink? (and extend? (startpos . < . extendstart))] + [leftshrink? (and extend? (endpos . > . extendend))]) + (let-values ([(code kind) + (cond + [(eq? 'prior code) (values 'up 'page)] + [(eq? 'next code) (values 'down 'page)] + [else (values code kind)])]) + (cond + [(eq? 'home code) + (if leftshrink? + (set-position-bias-scroll 'start-only extendstart extendend) + (set-position-bias-scroll 'start-only 0 (if extend? extendend 0)))] + [(eq? 'end code) + (if rightshrink? + (set-position-bias-scroll 'end-only extendstart extendend) + (set-position-bias-scroll 'end-only (if extend? extendstart len) len))] + [(eq? 'left code) + (if (and (not (eq? 'line kind)) + (not (eq? 'word kind)) + (not extend?) + (not (= endpos startpos))) + (set-position startpos) + (begin + ;; pick a starting place + (let ([start + (let ([start (if leftshrink? + endpos + startpos)]) + (cond + [(eq? 'word kind) + (let-boxes ([start start]) + (find-wordbreak start #f 'caret) + start)] + [(eq? 'line kind) + (line-start-position (position-line start posateol?))] + [else (max 0 (sub1 start))]))]) + (let-values ([(start end) + (if extend? + (if leftshrink? + (let ([start (max start extendend)]) ;; collapse to original + (values startpos start)) + (values start endpos)) + (values start start))]) + (set-position-bias-scroll 'start-only start end)))))] + [(eq? 'right code) + (if (and (not (eq? 'line kind)) + (not (eq? 'word kind)) + (not extend?) + (not (= endpos startpos))) + (set-position endpos endpos #t) + (begin + ;; pick a starting place + (let ([end + (let ([end (if rightshrink? + startpos + endpos)]) + (cond + [(eq? 'word kind) + (let-boxes ([end end]) + (find-wordbreak #f end 'caret) + end)] + [(eq? 'line kind) + (line-end-position (position-line end posateol?))] + [else (add1 end)]))]) + (let-values ([(start end) + (if extend? + (if rightshrink? + (let ([end (min end extendstart)]) ;; collapse to original + (values end endpos)) + (values startpos end)) + (values end end))]) + (set-position-bias-scroll 'end-only start end #t)))))] + [(or (eq? 'up code) (eq? 'down code)) + (let ([special-scroll? (eq? 'page kind)]) ;; used when paging + (let-values ([(start end ateol? special-scroll? + scroll-left scroll-top scroll-width scroll-height + bias) + (if (eq? 'up code) + (let ([start (if leftshrink? + endpos + startpos)]) + (let-boxes ([vcl vcursorloc]) + (when (not vcursor?) + (position-location start vcl #f #t posateol? #t)) + (set! vcursorloc vcl) + (let ([cline (position-line start posateol?)]) + (let-values ([(i scroll-left scroll-top scroll-width scroll-height) + (if (eq? 'page kind) + ;; the current top line should become the next-to bottom line. + ;; the caret should go to line above current top line, but + ;; watch out for: + ;; - especially tall lines + ;; - already at top + (let-boxes ([scroll-left 0.0] [vy 0.0] + [scroll-width 0.0] [scroll-height 0.0]) + (send s-admin get-view scroll-left vy scroll-width scroll-height) + ;; top line should be completely visible as bottom line after + ;; scrolling + (let* ([top (find-scroll-line vy)] + [ty (scroll-line-location (+ top 1))] + [newtop (find-scroll-line (- ty scroll-height))] + [y (scroll-line-location newtop)] + [newtop (if (y . < . (- ty scroll-height)) + (add1 newtop) + newtop)] + [y (scroll-line-location newtop)] + ;; y is the new top location + [y (if (y . >= . vy) + ;; no or backward progess + (scroll-line-location (max 0 (sub1 top))) + y)]) + (let ([i (if (= vy y) + ;; must be at the top: + (find-line y) + (let ([i (find-line (+ y scroll-height))]) + (if ((line-location (max 0 (- i 1))) . > . y) + (sub1 i) + i)))]) + (values i scroll-left y scroll-width scroll-height)))) + (values (- cline 1) 0.0 0.0 0.0 0.0))]) + (let-boxes ([start 0] [ateol? #f]) + (if (i . >= . 0) + (set-box! start (find-position-in-line i vcursorloc ateol?)) + (begin (set-box! start 0) (set-box! ateol? #f))) + (let-values ([(start end special-scroll?) + (if extend? + (if leftshrink? + (if (start . < . extendend) + (if (and (not (eq? 'page kind)) + (start . < . extendstart)) + ;; inversion! + (values start extendend special-scroll?) + ;; Collapse to original + (values startpos extendend #f)) + (values startpos start special-scroll?)) + (values start endpos special-scroll?)) + (values start start special-scroll?))]) + (values start end ateol? special-scroll? + scroll-left scroll-top scroll-width scroll-height + (if leftshrink? 'end-only 'start-only)))))))) + ;; (eq? code 'down) + (let ([end (if rightshrink? + startpos + endpos)]) + (let-boxes ([vcl vcursorloc]) + (when (not vcursor?) + (position-location end vcl #f #t posateol? #t)) + (set! vcursorloc vcl) + (let ([cline (position-line end posateol?)]) + (let-values ([(i scroll-left scroll-top scroll-width scroll-height) + (if (eq? 'page kind) + (let-boxes ([scroll-left 0.0] [vy 0.0] + [scroll-width 0.0] [scroll-height 0.0]) + (send s-admin get-view scroll-left vy scroll-width scroll-height) + ;; last fully-visible line is the new top line + (let* ([newtop (find-scroll-line (+ vy scroll-height))] + [y (scroll-line-location (+ newtop 1))] + [newtop (if (y . > . (+ vy scroll-height)) + (sub1 newtop) + newtop)] + [y (scroll-line-location newtop)]) + ;; y is the new top location + (let-values ([(newtop y) + (if (y . <= . vy) + ;; no or backwards movement; scroll back one + (let ([newtop (+ (find-scroll-line vy) 1)]) + (values newtop (scroll-line-location newtop))) + (values newtop y))]) + ;; compute top line, for caret + (let* ([i (find-line y)] + [i (if ((line-location i #t) . < . y) + (add1 i) + i)]) + ;; Now, suppose we're scrolling down while extending the + ;; selection. We want to be able to see that we're + ;; selecting. So try moving the line `i' down one more, if + ;; there's room: + (let ([i (if ((line-location (+ i 1) #f) . < . (+ y scroll-height)) + (add1 i) + i)]) + (values i scroll-left (- y 1) scroll-width scroll-height)))))) + (values (+ cline 1) 0.0 0.0 0.0 0.0))]) + (let-values ([(end ateol?) + (if (i . <= . (sub1 num-valid-lines)) + (let-boxes ([ateol? #f] [end 0]) + (set-box! end (find-position-in-line i vcursorloc ateol?)) + (values end ateol?)) + (values len #f))]) + (let-values ([(start end special-scroll?) + (if extend? + (if rightshrink? + (if (end . > . extendstart) + (if (and (not (eq? 'page kind)) + (end . > . extendend)) + ;; inversion! + (values extendstart end special-scroll?) + ;; collapse to original + (values extendstart endpos #f)) + (values end endpos special-scroll?)) + (values startpos end special-scroll?)) + (values end end special-scroll?))]) + (values start end ateol? special-scroll? + scroll-left scroll-top scroll-width scroll-height + (if rightshrink? 'start-only 'end-only)))))))))]) + (when special-scroll? + (begin-edit-sequence)) + + ;; scroll only if !special-scroll + (set-position-bias-scroll bias start end ateol? (not special-scroll?)) + + (when special-scroll? + ;; special scrolling intructions: + (do-scroll-to #f scroll-left scroll-top scroll-width scroll-height #f 'none) + + (end-edit-sequence)) + + (set! vcursor-streak? #t)))]) + + (set! keep-anchor-streak? kas?) + (when extend? + (set! extend-streak? #t)) + + (when (or extend-streak? anchor-streak?) + (set! extendendpos extendend) + (set! extendstartpos extendstart))))))) + + (def/public (set-anchor [any? on?]) + (let ([wason? anchor-streak?]) + (set! anchor-streak? (and on? #t)) + (when (and on? (not wason?)) + (set! extendendpos endpos) + (set! extendstartpos startpos)))) + + (def/public (get-anchor) + anchor-streak?) + + ;; ---------------------------------------- + + (define/private (do-insert isnip str snipsl start end scroll-ok?) + (unless (or write-locked? + s-user-locked? + (start . < . 0)) + (let ([start (min start len)]) + ;; turn off pending style, if it doesn't apply + (when caret-style + (when (or (not (equal? end start)) (not (= startpos start))) + (set! caret-style #f))) + (let ([deleted? (and (not (eq? end 'same)) + (start . < . end) + (begin + (when ALLOW-X-STYLE-SELECTION? + (when (zero? delay-refresh) + (set! need-x-copy? #t))) + (when (or isnip str snipsl) + (begin-edit-sequence)) + (delete start end scroll-ok?) + (when ALLOW-X-STYLE-SELECTION? + (when (zero? delay-refresh) + (set! need-x-copy? #f))) + #t))]) + (when (or isnip str snipsl) + (set! write-locked? #t) + (let ([success-finish + (lambda (addlen inserted-line?) + (set! initial-style-needed? #f) + (set! revision-count (add1 revision-count)) + + (adjust-clickbacks start start addlen #f) + + (unless s-modified? + (add-undo-rec (make-object unmodify-record% delayed-streak?))) + (unless (positive? s-noundomode) + (add-undo-rec + (make-object insert-record% + start addlen + (or deleted? typing-streak? delayed-streak? + insert-force-streak? + (not s-modified?)) + startpos endpos))) + (when (positive? delay-refresh) + (set! delayed-streak? #t)) + + (let ([scroll? (= start startpos)]) + + (when (startpos . >= . start) + (set! startpos (+ startpos addlen))) + (when (endpos . >= . start) + (set! endpos (+ endpos addlen))) + (unless refresh-unset? + (when (refresh-start . >= . start) + (set! refresh-start (+ refresh-start addlen))) + (when (refresh-end . >= . start) + (set! refresh-end (+ refresh-end addlen)))) + + (set! extra-line? (has-flag? (snip->flags last-snip) NEWLINE)) + + (set! write-locked? #f) + (set! flow-locked? #f) + + (when scroll? + (set! caret-blinked? #f)) + + (when (and scroll? scroll-ok?) + (set! delay-refresh (add1 delay-refresh)) + (scroll-to-position/refresh startpos) + (set! delay-refresh (sub1 delay-refresh))) + + (set! changed? #t) + + (set! caret-style #f) + + (if inserted-line? + (begin + (set! graphic-maybe-invalid? #t) + (need-refresh start)) + (refresh-by-line-demand)) + + (when deleted? + (end-edit-sequence)) + + (unless s-modified? + (set-modified #t)) + + (after-insert start addlen)))] + [fail-finish + (lambda () + (set! write-locked? #f) + (set! flow-locked? #f) + (when deleted? + (end-edit-sequence)))]) + (cond + [(or isnip snipsl) + (insert-snips (if isnip (list isnip) snipsl) start success-finish fail-finish)] + [else (insert-string str start success-finish fail-finish)]))))))) + + (define/private (insert-snips snipsl start success-finish fail-finish) + (let ([addlen (for/fold ([addlen 0]) + ([isnip (in-list snipsl)] + #:when addlen) + (let ([c (snip->count isnip)]) + (and (positive? c) + (not (send isnip is-owned?)) + (+ addlen c))))]) + + (if (or (not addlen) + (zero? addlen) + (not (can-insert? start addlen))) + (fail-finish) + (begin + (on-insert start addlen) + + (set! flow-locked? #t) + + ;; make sure on-insert didn't do something bad to the snips: + (if (not (for/and ([isnip (in-list snipsl)]) + (and (positive? (snip->count isnip)) + (not (send isnip is-owned?))))) + + (fail-finish) + + (let loop ([did-one? #f] + [before-snip #f] + [inserted-line? #f] + [snipsl snipsl]) + + (if (null? snipsl) + (success-finish addlen inserted-line?) + (let ([isnip (car snipsl)]) + (when (and (has-flag? (snip->flags isnip) NEWLINE) + (not (has-flag? (snip->flags isnip) HARD-NEWLINE))) + (set-snip-flags! isnip (remove-flag (snip->flags isnip) NEWLINE))) + + (let-values ([(before-snip inserted-new-line?) + (if (and (zero? len) (not did-one?)) + + ;; special case: ignore the empty snip + (begin + (set! snips isnip) + (set! last-snip isnip) + (let ([line-root (create-mline)]) + (set-box! line-root-box line-root) + (set-snip-line! isnip line-root) + (set-mline-snip! line-root isnip) + (set-mline-last-snip! line-root isnip) + (when (max-width . > . 0) + (mline-mark-check-flow line-root))) + (values before-snip #f)) + + (let* ([gsnip (if (not did-one?) + (begin + (make-snipset start start) + (find-snip start 'after-or-none)) + before-snip)] + [before-snip (or before-snip gsnip)] + [inserted-new-line? + (if (not gsnip) + (begin + (append-snip isnip) + (let ([gsnip (mline-last-snip last-line)]) + (if (and gsnip (has-flag? (snip->flags gsnip) HARD-NEWLINE)) + (let ([line (mline-insert last-line line-root-box #f)]) + (set-snip-line! isnip line) + (set-mline-snip! line isnip) + (set-mline-last-snip! line isnip) + (set! num-valid-lines (add1 num-valid-lines)) + #t) + (begin + (set-snip-line! isnip last-line) + (when (not (mline-snip last-line)) + (set-mline-snip! last-line isnip)) + (set-mline-last-snip! last-line isnip) + ;; maybe added extra ghost line: + (has-flag? (snip->flags isnip) HARD-NEWLINE))))) + (begin + (insert-snip gsnip isnip) + (if (has-flag? (snip->flags isnip) HARD-NEWLINE) + (let* ([gline (snip->line gsnip)] + [line (mline-insert gline line-root-box #t)]) + (set-snip-line! isnip line) + (set! num-valid-lines (add1 num-valid-lines)) + (if (eq? gsnip (mline-snip gline)) + (set-mline-snip! line isnip) + (set-mline-snip! line (mline-snip gline))) + (set-mline-last-snip! line isnip) + (set-mline-snip! gline gsnip) + + (let loop ([c-snip (mline-snip line)]) + (unless (eq? c-snip isnip) + (set-snip-line! c-snip line) + (loop (snip->next c-snip)))) + + (mline-calc-line-length gline) + (mline-mark-recalculate gline) + #t) + (let ([gline (snip->line gsnip)]) + (set-snip-line! isnip gline) + (when (eq? (mline-snip gline) gsnip) + (set-mline-snip! gline isnip)) + #f))))]) + + (when (max-width . > . 0) + (mline-mark-check-flow (snip->line isnip)) + (let ([prev (snip->prev isnip)]) + (when (and prev + (not (has-flag? (snip->flags isnip) NEWLINE))) + (mline-mark-check-flow (snip->line prev)))) + (let ([next (mline-next (snip->line isnip))]) + (when (and next + (has-flag? (snip->flags isnip) HARD-NEWLINE)) + (mline-mark-check-flow next)))) + + (values before-snip inserted-new-line?)))]) + + (set-snip-style! isnip (send s-style-list convert (or (snip->style isnip) + (send s-style-list basic-style)))) + + (send isnip size-cache-invalid) + + (mline-calc-line-length (snip->line isnip)) + (mline-mark-recalculate (snip->line isnip)) + + (set! len (+ len (snip->count isnip))) + + (snip-set-admin isnip snip-admin) + + (set! first-line (mline-first (unbox line-root-box))) + (set! last-line (mline-last (unbox line-root-box))) + + (loop #t + before-snip + (or inserted-line? inserted-new-line?) + (cdr snipsl))))))))))) + + (define/private (insert-string str start success-finish fail-finish) + (let ([addlen (string-length str)]) + (if (not (can-insert? start addlen)) + (fail-finish) + (begin + (on-insert start addlen) + + (set! flow-locked? #t) + + (let-values ([(snip s-pos inserted-line?) + (if (zero? len) + + (let* ([style (if (and sticky-styles? + (not initial-style-needed?)) + (snip->style snips) + (get-default-style))] + [snip (insert-text-snip start style)]) + (set! caret-style #f) + (set-mline-snip! (unbox line-root-box) snip) + (set-mline-last-snip! (unbox line-root-box) snip) + (values snip 0 #f)) + + (let-values ([(gsnip s-pos) + (if (positive? start) + (find-snip/pos start 'before) + (values #f 0))]) + (let-values ([(snip s-pos) + (if (or (not gsnip) + (and caret-style (not (eq? caret-style (snip->style gsnip)))) + (not (has-flag? (snip->flags gsnip) IS-TEXT)) + ((+ (snip->count gsnip) addlen) . > . MAX-COUNT-FOR-SNIP) + (and (not sticky-styles?) + (not (eq? (snip->style gsnip) (get-default-style))))) + + (let ([style (or caret-style + (if sticky-styles? + (if gsnip + (snip->style gsnip) + (snip->style snips)) + (get-default-style)))]) + (let ([snip (insert-text-snip start style)]) + (set! caret-style #f) + (values snip start))) + + (let ([snip gsnip]) + (if (has-flag? (snip->flags snip) CAN-APPEND) + (values snip s-pos) + (let ([style (if sticky-styles? + (snip->style snip) + (get-default-style))]) + (values (insert-text-snip start style) + start)))))]) + + (if (and gsnip + (has-flag? (snip->flags gsnip) HARD-NEWLINE) + (eq? (snip->next gsnip) snip)) + ;; preceeding snip was a newline, so the new slip belongs on the next line: + (let* ([oldline (snip->line gsnip)] + [inserted-new-line? + (if (mline-next oldline) + #f + (begin + (mline-insert oldline line-root-box #f) + (set! num-valid-lines (add1 num-valid-lines)) + (set-mline-last-snip! (mline-next oldline) snip) + #t))]) + (let ([newline (mline-next oldline)]) + (set-snip-line! snip newline) + + (set-mline-last-snip! oldline gsnip) + (set-mline-snip! newline snip) + + (mline-calc-line-length oldline) + (mline-mark-recalculate oldline) + (values snip s-pos inserted-new-line?))) + + (values snip s-pos #f)))))]) + + (let ([s (- start s-pos)]) + (set-snip-flags! snip (add-flag (snip->flags snip) CAN-SPLIT)) + (send snip insert str addlen s) + (when (has-flag? (snip->flags snip) CAN-SPLIT) + (set-snip-flags! snip (remove-flag (snip->flags snip) CAN-SPLIT))) + + (mline-calc-line-length (snip->line snip)) + (mline-mark-recalculate (snip->line snip)) + + (when (max-width . > . 0) + (mline-mark-check-flow (snip->line snip)) + (let ([prev (mline-prev (snip->line snip))]) + (when (and prev + (not (has-flag? (snip->flags (mline-last-snip prev)) HARD-NEWLINE))) + (mline-mark-check-flow prev)))) + + ;; The text is inserted, but all into one big snip. If the + ;; inserted text contains any newlines or tabs, we need to split + ;; it up to use tab snips or the HARD-NEWLINE flag: + (let loop ([snip-start-pos start] + [str (string-snip-buffer snip)] + [sp (+ s (string-snip-dtext snip))] + [i 0] + [cnt 0] + [inserted-line? inserted-line?]) + (if (= i addlen) + (begin + (set! first-line (mline-first (unbox line-root-box))) + (set! last-line (mline-last (unbox line-root-box))) + (set! len (+ len addlen)) + (unless (= (last-position) (+ (mline-get-position last-line) + (mline-len last-line))) + (error "yuck out")) + (success-finish addlen inserted-line?)) + (begin + (when (equal? (string-ref str sp) #\return) + (string-set! str sp #\newline)) + (let ([c (string-ref str sp)]) + (cond + [(or (equal? c #\newline) (equal? c #\tab)) + (let ([newline? (equal? c #\newline)]) + (make-snipset (+ i start) (+ i start 1)) + (let ([snip (find-snip (+ i start) 'after)]) + (if newline? + + ;; forced return - split the snip + (begin + (set-snip-flags! snip + (remove-flag + (add-flag (add-flag (add-flag (snip->flags snip) + NEWLINE) + HARD-NEWLINE) + INVISIBLE) + CAN-APPEND)) + (if (not (eq? snip (mline-last-snip (snip->line snip)))) + (let* ([old-line (snip->line snip)] + [line (mline-insert old-line line-root-box #t)]) + (set-snip-line! snip line) + (set! num-valid-lines (add1 num-valid-lines)) + (set-mline-last-snip! line snip) + (set-mline-snip! line (mline-snip old-line)) + + ;; retarget snips moved to new line: + (let loop ([c-snip (mline-snip old-line)]) + (unless (eq? c-snip snip) + (set-snip-line! c-snip line) + (loop (snip->next c-snip)))) + + (set-mline-snip! old-line (snip->next snip)) + + (mline-calc-line-length old-line) + (mline-mark-recalculate old-line) + (when (max-width . > . 0) + (mline-mark-check-flow old-line)) + + (mline-calc-line-length line) + (mline-mark-recalculate line) + (when (max-width . > . 0) + (mline-mark-check-flow line))) + + ;; carriage-return inserted at the end of a auto-wrapped line; + ;; line lengths stay the same, but next line now starts + ;; a paragraph + (let ([next (mline-next (snip->line snip))]) + (when next + (when (zero? (mline-starts-paragraph next)) + (mline-set-starts-paragraph next #t)))))) + + ;; convert a tab to a tab-snip% + (let ([tabsnip (let ([ts (on-new-tab-snip)]) + (if (or (send ts is-owned?) + (positive? (snip->count ts))) + ;; uh-oh + (new tab-snip%) + ts))]) + (set-snip-style! tabsnip (snip->style snip)) + (let* ([rsnip (snip-set-admin tabsnip snip-admin)] + [tabsnip (if (not (eq? rsnip tabsnip)) + ;; uh-oh + (let ([tabsnip (new tab-snip%)]) + (set-snip-style! tabsnip (snip->style snip)) + (send tabsnip set-admin snip-admin) + tabsnip) + tabsnip)]) + + (set-snip-flags! tabsnip + (add-flag (snip->flags tabsnip) CAN-SPLIT)) + (send tabsnip insert "\t" 1 0) + (when (has-flag? (snip->flags tabsnip) CAN-SPLIT) + (set-snip-flags! tabsnip + (remove-flag (snip->flags tabsnip) CAN-SPLIT))) + + (splice-snip tabsnip (snip->prev snip) (snip->next snip)) + (set-snip-line! tabsnip (snip->line snip)) + (when (eq? (mline-snip (snip->line snip)) snip) + (set-mline-snip! (snip->line tabsnip) tabsnip)) + (when (eq? (mline-last-snip (snip->line snip)) snip) + (set-mline-last-snip! (snip->line tabsnip) tabsnip)))))) + + (let ([snip (find-snip (+ i start 1) 'after)]) + (let ([i (add1 i)]) + (loop (+ i start) + (if (= i addlen) #f (string-snip-buffer snip)) + (if (= i addlen) #f (string-snip-dtext snip)) + i + 0 + (or inserted-line? newline?)))))] + + [(cnt . > . MAX-COUNT-FOR-SNIP) + ;; divide up snip, because it's too large: + (make-snipset (+ i start) (+ i start)) + (let ([snip (find-snip (+ i start) 'after)]) + (loop (+ i start) + (string-snip-buffer snip) + (add1 (string-snip-dtext snip)) + (add1 i) + 1 + inserted-line?))] + + [else + (loop start str (+ sp 1) (+ i 1) (+ cnt 1) inserted-line?)]))))))))))) + + (define/override (insert . args) + (case-args + args + [([string? str]) + (do-insert #f str #f startpos endpos #t)] + [([string? str] + [exact-nonnegative-integer? start] + [(make-alts exact-nonnegative-integer? (symbol-in same)) [end 'same]] + [any? [scroll-ok? #t]]) + (do-insert #f str #f start end scroll-ok?)] + [([exact-nonnegative-integer? len] + [string? str]) + (do-insert #f str #f startpos endpos #t)] + [([exact-nonnegative-integer? len] + [string? str] + [exact-nonnegative-integer? start] + [(make-alts exact-nonnegative-integer? (symbol-in same)) [end 'same]] + [any? [scroll-ok? #t]]) + (do-insert #f (substring str 0 len) #f start end scroll-ok?)] + [([snip% snip] + [exact-nonnegative-integer? [start startpos]] + [(make-alts exact-nonnegative-integer? (symbol-in same)) [end 'same]] + [any? [scroll-ok? #t]]) + (do-insert snip #f #f start end scroll-ok?)] + [([char? ch]) + (do-insert-char ch startpos endpos)] + [([char? ch] + [exact-nonnegative-integer? start] + [(make-alts exact-nonnegative-integer? (symbol-in same)) [end 'same]]) + (do-insert-char ch start end)] + (method-name 'text% 'insert))) + + (define/public (do-insert-snips snips pos) + (do-insert #f #f snips pos pos #t)) + + (define/private (do-insert-char ch start end) + (let ([streak? typing-streak?] + [ifs? insert-force-streak?]) + (end-streaks '(delayed)) + (set! insert-force-streak? streak?) + (do-insert #f (string ch) #f start end #t) + (set! insert-force-streak? ifs?) + (set! typing-streak? #t))) + + (define/private (do-delete start end with-undo? [scroll-ok? #t]) + (unless (or write-locked? s-user-locked?) + (let-values ([(start end set-caret-style?) + (if (eq? end 'back) + (if (zero? start) + (values 0 0 #f) + (values (sub1 start) start #t)) + (values start end (and (= start startpos) + (= end endpos))))]) + (unless (or (start . >= . end) + (start . < . 0) + (start . >= . len)) + (let ([end (min end len)]) + (when ALLOW-X-STYLE-SELECTION? + (when (and (start . <= . startpos) (end . >= . endpos)) + (when (or (zero? delay-refresh) need-x-copy?) + (set! need-x-copy? #f) + (copy-out-x-selection)))) + + (set! write-locked? #t) + + (if (not (can-delete? start (- end start))) + (begin + (set! write-locked? #f) + (set! flow-locked? #f)) + (begin + (on-delete start (- end start)) + + (set! flow-locked? #t) + + (make-snipset start end) + (set! revision-count (add1 revision-count)) + + (let* ([start-snip (find-snip start 'before-or-none)] + [end-snip (find-snip end 'before)] + [with-undo? (and with-undo? + (zero? s-noundomode))] + [rec (if with-undo? + (begin + (when (not s-modified?) + (add-undo-rec (make-object unmodify-record% delayed-streak?))) + (make-object delete-record% + start end + (or deletion-streak? delayed-streak? + delete-force-streak? (not s-modified?)) + startpos endpos)) + #f)]) + + (when (and set-caret-style? sticky-styles?) + (set! caret-style (if start-snip + (snip->style (snip->next start-snip)) + (snip->style snips)))) + + (let-values ([(deleted-line? update-cursor?) + (let loop ([snip end-snip] + [deleted-line? #f] + [update-cursor? #f]) + (if (eq? snip start-snip) + (values deleted-line? update-cursor?) + (let ([update-cursor? + (or (and (eq? snip s-caret-snip) + (begin + (send s-caret-snip own-caret #f) + (set! s-caret-snip #f) + #t)) + update-cursor?)]) + + (when with-undo? + (send rec insert-snip snip)) + + (let* ([prev (snip->prev snip)] + [deleted-another-line? + (let ([line (snip->line snip)]) + (cond + [(eq? (mline-snip line) snip) + (if (eq? (mline-last-snip line) snip) + (begin + (mline-delete line line-root-box) + (set! num-valid-lines (sub1 num-valid-lines)) + #t) + (begin + (set-mline-snip! line (snip->next snip)) + #f))] + [(eq? (mline-last-snip line) snip) + (if (mline-next line) + (begin + (set-mline-last-snip! line (mline-last-snip (mline-next line))) + (mline-delete (mline-next line) line-root-box) + (set! num-valid-lines (sub1 num-valid-lines)) + #t) + (begin + (set-mline-last-snip! line prev) + ;; maybe deleted extra ghost line: + extra-line?))] + [else #f]))]) + (delete-snip snip) + (loop prev + (or deleted-line? + deleted-another-line?) + update-cursor?)))))]) + + (when (zero? snip-count) + (make-only-snip) + (when caret-style + (set-snip-style! snips caret-style) + (set! caret-style #f))) + + (set! first-line (mline-first (unbox line-root-box))) + (set! last-line (mline-last (unbox line-root-box))) + + (let-values ([(line moved-to-next?) + (if start-snip + (if (has-flag? (snip->flags start-snip) NEWLINE) + (if (mline-next (snip->line start-snip)) + (values (mline-next (snip->line start-snip)) + #t) + (begin + (mline-mark-check-flow (snip->line start-snip)) + (values #f #f))) + (values (snip->line start-snip) #f)) + (values first-line #f))]) + + (when line + ;; fix line references from possibly moved snips: + (let ([next (snip->next (mline-last-snip line))]) + (let loop ([snip (mline-snip line)]) + (unless (eq? snip next) + (set-snip-line! snip line) + (loop (snip->next snip))))) + + (mline-calc-line-length line) + (mline-mark-recalculate line) + + (when (max-width . >= . 0) + (mline-mark-check-flow line) + (let ([prev (mline-prev line)]) + (when (and prev + (has-flag? (snip->flags (mline-last-snip prev)) HARD-NEWLINE)) + (mline-mark-check-flow prev) + (when (and moved-to-next? + deleted-line? + (mline-prev prev) + (not (has-flag? (snip->flags (mline-last-snip (mline-prev prev))) + HARD-NEWLINE))) + ;; maybe the deleted object was in the middle of a long word, + ;; and maybe now the long word can be folded into the previous + ;; line + (mline-mark-check-flow (mline-prev prev))))))) + + (adjust-clickbacks start end (- start end) rec) + + (when with-undo? + (add-undo-rec rec) + (when (positive? delay-refresh) + (set! delayed-streak? #t))) + + (let ([dellen (- end start)]) + (set! len (- len dellen)) + + (check-merge-snips start) + + (set! flow-locked? #f) + (set! write-locked? #f) + + (cond + [(and (startpos . >= . start) (startpos . <= . end)) + (set! caret-blinked? #f) + (set! startpos start)] + [(startpos . > . end) + (set! caret-blinked? #f) + (set! startpos (- startpos dellen))]) + + (cond + [(and (endpos . >= . start) (endpos . <= . end)) + (set! endpos start)] + [(endpos . > . end) + (set! endpos (- endpos dellen))]) + + (unless refresh-unset? + (cond + [(and (refresh-start . >= . start) (refresh-start . <= . end)) + (set! refresh-start start)] + [(refresh-start . >= . end) + (set! refresh-start (- refresh-start dellen))]) + (cond + [(and (refresh-end . >= . start) (refresh-end . <= . end)) + (set! refresh-end start)] + [(refresh-end . >= . end) + (set! refresh-end (- refresh-end dellen))])) + + (set! extra-line? (has-flag? (snip->flags last-snip) NEWLINE)) + + (when (and scroll-ok? (= start startpos)) + (set! delay-refresh (add1 delay-refresh)) + (scroll-to-position/refresh startpos) + (set! delay-refresh (sub1 delay-refresh))) + + (set! changed? #t) + + (unless set-caret-style? + (set! caret-style #f)) + + (when (= len start) + ;; force recheck extra line state: + (set! graphic-maybe-invalid? #t) + (set! graphic-maybe-invalid-force? #t)) + + (if deleted-line? + (begin + (set! graphic-maybe-invalid? #t) + (need-refresh start)) + (refresh-by-line-demand)) + + (unless s-modified? + (set-modified #t)) + + (after-delete start dellen) + + (when update-cursor? + (when s-admin + (send s-admin update-cursor)))))))))))))) + + (define/public (delete . args) + (case-args + args + [() + (let ([streak? (= endpos startpos)] + [dstreak? deletion-streak?] + [dfs? delete-force-streak?]) + (end-streaks '(delayed)) + (set! delete-force-streak? dstreak?) + + (delete startpos (if (= startpos endpos) 'back endpos)) + + (set! delete-force-streak? dfs?) + (set! deletion-streak? streak?))] + [([(make-alts exact-nonnegative-integer? (symbol-in start)) start] + [(make-alts exact-nonnegative-integer? (symbol-in back)) [end 'back]] + [any? [scroll-ok? #t]]) + (do-delete (if (symbol? start) startpos start) end scroll-ok?)] + (method-name 'text% 'delete))) + + (def/public (erase) + (do-delete 0 len #t)) + + (def/override (clear) + (delete startpos endpos #t)) + + ;; ---------------------------------------- + + (def/override (cut [any? [extend? #f]] [exact-integer? [time 0]] + [(make-alts exact-nonnegative-integer? (symbol-in start)) [start 'start]] + [(make-alts exact-nonnegative-integer? (symbol-in end)) [end 'end]]) + (let* ([start (if (symbol? start) + startpos + start)] + [end (if (symbol? end) + endpos + end)] + [end (min end len)]) + (unless (start . >= . end) + (copy extend? time start end) + (delete start end)))) + + (def/override (do-copy [exact-nonnegative-integer? startp] + [exact-nonnegative-integer? endp] + [exact-integer? time] + [bool? extend?]) + (let ([startp (max startp 0)] + [endp (min endp len)]) + (unless (endp . <= . startp) + + (make-snipset startp endp) + + (let ([sl (or (and extend? copy-style-list) + s-style-list)]) + (set-common-copy-region-data! (get-region-data startp endp)) + + (let ([start (find-snip startp 'after)] + [end (find-snip endp 'after-or-none)] + [wl? write-locked?] + [fl? flow-locked?]) + + (set! write-locked? #t) + (set! flow-locked? #t) + + (let loop ([snip start]) + (unless (eq? snip end) + (let ([asnip (send snip copy)]) + (snip-set-admin asnip #f) + (set-snip-style! asnip (send sl convert (snip->style asnip))) + (cons-common-copy-buffer! asnip) + (cons-common-copy-buffer2! (get-snip-data snip))) + (loop (snip->next snip)))) + + (set! write-locked? wl?) + (set! flow-locked? fl?) + + (install-copy-buffer time sl)))))) + + (def/override (copy [any? [extend? #f]] [exact-integer? [time 0]] + [(make-alts exact-nonnegative-integer? (symbol-in start)) [start 'start]] + [(make-alts exact-nonnegative-integer? (symbol-in end)) [end 'end]]) + (let* ([start (if (symbol? start) + startpos + start)] + [end (if (symbol? end) + endpos + end)] + [end (min end len)]) + (unless (start . >= . end) + (begin-copy-buffer) + (unless extend? + (free-old-copies)) + (do-copy start end time extend?) + (end-copy-buffer)))) + + (define/private (do-generic-paste cb start time) + (set! read-insert start) + (set! read-insert-start start) + (let ([orig-len len]) + (do-buffer-paste cb time #f) + (let ([delta (- len orig-len)]) + (set! prev-paste-start start) + (set! prev-paste-end (+ start delta))))) + + (define/override (do-paste start time) + (do-generic-paste the-clipboard start time)) + + (define/override (do-paste-x-selection start time) + (do-generic-paste the-x-selection-clipboard start time)) + + (define/private (generic-paste x-sel? time start end) + (let* ([end (if (symbol? end) + (if (symbol? start) + endpos + start) + end)] + [start (if (eq? start 'start) + startpos + (if (symbol? start) + endpos + start))] + [end (min end len)]) + (unless (start . > . end) + + (begin-edit-sequence) + (when (start . < . end) + (delete start end)) + + (if x-sel? + (do-paste-x-selection start time) + (do-paste start time)) + + (let ([save-prev-paste prev-paste-start]) + (end-edit-sequence) + (set! prev-paste-start save-prev-paste))))) + + (def/override (paste [exact-integer? [time 0]] + [(make-alts exact-nonnegative-integer? (symbol-in start end)) [start 'start]] + [(make-alts exact-nonnegative-integer? (symbol-in same)) [end 'same]]) + (generic-paste #f time start end)) + + (def/override (paste-x-selection [exact-integer? [time 0]] + [(make-alts exact-nonnegative-integer? (symbol-in start end)) [start 'start]] + [(make-alts exact-nonnegative-integer? (symbol-in same)) [end 'same]]) + (generic-paste #t time start end)) + + (define/override (insert-paste-snip snip data) + (let ([addpos (snip->count snip)]) + (insert snip read-insert) + (when data + (let ([snip (find-snip read-insert 'after)]) + (set-snip-data snip data))) + (set! read-insert (+ read-insert addpos)))) + + (define/public (paste-region-data data) + (set-region-data read-insert-start read-insert data)) + + (define/override (insert-paste-string str) + (let* ([str (if (eq? 'windows (system-type)) + (regexp-replace* #rx"\r\n" str "\n") + str)] + ;; change non-breaking space to space: + [str (regexp-replace* #rx"\xA0" str " ")]) + + (insert str read-insert) + (set! read-insert (+ read-insert (string-length str))))) + + (def/public (paste-next) + (unless (prev-paste-start . < . 0) + (let ([start prev-paste-start] + [end prev-paste-end]) + + (copy-ring-next) + (begin-edit-sequence) + (delete start end) + (set! read-insert start) + (set! read-insert-start start) + + (let ([orig-len len]) + (do-buffer-paste the-clipboard 0 #t) + + (end-edit-sequence) + + (let ([delta (- len orig-len)]) + + (set! prev-paste-start start) + (set! prev-paste-end (+ start delta))))))) + + (define/private (do-kill time start end) + (let ([streak? kill-streak?]) + + (begin-edit-sequence) + (let-values ([(start end) + (if (symbol? start) + (let ([newend (paragraph-end-position (position-paragraph endpos posateol?))]) + (if (= newend startpos) + (set-position startpos (+ startpos 1) #f #t 'local) + (begin + (set-position startpos newend #f #t 'local) + + (let ([text (get-text startpos endpos)]) + (let loop ([i (- endpos startpos)]) + (if (zero? i) + ;; line has all spaces: move one more + (set-position startpos (+ endpos 1) #f #t 'local) + (let ([i (sub1 i)]) + (when (char-whitespace? (string-ref text i)) + (loop i)))))))) + (values startpos endpos)) + (values start end))]) + + (cut streak? time start end) + (end-edit-sequence) + + (set! kill-streak? #t)))) + + (define/override (kill . args) + (case-args + args + [([exact-integer? [time 0]]) + (do-kill 0 'start 'end)] + [([exact-integer? time] + [exact-nonnegative-integer? start] + [exact-nonnegative-integer? end]) + (do-kill time start end)] + (method-name 'text% 'kill))) + + (def/override (select-all) + (set-position 0 len)) + + (define/override (really-can-edit? op) + (cond + [read-locked? #f] + [(and (not (eq? 'copy op)) + (or flow-locked? write-locked?)) + #f] + [else + (case op + [(clear cut copy) + (not (= endpos startpos))] + [(kill) + (not (= len endpos))] + [(select-all) + (positive? len)] + [else #t])])) + + ;; ---------------------------------------- + + (def/public (split-snip [exact-nonnegative-integer? pos]) + (unless (or flow-locked? + (pos . <= . 0) + (pos . >= . len)) + (let ([wl? write-locked?]) + + (set! write-locked? #t) + (set! flow-locked? #t) + (make-snipset pos pos) + (set! write-locked? wl?) + (set! flow-locked? #f)))) + + (def/public (get-revision-number) + revision-count) + + (def/override (get-flattened-text) + (get-text 0 'eof #t #f)) + + (def/public (get-text [exact-nonnegative-integer? [start 0]] + [(make-alts exact-nonnegative-integer? (symbol-in eof)) [end 'eof]] + [any? [flat? #f]] + [any? [force-cr? #f]]) + (if read-locked? + "" + (let* ([end (if (eq? end 'eof) + len + end)] + [start (min start len)] + [end (max end start)] + [end (min end len)] + [count (- end start)]) + (if (zero? count) + "" + (let ([wl? write-locked?] + [fl? flow-locked?] + [p (open-output-string)]) + (set! write-locked? #t) + (set! flow-locked? #t) + + (let-values ([(snip s-pos) (find-snip/pos start 'after)]) + (let loop ([snip snip] + [offset (- start s-pos)] + [count count]) + (let ([num (min (- (snip->count snip) offset) + count)]) + (if (not flat?) + (display (send-generic snip snip%-get-text offset num #f) p) + (begin + (display (send-generic snip snip%-get-text offset num #t) p) + (when (and force-cr? + (has-flag? (snip->flags snip) NEWLINE) + (not (has-flag? (snip->flags snip) HARD-NEWLINE))) + (display "\n" p)))) + (let ([count (- count num)]) + (if (zero? count) + (begin + (set! write-locked? wl?) + (set! flow-locked? fl?) + (get-output-string p)) + (loop (snip->next snip) + 0 + count))))))))))) + + (def/public (get-character [exact-nonnegative-integer? start]) + (if read-locked? + #\nul + (let-values ([(snip s-pos) (find-snip/pos (max 0 (min start len)) 'after)]) + (let ([buffer (make-string 1)]) + (send snip get-text! buffer (- start s-pos) 1 0) + (string-ref buffer 0))))) + + ;; ---------------------------------------- + + (def/public (set-clickback [exact-nonnegative-integer? start] + [exact-nonnegative-integer? end] + [procedure? f] + [(make-or-false style-delta%) [c-delta #f]] + [any? [call-on-down? #f]]) + (let ([delta (make-object style-delta%)]) + (when c-delta + (send delta copy c-delta)) + + (let ([cb (make-clickback start + end + f + call-on-down? + delta + #f + null)]) + (set! clickbacks (cons cb clickbacks))))) + + (define/public (add-back-clickback cb) + (set! clickbacks (cons cb clickbacks))) + + (def/public (remove-clickback [exact-nonnegative-integer? start] + [exact-nonnegative-integer? end]) + (set! clickbacks + (filter (lambda (cb) + (not (and (= start (clickback-start cb)) + (= end (clickback-start cb))))) + clickbacks))) + + (def/public (call-clickback [exact-nonnegative-integer? start] + [exact-nonnegative-integer? end]) + (for-each (lambda (cb) + (when (and ((clickback-start cb) . <= . start) + ((clickback-end cb) . >= . end)) + ((clickback-f cb) this (clickback-start cb) (clickback-end cb)))) + clickbacks)) + + + (define/private (adjust-clickbacks start end d rec) + (when (pair? clickbacks) + (set! clickbacks + (filter (lambda (c) + (if (and ((clickback-start c) . >= . start) + ((clickback-end c) . <= . end)) + (begin + (when rec + (send rec add-clickback c)) + #f) + #t)) + clickbacks)) + (for-each (lambda (c) + (cond + [((clickback-start c) . >= . end) + (set-clickback-start! c (+ (clickback-start c) d)) + (set-clickback-end! c (+ (clickback-end c) d))] + [(and ((clickback-start c) . <= . start) + ((clickback-end c) . >= . end)) + (when (or (d . < . 0) ((clickback-end c) . > . end)) + (set-clickback-end! c (+ (clickback-end c) d)))] + [(and ((clickback-start c) . > . start) + ((clickback-end c) . > . end)) + (set-clickback-start! c start) + (set-clickback-end! c (+ (clickback-end c) d))])) + clickbacks) + (set! clickbacks + (filter (lambda (c) + (if (= (clickback-start c) (clickback-end c)) + (when rec + (send rec add-clickback c) + #f) + #t)) + clickbacks)))) + + (define/private (find-clickback start y) + (ormap (lambda (c) + (and ((clickback-start c) . <= . start) + ((clickback-end c) . > . start) + ;; we're in the right horizontal region, but maybe the mouse + ;; is above or below the clickback + (let ([start (find-snip (clickback-start c) 'after)] + [end (find-snip (clickback-end c) 'before)]) + (and start + end + (let-boxes ([top 0.0] + [bottom 0.0]) + (begin + (get-snip-location start #f top #f) + (get-snip-location start #f bottom #t)) + (let loop ([start start] + [top top] + [bottom bottom]) + (if (eq? end start) + (and (y . >= . top) + (y . <= . bottom) + c) + (let ([start (snip->next start)]) + (let-boxes ([ntop 0.0] + [nbottom 0.0]) + (begin + (get-snip-location start #f ntop #f) + (get-snip-location start #f nbottom #t)) + (loop start + (min ntop top) + (max nbottom bottom))))))))))) + clickbacks)) + + (define/private (set-clickback-hilited c on?) + (when (not (eq? (and on? #t) + (clickback-hilited? c))) + (cond + [on? + (s-start-intercept) + + (begin-edit-sequence) + (flash-on (clickback-start c) (clickback-end c) #f #f 0) + (do-change-style (clickback-start c) (clickback-end c) #f (clickback-delta c) #f) + (end-edit-sequence) + + (set-clickback-unhilite! c (s-end-intercept))] + [else + (perform-undo-list (clickback-unhilite c)) + (set-clickback-unhilite! c null) + (flash-off)]) + (set-clickback-hilited?! (and on? #t)))) + + ;; ---------------------------------------- + + (def/public (flash-on [exact-nonnegative-integer? start] + [exact-nonnegative-integer? end] + [any? [ateol? #f]] + [any? [scroll? #t]] + [exact-nonnegative-integer? [timeout 500]]) + (do-set-position #t 'none start end ateol? scroll? 'default) + (when (timeout . > . 0) + (set! flashautoreset? #t) + (when flash-timer + (send flash-timer stop)) + (set! flash-timer (new flash-timer% [editor this])) + (send flash-timer start timeout)) + (set! flashscroll? scroll?)) + + (def/public (flash-off) + (when flash? + (set! flashautoreset? #t) + (set! flashdirectoff? #t) + (do-set-position #f 'none startpos endpos posateol? flashscroll? 'default))) + + ;; ---------------------------------------- + + (def/public (set-wordbreak-func [procedure? f]) + (set! word-break f)) + + (def/public (find-wordbreak [(make-or-false (make-box exact-nonnegative-integer?)) start] + [(make-or-false (make-box exact-nonnegative-integer?)) end] + [(symbol-in caret line selection user1 user2) reason]) + (unless read-locked? + (let ([oldstart (if start (unbox start) 0)] + [oldend (if end (unbox end) 0)]) + (word-break this start end reason) + + (when (and start ((unbox start) . > . oldstart)) + (set-box! start oldstart)) + (when (and end ((unbox end) . < . oldend)) + (set-box! end oldend))))) + + (def/public (get-wordbreak-map) + word-break-map) + + (def/public (set-wordbreak-map [(make-or-false editor-wordbreak-map%) map]) + (set! word-break-map map)) + + ;; ---------------------------------------- + + (def/public (set-line-spacing [nonnegative-real? s]) + (unless (or flow-locked? + (= line-spacing s)) + (set! line-spacing s) + (size-cache-invalid) + (set! changed? #t) + (need-refresh -1 -1))) + + (def/public (get-line-spacing) line-spacing) + + (def/override (get-max-width) + (if (max-width . <= . 0) + 'none + (+ max-width wrap-bitmap-width))) + + (def/override (get-min-width) + (if (min-width . <= . 0) + 'none + min-width)) + + (def/override (set-max-width [(make-alts nonnegative-real? (symbol-in none)) w]) + (unless flow-locked? + (let* ([w (if (eq? w 'none) 0.0 w)] + [w (if (and (positive? wrap-bitmap-width) (w . > . 0)) + (let ([w (- w wrap-bitmap-width)]) + (if (w . <= . 0.0) + (+ CURSOR-WIDTH 1) + w)) + w)]) + (unless (or (= max-width w) + (and (w . <= . 0) (max-width . <= . 0)) + (not (can-set-size-constraint?))) + (on-set-size-constraint) + + (let ([w (if (and (w . > . 0) + (w . < . (+ CURSOR-WIDTH 1))) + (+ CURSOR-WIDTH 1) + w)]) + (set! max-width w) + (set! flow-invalid? #t) + (set! graphic-maybe-invalid? #t) + (set! changed? #t) + (need-refresh -1 -1) + + (after-set-size-constraint)))))) + + (define/private (set-m-x v current setter) + (let ([v (if (eq? v 'none) 0.0 v)]) + (unless (or flow-locked? + (= current v) + (and (v . <= . 0) (current . <= . 0)) + (not (can-set-size-constraint?))) + (on-set-size-constraint) + + (set! graphic-maybe-invalid? #t) + (set! graphic-maybe-invalid-force? #t) + (setter v) + (set! changed? #t) + (need-refresh -1 -1) + + (after-set-size-constraint)))) + + (def/override (set-min-width [(make-alts nonnegative-real? (symbol-in none)) w]) + (set-m-x w min-width (lambda (w) (set! min-width w)))) + + (def/override (set-min-height [(make-alts nonnegative-real? (symbol-in none)) h]) + (set-m-x h min-height (lambda (h) (set! min-height h)))) + + (def/override (set-max-height [(make-alts nonnegative-real? (symbol-in none)) h]) + (set-m-x h max-height (lambda (h) (set! max-height h)))) + + (def/override (get-min-height) + (if (min-height . <= . 0) + 'none + min-height)) + + (def/override (get-max-height) + (if (max-height . <= . 0) + 'none + max-height)) + + ;; ---------------------------------------- + + (def/override (insert-port [input-port? f] + [(symbol-in guess same copy standard text text-force-cr) [format 'guess]] + [any? [replace-styles? #f]]) + (if (or write-locked? s-user-locked?) + 'guess ;; FIXME: docs say that this is more specific + (do-insert-file (method-name 'text% 'insert-file) f format replace-styles?))) + + (define/private (do-insert-file who f format clear-styles?) + (let ([format + (cond + [(or (eq? 'guess format) (eq? 'same format) (eq? 'copy format)) + (if (not (detect-wxme-file who f #t)) + 'text + 'standard)] + [else format])]) + + (let ([fileerr? + (cond + [(eq? 'standard format) + (if (not (detect-wxme-file who f #f)) + (error who "not a WXME file") + (let* ([b (make-object editor-stream-in-file-base% f)] + [mf (make-object editor-stream-in% b)]) + (not (and (read-editor-version mf b #f #t) + (read-editor-global-header mf) + (send mf ok?) + (read-from-file mf clear-styles?) + (read-editor-global-footer mf) + (begin + ;; if STD-STYLE wasn't loaded, re-create it: + (send s-style-list new-named-style "Standard" (send s-style-list basic-style)) + (send mf ok?))))))] + [(or (eq? format 'text) (eq? format 'text-force-cr)) + (let loop () + (let ([l (read-string 256 f)]) + (unless (eof-object? l) + (insert l) + (loop)))) + #f])]) + + (when fileerr? + (error who "error loading the file")) + + format))) + + (def/override (save-port [output-port? f] + [(symbol-in guess same copy standard text text-force-cr) [format 'same]] + [any? [show-errors? #t]]) + (when read-locked? + (error (method-name 'text% 'save-file) "editor locked for reading")) + + (let ([format + (cond + [(or (eq? 'same format) (eq? 'guess format) (eq? 'copy format)) + file-format] + [else format])]) + + (let ([fileerr? + (cond + [(or (eq? 'text format) (eq? 'text-force-cr format)) + (display (get-text 0 'eof #t (eq? format 'text-force-cr)) f) + #f] + [else + (let* ([b (make-object editor-stream-out-file-base% f)] + [mf (make-object editor-stream-out% b)]) + (not (and (write-editor-version mf b) + (write-editor-global-header mf) + (send mf ok?) + (write-to-file mf) + (write-editor-global-footer mf) + (send mf ok?))))])]) + (when fileerr? + (error (method-name 'text% 'save-port) "error writing editor content")) + #t))) + + + (define/private (do-read-from-file f start overwritestyle?) + (if write-locked? + #f + (let ([start (if (symbol? start) + startpos + start)]) + (set! read-insert start) + (let ([result (read-snips-from-file f overwritestyle?)]) + + (when (zero? len) + ;; we probably destructively changed the style list; reset the dummy snip + (set-snip-style! snips (or (get-default-style) + (send s-style-list basic-style)))) + + result)))) + + (define/override (read-from-file . args) + (case-args + args + [([editor-stream-in% f] [exact-nonnegative-integer? start] [any? [overwritestyle? #t]]) + (do-read-from-file f start overwritestyle?)] + [([editor-stream-in% f] [any? [overwritestyle? #t]]) + (do-read-from-file f 'start overwritestyle?)] + (method-name 'text% 'read-from-file))) + + (define/override (do-read-insert snip) + (if (list? snip) + (let ([oldlen len]) + (do-insert #f #f snip startpos startpos #t) + (set! read-insert (+ read-insert (- len oldlen))) + #t) + (let ([addpos (snip->count snip)]) + (do-insert snip #f #f startpos startpos #t) + (set! read-insert (+ addpos read-insert)) + #t))) + + (def/override (write-to-file [editor-stream-out% f] + [exact-nonnegative-integer? [start 0]] + [(make-alts exact-nonnegative-integer? (symbol-in eof)) [end 'eof]]) + (if read-locked? + #f + (let ([end (max (if (eq? end 'eof) + len + end) + start)]) + (let ([start-snip (if (zero? len) #f (find-snip start 'after))] + [end-snip (if (zero? len) #f (find-snip end 'after-or-none))]) + (and (do-write-headers-footers f #t) + (write-snips-to-file f s-style-list #f start-snip end-snip #f this) + (do-write-headers-footers f #f)))))) + + (def/public (get-file-format) file-format) + (def/public (set-file-format [(symbol-in standard text text-force-cr) format]) + (set! file-format format)) + + (def/override (set-filename [(make-or-false path-string?) name][any? [temp? #f]]) + (set! s-filename (if (string? name) + (string->path name) + name)) + (set! s-temp-filename? temp?) + (let ([wl? write-locked?] + [fl? flow-locked?]) + (set! write-locked? #t) + (set! flow-locked? #t) + + (let loop ([snip snips]) + (when snip + (when (has-flag? (snip->flags snip) USES-BUFFER-PATH) + (send snip set-admin snip-admin)) + (loop (snip->next snip)))) + + (set! write-locked? wl?) + (set! flow-locked? fl?))) + + ;; ---------------------------------------- + + (def/public (get-region-data [exact-nonnegative-integer? start] + [exact-nonnegative-integer? end]) + #f) + + (def/public (set-region-data [exact-nonnegative-integer? start] + [exact-nonnegative-integer? end] + [editor-data% d]) + (void)) + + ;; ---------------------------------------- + + (def/public (get-tabs [maybe-box? [count #f]] + [maybe-box? [space #f]] + [maybe-box? [in-units #f]]) + (when count + (set-box! count (vector-length tabs))) + (when space + (set-box! space (if (symbol? tab-space) + #f + tab-space))) + (when in-units + (set-box! in-units tab-space-in-units?)) + + (vector->list tabs)) + + (def/public (set-tabs [(make-list real?) newtabs] + [(make-alts real? (symbol-in tab-width)) [tab-width 20]] + [any? [in-units? #t]]) + (unless flow-locked? + (set! tabs (list->vector newtabs)) + + (if (and (number? tab-width) (tab-width . >= . 1)) + (set! tab-space (exact->inexact tab-width)) + (set! tab-space TAB-WIDTH)) + + (set! tab-space-in-units? in-units?) + + (size-cache-invalid) + (set! changed? #t) + (need-refresh -1 -1))) + + ;; ---------------------------------------- + + (define/private (do-find-position-in-line internal? i x ateol?-box onit?-box how-close-box) + (when onit?-box + (set-box! onit?-box #f)) + (when ateol?-box + (set-box! ateol?-box #f)) + (when how-close-box + (set-box! how-close-box 100.0)) + + (cond + [(and (not internal?) (not (check-recalc #t #f))) + 0] + [(i . < . 0) 0] + [(i . >= . num-valid-lines) len] + [else + (let* ([line (mline-find-line (unbox line-root-box) i)] + [x (- x (mline-get-left-location line max-width))]) + (if (x . <= . 0) + (find-first-visible-position line) + (let ([p (mline-get-position line)]) + (let-values ([(snip s-pos p) + (if (x . >= . (mline-w line)) + ;; snip == the last one + (let ([snip (mline-last-snip line)]) + (values snip + (+ p (- (mline-len line) (snip->count snip))) + (+ p (mline-len line)))) + (begin + (when onit?-box + (set-box! onit?-box #t)) + + (let ([dc (send s-admin get-dc)] + [X 0] + [wl? write-locked?] + [fl? flow-locked?]) + (set! write-locked? #t) + (set! flow-locked? #t) + + ;; linear seach for snip + (let ([topy (mline-get-location line)]) + (let loop ([snip (mline-snip line)] + [X X] + [x x] + [p p]) + (let-boxes ([w 0.0]) + (when dc (send snip get-extent dc X topy w #f #f #f #f #f)) + (if (and (x . > . w) (snip->next snip) dc) + (loop (snip->next snip) + (+ X w) + (- x w) + (+ p (snip->count snip))) + ;; found the right snip + (let ([s-pos p] + [p (+ p (do-find-position-in-snip dc X topy snip x how-close-box))]) + (set! write-locked? wl?) + (set! flow-locked? fl?) + (values snip s-pos p)))))))))]) + + ;; back up over invisibles + (let ([atsnipend? (- (- p s-pos) (snip->count snip))]) + (let-boxes ([p p] + [snip snip]) + (when atsnipend? + (find-last-visible-position line p snip)) + (when (and ateol?-box + atsnipend? + snip + (eq? snip (mline-last-snip line))) + (set-box! ateol?-box #t)) + p))))))])) + + (define/private (find-first-visible-position line [snip #f]) + (if read-locked? + 0 + (let* ([snip (or snip (mline-snip line))] + [startp (mline-get-position line)] + [p startp] + [next-snip (snip->next (mline-last-snip line))]) + (let loop ([snip snip] + [p p]) + (cond + [(eq? snip next-snip) + ;; if everything is invisible, then presumably the CR is forced, + ;; so go to the beginning of the line anyway + startp] + [(has-flag? (snip->flags snip) INVISIBLE) + (loop (snip->next snip) (+ p (snip->count snip)))] + [else p]))))) + + (define/private (find-last-visible-position line p-box [snip-box #f]) + (unless read-locked? + (let ([snip (or (if snip-box + (unbox snip-box) + #f) + (mline-last-snip line))] + [p (unbox p-box)]) + (let loop ([p p] + [snip snip]) + (let ([p (if (has-flag? (snip->flags snip) INVISIBLE) + (- p (snip->count snip)) + p)]) + (if (eq? snip (mline-snip line)) + (begin + (set-box! p-box p) + (when snip-box + (set-box! snip-box snip))) + (loop p (snip->prev snip)))))))) + + (def/public (find-position-in-line [exact-nonnegative-integer? i] + [real? x] + [maybe-box? [ateol? #f]] + [maybe-box? [onit? #f]] + [maybe-box? [how-close #f]]) + (do-find-position-in-line #f i x ateol? onit? how-close)) + + (define/private (do-find-position-in-snip dc X Y snip x how-close) + (cond + [read-locked? 0] + [(x . < . 0) + (when how-close + (set-box! how-close -100.0)) + 0] + [else + (let ([wl? write-locked?] + [fl? flow-locked?]) + (set! write-locked? #t) + (set! flow-locked? #t) + + (let ([c (snip->count snip)]) + (if ((send snip partial-offset dc X Y c) . <= . x) + (begin + (when how-close + (set-box! how-close 100.0)) + (set! write-locked? wl?) + (set! flow-locked? fl?) + c) + + ;; binary search for position within snip: + (let loop ([range c] + [i (quotient c 2)] + [offset 0]) + (let ([dl (send snip partial-offset dc X Y (+ offset i))]) + (if (dl . > . x) + (loop i (quotient i 2) offset) + (let ([dr (send snip partial-offset dc X Y (+ offset i 1))]) + (if (dr . <= . x) + (let ([range (- range i)]) + (loop range (quotient range 2) (+ offset i))) + (begin + (when how-close + (set-box! how-close + (if ((- dr x) . < . (- x dl)) + (- dr x) + (- dl x)))) + (set! write-locked? wl?) + (set! flow-locked? fl?) + (+ i offset))))))))))])) + + (def/public (find-line [real? y] [maybe-box? [onit? #f]]) + (when onit? + (set-box! onit? #f)) + + (cond + [(not (check-recalc #t #f)) 0] + [(y . <= . 0) 0] + [(or (y . >= . total-height) (and extra-line? (y . >= . (- total-height extra-line-h)))) + (- num-valid-lines (if extra-line? 0 1))] + [else + (when onit? + (set-box! onit? #t)) + (mline-get-line (mline-find-location (unbox line-root-box) y))])) + + (def/public (find-position [real? x] [real? y] + [maybe-box? [ateol? #f]] + [maybe-box? [onit? #f]] + [maybe-box? [how-close #f]]) + (if read-locked? + 0 + (begin + (when ateol? + (set-box! ateol? #f)) + + (let* ([online (box #f)] + [i (find-line y online)]) + (if (and (i . >= . (- num-valid-lines 1)) + (not (unbox online)) + (y . > . 0)) + (begin + (when onit? + (set-box! onit? #f)) + (when how-close + (set-box! how-close 100.0)) + len) + (let ([p (find-position-in-line i x ateol? onit? how-close)]) + (when onit? + (set-box! onit? (and (unbox online) (unbox onit?)))) + p)))))) + + (def/public (position-line [exact-nonnegative-integer? start] + [any? [eol? #f]]) + (cond + [(not (check-recalc (max-width . > . 0) #f #t)) 0] + [(start . <= . 0) 0] + [(start . >= . len) + (if (and extra-line? (not eol?)) + num-valid-lines + (- num-valid-lines 1))] + [else + (let* ([line (mline-find-position (unbox line-root-box) start)] + [line (if (and eol? (= (mline-get-position line) start)) + (mline-prev line) + line)]) + (mline-get-line line))])) + + + (def/public (get-snip-position-and-location [snip% thesnip] [maybe-box? pos] + [maybe-box? [x #f]] [maybe-box? [y #f]]) + (cond + [(not (check-recalc (or x y) #f)) + #f] + [(or (not (snip->line thesnip)) + (not (eq? (mline-get-root (snip->line thesnip)) (unbox line-root-box)))) + #f] + [(or pos x y) + (let* ([line (snip->line thesnip)] + [p (mline-get-position line)]) + (let loop ([snip (mline-snip line)] + [p p]) + (if (eq? snip thesnip) + (begin + (when pos + (set-box! pos p)) + (when (or x y) + (position-location p x y)) + #t) + (loop (snip->next snip) + (+ p (snip->count snip))))))] + [else #t])) + + (def/override (get-snip-location [snip% thesnip] [maybe-box? [x #f]] [maybe-box? [y #f]] [any? [bottom-right? #f]]) + (let ([x (or x (and bottom-right? (box 0.0)))] + [y (or y (and bottom-right? (box 0.0)))]) + (if (get-snip-position-and-location thesnip #f x y) + (if bottom-right? + (let ([wl? write-locked?] + [fl? flow-locked?]) + (set! write-locked? #t) + (set! flow-locked? #t) + + (let ([dc (send s-admin get-dc)]) + (let-boxes ([w 0.0] + [h 0.0]) + (send thesnip get-extent dc (unbox x) (unbox y) w h #f #f #f #f) + + (set! write-locked? wl?) + (set! flow-locked? fl?) + + (set-box! x (+ (unbox x) w)) + (set-box! y (+ (unbox y) h)) + #t))) + #t) + #f))) + + (def/public (get-snip-position [snip% thesnip]) + (let-boxes ([pos 0]) + (unless (get-snip-position-and-location thesnip pos) + (set-box! pos #f)) + pos)) + + (def/public (position-locations [exact-nonnegative-integer? start] + [maybe-box? [tx #f]] + [maybe-box? [ty #f]] + [maybe-box? [bx #f]] + [maybe-box? [by #f]] + [any? [eol? #f]] + [any? [whole-line? #f]]) + (when (check-recalc #t #f) + + ;; handle boundary cases first: + (let ([line + (cond + [(start . <= . 0) + (if whole-line? + (begin + (when (or tx bx) + (let ([xl (mline-get-left-location first-line max-width)]) + (when tx (set-box! tx xl)) + (when bx (set-box! bx xl)))) + (when (or ty by) + (let ([yl (mline-get-location first-line)]) + (when ty (set-box! ty yl)) + (when by (set-box! by (+ yl (mline-h first-line)))))) + #f) + first-line)] + [(start . >= . len) + (if (and extra-line? (not eol?)) + (begin + (when ty (set-box! ty (- total-height extra-line-h))) + (when by (set-box! by total-height)) + (when tx (set-box! tx 0)) + (when bx (set-box! bx 0)) + #f) + (if (or whole-line? (zero? len)) + (begin + (when (or tx bx) + (let ([xl (mline-get-right-location last-line max-width)]) + (when tx (set-box! tx xl)) + (when bx (set-box! bx xl)))) + (when (or ty by) + (let ([yl (mline-get-location last-line)]) + (when ty (set-box! ty yl)) + (when by (set-box! by (+ yl (mline-h last-line)))))) + #f) + last-line))] + [else + (let ([line (mline-find-line (unbox line-root-box) (position-line start eol?))]) + (if whole-line? + (begin + (when (or by ty) + (let ([yl (mline-get-location line)]) + (when ty (set-box! ty yl)) + (when by (set-box! by (+ yl (mline-h line)))))) + (if (not (or tx bx)) + #f + line)) + line))])]) + (when line + (let ([wl? write-locked?] + [fl? flow-locked?]) + (set! write-locked? #t) + (set! flow-locked? #t) + + (let ([horiz (mline-get-left-location line max-width)] + [topy (mline-get-location line)] + [start (- start (mline-get-position line))]) + (let-values ([(snip horiz start dc) + (cond + [(zero? start) (values (mline-snip line) horiz start #f)] + [(start . >= . (mline-len line)) + (values (mline-last-snip line) (+ horiz (- (mline-w line) (mline-last-w line))) + start #f)] + [else + ;; linear seach for snip + (let loop ([snip (mline-snip line)] + [start start] + [horiz horiz] + [dc #f]) + (if (or (start . > . (snip->count snip)) + (and (or whole-line? (positive? start)) + (= start (snip->count snip)))) + (let* ([start (- start (snip->count snip))] + [dc (or dc (send s-admin get-dc))]) + (let-boxes ([v 1.0]) + (when dc + (send snip get-extent dc horiz topy v #f #f #f #f #f)) + (loop (snip->next snip) start (+ horiz v) dc))) + ;; found snip + (values snip horiz start dc)))])]) + (let ([dc + (if (or tx bx) + (let ([dc (or dc + (and (positive? start) + (send s-admin get-dc)))]) + (let ([xv (+ horiz + (if (and dc (positive? start)) + (send snip partial-offset dc horiz topy start) + 0))]) + (when tx (set-box! tx xv)) + (when bx (set-box! bx xv))) + dc) + dc)]) + (when (and (not whole-line?) + (or ty by)) + (let ([dc (or dc (send s-admin get-dc))]) + (let-boxes ([h 0.0] + [descent 0.0] + [space 0.0]) + (send snip get-extent dc horiz topy #f h descent space #f #F) + (let ([align (send (snip->style snip) get-alignment)]) + (cond + [(eq? 'bottom align) + (let ([yl (+ topy (mline-bottombase line) descent)]) + (when ty (set-box! ty (- yl h))) + (when by (set-box! by yl)))] + [(eq? 'top align) + (let ([yl (- (+ topy (mline-topbase line)) space)]) + (when ty (set-box! ty yl)) + (when by (set-box! by (+ yl h))))] + [else + (let* ([h (/ (- h descent space) 2)] + [yl (+ topy (/ (+ (mline-topbase line) (mline-bottombase line)) 2))]) + (when ty (set-box! ty (- yl h space))) + (when by (set-box! by (+ yl h descent))))]))))) + + (set! write-locked? wl?) + (set! flow-locked? fl?))))))))) + + (def/public (position-location [exact-nonnegative-integer? start] + [maybe-box? [x #f]] + [maybe-box? [y #f]] + [any? [top? #t]] + [any? [eol? #f]] + [any? [whole-line? #f]]) + (position-locations start + (if top? x #f) (if top? y #f) + (if top? #f x) (if top? #f y) + eol? whole-line?)) + + (def/public (line-location [exact-nonnegative-integer? i] + [any? [top? #t]]) + (cond + [(not (check-recalc #t #f)) 0.0] + [(i . < . 0) 0.0] + [(i . > . num-valid-lines) total-height] + [(= num-valid-lines i) + (if extra-line? + (- total-height extra-line-h) + total-height)] + [else + (let* ([line (mline-find-line (unbox line-root-box) i)] + [y (mline-get-location line)]) + (if top? + y + (+ y (mline-h line))))])) + + (define/private (do-line-position start? i visible-only?) + (cond + [(not (check-recalc (max-width . > . 0) #f #t)) + 0] + [(and (i . >= . num-valid-lines) extra-line?) + len] + [else (let* ([i (max 0 (min i (sub1 num-valid-lines)))] + [line (mline-find-line (unbox line-root-box) i)]) + (if start? + (if visible-only? + (find-first-visible-position line) + (mline-get-position line)) + (let ([p (+ (mline-get-position line) (mline-len line))]) + (if visible-only? + (let-boxes ([p p]) + (find-last-visible-position line p) + p) + p))))])) + + (def/public (line-start-position [exact-nonnegative-integer? i] + [any? [visible-only? #t]]) + (do-line-position #t i visible-only?)) + + (def/public (line-end-position [exact-nonnegative-integer? i] + [any? [visible-only? #t]]) + (do-line-position #f i visible-only?)) + + + (def/public (line-length [exact-nonnegative-integer? i]) + (cond + [(not (check-recalc (max-width . > . 0) #f #t)) + 0] + [(i . < . 0) 0] + [(i . >= . num-valid-lines) 0] + [else (let ([line (mline-find-line (unbox line-root-box) i)]) + (mline-len line))])) + + (def/public (position-paragraph [exact-nonnegative-integer? i] + [any? [at-eol? #f]]) + (cond + [(not (check-recalc #f #f #t)) 0] + [else (let ([delta (if (and (i . >= . len) extra-line?) + 1 + 0)] + [i (max 0 (min i len))]) + (let ([line (mline-find-position (unbox line-root-box) i)]) + (+ (mline-get-paragraph line) delta)))])) + + (def/public (paragraph-start-position [exact-nonnegative-integer? i] + [any? [visible-only? #t]]) + (if (not (check-recalc #f #f #t)) + 0 + (if (i . > . (+ (last-paragraph) (if extra-line? -1 0))) + len + (let* ([i (max 0 i)] + [l (mline-find-paragraph (unbox line-root-box) i)] + [l (if (not l) + (if extra-line? + len + (let loop ([l last-line]) + (if (and (mline-prev l) + (not (mline-starts-paragraph l))) + (loop (mline-prev l)) + l))) + l)]) + (if visible-only? + (find-first-visible-position l) + (mline-get-position l)))))) + + (def/public (paragraph-end-position [exact-nonnegative-integer? i] + [any? [visible-only? #t]]) + (if (not (check-recalc #f #f #t)) + 0 + (let* ([i (max 0 i)] + [l (mline-find-paragraph (unbox line-root-box) i)] + [l (if l + (let loop ([l l]) + (if (and (mline-next l) + (zero? (mline-starts-paragraph (mline-next l)))) + (loop (mline-next l)) + l)) + (if extra-line? + len + last-line))]) + (if (mline? l) + (let ([p (+ (mline-get-position l) (mline-len l))]) + (if visible-only? + (let-boxes ([p p]) + (find-last-visible-position l p) + p) + p)) + l)))) + + (def/public (line-paragraph [exact-nonnegative-integer? i]) + (cond + [(not (check-recalc (max-width . > . 0) #f #t)) + 0] + [(i . < . 0) 0] + [(i . >= . num-valid-lines) + (+ (mline-get-paragraph last-line) (if extra-line? 1 0))] + [else + (let ([l (mline-find-line (unbox line-root-box) i)]) + (mline-get-paragraph l))])) + + (def/public (paragraph-start-line [exact-nonnegative-integer? i]) + (if (not (check-recalc (max-width . > . 0) #f #t)) + 0 + (let* ([i (max i 0)] + [l (mline-find-paragraph (unbox line-root-box) i)]) + (if (not l) + (last-line) + (mline-get-line l))))) + + (def/public (paragraph-end-line [exact-nonnegative-integer? i]) + (if (not (check-recalc (max-width . > . 0) #f #t)) + 0 + (let* ([i (max i 0)] + [l (mline-find-paragraph (unbox line-root-box) i)]) + (mline-get-line + (if l + (let loop ([l l]) + (if (and (mline-next l) + (not (mline-starts-paragraph (mline-next l)))) + (loop (mline-next l)) + l)) + last-line))))) + + (def/public (last-position) len) + + (public [/last-line last-line]) + (define (/last-line) + (if (not (check-recalc (max-width . > . 0) #f #t)) + 0 + (- num-valid-lines (if extra-line? 0 1)))) + + (def/public (last-paragraph) + (if (not (check-recalc #f #f #t)) + 0 + (+ (mline-get-paragraph last-line) (if extra-line? 1 0)))) + + ;; ---------------------------------------- + + (def/override (get-extent [maybe-box? w] [maybe-box? h]) + (check-recalc #t #f) + (when w (set-box! w total-width)) + (when h (set-box! h total-height))) + + (def/override (get-descent) + (check-recalc #t #f) + final-descent) + + (def/override (get-space) + (check-recalc #t #f) + initial-space) + + (def/public (get-top-line-base) + (check-recalc #t #f) + initial-line-base) + + (def/override (scroll-line-location [exact-nonnegative-integer? scroll]) + (if read-locked? + 0.0 + (begin + (check-recalc #t #f) + (let ([total (+ (mline-get-scroll last-line) (mline-numscrolls last-line))]) + (cond + [(= total scroll) + (if extra-line? + (- total-height extra-line-h) + total-height)] + [(scroll . > . total) + total-height] + [else + (let* ([line (mline-find-scroll (unbox line-root-box) scroll)] + [p (mline-get-scroll line)] + [y (mline-get-location line)]) + (if (p . < . scroll) + (+ y (mline-scroll-offset line (- scroll p))) + y))]))))) + + (def/override (num-scroll-lines) + (if read-locked? + 0 + (begin + (check-recalc (max-width . > . 0) #f #t) + (+ (mline-get-scroll last-line) + (mline-numscrolls last-line) + (if extra-line? 1 0))))) + + (def/override (find-scroll-line [real? p]) + (if read-locked? + 0 + (begin + (check-recalc #t #f) + (if (and extra-line? + (p . >= . (- total-height extra-line-h))) + (- (num-scroll-lines) 1) + (let* ([line (mline-find-location (unbox line-root-box) p)] + [s (mline-get-scroll line)]) + (if ((mline-numscrolls line) . > . 1) + (let ([y (mline-get-location line)]) + (+ s (mline-find-extra-scroll line (- p y)))) + s)))))) + + ;; ---------------------------------------- + + (def/public (find-string [string? str] + [(symbol-in forward backward) [direction 'forward]] + [(make-alts exact-nonnegative-integer? (symbol-in start)) [start 'start]] + [(make-alts exact-nonnegative-integer? (symbol-in eof)) [end 'eof]] + [any? [bos? #t]] + [any? [case-sens? #t]]) + (if (not (check-recalc #f #f)) + #f + (do-find-string-all str direction start end #t bos? case-sens?))) + + (def/public (find-string-all [string? str] + [(symbol-in forward backward) [direction 'forward]] + [(make-alts exact-nonnegative-integer? (symbol-in start)) [start 'start]] + [(make-alts exact-nonnegative-integer? (symbol-in eof)) [end 'eof]] + [any? [bos? #t]] + [any? [case-sens? #t]]) + (if (not (check-recalc #f #f)) + null + (reverse (do-find-string-all str direction start end #f bos? case-sens?)))) + + (def/public (find-newline [(symbol-in forward backward) [direction 'forward]] + [(make-alts exact-nonnegative-integer? (symbol-in start)) [start 'start]] + [(make-alts exact-nonnegative-integer? (symbol-in eof)) [end 'eof]]) + (let* ([para (position-paragraph (if (symbol? start) + startpos + start) + (eq? direction 'backward))] + [pos (if (eq? direction 'backward) + (paragraph-start-position para) + (if (para . >= . (last-paragraph)) + len + (paragraph-start-position (add1 para))))] + [end (if (symbol? end) len end)]) + (if (eq? direction 'forward) + (if (pos . > . end) + #f + pos) + (if (pos . < . end) + #f + pos)))) + + (define/private (do-find-string-all str direction + start end + just-one? + bos? + case-sens?) + + (let ([start (min (if (symbol? start) + startpos + start) + len)] + [end (min (if (symbol? end) + (if (eq? direction 'forward) + len + 0) + end) + len)]) + (let ([total-count + (if (eq? direction 'backward) + (- start end) + (- end start))]) + (if (or (negative? total-count) + (string=? str "")) + (if just-one? #f null) + + (let ([slen (string-length str)] + [str (if case-sens? + str + (string-foldcase str))]) + (let-values ([(snip s-pos) (find-snip/pos start (if (eq? direction 'forward) 'after 'before))]) + + (if (not snip) + (if just-one? #f null) + + ;; Knuth-Bendix + + (let-values ([(offset shorten sbase beyond sgoal direction) + (if (eq? direction 'forward) + (values (- start s-pos) 0 0 -1 slen 1) + (values 0 (- (+ s-pos (snip->count snip)) start) (- slen 1) slen -1 -1))] + [(smap) (make-vector slen 0)]) + + ;; initialize smap: + (vector-set! smap sbase beyond) + (let loop ([s beyond] + [i (+ sbase direction)]) + (unless (= i sgoal) + (let iloop ([s s]) + (if (and (not (= beyond s)) + (not (char=? (string-ref str (+ s direction)) (string-ref str i)))) + (iloop (vector-ref smap s)) + (let ([s (if (char=? (string-ref str (+ s direction)) + (string-ref str i)) + (+ s direction) + s)]) + (vector-set! smap i s) + (loop s (+ i direction))))))) + + (let a-loop ([s beyond] + [s-pos s-pos] + [snip snip] + [total-count total-count] + [offset offset] + [shorten shorten] + [results null]) + (if (and snip (positive? total-count)) + (let*-values ([(need) (- (snip->count snip) shorten offset)] + [(need offset) + (if (need . > . total-count) + (if (direction . < . 0) + (values total-count (+ offset (- need total-count))) + (values total-count offset)) + (values need offset))] + [(total-count) (- total-count need)]) + + (let b-loop ([checked 0] + [need need] + [results results]) + (let* ([thistime (min need 255)] + [need (- need thistime)] + [thisoffset (+ offset (if (direction . < . 0) need checked))] + [wl? write-locked?] + [fl? flow-locked?]) + (set! write-locked? #t) + (set! flow-locked? #t) + (let ([text (send snip get-text thisoffset thistime #f)]) + (set! write-locked? wl?) + (set! flow-locked? fl?) + + (let c-loop ([i (if (direction . > . 0) 0 (- thistime 1))] + [n thistime] + [s s] + [results results]) + (if (zero? n) + (if (positive? need) + + (b-loop (add1 checked) + need + results) + + (let* ([s-pos (if (direction . > . 0) + (+ s-pos (snip->count snip)) + s-pos)] + [snip (if (direction . > . 0) + (snip->next snip) + (snip->prev snip))] + [s-pos (if (and snip (direction . < . 0)) + (- s-pos (snip->count snip)) + s-pos)]) + (a-loop s + s-pos + snip + total-count + 0 + 0 + results))) + + (let* ([n (sub1 n)] + [c (string-ref text i)] + [c (if case-sens? (char-foldcase c) c)] + [s (let loop ([s s]) + (if (and (not (= beyond s)) + (not (char=? (string-ref str (+ s direction)) c))) + (loop (vector-ref smap s)) + s))]) + (if (char=? (string-ref str (+ s direction)) c) + (let ([s (+ s direction)]) + (if (= (+ s direction) sgoal) + (let* ([p (+ s-pos i thisoffset)] + [p (if bos? + (if (direction . < . 0) + (+ p slen) + (- p (- slen 1))) + (if (direction . > . 0) + (add1 p) + p))]) + (if just-one? + p ;; <------ single result returned here + (c-loop (+ i direction) + n + beyond + (cons p results)))) + (c-loop (+ i direction) + n + s + results))) + (c-loop (+ i direction) + n + s + results))))))))) + (if just-one? + #f + results))))))))))) + + ;; ---------------------------------------- + + (define/private (do-change-style start end new-style delta restore-sel? counts-as-mod?) + (unless (or write-locked? + s-user-locked? + (and new-style + (not (send s-style-list style-to-index new-style)))) + (let* ([start (max 0 (min len start))] + [end (min end len)]) + (unless (start . > . end) + (let ([new-style (if (and (not new-style) (not delta)) + (or (get-default-style) + (send s-style-list basic-style)) + new-style)]) + (cond + [(and (= start startpos) (= end endpos) (= end start) (positive? len)) + (when sticky-styles? + (set! caret-style + (cond + [new-style new-style] + [caret-style (send s-style-list find-or-create-style caret-style delta)] + [else (let ([gsnip (find-snip start 'before)]) + (send s-style-list find-or-create-style (snip->style gsnip) delta))])))] + [else + (set! write-locked? #t) + + (if (not (can-change-style? start (- end start))) + (set! write-locked? #f) + + (begin + (on-change-style start (- end start)) + + (set! flow-locked? #t) + + (make-snipset start end) + + (let-values ([(start-snip end-snip) + (if (zero? len) + (begin + (set! initial-style-needed? #f) + (values snips #f)) + (values (find-snip start 'after) (find-snip end 'after-or-none)))] + [(rec) + (and (zero? s-noundomode) + (make-object style-change-record% start end + (or delayed-streak? (not s-modified?)) + startpos endpos restore-sel?))]) + (let loop ([something? #f] + [extra-check-pos #f] + [prev-style #f] + [prev-style-pos start] + [p start] + [gsnip start-snip]) + (if (not (eq? gsnip end-snip)) + ;; Change a snip style: + (let* ([style (snip->style gsnip)] + [style2 (or new-style + (send s-style-list find-or-create-style style delta))]) + (if (not (eq? style style2)) + (begin + (set-snip-style! gsnip style2) + (let-values ([(prev-style prev-style-pos) + (if (and rec (not (eq? prev-style style))) + (begin + (when prev-style + (send rec add-style-change prev-style-pos p prev-style)) + (values style p)) + (values prev-style prev-style-pos))]) + (send gsnip size-cache-invalid) + (mline-mark-recalculate (snip->line gsnip)) + (when (max-width . > . 0) + (mline-mark-check-flow (snip->line gsnip))) + (loop #t + p + prev-style + prev-style-pos + (+ p (snip->count gsnip)) + (snip->next gsnip)))) + (let ([prev-style + (if (and rec prev-style) + (begin + (send rec add-style-change prev-style-pos p prev-style) + #f) + prev-style)]) + (loop something? + extra-check-pos + prev-style + prev-style-pos + (+ p (snip->count gsnip)) + (snip->next gsnip))))) + ;; All snips changed + (begin + (when (and rec prev-style) + (send rec add-style-change prev-style-pos p prev-style)) + + (if something? + ;; Something changed, so recalc and refresh: + (let ([line (snip->line start-snip)]) + (when (and (mline-prev line) + (not (has-flag? (snip->flags (mline-snip (mline-prev line))) HARD-NEWLINE))) + (mline-mark-check-flow (mline-prev line))) + (when (not s-modified?) + (add-undo-rec (make-object unmodify-record% delayed-streak?))) + (when rec + (add-undo-rec rec)) + (when (positive? delay-refresh) + (set! delayed-streak? #t)) + + (check-merge-snips start) + (when extra-check-pos + (check-merge-snips extra-check-pos)) + (when (not (= end extra-check-pos)) + (check-merge-snips end)) + + (when (and (not s-modified?) counts-as-mod?) + (set-modified #t)) + + (set! write-locked? #f) + (set! flow-locked? #f) + + (refresh-by-line-demand)) + ;; Nothing changed after all: + (begin + (set! write-locked? #f) + (set! flow-locked? #f) + + (check-merge-snips start) + (check-merge-snips end))) + + (after-change-style start (- end start))))))))])))))) + + (def/public (change-style [(make-or-false (make-alts style<%> style-delta%)) st] + [(make-alts exact-nonnegative-integer? (symbol-in start)) [start 'start]] + [(make-alts exact-nonnegative-integer? (symbol-in end)) [end 'end]] + [any? [counts-as-mod? #t]]) + (do-change-style (if (symbol? start) startpos start) + (if (symbol? end) (if (symbol? start) endpos len) end) + (and (st . is-a? . style<%>) st) + (and (st . is-a? . style-delta%) st) + 1 + counts-as-mod?)) + + (def/override (set-style-list [style-list% new-list]) + (unless write-locked? + (let ([delta (new style-delta%)] + [count (send s-style-list number)]) + (when (positive? count) + (let ([smap (make-vector count #f)]) + (vector-set! smap 0 (send new-list index-to-style 0)) + (for ([index (in-range 1 count)]) + (let* ([style (send s-style-list index-to-style index)] + [name (send style get-name)]) + (vector-set! + smap + index + (cond + [(and name (send new-list find-named-style name)) + => (lambda (new-style) new-style)] + [else + (let ([new-style + (let* ([base-style (send style get-base-style)] + [base-index (send s-style-list style-to-index base-style)]) + (if (send style is-join?) + (let* ([ss (send style get-shift-style)] + [shift-index (send s-style-list style-to-index ss)]) + (send new-list find-or-create-join-style + (vector-ref smap base-index) + (vector-ref smap shift-index))) + (begin + (send style get-delta delta) + (send new-list find-or-create-style + (vector-ref smap base-index) + delta))))]) + (if name + (send new-list new-named-style name new-style) + new-style))])))) + (let loop ([snip snips]) + (when snip + (let* ([index (send s-style-list style-to-index (snip->style snip))] + [index (if (not index) + ;; bad! snip had style not from this buffer's style list + 0 + index)]) + (set-snip-style! snip (vector-ref smap index))) + (loop (snip->next snip)))))) + + (super set-style-list new-list) + + (size-cache-invalid) + (set! changed? #t) + (need-refresh -1 -1)))) + + (def/override (style-has-changed [(make-or-false style<%>) style]) + (unless read-locked? + (if (not style) + ;; our cue to repaint + (begin + (set! changed? #t) + (need-refresh -1 -1)) + ;; notify snips: + (let ([wl? write-locked?] + [fl? flow-locked?]) + (set! write-locked? #t) + (set! flow-locked? #t) + + (let loop ([snip snips]) + (when snip + (when (eq? style (snip->style snip)) + (send snip size-cache-invalid) + (let ([line (snip->line snip)]) + (mline-mark-recalculate line) + (when (max-width . >= . 0) + (mline-mark-check-flow line) + (when (and (mline-prev line) + (not (has-flag? (snip->flags (mline-last-snip (mline-prev line))) + HARD-NEWLINE))) + (mline-mark-check-flow (mline-prev line)))))) + (loop (snip->next snip)))) + (set! write-locked? wl?) + (set! flow-locked? fl?))))) + + ;; ---------------------------------------- + + (define/private (do-scroll-to snip localx localy w h refresh? [bias 'none]) + (cond + [flow-locked? #f] + [(positive? delay-refresh) + (when s-admin + (set! delayedscroll -1) + (set! delayedscrollbox? #t) + (set! delayedscrollsnip snip) + (set! delayedscroll-x localx) + (set! delayedscroll-y localy) + (set! delayedscroll-w w) + (set! delayedscroll-h h) + (set! delayedscrollbias bias)) + #f] + [else + (let-boxes ([x 0.0] + [y 0.0] + [ok? #t]) + (when snip + (set-box! ok? (get-snip-position-and-location snip #f x y))) + (cond + [(not ok?) #f] + [(scroll-editor-to (+ x localx) (+ y localy) w h refresh? bias) + (unless refresh? + (set! refresh-all? #t)) + #t] + [else #f]))])) + + (def/public (scroll-to [snip% snip] [real? localx] [real? localy] + [nonnegative-real? w] [nonnegative-real? h] + [any? refresh?] + [(symbol-in start end none) [bias 'none]]) + (do-scroll-to snip localx localy w h refresh? bias)) + + (def/override (resized [snip% snip] [any? redraw-now?]) + (when (get-snip-position-and-location snip #f #f #f) + + (let ([line (snip->line snip)]) + (mline-mark-recalculate line) + (when (max-width . >= . 0) + (mline-mark-check-flow line) + ;; maybe something can now move to the previous line + (when (and (mline-prev line) + (not (has-flag? (snip->flags (mline-last-snip (mline-prev line))) + HARD-NEWLINE))) + (mline-mark-check-flow (mline-prev line))))) + + (set! graphic-maybe-invalid? #t) + + (let ([redraw-now? (and redraw-now? + (not flow-locked?))]) + + (set! changed? #t) + + (unless redraw-now? (set! delay-refresh (add1 delay-refresh))) + (refresh-by-line-demand) + (unless redraw-now? (set! delay-refresh (sub1 delay-refresh)))))) + + (def/override (recounted [snip% snip] [any? redraw-now?]) + (if write-locked? + #f + (begin + (set! revision-count (add1 revision-count)) + (resized snip redraw-now?) + #t))) + + (def/override (set-caret-owner [(make-or-false snip%) snip] + [(symbol-in immediate display global) [dist 'immediate]]) + (when (do-set-caret-owner snip dist) + (need-refresh startpos endpos) ;; (need-caret-refresh); <- doesn't work; local caret ownership weirdness + (on-focus (not snip)))) + + (def/override (release-snip [snip% snip]) + (let ([pos (get-snip-position snip)]) + (and pos + (begin + (do-delete pos (+ pos (snip->count snip)) #f #f) + (when (and (not (snip->admin snip)) + (has-flag? (snip->flags snip) OWNED)) + (set-snip-flags! snip (remove-flag (snip->flags snip) OWNED))) + #t)))) + + (define/public (refresh-box L T w h) + (let ([B (+ T h)] + [R (+ L w)]) + (if refresh-box-unset? + (begin + (set! refresh-l L) + (set! refresh-r R) + (set! refresh-t T) + (set! refresh-b B) + (set! refresh-box-unset? #f)) + (begin + (when (L . < . refresh-l) + (set! refresh-l L)) + (when (R . > . refresh-r) + (set! refresh-r R)) + (when (T . < . refresh-t) + (set! refresh-t T)) + (when (B . > . refresh-b) + (set! refresh-b B)))) + + (set! draw-cached-in-bitmap? #f))) + + (def/override (needs-update [snip% snip] + [real? localx] [real? localy] + [nonnegative-real? w] [nonnegative-real? h]) + (let-boxes ([x 0.0] + [y 0.0] + [ok? #t]) + (set-box! ok? (get-snip-location snip x y)) + (when ok? + (refresh-box (+ x localx) (+ y localy) w h) + (when (zero? delay-refresh) + (redraw))))) + + (def/override (invalidate-bitmap-cache [real? [x 0.0]] + [real? [y 0.0]] + [(make-alts nonnegative-real? (symbol-in end)) [w 'end]] + [(make-alts nonnegative-real? (symbol-in end)) [h 'end]]) + (let ([w (if (symbol? w) (- total-width x) w)] + [h (if (symbol? h) (- total-height y) h)]) + + (refresh-box x y w h) + (when (zero? delay-refresh) + (redraw)))) + + (def/public (hide-caret [any? hide?]) + (unless (eq? hilite-on? (not hide?)) + (set! hilite-on? (not hide?)) + (when (or s-own-caret? (not (= endpos startpos))) + (need-caret-refresh)))) + + (def/public (caret-hidden) (not hilite-on?)) + + (def/public (get-between-threshold) between-threshold) + + (def/public (set-between-threshold [nonnegative-real? t]) + (set! between-threshold (min t 99.0))) + + ;; ---------------------------------------- + + (define/private (make-only-snip) + (set! snips (new string-snip%)) + (set-snip-style! snips (or (get-default-style) + (send s-style-list basic-style))) + (set-snip-count! snips 0) + (send snips set-s-admin snip-admin) + + (let ([line (create-mline)]) + (set-snip-line! snips line) + (set-box! line-root-box line) + (set! first-line line) + (set! last-line line) + (mline-set-starts-paragraph line #t) + + (set-mline-snip! line snips) + (set-mline-last-snip! line snips) + + (set! last-snip snips) + (set! snip-count 1) + + (set! num-valid-lines 1))) + + (define/private (splice-snip snip prev next) + (if prev + (set-snip-next! prev snip) + (set! snips snip)) + (set-snip-prev! snip prev) + (set-snip-next! snip next) + (if next + (set-snip-prev! next snip) + (set! last-snip snip))) + + (define/private (insert-snip before snip) + (if (and (eq? snips last-snip) (zero? (snip->count snips))) + (append-snip snip) + (begin + (splice-snip snip (snip->prev before) before) + (set! snip-count (add1 snip-count))))) + + (define/private (append-snip snip) + (if (and (eq? snips last-snip) (zero? (snip->count snips))) + ;; get rid of empty snip + (begin + (set! snips snip) + (set! last-snip snip)) + (begin + (splice-snip snip last-snip #f) + (set! snip-count (add1 snip-count))))) + + (define/private (delete-snip snip) + (cond + [(snip->next snip) + (splice-snip (snip->next snip) (snip->prev snip) (snip->next (snip->next snip)))] + [(snip->prev snip) + (splice-snip (snip->prev snip) (snip->prev (snip->prev snip)) (snip->next snip))] + [else + (set! last-snip #f) + (set! snips #f)]) + (set! snip-count (sub1 snip-count)) + (set-snip-flags! snip (add-flag (snip->flags snip) CAN-DISOWN)) + (snip-set-admin snip #f) + (set-snip-line! snip #f) + (set-snip-prev! snip #f) + (set-snip-next! snip #f) + (set-snip-flags! snip (remove-flag (snip->flags snip) CAN-DISOWN))) + + (define/private (snip-set-admin snip a) + (let ([orig-count (snip->count snip)] + [line (snip->line snip)] + [orig-admin (snip->admin snip)] + [wl? write-locked?] + [fl? flow-locked?]) + + (set! read-locked? #t) + (set! write-locked? #t) + (set! flow-locked? #t) + + (send snip set-admin a) + + (set! read-locked? #f) + (set! write-locked? wl?) + (set! flow-locked? fl?) + + (let ([snip + (if (not (eq? (snip->admin snip) a)) + ;; something went wrong + (cond + [(and (not a) (eq? (snip->admin snip) orig-admin)) + ;; force admin to NULL + (send snip set-s-admin #f) + snip] + [a + ;; snip didn't accept membership into this editor; give up on it + (let ([naya (new snip%)]) + (set-snip-count! naya orig-count) + (splice-snip naya (snip->prev snip) (snip->next snip)) + (set-snip-line! naya line) + + (when line + (when (eq? (mline-snip line) snip) + (set-mline-snip! line naya)) + (when (eq? (mline-last-snip line) snip) + (set-mline-last-snip! line naya))) + + (send snip set-s-admin #f) + + (send naya set-admin a) + (set! snip naya) + naya)] + [else snip]) + snip)]) + + ;; force count to be consistent: + (when (and a (not (= (snip->count snip) orig-count))) + (set-snip-count! snip orig-count)) + + snip))) + + (define/private (snip-split snip pos a-ptr b-ptr) + (let ([c (snip->count snip)] + [nl? (has-flag? (snip->flags snip) NEWLINE)] + [hnl? (has-flag? (snip->flags snip) HARD-NEWLINE)] + [orig snip]) + + (set-snip-flags! snip (add-flag (snip->flags snip) CAN-SPLIT)) + + (delete-snip snip) + + (set-snip-flags! orig (remove-flag (snip->flags orig) OWNED)) + + (set! revision-count (add1 revision-count)) + + (let ([wl? write-locked?] + [fl? flow-locked?]) + + (set! read-locked? #t) + (set! write-locked? #t) + (set! flow-locked? #t) + + (set-box! a-ptr #f) + (set-box! b-ptr #f) + (send snip split pos a-ptr b-ptr) + + (set! read-locked? #f) + (set! write-locked? wl?) + (set! flow-locked? fl?)) + + (let* ([a (or (unbox a-ptr) + (new snip%))] + [a (if (send a is-owned?) + (new snip%) + a)] + [b (or (unbox b-ptr) + (new snip%))] + [b (if (send b is-owned?) + (new snip%) + b)]) + + (set-box! a-ptr a) + (set-box! b-ptr b) + + (set-snip-flags! a (remove-flag (snip->flags a) CAN-SPLIT)) + (set-snip-flags! b (remove-flag (snip->flags b) CAN-SPLIT)) + (set-snip-flags! orig (remove-flag (snip->flags orig) CAN-SPLIT)) + + ;; make sure that count is right + (set-snip-count! a pos) + (set-snip-count! b (- c pos)) + + ;; make sure that NEWLINE & HARD-NEWLINE is consistent: + (when nl? + (set-snip-flags! b (add-flag (snip->flags b) NEWLINE))) + (when hnl? + (set-snip-flags! b (add-flag (snip->flags b) HARD-NEWLINE))) + (set-snip-flags! a (remove-flag (remove-flag (snip->flags b) NEWLINE) + HARD-NEWLINE))))) + + (define/private (split-one pos s-pos snip extra) + (let ([line (snip->line snip)] + [prev (snip->prev snip)] + [next (snip->next snip)] + [style (snip->style snip)]) + (let ([at-start? (eq? (mline-snip line) snip)] + [at-end? (eq? (mline-last-snip line) snip)] + [orig snip]) + (let-boxes ([ins-snip #f] + [snip #f]) + (snip-split orig (- pos s-pos) ins-snip snip) + + (set-snip-style! snip style) + (set-snip-style! ins-snip style) + + (set-snip-line! snip line) + (set-snip-line! ins-snip line) + + (when at-start? + (set-mline-snip! line ins-snip)) + (when at-end? + (set-mline-last-snip! line snip)) + + (splice-snip snip prev next) + (set! snip-count (add1 snip-count)) + (insert-snip snip ins-snip) + (extra snip) + + (snip-set-admin snip snip-admin) + (snip-set-admin ins-snip snip-admin) + + (after-split-snip (- pos s-pos)))))) + + (define/private (make-snipset start end) + ;; BEWARE: `len' may not be up-to-date + (when (positive? start) + (let-values ([(snip s-pos) (find-snip/pos start 'after-or-none)]) + (when snip + (unless (= s-pos start) + (split-one start s-pos snip void))))) + (when (positive? end) + (let-values ([(snip s-pos) (find-snip/pos end 'before)]) + (unless (= (+ s-pos (snip->count snip)) end) + (split-one end s-pos snip void))))) + + (define/private (insert-text-snip start style) + (let* ([snip (on-new-string-snip)] + [snip (if (or (send snip is-owned?) + (positive? (snip->count snip))) + ;; uh-oh; resort to string-snip% + (new string-snip%) + snip)] + [style (or style + (get-default-style) + (send s-style-list basic-style))]) + (set-snip-style! snip style) + (let ([snip (let ([rsnip (snip-set-admin snip snip-admin)]) + (if (not (eq? snip rsnip)) + ;; uh-oh; resort to string-snip%: + (let ([snip (new string-snip%)]) + (set-snip-style! snip style) + (send snip set-s-admin snip-admin)) + snip))]) + (set-snip-count! snip 0) + + (let-values ([(gsnip s-pos) (find-snip/pos start 'before-or-none)]) + (if (and gsnip + (= (+ (snip->count gsnip) s-pos) start) + (has-flag? (snip->flags gsnip) NEWLINE) + (not (has-flag? (snip->flags gsnip) HARD-NEWLINE))) + (begin + ;; we want the snip on the same line as the preceeding snip: + (if (snip->next gsnip) + (insert-snip (snip->next gsnip) snip) + (append-snip snip)) + (set-snip-flags! gsnip (remove-flag (snip->flags gsnip) NEWLINE)) + (set-snip-flags! snip (add-flag (snip->flags snip) NEWLINE)) + (set-snip-line! snip (snip->line gsnip)) + (set-mline-last-snip! (snip->line snip) snip) + snip) + (let-values ([(gsnip s-pos) (find-snip/pos start 'after-or-none)]) + (cond + [(not gsnip) + (append-snip snip) + (set-snip-line! snip last-line) + (when (eq? (mline-last-snip last-line) last-snip) + (set! last-snip snip)) + (set-mline-last-snip! last-line snip) + snip] + [(= s-pos start) + (insert-snip gsnip snip) + (set-snip-line! snip (snip->line gsnip)) + (when (eq? (mline-snip (snip->line snip)) gsnip) + (set-mline-snip! (snip->line snip) snip)) + snip] + [else + (split-one start s-pos gsnip + (lambda (gsnip) + (set-snip-line! snip (snip->line gsnip)) + (insert-snip gsnip snip))) + snip]))))))) + + (define/private (check-merge-snips start) + (when (let loop ([did-something? #f]) + (let-values ([(snip1 s-pos1) (find-snip/pos start 'before)] + [(snip2 s-pos2) (find-snip/pos start 'after)]) + (if (eq? snip1 snip2) + did-something? + (if (not (and (snip->snipclass snip1) + (eq? (snip->snipclass snip1) (snip->snipclass snip2)) + (eq? (snip->style snip1) (snip->style snip2)))) + did-something? + (if (not (and + (not (has-flag? (snip->flags snip1) NEWLINE)) + (has-flag? (snip->flags snip1) CAN-APPEND) + (has-flag? (snip->flags snip2) CAN-APPEND) + ((+ (snip->count snip1) (snip->count snip2)) . < . MAX-COUNT-FOR-SNIP) + (eq? (snip->line snip1) (snip->line snip2)))) + did-something? + (cond + [(zero? (snip->count snip1)) + (when (eq? (mline-snip (snip->line snip1)) snip1) + (set-mline-snip! (snip->line snip1) snip2)) + (delete-snip snip1) + (set-snip-flags! snip1 (remove-flag (snip->flags snip1) OWNED)) + (loop #t)] + [(zero? (snip->count snip2)) + (when (eq? (mline-last-snip (snip->line snip2)) snip2) + (set-mline-last-snip! (snip->line snip2) snip1) + (mline-mark-recalculate (snip->line snip1)) ; need last-w updated + (set! graphic-maybe-invalid? #t)) + (delete-snip snip2) + (set-snip-flags! snip2 (remove-flag (snip->flags snip2) OWNED)) + (loop #t)] + [else + (let ([c (+ (snip->count snip1) (snip->count snip2))] + [prev (snip->prev snip1)] + [next (snip->next snip2)] + [line (snip->line snip1)]) + (let ([at-start? (eq? (mline-snip line) snip1)] + [at-end? (eq? (mline-last-snip line) snip2)] + [wl? write-locked?] + [fl flow-locked?]) + (set! read-locked? #t) + (set! write-locked? #t) + (set! flow-locked? #t) + + (set-snip-flags! snip2 (add-flag (snip->flags snip2) CAN-SPLIT)) + (let ([naya (send snip2 merge-with snip1)]) + (set! read-locked? #t) + (set! write-locked? wl?) + (set! flow-locked? wl?) + + (if naya + (begin + ;; claim snip1 & snip2 unowned for naya test: + (set-snip-flags! snip1 (remove-flag (remove-flag (snip->flags snip1) CAN-SPLIT) + OWNED)) + (set-snip-flags! snip2 (remove-flag (remove-flag (snip->flags snip2) CAN-SPLIT) + OWNED)) + + (let ([naya (if (send naya is-owned?) + ;; uh-oh; make dummy + (new snip%) + naya)]) + (set-snip-flags! naya (remove-flag (snip->flags naya) CAN-SPLIT)) + (set-snip-flags! snip1 (add-flag (snip->flags snip1) OWNED)) + (set-snip-flags! snip2 (add-flag (snip->flags snip2) OWNED)) + + (delete-snip snip1) + (set-snip-flags! snip1 (remove-flag (snip->flags snip1) OWNED)) + (delete-snip snip2) + (set-snip-flags! snip2 (remove-flag (snip->flags snip2) OWNED)) + + (splice-snip naya prev next) + (set! snip-count (add1 snip-count)) + + ;; make sure that count is right: + (set-snip-count! naya c) + + (set! revision-count (add1 revision-count)) + + (let ([naya (snip-set-admin naya snip-admin)]) + + (set-snip-line! naya line) + (when at-start? + (set-mline-snip! line naya)) + (when at-end? + (set-mline-last-snip! line naya) + (mline-mark-recalculate line) ;; need last-w updated + (set! graphic-maybe-invalid? #t)) + #t))) + (begin + (set-snip-flags! snip2 (remove-flag (snip->flags snip2) CAN-SPLIT)) + #t)))))])))))) + (after-merge-snips start))) + + ;; ---------------------------------------- + + (def/public (on-new-string-snip) + (new string-snip%)) + + (def/public (on-new-tab-snip) + (new tab-snip%)) + + ;; ---------------------------------------- + + (def/override (find-first-snip) + (if (zero? len) + #f + snips)) + + (def/public (find-snip [exact-nonnegative-integer? p] + [(symbol-in before-or-none before after after-or-none) direction] + [maybe-box? [s-pos #f]]) + ;; BEWARE: `len' may not be up-to-date + (let-values ([(snip pos) (find-snip/pos p direction)]) + (when s-pos (set-box! s-pos pos)) + snip)) + + (define/private (find-snip/pos p direction) + ;; BEWARE: `len' may not be up-to-date + (cond + [(and (eq? direction 'before-or-none) (zero? p)) + (values #f 0)] + [(and (eq? direction 'after-or-none) (p . >= . (let ([l (mline-last (unbox line-root-box))]) + (+ (mline-get-position l) + (mline-len l))))) + (values #f 0)] + [else + (let* ([line (mline-find-position (unbox line-root-box) p)] + [pos (mline-get-position line)] + [p (- p pos)]) + + (let-values ([(snip pos p) + (let ([snip (mline-snip line)]) + (if (and (zero? p) (snip->prev snip)) + ;; back up one: + (let ([snip (snip->prev snip)]) + (values snip + (- pos (snip->count snip)) + (+ p (snip->count snip)))) + (values snip pos p)))]) + + (let loop ([snip snip] + [pos pos] + [p p]) + (if snip + (let ([p (- p (snip->count snip))]) + (cond + [(or (and (eq? direction 'on) + (zero? p)) + (and (or (eq? direction 'before) + (eq? direction 'before-or-none)) + (p . <= . 0)) + (and (or (eq? direction 'after) + (eq? direction 'after-or-none)) + (p . < . 0))) + (values snip pos)] + [(and (eq? direction 'on) + (p . < . 0)) + (values #f 0)] + [else + (loop (snip->next snip) (+ pos (snip->count snip)) p)])) + (if (not (eq? direction 'after-or-none)) + (values last-snip (- pos (snip->count last-snip))) + (values #f 0))))))])) + + (def/public (find-next-non-string-snip [(make-or-false snip%) snip]) + (if (or (and snip + (not (eq? (snip->admin snip) snip-admin))) + (zero? len)) + #f + (let loop ([snip (if snip + (snip->next snip) + snips)]) + (if (and snip (snip . is-a? . string-snip%)) + (loop (snip->next snip)) + snip)))) + + ;; ---------------------------------------- + + (define/override (setting-admin admin) (void)) + + (define/override (init-new-admin) + (when (and (zero? delay-refresh) + (or (not s-admin) (not (send s-admin delay-refresh?)))) + (redraw))) + + (define/private (end-streaks exceptions) + (when (and s-keymap + (not (memq 'key-sequence exceptions)) + (not streaks-pushed?)) + (send s-keymap break-sequence)) + (when (and flash? flashautoreset? (not flashdirectoff?)) + (flash-off)) + + (set! typing-streak? #f) + (set! deletion-streak? #f) + (when (not (memq 'cursor exceptions)) + (set! vcursor-streak? #f) + (set! extend-streak? #f)) + + (when (and anchor-streak? (not keep-anchor-streak?)) + (set-anchor #f)) + + (when (not (memq 'delayed exceptions)) + (set! delayed-streak? #f)) + + (set! kill-streak? #f) + + (set! prev-paste-start -1)) + + (define/private (push-streaks) + (set! streaks-pushed? #t) + (set! save-typing-streak? typing-streak?) + (set! save-deletion-streak? deletion-streak?) + (set! save-delayed-streak? delayed-streak?) + (set! save-vcursor-streak? vcursor-streak?) + (set! save-kill-streak? kill-streak?) + (set! save-anchor-streak? anchor-streak?) + (set! save-extend-streak? extend-streak?) + (set! save-prev-paste-start prev-paste-start) + (set! save-prev-paste-end prev-paste-end)) + + (define/private (pop-streaks) + (when streaks-pushed? + (set! streaks-pushed? #f) + (set! typing-streak? save-typing-streak?) + (set! deletion-streak? save-deletion-streak?) + (set! delayed-streak? save-delayed-streak?) + (set! vcursor-streak? save-vcursor-streak?) + (set! kill-streak? save-kill-streak?) + (set! anchor-streak? save-anchor-streak?) + (set! extend-streak? save-extend-streak?) + (set! prev-paste-start save-prev-paste-start) + (set! prev-paste-end save-prev-paste-end))) + + ;; ---------------------------------------- + + (define/private (check-recalc [need-graphic? #t] [need-write? #t] [no-display-ok? #f]) + (and (not read-locked?) + (not (and write-locked? need-write?)) + (if (not need-graphic?) + #t + (if (not s-admin) + no-display-ok? + (if (not graphic-maybe-invalid?) + #t + (if flow-locked? + #f + (let ([dc (send s-admin get-dc)]) + (if (not dc) + no-display-ok? + (recalc-lines dc need-graphic?))))))))) + + (define/public (check-flow maxw dc Y startp start) + ;; this method is called with write-locked and flow-locked already #t + (let ([p startp] + [checking-underflow? #f] ;; start by ensuring no overflow + [checking-underflow-at-next? #f] + [no-change-if-end-of-snip? #t] ;; because an immediate overflow can't be helped + [no-change-if-start-of-snip? #f] + [the-first-snip? #t] + [first-underflow? #f] + [deleted-a-newline? #f] + [had-newline? #f]) + + (define (done snip) + (cond + [(and (not snip) + (has-flag? (snip->flags last-snip) NEWLINE) + (not (has-flag? (snip->flags last-snip) HARD-NEWLINE))) + (begin + (set-snip-flags! last-snip (remove-flag (snip->flags last-snip) NEWLINE)) + (set! refresh-all? #t) + #t)] + [(or (not checking-underflow?) no-change-if-end-of-snip?) + deleted-a-newline?] + [else + (set! refresh-all? #t) + #t])) + + (let loop ([snip start] + [p p] + [_total-width 0]) + (if (and snip (not (has-flag? (snip->flags snip) HARD-NEWLINE))) + (begin + (when (not checking-underflow?) + (set! checking-underflow? checking-underflow-at-next?) + (when checking-underflow? + (set! first-underflow? #t))) + (set! no-change-if-start-of-snip? no-change-if-end-of-snip?) + + (if (has-flag? (snip->flags snip) NEWLINE) + (begin + (set! no-change-if-end-of-snip? (not checking-underflow?)) + (set-snip-flags! snip (remove-flag (snip->flags snip) NEWLINE)) + (set! checking-underflow-at-next? #t) + (set! had-newline? #t) + (set! deleted-a-newline? #t) + ;; note: if the newline is restored, then + ;; we leave the loop + ) + (begin + (set! no-change-if-end-of-snip? #f) + (set! checking-underflow-at-next? #f) + (set! had-newline? #f))) + + (let-boxes ([w 0.0]) + (send snip get-extent dc _total-width Y w #f #f #f #f #f) + (let ([_total-width (+ _total-width w)]) + (if (_total-width . > . maxw) + (let ([_total-width (- _total-width w)]) + ;; get best breaking position: + ;; (0.1 is hopefully a positive value smaller than any character) + (let ([origc (do-find-position-in-snip dc _total-width Y snip (- maxw _total-width 0.1) #f)]) + ;; get legal breaking position before optimal: + (let-boxes ([b (+ p origc 1)]) + (find-wordbreak b #f 'line) + (let ([c (min (- b p) origc)]) + (let ([p + (if (c . <= . 0) + (cond + [(and (b . <= . startp) checking-underflow? (positive? origc)) + ;; the word was currently force-broken; shift some part to here + (+ p origc)] + [(or (and checking-underflow? + first-underflow? + (or (b . <= . startp) (c . >= . 0))) + (and (not the-first-snip?) + (or (zero? c) + (and (zero? origc) + (c . < . 0) + (b . <= . startp))))) + ;; can't fit this snip in the line + (when (snip->prev snip) + (set-snip-flags! (snip->prev snip) (add-flag (snip->flags (snip->prev snip)) NEWLINE))) + (when (and had-newline? (snip->next snip)) + (set-snip-flags! snip (add-flag (snip->flags snip) NEWLINE))) + (if (and no-change-if-start-of-snip? + (or (not had-newline?) + (snip->next snip))) + #f + (begin + (set! refresh-all? #t) + #t))] + [(and (c . < . 0) (b . > . startp)) + ;; overflow, but previous wordbreak was before this snip + b] + [else + ;; overflow: we have to break the word anyway + (if (zero? origc) + (if (and (= (snip->count snip) 1) + (snip->next snip) + (has-flag? (snip->flags (snip->next snip)) NEWLINE)) + ;; don't insert a break before a real newline + (done snip) + (+ p 1)) + (+ p origc))]) + (+ p c))]) + (if (not (number? p)) + p ;; the result + (begin + (make-snipset p p) + (let ([snip (find-snip p 'before)]) + (when (snip->next snip) + (set-snip-flags! snip (add-flag (snip->flags snip) NEWLINE))) + (set! refresh-all? #t) + #t)))))))) + (begin + (set! the-first-snip? #f) + (set! first-underflow? #f) + (loop (snip->next snip) + (+ p (snip->count snip)) + _total-width)))))) + (done snip))))) + + (define/private (recalc-lines dc [calc-graphics? #t]) + (when calc-graphics? + (when snip-cache-invalid? + (let loop ([snip snips]) + (when snip + (send snip size-cache-invalid) + (loop (snip->next snip))))) + + (let ([old-max-width max-width]) + (when (and flow-invalid? + (max-width . <= . 0)) + (set! max-width A-VERY-BIG-NUMBER)) + + (when (or graphics-invalid? + flow-invalid? + snip-cache-invalid?) + ;; set all lines invalid + (let loop ([line first-line]) + (when line + (mline-mark-recalculate line) + (when flow-invalid? + (mline-mark-check-flow line)) + (loop (mline-next line))))) + + (let ([-changed? + (if (max-width . > . 0) + (let ([wl? write-locked?] + [fl? flow-locked?]) + ;; if any flow is updated, snip sizing methods will be called + (set! write-locked? #t) + (set! flow-locked? #t) + + (let ([w (- max-width CURSOR-WIDTH)]) + (let loop ([-changed? #f]) + (if (mline-update-flow (unbox line-root-box) line-root-box this w dc) + (loop #t) + + (begin + (set! flow-locked? fl?) + (set! write-locked? wl?) + -changed?))))) + #f)]) + + (when (not (= max-width old-max-width)) + (set! max-width old-max-width)) + + (when -changed? + (set! refresh-all? #t) + (set! first-line (mline-first (unbox line-root-box))) + (set! last-line (mline-last (unbox line-root-box))) + (set! num-valid-lines (mline-number (unbox line-root-box)))) + + (let ([-changed? + (or (mline-update-graphics (unbox line-root-box) this dc) + -changed?)]) + + (if (and (not -changed?) + (not graphic-maybe-invalid-force?)) + (begin + (set! graphic-maybe-invalid? #f) + (void)) + (begin + (set! graphic-maybe-invalid? #f) + (set! graphic-maybe-invalid-force? #f) + + (let* ([Y (+ (mline-get-location last-line) (mline-h last-line))] + [Y (if (has-flag? (snip->flags last-snip) NEWLINE) + (begin + (set! extra-line? #t) + (set! extra-line-h (+ (mline-last-h last-line) line-spacing)) + (+ Y extra-line-h)) + (begin + (set! extra-line? #f) + (set! extra-line-h 0) + Y))] + [X (+ (mline-max-width (unbox line-root-box)) CURSOR-WIDTH)] + [X (if (min-width . > . 0.0) + (max X min-width) + X)] + [Y (if (min-height . > . 0.0) + (max Y min-height) + Y)] + [Y (if (max-height . > . 0.0) + (min Y max-height) + Y)]) + (let ([descent (- (mline-h last-line) (mline-bottombase last-line))] + [space (mline-topbase first-line)] + [line-base (mline-bottombase first-line)]) + (let ([resized? + (if (or (not (= total-height Y)) + (not (= total-width X)) + (not (= final-descent descent)) + (not (= initial-space space)) + (not (= line-base initial-line-base))) + (begin + (set! total-height Y) + (set! total-width X) + (set! final-descent descent) + (set! initial-space space) + (set! initial-line-base line-base) + #t) + #f)]) + + (set! graphics-invalid? #f) + (set! flow-invalid? #f) + (set! snip-cache-invalid? #f) + + (set! draw-cached-in-bitmap? #f) + + (when (and resized? s-admin) + (send s-admin resized #f)) + + (on-reflow))))))))))) + + (def/public (on-reflow) (void)) + + (def/public (set-autowrap-bitmap [(make-or-false bitmap%) bm]) + (if flow-locked? + #f + (let ([old auto-wrap-bitmap] + [old-width wrap-bitmap-width]) + + (set! auto-wrap-bitmap bm) + (if auto-wrap-bitmap + (set! wrap-bitmap-width (send auto-wrap-bitmap get-width)) + (set! wrap-bitmap-width 0)) + + (when (max-width . > . 0) + (set-max-width (+ max-width old-width))) + + old))) + + ;; ---------------------------------------- + + ;; notifies the administrator that we need to be redrawn + (define/private (redraw) + + (unless (or flow-locked? (not s-admin)) + (let-values ([(continue? notify?) + (if (send s-admin delay-refresh?) + ;; does the admin know the refresh box already? + (if (and (not (= delayedscroll -1)) + (not delayedscrollbox?) + (or refresh-all? refresh-unset?)) + ;; yes... + (if (and (not refresh-all?) refresh-box-unset?) + ;; nothing to do + (values #f #f) + (values #t #t)) + (values #t #t)) + (values #t #f))]) + (when continue? + + (when notify? + (let-boxes ([x 0.0] [y 0.0] [w 0.0] [h 0.0]) + (send s-admin get-max-view x y w h) + (let ([top y] + [bottom (+ y h)] + [left x] + [right (+ x w)]) + (let-values ([(left right top bottom) + (if refresh-all? + (values left right top bottom) + (values + (max refresh-l left) + (min refresh-r right) + (max refresh-t top) + (min refresh-b bottom)))]) + (set! refresh-unset? #t) + (set! refresh-box-unset? #t) + (set! refresh-all? #f) + (let ([height (- bottom top)] + [width (- right left)]) + (when (and (width . > . 0) (height . > . 0)) + (send s-admin needs-update left top width height))))))) + + (let-boxes ([dc #f] + [x 0.0] + [y 0.0]) + (set-box! dc (send s-admin get-dc x y)) + (if (not dc) + (begin + (set! delayedscroll -1) + (set! delayedscrollbox? #f)) + + (let ([origx x] + [origy y]) + + (recalc-lines dc) + + (cond + [(not (= delayedscroll -1)) + (scroll-to-position/refresh delayedscroll delayedscrollateol? #f + delayedscrollend delayedscrollbias) + (set! refresh-all? #t)] + [delayedscrollbox? + (set! delayedscrollbox? #f) + (when (do-scroll-to delayedscrollsnip delayedscroll-x delayedscroll-y + delayedscroll-w delayedscroll-h #f delayedscrollbias) + (set! refresh-all? #t))]) + (let-boxes ([x 0.0] + [y 0.0]) + (send s-admin get-dc x y) + (when (or (not (= origx x)) (not (= origy y))) + (set! refresh-all? #t))) + + (let-boxes ([x 0.0] [y 0.0] [w 0.0] [h 0.0]) + (send s-admin get-max-view x y w h) + (let ([top y] + [bottom (+ y h)] + [left x] + [right (+ x w)]) + + ;; figure out the minimal refresh area; the refresh area may be + ;; determined by character position ranges, box coordinates, or + ;; both; if neither is specified, we have to assume that everything + ;; needs to be refreshed + (let-values ([(left top right bottom needs-update?) + (if (and (not refresh-all?) + (or (not refresh-unset?) (not refresh-box-unset?))) + (if (not refresh-unset?) + (let ([top (if (refresh-start . > . -1) + (let-boxes ([fy 0.0]) + (position-location refresh-start #f fy #t #t #t) + (max top fy)) + top)] + [bottom (if (refresh-end . > . -1) + (let-boxes ([fy 0.0]) + (position-location refresh-end #f fy #f #f #t) + (min bottom fy)) + bottom)]) + (values left (if (not refresh-box-unset?) + (min refresh-t top) + top) + right (if (not refresh-box-unset?) + (max bottom refresh-b) + bottom) + #t)) + (values (max refresh-l left) + (max top refresh-t) + (min right refresh-r) + (min bottom refresh-b) + #t)) + (values left top right bottom refresh-all?))]) + + (set! refresh-unset? #t) + (set! refresh-box-unset? #t) + (set! refresh-all? #f) + + (let ([height (- bottom top)] + [width (- right left)]) + + (when changed? + (set! changed? #f) + (let ([wl? write-locked?] + [fl? flow-locked?]) + + (set! write-locked? #t) + (set! flow-locked? #t) + (on-change) + (set! write-locked? wl?) + (set! flow-locked? fl?))) + + (when (and needs-update? + (width . > . 0) + (height . > . 0)) + (send s-admin needs-update left top width height))))))))))))) + + (define/private (too-busy-to-refresh?) + (or graphic-maybe-invalid? + flow-locked? + (positive? delay-refresh))) + + ;; called by the administrator to trigger a redraw + (def/override (refresh [real? left] [real? top] [nonnegative-real? width] [nonnegative-real? height] + [(symbol-in no-caret show-inactive-caret show-caret) show-caret] + [(make-or-false color%) bg-color]) + (cond + [(or (width . <= . 0) (height . <= . 0)) (void)] + [(too-busy-to-refresh?) + ;; this refresh command was not requested by us and we're busy + ;; (probably in the middle of a begin-/end-edit-sequnce); + ;; add the given region to our own invalid-region tracking, and + ;; we'll get back to it when we're done with whatever + (refresh-box left top width height)] + [(not s-admin) + (void)] + [else + (let-boxes ([x 0.0] + [y 0.0] + [dc #f]) + (set-box! dc (send s-admin get-dc x y)) + (when dc + (begin-sequence-lock) + + (let ([show-caret + (if (and caret-blinked? + (not (eq? show-caret 'no-caret)) + (not s-caret-snip)) + ;; maintain caret-blinked invariant + 'no-caret + show-caret)]) + + (when (send s-offscreen ready-offscreen width height) + (set! draw-cached-in-bitmap? #f)) + + ;; make sure all location information is integral, + ;; so we can shift the coordinate system and generally + ;; update on pixel boundaries + (let ([x (->long (floor x))] + [y (->long (floor y))] + [bottom (->long (ceiling (+ top height)))] + [right (->long (ceiling (+ left width)))] + [top (->long (floor top))] + [left (->long (floor left))]) + (let ([width (- right left)] + [height (- bottom top)] + [ps? (or (dc . is-a? . post-script-dc%) + (dc . is-a? . printer-dc%))] + [show-xsel? + (and ALLOW-X-STYLE-SELECTION? + (or (not (eq? 'show-caret show-caret)) s-caret-snip) + (eq? this editor-x-selection-owner) + (not flash?) + (not (= endpos startpos)))]) + + (if (and bg-color + (not (send s-offscreen is-in-use?)) + (send s-offscreen get-bitmap) + (send (send s-offscreen get-bitmap) ok?) + (send (send s-offscreen get-dc) ok?) + (not ps?)) + ;; draw to offscreen + (let ([red (send bg-color red)] + [green (send bg-color green)] + [blue (send bg-color blue)]) + (send s-offscreen set-in-use #t) + + (when (or + (not draw-cached-in-bitmap?) + (not (eq? offscreen-key (send s-offscreen get-last-used))) + (not (= last-draw-t top)) + (not (= last-draw-b bottom)) + (not (= last-draw-l left)) + (not (= last-draw-r right)) + (not (eq? show-caret last-draw-caret)) + (not (eq? show-xsel? last-draw-x-sel?)) + (not (= last-draw-red red)) + (not (= last-draw-green green)) + (not (= last-draw-blue blue))) + + (do-redraw (send s-offscreen get-dc) top bottom left right + (- top) (- left) show-caret show-xsel? bg-color) + + (set! last-draw-l left) + (set! last-draw-t top) + (set! last-draw-r right) + (set! last-draw-b bottom) + (set! last-draw-caret show-caret) + (set! last-draw-x-sel? show-xsel?) + (set! last-draw-red red) + (set! last-draw-green green) + (set! last-draw-blue blue) + (set! draw-cached-in-bitmap? #t)) + + (send dc draw-bitmap-section + (send (send s-offscreen get-dc) get-bitmap) + (- left x) (- top y) + 0 0 width height 'solid) + + (send s-offscreen set-last-used offscreen-key) + (send s-offscreen set-in-use #f)) + + ;; draw to given DC: + (let ([pen (send dc get-pen)] + [brush (send dc get-brush)] + [font (send dc get-font)] + [fg (make-object color% (send dc get-text-foreground))] + [bg (make-object color% (send dc get-text-background))] + [bgmode (send dc get-text-mode)] + [rgn (send dc get-clipping-region)]) + + (send dc set-clipping-rect (- left x) (- top y) width height) + + (do-redraw dc top bottom left right (- y) (- x) show-caret show-xsel? bg-color) + + (send dc set-clipping-region rgn) + + (send dc set-brush brush) + (send dc set-pen pen) + (send dc set-font font) + (send dc set-text-foreground fg) + (send dc set-text-background bg) + (send dc set-text-mode bgmode)))))) + + (end-sequence-lock)))])) + + ;; performs the actual drawing operations + (define/private (do-redraw dc starty endy leftx rightx dy dx show-caret show-xsel? bg-color) + (let ([wl? write-locked?]) + + (set! flow-locked? #t) + (set! write-locked? #t) + + (let-values ([(-startpos -endpos pos-at-eol?) + (if flash? + (values flashstartpos flashendpos flashposateol?) + (values startpos endpos posateol?))]) + + (send dc set-text-mode 'solid) + + (let ([line (mline-find-location (unbox line-root-box) starty)]) + + (when bg-color + (let ([lsave-pen (send dc get-pen)] + [lsave-brush (send dc get-brush)]) + (let ([wb (if (and (= 255 (send bg-color red)) + (= 255 (send bg-color green)) + (= 255 (send bg-color blue))) + clear-brush + (send the-brush-list find-or-create-brush bg-color 'solid))]) + (send dc set-brush wb) + (send dc set-pen outline-pen) + + (send dc draw-rectangle + (+ leftx dx) (+ starty dy) + (- rightx leftx) (- endy starty)) + + (send dc set-brush lsave-brush) + (send dc set-pen lsave-pen)))) + + (let* ([call-on-paint + (lambda (pre?) + (on-paint pre? dc leftx starty rightx endy dx dy + (if (not s-caret-snip) + show-caret + 'no-caret)))] + [paint-done + (lambda () + (call-on-paint #f) + (set! write-locked? wl?) + (set! flow-locked? #f))]) + + (call-on-paint #t) + + (when line + (let ([tleftx (+ leftx dx)] + [tstarty (+ starty dy)] + [trightx (+ rightx dx)] + [tendy (+ endy dy)]) + (let lloop ([line line] + [old-style #f] + [ycounter (mline-get-location line)] + [pcounter (mline-get-position line)] + [prevwasfirst 0.0]) + (cond + [(not line) + (send (send s-style-list basic-style) switch-to dc old-style) + (when (and (eq? 'show-caret show-caret) (not s-caret-snip) + extra-line? + (not pos-at-eol?) + (= len -startpos) + (= -endpos -startpos) + hilite-on?) + (let ([y ycounter] + [save-pen (send dc get-pen)]) + (send dc set-pen caret-pen) + (send dc draw-line dx (+ y dy) dx (sub1 (+ y extra-line-h dy))) + (send dc set-pen save-pen))) + (paint-done)] + [(ycounter . >= . endy) + (paint-done)] + [line + (let ([first (mline-snip line)] + [last (snip->next (mline-last-snip line))] + [bottombase (+ ycounter (mline-bottombase line))] + [topbase (+ ycounter (mline-topbase line))]) + (let-values ([(hilite-some? hsxs hsxe hsys hsye old-style) + (let sloop ([snip first] + [p pcounter] + [x (mline-get-left-location line max-width)] + [hilite-some? #f] + [hsxs 0.0] + [hsxe 0.0] + [hsys 0.0] + [hsye 0.0] + [old-style old-style]) + (if (eq? snip last) + (values hilite-some? hsxs hsxe hsys hsye old-style) + (begin + (send (snip->style snip) switch-to dc old-style) + (let ([old-style (snip->style snip)]) + (let-boxes ([w 0.0] [h 0.0] [descent 0.0] [space 0.0]) + (send snip get-extent dc x ycounter w h descent space #f #f) + (let* ([align (send (snip->style snip) get-alignment)] + [down + (cond + [(eq? 'bottom align) + (+ (- bottombase h) descent)] + [(eq? 'top align) + (- topbase space)] + [else + (- (/ (+ topbase bottombase) 2) + (/ (- h descent space) 2) + space)])]) + + (when (and (x . <= . rightx) + ((+ x w) . >= . leftx)) + (send snip draw dc (+ x dx) (+ down dy) + tleftx tstarty trightx tendy + dx dy + (if (eq? snip s-caret-snip) + show-caret + 'no-caret))) + + ;; the rules for hiliting are surprisingly complicated: + (let ([hilite? + (and + hilite-on? + (or show-xsel? + (and (not s-caret-snip) + (or (eq? 'show-caret show-caret) + (and (show-caret . showcaret>= . s-inactive-caret-threshold) + (not (= -endpos -startpos)))))) + (if pos-at-eol? + (= -startpos (+ p (snip->count snip))) + (or (and (-startpos . < . (+ p (snip->count snip))) + (-endpos . >= . p) + (or (= -endpos -startpos) (-endpos . > . p))) + (and (= (+ p (snip->count snip)) len) + (= len -startpos)))) + (or (not (has-flag? (snip->flags snip) NEWLINE)) + ;; end of line: + (or (not (= -startpos (+ p (snip->count snip)))) + (and (= -endpos -startpos) pos-at-eol?) + (and (not (= -endpos -startpos)) + (-startpos . < . (+ p (snip->count snip)))))) + (or (not (eq? snip first)) + ;; beginning of line: + (or (not (= p -endpos)) + (and (= -endpos -startpos) (not pos-at-eol?)) + (and (not (= -endpos -startpos)) + (-endpos . > . p)))))]) + + (if hilite? + (let*-values ([(bottom) (+ down h)] + [(hxs) (if (-startpos . <= . p) + (if (-startpos . < . p) + 0 + x) + (+ x (send snip partial-offset dc x ycounter + (- -startpos p))))] + [(hxe bottom) (if (-endpos . >= . (+ p (snip->count snip))) + (if (has-flag? (snip->flags snip) NEWLINE) + (if (= -startpos -endpos) + (values hxs bottom) + (values rightx + (+ ycounter (mline-h line)))) + (values (+ x w) bottom)) + (values (+ x (send snip partial-offset dc x ycounter + (- -endpos p))) + bottom))]) + + (let-values ([(hsxs hsxe hsys hsye) + (if (not hilite-some?) + (values hxs hxe down bottom) + (values hsxs hxe (min down hsys) (max hsye bottom)))]) + (sloop (snip->next snip) + (+ p (snip->count snip)) + (+ x w) + #t hsxs hsxe hsys hsye + old-style))) + (sloop (snip->next snip) + (+ p (snip->count snip)) + (+ x w) + hilite-some? hsxs hsxe hsys hsye + old-style)))))))))]) + (when (and (positive? wrap-bitmap-width) + (not (has-flag? (snip->flags (mline-last-snip line)) HARD-NEWLINE)) + last + (rightx . >= . max-width) + (send auto-wrap-bitmap ok?)) + (let ([h (min (->long (send auto-wrap-bitmap get-height)) + (mline-bottombase line))] + [osfg (send old-style get-foreground)]) + (send dc draw-bitmap-section + auto-wrap-bitmap + (sub1 (+ max-width dx)) (+ (- bottombase h) dy) + 0 0 wrap-bitmap-width h + 'solid osfg))) + + (let ([prevwasfirst + (if hilite-some? + (if (not (= hsxs hsxe)) + (if (and (hsxs . <= . rightx) (hsxe . >= . leftx)) + (let ([save-pen (send dc get-pen)] + [hxsx (max hsxs leftx)] + [hsxe (min hsxe rightx)]) + (begin0 + (if (and (not show-xsel?) + (not (showcaret>= show-caret 'show-caret))) + (if show-outline-for-inactive? + (let ([first-hilite? (-startpos . >= . pcounter)] + [last-hilite? (-endpos . <= . (+ pcounter (mline-len line)))]) + (send dc set-pen outline-inactive-pen) + (let ([prevwasfirst + (cond + [first-hilite? + (send dc draw-line (+ hsxs dx) (+ hsys dy) (+ hsxe (sub1 dx)) (+ hsys dy)) + hsxs] + [(positive? prevwasfirst) + (send dc draw-line dx (+ hsys dy) (+ prevwasfirst dx) (+ hsys dy)) + 0.0] + [else 0.0])]) + (send dc draw-line (+ hsxs dx) (+ hsys dy) (+ hsxs dx) (+ hsye (sub1 dy))) + (send dc draw-line (+ hsxe (sub1 dx)) (+ hsys dy) + (+ hsxe (sub1 dx)) (+ hsye (sub1 dy))) + (when last-hilite? + (send dc draw-line (+ hsxs dx) (+ hsye dy) (+ hsxe (sub1 dx)) (+ hsye dy))) + (when (not first-hilite?) + (send dc draw-line (+ hsxe dx) (+ hsys dy) (+ rightx dx) (+ hsys dy))) + prevwasfirst)) + prevwasfirst) + (let ([save-brush (send dc get-brush)]) + (send dc set-pen outline-pen) + (send dc set-brush outline-brush) + + (send dc draw-rectangle (+ hsxs dx) (+ hsys dy) + (max 0.0 (- hsxe hsxs)) (max 0.0 (- hsye hsys))) + (when ALLOW-X-STYLE-SELECTION? + (when show-xsel? + (send dc set-brush outline-nonowner-brush) + (send dc draw-rectangle (+ hsxs dx) (+ hsys dy) + (max 0.0 (- hsxe hsxs)) (max 0.0 (- hsye hsys))))) + (send dc set-brush save-brush) + prevwasfirst)) + (send dc set-pen save-pen))) + prevwasfirst) + (begin + (when (eq? 'show-caret show-caret) + (when (and (hsxs . <= . rightx) (hsxs . >= . leftx)) + (let ([save-pen (send dc get-pen)]) + (send dc set-pen caret-pen) + (send dc draw-line (+ hsxs dx) (+ hsys dy) + (+ hsxs dx) + (+ hsye (sub1 dy))) + (send dc set-pen save-pen)))) + prevwasfirst)) + prevwasfirst)]) + (lloop (mline-next line) + old-style + (+ ycounter (mline-h line)) + (+ pcounter (mline-len line)) + prevwasfirst))))]))))))))) + + ;; ---------------------------------------- + + ;; used internally to delay refreshes: + (define/private (need-refresh start [end -1]) + (if refresh-unset? + (begin + (set! refresh-start start) + (set! refresh-end end) + (set! refresh-unset? #f)) + (begin + (set! refresh-start (min start refresh-start)) + (cond + [(= end -1) + (set! refresh-end -1)] + [(= refresh-end -1) + (void)] + [else (set! refresh-end (max end refresh-end))]))) + + (set! draw-cached-in-bitmap? #f) + + (continue-refresh)) + + (define/private (refresh-by-line-demand) + (set! graphic-maybe-invalid? #t) + (continue-refresh)) + + (define/private (continue-refresh) + (if (and (zero? delay-refresh) + (not (super is-printing?)) + (or (not s-admin) (not (send s-admin delay-refresh?)))) + (redraw) + (begin + (when (and (zero? delay-refresh) + (or (= delayedscroll -1) + delayedscrollbox?)) + (if (and (not (super is-printing?)) s-admin) + ;; although the administrator says to delay, + ;; we can't just drop scroll requests + (redraw) + (begin + (set! delayedscroll -1) + (set! delayedscrollbox? #f)))) + (when (and s-admin (zero? (send s-admin get-s-standard))) + (send s-admin resized #f))))) + + (define/private (need-caret-refresh) + (need-refresh startpos endpos)) + + ;; ---------------------------------------- + + (define/override (own-x-selection on? update? force?) + (and (do-own-x-selection on? force?) + (begin + (when update? + (need-caret-refresh)) + #t))) + + ;; ---------------------------------------- + + (def/public (set-paragraph-margins [exact-nonnegative-integer? i] + [nonnegative-real? first-left] + [nonnegative-real? left] + [nonnegative-real? right]) + (let ([l (mline-find-paragraph (unbox line-root-box) i)]) + (when l + (let ([p (mline-clone-paragraph (mline-paragraph l))]) + (set-mline-paragraph! l p) + + (set-paragraph-left-margin-first! p first-left) + (set-paragraph-left-margin! p left) + (set-paragraph-right-margin! p right) + + (if (max-width . > . 0) + (begin + (mline-mark-check-flow l) + (let loop ([l (mline-next l)]) + (when (and l + (zero? (mline-starts-paragraph l))) + (mline-mark-check-flow l) + (loop (mline-next l))))) + (need-refresh (paragraph-start-position i) (paragraph-end-position i))) + + (refresh-by-line-demand))))) + + (def/public (set-paragraph-alignment [exact-nonnegative-integer? i] [(symbol-in left center right) align]) + (let ([l (mline-find-paragraph (unbox line-root-box) i)]) + (when l + (let ([p (mline-clone-paragraph (mline-paragraph l))]) + (set-mline-paragraph! l p) + + (set-paragraph-alignment! p align) + + (need-refresh (paragraph-start-position i) (paragraph-end-position i)) + + (refresh-by-line-demand))))) + + ;; ---------------------------------------- + + (def/override (is-printing?) (super is-printing?)) + + (define/override (do-begin-print dc fit?) + (if flow-locked? + #f + (begin + (check-recalc) + (size-cache-invalid) + + (let ([save-info (if fit? + (cons (get-max-width) + (set-autowrap-bitmap #f)) + #f)]) + (when fit? + (let-values ([(w h) (send dc get-size)]) + (let-boxes ([hm 0] + [vm 0]) + (send (current-ps-setup) get-editor-margin hm vm) + (set-max-width (- w (* 2 hm)))))) + + (recalc-lines dc #t) + + (let ([wl? write-locked?] + [fl? flow-locked?]) + (set! write-locked? #t) + (set! flow-locked? #t) + (on-change) + (set! write-locked? wl?) + (set! flow-locked? fl?)) + + save-info)))) + + (define/override (do-end-print dc data) + (unless flow-locked? + (size-cache-invalid) + + (when data + (set-max-width (car data)) + (set-autowrap-bitmap (cdr data))) + + (let ([wl? write-locked?] + [fl? flow-locked?]) + (set! write-locked? #t) + (set! flow-locked? #t) + (on-change) + (set! write-locked? wl?) + (set! flow-locked? fl?)))) + + (define/private (has/print-page dc page print?) + (if flow-locked? + #f + (begin + (recalc-lines dc #t) + (let-values ([(W H) (send dc get-size)]) + (let-boxes ([W W] + [H H] + [hm 0] + [vm 0]) + (begin + (when (or (zero? (unbox W)) (zero? (unbox H))) + (get-default-print-size W H)) + (send (current-ps-setup) get-editor-margin hm vm)) + (let ([H (- H (* 2 vm))] + [W (- W (* 2 hm))]) + + ;; H is the total page height; + ;; line is the line that we haven't finished printing; + ;; y is the starting location to print for this page; + ;; h is the height that we're hoping to fit into the page + ;; i is the line number + (let ploop ([this-page 1] + [line first-line] + [y 0.0] + [next-h 0.0] + [i 0]) + (and + line + (let ([h next-h] + [next-h 0.0]) + (let loop ([h h] + [i i] + [line line]) + (if (or (zero? h) + (and (i . < . num-valid-lines) + ((mline-h line) . < . (- H h)))) + (loop (+ h (mline-h line)) + (add1 i) + (mline-next line)) + (let-values ([(h i line) + (if (and (h . < . H) + (i . < . num-valid-lines) + ((mline-h line) . > . H)) + ;; we'll have to break it up anyway; start now? + (let* ([pos (find-scroll-line (+ y H))] + [py (scroll-line-location pos)]) + (if (py . > . (+ y h)) + ;; yes, at least one line will fit + (values (+ h (mline-h line)) + (add1 i) + (mline-next line)) + (values h i line))) + (values h i line))]) + (let-values ([(next-h h) + (if (h . > . H) + ;; only happens if we have something that's too big to fit on a page; + ;; look for internal scroll positions + (let* ([pos (find-scroll-line (+ y H))] + [py (scroll-line-location pos)]) + (if (py . > . y) + (let ([new-h (- py y)]) + (values (- h new-h) + new-h)) + (values next-h h))) + (values next-h h))]) + (or (if print? + (begin + (when (or (negative? page) (= this-page page)) + (begin + (when (negative? page) + (send dc start-page)) + (do-redraw dc + (+ y (if (zero? i) 0 1)) + (+ y (- h 1)) + 0 W (+ (- y) vm) hm + 'no-caret #f #f) + (when (negative? page) + (send dc end-page)))) + #f) + (= this-page page)) + (ploop (add1 this-page) + line + (+ y h) + next-h + i))))))))))))))) + + (define/override (do-has-print-page? dc page) + (has/print-page dc page #f)) + + (def/override (print-to-dc [dc<%> dc] [exact-integer? [page -1]]) + (has/print-page dc page #t) + (void))) + +(set-text%! text%) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define/top (add-text-keymap-functions [keymap% tab]) + (let ([add (lambda (n f) + (send tab add-function n + (lambda (e evt) + (if (e . is-a? . text%) + (begin (f e evt) #t) + #f))))]) + (add "forward-character" (lambda (t evt) (send t move-position 'right))) + (add "backward-character" (lambda (t evt) (send t move-position 'left))) + (add "previous-line" (lambda (t evt) (send t move-position 'up))) + (add "next-line" (lambda (t evt) (send t move-position 'down))) + (add "previous-page" (lambda (t evt) (send t move-position 'up #f 'page))) + (add "next-page" (lambda (t evt) (send t move-position 'down #f 'page))) + (add "forward-word" (lambda (t evt) (send t move-position 'right #f 'word))) + (add "backward-word" (lambda (t evt) (send t move-position 'left #f 'word))) + + (add "forward-select" (lambda (t evt) (send t move-position 'right #t))) + (add "backward-select" (lambda (t evt) (send t move-position 'left #t))) + (add "select-down" (lambda (t evt) (send t move-position 'down #t))) + (add "select-up" (lambda (t evt) (send t move-position 'up #t))) + (add "select-page-up" (lambda (t evt) (send t move-position 'up #t 'page))) + (add "select-page-down" (lambda (t evt) (send t move-position 'down #t 'page))) + (add "forward-select-word" (lambda (t evt) (send t move-position 'right #t 'word))) + (add "backward-select-word" (lambda (t evt) (send t move-position 'left #t 'word))) + + (add "beginning-of-file" (lambda (t evt) (send t move-position 'home))) + (add "end-of-file" (lambda (t evt) (send t move-position 'end))) + (add "beginning-of-line" (lambda (t evt) (send t move-position 'left #f 'line))) + (add "end-of-line" (lambda (t evt) (send t move-position 'right #f 'line))) + + (add "select-to-beginning-of-file" (lambda (t evt) (send t move-position 'home #t))) + (add "select-to-end-of-file" (lambda (t evt) (send t move-position 'end #t))) + (add "select-to-beginning-of-line" (lambda (t evt) (send t move-position 'left #t 'line))) + (add "select-to-end-of-line" (lambda (t evt) (send t move-position 'right #t 'line))) + + (add "delete-previous-character" (lambda (t evt) (send t delete))) + (add "delete-next-character" (lambda (t evt) + (let-boxes ([s 0] + [e 0]) + (send t get-position s e) + (if (not (= s e)) + (send t delete) + (send t delete s (+ s 1)))))) + + (add "clear-buffer" (lambda (t evt) (send t erase))) + (add "delete-next-word" (lambda (t evt) + (send t begin-edit-sequence) + (send t move-position 'right #t 'word) + (send t delete) + (send t end-edit-sequence))) + (add "delete-previous-word" (lambda (t evt) + (send t begin-edit-sequence) + (send t move-position 'left #t 'word) + (send t delete) + (send t end-edit-sequence))) + (add "delete-line" (lambda (t evt) + (send t begin-edit-sequence) + (send t move-position 'left #f 'line) + (send t move-position 'right #t 'line) + (send t delete) + (send t end-edit-sequence))) + + (add "paste-next" (lambda (t evt) (send t paste-next))) + + (add-editor-keymap-functions tab))) diff --git a/collects/mred/private/wxme/undo.ss b/collects/mred/private/wxme/undo.ss new file mode 100644 index 00000000..15f44fbd --- /dev/null +++ b/collects/mred/private/wxme/undo.ss @@ -0,0 +1,307 @@ +#lang scheme/base +(require scheme/class + "private.ss" + "snip.ss" + "snip-flags.ss") + +(provide proc-record% + unmodify-record% + insert-record% + insert-snip-record% + delete-record% + delete-snip-record% + style-change-record% + style-change-snip-record% + move-snip-record% + resize-snip-record% + composite-record%) + +(define (disown snip) + (when (has-flag? (snip->flags snip) OWNED) + (send snip set-s-flags (remove-flag (snip->flags snip) OWNED)))) + +(define change-record% + (class object% + (super-new) + (define/public (cancel) (void)) + (define/public (undo editor) #f) + (define/public (drop-set-unmodified) (void)) + (define/public (is-composite?) #f) + (define/public (get-id) #f) + (define/public (get-parity) 0) + (define/public (inverse) #f))) + +(define proc-record% + (class change-record% + (init-field proc) + (super-new) + + (define/override (undo editor) + (proc)))) + +(define unmodify-record% + (class change-record% + (init-field cont?) + (define ok? #t) + (super-new) + + (define/override (undo editor) + (when ok? + (send editor set-modified #f)) + cont?) + + (define/override (drop-set-unmodified) + (set! ok? #f)))) + +(define insert-record% + (class change-record% + (init-field start) + (init length) + (init-field cont? + startsel + endsel) + (define end (+ start length)) + (super-new) + + (define/override (undo editor) + (send editor delete start end) + (send editor set-position startsel endsel) + cont?))) + +(define insert-snip-record% + (class change-record% + (init-field snip + cont?) + (super-new) + + (define/override (undo editor) + (send editor delete snip) + (unless cont? + (send editor set-selected snip)) + cont?))) + +(define-struct delete-snip-item (snip before x y)) + +(define delete-snip-record% + (class change-record% + (init-field cont?) + (define deletions null) + (define undid? #f) + (super-new) + + (define/public (insert-snip snip before x y) + (set! deletions (cons (make-delete-snip-item snip before x y) + deletions))) + + (define/override (cancel) + (unless undid? + (for-each (lambda (i) + (let ([snip (delete-snip-item-snip i)]) + (disown snip) + (send snip set-admin #f))) + deletions))) + + (define/override (undo editor) + (unless cont? + (send editor no-selected)) + + (for-each + (lambda (del) + (let ([snip (delete-snip-item-snip del)]) + ;; have to turn off the owned flag; we know that it's really ours + (disown snip) + + (send editor insert snip + (delete-snip-item-before del) + (delete-snip-item-x del) + (delete-snip-item-y del)) + + (unless cont? + (send editor add-selected snip)))) + deletions) + + (set! undid? #t) + + cont?))) + +(define delete-record% + (class change-record% + (init-field start + end + cont? + startsel + endsel) + (define deletions null) + (define clickbacks null) + (define undid? #f) + (super-new) + + (define/public (insert-snip snip) + (set! deletions (cons snip deletions))) + + (define/public (add-clickback click) + (set! clickbacks (cons click clickbacks))) + + (define/override (cancel) + (unless undid? + (for-each (lambda (snip) + (disown snip) + (send snip set-admin #f)) + deletions))) + + (define/override (undo editor) + ;; have to turn off the owned flag; we know that it's really ours + (for-each disown deletions) + (send editor do-insert-snips deletions start) + (for-each (lambda (cb) + (send editor set-clickback cb)) + clickbacks) + + (send editor set-position startsel endsel) + + (set! undid? #t) + + cont?))) + +(define style-change-record% + (class change-record% + (init-field start + end + cont? + startsel + endsel + restore-selection?) + (define changes null) + (super-new) + + (define/public (add-style-change start end style) + (set! changes (cons (vector start end style) + changes))) + + (define/override (undo editor) + (for-each (lambda (c) + (send editor change-style + (vector-ref c 2) + (vector-ref c 0) + (vector-ref c 1))) + (reverse changes)) + + (when restore-selection? + (send editor set-position startsel endsel)) + + cont?))) + +(define style-change-snip-record% + (class change-record% + (init-field cont?) + (define changes null) + (super-new) + + (define/public (add-style-change snip style) + (set! changes (cons (cons snip style) changes))) + + (define/override (undo editor) + (unless cont? + (send editor no-selected)) + + (for-each (lambda (s) + (send editor change-style (cdr s) (cdr s)) + (unless cont? + (send editor add-selected (car s)))) + (reverse changes)) + + cont?))) + +(define move-snip-record% + (class change-record% + (init-field snip + x + y + delta? + cont?) + (super-new) + + (define/override (undo editor) + (if delta? + (send editor move snip x y) + (send editor move-to snip x y)) + cont?))) + +(define resize-snip-record% + (class change-record% + (init-field snip + x + y + cont?) + (super-new) + + (define/override (undo editor) + (send editor resize snip x y) + cont?))) + +(define composite-record% + (class change-record% + (init count) + (init-field id + parity?) + (unless id + (set! id (if parity? + (cons this #f) + (cons #f this)))) + (define seq (make-vector count)) + (super-new) + + (define/override (cancel) + (for ([c (in-vector seq)]) + (send c cancel))) + + (define/override (undo editor) + (for ([c (in-vector seq)]) + (send c undo)) + #f) + + (define/override (drop-set-unmodified) + (for ([c (in-vector seq)]) + (send c drop-set-unmodified))) + + (define/public (add-undo pos c) + (vector-set! seq (- (vector-length seq) pos 1) c)) + + (define/override (is-composite?) #t) + + (define/override (get-id) id) + + (define/override (get-parity) parity?) + + (define/override (inverse) + (make-object inverse-record% id (not parity?))))) + + +(define inverse-record% + (class change-record% + (init-field id + parity?) + + (define/private (get) + (if parity? + (car id) + (cdr id))) + + (define/override (cancel) + ;; Avoid double-frees by not doing anything + (void)) + + (define/override (undo editor) + (send (get) undo editor)) + + (define/override (drop-set-unmodified) + (let ([c (get)]) + (when c + (send c drop-set-unmodified)))) + + (define/override (get-id) id) + + (define/override (get-parity) parity?) + + (define/override (inverse) + (send (get) inverse)))) diff --git a/collects/mred/private/wxme/wordbreak.ss b/collects/mred/private/wxme/wordbreak.ss new file mode 100644 index 00000000..03b428c9 --- /dev/null +++ b/collects/mred/private/wxme/wordbreak.ss @@ -0,0 +1,151 @@ +#lang scheme/base +(require scheme/class + "../syntax.ss" + "cycle.ss") + +(provide editor-wordbreak-map% + the-editor-wordbreak-map + standard-wordbreak) + +(defclass editor-wordbreak-map% object% + (define char-map (make-hash)) + + (super-new) + + (hash-set! char-map #\- '(line)) + + (def/public (set-map [char? ch] [(make-list (symbol-in caret line selection user1 user2)) mask]) + (hash-set! char-map ch mask)) + + (def/public (get-map [char? ch]) + (or (hash-ref char-map ch #f) + (cond + [(or (char-alphabetic? ch) + (char-numeric? ch)) + '(caret line selection)] + [(not (char-whitespace? ch)) + '(line)] + [else null])))) + +(define the-editor-wordbreak-map (new editor-wordbreak-map%)) + +(define MAX-DIST-TRY 30) + +(define wb-get-map (generic editor-wordbreak-map% get-map)) + +(define (string-ref* str n) + (if (n . >= . (string-length str)) + #\nul + (string-ref str n))) + +(define/top (standard-wordbreak [text% win] + [(make-or-false (make-box exact-nonnegative-integer?)) startp] + [(make-or-false (make-box exact-nonnegative-integer?)) endp] + [(symbol-in caret line selection user1 user2)reason]) + (with-method ([get-map ((send win get-wordbreak-map) get-map)]) + (define (nonbreak? ch) (memq reason (get-map ch))) + + (when startp + (let* ([start (unbox startp)] + [pstart start] + [lstart (send win find-newline 'backward start 0)] + [lstart (if lstart + (if (eq? 'caret reason) + (or (and (positive? lstart) + (send win find-newline 'backward (sub1 lstart) 0)) + 0) + lstart) + 0)] + [lend (min (+ start 1) (send win last-position))] + [tstart (if ((- start lstart) . > . MAX-DIST-TRY) + (- start MAX-DIST-TRY) + lstart)] + [text (send win get-text tstart lend)] + [start (- start tstart)] + [pstart (- pstart tstart)]) + + (let ploop ([phase1-complete? #f] + [phase2-complete? #f] + [start start] + [pstart pstart] + [text text] + [tstart tstart]) + (let*-values ([(start phase1-complete?) + (if phase1-complete? + (values start #t) + (let ([start (if (and (positive? start) + (nonbreak? (string-ref* text start))) + (sub1 start) + start)]) + (values start + (not (nonbreak? (string-ref* text start))))))] + [(start phase2-complete?) + (if (not (eq? 'selection reason)) + (if (not phase2-complete?) + (let loop ([start start]) + (if (and (positive? start) + (not (nonbreak? (string-ref* text start)))) + (loop (sub1 start)) + (if (nonbreak? (string-ref* text start)) + (values start #t) + (values start #f)))) + (values start #t)) + (values start phase2-complete?))]) + (let loop ([start start]) + (if (and (positive? start) + (nonbreak? (string-ref* text start))) + (loop (sub1 start)) + (let ([start (if (and (start . < . pstart) + (not (nonbreak? (string-ref* text start)))) + (add1 start) + start)]) + (if (and (zero? start) + (not (= lstart tstart))) + (ploop phase1-complete? + phase2-complete? + (+ start (- tstart lstart)) + (+ pstart (- tstart lstart)) + (send win get-text lstart lend) + lstart) + (set-box! startp (+ start tstart)))))))))) + + (when endp + (let* ([end (unbox endp)] + [lstart end] + [lend (send win find-newline 'forward end)] + [lend (if lend + (if (eq? 'caret reason) + (or (send win find-newline 'forward (+ lend 1)) + (send win last-position)) + lend) + (send win last-position))] + [tend (if ((- lend end) . > . MAX-DIST-TRY) + (+ end MAX-DIST-TRY) + lend)] + [text (send win get-text lstart tend)] + [end (- end lstart)] + [lend (- lend lstart)] + [tend (- tend lstart)]) + + (let ploop ([phase1-complete? #f] + [text text] + [tend tend]) + (let-values ([(end phase1-complete?) + (if phase1-complete? + (values end #t) + (let loop ([end end]) + (if (and (end . < . tend) + (not (nonbreak? (string-ref* text end)))) + (loop (add1 end)) + (if (end . < . tend) + (values end #t) + (values end #f)))))]) + (let loop ([end end]) + (if (and (end . < . tend) + (nonbreak? (string-ref* text end))) + (loop (add1 end)) + (if (and (= tend end) (not (= lend tend))) + (ploop phase1-complete? + (send win get-text lstart (+ lstart lend)) + lend) + (set-box! endp (+ end lstart))))))))))) diff --git a/collects/mred/private/wxme/wx.ss b/collects/mred/private/wxme/wx.ss new file mode 100644 index 00000000..a50d9a08 --- /dev/null +++ b/collects/mred/private/wxme/wx.ss @@ -0,0 +1,63 @@ +#lang scheme/base +(require "../kernel.ss") + +(define the-clipboard (get-the-clipboard)) +(define the-x-selection-clipboard (get-the-x-selection)) +(define the-brush-list (get-the-brush-list)) +(define the-pen-list (get-the-pen-list)) +(define the-font-list (get-the-font-list)) +(define the-color-database (get-the-color-database)) +(define the-font-name-directory (get-the-font-name-directory)) + +(define (family-symbol? s) + (memq s '(default decorative roman script + swiss modern symbol system))) +(define (style-symbol? s) + (memq s '(normal italic slant))) +(define (weight-symbol? s) + (memq s '(normal bold light))) +(define (smoothing-symbol? s) + (memq s '(default smoothed unsmoothed partly-smoothed))) +(define (size? v) (and (exact-positive-integer? v) + (byte? v))) + +(provide event% + mouse-event% + key-event% + timer% + canvas% + bitmap-dc% + color% + the-color-database + pen% + the-pen-list + brush% + the-brush-list + font% + the-font-list + the-font-name-directory + cursor% + bitmap% + dc<%> + post-script-dc% + printer-dc% + current-eventspace + clipboard-client% + clipboard<%> + the-clipboard + the-x-selection-clipboard + get-double-click-threshold + begin-refresh-sequence + end-refresh-sequence + begin-busy-cursor + end-busy-cursor + hide-cursor + run-printout + current-ps-setup + family-symbol? + style-symbol? + weight-symbol? + smoothing-symbol?) + +(define (get-double-click-threshold) + (get-double-click-time)) diff --git a/collects/mred/private/wxmenu.ss b/collects/mred/private/wxmenu.ss index 91c34e9a..d0a00ff5 100644 --- a/collects/mred/private/wxmenu.ss +++ b/collects/mred/private/wxmenu.ss @@ -3,6 +3,7 @@ mzlib/class100 mzlib/list (prefix wx: "kernel.ss") + (prefix wx: "wxme/keymap.ss") "lock.ss" "const.ss" "helper.ss" diff --git a/collects/mred/private/wxtextfield.ss b/collects/mred/private/wxtextfield.ss index 4ecd8030..f17688bb 100644 --- a/collects/mred/private/wxtextfield.ss +++ b/collects/mred/private/wxtextfield.ss @@ -2,6 +2,8 @@ (require mzlib/class mzlib/class100 (prefix wx: "kernel.ss") + (prefix wx: "wxme/text.ss") + (prefix wx: "wxme/editor-canvas.ss") "lock.ss" "const.ss" "check.ss" diff --git a/collects/mred/private/wxtop.ss b/collects/mred/private/wxtop.ss index ada1f634..da720d36 100644 --- a/collects/mred/private/wxtop.ss +++ b/collects/mred/private/wxtop.ss @@ -4,6 +4,8 @@ mzlib/etc mzlib/list (prefix wx: "kernel.ss") + (prefix wx: "wxme/editor-canvas.ss") + (prefix wx: "wxme/editor-snip.ss") "lock.ss" "helper.ss" "const.ss" diff --git a/collects/scribblings/gui/clipboard-intf.scrbl b/collects/scribblings/gui/clipboard-intf.scrbl index bb1807c6..23094928 100644 --- a/collects/scribblings/gui/clipboard-intf.scrbl +++ b/collects/scribblings/gui/clipboard-intf.scrbl @@ -80,6 +80,14 @@ See @|timediscuss| for a discussion of the @scheme[time] argument. If } + +@defmethod[(same-clipboard-client? [owner (is-a?/c clipboard-client%)]) + boolean?]{ + +Returns @scheme[#t] if @scheme[owner] currently owns the clipboard, +@scheme[#f] otherwise.} + + @defmethod[(set-clipboard-bitmap [new-bitmap (is-a?/c bitmap%)] [time (and/c exact? integer?)]) void?]{ diff --git a/collects/scribblings/gui/editor-intf.scrbl b/collects/scribblings/gui/editor-intf.scrbl index 1e975675..2184550f 100644 --- a/collects/scribblings/gui/editor-intf.scrbl +++ b/collects/scribblings/gui/editor-intf.scrbl @@ -59,7 +59,7 @@ The system adds undoers to an editor (in response to other method } @defmethod[(adjust-cursor [event (is-a?/c mouse-event%)]) - (or/c (is-a?/c cursor%) false/c)]{ + (or/c (is-a?/c cursor%) #f)]{ @methspec{ @@ -332,9 +332,9 @@ Returns @scheme[#t]. }} -@defmethod*[([(change-style [delta (or/c (is-a?/c style-delta%) false/c)]) +@defmethod*[([(change-style [delta (or/c (is-a?/c style-delta%) #f)]) void?] - [(change-style [style (or/c (is-a?/c style<%>) false/c)]) + [(change-style [style (or/c (is-a?/c style<%>) #f)]) void?])]{ Changes the style for @techlink{items} in the editor, either by @@ -456,6 +456,12 @@ Returns the name of a style to be used for newly inserted text, } + +@defmethod[(do-copy) void?]{ + +See @xmethod[text% do-copy] or @xmethod[pasteboard% do-copy].} + + @defmethod[(do-edit-operation [op (one-of/c 'undo 'redo 'clear 'cut 'copy 'paste 'kill 'select-all 'insert-text-box 'insert-pasteboard-box 'insert-image)] @@ -492,6 +498,17 @@ See @|timediscuss| for a discussion of the @scheme[time] argument. If } + +@defmethod[(do-paste) void?]{ + +See @xmethod[text% do-paste] or @xmethod[pasteboard% do-paste].} + + +@defmethod[(do-paste-x-selection) void?]{ + +See @xmethod[text% do-paste-x-selection] or @xmethod[pasteboard% do-paste-x-selection].} + + @defmethod[(editor-location-to-dc-location [x real?] [y real?]) (values real? real?)]{ @@ -530,7 +547,7 @@ more information. @defmethod[(find-first-snip) - (or/c (is-a?/c snip%) false/c)]{ + (or/c (is-a?/c snip%) #f)]{ Returns the first snip in the editor, or @scheme[#f] if the editor is empty. To get all of the snips in the editor, use the @xmethod[snip% @@ -553,7 +570,7 @@ For @scheme[text%] objects: @|FCA| @|OVD| } @defmethod[(get-active-canvas) - (or/c (is-a?/c editor-canvas%) false/c)]{ + (or/c (is-a?/c editor-canvas%) #f)]{ If the editor is displayed in a canvas, this method returns the canvas that most recently had the keyboard focus (while the editor was @@ -562,7 +579,7 @@ If the editor is displayed in a canvas, this method returns the canvas } @defmethod[(get-admin) - (or/c (is-a?/c editor-admin%) false/c)]{ + (or/c (is-a?/c editor-admin%) #f)]{ Returns the @scheme[editor-admin%] object currently managing this editor or @scheme[#f] if the editor is not displayed. @@ -570,7 +587,7 @@ Returns the @scheme[editor-admin%] object currently managing this } @defmethod[(get-canvas) - (or/c (is-a?/c editor-canvas%) false/c)]{ + (or/c (is-a?/c editor-canvas%) #f)]{ If @method[editor<%> get-active-canvas] returns a canvas, that canvas is also returned by this method. Otherwise, if @method[editor<%> @@ -591,7 +608,7 @@ Returns a list of canvases displaying the editor. An editor may be } @defmethod[(get-dc) - (or/c (is-a?/c dc<%>) false/c)]{ + (or/c (is-a?/c dc<%>) #f)]{ Typically used (indirectly) by snip objects belonging to the editor. Returns a destination drawing context which is suitable for @@ -610,8 +627,8 @@ Returns the font descent for the editor. This method is primarily used } -@defmethod[(get-extent [w (or/c (box/c (and/c real? (not/c negative?))) false/c)] - [h (or/c (box/c (and/c real? (not/c negative?))) false/c)]) +@defmethod[(get-extent [w (or/c (box/c (and/c real? (not/c negative?))) #f)] + [h (or/c (box/c (and/c real? (not/c negative?))) #f)]) void?]{ Gets the current extent of the editor's graphical representation. @@ -622,8 +639,8 @@ Gets the current extent of the editor's graphical representation. } -@defmethod[(get-file [directory (or/c path? false/c)]) - (or/c path-string? false/c)]{ +@defmethod[(get-file [directory (or/c path? #f)]) + (or/c path-string? #f)]{ @methspec{ Called when the user must be queried for a filename to load an @@ -644,8 +661,8 @@ If the editor is displayed in a single canvas, then the canvas's }} -@defmethod[(get-filename [temp (box/c (or/c any/c false/c)) #f]) - (or/c path-string? false/c)]{ +@defmethod[(get-filename [temp (box/c (or/c any/c #f)) #f]) + (or/c path-string? #f)]{ Returns the path name of the last file saved from or loaded into this editor, @scheme[#f] if the editor has no filename. @@ -665,7 +682,7 @@ a discussion of flattened vs. non-flattened text. @defmethod[(get-focus-snip) - (or/c (is-a?/c snip%) false/c)]{ + (or/c (is-a?/c snip%) #f)]{ @index['("keyboard focus" "snips")]{Returns} the snip within the editor that gets the keyboard focus when the editor has the focus, or @@ -698,7 +715,7 @@ See also @method[editor<%> set-inactive-caret-threshold] and @defmethod[(get-keymap) - (or/c (is-a?/c keymap%) false/c)]{ + (or/c (is-a?/c keymap%) #f)]{ Returns the main keymap currently used by the editor. @@ -788,7 +805,7 @@ If the result is @scheme[#t], then the editor accepts only plain-text } @defmethod[(get-snip-data [thesnip (is-a?/c snip%)]) - (or/c (is-a?/c editor-data%) false/c)]{ + (or/c (is-a?/c editor-data%) #f)]{ @methspec{ @@ -805,8 +822,8 @@ Returns @scheme[#f]. @defmethod[(get-snip-location [thesnip (is-a?/c snip%)] - [x (or/c (box/c real?) false/c) #f] - [y (or/c (box/c real?) false/c) #f] + [x (or/c (box/c real?) #f) #f] + [y (or/c (box/c real?) #f) #f] [bottom-right? any/c #f]) boolean?]{ @@ -850,8 +867,8 @@ Returns the style list currently in use by the editor. } -@defmethod[(get-view-size [w (or/c (box/c (and/c real? (not/c negative?))) false/c)] - [h (or/c (box/c (and/c real? (not/c negative?))) false/c)]) +@defmethod[(get-view-size [w (or/c (box/c (and/c real? (not/c negative?))) #f)] + [h (or/c (box/c (and/c real? (not/c negative?))) #f)]) void?]{ Returns the visible area into which the editor is currently being @@ -868,8 +885,8 @@ If the @techlink{display} is an editor canvas, see also } -@defmethod[(global-to-local [x (or/c (box/c real?) false/c)] - [y (or/c (box/c real?) false/c)]) +@defmethod[(global-to-local [x (or/c (box/c real?) #f)] + [y (or/c (box/c real?) #f)]) void?]{ Converts the given coordinates from top-level @techlink{display} coordinates @@ -949,7 +966,7 @@ The @scheme[show-errors?] argument is no longer used. } -@defmethod[(insert-image [filename (or/c path-string? false/c) #f] +@defmethod[(insert-image [filename (or/c path-string? #f) #f] [type (one-of/c 'unknown 'gif 'jpeg 'xbm 'xpm 'bmp 'pict) 'unknown] [relative-path? any/c #f] [inline? any/c #t]) @@ -974,7 +991,7 @@ calling @defmethod[(insert-port [port input-port] [format (one-of/c 'guess 'same 'copy 'standard 'text 'text-force-cr) 'guess] - [show-errors? any/c #t]) + [replace-styles? any/c #t]) (one-of/c 'standard 'text 'text-force-cr)]{ Use @method[editor<%> insert-file], instead. @@ -991,8 +1008,8 @@ The @scheme[port] must support position setting with @scheme[file-position]. For information on @scheme[format], see @method[editor<%> load-file]. -The @scheme[show-errors?] argument is no longer used. - +if @scheme[replace-styles?] is true, then styles in the current style + list are replaced by style specifications in @scheme[port]'s stream. } @defmethod[(invalidate-bitmap-cache [x real? 0.0] @@ -1030,13 +1047,20 @@ Returns @scheme[#t] if the editor is currently locked, @scheme[#f] @defmethod[(is-modified?) boolean?]{ -Returns @scheme[#t] is the editor has been modified since the last +Returns @scheme[#t] if the editor has been modified since the last save or load (or the last call to @method[editor<%> set-modified] with @scheme[#f]), @scheme[#f] otherwise. } +@defmethod[(is-printing?) + boolean?]{ + +Returns @scheme[#t] if the editor is currently being printed through +the @method[editor<%> print] method, @scheme[#f] otherwise.} + + @defmethod[(kill [time (and/c exact? integer?) 0]) void?]{ @@ -1056,7 +1080,7 @@ See also @method[editor<%> cut]. } -@defmethod[(load-file [filename (or/c path-string? false/c) #f] +@defmethod[(load-file [filename (or/c path-string? #f) #f] [format (one-of/c 'guess 'same 'copy 'standard 'text 'text-force-cr) 'guess] [show-errors? any/c #t]) @@ -1117,8 +1141,8 @@ See also @method[editor<%> on-load-file], @method[editor<%> } -@defmethod[(local-to-global [x (box/c real?)] - [y (box/c real?)]) +@defmethod[(local-to-global [x (or/c (box/c real?) #f)] + [y (or/c (box/c real?) #f)]) void?]{ Converts the given coordinates from editor @techlink{location} @@ -1499,7 +1523,7 @@ Creates a @scheme[editor-snip%] with either a sub-editor from }} -@defmethod[(on-new-image-snip [filename (or/c path? false/c)] +@defmethod[(on-new-image-snip [filename (or/c path? #f)] [kind (one-of/c 'unknown 'gif 'jpeg 'xbm 'xpm 'bmp 'pict)] [relative-path? any/c] [inline? any/c]) @@ -1689,7 +1713,7 @@ To extend or re-implement copying, override the @xmethod[text% @defmethod[(print [interactive? any/c #t] [fit-on-page? any/c #t] [output-mode (one-of/c 'standard 'postscript) 'standard] - [parent (or/c (or/c @scheme[frame%] (is-a?/c dialog%)) false/c) #f] + [parent (or/c (or/c @scheme[frame%] (is-a?/c dialog%)) #f) #f] [force-ps-page-bbox? any/c #t] [as-eps? any/c #f]) void?]{ @@ -1750,18 +1774,26 @@ The printing margins are determined by @method[ps-setup% } -@defmethod[(print-to-dc [dc (is-a?/c dc<%>)]) +@defmethod[(print-to-dc [dc (is-a?/c dc<%>)] + [page-number exact-integer? -1]) void?]{ Prints the editor into the given drawing context. See also @method[editor<%> print]. +If @scheme[page-number] is a non-negative integer, then just the +indicated page is printed, where pages are numbered from +@scheme[1]. (So, supplying @scheme[0] as @scheme[page-number] produces +no output.) When @scheme[page-number] is negative, the +@method[dc<%> start-page] and @scheme[dc<%> end-page] methods of @scheme[dc] are +called for each page. + } -@defmethod[(put-file [directory (or/c path? false/c)] - [default-name (or/c path? false/c)]) - (or/c path-string? false/c)]{ +@defmethod[(put-file [directory (or/c path? #f)] + [default-name (or/c path? #f)]) + (or/c path-string? #f)]{ @methspec{ Called when the user must be queried for a filename to save an @@ -1860,7 +1892,7 @@ See also @method[editor<%> add-undo]. [width (and/c real? (not/c negative?))] [height (and/c real? (not/c negative?))] [draw-caret (one-of/c 'no-caret 'show-inactive-caret 'show-caret)] - [background (or/c (is-a?/c color%) false/c)]) + [background (or/c (is-a?/c color%) #f)]) void?]{ Repaints a region of the editor, generally called by an editor @@ -1940,7 +1972,7 @@ If @scheme[redraw-now?] is @scheme[#f], the editor will require } -@defmethod[(save-file [filename (or/c path-string? false/c) #f] +@defmethod[(save-file [filename (or/c path-string? #f) #f] [format (one-of/c 'guess 'same 'copy 'standard 'text 'text-force-cr) 'same] [show-errors? any/c #t]) @@ -2074,7 +2106,7 @@ Normally, this method is called only by @xmethod[editor-canvas% } -@defmethod[(set-admin [admin (or/c (is-a?/c editor-admin%) false/c)]) +@defmethod[(set-admin [admin (or/c (is-a?/c editor-admin%) #f)]) void?]{ Sets the editor's administrator. This method is only called by an @@ -2087,7 +2119,7 @@ get-admin]}] } -@defmethod[(set-caret-owner [snip (or/c (is-a?/c snip%) false/c)] +@defmethod[(set-caret-owner [snip (or/c (is-a?/c snip%) #f)] [domain (one-of/c 'immediate 'display 'global) 'immediate]) void?]{ @@ -2127,8 +2159,8 @@ See also @method[editor<%> get-focus-snip]. } -@defmethod[(set-cursor [cursor (or/c (is-a?/c cursor%) false/c)] - [override? any/c @scheme[#t]]) +@defmethod[(set-cursor [cursor (or/c (is-a?/c cursor%) #f)] + [override? any/c #t]) void?]{ Sets the custom cursor for the editor to @scheme[cursor]. If @@ -2148,7 +2180,7 @@ An embedding editor's custom cursor can override the cursor of an } -@defmethod[(set-filename [filename (or/c path-string? false/c)] +@defmethod[(set-filename [filename (or/c path-string? #f)] [temporary? any/c #f]) void?]{ @@ -2172,7 +2204,7 @@ Sets the threshold for painting an inactive selection. See } -@defmethod[(set-keymap [keymap (or/c (is-a?/c keymap%) false/c) #f]) +@defmethod[(set-keymap [keymap (or/c (is-a?/c keymap%) #f) #f]) void?]{ Sets the current keymap for the editor. A @scheme[#f] argument removes @@ -2336,7 +2368,7 @@ recalculated on demand. See also @method[editor<%> invalidate-bitmap-cache].} -@defmethod[(style-has-changed [style (or/c (is-a?/c style<%>) false/c)]) +@defmethod[(style-has-changed [style (or/c (is-a?/c style<%>) #f)]) void?]{ Notifies the editor that a style in its style list has changed. This diff --git a/collects/scribblings/gui/editor-stream-in-base-class.scrbl b/collects/scribblings/gui/editor-stream-in-base-class.scrbl index adc5952e..ce4cfc89 100644 --- a/collects/scribblings/gui/editor-stream-in-base-class.scrbl +++ b/collects/scribblings/gui/editor-stream-in-base-class.scrbl @@ -24,14 +24,18 @@ Returns @scheme[#t] if there has been an error reading from the @defmethod[(read [data (and/c vector? (not immutable?))]) exact-nonnegative-integer?]{ -Reads Latin-1 characters to fill the supplied vector. The return value is the - number of characters read, which may be less than the number +Like @method[editor-stream-in-base% read-bytes], but fills a supplied +vector with Latin-1 characters instead of filling a byte string. This method +is implemented by default via @method[editor-stream-in-base% read-bytes].} + +@defmethod[(read-bytes [bstr (and/c bytes? (not immutable?))]) + exact-nonnegative-integer?]{ + +Reads bytes to fill the supplied byte string. The return value is the + number of bytes read, which may be less than the number requested if the stream is emptied. If the stream is emptied, the next call to @method[editor-stream-in-base% bad?] must return - @scheme[#t]. - -} - + @scheme[#t].} @defmethod[(seek [pos exact-nonnegative-integer?]) void?]{ diff --git a/collects/scribblings/gui/editor-stream-out-base-class.scrbl b/collects/scribblings/gui/editor-stream-out-base-class.scrbl index d45aabb5..9b02aab2 100644 --- a/collects/scribblings/gui/editor-stream-out-base-class.scrbl +++ b/collects/scribblings/gui/editor-stream-out-base-class.scrbl @@ -39,6 +39,12 @@ Returns the current stream position. @defmethod[(write [data (listof char?)]) void?]{ -Writes data (encoded as Latin-1 characters) to the stream. +Writes data (encoded as Latin-1 characters) to the stream. This method +is implemented by default via @method[editor-stream-out-base% +write-bytes].} + +@defmethod[(write-bytes [bstr bytes?]) void?]{ + +Writes data to the stream.}} + -}} diff --git a/collects/scribblings/gui/editor-stream-out-class.scrbl b/collects/scribblings/gui/editor-stream-out-class.scrbl index 2499f448..d869eaf2 100644 --- a/collects/scribblings/gui/editor-stream-out-class.scrbl +++ b/collects/scribblings/gui/editor-stream-out-class.scrbl @@ -62,8 +62,9 @@ This method is called by @scheme[write-editor-global-header]. Writes @scheme[v], or @scheme[n] bytes of @scheme[v]. -When @scheme[n] is supplied, use @method[editor-stream-in% - get-unterminated-bytes] to read the bytes later. +When @scheme[n] is supplied with a byte-string @scheme[v], use + @method[editor-stream-in% get-unterminated-bytes] to read the bytes + later. If @scheme[n] is not supplied and @scheme[v] is a byte string, then for historical reasons, the actual number of bytes written includes a @@ -85,9 +86,14 @@ Puts a fixed-sized integer into the stream. This method is needed fixed-size number. Numbers written to a stream with @method[editor-stream-out% put-fixed] - must be read with @method[editor-stream-in% get-fixed]. + must be read with @method[editor-stream-in% get-fixed].} + + +@defmethod[(put-unterminated [v bytes?]) (is-a?/c editor-stream-out%)]{ + +The same as calling @method[editor-stream-out% put] with +@scheme[(bytes-length v)] and @scheme[v].} -} @defmethod[(tell) exact-nonnegative-integer?]{ diff --git a/collects/scribblings/gui/pasteboard-class.scrbl b/collects/scribblings/gui/pasteboard-class.scrbl index d4e58bc6..5c109bb6 100644 --- a/collects/scribblings/gui/pasteboard-class.scrbl +++ b/collects/scribblings/gui/pasteboard-class.scrbl @@ -499,7 +499,8 @@ Deletes @scheme[snip] when provided, or deletes the currently selected } -@defmethod[(do-copy [time (and/c exact? integer?)] +@defmethod[#:mode override + (do-copy [time (and/c exact? integer?)] [extend? any/c]) void?]{ @@ -523,7 +524,8 @@ Copies the current selection, extending the current clipboard contexts }} -@defmethod[(do-paste [time (and/c exact? integer?)]) +@defmethod[#:mode override + (do-paste [time (and/c exact? integer?)]) void?]{ @methspec{ @@ -544,7 +546,8 @@ Pastes. }} -@defmethod[(do-paste-x-selection [time (and/c exact? integer?)]) +@defmethod[#:mode override + (do-paste-x-selection [time (and/c exact? integer?)]) void?]{ @methspec{ @@ -806,7 +809,7 @@ Deselects all selected snips in the editor. } -@defmethod[#:mode override +@defmethod[#:mode override (on-default-event [event (is-a?/c mouse-event%)]) void?]{ diff --git a/collects/scribblings/gui/text-class.scrbl b/collects/scribblings/gui/text-class.scrbl index 1b0f04dd..3635683e 100644 --- a/collects/scribblings/gui/text-class.scrbl +++ b/collects/scribblings/gui/text-class.scrbl @@ -324,12 +324,12 @@ See also @method[text% hide-caret]. @defmethod*[#:mode extend - ([(change-style [delta (or/c (is-a?/c style-delta%) false/c)] + ([(change-style [delta (or/c (is-a?/c style-delta%) #f)] [start (or/c exact-nonnegative-integer? (one/of 'start)) 'start] [end (or/c exact-nonnegative-integer? (one/of 'end)) 'end] [counts-as-mod? any/c #t]) void?] - [(change-style [style (or/c (is-a?/c style<%>) false/c)] + [(change-style [style (or/c (is-a?/c style<%>) #f)] [start (or/c exact-nonnegative-integer? (one/of 'start)) 'start] [end (or/c exact-nonnegative-integer? (one/of 'end)) 'end] [counts-as-mod? any/c #t]) @@ -422,7 +422,8 @@ Deletes the specified range or the currently selected text (when no } -@defmethod[(do-copy [start exact-nonnegative-integer?] +@defmethod[#:mode override + (do-copy [start exact-nonnegative-integer?] [end exact-nonnegative-integer?] [time (and/c exact? integer?)] [extend? any/c]) @@ -446,7 +447,8 @@ Copy the data from @scheme[start] to @scheme[end], extending the current }} -@defmethod[(do-paste [start exact-nonnegative-integer?] +@defmethod[#:mode override + (do-paste [start exact-nonnegative-integer?] [time (and/c exact? integer?)]) void?]{ @methspec{ @@ -467,7 +469,8 @@ Pastes into the @techlink{position} @scheme[start]. }} -@defmethod[(do-paste-x-selection [start exact-nonnegative-integer?] +@defmethod[#:mode override + (do-paste-x-selection [start exact-nonnegative-integer?] [time (and/c exact? integer?)]) void?]{ @methspec{ @@ -500,7 +503,7 @@ See also @method[text% delete]. @defmethod[(find-line [y real?] - [on-it? (or/c (box/c any/c) false/c) #f]) + [on-it? (or/c (box/c any/c) #f) #f]) exact-nonnegative-integer?]{ Given a @techlink{location} in the editor, returns the line at the @@ -516,8 +519,17 @@ Given a @techlink{location} in the editor, returns the line at the } -@defmethod[(find-next-non-string-snip [after (or/c (is-a?/c snip%) false/c)]) - (or/c (is-a?/c snip%) false/c)]{ +@defmethod[(find-newline [direction (one-of/c 'forward 'backward) 'forward] + [start (or/c exact-nonnegative-integer? (one/of 'start)) 'start] + [end (or/c exact-nonnegative-integer? (one/of 'eof)) 'eof]) + (or/c exact-nonnegative-integer? #f)]{ + +Like @method[text% find-string], but specifically finds a paragraph +break (possibly more efficiently than searching text).} + + +@defmethod[(find-next-non-string-snip [after (or/c (is-a?/c snip%) #f)]) + (or/c (is-a?/c snip%) #f)]{ Given a snip, returns the next snip in the editor (after the given one) that is not an instance of @scheme[string-snip%]. If @@ -530,9 +542,9 @@ Given a snip, returns the next snip in the editor (after the given @defmethod[(find-position [x real?] [y real?] - [at-eol? (or/c (box/c any/c) false/c) #f] - [on-it? (or/c (box/c any/c) false/c) #f] - [edge-close? (or/c (box/c real?) false/c) #f]) + [at-eol? (or/c (box/c any/c) #f) #f] + [on-it? (or/c (box/c any/c) #f) #f] + [edge-close? (or/c (box/c real?) #f) #f]) exact-nonnegative-integer?]{ Given a @techlink{location} in the editor, returns the @techlink{position} at the @@ -557,9 +569,9 @@ See @|ateoldiscuss| for a discussion of the @scheme[at-eol?] argument. @defmethod[(find-position-in-line [line exact-nonnegative-integer?] [x real?] - [at-eol? (or/c (box/c any/c) false/c) #f] - [on-it? (or/c (box/c any/c) false/c) #f] - [edge-close? (or/c (box/c real?) false/c) #f]) + [at-eol? (or/c (box/c any/c) #f) #f] + [on-it? (or/c (box/c any/c) #f) #f] + [edge-close? (or/c (box/c real?) #f) #f]) exact-nonnegative-integer?]{ Given a @techlink{location} within a line of the editor, returns the @@ -579,8 +591,8 @@ See @method[text% find-position] for a discussion of @defmethod[(find-snip [pos exact-nonnegative-integer?] [direction (one-of/c 'before-or-none 'before 'after 'after-or-none)] - [s-pos (or/c (box/c exact-nonnegative-integer?) false/c) #f]) - (or/c (is-a?/c snip%) false/c)]{ + [s-pos (or/c (box/c exact-nonnegative-integer?) #f) #f]) + (or/c (is-a?/c snip%) #f)]{ Returns the snip at a given @techlink{position}, or @scheme[#f] if an appropriate snip cannot be found. @@ -615,7 +627,7 @@ can be any of the following: [end (or/c exact-nonnegative-integer? (one/of 'eof)) 'eof] [get-start? any/c #t] [case-sensitive? any/c #t]) - (or/c exact-nonnegative-integer? false/c)]{ + (or/c exact-nonnegative-integer? #f)]{ Finds an exact-match string in the editor and returns its @techlink{position}. If the string is not found, @scheme[#f] is returned. @@ -656,8 +668,8 @@ Finds all occurrences of a string using @method[text% find-string]. If } -@defmethod[(find-wordbreak [start (or/c (box/c exact-nonnegative-integer?) false/c)] - [end (or/c (box/c exact-nonnegative-integer?) false/c)] +@defmethod[(find-wordbreak [start (or/c (box/c exact-nonnegative-integer?) #f)] + [end (or/c (box/c exact-nonnegative-integer?) #f)] [reason (one-of/c 'caret 'line 'selection 'user1 'user2)]) void?]{ @@ -804,8 +816,8 @@ Returns @scheme[#t] if the editor is in overwrite mode, @scheme[#f] } -@defmethod[(get-position [start (or/c (box/c exact-nonnegative-integer?) false/c)] - [end (or/c (box/c exact-nonnegative-integer?) false/c) #f]) +@defmethod[(get-position [start (or/c (box/c exact-nonnegative-integer?) #f)] + [end (or/c (box/c exact-nonnegative-integer?) #f) #f]) void?]{ Returns the current selection range in @techlink{position}s. If @@ -823,7 +835,7 @@ and @method[text% get-end-position]. @defmethod[(get-region-data [start exact-nonnegative-integer?] [end exact-nonnegative-integer?]) - (or/c (is-a?/c editor-data%) false/c)]{ + (or/c (is-a?/c editor-data%) #f)]{ Gets extra data associated with a given region. See @|editordatadiscuss| for more information. @@ -854,7 +866,7 @@ Returns an inexact number that increments every time the editor is @defmethod[(get-snip-position [snip (is-a?/c snip%)]) - (or/c exact-nonnegative-integer? false/c)]{ + (or/c exact-nonnegative-integer? #f)]{ Returns the starting @techlink{position} of a given snip or @scheme[#f] if the snip is not in this editor. @@ -862,9 +874,9 @@ Returns the starting @techlink{position} of a given snip or } @defmethod[(get-snip-position-and-location [snip (is-a?/c snip%)] - [pos (or/c (box/c exact-nonnegative-integer?) false/c)] - [x (or/c (box/c real?) false/c) #f] - [y (or/c (box/c real?) false/c) #f]) + [pos (or/c (box/c exact-nonnegative-integer?) #f)] + [x (or/c (box/c real?) #f) #f] + [y (or/c (box/c real?) #f) #f]) boolean?]{ Gets a snip's @techlink{position} and top left @techlink{location} in editor @@ -911,9 +923,9 @@ See also @method[text% set-styles-sticky]. } -@defmethod[(get-tabs [length (or/c (box/c exact-nonnegative-integer?) false/c) #f] - [tab-width (or/c (box/c real?) false/c) #f] - [in-units (or/c (box/c any/c) false/c) #f]) +@defmethod[(get-tabs [length (or/c (box/c exact-nonnegative-integer?) #f) #f] + [tab-width (or/c (box/c real?) #f) #f] + [in-units (or/c (box/c any/c) #f) #f]) (listof real?)]{ Returns the current tab-position array as a list. @@ -964,8 +976,8 @@ Returns the distance from the top of the editor to the alignment } -@defmethod[(get-visible-line-range [start (or/c (box/c exact-nonnegative-integer?) false/c)] - [end (or/c (box/c exact-nonnegative-integer?) false/c)] +@defmethod[(get-visible-line-range [start (or/c (box/c exact-nonnegative-integer?) #f)] + [end (or/c (box/c exact-nonnegative-integer?) #f)] [all? any/c #t]) void?]{ @@ -985,8 +997,8 @@ If the editor is displayed by multiple canvases and @scheme[all?] is } -@defmethod[(get-visible-position-range [start (or/c (box/c exact-nonnegative-integer?) false/c)] - [end (or/c (box/c exact-nonnegative-integer?) false/c)] +@defmethod[(get-visible-position-range [start (or/c (box/c exact-nonnegative-integer?) #f)] + [end (or/c (box/c exact-nonnegative-integer?) #f)] [all? any/c #t]) void?]{ @@ -1523,7 +1535,9 @@ If the paragraph ends with invisible @techlink{item}s (such as a carriage @defmethod[(paragraph-start-line [paragraph exact-nonnegative-integer?]) exact-nonnegative-integer?]{ -Returns the starting line of a given paragraph. @|ParagraphNumbering| @|LineNumbering| +Returns the starting line of a given paragraph. If @scheme[paragraph] +is greater than the highest-numbered paragraph, then the editor's end +@tech{position} is returned. @|ParagraphNumbering| @|LineNumbering| @|FCAMW| @|EVD| @@ -1548,13 +1562,17 @@ If the paragraph starts with invisible @techlink{item}s and @scheme[visible?] is @defmethod[#:mode override (paste [time (and/c exact? integer?) 0] - [start (or/c exact-nonnegative-integer? (one/of 'end)) 'end] + [start (or/c exact-nonnegative-integer? (one/of 'start 'end)) 'start] [end (or/c exact-nonnegative-integer? (one/of 'same)) 'same]) void?]{ -Pastes into the specified range. If @scheme[start] is @scheme['end], then - the current selection end @techlink{position} is used. If @scheme[end] is - @scheme['same], then @scheme[start] is used for @scheme[end]. +Pastes into the specified range. If @scheme[start] is @scheme['start], + then the current selection start @techlink{position} is used. If + @scheme[start] is @scheme['end], then the current selection end + @techlink{position} is used. If @scheme[end] is @scheme['same], then + @scheme[start] is used for @scheme[end], unless @scheme[start] is + @scheme['start], in which case the current selection end + @techlink{position} is used. See @|timediscuss| for a discussion of the @scheme[time] argument. If @scheme[time] is outside the platform-specific range of times, @@ -1586,13 +1604,17 @@ If the previous operation on the editor was not a paste, calling @defmethod[#:mode override (paste-x-selection [time (and/c exact? integer?)] - [start (or/c exact-nonnegative-integer? (one/of 'end)) 'end] + [start (or/c exact-nonnegative-integer? (one/of 'start 'end)) 'start] [end (or/c exact-nonnegative-integer? (one/of 'same)) 'same]) void?]{ -Pastes into the specified range. If @scheme[start] is @scheme['end], then - the current selection end @techlink{position} is used. If @scheme[end] is - @scheme['same], then @scheme[start] is used for @scheme[end]. +Pastes into the specified range. If @scheme[start] is @scheme['start], + then the current selection start @techlink{position} is used. If + @scheme[start] is @scheme['end], then the current selection end + @techlink{position} is used. If @scheme[end] is @scheme['same], then + @scheme[start] is used for @scheme[end], unless @scheme[start] is + @scheme['start], in which case the current selection end + @techlink{position} is used. See @|timediscuss| for a discussion of the @scheme[time] argument. If @scheme[time] is outside the platform-specific range of times, @@ -1616,8 +1638,8 @@ See @|ateoldiscuss| for a discussion of @scheme[at-eol?]. @defmethod[(position-location [start exact-nonnegative-integer?] - [x (or/c (box/c real?) false/c) #f] - [y (or/c (box/c real?) false/c) #f] + [x (or/c (box/c real?) #f) #f] + [y (or/c (box/c real?) #f) #f] [top? any/c #t] [at-eol? any/c #f] [whole-line? any/c #f]) @@ -1647,10 +1669,10 @@ maximum bottom @techlink{location} for the whole line is returned in @scheme[y]. @defmethod[(position-locations [start exact-nonnegative-integer?] - [top-x (or/c (box/c real?) false/c) #f] - [top-y (or/c (box/c real?) false/c) #f] - [bottom-x (or/c (box/c real?) false/c) #f] - [bottom-y (or/c (box/c real?) false/c) #f] + [top-x (or/c (box/c real?) #f) #f] + [top-y (or/c (box/c real?) #f) #f] + [bottom-x (or/c (box/c real?) #f) #f] + [bottom-y (or/c (box/c real?) #f) #f] [at-eol? any/c #f] [whole-line? any/c #f]) void?]{ @@ -1750,8 +1772,8 @@ If @scheme[on?] is not @scheme[#f], then the selection will be } -@defmethod[(set-autowrap-bitmap [bitmap (or/c (is-a?/c bitmap%) false/c)]) - (or/c (is-a?/c bitmap%) false/c)]{ +@defmethod[(set-autowrap-bitmap [bitmap (or/c (is-a?/c bitmap%) #f)]) + (or/c (is-a?/c bitmap%) #f)]{ Sets the bitmap that is drawn at the end of a line when it is automatically line-wrapped. @@ -1790,7 +1812,7 @@ See also exact-nonnegative-integer? exact-nonnegative-integer?) . -> . any)] - [hilite-delta (or/c (is-a?/c style-delta%) false/c) #f] + [hilite-delta (or/c (is-a?/c style-delta%) #f) #f] [call-on-down? any/c #f]) void?]{ @@ -2010,8 +2032,8 @@ Setting tabs is disallowed when the editor is internally locked for } -@defmethod[(set-wordbreak-func [f ((is-a?/c text%) (or/c (box/c exact-nonnegative-integer?) false/c) - (or/c (box/c exact-nonnegative-integer?) false/c) +@defmethod[(set-wordbreak-func [f ((is-a?/c text%) (or/c (box/c exact-nonnegative-integer?) #f) + (or/c (box/c exact-nonnegative-integer?) #f) symbol? . -> . any)]) void?]{ @@ -2036,7 +2058,7 @@ Since the wordbreak function will be called when line breaks are being } -@defmethod[(set-wordbreak-map [map (or/c (is-a?/c editor-wordbreak-map%) false/c)]) +@defmethod[(set-wordbreak-map [map (or/c (is-a?/c editor-wordbreak-map%) #f)]) void?]{ Sets the wordbreaking map that is used by the standard wordbreaking diff --git a/collects/tests/mred/media8.mre b/collects/tests/mred/media8.mre index 3b2f394b..3f19360e 100644 --- a/collects/tests/mred/media8.mre +++ b/collects/tests/mred/media8.mre @@ -1,17 +1,20 @@ #reader(lib"read.ss""wxme")WXME0108 ## +#| + This file is in PLT Scheme editor format. Open this file in DrScheme version 370 or later to read it. - Open this file in DrScheme version 370 or later to read it. - Most likely, it was created by saving a program in DrScheme version - 370 or later, and it probably contains a program with non-text - elements (such as images or comment boxes). - www.plt-scheme.org + + Most likely, it was created by saving a program in DrScheme, + and it probably contains a program with non-text elements + (such as images or comment boxes). + + http://www.plt-scheme.org |# 4 7 #"wxtext\0" 3 1 6 #"wxtab\0" 1 1 8 #"wxmedia\0" -3 1 8 #"wximage\0" +4 1 8 #"wximage\0" 2 0 1 6 #"wxloc\0" -00000000000 1 26 0 9 #"Standard\0" +00000000000 1 19 0 9 #"Standard\0" 0 70 1 #"\0" 1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 0 1 #"\0" 0 70 1 #"\0" @@ -50,25 +53,11 @@ 0 75 1 #"\0" 1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 0 1 1 1 #"\0" 0 70 1 #"\0" -1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 2 1 1 1 #"\0" -0 71 1 #"\0" -1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 -1 1 1 #"\0" -0 70 1 #"\0" -1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 -1 1 1 #"\0" -0 72 1 #"\0" -1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 -1 1 1 #"\0" -0 73 1 #"\0" -1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 -1 1 1 #"\0" -0 74 1 #"\0" -1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 -1 1 1 #"\0" -0 75 1 #"\0" -1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 -1 1 1 #"\0" -0 -1 1 #"\0" -1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 -1 -00000000002 0 00000000000 2 00000000000 41 0 1 3 44 +1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 2 1 00000000002 +0 00000000000 2 00000000000 40 0 1 3 44 #"This is a line of plain text (default font)." 0 0 1 29 1 #"\n" -0 2 1 1 1 5 5 5 5 1 1 1 1 -1 -1 -1 -1 0 0 00000000000 2 3 0 9 +0 2 1 1 1 5 5 5 5 1 1 1 1 -1 -1 -1 -1 0 0 0 00000000000 2 3 0 9 #"Standard\0" 0 70 1 #"\0" 1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 0 1 #"\0" @@ -76,13 +65,13 @@ 1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 00000000000 1 0 1 3 38 #"This is a line of plain text in a box." 0 00000000000 0 0 1 29 1 #"\n" -0 2 1 1 1 5 5 5 5 1 1 1 1 -1 -1 -1 -1 0 0 00000000000 3 3 0 9 +0 2 1 1 1 5 5 5 5 1 1 1 1 -1 -1 -1 -1 0 0 0 00000000000 3 3 0 9 #"Standard\0" 0 70 1 #"\0" 1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 0 1 #"\0" 0 70 1 #"\0" 1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 00000000000 -1 2 1 1 1 5 5 5 5 1 1 1 1 -1 -1 -1 -1 0 0 00000000000 4 3 0 9 +1 2 1 1 1 5 5 5 5 1 1 1 1 -1 -1 -1 -1 0 0 0 00000000000 4 3 0 9 #"Standard\0" 0 70 1 #"\0" 1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 0 1 #"\0" @@ -97,7 +86,7 @@ 0 0 5 3 29 #"This has a yellow background." 0 0 1 29 1 #"\n" 0 0 7 3 34 #"Top aligned (compared to the box)." -0 2 1 1 1 5 5 5 5 1 1 1 1 -1 -1 -1 -1 0 0 00000000000 5 5 0 9 +0 2 1 1 1 5 5 5 5 1 1 1 1 -1 -1 -1 -1 0 0 0 00000000000 5 5 0 9 #"Standard\0" 0 70 1 #"\0" 1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 0 1 #"\0" @@ -112,7 +101,7 @@ 0 0 1 29 1 #"\n" 0 0 4 3 3 #"Red" 0 0 4 29 1 #"\n" -0 2 4 1 1 5 5 5 5 1 1 1 1 -1 -1 -1 -1 0 0 00000000000 6 4 0 9 +0 2 4 1 1 5 5 5 5 1 1 1 1 -1 -1 -1 -1 0 0 0 00000000000 6 4 0 9 #"Standard\0" 0 70 1 #"\0" 1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 0 1 #"\0" @@ -138,15 +127,14 @@ 0 0 7 29 1 #"\n" 0 0 12 3 19 #"(2 points smaller.)" 0 0 7 29 1 #"\n" -0 0 19 3 11 #"Decorative." -0 0 20 3 1 #" " -0 0 21 3 6 #"Roman." -0 0 20 3 1 #" " -0 0 22 3 7 #"Script." -0 0 20 3 1 #" " -0 0 23 3 6 #"Swiss." -0 0 20 3 1 #" " -0 0 24 3 6 #"Fixed." -0 0 25 3 53 #" (Last line changed to bottom-aligned for version 8.)" -0 0 20 29 1 #"\n" +0 0 13 3 11 #"Decorative." +0 0 7 3 1 #" " +0 0 14 3 6 #"Roman." +0 0 7 3 1 #" " +0 0 15 3 7 #"Script." +0 0 7 3 1 #" " +0 0 16 3 6 #"Swiss." +0 0 7 3 1 #" " +0 0 17 3 6 #"Fixed." +0 0 7 29 1 #"\n" 0 00000000000 diff --git a/collects/tests/mred/test-editor-admin.ss b/collects/tests/mred/test-editor-admin.ss new file mode 100644 index 00000000..d0732366 --- /dev/null +++ b/collects/tests/mred/test-editor-admin.ss @@ -0,0 +1,44 @@ +#lang scheme/base +(require scheme/class + scheme/gui/base) + +(provide test-editor-admin%) + +(define the-dc + (new (class* bitmap-dc% () + (super-new) + (define/override (get-text-extent s [font #f] [combine? #f] [offset 0]) + (values (* 10.0 (string-length s)) 10.0 1.0 1.0)) + (define/override (set-pen . p) (void)) + (define/override (get-pen . p) #f) + (define/override (set-brush . b) (void)) + (define/override (get-brush . b) #f) + (define/override (set-clipping-rect . b) (void)) + (define/override (get-clipping-region . b) #f) + (define/override (draw-text s x y combine? offset count) (void)) + (define/override (cache-font-metrics-key) 100)))) + + +(define test-editor-admin% + (class editor-admin% + (super-new) + + (define/override (get-dc [x #f] [y #f]) + (when x (set-box! x 1.0)) + (when y (set-box! y 1.0)) + the-dc) + + (define/private (do-get-view x y w h) + (when x (set-box! x 0.0)) + (when y (set-box! y 0.0)) + (when w (set-box! w 100.0)) + (when h (set-box! h 100.0))) + + (define/override (get-view x y w h [full? #f]) + (do-get-view x y w h)) + + (define/override (get-max-view x y w h [full? #f]) + (do-get-view x y w h)) + + (define/override (scroll-to x y w h refresh? bias) + (void)))) diff --git a/collects/tests/mred/wxme.ss b/collects/tests/mred/wxme.ss new file mode 100644 index 00000000..695bce17 --- /dev/null +++ b/collects/tests/mred/wxme.ss @@ -0,0 +1,1337 @@ +#lang scheme/base +(require scheme/class + (only-in scheme/gui/base + color% + font% + the-clipboard + clipboard-client% + key-event% + mouse-event%) + mred/private/wxme/snip + mred/private/wxme/mline + mred/private/wxme/style + mred/private/wxme/editor + mred/private/wxme/text + mred/private/wxme/pasteboard + "test-editor-admin.ss" + mred/private/wxme/stream + mred/private/wxme/keymap + mred/private/wxme/editor-snip) + +(define wrong-cnt 0) +(define test-cnt 0) + +(define (expect v v2) + (set! test-cnt (add1 test-cnt)) + (unless (equal? v v2) + (set! wrong-cnt (add1 wrong-cnt)) + (printf "EXPECTED ~s:\n" v2)) + v) + +(define (show v) + (print v) + (newline)) + +(define (expect* v v2) + (if (equal? v v2) + (set! test-cnt (add1 test-cnt)) + (show (expect v v2)))) + +(define (done) + (printf "\n~a tests\n" test-cnt) + (if (zero? wrong-cnt) + (printf "all passed\n") + (printf "~s FAILED\n" wrong-cnt))) + +;; ---------------------------------------- +;; String snips and lines + +(define s (make-object string-snip% "helko")) +(send s insert "cat " 4 2) +(send s get-text 0 (send s get-count)) +(send s set-flags (cons 'invisible (send s get-flags))) +(send s get-flags) +(send (send (get-the-snip-class-list) find "wxtext") get-classname) + +(define root-box (box mline-NIL)) +(define m20 (mline-insert #f root-box #t)) +(expect (mline-get-line m20) 0) +(define m00 (mline-insert m20 root-box #t)) +(expect (mline-get-line m00) 0) +(expect (mline-get-line m20) 1) +(expect (mline-get-position m00) 0) +(expect (mline-get-position m20) 0) +(mline-set-length m00 5) +(mline-set-length m20 20) +(expect (mline-get-position m00) 0) +(expect (mline-get-position m20) 5) + +(mline-check-consistent (unbox root-box)) + +;; ---------------------------------------- +;; Line inserts and deletes + +(define m5 (mline-insert m20 root-box #t)) +(mline-check-consistent (unbox root-box)) + +(mline-set-length m5 10) + +(expect (mline-get-position m00) 0) +(expect (mline-get-position m5) 5) +(expect (mline-get-position m20) 15) + +(mline-delete m5 root-box) +(expect (mline-get-position m20) 5) + +(set! m5 (mline-insert m20 root-box #t)) +(mline-set-length m5 8) + +(expect (mline-get-position m00) 0) +(expect (mline-get-position m5) 5) +(expect (mline-get-position m20) 13) + +(mline-delete m5 root-box) + +(mline-check-consistent (unbox root-box)) + +;; ---------------------------------------- +;; Line counts and positions + +(define m30 (mline-insert m20 root-box #f)) + +(expect (mline-get-line m00) 0) +(expect (mline-get-line m20) 1) +(expect (mline-get-line m30) 2) + +(expect (mline-get-position m00) 0) +(expect (mline-get-position m20) 5) +(expect (mline-get-position m30) 25) + +(mline-check-consistent (unbox root-box)) + +;; ---------------------------------------- +;; More line lines and positions + +(define m05 (mline-insert m00 root-box #f)) + +(mline-set-length m05 2) + +(expect (mline-get-line m00) 0) +(expect (mline-get-line m05) 1) +(expect (mline-get-line m20) 2) +(expect (mline-get-line m30) 3) + +(expect (mline-get-position m00) 0) +(expect (mline-get-position m05) 5) +(expect (mline-get-position m20) 7) +(expect (mline-get-position m30) 27) + +(mline-check-consistent (unbox root-box)) + +;; ---------------------------------------- +;; Line inserts and deletes, radomized + +(let ([added + (let loop ([l (list m00 m05 m20 m30)] + [n 100]) + (let ([m (mline-insert (list-ref l (random (length l))) + root-box + (zero? (random 2)))]) + (mline-check-consistent (unbox root-box)) + (if (zero? n) + (cons m l) + (loop (cons m l) (sub1 n)))))]) + (for-each (lambda (i) + (mline-delete i root-box) + (mline-check-consistent (unbox root-box))) + (cdr added)) + (show (expect (mline-next (car added)) #f)) + (show (expect (mline-prev (car added)) #f)) + (expect (unbox root-box) + (car added))) + +;; ---------------------------------------- +;; Styles, deltas, lists + +(define d1 (new style-delta%)) +(define d2 (new style-delta%)) +(expect (send d1 get-underlined-on) #f) +(expect (send d1 equal d2) #t) +(send d1 set-underlined-on #t) +(expect (send d1 equal d2) #f) +(send d2 collapse d1) +(expect (send d2 get-underlined-on) #t) +(send d2 set-underlined-on #f) +(send d1 copy d2) +(expect (send d1 get-underlined-on) #f) + +(define sl (new style-list%)) +(expect #t (eq? (send sl basic-style) (send sl basic-style))) +(define s-plain (send sl find-or-create-style (send sl basic-style) + (new style-delta%))) +(expect (send sl find-or-create-style (send sl basic-style) + (new style-delta%)) + s-plain) + +(send d1 set-underlined-on #t) +(define s-underlined (send sl find-or-create-style s-plain d1)) +(expect (send s-plain get-underlined) #f) +(expect (send s-underlined get-underlined) #t) + +(send d2 set-underlined-off #t) +(send d2 set-smoothing-on 'partly-smoothed) +(define s-nonunderlined1 (send sl find-or-create-style s-underlined d2)) +(expect (send s-nonunderlined1 get-underlined) #f) +(expect (send s-nonunderlined1 get-base-style) (send sl basic-style)) ; due to collpasing + +(define s-named-underlined (send sl new-named-style "underlined" s-underlined)) +(define s-nonunderlined (send sl find-or-create-style s-named-underlined d2)) +(expect (send s-nonunderlined get-underlined) #f) +(expect (send s-nonunderlined get-base-style) s-named-underlined) + +(send d1 set-family 'modern) +(define s-modern (send sl find-or-create-style s-plain d1)) +(expect (send s-modern get-underlined) #t) +(expect (send s-modern get-family) 'modern) +(expect (send s-plain get-family) 'default) + +(expect (send s-plain is-join?) #f) + +(define s-modern+nonunderlined (send sl find-or-create-join-style + s-modern + s-nonunderlined)) +(expect (send s-modern+nonunderlined get-underlined) #f) +(expect (send s-modern+nonunderlined get-smoothing) 'partly-smoothed) +(expect (send s-modern+nonunderlined get-family) 'modern) +(expect (send s-modern+nonunderlined is-join?) #t) + +(send d2 set-smoothing-on 'base) +(send s-nonunderlined set-delta d2) +(expect (send s-nonunderlined get-smoothing) 'default) +(expect (send s-modern+nonunderlined get-smoothing) 'default) + +(send d1 set-style-on 'italic) +(send s-modern set-delta d1) +(expect (send s-modern get-style) 'italic) +(expect (send s-modern+nonunderlined get-style) 'italic) + +(expect (send s-plain get-alignment) 'bottom) +(expect (send (send s-plain get-background) red) 255) +(expect (send s-plain get-base-style) (send sl basic-style)) +(expect (send s-modern+nonunderlined get-base-style) s-modern) +(expect (send s-plain get-face) #f) +(expect (send s-plain get-name) #f) +(expect (send s-plain get-shift-style) (send sl basic-style)) +(expect (send s-modern+nonunderlined get-shift-style) s-nonunderlined) +(expect (send s-plain get-size-in-pixels) #f) +(expect (send s-plain get-transparent-text-backing) #t) +(expect (send s-plain get-weight) 'normal) + +(expect (send s-nonunderlined get-base-style) s-named-underlined) +(send s-nonunderlined set-base-style s-modern+nonunderlined) ; would create cycle +(expect (send s-nonunderlined get-base-style) s-named-underlined) + +(send s-modern+nonunderlined set-base-style s-plain) +(expect (send s-modern+nonunderlined get-family) 'default) +(expect (send s-modern+nonunderlined get-style) 'normal) + +(send s-modern+nonunderlined set-shift-style s-modern+nonunderlined) ; would create cycle + +(define sl2 (new style-list%)) +(define s2-modern (send sl2 convert s-modern)) +(expect (send s2-modern get-family) 'modern) + +;; ---------------------------------------- +;; Lines, positions, paragraphs + +(define t (new text%)) +(expect (send t get-text) "") +(expect (send t last-position) 0) +(expect (send t get-start-position) 0) +(expect (send t get-end-position) 0) +(expect (send t position-line 0) 0) +(expect (send t position-paragraph 0) 0) + +(send t insert "hello") +(expect (send t get-text) "hello") +(expect (send t get-text 3) "lo") +(expect (send t get-text 2 4) "ll") +(expect (send t last-position) 5) +(expect (send t last-line) 0) +(expect (send t get-start-position) 5) +(expect (send t get-end-position) 5) +(expect (send t get-character 1) #\e) +(expect (send t position-line 1) 0) +(expect (send t position-paragraph 1) 0) + +(send t insert "!\nbye") +(expect (send t get-text) "hello!\nbye") +(expect (send t last-position) 10) +(expect (send t line-length 0) 7) +(expect (send t line-length 1) 3) +(expect (send t last-line) 1) +(expect (send t line-start-position 0) 0) +(expect (send t line-start-position 1) 7) +(expect (send t line-end-position 0) 6) +(expect (send t position-line 0) 0) +(expect (send t position-line 1) 0) +(expect (send t position-line 6) 0) +(expect (send t position-line 7 #t) 0) +(expect (send t position-line 7) 1) +(expect (send t position-line 10) 1) +(expect (send t position-paragraph 1) 0) +(expect (send t position-paragraph 6) 0) +(expect (send t position-paragraph 7 #t) 1) ; no eol ambiguity for paragraphs +(expect (send t position-paragraph 7) 1) +(expect (send t position-paragraph 8) 1) +(expect (send t get-start-position) 10) +(expect (send t get-end-position) 10) + +(send t set-position 7 8) +(expect (send t get-start-position) 7) +(expect (send t get-end-position) 8) +(expect + (let ([b (box 0)][e (box 0)]) + (list + (begin (send t get-position b) (unbox b)) + (begin (send t get-position #f e) (list (unbox b) (unbox e))))) + '(7 (7 8))) + +(send t insert ".\t," 2 4) +(expect (send t get-text) "he.\t,o!\nbye") +(expect (send t get-start-position) 8) +(expect (send t get-end-position) 9) + +(send t insert "\n3\n" 10) +(expect (send t get-text) "he.\t,o!\nby\n3\ne") +(expect (send t last-line) 3) +(expect (send t get-start-position) 8) +(expect (send t get-end-position) 9) +(send t set-position 100) +(expect (send t get-start-position) 14) +(expect (send t get-end-position) 14) +(send t set-position 14) +(expect (send t get-start-position) 14) +(expect (send t get-end-position) 14) + +(send t delete (send t last-position)) +(expect (send t get-text) "he.\t,o!\nby\n3\n") +(expect (send t last-line) 3) +(expect (send t get-start-position) 13) +(expect (send t get-end-position) 13) + +(send t insert "4" (send t last-position)) +(expect (send t get-text) "he.\t,o!\nby\n3\n4") +(expect (send t last-line) 3) +(send t delete 9 11) +(expect (send t last-line) 2) +(expect (send t get-text) "he.\t,o!\nb3\n4") + +(send t set-position 2 4) +(send t delete) +(expect (send t get-text) "he,o!\nb3\n4") +(expect (send t last-line) 2) +(expect (send t get-start-position) 2) +(expect (send t get-end-position) 2) +(expect (send t position-line 6) 1) +(expect (send t position-line 7) 1) +(expect (send t position-line 12) 2) + +(send t insert (make-object string-snip% "?") 2) +(expect (send t get-text) "he?,o!\nb3\n4") + +(expect (send t find-string "o") 4) +(expect (send t find-string "q") #f) +(expect (send t find-string "\n") 6) +(expect (send t find-string "\n" 'forward) 6) +(expect (send t find-string "\n" 'forward 7) 9) +(expect (send t find-string "\n" 'backward 7) 7) +(expect (send t find-string "\n" 'backward 9) 7) +(expect (send t find-string-all "\n") '(6 9)) +(expect (send t find-string-all "\n" 'forward 3 7) '(6)) +(expect (send t find-string-all "\n" 'backward 8 4) '(7)) +(expect (send t find-string-all "\n" 'backward 8 4 #f) '(6)) +(expect (send t find-string "\n4") 9) +(expect (send t find-string "O") #f) +(expect (send t find-string "O" 'forward 0 20 #t #f) 4) + +(expect (send t find-next-non-string-snip #f) #f) + +;; ---------------------------------------- + +;; Insert very long strings to test max-string-length handling +(send t delete 0 (send t last-position)) +(send t insert (make-string 256 #\a)) +(send t insert (make-string 256 #\a)) +(send t insert (make-string 256 #\a)) +(send t insert (make-string 256 #\a)) +(send t insert (make-string 1024 #\a)) +(expect (send t last-position) 2048) + +;; ---------------------------------------- +;; Moving and word boundaries + +(send t delete 0 (send t last-position)) +(send t insert "do you like\ngreen eggs and ham?") +(expect (send t position-paragraph 0) 0) +(expect (send t position-paragraph 12) 1) +(expect (send t paragraph-start-position 1) 12) +(expect (send t paragraph-start-position 2) 31) +(expect (send t find-newline 'forward 0) 12) +(expect (send t find-newline 'forward 12) 31) +(expect (send t get-text) "do you like\ngreen eggs and ham?") +(send t set-position 0) +(send t move-position 'right #f 'word) +(expect (send t get-start-position) 2) +(send t move-position 'right #f 'word) +(expect (send t get-start-position) 6) +(send t move-position 'left #f 'word) +(expect (send t get-start-position) 3) +(send t move-position 'right #f 'word) +(expect (send t get-start-position) 6) +(send t move-position 'right #f 'word) +(expect (send t get-start-position) 11) +(send t move-position 'right #f 'simple) +(send t move-position 'right #f 'word) +(expect (send t get-start-position) 17) +(send t set-position 11) +(send t move-position 'right #f 'word) +(expect (send t get-start-position) 17) + +(define (check-positions graphics?) + (define snips+counts + (let loop ([snip (send t find-first-snip)]) + (if snip + (cons (cons snip (send snip get-count)) + (loop (send snip next))) + null))) + + (let ([x (box 0.0)] + [y (box 0.0)]) + (let loop ([s+c snips+counts] + [pos 0]) + (unless (null? s+c) + (let ([p (send t get-snip-position (caar s+c))]) + (expect* p pos) + (let ([p2 (box 0)]) + (when graphics? + (if (send t get-snip-position-and-location (caar s+c) p2 x y) + (expect* (unbox p2) pos) + (show (expect #f #t)))) + (loop (cdr s+c) (+ pos (cdar s+c)))))))) + + (for-each + (lambda (before) + (let loop ([pos 0][s+c snips+counts][snip-pos 0]) + (if (null? s+c) + (show (expect pos (add1 (send t last-position)))) + (let* ([s-pos (box 0)] + [s (send t find-snip pos before s-pos)]) + (let ([es (if (and (= pos 0) (eq? before 'before-or-none)) + #f + (caar s+c))]) + (expect* s es) + (expect* (unbox s-pos) snip-pos) + (let ([next? (= pos (+ snip-pos (cdar s+c)))]) + (loop (add1 pos) + (if next? + (cdr s+c) + s+c) + (if next? + (+ snip-pos (cdar s+c)) + snip-pos)))))))) + '(before before-or-none)) + + (for-each + (lambda (after) + (let loop ([pos 0][s+c snips+counts][snip-pos 0][prev #f][prev-snip-pos 0]) + (let* ([s-pos (box 0)] + [s (send t find-snip pos after s-pos)] + [end? (null? s+c)] + [es (if end? + (if (eq? after 'after-or-none) + #f + (car prev)) + (caar s+c))] + [ep (if end? (if es prev-snip-pos 0) snip-pos)]) + (expect* s es) + (expect* (unbox s-pos) ep) + (if end? + (show (expect pos (send t last-position))) + (let ([next? (= (add1 pos) (+ snip-pos (cdar s+c)))]) + (loop (add1 pos) + (if next? + (cdr s+c) + s+c) + (if next? + (+ snip-pos (cdar s+c)) + snip-pos) + (car s+c) + snip-pos)))))) + '(after after-or-none))) + +(check-positions #f) + +;; ---------------------------------------- +;; Line flow + +;; Every character is 10.0 high, 10.0 wide, 1.0 descent, 1.0 top space +(send t set-admin (new test-editor-admin%)) + +(expect (let ([x (box 0.0)] [y (box 0.0)]) + (list (begin + (send t position-location 1 x y) + (list (unbox x) (unbox y))) + (begin + (send t position-location 1 x y #f) + (list (unbox x) (unbox y))))) + '((10.0 0.0) (10.0 10.0))) +(expect (let ([x (box 0.0)] [y (box 0.0)]) + (list (begin + (send t position-location 14 x y) + (list (unbox x) (unbox y))) + (begin + (send t position-location 14 x y #f) + (list (unbox x) (unbox y))))) + '((20.0 11.0) (20.0 21.0))) +(expect (let ([w (box 0.0)] [h (box 0.0)]) + (send t get-extent w h) + (list (unbox w) (unbox h))) + '(192.0 22.0)) + +(expect (send t find-position 0.0 0.0) 0) +(expect (send t find-position 0.0 3.0) 0) +(expect (send t find-position 10.0 0.0) 1) +(expect (send t find-position 13.0 0.0) 1) +(expect (send t find-position 0.0 12.0) 12) +(expect (send t find-position 13.0 12.0) 13) +(expect (send t find-position 13.0 23.0) 31) +(expect (send t find-position 0.0 230.0) 31) +(expect (send t find-position 300.0 2.0) 11) +(expect (send t find-position -1.0 12.0) 12) +(expect (send t find-position 109.0 2.0) 10) +(expect (send t find-position 110.0 2.0) 11) +(expect (let ([b (box #f)]) + (send t find-position 1.0 12.0 #f b) + (unbox b)) + #t) +(expect (let ([b (box #f)] + [e (box 0.0)]) + (send t find-position -1.0 12.0 #f b e) + (list (unbox b) (unbox e))) + '(#f 100.0)) +(expect (let ([b (box #f)] + [e (box 0.0)]) + (list (send t find-position 109.0 2.0 #f b e) + (unbox b) + (unbox e))) + '(10 #t 1.0)) +(expect (let ([b (box #f)] + [e (box 0.0)]) + (list (send t find-position 102.0 2.0 #f b e) + (unbox b) + (unbox e))) + '(10 #t -2.0)) +(expect (let ([b (box #f)] + [e (box 0.0)]) + (list (send t find-position 110.0 2.0 #f b e) + (unbox b) + (unbox e))) + '(11 #f 100.0)) +(expect (send t find-position-in-line 0 14.0) 1) +(expect (send t find-position-in-line 1 14.0) 13) + +(send t set-position 1 1) +(send t move-position 'down #f 'line) +(expect (send t get-start-position) 13) +(send t move-position 'right #f 'simple) +(send t move-position 'up #f 'line) +(expect (send t get-start-position) 2) + +(check-positions #t) + +(send t set-max-width 71.0) + +(define (check-ge&h-flow) + (expect* (send t last-line) 6) + (expect* (send t line-start-position 0) 0) + (expect* (send t line-start-position 1) 3) + (expect* (send t line-start-position 2) 7) + (expect* (send t line-start-position 3) 12) + (expect* (send t line-start-position 4) 18) + (expect* (send t line-start-position 5) 23) + (expect* (send t line-start-position 6) 27) + (expect* (send t last-paragraph) 1) + (expect* (send t paragraph-start-position 0) 0) + (expect* (send t paragraph-end-position 0) 11) + (expect* (send t paragraph-start-position 1) 12) + (expect* (send t paragraph-end-position 1) 31) + (expect* (send t paragraph-start-position 2) 31) + (void)) +(check-ge&h-flow) + +(check-positions #t) + +(send t set-max-width 200.0) +(expect (send t last-line) 1) + +(send t set-max-width 71.0) +(check-ge&h-flow) + +(send t insert "Sir: " 0) +(expect (send t last-line) 7) +(expect (send t line-start-position 7) 32) +(send t delete 0 5) +(check-ge&h-flow) + +(define (check-line-starts) + (let ([lens (let loop ([snip (send t find-first-snip)][len 0]) + (if snip + (let ([len (+ len (send snip get-count))]) + (let ([s (send snip get-text 0 (send snip get-count))]) + (when (regexp-match? #rx"\n" s) + (unless (and (memq 'hard-newline (send snip get-flags)) + (string=? s "\n")) + (error "embedded newline!"))) + (if (or (memq 'newline (send snip get-flags)) + (memq 'hard-newline (send snip get-flags))) + (cons len (loop (send snip next) 0)) + (loop (send snip next) len)))) + (list len)))]) + (for/fold ([pos 0]) ([i (in-range (add1 (send t last-line)))] + [len (in-list lens)]) + (expect* (send t line-start-position i #f) pos) + (expect* (send t line-end-position i #f) (+ pos len)) + (+ pos len)))) + +(for-each + (lambda (str) + ;; (printf ">> ~a <<\n" str) + (for ([i (in-range (add1 (send t last-position)))]) + ;; (printf "~a\n" i) + (check-line-starts) + (send t insert str i) + (check-line-starts) + (send t last-line) + (send t delete i (+ i (string-length str))) + (check-line-starts) + (check-ge&h-flow))) + '(" a" "a " "qvzxw " " qvxzw" "qqq qqqq" "a\nb")) + +;; ---------------------------------------- +;; Undo + +(send t set-modified #f) +(send t set-max-undo-history 100) +(send t delete 0 3) +(expect (send t get-text) "you like\ngreen eggs and ham?") +(expect (send t modified?) #t) +(send t undo) +(expect (send t get-text) "do you like\ngreen eggs and ham?") +(expect (send t modified?) #f) +(send t redo) +(expect (send t modified?) #t) +(expect (send t get-text) "you like\ngreen eggs and ham?") +(send t set-position 0) +(send t insert #\d) +(send t insert #\o) +(send t insert #\space) +(expect (send t get-text) "do you like\ngreen eggs and ham?") +(send t undo) +(expect (send t get-text) "you like\ngreen eggs and ham?") +(send t redo) +(expect (send t get-text) "do you like\ngreen eggs and ham?") + +(send t begin-edit-sequence) +(send t delete 0 3) +(send t delete (- (send t last-position) 4) (send t last-position)) +(send t end-edit-sequence) +(expect (send t get-text) "you like\ngreen eggs and ") +(send t delete 0 4) +(expect (send t get-text) "like\ngreen eggs and ") +(send t undo) +(send t undo) +(expect (send t get-text) "do you like\ngreen eggs and ham?") + +;; ---------------------------------------- +;; Stream out base + +(define fbo (make-object editor-stream-out-bytes-base%)) +(expect (send fbo tell) 0) +(send fbo write-bytes #"abc") +(expect (send fbo tell) 3) +(expect (send fbo get-bytes) #"abc") +(send fbo seek 2) +(send fbo write-bytes #"012345" 1 4) +(expect (send fbo tell) 5) +(expect (send fbo get-bytes) #"ab123") +(expect (send fbo bad?) #f) +(send fbo write '(#\o #\l #\d)) +(expect (send fbo get-bytes) #"ab123old") + +;; ---------------------------------------- +;; Stream in base + +(define fbi (make-object editor-stream-in-bytes-base% #"ab123old")) +(define ibuf (make-bytes 3)) +(expect (send fbi tell) 0) +(send fbi read-bytes ibuf) +(expect ibuf #"ab1") +(expect (send fbi tell) 3) +(send fbi seek 2) +(send fbi read-bytes ibuf 1 2) +(expect ibuf #"a11") +(send fbi skip 2) +(send fbi read-bytes ibuf 0 2) +(expect ibuf #"ol1") +(expect (send fbi bad?) #f) + +;; ---------------------------------------- +;; Stream writing + +(define fbo2 (make-object editor-stream-out-bytes-base%)) +(define fo (make-object editor-stream-out% fbo2)) + +(expect (send fo tell) 0) +(void (send fo put 2)) +(expect (send fbo2 get-bytes) #"\n2") +(void (send fo put 2.0)) +(expect (send fbo2 get-bytes) #"\n2 2.0") +(expect (send fo tell) 2) +(send fo jump-to 0) +(send fo put 3) +(send fo jump-to 2) +(expect (send fbo2 get-bytes) #"\n3 2.0") +(void (send fo put #"hi")) +(expect (send fbo2 get-bytes) #"\n3 2.0 3 #\"hi\\0\"") +(void (send fo put 3 #"bye?")) +(expect (send fbo2 get-bytes) #"\n3 2.0 3 #\"hi\\0\"\n3 #\"bye\"") +(void (send fo put 80 #"0123456789abcdefghij0123456789ABCDEFGHIJ0123456789abcdefghij0123456\"89ABCDEFGHIJ")) +(expect (send fbo2 get-bytes) + (bytes-append + #"\n3 2.0 3 #\"hi\\0\"\n3 #\"bye\"\n80\n" + #"(\n" + #" #\"0123456789abcdefghij0123456789ABCDEFGHIJ0123456789abcdefghij0123456\"\n" + #" #\"\\\"89ABCDEFGHIJ\"\n" + #")")) + +(define fbo3 (make-object editor-stream-out-bytes-base%)) +(define fo3 (make-object editor-stream-out% fbo3)) +(void (send fo3 put 2)) +(expect (send fo3 tell) 1) +(void (send fo3 put-fixed 5)) +(expect (send fo3 tell) 2) +(void (send fo3 put-fixed -8)) +(void (send fo3 put 2 #"hi")) +(expect (send fbo3 get-bytes) #"\n2 5 -8 2 #\"hi\"") +(send fo3 jump-to 1) +(void (send fo3 put-fixed -4)) +(send fo3 jump-to 2) +(void (send fo3 put-fixed 7)) +(expect (send fbo3 get-bytes) #"\n2 -4 7 2 #\"hi\"") + +;; ---------------------------------------- +;; Stream reading + +(define fbi2 (make-object editor-stream-in-bytes-base% (bytes-append #"1 ; comment \n 2 " + #"#| | x # #| |# q |# 4.0" + #" 2 #\"hi\"" + #" 3 #\"hi\\\"\"" + #" 23 ( #\"0123456789ABCDEFappl\" #\"e!\\0\" ) 88"))) +(define fi2 (make-object editor-stream-in% fbi2)) + +(expect (send fi2 ok?) #t) +(expect (send fi2 tell) 0) +(expect (let ([b (box 0)]) (send fi2 get b) (unbox b)) 1) +(expect (send fi2 ok?) #t) +(expect (send fi2 tell) 1) +(expect (let ([b (box 0)]) (send fi2 get b) (unbox b)) 2) +(expect (send fi2 ok?) #t) +(expect (let ([b (box 0.0)]) (send fi2 get b) (unbox b)) 4.0) +(expect (send fi2 ok?) #t) +(expect (send fi2 tell) 3) +(expect (send fi2 get-unterminated-bytes) #"hi") +(expect (send fi2 ok?) #t) +(expect (send fi2 tell) 5) +(expect (send fi2 get-unterminated-bytes) #"hi\"") +(expect (send fi2 ok?) #t) +(expect (send fi2 get-bytes) #"0123456789ABCDEFapple!") +(expect (send fi2 ok?) #t) +(expect (send fi2 tell) 9) + +(send fi2 jump-to 3) +(expect (send fi2 tell) 3) +(expect (send fi2 get-unterminated-bytes) #"hi") +(send fi2 skip 4) +(expect (let ([b (box 0)]) (send fi2 get b) (unbox b)) 88) +(expect (send fi2 ok?) #t) +(expect (send fi2 tell) 10) + +(send fi2 jump-to 3) +(send fi2 set-boundary 5) +(expect (send fi2 get-unterminated-bytes) #"hi") +(send fi2 jump-to 3) +(expect (send fi2 ok?) #t) +(send fi2 set-boundary 4) +(expect (send fi2 get-unterminated-bytes) #"") +(expect (send fi2 ok?) #f) + +;; ---------------------------------------- +;; Save & load + +(send t delete 0 (send t last-position)) +(send t clear-undos) +(send t insert "one\ntwo\n") +(send t set-position 0 3) +(send t copy #f 0) +(send t set-position 8) +(send t paste 0) ;; probably uses the snip% `copy' method +(expect (send t get-text) "one\ntwo\none") +(define (move-to-serialized-clipboard) + (let ([data (send the-clipboard get-clipboard-data "WXME" 0)]) + (send the-clipboard set-clipboard-client + (new (class clipboard-client% + (inherit add-type) + (super-new) + (add-type "WXME") + (define/override (get-data format) data))) + 0))) +(move-to-serialized-clipboard) +(send t paste 0) ;; uses above clipboard +(expect (send t get-text) "one\ntwo\noneone") +(send the-clipboard set-clipboard-string "\u3BB" 0) +(send t paste 0) +(expect (send t get-text) "one\ntwo\noneone\u3BB") + +(send t set-position 3 4) +(send t copy #f 0) +(send t set-position 4 7) +(send t copy #t 0) +(send t set-position (send t last-position)) +(send t paste 0) +(expect (send t get-text) "one\ntwo\noneone\u3BB\ntwo") +(send t paste-next) +(expect (send t get-text) "one\ntwo\noneone\u3BBone") + +(send t cut #f 0 0 4) +(expect (send t get-text) "two\noneone\u3BBone") + +(define-values (in7 out7) (make-pipe)) +(expect (send t save-port out7 'text) #t) +(close-output-port out7) +(expect (read-string 100 in7) "two\noneone\u3BBone") + +(define out8 (open-output-bytes)) +(expect (send t save-port out8 'standard) #t) +(define in8 (open-input-bytes (get-output-bytes out8))) +(expect (peek-bytes 31 0 in8) #"#reader(lib\"read.ss\"\"wxme\")WXME") +(send t erase) +(expect (send t get-text) "") +(expect (send t insert-port in8) 'standard) +(expect (send t get-text) "two\noneone\u3BBone") + +;; ---------------------------------------- +;; Styles on text + +(define (check-color pos r g b w) + (let* ([s (send (send t find-snip pos 'after) get-style)] + [c (send s get-foreground)] + [f (send s get-font)]) + (expect* (send c red) r) + (expect* (send c green) g) + (expect* (send c blue) b) + (expect* (send f get-weight) w))) + +(send t erase) +(send t insert "red\nblue") +(check-color 0 0 0 0 'normal) +(let ([d (send (new style-delta%) set-delta-foreground (make-object color% 255 0 0))]) + (send d set-weight-on 'bold) + (send t change-style d 0 3)) +(send t change-style + (send (new style-delta%) set-delta-foreground (make-object color% 0 0 255)) + 4 8) +(check-color 0 255 0 0 'bold) +(check-color 4 0 0 255 'normal) + +(define out9 (open-output-bytes)) +(expect (send t save-port out9 'standard) #t) +(define in9 (open-input-bytes (get-output-bytes out9))) +(send t erase) +(expect (send t insert-port in9) 'standard) +(expect (send t get-text) "red\nblue") +(check-color 0 255 0 0 'bold) +(check-color 4 0 0 255 'normal) + +(define (check-random-delta d) + (expect* (send d get-alignment-on) 'top) + (expect* (send d get-alignment-off) 'base) + (expect* (send (send d get-background-add) get-r) 25) + (expect* (send (send d get-background-add) get-g) 25) + (expect* (send (send d get-background-add) get-b) 25) + (expect* (send (send d get-background-mult) get-r) 0.5) + (expect* (send (send d get-background-mult) get-g) 0.5) + (expect* (send (send d get-background-mult) get-b) 0.5) + (expect* (send (send d get-foreground-add) get-r) 50) + (expect* (send (send d get-foreground-add) get-g) 50) + (expect* (send (send d get-foreground-add) get-b) 50) + (expect* (send (send d get-foreground-mult) get-r) 0.6) + (expect* (send (send d get-foreground-mult) get-g) 0.6) + (expect* (send (send d get-foreground-mult) get-b) 0.6) + (expect* (send d get-face) "Purty") + (expect* (send d get-family) 'decorative) + (expect* (send d get-size-in-pixels-on) #t) + (expect* (send d get-size-in-pixels-off) #f) + (expect* (send d get-smoothing-off) 'smoothed) + (expect* (send d get-smoothing-on) 'base) + (expect* (send d get-style-on) 'italic) + (expect* (send d get-style-off) 'base) + (expect* (send d get-transparent-text-backing-on) #t) + (expect* (send d get-transparent-text-backing-off) #f) + (expect* (send d get-underlined-off) #t) + (expect* (send d get-underlined-on) #f) + (expect* (send d get-weight-on) 'light) + (expect* (send d get-weight-off) 'base)) + +(let ([d (new style-delta%)]) + (send d set-alignment-on 'top) + (send (send d get-background-add) set 25 25 25) + (send (send d get-background-mult) set 0.5 0.5 0.5) + (send (send d get-foreground-add) set 50 50 50) + (send (send d get-foreground-mult) set 0.6 0.6 0.6) + (send d set-delta-face "Purty" 'decorative) + (send d set-size-in-pixels-on #t) + (send d set-smoothing-off 'smoothed) + (send d set-style-on 'italic) + (send d set-transparent-text-backing-on #t) + (send d set-underlined-off #t) + (send d set-weight-on 'light) + + (check-random-delta d) + + (let* ([sl (send t get-style-list)] + [s (send sl find-or-create-style (send sl basic-style) d)]) + (send t change-style s 0 1))) + +(define out10 (open-output-bytes)) +(expect (send t save-port out10 'standard) #t) +(define in10 (open-input-bytes (get-output-bytes out10))) +(send t erase) +(expect (send t insert-port in10 'guess #t) 'standard) +(expect (send t get-text) "red\nblue") +(check-color 0 50 50 50 'light) +(check-color 1 255 0 0 'bold) +(check-color 4 0 0 255 'normal) + +(let ([d (new style-delta%)]) + (send (send (send t find-first-snip) get-style) get-delta d) + (check-random-delta d)) + +;; ---------------------------------------- +;; Keymaps + +(define km (new keymap%)) +(define hit #f) +(define kevt (new key-event%)) + +(send km add-function "letter-a" (lambda (obj evt) (set! hit #\a))) +(send km add-function "letter-m" (lambda (obj evt) (set! hit #\m))) +(send km add-function "letter-n" (lambda (obj evt) (set! hit #\n))) +(send km add-function "letter-up" (lambda (obj evt) (set! hit 'up))) +(send km add-function "letter-UP" (lambda (obj evt) (set! hit 'UP))) +(send km add-function "letter-down" (lambda (obj evt) (set! hit 'down))) +(send km add-function "letter-DOWN" (lambda (obj evt) (set! hit 'DOWN))) + +(send km map-function "a" "letter-a") +(send kevt set-key-code #\x) +(expect (send km handle-key-event 'obj kevt) #f) +(send kevt set-key-code #\a) +(expect (send km handle-key-event 'obj kevt) #t) +(expect hit #\a) + +(send km map-function "up" "letter-up") +(send kevt set-key-code 'up) +(expect (send km handle-key-event 'obj kevt) #t) +(expect hit 'up) +(set! hit #f) +(send kevt set-shift-down #t) +(expect (send km handle-key-event 'obj kevt) #t) +(expect hit 'up) + +(send km map-function "s:up" "letter-UP") +(expect (send km handle-key-event 'obj kevt) #t) +(expect hit 'UP) + +(send km map-function ":down" "letter-down") +(send kevt set-key-code 'down) +(send kevt set-shift-down #f) +(expect (send km handle-key-event 'obj kevt) #t) +(expect hit 'down) +(set! hit #f) +(send kevt set-shift-down #t) +(expect (send km handle-key-event 'obj kevt) #f) + +(send km map-function "s:down" "letter-DOWN") +(expect (send km handle-key-event 'obj kevt) #t) +(expect hit 'DOWN) + +(expect (with-handlers ([values + (lambda (exn) + (and (regexp-match? #rx"mapped as a non-prefix key" (exn-message exn)) + 'bad-remap))]) + (send km map-function "s:down;z" "oops")) + 'bad-remap) + +;; Check sequence +(set! hit #f) +(send km map-function "d;O" "letter-down") +(send kevt set-shift-down #f) +(send kevt set-key-code #\d) +(expect (send km handle-key-event 'obj kevt) #t) +(expect hit #f) +(send kevt set-key-code #\o) +(expect (send km handle-key-event 'obj kevt) #f) +(send kevt set-shift-down #f) +(send kevt set-key-code #\d) +(expect (send km handle-key-event 'obj kevt) #t) +(send kevt set-key-code #\O) +(send kevt set-shift-down #t) +(expect (send km handle-key-event 'obj kevt) #t) +(expect hit 'down) + +;; Interrupt sequence +(set! hit #f) +(send kevt set-shift-down #f) +(send kevt set-key-code #\d) +(expect (send km handle-key-event 'obj kevt) #t) +(expect hit #f) +(send km break-sequence) +(send kevt set-key-code #\O) +(send kevt set-shift-down #t) +(expect (send km handle-key-event 'obj kevt) #f) +(expect hit #f) + +;; Check success with alternate, then override with more specific non-alternate +(send kevt set-key-code #\m) +(send kevt set-other-shift-key-code #\n) +(send kevt set-shift-down #f) +(send km map-function "?:n" "letter-n") +(expect (send km handle-key-event 'obj kevt) #t) +(expect hit #\n) +(send km map-function "?:m" "letter-m") +(expect (send km handle-key-event 'obj kevt) #t) +(expect hit #\m) + +(define km2 (new keymap%)) +(send km chain-to-keymap km2 #t) + +;; Chained keymap more specific overrides less specific +(send km2 add-function "letter-n2" (lambda (obj evt) (set! hit 'n2))) +(send km2 map-function "n" "letter-n2") +(expect (send km handle-key-event 'obj kevt) #t) +(expect hit #\m) +(send kevt set-key-code #\n) +(send kevt set-other-shift-key-code #\p) +(expect (send km handle-key-event 'obj kevt) #t) +(expect hit 'n2) + +;; Check sequence in chained keymap +(send km2 add-function "letter-t" (lambda (obj evt) (set! hit #\t))) +(send km2 map-function "c:x;t" "letter-t") +(send kevt set-key-code #\x) +(send kevt set-control-down #t) +(send kevt set-other-shift-key-code #f) +(set! hit #f) +(expect (send km handle-key-event 'obj kevt) #t) +(expect hit #f) +(send kevt set-control-down #f) +(send kevt set-key-code #\t) +(expect (send km handle-key-event 'obj kevt) #t) +(expect hit #\t) + +;; Chained keymap non-prefixed overrides prefixed +(send km2 add-function "letter-d" (lambda (obj evt) (set! hit #\d))) +(send km2 map-function "d" "letter-d") +(send kevt set-key-code #\d) +(expect (send km handle-key-event 'obj kevt) #t) +(expect hit #\d) +(send kevt set-key-code #\O) +(send kevt set-shift-down #t) +(expect (send km handle-key-event 'obj kevt) #f) +(expect hit #\d) + +;; Remove chained keymap +(send km remove-chained-keymap km2) +(send kevt set-key-code #\d) +(send kevt set-shift-down #f) +(set! hit #f) +(expect (send km handle-key-event 'obj kevt) #t) +(expect hit #f) +(send kevt set-key-code #\O) +(send kevt set-shift-down #t) +(expect (send km handle-key-event 'obj kevt) #t) +(expect hit 'down) + +;; Key grab +(send kevt set-key-code #\m) +(send kevt set-shift-down #f) +(send km set-grab-key-function (lambda (str km-in ed evt) + (expect* km-in km) + (expect* evt kevt) + (set! hit (list str ed)) + #t)) +(expect (send km handle-key-event 'obj kevt) #t) +(expect hit '("letter-m" obj)) +(send kevt set-key-code #\p) +(expect (send km handle-key-event 'obj kevt) #t) +(expect hit '(#f obj)) +(send km set-grab-key-function (lambda (str km-in ed evt) + (expect* str "letter-m") + (expect* ed 'obj2) + (set! hit 'nope) + #f)) +(send kevt set-key-code #\m) +(expect (send km handle-key-event 'obj2 kevt) #t) +(expect hit #\m) +(send km set-grab-key-function (lambda (str km-in ed evt) + (expect* str #f) + (expect* ed 'obj3) + (set! hit 'nope) + #f)) +(send kevt set-key-code #\p) +(expect (send km handle-key-event 'obj3 kevt) #f) +(expect hit 'nope) + +;; Mouse events +(define mevt/l (new mouse-event% [event-type 'left-down])) +(send mevt/l set-left-down #t) +(send km add-function "mouse-right" (lambda (obj evt) (set! hit 'right))) +(send km add-function "mouse-left" (lambda (obj evt) (set! hit 'left))) +(send km add-function "mouse-left2" (lambda (obj evt) (set! hit 'left2))) + +(expect (send km handle-mouse-event 'obj mevt/l) #f) +(send mevt/l set-time-stamp 501) ;; FIXME: depends on double-click time +(send km map-function "leftbutton" "mouse-left") +(send km map-function "leftbuttondouble" "mouse-left2") +(expect (send km handle-mouse-event 'obj mevt/l) #t) +(expect hit 'left) +(expect (send km handle-mouse-event 'obj mevt/l) #t) +(expect hit 'left2) +(expect (send km handle-mouse-event 'obj mevt/l) #t) +(expect hit 'left) +(send mevt/l set-time-stamp 10100) +(expect (send km handle-mouse-event 'obj mevt/l) #t) +(expect hit 'left) + +(set! hit #f) +(send km map-function "rightbuttonseq" "mouse-right") +(define mevt/r (new mouse-event% [event-type 'right-down])) +(send mevt/r set-right-down #t) +(define mevt/r/up (new mouse-event% [event-type 'right-up])) +(expect (send km handle-mouse-event 'obj mevt/r) #t) +(expect hit 'right) +(set! hit #f) +(expect (send km handle-mouse-event 'obj mevt/r/up) #t) +(expect hit 'right) + +(send km set-grab-mouse-function (lambda (str km-in ed evt) + (set! hit 'm) + #t)) +(define mevt/m (new mouse-event% [event-type 'middle-down])) +(send mevt/m set-middle-down #t) +(expect (send km handle-mouse-event 'obj mevt/m) #t) +(expect hit 'm) +(send km remove-grab-mouse-function) +(expect (send km handle-mouse-event 'obj mevt/m) #f) + +;; ---------------------------------------- +;; editor snips, content + +(define oe (new text%)) +(define ie (new text%)) +(define es (new editor-snip% [editor ie])) +(send ie insert "Hello") +(send oe insert es) + +(expect (send oe get-text 0 'eof #f) ".") +(expect (send oe get-flattened-text) "Hello") + +(send es show-border #t) +(expect (send es border-visible?) #t) +(send es set-margin 1 2 3 4) +(define (check-border es) + (let ([l (box 0)][t (box 0)][r (box 0)][b (box 0)]) + (send es get-margin l t r b) + (expect (list (unbox l) (unbox t) (unbox r) (unbox b)) + (list 1 2 3 4)))) +(check-border es) + +(send oe set-position 0 1) +(send oe copy #f 0) +(send oe set-position 1) +(send oe paste 0) ;; probably uses the snip% `copy' method +(expect (send oe last-position) 2) +(define es2 (send oe find-snip 1 'after-or-none)) +(check-border es2) +(move-to-serialized-clipboard) +(send oe paste 0) ;; uses above clipboard +(define es3 (send oe find-snip 2 'after-or-none)) +(check-border es3) +(expect (send es3 border-visible?) #t) +(expect (send es3 get-align-top-line) #f) + +(send (send es2 get-editor) insert "zzz" 2 2) +(expect (send oe get-text 0 'eof #f) "...") +(expect (send oe get-flattened-text) "HelloHezzzlloHello") + +(send oe insert "a\n" 0) +(send oe insert "\nb" (send oe last-position)) +(expect (send oe get-flattened-text) "a\nHelloHezzzlloHello\nb") + +;; ---------------------------------------- +;; editor snips, locations + +(send oe set-admin (new test-editor-admin%)) +(expect (let ([w (box 0.0)] [h (box 0.0)]) + (send oe get-extent w h) + (list (unbox w) (unbox h))) + '(197.0 40.0)) +(expect (let ([x (box 0.0)] [y (box 0.0)]) + (list (begin + (send oe position-location 0 x y) + (list (unbox x) (unbox y))) + (begin + (send oe position-location 1 x y #f) + (list (unbox x) (unbox y))))) + '((0.0 0.0) (10.0 10.0))) +(expect (let ([x (box 0.0)] [y (box 0.0)]) + (list (begin + (send oe position-location 2 x y) + (list (unbox x) (unbox y))) + (begin + (send oe position-location 3 x y #f) + (list (unbox x) (unbox y))))) + '((0.0 11.0) (55.0 28.0))) + +(send (send es2 get-editor) insert "\nmore" 100) +(expect (let ([w (box 0.0)] [h (box 0.0)]) + (send oe get-extent w h) + (list (unbox w) (unbox h))) + '(197.0 51.0)) + +;; ---------------------------------------- +;; Pasteboard + +(define pb (new pasteboard%)) +(expect (send pb find-first-snip) #f) +(expect (send pb find-snip 10.0 10.0) #f) +(expect (let ([w (box 0.0)] [h (box 0.0)]) + (send pb get-extent w h) + (list (unbox w) (unbox h))) + '(0.0 0.0)) + +(define ss1 (new string-snip%)) +(send ss1 insert "one" 3) +(send pb insert ss1 12.0 17.5) +(expect (send pb find-first-snip) ss1) +(expect (send pb get-flattened-text) "one") + +(define ss2 (new string-snip%)) +(send ss2 insert "two!" 4) +(send pb insert ss2 ss1 32.0 7.5) +(expect (send pb find-first-snip) ss2) +(expect (send pb get-flattened-text) "two!one") +(send pb lower ss2) +(expect (send pb get-flattened-text) "onetwo!") +(send pb raise ss2) +(expect (send pb get-flattened-text) "two!one") + +(send pb set-admin (new test-editor-admin%)) +(expect (let ([w (box 0.0)] [h (box 0.0)]) + (send pb get-extent w h) + (list (unbox w) (unbox h))) + '(74.0 29.5)) +(expect (let ([x (box 0.0)] [y (box 0.0)]) + (send pb get-snip-location ss2 x y #t) + (list (unbox x) (unbox y))) + '(72.0 17.5)) +(send ss2 insert "more" 4 3) +(expect (let ([x (box 0.0)] [y (box 0.0)]) + (send pb get-snip-location ss2 x y #t) + (list (unbox x) (unbox y))) + '(112.0 17.5)) +(expect (send pb get-flattened-text) "twomore!one") + +(send pb no-selected) +(expect (send pb find-next-selected-snip #f) #f) +(send pb add-selected ss1) +(expect (send pb find-next-selected-snip #f) ss1) +(expect (send pb find-next-selected-snip ss1) #f) +(send pb no-selected) +(send pb add-selected 0.0 0.0 10.0 10.0) +(expect (send pb find-next-selected-snip #f) #f) +(send pb add-selected 10.0 10.0 20.0 20.0) +(expect (send pb find-next-selected-snip #f) ss1) +(expect (send pb find-next-selected-snip ss1) #f) +(send pb add-selected 10.0 10.0 40.0 40.0) +(expect (send pb find-next-selected-snip #f) ss2) +(expect (send pb find-next-selected-snip ss2) ss1) + +(send pb set-max-undo-history 10) + +(send pb move 3 4) +(expect (let ([x (box 0.0)] [y (box 0.0)]) + (send pb get-snip-location ss1 x y #f) + (list (unbox x) (unbox y))) + '(15.0 21.5)) +(expect (let ([x (box 0.0)] [y (box 0.0)]) + (send pb get-snip-location ss2 x y #f) + (list (unbox x) (unbox y))) + '(35.0 11.5)) +(send pb undo) +(expect (let ([x (box 0.0)] [y (box 0.0)]) + (send pb get-snip-location ss1 x y #f) + (list (unbox x) (unbox y))) + '(12.0 17.5)) +(expect (let ([x (box 0.0)] [y (box 0.0)]) + (send pb get-snip-location ss2 x y #f) + (list (unbox x) (unbox y))) + '(32.0 7.5)) + +(send pb remove-selected ss1) +(expect (send pb find-snip 15.0 20.0) ss1) +(expect (send pb find-snip 35.0 10.0) ss2) +(expect (send pb find-first-snip) ss2) +(send pb delete) "delete" +(expect (send pb find-first-snip) ss1) +(expect (send pb find-snip 15.0 20.0) ss1) +(expect (send pb find-snip 35.0 10.0) #f) +(send pb undo) "undo" +(expect (send pb find-first-snip) ss2) +(expect (send pb find-snip 35.0 10.0) ss2) +(expect (let ([x (box 0.0)] [y (box 0.0)]) + (send pb get-snip-location ss2 x y #f) + (list (unbox x) (unbox y))) + '(32.0 7.5)) + +(define out20 (open-output-bytes)) +(expect (send pb save-port out20 'standard) #t) +(define in20 (open-input-bytes (get-output-bytes out20))) +(expect (peek-bytes 31 0 in20) #"#reader(lib\"read.ss\"\"wxme\")WXME") + +(define t10 (make-object text%)) +(expect (send t10 insert-port in20) 'standard) +(expect (send t10 get-flattened-text) "twomore!one") + +(define in21 (open-input-bytes (get-output-bytes out20))) +(define pb2 (make-object pasteboard%)) +(expect (send pb2 insert-port in21) 'standard) +(expect (send pb2 get-flattened-text) "twomore!one") +(expect (let ([x (box 0.0)] [y (box 0.0)]) + (send pb2 get-snip-location (send pb2 find-first-snip) x y #f) + (list (unbox x) (unbox y))) + '(32.0 7.5)) + +;; ---------------------------------------- + +(done) From 749043f8e808afd693cc099c373dda54bb85066c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 8 Apr 2009 09:51:38 +0000 Subject: [PATCH 22/66] fix bug in case-sens vs. case-insens find-string for text% svn: r14460 original commit: 28ce21c23ba8774ea9d342f9e3f8dcd17803d395 --- collects/mred/private/wxme/text.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mred/private/wxme/text.ss b/collects/mred/private/wxme/text.ss index 037fdfc5..2cd842ad 100644 --- a/collects/mred/private/wxme/text.ss +++ b/collects/mred/private/wxme/text.ss @@ -3461,7 +3461,7 @@ (let* ([n (sub1 n)] [c (string-ref text i)] - [c (if case-sens? (char-foldcase c) c)] + [c (if case-sens? c (char-foldcase c))] [s (let loop ([s s]) (if (and (not (= beyond s)) (not (char=? (string-ref str (+ s direction)) c))) From f0a0d5879daa1d62abf29fb5d696c6830893d974 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 8 Apr 2009 12:42:25 +0000 Subject: [PATCH 23/66] some pasteboard repairs svn: r14462 original commit: 406d0774c90e9cb178e0cd9a1ebdf8f4e684f9b8 --- collects/mred/private/wxme/editor.ss | 6 +++--- collects/mred/private/wxme/pasteboard.ss | 16 ++++++++-------- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/collects/mred/private/wxme/editor.ss b/collects/mred/private/wxme/editor.ss index 6e191f86..6e4b7842 100644 --- a/collects/mred/private/wxme/editor.ss +++ b/collects/mred/private/wxme/editor.ss @@ -1109,10 +1109,10 @@ (let loop ([s (send this find-first-snip)]) (if s (if (send this is-selected? s) + (loop (snip->next s)) (begin (send this add-selected s) - (cons s (loop (snip->next s)))) - (loop (snip->next s))) + (cons s (loop (snip->next s))))) null))]) (send this copy #t 0) (for-each (lambda (s) @@ -1134,7 +1134,7 @@ (for-each (lambda (s bfd) (unless (this . is-a? . text%) - (send m insert s s)) ;; before itself -> at end + (send m insert s #f)) (when bfd (send m set-snip-data s bfd))) copy-snips diff --git a/collects/mred/private/wxme/pasteboard.ss b/collects/mred/private/wxme/pasteboard.ss index 98366e7d..30eff379 100644 --- a/collects/mred/private/wxme/pasteboard.ss +++ b/collects/mred/private/wxme/pasteboard.ss @@ -1637,23 +1637,23 @@ ;; ---------------------------------------- - (def/override (set-min-width [real? w]) - (set! min-width (if (w . <= . 0) 'none w)) + (def/override (set-min-width [(make-alts real? (symbol-in none)) w]) + (set! min-width (if (and (real? w) (w . <= . 0)) 'none w)) (set! need-resize? #t) (update-all)) - (def/override (set-max-width [real? w]) - (set! max-width (if (w . <= . 0) 'none w)) + (def/override (set-max-width [(make-alts real? (symbol-in none)) w]) + (set! max-width (if (and (real? w) (w . <= . 0)) 'none w)) (set! need-resize? #t) (update-all)) - (def/override (set-min-height [real? h]) - (set! min-height (if (h . <= . 0) 'none h)) + (def/override (set-min-height [(make-alts real? (symbol-in none)) h]) + (set! min-height (if (and (real? h) (h . <= . 0)) 'none h)) (set! need-resize? #t) (update-all)) - (def/override (set-max-height [real? h]) - (set! max-height (if (h . <= . 0) 'none h)) + (def/override (set-max-height [(make-alts real? (symbol-in none)) h]) + (set! max-height (if (and (real? h) (h . <= . 0)) 'none h)) (set! need-resize? #t) (update-all)) From 2e537cd06269f9a2bafa71ad74ac4461263fa5c5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 8 Apr 2009 12:59:22 +0000 Subject: [PATCH 24/66] aligned-pasteboard and cue-text% repairs svn: r14463 original commit: 52d6fb4e1dd1ca6a62f5026f748f200c2318e82b --- collects/embedded-gui/private/cue-text.ss | 10 +++++++++- .../aligned-pasteboard/geometry-managed-pasteboard.ss | 2 +- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/collects/embedded-gui/private/cue-text.ss b/collects/embedded-gui/private/cue-text.ss index b4c4cadb..8af79ecb 100644 --- a/collects/embedded-gui/private/cue-text.ss +++ b/collects/embedded-gui/private/cue-text.ss @@ -19,7 +19,8 @@ (define cue-text-mixin (mixin ((class->interface text%)) () - (inherit insert change-style erase clear-undos) + (inherit insert change-style erase clear-undos + copy-self-to get-line-spacing) (init [cue-text ""] [color "gray"]) (init-field @@ -47,6 +48,13 @@ (when (member 'on-char behavior) (clear-cue-text)) (super on-local-char akeyevent)) + + (define/override (copy-self) + (let ([m (new cue-text% + [behavior behavior] + [line-spacing (get-line-spacing)])]) + (copy-self-to m) + m)) ;; Insert the cue text into the text% on instantiation (super-new) diff --git a/collects/mrlib/private/aligned-pasteboard/geometry-managed-pasteboard.ss b/collects/mrlib/private/aligned-pasteboard/geometry-managed-pasteboard.ss index 37b74e60..9d5e2abe 100644 --- a/collects/mrlib/private/aligned-pasteboard/geometry-managed-pasteboard.ss +++ b/collects/mrlib/private/aligned-pasteboard/geometry-managed-pasteboard.ss @@ -80,7 +80,7 @@ (define/public (realign-to-alloted) (when (and alloted-width alloted-height) (when (not (and (positive? alloted-width) (positive? alloted-height))) - (error 'here "I am")) + (error "allotted width or height is not positive")) (dynamic-let ([ignore-resizing? true]) (let* ([first-snip (find-first-snip)] [aligned-rects From b311d7ed1bb987da750f41fa1424b1aae653abb2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 8 Apr 2009 13:16:51 +0000 Subject: [PATCH 25/66] pasteboard snip-sizing repairs svn: r14464 original commit: 0e7e85269d1cbee351831094d8c793d39b55b7d2 --- collects/mred/private/wxme/pasteboard.ss | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/collects/mred/private/wxme/pasteboard.ss b/collects/mred/private/wxme/pasteboard.ss index 30eff379..2e119db4 100644 --- a/collects/mred/private/wxme/pasteboard.ss +++ b/collects/mred/private/wxme/pasteboard.ss @@ -337,7 +337,7 @@ [f? #f]) (set-box! f? (find-dot loc x y dx dy)) (set! sizedxm dx) - (set! sizedxm dy) + (set! sizedym dy) (when f? (set! resizing snip)) (init-dragging event))))) @@ -1102,11 +1102,11 @@ ;; ---------------------------------------- (define/private (find-dot loc x y dxm dym) - (define (check-y) + (define (check-y can-mid?) (cond [(inbox? (loc-y loc) y) (set-box! dym -1) #t] - [(inbox? (loc-vm loc) y) + [(and can-mid? (inbox? (loc-vm loc) y)) (set-box! dym 0) #t] [(inbox? (loc-b loc) y) (set-box! dym 1) #t] @@ -1114,13 +1114,13 @@ (cond [(inbox? (loc-x loc) x) (set-box! dxm -1) - (check-y)] + (check-y #t)] [(inbox? (loc-hm loc) x) (set-box! dxm 0) - (check-y)] + (check-y #f)] [(inbox? (loc-r loc) x) (set-box! dxm 1) - (check-y)] + (check-y #t)] [else #f])) (def/public (find-snip [real? x] [real? y] [(make-or-false snip%) [after #f]]) From e9e6beb7438ad2c803a559604cca35460d909d15 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 9 Apr 2009 12:43:10 +0000 Subject: [PATCH 26/66] fix forward-word bug for words > 30 characters svn: r14475 original commit: 49852a87fc543170a5b7479eade962cf3b995760 --- collects/mred/private/wxme/wordbreak.ss | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/collects/mred/private/wxme/wordbreak.ss b/collects/mred/private/wxme/wordbreak.ss index 03b428c9..ea2d0881 100644 --- a/collects/mred/private/wxme/wordbreak.ss +++ b/collects/mred/private/wxme/wordbreak.ss @@ -129,7 +129,8 @@ (let ploop ([phase1-complete? #f] [text text] - [tend tend]) + [tend tend] + [end end]) (let-values ([(end phase1-complete?) (if phase1-complete? (values end #t) @@ -147,5 +148,6 @@ (if (and (= tend end) (not (= lend tend))) (ploop phase1-complete? (send win get-text lstart (+ lstart lend)) - lend) + lend + end) (set-box! endp (+ end lstart))))))))))) From 561fadaa49c31bd0f0db72c5cdf4dd397a33aed8 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Thu, 9 Apr 2009 14:59:19 +0000 Subject: [PATCH 27/66] mred/private/wxme: fixed some method arities and defaults svn: r14477 original commit: b6b917a4b96c3c5d51b97665fc28a0a23d4f5db9 --- collects/mred/private/wxme/editor-admin.ss | 2 +- collects/mred/private/wxme/editor-canvas.ss | 13 ++++++------- collects/mred/private/wxme/editor.ss | 4 ++-- collects/mred/private/wxme/pasteboard.ss | 11 ++++++----- collects/mred/private/wxme/snip-admin.ss | 2 +- 5 files changed, 16 insertions(+), 16 deletions(-) diff --git a/collects/mred/private/wxme/editor-admin.ss b/collects/mred/private/wxme/editor-admin.ss index 8ece0cf2..d511cf9c 100644 --- a/collects/mred/private/wxme/editor-admin.ss +++ b/collects/mred/private/wxme/editor-admin.ss @@ -39,7 +39,7 @@ [(symbol-in start none end) [bias 'none]]) (void)) - (def/public (grab-caret [(symbol-in immediate display global) dist]) + (def/public (grab-caret [(symbol-in immediate display global) [dist 'global]]) (void)) (def/public (resized [any? redraw-now]) (void)) diff --git a/collects/mred/private/wxme/editor-canvas.ss b/collects/mred/private/wxme/editor-canvas.ss index cec33592..670fa5c6 100644 --- a/collects/mred/private/wxme/editor-canvas.ss +++ b/collects/mred/private/wxme/editor-canvas.ss @@ -273,7 +273,7 @@ (send blink-timer kill) (set! blink-timer #f)) (send admin set-canvas #f) - #;(super ~)) + #|(super ~)|#) (define/override (on-size w h) (unless noloop? @@ -352,7 +352,7 @@ (define/public (is-focus-on?) focuson?) - (define (force-display-focus on?) + (define/public (force-display-focus on?) (let ([old-on? focusforcedon?]) (set! focusforcedon? on?) (send admin adjust-std-flag) @@ -360,7 +360,6 @@ (or focuson? old-on?))) (refresh)))) - (define/override (on-event event) ;; Turn off auto-dragger, if there is one (when auto-dragger @@ -493,7 +492,7 @@ need-refresh?) (on-paint))) - (define (get-lazy-refresh) lazy-refresh?) + (define/public (get-lazy-refresh) lazy-refresh?) (define/public (set-custom-cursor cursor) (if (not cursor) @@ -879,7 +878,7 @@ (define/public (get-editor) media) - (define/public (set-editor m update?) + (define/public (set-editor m [update? #t]) (unless (eq? media m) (when media (when (eq? admin (send media get-admin)) @@ -932,8 +931,8 @@ (set! scroll-to-last? to-last?) (reset-visual #f) (repaint)) - - (define (scroll-with-bottom-base bottom?) + + (define/public (scroll-with-bottom-base bottom?) (set! scroll-bottom-based? bottom?) (reset-visual #f) (repaint))) diff --git a/collects/mred/private/wxme/editor.ss b/collects/mred/private/wxme/editor.ss index 6e4b7842..da7bd4cb 100644 --- a/collects/mred/private/wxme/editor.ss +++ b/collects/mred/private/wxme/editor.ss @@ -387,7 +387,7 @@ ;; ---------------------------------------- - (def/public (set-keymap [keymap% k]) + (def/public (set-keymap [keymap% [k #f]]) (set! s-keymap k)) (def/public (get-keymap) s-keymap) (def/public (get-style-list) s-style-list) @@ -481,7 +481,7 @@ (define/public (really-can-edit?) #f) - (def/public (insert-box [symbol? type]) + (def/public (insert-box [symbol? [type 'text]]) (let ([snip (on-new-box type)]) (when snip (let ([sname (default-style-name)]) diff --git a/collects/mred/private/wxme/pasteboard.ss b/collects/mred/private/wxme/pasteboard.ss index 2e119db4..fcba8bf5 100644 --- a/collects/mred/private/wxme/pasteboard.ss +++ b/collects/mred/private/wxme/pasteboard.ss @@ -1734,7 +1734,7 @@ (loop (snip->next snip)))) (install-copy-buffer time sl))) - (def/override (copy [bool? extend?] [exact-integer? time]) + (def/override (copy [bool? [extend? #f]] [exact-integer? [time 0]]) (begin-copy-buffer) (when (not extend?) (free-old-copies)) @@ -1795,10 +1795,10 @@ (do-paste time)) (end-edit-sequence))) - (def/override (paste [exact-integer? time]) + (def/override (paste [exact-integer? [time 0]]) (generic-paste #f time)) - (def/override (paste-x-selection [exact-integer? time]) + (def/override (paste-x-selection [exact-integer? [time 0]]) (generic-paste #t time)) (define/override (insert-paste-snip snip data) @@ -1812,7 +1812,7 @@ (send snip insert str) (insert-paste-snip snip #f))) - (def/override (kill [exact-integer? time]) + (def/override (kill [exact-integer? [time 0]]) (cut time)) (define/override (own-x-selection on? update? force?) @@ -1912,7 +1912,8 @@ (write-snips-to-file f s-style-list #f snips #f #f this) (do-write-headers-footers f #f))) - (def/override (read-from-file [editor-stream-in% f] [bool? overwritestyle?]) + (def/override (read-from-file [editor-stream-in% f] + [bool? [overwritestyle? #t]]) (if (or s-user-locked? (not (zero? write-locked))) #f diff --git a/collects/mred/private/wxme/snip-admin.ss b/collects/mred/private/wxme/snip-admin.ss index 73a23f3a..9a6bee31 100644 --- a/collects/mred/private/wxme/snip-admin.ss +++ b/collects/mred/private/wxme/snip-admin.ss @@ -19,7 +19,7 @@ #f) (def/public (get-view [maybe-box? x] [maybe-box? y] [maybe-box? w] [maybe-box? h] - [(make-or-false snip%) snip]) + [(make-or-false snip%) [snip #f]]) #f) (def/public (scroll-to [snip% s] From 4fcd7bdedcb5cb2066246522109fa7a770bd59b3 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 9 Apr 2009 16:40:52 +0000 Subject: [PATCH 28/66] more wxme repairs from Ryan svn: r14478 original commit: bd9d17c94f9c7dd35a179622611e0fadd3dbb00e --- collects/mred/private/wxme/editor-admin.ss | 4 ++-- collects/mred/private/wxme/editor-canvas.ss | 9 --------- collects/mred/private/wxme/editor-snip.ss | 4 ++-- collects/mred/private/wxme/editor.ss | 1 + collects/mred/private/wxme/pasteboard.ss | 4 ++-- collects/mred/private/wxme/text.ss | 14 +++++++------- 6 files changed, 14 insertions(+), 22 deletions(-) diff --git a/collects/mred/private/wxme/editor-admin.ss b/collects/mred/private/wxme/editor-admin.ss index d511cf9c..2a7e8cff 100644 --- a/collects/mred/private/wxme/editor-admin.ss +++ b/collects/mred/private/wxme/editor-admin.ss @@ -33,7 +33,7 @@ (def/public (get-max-view [maybe-box? x] [maybe-box? y] [maybe-box? w] [maybe-box? h] [any? [full? #f]]) - (get-view x y w h)) + (get-view x y w h full?)) (def/public (scroll-to [real? localx] [real? localy] [real? w] [real? h] [any? [refresh? #t]] [(symbol-in start none end) [bias 'none]]) @@ -50,7 +50,7 @@ (def/public (update-cursor) (void)) - (def/public (delay-refresh?) #f) + (def/public (refresh-delayed?) #f) (def/public (popup-menu [popup-menu% m] [real? x] [real? y]) #f) diff --git a/collects/mred/private/wxme/editor-canvas.ss b/collects/mred/private/wxme/editor-canvas.ss index 670fa5c6..2fc6df3b 100644 --- a/collects/mred/private/wxme/editor-canvas.ss +++ b/collects/mred/private/wxme/editor-canvas.ss @@ -1121,12 +1121,3 @@ 1))) (def/override (modified [bool? modified?]) (void))) - - -;; For editor-admin%: -#;( - (define/override (get-max-view fx fy fw fh full?) - (get-view fx fy fh fw full?)) - - (define/override (delay-refresh?) #f) -) diff --git a/collects/mred/private/wxme/editor-snip.ss b/collects/mred/private/wxme/editor-snip.ss index 791925d1..29ee21aa 100644 --- a/collects/mred/private/wxme/editor-snip.ss +++ b/collects/mred/private/wxme/editor-snip.ss @@ -184,7 +184,7 @@ (and editor (send editor can-do-edit-operation? op recur?))) - (def/override (match [snip% s]) + (def/override (match? [snip% s]) #f) (def/override (size-cache-invalid) @@ -699,7 +699,7 @@ (+ x (send snip do-get-left-margin)) (+ y (send snip do-get-top-margin)))))) - (def/override (delay-refresh?) + (def/override (refresh-delayed?) (let ([sadmin (send snip get-admin)]) (or (not sadmin) (and (sadmin . is-a? . standard-snip-admin%) diff --git a/collects/mred/private/wxme/editor.ss b/collects/mred/private/wxme/editor.ss index da7bd4cb..8fdb73f8 100644 --- a/collects/mred/private/wxme/editor.ss +++ b/collects/mred/private/wxme/editor.ss @@ -182,6 +182,7 @@ (def/public (size-cache-invalid) (void)) (def/public (locked-for-read?) #f) (def/public (locked-for-write?) #f) + (def/public (locked-for-flow?) #f) (def/public (resized) (void)) (def/public (recounted) (void)) diff --git a/collects/mred/private/wxme/pasteboard.ss b/collects/mred/private/wxme/pasteboard.ss index fcba8bf5..b7bb324c 100644 --- a/collects/mred/private/wxme/pasteboard.ss +++ b/collects/mred/private/wxme/pasteboard.ss @@ -1681,7 +1681,7 @@ (def/override (get-descent) 0.0) (def/override (get-space) 0.0) - (define/private (get-center) + (def/public (get-center) (let-boxes ([x 0.0] [y 0.0] [w 0.0] @@ -1971,7 +1971,7 @@ (def/override (refresh-delayed?) (or (positive? sequence) (not s-admin) - (send s-admin delay-refresh?))) + (send s-admin refresh-delayed?))) (def/override (in-edit-sequence?) (positive? sequence)) diff --git a/collects/mred/private/wxme/text.ss b/collects/mred/private/wxme/text.ss index 2cd842ad..aa136381 100644 --- a/collects/mred/private/wxme/text.ss +++ b/collects/mred/private/wxme/text.ss @@ -336,7 +336,7 @@ (send m set-wordbreak-func word-break) (send m set-wordbreak-map (get-wordbreak-map)) (send m set-between-threshold (get-between-threshold)) - (send m hide-caret (caret-hidden)) + (send m hide-caret (caret-hidden?)) (send m set-overwrite-mode (get-overwrite-mode)) (send m set-autowrap-bitmap auto-wrap-bitmap) @@ -619,7 +619,7 @@ (def/override (locked-for-read?) read-locked?) - (def/public (locked-for-flow?) + (def/override (locked-for-flow?) flow-locked?) (def/override (locked-for-write?) write-locked?) @@ -710,7 +710,7 @@ (def/override (refresh-delayed?) (or (delay-refresh . > . 0) (not s-admin) - (send s-admin delay-refresh?))) + (send s-admin refresh-delayed?))) (def/override (in-edit-sequence?) (delay-refresh . > . 0)) @@ -3852,7 +3852,7 @@ (when (or s-own-caret? (not (= endpos startpos))) (need-caret-refresh)))) - (def/public (caret-hidden) (not hilite-on?)) + (def/public (caret-hidden?) (not hilite-on?)) (def/public (get-between-threshold) between-threshold) @@ -4324,7 +4324,7 @@ (define/override (init-new-admin) (when (and (zero? delay-refresh) - (or (not s-admin) (not (send s-admin delay-refresh?)))) + (or (not s-admin) (not (send s-admin refresh-delayed?)))) (redraw))) (define/private (end-streaks exceptions) @@ -4655,7 +4655,7 @@ (unless (or flow-locked? (not s-admin)) (let-values ([(continue? notify?) - (if (send s-admin delay-refresh?) + (if (send s-admin refresh-delayed?) ;; does the admin know the refresh box already? (if (and (not (= delayedscroll -1)) (not delayedscrollbox?) @@ -5200,7 +5200,7 @@ (define/private (continue-refresh) (if (and (zero? delay-refresh) (not (super is-printing?)) - (or (not s-admin) (not (send s-admin delay-refresh?)))) + (or (not s-admin) (not (send s-admin refresh-delayed?)))) (redraw) (begin (when (and (zero? delay-refresh) From 237172a3e1a5517426721c96470f635d376067ad Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 9 Apr 2009 21:29:51 +0000 Subject: [PATCH 29/66] another fix from Ryan, plus one that didn't get committed before svn: r14479 original commit: 0657fc52cf7680a2f152d7b2195dff99c63d0d20 --- collects/mred/private/wxme/editor-canvas.ss | 3 +++ 1 file changed, 3 insertions(+) diff --git a/collects/mred/private/wxme/editor-canvas.ss b/collects/mred/private/wxme/editor-canvas.ss index 2fc6df3b..eb0c6a25 100644 --- a/collects/mred/private/wxme/editor-canvas.ss +++ b/collects/mred/private/wxme/editor-canvas.ss @@ -184,6 +184,9 @@ (define xmargin 5) (define ymargin 5) + (define/public (set-wheel-step v) (set! wheel-amt v)) + (define/public (get-wheel-step) wheel-amt) + (set! noloop? #t) (init parent x y width height name style From 52ab67351a4791e392797a6b15c24a097fd3d890 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 9 Apr 2009 23:22:50 +0000 Subject: [PATCH 30/66] editor-canvas clean-up of internal scroll method svn: r14481 original commit: 8fe203ad728c57f08f7c1f69fffc0c52567efecb --- collects/mred/private/wxme/editor-canvas.ss | 41 ++++++++++----------- 1 file changed, 19 insertions(+), 22 deletions(-) diff --git a/collects/mred/private/wxme/editor-canvas.ss b/collects/mred/private/wxme/editor-canvas.ss index eb0c6a25..78c236f9 100644 --- a/collects/mred/private/wxme/editor-canvas.ss +++ b/collects/mred/private/wxme/editor-canvas.ss @@ -427,7 +427,7 @@ -1 1)) 0)]) - (scroll x y #t))))] + (do-scroll x y #t))))] [else (when (and media (not (send media get-printing))) (using-admin @@ -673,7 +673,7 @@ (send hscroll set-value sx)) (when vscroll (send vscroll set-value sy)) - (scroll sx sy refresh?) + (do-scroll sx sy refresh?) #t) #f))))))))) @@ -840,26 +840,23 @@ retval))))))) - (define/override scroll - (case-lambda - [(x y refresh?) - (let ([savenoloop? noloop?]) - (set! noloop? #t) - - (when (and (x . > . -1) - (not fake-x-scroll?)) - (when (positive? scroll-width) - (set-scroll-pos 'horizontal (->long (min x scroll-width))))) - - (when (and (y . > . -1) - (not fake-y-scroll?)) - (when (positive? scroll-height) - (set-scroll-pos 'vertical (->long (min y scroll-height))))) - - (set! noloop? savenoloop?) - - (when refresh? (repaint)))] - [(scroll x y) (void)])) + (define/private (do-scroll x y refresh?) + (let ([savenoloop? noloop?]) + (set! noloop? #t) + + (when (and (x . > . -1) + (not fake-x-scroll?)) + (when (positive? scroll-width) + (set-scroll-pos 'horizontal (->long (min x scroll-width))))) + + (when (and (y . > . -1) + (not fake-y-scroll?)) + (when (positive? scroll-height) + (set-scroll-pos 'vertical (->long (min y scroll-height))))) + + (set! noloop? savenoloop?) + + (when refresh? (repaint)))) (define/override (set-scrollbars x y x2 y2 x3 y3 x4 y4 ?) (void)) From 26bc2fa82913e6e34156145e8349d716e72a14da Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 11 Apr 2009 13:37:14 +0000 Subject: [PATCH 31/66] pasteboard printing fix svn: r14489 original commit: c98e4e0881d17075776cefede0d865c42ff27cd3 --- collects/mred/private/wxme/pasteboard.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mred/private/wxme/pasteboard.ss b/collects/mred/private/wxme/pasteboard.ss index b7bb324c..6b8ae007 100644 --- a/collects/mred/private/wxme/pasteboard.ss +++ b/collects/mred/private/wxme/pasteboard.ss @@ -2081,7 +2081,7 @@ (when (or (zero? (unbox w)) (zero? (unbox h))) (get-default-print-size w h)) - (send (current-ps-setup) get-editor-marginhm vm)) + (send (current-ps-setup) get-editor-margin hm vm)) (let ([W (- w (* 2 hm))] [H (- h (* 2 vm))]) (let-boxes ([w 0.0] From 7aac5a700402a9bcd2aced4f0c7c49569f0c36f2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 11 Apr 2009 14:07:39 +0000 Subject: [PATCH 32/66] pasteboard printing fix & editor-canvas chaining fix svn: r14490 original commit: ccf5809b45a62393491203add9e73fda2fb03cc5 --- collects/mred/private/wxme/editor-canvas.ss | 27 +++++++++++++++------ collects/mred/private/wxme/pasteboard.ss | 21 ++++++++-------- 2 files changed, 30 insertions(+), 18 deletions(-) diff --git a/collects/mred/private/wxme/editor-canvas.ss b/collects/mred/private/wxme/editor-canvas.ss index 78c236f9..db19417a 100644 --- a/collects/mred/private/wxme/editor-canvas.ss +++ b/collects/mred/private/wxme/editor-canvas.ss @@ -907,14 +907,15 @@ (set! media #f) (if oldadmin (begin - (send admin set-nextadmin oldadmin) - (send admin set-prevadmin (send oldadmin get-prevadmin)) - (send oldadmin set-prevadmin admin) - (send oldadmin adjust-std-flag) - (let ([a (send admin get-prevadmin)]) - (when a - (send a set-nextadmin admin) - (send a adjust-std-flag))) + (unless (in-chain? admin oldadmin) + (send admin set-nextadmin oldadmin) + (send admin set-prevadmin (send oldadmin get-prevadmin)) + (send oldadmin set-prevadmin admin) + (send oldadmin adjust-std-flag) + (let ([a (send admin get-prevadmin)]) + (when a + (send a set-nextadmin admin) + (send a adjust-std-flag)))) ;; get the right cursor: (send admin update-cursor)) (begin @@ -927,6 +928,16 @@ (when update? (repaint)))) + (define/private (in-chain? admin oldadmin) + (or (let loop ([oldadmin oldadmin]) + (and oldadmin + (or (eq? admin oldadmin) + (loop (send oldadmin get-prevadmin))))) + (let loop ([oldadmin oldadmin]) + (and oldadmin + (or (eq? admin oldadmin) + (loop (send oldadmin get-nextadmin))))))) + (define/public (allow-scroll-to-last to-last?) (set! scroll-to-last? to-last?) (reset-visual #f) diff --git a/collects/mred/private/wxme/pasteboard.ss b/collects/mred/private/wxme/pasteboard.ss index 6b8ae007..80b023d9 100644 --- a/collects/mred/private/wxme/pasteboard.ss +++ b/collects/mred/private/wxme/pasteboard.ss @@ -2088,8 +2088,8 @@ [h 0.0]) (get-extent w h) - (let ([hcount (->long (ceiling (/ W w)))] - [vcount (->long (ceiling (/ H h)))]) + (let ([hcount (->long (ceiling (/ w W)))] + [vcount (->long (ceiling (/ h H)))]) (if (not print?) (page . <= . (* hcount vcount)) @@ -2097,20 +2097,21 @@ (if (negative? page) (values 1 (* hcount vcount)) (values page page))]) - (for ([p (in-range start end)]) + (for ([p (in-range start (add1 end))]) (let ([vpos (quotient (- p 1) hcount)] [hpos (modulo (- p 1) hcount)]) (let ([x (* hpos w)] [y (* vpos h)]) (when (negative? page) - (send dc start-page) + (send dc start-page)) - (draw dc (+ (- x) hm) (+ (- y) vm) - x y (+ x w) (+ y h) - #f - #f) - (when (negative? page) - (send dc end-page)))))))))))))) + (draw dc (+ (- x) hm) (+ (- y) vm) + x y (+ x w) (+ y h) + 'no-caret + #f) + + (when (negative? page) + (send dc end-page))))))))))))) ;; ---------------------------------------- ) From 6bfcb41c5e772fc8424cdbc8988514a7de1592a1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 11 Apr 2009 22:40:04 +0000 Subject: [PATCH 33/66] fix method name 'equal?' i wxme test svn: r14492 original commit: 3a68af494ab4e3d2b46c68efea8bef05a87f005e --- collects/tests/mred/wxme.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/tests/mred/wxme.ss b/collects/tests/mred/wxme.ss index 695bce17..3870cd3b 100644 --- a/collects/tests/mred/wxme.ss +++ b/collects/tests/mred/wxme.ss @@ -156,9 +156,9 @@ (define d1 (new style-delta%)) (define d2 (new style-delta%)) (expect (send d1 get-underlined-on) #f) -(expect (send d1 equal d2) #t) +(expect (send d1 equal? d2) #t) (send d1 set-underlined-on #t) -(expect (send d1 equal d2) #f) +(expect (send d1 equal? d2) #f) (send d2 collapse d1) (expect (send d2 get-underlined-on) #t) (send d2 set-underlined-on #f) From 1c458d4d32f3099c1fe5dfad3a3d0e35b909b4d9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 11 Apr 2009 22:40:27 +0000 Subject: [PATCH 34/66] fix tab-paste bug and missing default for read-editor-version svn: r14493 original commit: 767d5dde3322ba1eec08654d59521ed1aab68976 --- collects/mred/private/wxme/editor.ss | 2 +- collects/mred/private/wxme/private.ss | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/collects/mred/private/wxme/editor.ss b/collects/mred/private/wxme/editor.ss index 8fdb73f8..5488a75c 100644 --- a/collects/mred/private/wxme/editor.ss +++ b/collects/mred/private/wxme/editor.ss @@ -1729,7 +1729,7 @@ v)))]) (equal? s MRED-READER+START-STR)))))) -(define (read-editor-version mf b parse-format? show-errors?) +(define (read-editor-version mf b parse-format? [show-errors? #t]) (and (or (not parse-format?) diff --git a/collects/mred/private/wxme/private.ss b/collects/mred/private/wxme/private.ss index 816cf7c2..672312a5 100644 --- a/collects/mred/private/wxme/private.ss +++ b/collects/mred/private/wxme/private.ss @@ -28,7 +28,8 @@ ;; snip-class% (define-local-member-name - get-s-required?) + get-s-required? + s-read) ;; editor-data% (define-local-member-name From dfd13aa1326382eeb41bc9f23162d0e2aee8002c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 13 Apr 2009 12:37:48 +0000 Subject: [PATCH 35/66] fix problems with editor stream reading svn: r14497 original commit: 9371f69eefe6614460e13e33054c6d05d397474f --- collects/mred/private/wxme/editor.ss | 2 +- collects/mred/private/wxme/stream.ss | 6 ++++-- collects/mred/private/wxme/text.ss | 2 +- 3 files changed, 6 insertions(+), 4 deletions(-) diff --git a/collects/mred/private/wxme/editor.ss b/collects/mred/private/wxme/editor.ss index 5488a75c..086ba444 100644 --- a/collects/mred/private/wxme/editor.ss +++ b/collects/mred/private/wxme/editor.ss @@ -124,7 +124,7 @@ (define undomode? #f) (define redomode? #f) (define interceptmode? #f) - (define loadoverwritesstyles? #f) + (define loadoverwritesstyles? #t) (field [s-custom-cursor-overrides? #f] [s-need-on-display-size? #f]) diff --git a/collects/mred/private/wxme/stream.ss b/collects/mred/private/wxme/stream.ss index 10aa45c1..d5ed4bb4 100644 --- a/collects/mred/private/wxme/stream.ss +++ b/collects/mred/private/wxme/stream.ss @@ -569,10 +569,10 @@ #t (cond [(and (pair? boundaries) - ((tell) . > . (car boundaries))) + (items . > . (car boundaries))) (set! is-bad? #t) (error 'editor-stream-in% - "overread (caused by file corruption?; ~a vs ~a)" (tell) (car boundaries))] + "overread (caused by file corruption?; ~a vs ~a)" items (car boundaries))] [(send f bad?) (set! is-bad? #t) (error 'editor-stream-in% "stream error")] @@ -587,6 +587,8 @@ (if (read-version . < . 8) (send f tell) (let ([pos (send f tell)]) + (when (not (equal? (hash-ref pos-map items pos) pos)) + (error "again")) (hash-set! pos-map items pos) items))) diff --git a/collects/mred/private/wxme/text.ss b/collects/mred/private/wxme/text.ss index aa136381..702e1e2f 100644 --- a/collects/mred/private/wxme/text.ss +++ b/collects/mred/private/wxme/text.ss @@ -2479,7 +2479,7 @@ (def/override (insert-port [input-port? f] [(symbol-in guess same copy standard text text-force-cr) [format 'guess]] - [any? [replace-styles? #f]]) + [any? [replace-styles? #t]]) (if (or write-locked? s-user-locked?) 'guess ;; FIXME: docs say that this is more specific (do-insert-file (method-name 'text% 'insert-file) f format replace-styles?))) From 3bd10ef6448d9979027884feacfc45912e3a84b0 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 13 Apr 2009 18:01:18 +0000 Subject: [PATCH 36/66] svn: r14499 original commit: 4883d8bb1d1373ab703614b4be500af5b69ae151 --- collects/framework/private/frame.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index ebce5d61..b07f7797 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -2178,7 +2178,7 @@ (when found-pos (unless (hash-ref ht found-txt #f) (hash-set! ht found-txt #t) - (send txt begin-edit-sequence)) + (send found-txt begin-edit-sequence)) (let ([start (- found-pos (send find-edit last-position))]) (send found-txt delete start found-pos) (copy-over replace-edit 0 (send replace-edit last-position) found-txt start) From 27a4afa78c1c27208e6d73c84115ef8e3e5db0aa Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 13 Apr 2009 23:11:08 +0000 Subject: [PATCH 37/66] fix cross-canvas-editor-admin call to do-scroll-to svn: r14500 original commit: 09bec206d61b0f240fcb9ce6d32cd1b18c347e9f --- collects/mred/private/wxme/editor-canvas.ss | 2 +- collects/mred/private/wxme/private.ss | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/collects/mred/private/wxme/editor-canvas.ss b/collects/mred/private/wxme/editor-canvas.ss index db19417a..17c4eb33 100644 --- a/collects/mred/private/wxme/editor-canvas.ss +++ b/collects/mred/private/wxme/editor-canvas.ss @@ -1046,7 +1046,7 @@ (let ([v (do-scroll-to localx localy w h refresh? bias #t #t #f)]) (and v (car v)))) - (define/private (do-scroll-to localx localy w h refresh? bias prev? next? only-focus?) + (define/public (do-scroll-to localx localy w h refresh? bias prev? next? only-focus?) (and canvas (or (and (not (send canvas is-focus-on?)) (or diff --git a/collects/mred/private/wxme/private.ss b/collects/mred/private/wxme/private.ss index 672312a5..b7fba6ba 100644 --- a/collects/mred/private/wxme/private.ss +++ b/collects/mred/private/wxme/private.ss @@ -107,7 +107,8 @@ ;; editor-canvas-editor-admin% (define-local-member-name - do-get-canvas) + do-get-canvas + do-scroll-to) ;; editor-stream% (define-local-member-name From cece9d5dc95f1dbf3a5b4fa0c724ff0e3b579d9e Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 14 Apr 2009 02:08:05 +0000 Subject: [PATCH 38/66] use .ss suffix, both .scm and .ss for the filters, and a descriptive name svn: r14502 original commit: 6b67f941fecab1b1596482a62a3f16f65c7fd3a0 --- collects/framework/private/scheme.ss | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/framework/private/scheme.ss b/collects/framework/private/scheme.ss index 30920fb9..3535effd 100644 --- a/collects/framework/private/scheme.ss +++ b/collects/framework/private/scheme.ss @@ -1183,7 +1183,8 @@ (define/override (put-file text sup directory default-name) (parameterize ([finder:default-extension "ss"] - [finder:default-filters '(("SCM" "*.scm") ("Any" "*.*"))]) + [finder:default-filters '(["Scheme Sources" "*.ss;*.scm"] + ["Any" "*.*"])]) ;; don't call the surrogate's super, since it sets the default extension (sup directory default-name))) From cbf7ba42d41040c62a06d5ca34e293d6b713a9da Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 14 Apr 2009 16:21:09 +0000 Subject: [PATCH 39/66] fix CDLF conversion when loading a text file into an editor svn: r14512 original commit: 6082e6a9c385409b11d4240cc311fdcf33ec4727 --- collects/mred/private/wxme/text.ss | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/collects/mred/private/wxme/text.ss b/collects/mred/private/wxme/text.ss index 702e1e2f..9f14bf29 100644 --- a/collects/mred/private/wxme/text.ss +++ b/collects/mred/private/wxme/text.ss @@ -2510,13 +2510,20 @@ (send s-style-list new-named-style "Standard" (send s-style-list basic-style)) (send mf ok?))))))] [(or (eq? format 'text) (eq? format 'text-force-cr)) - (let loop () + (let loop ([saved-cr? #f]) (let ([l (read-string 256 f)]) (unless (eof-object? l) - (insert l) - (loop)))) + (let ([l2 (if (equal? l "") + l + (if (equal? #\return (string-ref l (sub1 (string-length l)))) + (substring l 0 (sub1 (string-length l))) + l))]) + (insert (regexp-replace* #rx"\r\n" + (if saved-cr? (string-append "\r" l2) l2) + "\n")) + (loop (not (eq? l l2))))))) #f])]) - + (when fileerr? (error who "error loading the file")) From 28ba2e3e4a7dc41a7a7297cdf626eac0e2352e6e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 14 Apr 2009 16:38:37 +0000 Subject: [PATCH 40/66] fix problem with keymap chaining and prefix bindings svn: r14513 original commit: 0f9cb4882d787899b311ae82fd693042effeb52b --- collects/mred/private/wxme/keymap.ss | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/collects/mred/private/wxme/keymap.ss b/collects/mred/private/wxme/keymap.ss index 4f2f66a9..94efd9e7 100644 --- a/collects/mred/private/wxme/keymap.ss +++ b/collects/mred/private/wxme/keymap.ss @@ -473,12 +473,14 @@ (for/fold ([r 0]) ([c (in-list chain-to)] #:when (r . <= . 0)) - (let ([r (send c chain-handle-key-event obj event grab try-prefixed? score)]) - (if (r . > . 0) + (let ([r2 (send c chain-handle-key-event obj event grab try-prefixed? score)]) + (if (r2 . > . 0) (begin (reset) - r) - r)))) + r2) + (if (r2 . < . 0) + r2 + r))))) (define/public (chain-handle-key-event obj event grab only-prefixed? score) ;; results: 0 = no match, 1 = match, -1 = matched prefix From 00d4fef044abbdd74c2efe051ee9af96da87c7e5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 14 Apr 2009 23:08:51 +0000 Subject: [PATCH 41/66] under Windows, editor-canvas% needs to set its own focus on mouse clicks svn: r14516 original commit: 8001b11c03cee29dc3e8518bd8f85b3164b5e848 --- collects/mred/private/wxme/editor-canvas.ss | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/collects/mred/private/wxme/editor-canvas.ss b/collects/mred/private/wxme/editor-canvas.ss index 17c4eb33..7dab3fd1 100644 --- a/collects/mred/private/wxme/editor-canvas.ss +++ b/collects/mred/private/wxme/editor-canvas.ss @@ -152,7 +152,8 @@ get-scroll-page set-scroll-page get-scroll-range set-scroll-range is-shown-to-root? - show-scrollbars) + show-scrollbars + set-focus) (define blink-timer #f) (define noloop? #f) @@ -373,6 +374,12 @@ [y (send event get-y)]) (set! last-x x) (set! last-y y) + + (when (and (eq? 'windows (system-type)) + (not focuson?) + (send event button-down?)) + (set-focus) + (on-focus #t)) (when (and media (not (send media get-printing))) From e09ac14cccb90c682fd3b3cc9683dcb36ed7eeb4 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 15 Apr 2009 03:18:11 +0000 Subject: [PATCH 42/66] svn: r14517 original commit: 405ade476585c0e6e735ac11a5504d57d6bf4758 --- collects/framework/private/text.ss | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index 63711e61..391bf360 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -1170,7 +1170,11 @@ WARNING: printf is rebound in the body of the unit to always (set! clear-yellow void) (when (and searching-str (= (string-length searching-str) (- end start))) (when (do-search searching-str start end) - (set! clear-yellow (highlight-range start end "khaki" #f 'low 'ellipse)))) + (set! clear-yellow (highlight-range start end + (if (preferences:get 'framework:white-on-black?) + (make-object color% 50 50 5) + "khaki") + #f 'low 'ellipse)))) (end-edit-sequence)]))] [else (clear-yellow) From 52d97df6c05a7f5c23dc1a4b8583356d495b1876 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 15 Apr 2009 22:27:43 +0000 Subject: [PATCH 43/66] fix some problems and inefficiencies in saving and loading wxme streams svn: r14526 original commit: 119c69e1ad342ff802ab0f00ad566b8a19c410b6 --- collects/mred/private/wxme/cycle.ss | 2 + collects/mred/private/wxme/editor.ss | 23 ++-- collects/mred/private/wxme/stream.ss | 169 +++++++++++++++------------ collects/tests/mred/wxme.ss | 9 +- 4 files changed, 113 insertions(+), 90 deletions(-) diff --git a/collects/mred/private/wxme/cycle.ss b/collects/mred/private/wxme/cycle.ss index 7bc95563..ee30467e 100644 --- a/collects/mred/private/wxme/cycle.ss +++ b/collects/mred/private/wxme/cycle.ss @@ -25,3 +25,5 @@ (decl editor-put-file set-editor-put-file!) (decl popup-menu% set-popup-menu%!) + + diff --git a/collects/mred/private/wxme/editor.ss b/collects/mred/private/wxme/editor.ss index 086ba444..8df96069 100644 --- a/collects/mred/private/wxme/editor.ss +++ b/collects/mred/private/wxme/editor.ss @@ -611,11 +611,8 @@ (and ;; Read headers (for/and ([i (in-range num-headers)]) - (let-boxes ([n 0] - [len 0]) - (begin - (send f get n) - (send f get-fixed len)) + (let ([n (send f get-exact)] + [len (send f get-fixed-exact)]) (and (send f ok?) (or (zero? len) (let ([sclass (send (send f get-s-scl) find-by-map-position f n)]) @@ -646,11 +643,10 @@ (let ([sclass (if (n . >= . 0) (send (send f get-s-scl) find-by-map-position f n) #f)]) ; -1 => unknown - (let-boxes ([len 0]) - (if (or (not sclass) - (not (send sclass get-s-required?))) - (send f get-fixed len) - (set-box! len -1)) + (let ([len (if (or (not sclass) + (not (send sclass get-s-required?))) + (send f get-fixed-exact) + -1)]) (and (send f ok?) (or (and (zero? len) accum) (and @@ -658,8 +654,7 @@ (let ([start (send f tell)]) (when (len . >= . 0) (send f set-boundary len)) - (let-boxes ([style-index 0]) - (send f get style-index) + (let ([style-index (send f get-exact)]) (let ([snip (send sclass read f)]) (and snip @@ -1337,7 +1332,7 @@ (editor-get-file "choose a file" (extract-parent) #f path)) (def/public (put-file [(make-or-false path-string?) dir] - [(make-or-false string?) suggested-name]) + [(make-or-false path-string?) suggested-name]) (editor-put-file "save file as" (extract-parent) dir suggested-name)) (def/public (set-load-overwrites-styles [any? b?]) @@ -1419,7 +1414,7 @@ (let ([sclass (snip->snipclass snip)]) (unless sclass (error 'write-snips-to-file "snip has no snipclass")) - (if (send f do-get-header-flag sclass) + (if (not (send f do-get-header-flag sclass)) (begin (send f put (send f do-map-position sclass)) (let ([header-start (send f tell)]) diff --git a/collects/mred/private/wxme/stream.ss b/collects/mred/private/wxme/stream.ss index d5ed4bb4..85eb7d13 100644 --- a/collects/mred/private/wxme/stream.ss +++ b/collects/mred/private/wxme/stream.ss @@ -99,7 +99,11 @@ (def/public (read-bytes [bytes? v] [exact-nonnegative-integer? [start 0]] [exact-nonnegative-integer? [end (bytes-length v)]]) - 0)) + 0) + (def/public (read-byte) + (let ([s (make-bytes 1)]) + (and (= 1 (read-bytes s 0 1)) + (bytes-ref s 0))))) (defclass editor-stream-out-base% object% (super-new) @@ -116,6 +120,8 @@ ;; ---------------------------------------- +(define mz:read-byte read-byte) + (defclass editor-stream-in-port-base% editor-stream-in-base% (init-field port) (super-new) @@ -137,7 +143,11 @@ (let ([r (read-bytes! v port start end)]) (if (eof-object? r) 0 - r)))) + r))) + + (def/override (read-byte) + (let ([v (mz:read-byte port)]) + (if (eof-object? v) #f v)))) (defclass editor-stream-in-file-base% editor-stream-in-port-base% (super-new)) @@ -182,6 +192,8 @@ ;; ---------------------------------------- +(define in-read-byte (generic editor-stream-in-base% read-byte)) + (defclass editor-stream-in% editor-stream% (init-rest args) @@ -216,48 +228,50 @@ (define (bad!) (set! is-bad? #t) 0) (if is-bad? 0 - (let ([s (make-bytes 1)]) - (let loop ([prev-byte 0]) - (if (not (= 1 (send f read-bytes s))) + (let loop ([prev-byte 0]) + (let ([b (send-generic f in-read-byte)]) + (if (not b) (bad!) - (let ([b (bytes-ref s 0)]) - (case (integer->char b) - [(#\#) - (let ([pos (send f tell)]) - (if (and (= 1 (send f read-bytes s)) - (= (bytes-ref s 0) (char->integer #\|))) - ;; skip to end of comment - (let cloop ([saw-bar? #f] - [saw-hash? #f] - [nesting 0]) - (if (not (= 1 (send f read-bytes s))) + (case (integer->char b) + [(#\#) + (let ([pos (send f tell)] + [b (send-generic f in-read-byte)]) + (if (and b + (= b (char->integer #\|))) + ;; skip to end of comment + (let cloop ([saw-bar? #f] + [saw-hash? #f] + [nesting 0]) + (let ([b (send-generic f in-read-byte)]) + (if (not b) (bad!) (cond - [(and saw-bar? (= (bytes-ref s 0) (char->integer #\#))) + [(and saw-bar? (= b (char->integer #\#))) (if (zero? nesting) (loop (char->integer #\space)) (cloop #f #f (sub1 nesting)))] - [(and saw-hash? (= (bytes-ref s 0) (char->integer #\|))) + [(and saw-hash? (= b (char->integer #\|))) (cloop #t #f (add1 nesting))] - [else (cloop (= (bytes-ref s 0) (char->integer #\|)) - (= (bytes-ref s 0) (char->integer #\#)) - nesting)]))) - (begin - (send f seek pos) - (char->integer #\#))))] - [(#\;) - ;; skip to end of comment - (let cloop () - (if (not (= 1 (send f read-bytes s))) + [else (cloop (= b (char->integer #\|)) + (= b (char->integer #\#)) + nesting)])))) + (begin + (send f seek pos) + (char->integer #\#))))] + [(#\;) + ;; skip to end of comment + (let cloop () + (let ([b (send-generic f in-read-byte)]) + (if (not b) (bad!) - (if (or (= (bytes-ref s 0) (char->integer #\newline)) - (= (bytes-ref s 0) (char->integer #\return))) + (if (or (= b (char->integer #\newline)) + (= b (char->integer #\return))) (loop (char->integer #\space)) - (cloop))))] - [else - (if (char-whitespace? (integer->char b)) - (loop b) - b)]))))))) + (cloop)))))] + [else + (if (char-whitespace? (integer->char b)) + (loop b) + b)])))))) (define/private (skip-whitespace [buf #f]) (let ([c (do-skip-whitespace)]) @@ -270,9 +284,8 @@ [(char-whitespace? (integer->char b)) #t] [(= b (char->integer #\#)) (let ([pos (send f tell)] - [s (make-bytes 1)]) - (send f read-bytes s) - (let ([d? (= (bytes-ref s 0) (char->integer #\|))]) + [b (send-generic f in-read-byte)]) + (let ([d? (= b (char->integer #\|))]) (send f seek (if d? (sub1 pos) pos)) d?))] [(= b (char->integer #\;)) @@ -284,36 +297,43 @@ (let ([c0 (skip-whitespace)]) (if (check-boundary) (if get-exact? 0 0.0) - (let* ([s (make-bytes 1)] - [l (cons (integer->char c0) - (let loop ([counter 50]) - (if (zero? counter) - null - (if (= 1 (send f read-bytes s)) - (let ([s (bytes-ref s 0)]) - (if (is-delim? s) - null - (cons (integer->char s) - (loop (sub1 counter))))) - null))))]) + (let* ([l + ;; As fast path, accum integer result + (let loop ([counter 50][c c0][v 0]) + (if (zero? counter) + null + (if (or (not c) + (is-delim? c)) + (or v null) + (let ([rest (loop (sub1 counter) + (send-generic f in-read-byte) + (and v + (c . >= . (char->integer #\0)) + (c . <= . (char->integer #\9)) + (+ (* v 10) (- c (char->integer #\0)))))]) + (if (exact-integer? rest) + rest + (cons (integer->char c) rest))))))]) (inc-item-count) - (let ([n (string->number (list->string l))]) + (let ([n (if (exact-integer? l) + l + (string->number (list->string l)))]) (cond - [(or (not n) - (not (real? n)) - (and get-exact? (not (exact-integer? n)))) - (set! is-bad? #t) - (if get-exact? 0 0.0)] - [get-exact? n] + [(and get-exact? (exact-integer? n)) n] + [(real? n) (exact->inexact n)] [else - (exact->inexact n)])))))) + (set! is-bad? #t) + (if get-exact? 0 0.0)])))))) (define/private (get-a-string limit recur?) (let* ([orig-len (if recur? (if (limit . < . 16) limit 16) - (get-exact))] + (let ([v (get-exact)]) + (if (check-boundary) + 0 + v)))] [buf (make-bytes 32)] [fail (lambda () (set! is-bad? #t) @@ -447,20 +467,22 @@ (success) (loop))))])))) + (def/public (get-fixed-exact) + (if (check-boundary) + 0 + (if (read-version . < . 8) + (let ([buf (make-bytes 4)]) + (send f read-bytes buf) + (integer-bytes->integer + buf + #t + (if (= read-version 1) + (system-big-endian?) + #t))) + (get-exact)))) + (def/public (get-fixed [box? vb]) - (let ([v (if (check-boundary) - 0 - (if (read-version . < . 8) - (let ([buf (make-bytes 4)]) - (send f read-bytes buf) - (integer-bytes->integer - buf - #t - (if (= read-version 1) - (system-big-endian?) - #t))) - (get-exact)))]) - (set-box! vb v))) + (set-box! vb (get-fixed-exact))) #| integer format specified by first byte: @@ -569,7 +591,7 @@ #t (cond [(and (pair? boundaries) - (items . > . (car boundaries))) + (items . >= . (car boundaries))) (set! is-bad? #t) (error 'editor-stream-in% "overread (caused by file corruption?; ~a vs ~a)" items (car boundaries))] @@ -647,6 +669,7 @@ (bytes-append spc (make-bytes (- 11 (string-length s)) (char->integer #\space)) (string->bytes/latin-1 s)))) + (set! col new-col) (set! items (add1 items))) this) diff --git a/collects/tests/mred/wxme.ss b/collects/tests/mred/wxme.ss index 3870cd3b..869d90c4 100644 --- a/collects/tests/mred/wxme.ss +++ b/collects/tests/mred/wxme.ss @@ -768,12 +768,15 @@ (expect (send fi2 tell) 10) (send fi2 jump-to 3) -(send fi2 set-boundary 5) +(send fi2 set-boundary 2) (expect (send fi2 get-unterminated-bytes) #"hi") (send fi2 jump-to 3) (expect (send fi2 ok?) #t) -(send fi2 set-boundary 4) -(expect (send fi2 get-unterminated-bytes) #"") +(expect (send fi2 tell) 3) +(send fi2 set-boundary 1) +(expect (with-handlers ([values (lambda (exn) #"")]) + (send fi2 get-unterminated-bytes)) + #"") (expect (send fi2 ok?) #f) ;; ---------------------------------------- From a6ef7af3bdd7f3d23bd0fa25e74e08525d798b4a Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 16 Apr 2009 17:18:35 +0000 Subject: [PATCH 44/66] shrunk the height of the preferences window svn: r14528 original commit: 0c2c04e168ef6caaec143099d96745a8112a8c1d --- collects/framework/main.ss | 16 +++++- collects/framework/private/preferences.ss | 60 ++++++++++++++--------- collects/framework/private/sig.ss | 2 + 3 files changed, 55 insertions(+), 23 deletions(-) diff --git a/collects/framework/main.ss b/collects/framework/main.ss index 0f16c0fc..c85f5de8 100644 --- a/collects/framework/main.ss +++ b/collects/framework/main.ss @@ -198,6 +198,12 @@ @{Adds a preferences panel for configuring options related to editing.}) + (proc-doc/names + preferences:add-general-checkbox-panel + (-> void?) + () + @{Adds a catch-all preferences panel for options.}) + (proc-doc/names preferences:add-warnings-checkbox-panel (-> void?) @@ -232,7 +238,15 @@ (((is-a?/c vertical-panel%) . -> . void?) . -> . void?) (proc) @{Saves @scheme[proc] until the preferences panel is created, when it - is called with the Echeme preferences panel to add new children to + is called with the editor preferences panel to add new children to + the panel.}) + + (proc-doc/names + preferences:add-to-general-checkbox-panel + (((is-a?/c vertical-panel%) . -> . void?) . -> . void?) + (proc) + @{Saves @scheme[proc] until the preferences panel is created, when it + is called with the general preferences panel to add new children to the panel.}) (proc-doc/names diff --git a/collects/framework/private/preferences.ss b/collects/framework/private/preferences.ss index 5bb3db1d..c2a10f40 100644 --- a/collects/framework/private/preferences.ss +++ b/collects/framework/private/preferences.ss @@ -227,8 +227,9 @@ the state transitions / contracts are: (super show on?)) (super-new))] [frame - (make-object frame-stashed-prefs% - (string-constant preferences))] + (new frame-stashed-prefs% + [label (string-constant preferences)] + [height 200])] [build-ppanel-tree (λ (ppanel tab-panel single-panel) (send tab-panel append (ppanel-name ppanel)) @@ -310,6 +311,11 @@ the state transitions / contracts are: (let ([old editor-panel-procs]) (λ (parent) (old parent) (f parent))))) + (define (add-to-general-checkbox-panel f) + (set! general-panel-procs + (let ([old general-panel-procs]) + (λ (parent) (old parent) (f parent))))) + (define (add-to-warnings-checkbox-panel f) (set! warnings-panel-procs (let ([old warnings-panel-procs]) @@ -317,6 +323,7 @@ the state transitions / contracts are: (define scheme-panel-procs void) (define editor-panel-procs void) + (define general-panel-procs void) (define warnings-panel-procs void) (define (add-checkbox-panel label proc) @@ -394,21 +401,8 @@ the state transitions / contracts are: (list (string-constant editor-prefs-panel-label) (string-constant general-prefs-panel-label)) (λ (editor-panel) - (make-recent-items-slider editor-panel) - (make-check editor-panel - 'framework:autosaving-on? - (string-constant auto-save-files) - values values) - (make-check editor-panel 'framework:backup-files? (string-constant backup-files) values values) (make-check editor-panel 'framework:delete-forward? (string-constant map-delete-to-backspace) not not) - (make-check editor-panel 'framework:show-status-line (string-constant show-status-line) values values) - (make-check editor-panel 'framework:col-offsets (string-constant count-columns-from-one) values values) - (make-check editor-panel - 'framework:display-line-numbers - (string-constant display-line-numbers) - values values) - (make-check editor-panel 'framework:auto-set-wrap? (string-constant wrap-words-in-editor-buffers) @@ -432,13 +426,7 @@ the state transitions / contracts are: 'framework:coloring-active (string-constant online-coloring-active) values values) - (unless (eq? (system-type) 'unix) - (make-check editor-panel - 'framework:print-output-mode - (string-constant automatically-to-ps) - (λ (b) - (if b 'postscript 'standard)) - (λ (n) (eq? 'postscript n)))) + (make-check editor-panel 'framework:anchored-search (string-constant find-anchor-based) @@ -454,6 +442,34 @@ the state transitions / contracts are: (editor-panel-procs editor-panel))))]) (add-editor-checkbox-panel))) + (define (add-general-checkbox-panel) + (letrec ([add-general-checkbox-panel + (λ () + (set! add-general-checkbox-panel void) + (add-checkbox-panel + (list (string-constant general-prefs-panel-label)) + (λ (editor-panel) + (make-recent-items-slider editor-panel) + (make-check editor-panel + 'framework:autosaving-on? + (string-constant auto-save-files) + values values) + (make-check editor-panel 'framework:backup-files? (string-constant backup-files) values values) + (make-check editor-panel 'framework:show-status-line (string-constant show-status-line) values values) + (make-check editor-panel 'framework:col-offsets (string-constant count-columns-from-one) values values) + (make-check editor-panel + 'framework:display-line-numbers + (string-constant display-line-numbers) + values values) + (unless (eq? (system-type) 'unix) + (make-check editor-panel + 'framework:print-output-mode + (string-constant automatically-to-ps) + (λ (b) + (if b 'postscript 'standard)) + (λ (n) (eq? 'postscript n)))))))]) + (add-general-checkbox-panel))) + (define (add-warnings-checkbox-panel) (letrec ([add-warnings-checkbox-panel (λ () diff --git a/collects/framework/private/sig.ss b/collects/framework/private/sig.ss index 32e5a033..ec23b69f 100644 --- a/collects/framework/private/sig.ss +++ b/collects/framework/private/sig.ss @@ -74,10 +74,12 @@ add-font-panel add-editor-checkbox-panel + add-general-checkbox-panel add-warnings-checkbox-panel add-scheme-checkbox-panel add-to-editor-checkbox-panel + add-to-general-checkbox-panel add-to-warnings-checkbox-panel add-to-scheme-checkbox-panel From e1ff6bf4056ebe69eb97e41d93e4b18e4a4b514d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 16 Apr 2009 19:01:20 +0000 Subject: [PATCH 45/66] performance improvements: class local-field access uses accessor with index built in (so the index is checked once); JIT partially inlines struct-field mutation svn: r14530 original commit: 709ad23400dab6a39cf3499be13896434414d2fa --- collects/mred/private/wxme/text.ss | 149 +++++++++++++++-------------- collects/mred/private/wxme/undo.ss | 3 +- 2 files changed, 80 insertions(+), 72 deletions(-) diff --git a/collects/mred/private/wxme/text.ss b/collects/mred/private/wxme/text.ss index 9f14bf29..2b297eaa 100644 --- a/collects/mred/private/wxme/text.ss +++ b/collects/mred/private/wxme/text.ss @@ -384,7 +384,7 @@ (not (zero? how-close)) ((abs how-close) . > . between-threshold))]) (let ([snip (and onit? - (find-snip pos 'after))]) + (do-find-snip pos 'after))]) (and snip (let-boxes ([x 0.0] [y 0.0]) (get-snip-position-and-location snip #f x y) @@ -428,7 +428,7 @@ ((abs how-close) . > . between-threshold))]) (if onit? ;; we're in the snip's horizontal region... - (let ([snip (find-snip now 'after)]) + (let ([snip (do-find-snip now 'after)]) ;; ... but maybe the mouse is above or below it. (let-boxes ([top 0.0] [bottom 0.0] @@ -1332,7 +1332,7 @@ (let* ([gsnip (if (not did-one?) (begin (make-snipset start start) - (find-snip start 'after-or-none)) + (do-find-snip start 'after-or-none)) before-snip)] [before-snip (or before-snip gsnip)] [inserted-new-line? @@ -1534,7 +1534,7 @@ [(or (equal? c #\newline) (equal? c #\tab)) (let ([newline? (equal? c #\newline)]) (make-snipset (+ i start) (+ i start 1)) - (let ([snip (find-snip (+ i start) 'after)]) + (let ([snip (do-find-snip (+ i start) 'after)]) (if newline? ;; forced return - split the snip @@ -1611,7 +1611,7 @@ (when (eq? (mline-last-snip (snip->line snip)) snip) (set-mline-last-snip! (snip->line tabsnip) tabsnip)))))) - (let ([snip (find-snip (+ i start 1) 'after)]) + (let ([snip (do-find-snip (+ i start 1) 'after)]) (let ([i (add1 i)]) (loop (+ i start) (if (= i addlen) #f (string-snip-buffer snip)) @@ -1623,7 +1623,7 @@ [(cnt . > . MAX-COUNT-FOR-SNIP) ;; divide up snip, because it's too large: (make-snipset (+ i start) (+ i start)) - (let ([snip (find-snip (+ i start) 'after)]) + (let ([snip (do-find-snip (+ i start) 'after)]) (loop (+ i start) (string-snip-buffer snip) (add1 (string-snip-dtext snip)) @@ -1711,8 +1711,8 @@ (make-snipset start end) (set! revision-count (add1 revision-count)) - (let* ([start-snip (find-snip start 'before-or-none)] - [end-snip (find-snip end 'before)] + (let* ([start-snip (do-find-snip start 'before-or-none)] + [end-snip (do-find-snip end 'before)] [with-undo? (and with-undo? (zero? s-noundomode))] [rec (if with-undo? @@ -1956,8 +1956,8 @@ s-style-list)]) (set-common-copy-region-data! (get-region-data startp endp)) - (let ([start (find-snip startp 'after)] - [end (find-snip endp 'after-or-none)] + (let ([start (do-find-snip startp 'after)] + [end (do-find-snip endp 'after-or-none)] [wl? write-locked?] [fl? flow-locked?]) @@ -2050,7 +2050,7 @@ (let ([addpos (snip->count snip)]) (insert snip read-insert) (when data - (let ([snip (find-snip read-insert 'after)]) + (let ([snip (do-find-snip read-insert 'after)]) (set-snip-data snip data))) (set! read-insert (+ read-insert addpos)))) @@ -2300,8 +2300,8 @@ ((clickback-end c) . > . start) ;; we're in the right horizontal region, but maybe the mouse ;; is above or below the clickback - (let ([start (find-snip (clickback-start c) 'after)] - [end (find-snip (clickback-end c) 'before)]) + (let ([start (do-find-snip (clickback-start c) 'after)] + [end (do-find-snip (clickback-end c) 'before)]) (and start end (let-boxes ([top 0.0] @@ -2510,18 +2510,20 @@ (send s-style-list new-named-style "Standard" (send s-style-list basic-style)) (send mf ok?))))))] [(or (eq? format 'text) (eq? format 'text-force-cr)) - (let loop ([saved-cr? #f]) - (let ([l (read-string 256 f)]) - (unless (eof-object? l) - (let ([l2 (if (equal? l "") - l - (if (equal? #\return (string-ref l (sub1 (string-length l)))) - (substring l 0 (sub1 (string-length l))) - l))]) - (insert (regexp-replace* #rx"\r\n" - (if saved-cr? (string-append "\r" l2) l2) - "\n")) - (loop (not (eq? l l2))))))) + (let ([s (make-string 1024)]) + (let loop ([saved-cr? #f]) + (let ([len (read-string! s f)]) + (unless (eof-object? len) + (let* ([s1 (if (= len (string-length s)) + s + (substring s 0 len))] + [s2 (if (equal? #\return (string-ref s1 (sub1 len))) + (substring s1 0 (sub1 len)) + s1)]) + (insert (regexp-replace* #rx"\r\n" + (if saved-cr? (string-append "\r" s2) s2) + "\n")) + (loop (not (eq? s1 s2)))))))) #f])]) (when fileerr? @@ -2605,8 +2607,8 @@ len end) start)]) - (let ([start-snip (if (zero? len) #f (find-snip start 'after))] - [end-snip (if (zero? len) #f (find-snip end 'after-or-none))]) + (let ([start-snip (if (zero? len) #f (do-find-snip start 'after))] + [end-snip (if (zero? len) #f (do-find-snip end 'after-or-none))]) (and (do-write-headers-footers f #t) (write-snips-to-file f s-style-list #f start-snip end-snip #f this) (do-write-headers-footers f #f)))))) @@ -3524,7 +3526,7 @@ (cond [new-style new-style] [caret-style (send s-style-list find-or-create-style caret-style delta)] - [else (let ([gsnip (find-snip start 'before)]) + [else (let ([gsnip (do-find-snip start 'before)]) (send s-style-list find-or-create-style (snip->style gsnip) delta))])))] [else (set! write-locked? #t) @@ -3544,7 +3546,7 @@ (begin (set! initial-style-needed? #f) (values snips #f)) - (values (find-snip start 'after) (find-snip end 'after-or-none)))] + (values (do-find-snip start 'after) (do-find-snip end 'after-or-none)))] [(rec) (and (zero? s-noundomode) (make-object style-change-record% start end @@ -4007,8 +4009,6 @@ (set! write-locked? #t) (set! flow-locked? #t) - (set-box! a-ptr #f) - (set-box! b-ptr #f) (send snip split pos a-ptr b-ptr) (set! read-locked? #f) @@ -4071,7 +4071,8 @@ (splice-snip snip prev next) (set! snip-count (add1 snip-count)) (insert-snip snip ins-snip) - (extra snip) + (when extra + (extra snip)) (snip-set-admin snip snip-admin) (snip-set-admin ins-snip snip-admin) @@ -4084,11 +4085,11 @@ (let-values ([(snip s-pos) (find-snip/pos start 'after-or-none)]) (when snip (unless (= s-pos start) - (split-one start s-pos snip void))))) + (split-one start s-pos snip #f))))) (when (positive? end) (let-values ([(snip s-pos) (find-snip/pos end 'before)]) (unless (= (+ s-pos (snip->count snip)) end) - (split-one end s-pos snip void))))) + (split-one end s-pos snip #f))))) (define/private (insert-text-snip start style) (let* ([snip (on-new-string-snip)] @@ -4257,6 +4258,11 @@ #f snips)) + (define/private (do-find-snip p direction) + ;; BEWARE: `len' may not be up-to-date + (let-values ([(snip pos) (find-snip/pos p direction)]) + snip)) + (def/public (find-snip [exact-nonnegative-integer? p] [(symbol-in before-or-none before after after-or-none) direction] [maybe-box? [s-pos #f]]) @@ -4270,48 +4276,49 @@ (cond [(and (eq? direction 'before-or-none) (zero? p)) (values #f 0)] - [(and (eq? direction 'after-or-none) (p . >= . (let ([l (mline-last (unbox line-root-box))]) - (+ (mline-get-position l) - (mline-len l))))) - (values #f 0)] [else (let* ([line (mline-find-position (unbox line-root-box) p)] [pos (mline-get-position line)] [p (- p pos)]) + (if (and (eq? direction 'after-or-none) + (not (mline-next line)) + (p . >= . (mline-len line))) + ;; past the end: + (values #f 0) + ;; within the line: + (let-values ([(snip pos p) + (let ([snip (mline-snip line)]) + (if (and (zero? p) (snip->prev snip)) + ;; back up one: + (let ([snip (snip->prev snip)]) + (values snip + (- pos (snip->count snip)) + (+ p (snip->count snip)))) + (values snip pos p)))]) - (let-values ([(snip pos p) - (let ([snip (mline-snip line)]) - (if (and (zero? p) (snip->prev snip)) - ;; back up one: - (let ([snip (snip->prev snip)]) - (values snip - (- pos (snip->count snip)) - (+ p (snip->count snip)))) - (values snip pos p)))]) - - (let loop ([snip snip] - [pos pos] - [p p]) - (if snip - (let ([p (- p (snip->count snip))]) - (cond - [(or (and (eq? direction 'on) - (zero? p)) - (and (or (eq? direction 'before) - (eq? direction 'before-or-none)) - (p . <= . 0)) - (and (or (eq? direction 'after) - (eq? direction 'after-or-none)) - (p . < . 0))) - (values snip pos)] - [(and (eq? direction 'on) - (p . < . 0)) - (values #f 0)] - [else - (loop (snip->next snip) (+ pos (snip->count snip)) p)])) - (if (not (eq? direction 'after-or-none)) - (values last-snip (- pos (snip->count last-snip))) - (values #f 0))))))])) + (let loop ([snip snip] + [pos pos] + [p p]) + (if snip + (let ([p (- p (snip->count snip))]) + (cond + [(or (and (eq? direction 'on) + (zero? p)) + (and (or (eq? direction 'before) + (eq? direction 'before-or-none)) + (p . <= . 0)) + (and (or (eq? direction 'after) + (eq? direction 'after-or-none)) + (p . < . 0))) + (values snip pos)] + [(and (eq? direction 'on) + (p . < . 0)) + (values #f 0)] + [else + (loop (snip->next snip) (+ pos (snip->count snip)) p)])) + (if (not (eq? direction 'after-or-none)) + (values last-snip (- pos (snip->count last-snip))) + (values #f 0)))))))])) (def/public (find-next-non-string-snip [(make-or-false snip%) snip]) (if (or (and snip diff --git a/collects/mred/private/wxme/undo.ss b/collects/mred/private/wxme/undo.ss index 15f44fbd..053b3f82 100644 --- a/collects/mred/private/wxme/undo.ss +++ b/collects/mred/private/wxme/undo.ss @@ -4,7 +4,8 @@ "snip.ss" "snip-flags.ss") -(provide proc-record% +(provide change-record% + proc-record% unmodify-record% insert-record% insert-snip-record% From 8cbce413425bb403fa76ac123c767dba54105834 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 16 Apr 2009 19:20:44 +0000 Subject: [PATCH 46/66] don't let syntax-colorer thread get suspend while reading from the editor svn: r14531 original commit: ce9d26492076373d71a52b706f182a56f319f499 --- collects/framework/private/color.ss | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/collects/framework/private/color.ss b/collects/framework/private/color.ss index 80b64bd4..a5b0526b 100644 --- a/collects/framework/private/color.ss +++ b/collects/framework/private/color.ss @@ -260,7 +260,11 @@ added get-regions (define/private (re-tokenize ls in in-start-pos enable-suspend) (let-values ([(lexeme type data new-token-start new-token-end) - (get-token in)]) + (begin + (enable-suspend #f) + (begin0 + (get-token in) + (enable-suspend #t)))]) (unless (eq? 'eof type) (enable-suspend #f) #; (printf "~a at ~a to ~a~n" lexeme (+ in-start-pos (sub1 new-token-start)) @@ -365,10 +369,14 @@ added get-regions (for-each (lambda (ls) (re-tokenize ls - (open-input-text-editor this - (lexer-state-current-pos ls) - (lexer-state-end-pos ls) - (λ (x) #f)) + (begin + (enable-suspend #f) + (begin0 + (open-input-text-editor this + (lexer-state-current-pos ls) + (lexer-state-end-pos ls) + (λ (x) #f)) + (enable-suspend #t))) (lexer-state-current-pos ls) enable-suspend)) lexer-states))))) From 4b68d460bb99ca31bf0b2bf805e412329899da39 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 17 Apr 2009 11:12:13 +0000 Subject: [PATCH 47/66] doc scheme/gui editor-stream method updates svn: r14538 original commit: a99c653997d179f88a7a4909941be8bf59a79bfc --- .../scribblings/gui/editor-stream-in-base-class.scrbl | 8 ++++++++ collects/scribblings/gui/editor-stream-in-class.scrbl | 10 ++++++++-- collects/scribblings/gui/editor-stream-out-class.scrbl | 3 ++- 3 files changed, 18 insertions(+), 3 deletions(-) diff --git a/collects/scribblings/gui/editor-stream-in-base-class.scrbl b/collects/scribblings/gui/editor-stream-in-base-class.scrbl index ce4cfc89..77d66c3a 100644 --- a/collects/scribblings/gui/editor-stream-in-base-class.scrbl +++ b/collects/scribblings/gui/editor-stream-in-base-class.scrbl @@ -37,6 +37,14 @@ Reads bytes to fill the supplied byte string. The return value is the next call to @method[editor-stream-in-base% bad?] must return @scheme[#t].} +@defmethod[(read-byte) (or/c byte? #f)]{ + +Reads a single byte and return it, or returns @scheme[#f] if no more +bytes are available. The default implementation of this method uses +@method[editor-stream-in-base% read-bytes]. + +} + @defmethod[(seek [pos exact-nonnegative-integer?]) void?]{ diff --git a/collects/scribblings/gui/editor-stream-in-class.scrbl b/collects/scribblings/gui/editor-stream-in-class.scrbl index 25f0e964..5d67b067 100644 --- a/collects/scribblings/gui/editor-stream-in-class.scrbl +++ b/collects/scribblings/gui/editor-stream-in-class.scrbl @@ -54,12 +54,18 @@ Returns the next integer value in the stream. @defmethod[(get-fixed [v (box/c (and/c exact? integer?))]) (is-a?/c editor-stream-in%)]{ +@boxisfill[(scheme v) @elem{a fixed-size integer from the stream obtained through + @method[editor-stream-in% get-fixed-exact]}] + +} + +@defmethod[(get-fixed-exact) + (and/c exact? integer?)]{ + Gets a fixed-sized integer from the stream. See @method[editor-stream-out% put-fixed] for more information. Reading from a bad stream always gives @scheme[0]. -@boxisfill[(scheme v) @elem{the fixed-size integer from the stream}] - } @defmethod[(get-inexact) diff --git a/collects/scribblings/gui/editor-stream-out-class.scrbl b/collects/scribblings/gui/editor-stream-out-class.scrbl index d869eaf2..30bdb2b4 100644 --- a/collects/scribblings/gui/editor-stream-out-class.scrbl +++ b/collects/scribblings/gui/editor-stream-out-class.scrbl @@ -86,7 +86,8 @@ Puts a fixed-sized integer into the stream. This method is needed fixed-size number. Numbers written to a stream with @method[editor-stream-out% put-fixed] - must be read with @method[editor-stream-in% get-fixed].} + must be read with @method[editor-stream-in% get-fixed-exact] + or @method[editor-stream-in% get-fixed].} @defmethod[(put-unterminated [v bytes?]) (is-a?/c editor-stream-out%)]{ From e479b0057533f11cb28158a175cdc285af0cda1a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 17 Apr 2009 22:50:19 +0000 Subject: [PATCH 48/66] fix inverted argument default for editor<%> read-from-file method; better Check Sytax results on packages; added syntax/flatten-begin library svn: r14548 original commit: 4b3626c1560658fe3937019e001911c2a44aaff3 --- collects/mred/private/wxme/pasteboard.ss | 2 +- collects/mred/private/wxme/text.ss | 4 ++-- collects/scribblings/gui/editor-intf.scrbl | 2 +- collects/scribblings/gui/text-class.scrbl | 2 +- 4 files changed, 5 insertions(+), 5 deletions(-) diff --git a/collects/mred/private/wxme/pasteboard.ss b/collects/mred/private/wxme/pasteboard.ss index 80b023d9..9402788f 100644 --- a/collects/mred/private/wxme/pasteboard.ss +++ b/collects/mred/private/wxme/pasteboard.ss @@ -1913,7 +1913,7 @@ (do-write-headers-footers f #f))) (def/override (read-from-file [editor-stream-in% f] - [bool? [overwritestyle? #t]]) + [bool? [overwritestyle? #f]]) (if (or s-user-locked? (not (zero? write-locked))) #f diff --git a/collects/mred/private/wxme/text.ss b/collects/mred/private/wxme/text.ss index 2b297eaa..7a188eff 100644 --- a/collects/mred/private/wxme/text.ss +++ b/collects/mred/private/wxme/text.ss @@ -2581,9 +2581,9 @@ (define/override (read-from-file . args) (case-args args - [([editor-stream-in% f] [exact-nonnegative-integer? start] [any? [overwritestyle? #t]]) + [([editor-stream-in% f] [exact-nonnegative-integer? start] [any? [overwritestyle? #f]]) (do-read-from-file f start overwritestyle?)] - [([editor-stream-in% f] [any? [overwritestyle? #t]]) + [([editor-stream-in% f] [any? [overwritestyle? #f]]) (do-read-from-file f 'start overwritestyle?)] (method-name 'text% 'read-from-file))) diff --git a/collects/scribblings/gui/editor-intf.scrbl b/collects/scribblings/gui/editor-intf.scrbl index 2184550f..99dc7b6f 100644 --- a/collects/scribblings/gui/editor-intf.scrbl +++ b/collects/scribblings/gui/editor-intf.scrbl @@ -1826,7 +1826,7 @@ See @method[editor<%> read-header-from-file]. @defmethod[(read-from-file [stream (is-a?/c editor-stream-in%)] - [overwrite-styles? any/c #t]) + [overwrite-styles? any/c #f]) boolean?]{ Reads new contents for the editor from a stream. The return value is diff --git a/collects/scribblings/gui/text-class.scrbl b/collects/scribblings/gui/text-class.scrbl index 3635683e..d0af7be3 100644 --- a/collects/scribblings/gui/text-class.scrbl +++ b/collects/scribblings/gui/text-class.scrbl @@ -1698,7 +1698,7 @@ Returns the paragraph number of the paragraph containing a given @techlink{posit @defmethod[#:mode extend (read-from-file [stream (is-a?/c editor-stream-in%)] [start (or/c exact-nonnegative-integer? (one/of 'start))] - [overwrite-styles? any/c #t]) + [overwrite-styles? any/c #f]) boolean?]{ New data is inserted at the @techlink{position} indicated by @scheme[start], or at From 744f17fcd9399951a29f4971e4310f8c91491bab Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 18 Apr 2009 01:38:18 +0000 Subject: [PATCH 49/66] fix excessive redraw after changes within an editor svn: r14549 original commit: 82b9ab8a53d955f3478d599e7ab234745fd9ec13 --- collects/mred/private/wxme/text.ss | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/collects/mred/private/wxme/text.ss b/collects/mred/private/wxme/text.ss index 7a188eff..eb78bee8 100644 --- a/collects/mred/private/wxme/text.ss +++ b/collects/mred/private/wxme/text.ss @@ -2560,7 +2560,6 @@ (when fileerr? (error (method-name 'text% 'save-port) "error writing editor content")) #t))) - (define/private (do-read-from-file f start overwritestyle?) (if write-locked? @@ -4722,9 +4721,9 @@ (cond [(not (= delayedscroll -1)) - (scroll-to-position/refresh delayedscroll delayedscrollateol? #f - delayedscrollend delayedscrollbias) - (set! refresh-all? #t)] + (when (scroll-to-position/refresh delayedscroll delayedscrollateol? #f + delayedscrollend delayedscrollbias) + (set! refresh-all? #t))] [delayedscrollbox? (set! delayedscrollbox? #f) (when (do-scroll-to delayedscrollsnip delayedscroll-x delayedscroll-y @@ -4735,7 +4734,7 @@ (send s-admin get-dc x y) (when (or (not (= origx x)) (not (= origy y))) (set! refresh-all? #t))) - + (let-boxes ([x 0.0] [y 0.0] [w 0.0] [h 0.0]) (send s-admin get-max-view x y w h) (let ([top y] From 400840fa43687e553d61c9868e98270f87d6243b Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 19 Apr 2009 22:20:46 +0000 Subject: [PATCH 50/66] added back in support for the with-border? flag svn: r14561 original commit: 104dde2a08f6e96289ce2f825f4760bd52f58fba --- .../framework/private/decorated-editor-snip.ss | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/collects/framework/private/decorated-editor-snip.ss b/collects/framework/private/decorated-editor-snip.ss index f495ee35..969e76c4 100644 --- a/collects/framework/private/decorated-editor-snip.ss +++ b/collects/framework/private/decorated-editor-snip.ss @@ -22,6 +22,9 @@ (define editor-snip:decorated-mixin (mixin ((class->interface editor-snip%)) (editor-snip:decorated<%>) + (init [with-border? #t]) + (define draw-border? with-border?) + ;; get-corner-bitmap : -> (union #f (is-a?/c bitmap%)) ;; returns the bitmap to be shown in the top right corner. (define/public (get-corner-bitmap) #f) @@ -152,13 +155,14 @@ (+ x (unbox bil) 2) (+ y (unbox bmt)))]))) - (send dc set-pen (get-pen)) - (send dc set-brush (get-brush)) - (send dc draw-rectangle - (+ x (unbox bil)) - (+ y (unbox bit)) - (max 0 (- (unbox bw) (unbox bil) (unbox bir))) - (max 0 (- (unbox bh) (unbox bit) (unbox bib)))) + (when draw-border? + (send dc set-pen (get-pen)) + (send dc set-brush (get-brush)) + (send dc draw-rectangle + (+ x (unbox bil)) + (+ y (unbox bit)) + (max 0 (- (unbox bw) (unbox bil) (unbox bir))) + (max 0 (- (unbox bh) (unbox bit) (unbox bib))))) (send dc set-pen old-pen) (send dc set-brush old-brush)))) From 0b88d2cdfe0fab512a5bdf590bee46bff2c876e2 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 20 Apr 2009 07:46:50 +0000 Subject: [PATCH 51/66] its typos svn: r14562 original commit: 9c0f6bc775226aa9bbbd96d16e978f20bc1b1103 --- collects/scribblings/framework/scheme.scrbl | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/scribblings/framework/scheme.scrbl b/collects/scribblings/framework/scheme.scrbl index e7f1c5bd..3534b8a1 100644 --- a/collects/scribblings/framework/scheme.scrbl +++ b/collects/scribblings/framework/scheme.scrbl @@ -57,7 +57,7 @@ The result of this method is used to determine if the return key automatically tabs over to the correct position. - Override it to change it's behavior. + Override it to change its behavior. } @@ -199,7 +199,7 @@ } @defmethod*[(((mark-matching-parenthesis (pos exact-positive-integer)) void))]{ If the paren after @scheme[pos] is matched, this method - highlights it and it's matching counterpart in dark green. + highlights it and its matching counterpart in dark green. } @defmethod*[(((get-tab-size) exact-integer))]{ From 712ece9ead811046802abcc7810be252ba660281 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 20 Apr 2009 07:55:41 +0000 Subject: [PATCH 52/66] bar typos svn: r14564 original commit: d9ae39c2182b5538d40138f71105598b5539847c --- collects/scribblings/framework/color.scrbl | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/scribblings/framework/color.scrbl b/collects/scribblings/framework/color.scrbl index 59b53cda..b796f2ee 100644 --- a/collects/scribblings/framework/color.scrbl +++ b/collects/scribblings/framework/color.scrbl @@ -71,7 +71,7 @@ closing parenthesis, each closing symbol in pairs will be converted to a string and tried as a closing parenthesis. } - @defmethod*[(((stop-colorer (clear-colors boolean |#t|)) void))]{ + @defmethod*[(((stop-colorer (clear-colors boolean #t)) void))]{ Stops coloring and paren matching the buffer. @@ -106,7 +106,7 @@ entire text is brought up-to-date. It must not be called on a locked text. } - @defmethod*[(((thaw-colorer (recolor boolean |#t|) (retokenize boolean |#f|)) void))]{ + @defmethod*[(((thaw-colorer (recolor boolean #t) (retokenize boolean #f)) void))]{ Start coloring a frozen buffer again. From 8ebb17fb2d329e6ad04b354ef8fe1ed0ec6b080e Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 20 Apr 2009 08:20:19 +0000 Subject: [PATCH 53/66] scheme expression typos svn: r14565 original commit: da4742700bbe8c680c0ef4ba7875d5b32b384005 --- collects/scribblings/framework/color.scrbl | 54 +++++++++------------- 1 file changed, 23 insertions(+), 31 deletions(-) diff --git a/collects/scribblings/framework/color.scrbl b/collects/scribblings/framework/color.scrbl index b796f2ee..c158f797 100644 --- a/collects/scribblings/framework/color.scrbl +++ b/collects/scribblings/framework/color.scrbl @@ -12,7 +12,7 @@ Starts tokenizing the buffer for coloring and parenthesis matching. - token-sym-style will be passed the first return symbol from get-token + @scheme[token-sym-style] will be passed the first return symbol from @scheme[get-token] and should return the style-name that the token should be colored. get-token takes an input port and returns the next token as 5 values: @@ -22,11 +22,11 @@ component of the token and may be used as such in the future.} @item{ A symbol describing the type of the token. This symbol is transformed - into a style-name via the token-sym->style argument. The symbols - 'white-space and 'comment have special meaning and should always be + into a style-name via the @scheme[token-sym->style] argument. The symbols + @scheme['white-space] and @scheme['comment] have special meaning and should always be returned for white space and comment tokens respectively. The symbol @scheme['no-color] can be used to indicate that although the token is not white - space, it should not be colored. The symbol 'eof must be used to + space, it should not be colored. The symbol @scheme['eof] must be used to indicate when all the tokens have been consumed.} @item{ A symbol indicating how the token should be treated by the paren @@ -36,7 +36,7 @@ @item{ The ending position of the token.}] - get-token will usually be implemented with a lexer using the + @scheme[get-token] will usually be implemented with a lexer using the @scheme[parser-tools/lex] library. get-token must obey the following invariants: @itemize[ @@ -44,7 +44,7 @@ Every position in the buffer must be accounted for in exactly one token.} @item{ - The token returned by get-token must rely only on the contents of the + The token returned by @scheme[get-token] must rely only on the contents of the input port argument. This means that the tokenization of some part of the input cannot depend on earlier parts of the input.} @item{ @@ -57,14 +57,14 @@ the buffer look like: @verbatim{" 1 2 3"} would result in a single string token modifying previous tokens. To - handle these situations, get-token must treat the first line as a + handle these situations, @scheme[get-token] must treat the first line as a single token.}] @scheme[pairs] is a list of different kinds of matching parens. The second value returned by get-token is compared to this list to see how the paren matcher should treat the token. An example: Suppose pairs is @scheme['((|(| |)|) (|[| |]|) (begin end))]. This means that there - are three kinds of parens. Any token which has 'begin as its second + are three kinds of parens. Any token which has @scheme['begin] as its second return value will act as an open for matching tokens with 'end. Similarly any token with @scheme['|]|] will act as a closing match for tokens with @scheme['|[|]. When trying to correct a mismatched @@ -75,7 +75,7 @@ Stops coloring and paren matching the buffer. - If clear-colors is true all the text in the buffer will have it's + If @scheme[clear-colors] is true all the text in the buffer will have its style set to Standard. } @defmethod*[(((force-stop-colorer (stop? boolean?)) void))]{ @@ -83,7 +83,7 @@ Intended for debugging purposes only. - stop? determines whether the system is being forced to stop or allowed + @scheme[stop?] determines whether the system is being forced to stop or allowed to wake back up. } @defmethod*[(((is-stopped?) boolean?))]{ @@ -96,13 +96,11 @@ and @method[color:text<%> thaw-colorer]. - } @defmethod*[(((freeze-colorer) void))]{ Keep the text tokenized and paren matched, but stop altering the colors. - - freeze-colorer will not return until the coloring/tokenization of the + @scheme[freeze-colorer] will not return until the coloring/tokenization of the entire text is brought up-to-date. It must not be called on a locked text. } @@ -110,13 +108,13 @@ Start coloring a frozen buffer again. - If recolor? is @scheme[#t], the text is re-colored. If it is - @scheme[#f] the text is not recolored. When recolor? is @scheme[#t], - retokenize? controls how the text is recolored. @scheme[#f] causes + If @scheme[recolor?] is @scheme[#t], the text is re-colored. If it is + @scheme[#f] the text is not recolored. When @scheme[recolor?] is @scheme[#t], + @scheme[retokenize?] controls how the text is recolored. @scheme[#f] causes the text to be entirely re-colored before thaw-colorer returns using the existing tokenization. @scheme[#t] causes the entire text to be retokenized and recolored from scratch. This will happen in the - background after the call to thaw-colorer returns. + background after the call to @scheme[thaw-colorer] returns. } @defmethod*[(((reset-region (start natural-number?) (end (union (quote end) natural-number?))) void))]{ @@ -134,19 +132,16 @@ @defmethod*[(((skip-whitespace (position natural-number?) (direction (symbols (quote forward) (quote backward))) (comments? boolean?)) natural-number?))]{ Returns the next non-whitespace character. - Starts from position and skips whitespace in the direction indicated - by direction. If comments? is true, comments are skipped as well as + by direction. If @scheme[comments?] is true, comments are skipped as well as whitespace. skip-whitespace determines whitespaces and comments by - comparing the token type to 'white-space and 'comment. + comparing the token type to @scheme['white-space] and @scheme['comment]. Must only be called while the tokenizer is started. } @defmethod*[(((backward-match (position natural-number?) (cutoff natural-number?)) (union natural-number? false?)))]{ - - - Skip all consecutive whitespaces and comments (using skip-whitespace) + Skip all consecutive whitespaces and comments (using @scheme[skip-whitespace]) immediately preceding the position. If the token at this position is a close, return the position of the matching open, or @scheme[#f] if there is none. If the token was an open, return @scheme[#f]. For any @@ -163,9 +158,7 @@ } @defmethod*[(((forward-match (position natural-number?) (cutoff natural-number?)) (union natural-number? false?)))]{ - - - Skip all consecutive whitespaces and comments (using skip-whitespace) + Skip all consecutive whitespaces and comments (using @scheme[skip-whitespace]) immediately following position. If the token at this position is an open, return the position of the matching close, or @scheme[#f] if there is none. For any other token, return the end of that token. @@ -174,12 +167,11 @@ } @defmethod*[(((insert-close-paren (position natural-number?) (char char?) (flash? boolean?) (fixup? boolean?)) void))]{ - Position is the place to put the parenthesis and char is the - parenthesis to be added. If fixup? is true, the right kind of closing + parenthesis to be added. If @scheme[fixup?] is true, the right kind of closing parenthesis will be chosen from the pairs list kept last passed to - start-colorer, otherwise char will be inserted, even if it is not the - right kind. If flash? is true the matching open parenthesis will be + @scheme[start-colorer], otherwise char will be inserted, even if it is not the + right kind. If @scheme[flash?] is true the matching open parenthesis will be flashed. } @defmethod*[(((classify-position (position natural-number?)) symbol?))]{ @@ -218,7 +210,7 @@ @defmixin[color:text-mode-mixin (mode:surrogate-text<%>) (color:text-mode<%>)]{ This mixin adds coloring functionality to the mode. - @defconstructor[((get-token lexer default-lexer) (token-sym->style (token $rightarrow$ string) |scheme(λ (x) "Standard"))|) (matches (listof (list/c symbol? symbol?)) null))]{ + @defconstructor[((get-token lexer default-lexer) (token-sym->style (token $rightarrow$ string) @scheme[(λ (x) "Standard")])|) (matches (listof (list/c symbol? symbol?)) null))]{ The arguments are passed to @method[color:text<%> start-colorer]. From acd0d9a47a42eeccd4286aab93610e26b4b25be8 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 20 Apr 2009 17:02:27 +0000 Subject: [PATCH 54/66] Unbalance | was breaking build. Revert if fixed wrong svn: r14568 original commit: 77ec85a66ba3751d2d8ebb3ab8d192cc09a80746 --- collects/scribblings/framework/color.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribblings/framework/color.scrbl b/collects/scribblings/framework/color.scrbl index c158f797..c4b8641b 100644 --- a/collects/scribblings/framework/color.scrbl +++ b/collects/scribblings/framework/color.scrbl @@ -210,7 +210,7 @@ @defmixin[color:text-mode-mixin (mode:surrogate-text<%>) (color:text-mode<%>)]{ This mixin adds coloring functionality to the mode. - @defconstructor[((get-token lexer default-lexer) (token-sym->style (token $rightarrow$ string) @scheme[(λ (x) "Standard")])|) (matches (listof (list/c symbol? symbol?)) null))]{ + @defconstructor[((get-token lexer default-lexer) (token-sym->style (token $rightarrow$ string) |@scheme[(λ (x) "Standard")])|) (matches (listof (list/c symbol? symbol?)) null))]{ The arguments are passed to @method[color:text<%> start-colorer]. From 41d4c583a6a4607388feedfac625d71d6cb32569 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 21 Apr 2009 16:37:25 +0000 Subject: [PATCH 55/66] snip and editor-data class lists need to be eventspace-specific svn: r14575 original commit: 4bc2ddaf9d73ad6865b3059b995a15389f56f39a --- collects/mred/mred.ss | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/collects/mred/mred.ss b/collects/mred/mred.ss index 0ba30ed8..de283d13 100644 --- a/collects/mred/mred.ss +++ b/collects/mred/mred.ss @@ -74,6 +74,11 @@ (namespace-require 'scheme/class)) ns)) + (define (make-eventspace) + (parameterize ([wx:the-snip-class-list (wx:make-the-snip-class-list)] + [wx:the-editor-data-class-list (wx:make-the-editor-data-class-list)]) + (wx:make-eventspace))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-syntax propagate @@ -139,7 +144,6 @@ is-color-display? key-event% keymap% - make-eventspace editor-admin% editor-set-x-selection-mode editor-snip-editor-admin<%> @@ -307,6 +311,7 @@ current-eventspace-has-standard-menus? current-eventspace-has-menu-root? eventspace-handler-thread + make-eventspace make-gui-namespace make-gui-empty-namespace file-creator-and-type From 686d1ebd18e84d88b02626574e24c67953a9191e Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 22 Apr 2009 09:21:54 +0000 Subject: [PATCH 56/66] fix a subtle bug (canvas could be #f) svn: r14584 original commit: 64b59f2b288871b1482da2c7e583037cce0abc7f --- collects/framework/private/frame.ss | 19 ++++++++----------- 1 file changed, 8 insertions(+), 11 deletions(-) diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index b07f7797..e1db4bb9 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -2096,17 +2096,14 @@ (send (send find-edit get-canvas) focus)))) (define/public (unhide-search-and-toggle-focus) - (cond - [hidden? - (unhide-search #t)] - [(or (not text-to-search) - (send (send text-to-search get-canvas) has-focus?)) - (send find-edit set-position 0 (send find-edit last-position)) - (send find-canvas focus)] - [else - (let ([canvas (send text-to-search get-canvas)]) - (when canvas - (send canvas focus)))])) + (if hidden? + (unhide-search #t) + (let ([canvas (and text-to-search (send text-to-search get-canvas))]) + (cond + [(or (not text-to-search) (and canvas (send canvas has-focus?))) + (send find-edit set-position 0 (send find-edit last-position)) + (send find-canvas focus)] + [canvas (send canvas focus)])))) (define/public (search searching-direction) (unhide-search #f) From b6df675849601c2ff33ac08ed533b63ed7ce56cb Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 22 Apr 2009 18:30:35 +0000 Subject: [PATCH 57/66] fix typos (incl PRs 10213, 10214) svn: r14585 original commit: 43fe904fe5365496026d6021f9306661695f0981 --- collects/scribblings/framework/color.scrbl | 22 +++++++++++++++------- 1 file changed, 15 insertions(+), 7 deletions(-) diff --git a/collects/scribblings/framework/color.scrbl b/collects/scribblings/framework/color.scrbl index c4b8641b..50fb4088 100644 --- a/collects/scribblings/framework/color.scrbl +++ b/collects/scribblings/framework/color.scrbl @@ -8,14 +8,20 @@ This interface describes how coloring is stopped and started for text that knows how to color itself. It also describes how to query the lexical and s-expression structure of the text. - @defmethod*[(((start-colorer (token-sym-style (-> symbol? string?)) (get-token (-> input-port? (values any? symbol? (union false? symbol?) natural-number? natural-number?))) (pairs (listof (list/p symbol? symbol?)))) void))]{ + @defmethod*[(((start-colorer (token-sym->style (-> symbol? string?)) + (get-token (-> input-port? (values any/c + symbol? + (or/c false? symbol?) + exact-nonnegative-integer? + exact-nonnegative-integer?))) + (pairs (listof (list/p symbol? symbol?)))) void))]{ Starts tokenizing the buffer for coloring and parenthesis matching. - @scheme[token-sym-style] will be passed the first return symbol from @scheme[get-token] + The @scheme[token-sym->style] argument will be passed the first return symbol from @scheme[get-token] and should return the style-name that the token should be colored. - get-token takes an input port and returns the next token as 5 values: + The @scheme[get-token] argument takes an input port and returns the next token as 5 values: @itemize[ @item{ An unused value. This value is intended to represent the textual @@ -36,7 +42,7 @@ @item{ The ending position of the token.}] - @scheme[get-token] will usually be implemented with a lexer using the + The @scheme[get-token] function will usually be implemented with a lexer using the @scheme[parser-tools/lex] library. get-token must obey the following invariants: @itemize[ @@ -60,12 +66,12 @@ handle these situations, @scheme[get-token] must treat the first line as a single token.}] - @scheme[pairs] is a list of different kinds of matching parens. The second + The @scheme[pairs] argument is a list of different kinds of matching parens. The second value returned by get-token is compared to this list to see how the paren matcher should treat the token. An example: Suppose pairs is @scheme['((|(| |)|) (|[| |]|) (begin end))]. This means that there are three kinds of parens. Any token which has @scheme['begin] as its second - return value will act as an open for matching tokens with 'end. + return value will act as an open for matching tokens with @scheme['end]. Similarly any token with @scheme['|]|] will act as a closing match for tokens with @scheme['|[|]. When trying to correct a mismatched closing parenthesis, each closing symbol in pairs will be converted to @@ -210,7 +216,9 @@ @defmixin[color:text-mode-mixin (mode:surrogate-text<%>) (color:text-mode<%>)]{ This mixin adds coloring functionality to the mode. - @defconstructor[((get-token lexer default-lexer) (token-sym->style (token $rightarrow$ string) |@scheme[(λ (x) "Standard")])|) (matches (listof (list/c symbol? symbol?)) null))]{ + @defconstructor[((get-token lexer default-lexer) + (token-sym->style (symbol? . -> . string?) (λ (x) "Standard")) + (matches (listof (list/c symbol? symbol?)) null))]{ The arguments are passed to @method[color:text<%> start-colorer]. From 71e8dd3a1c4d743387a842c8803dc2ac3b23dcd9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 24 Apr 2009 21:54:28 +0000 Subject: [PATCH 58/66] raise canvas scroll limits to 1B instead of 10k svn: r14605 original commit: a542660087b7598511392eb83444954eef872f09 --- collects/scribblings/gui/canvas-class.scrbl | 28 ++++++++++----------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/collects/scribblings/gui/canvas-class.scrbl b/collects/scribblings/gui/canvas-class.scrbl index e64cfb96..1c05ac8d 100644 --- a/collects/scribblings/gui/canvas-class.scrbl +++ b/collects/scribblings/gui/canvas-class.scrbl @@ -111,7 +111,7 @@ When tab-focus is enabled for a canvas, Tab, arrow, and Enter keyboard @defmethod[(get-scroll-page [which (one-of/c 'horizontal 'vertical)]) - (integer-in 1 10000)]{ + (integer-in 1 1000000000)]{ Get the current page step size of a manual scrollbar. The result is @scheme[0] if the scrollbar is not active or it is automatic. @@ -126,7 +126,7 @@ See also @defmethod[(get-scroll-pos [which (one-of/c 'horizontal 'vertical)]) - (integer-in 0 10000)]{ + (integer-in 0 1000000000)]{ Gets the current value of a manual scrollbar. The result is always @scheme[0] if the scrollbar is not active or it is automatic. @@ -141,7 +141,7 @@ See also @defmethod[(get-scroll-range [which (one-of/c 'horizontal 'vertical)]) - (integer-in 0 10000)]{ + (integer-in 0 1000000000)]{ Gets the current maximum value of a manual scrollbar. The result is always @scheme[0] if the scrollbar is not active or it is automatic. @@ -183,8 +183,8 @@ Gets the size in device units of the scrollable canvas area (as } -@defmethod[(init-auto-scrollbars [horiz-pixels (or/c (integer-in 1 10000) false/c)] - [vert-pixels (or/c (integer-in 1 10000) false/c)] +@defmethod[(init-auto-scrollbars [horiz-pixels (or/c (integer-in 1 1000000000) false/c)] + [vert-pixels (or/c (integer-in 1 1000000000) false/c)] [h-value (real-in 0.0 1.0)] [v-value (real-in 0.0 1.0)]) void?]{ @@ -222,12 +222,12 @@ See also } -@defmethod[(init-manual-scrollbars [h-length (or/c (integer-in 0 10000) false/c)] - [v-length (or/c (integer-in 0 10000) false/c)] - [h-page (integer-in 1 10000)] - [v-page (integer-in 1 10000)] - [h-value (integer-in 0 10000)] - [v-value (integer-in 0 10000)]) +@defmethod[(init-manual-scrollbars [h-length (or/c (integer-in 0 1000000000) false/c)] + [v-length (or/c (integer-in 0 1000000000) false/c)] + [h-page (integer-in 1 1000000000)] + [v-page (integer-in 1 1000000000)] + [h-value (integer-in 0 1000000000)] + [v-value (integer-in 0 1000000000)]) void?]{ Enables and initializes manual scrollbars for the canvas. A @@ -319,7 +319,7 @@ See also @defmethod[(set-scroll-page [which (one-of/c 'horizontal 'vertical)] - [value (integer-in 1 10000)]) + [value (integer-in 1 1000000000)]) void?]{ Set the current page step size of a manual scrollbar. (This method has @@ -336,7 +336,7 @@ See also @defmethod[(set-scroll-pos [which (one-of/c 'horizontal 'vertical)] - [value (integer-in 0 10000)]) + [value (integer-in 0 1000000000)]) void?]{ Sets the current value of a manual scrollbar. (This method has no @@ -356,7 +356,7 @@ See also @defmethod[(set-scroll-range [which (one-of/c 'horizontal 'vertical)] - [value (integer-in 0 10000)]) + [value (integer-in 0 1000000000)]) void?]{ Sets the current maximum value of a manual scrollbar. (This method has From 603e6d11fc80ef9b3abebedb0a507dd7762c21ca Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 25 Apr 2009 13:21:50 +0000 Subject: [PATCH 59/66] svn: r14607 original commit: 6ce301f3c8962a08e6d3ed3a5ef5f89cdfe737f1 --- collects/scribblings/gui/snip-class.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribblings/gui/snip-class.scrbl b/collects/scribblings/gui/snip-class.scrbl index 2a9faf18..02cfdf68 100644 --- a/collects/scribblings/gui/snip-class.scrbl +++ b/collects/scribblings/gui/snip-class.scrbl @@ -834,7 +834,7 @@ The snip's editor is usually internally locked for reading when this @methimpl{ -Creates a new @scheme[snip%] instance while @scheme[position] +Creates a new @scheme[snip%] instance with @scheme[position] elements, and modifies @this-obj[] to decrement its count by @scheme[position]. The nest snip is installed into @scheme[first] and @this-obj[] is installed into @scheme[second]. From ef3cf1eab8a799fb59133e85a791de49d192a510 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 26 Apr 2009 15:24:50 +0000 Subject: [PATCH 60/66] fix some editor lock tracking svn: r14614 original commit: 4141389b847687df4dc0d9d9141575f55c368338 --- collects/mred/private/wxme/text.ss | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/mred/private/wxme/text.ss b/collects/mred/private/wxme/text.ss index eb78bee8..34ed1131 100644 --- a/collects/mred/private/wxme/text.ss +++ b/collects/mred/private/wxme/text.ss @@ -4187,16 +4187,16 @@ (let ([at-start? (eq? (mline-snip line) snip1)] [at-end? (eq? (mline-last-snip line) snip2)] [wl? write-locked?] - [fl flow-locked?]) + [fl? flow-locked?]) (set! read-locked? #t) (set! write-locked? #t) (set! flow-locked? #t) (set-snip-flags! snip2 (add-flag (snip->flags snip2) CAN-SPLIT)) (let ([naya (send snip2 merge-with snip1)]) - (set! read-locked? #t) + (set! read-locked? #f) (set! write-locked? wl?) - (set! flow-locked? wl?) + (set! flow-locked? fl?) (if naya (begin From 0560c150d33aead0850a6ca554e951b592e504bb Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 26 Apr 2009 22:52:58 +0000 Subject: [PATCH 61/66] fix combo-field popdown arrow svn: r14617 original commit: 308afeabf4fde74b3cde71dec1ae604a10f941ab --- collects/mred/private/wxme/editor-canvas.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mred/private/wxme/editor-canvas.ss b/collects/mred/private/wxme/editor-canvas.ss index 7dab3fd1..a6f092d2 100644 --- a/collects/mred/private/wxme/editor-canvas.ss +++ b/collects/mred/private/wxme/editor-canvas.ss @@ -204,7 +204,7 @@ '(transparent) '(no-autoclear)) (keep-style style 'control-border) - (keep-style style 'combo-side) + (keep-style style 'combo) (keep-style style 'resize-corner)) name gl-config) From 9d944f835740ef3dd786e651ddba96cc8925dfa3 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 27 Apr 2009 13:02:49 +0000 Subject: [PATCH 62/66] fix undo of delete implied by insert over a selection svn: r14623 original commit: 30a3e8ced8ecf84790db87db1265086ed829c96f --- collects/mred/private/wxme/text.ss | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/collects/mred/private/wxme/text.ss b/collects/mred/private/wxme/text.ss index 34ed1131..388e30bf 100644 --- a/collects/mred/private/wxme/text.ss +++ b/collects/mred/private/wxme/text.ss @@ -1700,9 +1700,7 @@ (set! write-locked? #t) (if (not (can-delete? start (- end start))) - (begin - (set! write-locked? #f) - (set! flow-locked? #f)) + (set! write-locked? #f) (begin (on-delete start (- end start)) @@ -1917,11 +1915,11 @@ [([(make-alts exact-nonnegative-integer? (symbol-in start)) start] [(make-alts exact-nonnegative-integer? (symbol-in back)) [end 'back]] [any? [scroll-ok? #t]]) - (do-delete (if (symbol? start) startpos start) end scroll-ok?)] + (do-delete (if (symbol? start) startpos start) end #t scroll-ok?)] (method-name 'text% 'delete))) (def/public (erase) - (do-delete 0 len #t)) + (do-delete 0 len #t #t)) (def/override (clear) (delete startpos endpos #t)) From e006bca48a1b2b5ab3095043bbae9df938c353f2 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 27 Apr 2009 14:32:30 +0000 Subject: [PATCH 63/66] svn: r14624 original commit: 955f99fe4176d843fc9c49b645e7aaac37b83066 --- collects/framework/private/main.ss | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/framework/private/main.ss b/collects/framework/private/main.ss index 97a074b8..fc55c8ef 100644 --- a/collects/framework/private/main.ss +++ b/collects/framework/private/main.ss @@ -58,6 +58,7 @@ ("cond" 0) ("field" 0) ("provide/contract" 0) + ("match" 1) ("new" 1) ("case" 1) ("syntax-rules" 1) From a114423cef102b168594f176cb20e5048661ebc5 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 30 Apr 2009 23:15:10 +0000 Subject: [PATCH 64/66] improvements to the preferences dialog svn: r14670 original commit: 1cb53bdf2a273d9d2e8bd8036dbaaa7d6adac9ef --- collects/framework/private/preferences.ss | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/framework/private/preferences.ss b/collects/framework/private/preferences.ss index c2a10f40..03de7025 100644 --- a/collects/framework/private/preferences.ss +++ b/collects/framework/private/preferences.ss @@ -467,7 +467,8 @@ the state transitions / contracts are: (string-constant automatically-to-ps) (λ (b) (if b 'postscript 'standard)) - (λ (n) (eq? 'postscript n)))))))]) + (λ (n) (eq? 'postscript n)))) + (general-panel-procs editor-panel))))]) (add-general-checkbox-panel))) (define (add-warnings-checkbox-panel) From 424dcbc9c2e818245f1bb3c7019a5c3a70d7eabb Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 1 May 2009 21:02:51 +0000 Subject: [PATCH 65/66] removed lots of "the the"s svn: r14679 original commit: ff73a5395ee00699c7b85d6ed20bbc3e5d9a2957 --- collects/embedded-gui/doc.txt | 4 ++-- collects/embedded-gui/private/aligned-pasteboard.ss | 2 +- collects/embedded-gui/private/interface.ss | 2 +- collects/embedded-gui/private/verthoriz-alignment.ss | 2 +- collects/embedded-gui/scribblings/alignment-parent.scrbl | 2 +- collects/framework/main.ss | 2 +- collects/framework/private/text.ss | 2 +- collects/mrlib/scribblings/graph/graph-pasteboard-intf.scrbl | 2 +- collects/mrlib/scribblings/name-message.scrbl | 2 +- collects/scribblings/framework/text.scrbl | 2 +- collects/tests/mred/canvas-steps.txt | 2 +- collects/tests/mred/draw-info.txt | 4 ++-- 12 files changed, 14 insertions(+), 14 deletions(-) diff --git a/collects/embedded-gui/doc.txt b/collects/embedded-gui/doc.txt index f696e62c..f528ab78 100644 --- a/collects/embedded-gui/doc.txt +++ b/collects/embedded-gui/doc.txt @@ -93,8 +93,8 @@ Add the given alignment as a child after the existing child > (send an-alignment-parent delete-child child) -> void child : (is-a?/c alignment<%>) -Deletes a child from the the alignments - +Deletes a child from the alignments + > (send an-alignment-parent is-shown?) -> boolean? True if the alignment is being shown (accounting for its parent being shown) diff --git a/collects/embedded-gui/private/aligned-pasteboard.ss b/collects/embedded-gui/private/aligned-pasteboard.ss index 363b9d27..b742f880 100644 --- a/collects/embedded-gui/private/aligned-pasteboard.ss +++ b/collects/embedded-gui/private/aligned-pasteboard.ss @@ -74,7 +74,7 @@ (set! alignment child)))) #;((is-a?/c alignment<%>) . -> . void?) - ;; Deletes a child from the the alignments + ;; Deletes a child from the alignments (define/public (delete-child child) (if alignment (if (eq? child alignment) diff --git a/collects/embedded-gui/private/interface.ss b/collects/embedded-gui/private/interface.ss index cb41a94b..bbc1b498 100644 --- a/collects/embedded-gui/private/interface.ss +++ b/collects/embedded-gui/private/interface.ss @@ -66,7 +66,7 @@ add-child #;((is-a?/c alignment<%>) . -> . void?) - ;; Deletes a child from the the alignments + ;; Deletes a child from the alignments delete-child #;(-> boolean?) diff --git a/collects/embedded-gui/private/verthoriz-alignment.ss b/collects/embedded-gui/private/verthoriz-alignment.ss index def03e25..145c7322 100644 --- a/collects/embedded-gui/private/verthoriz-alignment.ss +++ b/collects/embedded-gui/private/verthoriz-alignment.ss @@ -137,7 +137,7 @@ (link (send tail prev) child tail)))) #;((is-a?/c alignment<%>) . -> . void?) - ;; Deletes a child from the the alignments + ;; Deletes a child from the alignments (define/public (delete-child child) (send child show/hide false) (let ([p (send child prev)] diff --git a/collects/embedded-gui/scribblings/alignment-parent.scrbl b/collects/embedded-gui/scribblings/alignment-parent.scrbl index 4cbf614f..9e2d5ad1 100644 --- a/collects/embedded-gui/scribblings/alignment-parent.scrbl +++ b/collects/embedded-gui/scribblings/alignment-parent.scrbl @@ -13,7 +13,7 @@ Add the given alignment as a child after the existing child.} @defmethod[(delete-child [child (is-a?/c alignment<%>)]) void?]{ -Deletes a child from the the alignments.} +Deletes a child from the alignments.} @defmethod[(is-shown?) boolean?]{ diff --git a/collects/framework/main.ss b/collects/framework/main.ss index c85f5de8..3ef72157 100644 --- a/collects/framework/main.ss +++ b/collects/framework/main.ss @@ -1428,7 +1428,7 @@ This function is not symmetric in red, green, and blue, so it is important to pass red, green, and blue components of the colors in - the the proper order. The first three arguments are red, green and + the proper order. The first three arguments are red, green and blue for the first color, respectively, and the second three arguments are red green and blue for the second color, respectively.}) diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index 391bf360..f2e48fd1 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -382,7 +382,7 @@ WARNING: printf is rebound in the body of the unit to always (and (string? color) (send the-color-database find-color color))) (error 'highlight-range - "expected a color or a string in the the-color-database for the third argument, got ~e" color)) + "expected a color or a string in the-color-database for the third argument, got ~e" color)) (unless (memq style '(rectangle hollow-ellipse ellipse dot)) (error 'highlight-range "expected one of 'rectangle, 'ellipse 'hollow-ellipse, or 'dot as the style, got ~e" style)) diff --git a/collects/mrlib/scribblings/graph/graph-pasteboard-intf.scrbl b/collects/mrlib/scribblings/graph/graph-pasteboard-intf.scrbl index 00b32bbe..13a4c7f8 100644 --- a/collects/mrlib/scribblings/graph/graph-pasteboard-intf.scrbl +++ b/collects/mrlib/scribblings/graph/graph-pasteboard-intf.scrbl @@ -98,7 +98,7 @@ destination snip's bounding box where a straight line between the centers of the snip would intersect. The @scheme[arrow-point-ok?] function returns @scheme[#t] -when the point specified by its arguments is inside the the +when the point specified by its arguments is inside the smallest rectangle that covers both the source and destination snips, but is outside of both of the rectangles that surround the source and destination snips themselves. diff --git a/collects/mrlib/scribblings/name-message.scrbl b/collects/mrlib/scribblings/name-message.scrbl index a63945bb..9f7c790c 100644 --- a/collects/mrlib/scribblings/name-message.scrbl +++ b/collects/mrlib/scribblings/name-message.scrbl @@ -67,7 +67,7 @@ saying that there is no file name until the file is saved.} @defmethod[(get-background-color) (or/c false/c (is-a/c color%) string?)]{ The result of this method is used for the background color -when redrawing the the name message. If it is @scheme[#f], the +when redrawing the name message. If it is @scheme[#f], the OS's default panel background is used. } diff --git a/collects/scribblings/framework/text.scrbl b/collects/scribblings/framework/text.scrbl index cece0eb2..8dcb5ed6 100644 --- a/collects/scribblings/framework/text.scrbl +++ b/collects/scribblings/framework/text.scrbl @@ -387,7 +387,7 @@ @method[text:searching<%> set-replace-start]) and the closest search hit following @tt{replace-start} does not collapse with an adjacent bubble,the result will include - that bubble. If the the closest search hit after + that bubble. If the closest search hit after @tt{replace-start} is collpased with another bubble, then the search hit is not reflected in the result. diff --git a/collects/tests/mred/canvas-steps.txt b/collects/tests/mred/canvas-steps.txt index 3b5a5a3e..c7736642 100644 --- a/collects/tests/mred/canvas-steps.txt +++ b/collects/tests/mred/canvas-steps.txt @@ -128,7 +128,7 @@ Move all scrolls to 1 step beyond the smallest setting. Check "swap". Now, the top canvas is managed and the bottom canvas is unmanaged. But the top canvas's area is so small that its scrollbars are always disabled. (It may also be clipped to the tiny 10x10 box.) - The bottom canvas's scrollbars should now act the the top ones used + The bottom canvas's scrollbars should now act the top ones used to: there are 20 steps in each direction and the `V:' and `H:' values change as the scrolls are moved. diff --git a/collects/tests/mred/draw-info.txt b/collects/tests/mred/draw-info.txt index 382d223f..59297dc8 100644 --- a/collects/tests/mred/draw-info.txt +++ b/collects/tests/mred/draw-info.txt @@ -38,7 +38,7 @@ The drawing area should have the following features: pattern; the third shape should be a semi-circle with no outline on the bottom edge. - Further right (to the the right of the columns) should appear an + Further right (to the right of the columns) should appear an X, a cross, and an narrow X tilted NW. Each should be drawn in green (5 pixels wide) with a thin black line centered along each green line. Scaling the picture should make the green line thicker, @@ -208,7 +208,7 @@ Clipping should slip the drawing to a particular shape: wedge - pi/4 to 3pi/4 of circle - round rectangle - a rounded rect inscribed in the the blue box for + round rectangle - a rounded rect inscribed in the blue box for testing stipples unions, intersects, subtracts - hopefully obvious From ec340175e9d08f9ead6d45b54f2f181dd1bd1e9b Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 4 May 2009 09:34:07 +0000 Subject: [PATCH 66/66] some typos svn: r14709 original commit: 8b4844cf5ea7020bdb3d7f7d0cff715ce1141bfe --- collects/framework/preferences.ss | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/framework/preferences.ss b/collects/framework/preferences.ss index 0671752a..22a4e13c 100644 --- a/collects/framework/preferences.ss +++ b/collects/framework/preferences.ss @@ -355,7 +355,7 @@ the state transitions / contracts are: ((p f) ((weak? #f))) @{This function adds a callback which is called with a symbol naming a - preference and it's value, when the preference changes. + preference and its value, when the preference changes. @scheme[preferences:add-callback] returns a thunk, which when invoked, removes the callback from this preference. @@ -406,7 +406,7 @@ the state transitions / contracts are: preferences to turn the preference value for @scheme[symbol] into a printable value. @scheme[unmarshall] will be called when the user's preferences are read from the file to transform the printable value - into it's internal representation. If @scheme[preference:set-un/marshall] + into its internal representation. If @scheme[preference:set-un/marshall] is never called for a particular preference, the values of that preference are assumed to be printable. @@ -450,7 +450,7 @@ the state transitions / contracts are: (parameter/c (-> (listof symbol?) (listof any/c) any)) put-preference @{This parameter's value - is called when to save preference the preferences. Its interface should + is called to save preference the preferences. Its interface should be just like mzlib's @scheme[put-preference].}) (proc-doc/names @@ -477,7 +477,7 @@ the state transitions / contracts are: @{Caches all of the current values of the preferences and returns them. For any preference that has marshalling and unmarshalling set (see @scheme[preferences:set-un/marshall]), the preference value is - copied by passing it thru the marshalling and unmarshalling process. + copied by passing it through the marshalling and unmarshalling process. Other values are not copied, but references to them are instead saved. See also @scheme[preferences:restore-prefs-snapshot].}))