diff --git a/collects/mred/edit.ss b/collects/mred/edit.ss index 87b4b083..5a1a7c70 100644 --- a/collects/mred/edit.ss +++ b/collects/mred/edit.ss @@ -1,7 +1,12 @@ (define-sigfunctor (mred:edit@ mred:edit^) - (import mred:finder^ mred:path-utils^ mred:mode^ mred:scheme-paren^ + (import mred:debug^ mred:finder^ mred:path-utils^ mred:mode^ mred:scheme-paren^ mred:keymap^ mzlib:function^) + (define first car) + (define second cadr) + (define third caddr) + (define fourth cadddr) + (define make-std-buffer% (lambda (buffer%) (class buffer% args @@ -162,6 +167,8 @@ on-default-char on-default-event set-file-format get-style-list) (rename [super-on-focus on-focus] + [super-on-paint on-paint] + [super-after-set-position after-set-position] [super-on-local-event on-local-event] [super-on-local-char on-local-char] [super-on-insert on-insert] @@ -212,8 +219,82 @@ [after-delete (lambda (start len) (if mode (send mode after-delete this start len)) - (super-after-delete start len))]) + (super-after-delete start len))] + [after-set-position + (lambda () + (when mode + (send mode after-set-position this)) + (super-after-set-position))] + + [ranges (list (list 4 24 '... '...))] + [add-range + (lambda (start end b/w-pattern color-pattern) + (let ([l (list start end b/w-pattern color-pattern)]) + (set! ranges (cons l ranges)) + (lambda () (set! ranges + (let loop ([r ranges]) + (cond + [(null? r) r] + [else (if (eq? (car r) l) + (cdr r) + (cons (car r) (loop (cdr r))))]))))))] + [range-rectangles null] + [recompute-range-rectangles + (lambda () + (let ([new-rectangles + (lambda (start end b/w color) + (let ([left 0] + [right 1000] + [top-start-x (box 0)] + [top-start-y (box 0)] + [bottom-start-x (box 0)] + [bottom-start-y (box 0)] + [top-end-x (box 0)] + [top-end-y (box 0)] + [bottom-end-x (box 0)] + [bottom-end-y (box 0)]) + (send this position-location start top-start-x top-start-y #t #f #t) + (send this position-location end top-end-x top-end-y #t #t #t) + (send this position-location start bottom-start-x bottom-start-y #f #f #t) + (send this position-location end bottom-end-x bottom-end-y #f #t #t) + (cond + [(= (unbox top-start-y) (unbox top-end-y)) + (list (list (unbox top-start-x) (unbox top-start-y) + (- (unbox bottom-end-x) (unbox top-start-x)) + (- (unbox bottom-end-y) (unbox top-start-y))))] + [else + (list (list (unbox top-start-x) (unbox top-start-y) + (- right (unbox top-start-x)) + (- (unbox bottom-start-y) (unbox top-start-y))) + (list (unbox bottom-start-x) left + (- right left) (- (unbox bottom-start-x) (unbox top-end-x))) + (list left (unbox top-end-y) + (- (unbox top-end-x) left) + (- (unbox bottom-end-y) (unbox top-end-y))))])))]) + (set! range-rectangles (map (lambda (x) (apply new-rectangles x)) ranges)) + (printf "~a~n" range-rectangles)))] + [on-paint + (lambda (before dc left top right bottom dx dy draw-caret) + (when #f + (for-each (lambda (rlist) + (for-each (lambda (rectangle) + (let ([pen (make-object wx:pen% "black" 1 1)] + [brush (make-object wx:brush% "black" wx:const-transparent)] + [old-pen (send dc get-pen)] + [old-brush (send dc get-brush)]) + (send dc set-pen pen) + (send dc set-brush brush) + (send dc draw-rectangle + (+ (first rectangle) dx) + (+ (second rectangle) dy) + (+ (third rectangle) dx) + (+ (fourth rectangle) dy)) + (send dc set-pen old-pen) + (send dc set-brush old-brush))) + rlist)) + range-rectangles)) + (super-on-paint before dc left top right bottom dx dy draw-caret))]) (sequence (apply super-init args) (send edits add this) diff --git a/collects/mred/exit.ss b/collects/mred/exit.ss index 6c5234dd..0c83b446 100644 --- a/collects/mred/exit.ss +++ b/collects/mred/exit.ss @@ -2,7 +2,7 @@ ;; exit doesn't actually exit, now. (define-sigfunctor (mred:exit@ mred:exit^) - (import) + (import mred:debug^) (rename (-exit exit)) (define exit-callbacks '()) @@ -30,7 +30,8 @@ [(not ((car cb-list))) cb-list] [else (loop (cdr cb-list))]))) (if (null? exit-callbacks) - (begin (exit) + (begin (when mred:debug^:exit? + (exit)) #t) #f)))) diff --git a/collects/mred/finder.ss b/collects/mred/finder.ss index dc6216cd..4c5f4109 100644 --- a/collects/mred/finder.ss +++ b/collects/mred/finder.ss @@ -1,5 +1,5 @@ (define-sigfunctor (mred:finder@ mred:finder^) - (import mzlib:string^ mzlib:function^ mzlib:file^) + (import mred:debug^ mzlib:string^ mzlib:function^ mzlib:file^) (define filter-match? (lambda (filter name msg) diff --git a/collects/mred/keys.ss b/collects/mred/keys.ss index 187c05b6..561a5e3b 100644 --- a/collects/mred/keys.ss +++ b/collects/mred/keys.ss @@ -1,7 +1,7 @@ (define-sigfunctor (mred:keymap@ mred:keymap^) - (import mred:finder^ mred:handler^ mred:find-string^ mred:scheme-paren^) + (import mred:debug^ mred:finder^ mred:handler^ mred:find-string^ mred:scheme-paren^) - '(printf "mred:keymap@~n") + (mred:debug^:dprintf "mred:keymap@~n") ; This is a list of keys that are typed with the SHIFT key, but ; are not normally thought of as shifted. It will have to be