...
original commit: a17f24f190476e573d325c7bf7dd58159eb20e70
This commit is contained in:
Robby Findler
parent
244aa5dd7c
commit
abfbc1dfc4
|
|
@ -27,6 +27,25 @@
|
|||
refresh-delayed?
|
||||
get-canvas
|
||||
get-max-width get-admin set-filename)
|
||||
|
||||
(rename [super-begin-edit-sequence begin-edit-sequence]
|
||||
[super-end-edit-sequence end-edit-sequence])
|
||||
(private
|
||||
[edit-sequence-count 0])
|
||||
(override
|
||||
[begin-edit-sequence
|
||||
(lambda ()
|
||||
(set! edit-sequence-count (+ edit-sequence-count 1))
|
||||
(super-begin-edit-sequence))]
|
||||
[end-edit-sequence
|
||||
(lambda ()
|
||||
(set! edit-sequence-count (- edit-sequence-count 1))
|
||||
(when (< edit-sequence-count 0)
|
||||
(error 'end-edit-sequence "extra end-edit-sequence"))
|
||||
(super-end-edit-sequence))])
|
||||
|
||||
|
||||
|
||||
(rename [super-set-modified set-modified]
|
||||
[super-on-focus on-focus]
|
||||
[super-lock lock])
|
||||
|
|
@ -176,7 +195,7 @@
|
|||
[check-lock
|
||||
(lambda ()
|
||||
(let* ([filename (get-filename)]
|
||||
[lock? (and (not (null? filename))
|
||||
[lock? (and filename
|
||||
(file-exists? filename)
|
||||
(not (member
|
||||
'write
|
||||
|
|
|
|||
|
|
@ -141,8 +141,8 @@
|
|||
(unless (implementation? % <%>)
|
||||
(let ([name (inferred-name this)])
|
||||
(error (or name 'frame:editor%)
|
||||
"result of get-editor% method must match ~e class; got: ~e"
|
||||
% <%>)))
|
||||
"result of get-editor% method must match ~e interface; got: ~e"
|
||||
<%> %)))
|
||||
(make-object %)))])
|
||||
|
||||
|
||||
|
|
@ -451,6 +451,7 @@
|
|||
[super-root 'unitiaialized-super-root])
|
||||
(override
|
||||
[get-editor<%> (lambda () text:searching<%>)]
|
||||
[get-editor% (lambda () text:searching%)]
|
||||
[edit-menu:find (lambda (menu evt) (search))])
|
||||
(override
|
||||
[make-root-area-container
|
||||
|
|
@ -705,7 +706,8 @@
|
|||
r-root))])
|
||||
|
||||
(override
|
||||
[get-editor<%> (lambda () text:info<%>)])
|
||||
[get-editor<%> (lambda () text:info<%>)]
|
||||
[get-editor% (lambda () text:info%)])
|
||||
|
||||
(public
|
||||
[determine-width
|
||||
|
|
@ -766,13 +768,11 @@
|
|||
(set! icon-currently-locked? locked-now?)
|
||||
(let ([label
|
||||
(if locked-now?
|
||||
(cons (icon:get-lock-bdc)
|
||||
(icon:get-lock-bitmap))
|
||||
(cons (icon:get-unlock-bdc)
|
||||
(icon:get-unlock-bitmap)))])
|
||||
(icon:get-lock-bitmap)
|
||||
(icon:get-unlock-bitmap))])
|
||||
(send lock-message
|
||||
set-label
|
||||
(if (send (car label) ok?)
|
||||
(if (send label ok?)
|
||||
label
|
||||
(if locked-now? "Locked" "Unlocked"))))))))))])
|
||||
(public
|
||||
|
|
@ -835,7 +835,8 @@
|
|||
(border 3))
|
||||
(send* time-canvas
|
||||
(set-editor time-edit)
|
||||
(stretchable-width #f))
|
||||
(stretchable-width #f)
|
||||
(stretchable-height #f))
|
||||
(semaphore-wait time-semaphore)
|
||||
(determine-width wide-time time-canvas time-edit)
|
||||
(semaphore-post time-semaphore)
|
||||
|
|
@ -971,7 +972,6 @@
|
|||
"Overwrite"
|
||||
(get-info-panel))]
|
||||
[position-canvas (make-object editor-canvas% (get-info-panel) #f '(no-hscroll no-vscroll))]
|
||||
[_2 (send position-canvas set-line-count 1)]
|
||||
[position-edit (make-object text%)])
|
||||
|
||||
(inherit determine-width)
|
||||
|
|
@ -991,8 +991,10 @@
|
|||
(send anchor-message show #f)
|
||||
(send overwrite-message show #f)
|
||||
(send* position-canvas
|
||||
(set-line-count 1)
|
||||
(set-editor position-edit)
|
||||
(stretchable-width #f))
|
||||
(stretchable-width #f)
|
||||
(stretchable-height #f))
|
||||
(determine-width "0000:000-0000:000"
|
||||
position-canvas
|
||||
position-edit)
|
||||
|
|
|
|||
|
|
@ -195,11 +195,8 @@
|
|||
get-autowrap-bitmap
|
||||
|
||||
get-lock-bitmap
|
||||
get-lock-bdc
|
||||
get-unlock-bitmap
|
||||
get-unlock-bdc
|
||||
get-anchor-bitmap
|
||||
get-anchor-bdc
|
||||
|
||||
get-gc-on-bitmap
|
||||
get-gc-off-bitmap))
|
||||
|
|
|
|||
|
|
@ -6,44 +6,32 @@
|
|||
(collection-path "icons")))
|
||||
|
||||
(define (load-icon name type)
|
||||
(let ([p (build-path icon-path name)]
|
||||
[bitmap #f])
|
||||
(letrec ([p (build-path icon-path name)]
|
||||
[f
|
||||
(lambda ()
|
||||
(let ([bitmap (make-object bitmap% p type)])
|
||||
(set! f (lambda () bitmap))
|
||||
bitmap))])
|
||||
(unless (file-exists? p)
|
||||
(fprintf (current-error-port) "WARNING: couldn't find ~a~n" p))
|
||||
(lambda ()
|
||||
(if bitmap
|
||||
bitmap
|
||||
(begin (set! bitmap (make-object bitmap% p type))
|
||||
bitmap)))))
|
||||
(f))))
|
||||
|
||||
(define (load-bitmap/bdc name type)
|
||||
(let* ([p (build-path icon-path name)]
|
||||
[bitmap #f]
|
||||
[bitmap-dc #f]
|
||||
[force
|
||||
(lambda ()
|
||||
(set! bitmap (make-object bitmap% p type))
|
||||
(set! bitmap-dc (make-object bitmap-dc%))
|
||||
(when (send bitmap ok?)
|
||||
(send bitmap-dc set-bitmap bitmap)))])
|
||||
(define (load-bitmap name type)
|
||||
(letrec ([p (build-path icon-path name)]
|
||||
[f
|
||||
(lambda ()
|
||||
(let ([bitmap (make-object bitmap% p type)])
|
||||
(set! f (lambda () bitmap))
|
||||
bitmap))])
|
||||
(unless (file-exists? p)
|
||||
(fprintf (current-error-port) "WARNING: couldn't find ~a~n" p))
|
||||
(values
|
||||
(lambda ()
|
||||
(or bitmap
|
||||
(begin (force)
|
||||
bitmap)))
|
||||
(lambda ()
|
||||
(or bitmap-dc
|
||||
(begin (force)
|
||||
bitmap-dc))))))
|
||||
(lambda ()
|
||||
(f))))
|
||||
|
||||
(define-values (get-anchor-bitmap get-anchor-bdc)
|
||||
(load-bitmap/bdc "anchor.gif" 'gif))
|
||||
(define-values (get-lock-bitmap get-lock-bdc)
|
||||
(load-bitmap/bdc "lock.gif" 'gif))
|
||||
(define-values (get-unlock-bitmap get-unlock-bdc)
|
||||
(load-bitmap/bdc "unlock.gif" 'gif))
|
||||
(define-values (get-anchor-bitmap) (load-bitmap "anchor.gif" 'gif))
|
||||
(define-values (get-lock-bitmap) (load-bitmap "lock.gif" 'gif))
|
||||
(define-values (get-unlock-bitmap) (load-bitmap "unlock.gif" 'gif))
|
||||
|
||||
(define get-autowrap-bitmap (load-icon "return.xbm" 'xbm))
|
||||
(define get-paren-highlight-bitmap (load-icon "paren.xbm" 'xbm))
|
||||
|
|
|
|||
|
|
@ -111,10 +111,10 @@
|
|||
(let ([line (position-line position)])
|
||||
(ormap
|
||||
(lambda (comment-start)
|
||||
(let ([f (send find-string comment-start 'backward position)])
|
||||
(if (= -1 f)
|
||||
#f
|
||||
(= (send position-line f) line))))
|
||||
(let ([f (find-string comment-start 'backward position)])
|
||||
(if f
|
||||
(= (send position-line f) line)
|
||||
#f)))
|
||||
(scheme-paren:get-comments))))])
|
||||
(private
|
||||
[remove-indents-callback
|
||||
|
|
@ -145,19 +145,19 @@
|
|||
(override
|
||||
[on-focus
|
||||
(lambda (on?)
|
||||
(super-on-focus)
|
||||
(super-on-focus on?)
|
||||
(highlight-parens (not on?)))]
|
||||
[on-change-style
|
||||
(lambda (start len)
|
||||
(begin-edit-sequence)
|
||||
(super-on-change-style)
|
||||
(super-on-change-style start len)
|
||||
#t)]
|
||||
[after-change-style
|
||||
(lambda (start len)
|
||||
(end-edit-sequence)
|
||||
(unless (get-styles-fixed)
|
||||
(highlight-parens))
|
||||
(super-after-change-style))]
|
||||
(super-after-change-style start len))]
|
||||
[after-edit-sequence
|
||||
(lambda ()
|
||||
(unless in-highlight-parens?
|
||||
|
|
@ -166,17 +166,17 @@
|
|||
[on-insert
|
||||
(lambda (start size)
|
||||
(begin-edit-sequence)
|
||||
(super-on-insert))]
|
||||
(super-on-insert start size))]
|
||||
[after-insert
|
||||
(lambda (start size)
|
||||
(send backward-cache invalidate start)
|
||||
(send forward-cache forward-invalidate start size)
|
||||
(end-edit-sequence)
|
||||
(highlight-parens)
|
||||
(super-after-insert))]
|
||||
(super-after-insert start size))]
|
||||
[on-delete
|
||||
(lambda (start size)
|
||||
(and (super-on-delete)
|
||||
(and (super-on-delete start size)
|
||||
(begin
|
||||
(send backward-cache invalidate start)
|
||||
(send forward-cache forward-invalidate (+ start size) (- size))
|
||||
|
|
@ -186,8 +186,7 @@
|
|||
(lambda (start size)
|
||||
(super-after-delete start size)
|
||||
(end-edit-sequence)
|
||||
(highlight-parens)
|
||||
(super-after-delete))]
|
||||
(highlight-parens))]
|
||||
[on-set-size-constraint
|
||||
(lambda ()
|
||||
(and (super-on-set-size-constraint)
|
||||
|
|
@ -200,7 +199,8 @@
|
|||
(super-after-set-size-constraint))]
|
||||
[after-set-position
|
||||
(lambda ()
|
||||
(highlight-parens))])
|
||||
(highlight-parens)
|
||||
(super-after-set-position))])
|
||||
|
||||
(private
|
||||
[highlight-parens? (preferences:get 'framework:highlight-parens)]
|
||||
|
|
@ -212,12 +212,17 @@
|
|||
[find-enclosing-paren
|
||||
(lambda (pos)
|
||||
(let loop ([pos pos])
|
||||
(let ([paren-pos (apply max (map (lambda (pair) (find-string (car pair) -1 pos -1 #f))
|
||||
(let ([paren-pos (apply max (map (lambda (pair) (find-string
|
||||
(car pair)
|
||||
'backward
|
||||
pos
|
||||
'eof
|
||||
#f))
|
||||
(scheme-paren:get-paren-pairs)))])
|
||||
(cond
|
||||
[(= -1 paren-pos) #f]
|
||||
[else
|
||||
(let ([semi-pos (find-string ";" -1 paren-pos)])
|
||||
(let ([semi-pos (find-string ";" 'backward paren-pos)])
|
||||
(cond
|
||||
[(or (= -1 semi-pos)
|
||||
(< semi-pos (paragraph-start-position
|
||||
|
|
@ -266,7 +271,8 @@
|
|||
(let-values
|
||||
([(left right)
|
||||
(cond
|
||||
[(is-right-paren? (get-character (sub1 here)))
|
||||
[(and (> here 0)
|
||||
(is-right-paren? (get-character (sub1 here))))
|
||||
(cond
|
||||
[(slash? (- here 2) (- here 1)) (k (void))]
|
||||
[(scheme-paren:backward-match
|
||||
|
|
@ -643,7 +649,7 @@
|
|||
(lambda (paren-pair)
|
||||
(find-string
|
||||
(car paren-pair)
|
||||
-1
|
||||
'backward
|
||||
exp-pos))])
|
||||
|
||||
(if (and exp-pos (> exp-pos 0))
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
|
||||
(lambda (filename title width-default depth-default)
|
||||
(let/ec k
|
||||
(let*-values
|
||||
(letrec-values
|
||||
([(no-splash) (lambda () (k void void void))]
|
||||
[(splash-get-resource)
|
||||
(lambda (name default)
|
||||
|
|
@ -15,7 +15,7 @@
|
|||
(lambda (name value)
|
||||
(write-resource "mred" name value (find-graphical-system-path 'setup-file))
|
||||
)]
|
||||
[(_)
|
||||
[(_1)
|
||||
(begin
|
||||
(unless filename
|
||||
(no-splash))
|
||||
|
|
@ -25,7 +25,7 @@
|
|||
|
||||
[(splash-width-resource) (format "~a-splash-max-width" title)]
|
||||
[(splash-depth-resource) (format "~a-splash-max-depth" title)]
|
||||
[(splash-max-width) (splash-get-resource splash-width-resource width-default)]
|
||||
[(splash-max-width) (max 1 (splash-get-resource splash-width-resource width-default))]
|
||||
[(splash-max-depth) (splash-get-resource splash-depth-resource depth-default)]
|
||||
|
||||
[(splash-sofar-depth) 0]
|
||||
|
|
@ -69,10 +69,10 @@
|
|||
[(string-ci=? "pict" suffix) 'pict]
|
||||
[else 'xpm]))))]
|
||||
[(bitmap) (make-object bitmap% filename bitmap-flag)]
|
||||
[(_) (unless (send bitmap ok?)
|
||||
[(_2) (unless (send bitmap ok?)
|
||||
(fprintf (current-error-port) "WARNING: bad bitmap ~s" filename)
|
||||
(no-splash))]
|
||||
[(canvas%)
|
||||
[(splash-canvas%)
|
||||
(class canvas% args
|
||||
(inherit get-dc)
|
||||
(override
|
||||
|
|
@ -85,10 +85,14 @@
|
|||
(if (get-resource "mred" "splashMessages" b)
|
||||
(not (zero? (unbox b)))
|
||||
#f))]
|
||||
[(logo-canvas) (make-object canvas% frame)]
|
||||
[(panel) (make-object vertical-panel% frame)]
|
||||
[(logo-canvas) (make-object splash-canvas% panel)]
|
||||
[(h-panel) (make-object (if show-messages? horizontal-panel% vertical-panel%)
|
||||
frame)]
|
||||
[(gauge) (make-object gauge% #f splash-max-width h-panel '(vertical))]
|
||||
panel)]
|
||||
[(gauge) (make-object gauge% #f splash-max-width h-panel
|
||||
(if show-messages?
|
||||
'(vertical)
|
||||
'(horizontal)))]
|
||||
[(v-panel) (make-object vertical-panel% h-panel)]
|
||||
[(splash-messages)
|
||||
(and show-messages?
|
||||
|
|
@ -102,9 +106,12 @@
|
|||
(loop (sub1 n)))]))])
|
||||
(send (car msgs) set-label (format "Welcome to ~a" title))
|
||||
msgs))]
|
||||
[(_) (begin
|
||||
(send frame set-alignment 'left 'center)
|
||||
(send v-panel set-alignment 'left 'top)
|
||||
[(_3) (begin
|
||||
(send frame set-alignment 'center 'center)
|
||||
(send panel stretchable-width show-messages?)
|
||||
(send panel stretchable-height #f)
|
||||
(send h-panel set-alignment 'center 'top)
|
||||
(send v-panel set-alignment 'left 'center)
|
||||
(send logo-canvas min-width (send bitmap get-width))
|
||||
(send logo-canvas min-height (send bitmap get-height))
|
||||
(send logo-canvas stretchable-width #f)
|
||||
|
|
@ -137,19 +144,26 @@
|
|||
[(splash-load-handler)
|
||||
(let ([depth 0])
|
||||
(lambda (old-load f)
|
||||
(let ([finalf (splitup-path f)])
|
||||
(set! splash-sofar-depth (max (+ depth 1) splash-sofar-depth))
|
||||
(set! splash-current-width (+ splash-current-width 1))
|
||||
(when (change-splash-message (format "Loading ~a..." finalf) depth #f)
|
||||
(when (<= splash-current-width splash-max-width)
|
||||
(send gauge set-value splash-current-width)))
|
||||
(set! depth (+ depth 1))
|
||||
(begin0
|
||||
(old-load f)
|
||||
(begin (set! depth (- depth 1))
|
||||
(change-splash-message (format "Loading ~a...done." finalf)
|
||||
depth #t))))))]
|
||||
[(_) (current-load
|
||||
(let ([error? #t]
|
||||
[finalf (splitup-path f)])
|
||||
(dynamic-wind
|
||||
(lambda () (void))
|
||||
(lambda ()
|
||||
(set! splash-sofar-depth (max (+ depth 1) splash-sofar-depth))
|
||||
(set! splash-current-width (+ splash-current-width 1))
|
||||
(when (change-splash-message (format "Loading ~a..." finalf) depth #f)
|
||||
(when (<= splash-current-width splash-max-width)
|
||||
(send gauge set-value splash-current-width)))
|
||||
(set! depth (+ depth 1))
|
||||
(begin0 (old-load f)
|
||||
(set! error? #f)))
|
||||
(lambda ()
|
||||
(if error?
|
||||
(shutdown-splash)
|
||||
(begin (set! depth (- depth 1))
|
||||
(change-splash-message (format "Loading ~a...done." finalf)
|
||||
depth #t))))))))]
|
||||
[(_4) (current-load
|
||||
(let ([old-load (current-load)])
|
||||
(lambda (f)
|
||||
(splash-load-handler old-load f))))]
|
||||
|
|
@ -157,7 +171,7 @@
|
|||
(lambda ()
|
||||
(set! splash-load-handler (lambda (old-load f) (old-load f)))
|
||||
(unless (= splash-max-width splash-current-width)
|
||||
(set-resource splash-width-resource splash-current-width))
|
||||
(set-resource splash-width-resource (max 1 splash-current-width)))
|
||||
(unless (= splash-max-depth splash-sofar-depth)
|
||||
(set-resource splash-depth-resource splash-sofar-depth)))]
|
||||
[(close-splash)
|
||||
|
|
|
|||
|
|
@ -204,7 +204,7 @@
|
|||
[color (let* ([rc (rectangle-color rectangle)]
|
||||
[tmpc (make-object color% 0 0 0)])
|
||||
(if rc
|
||||
(begin (send dc try-colour rc tmpc)
|
||||
(begin (send dc try-color rc tmpc)
|
||||
(and (<= (max (abs (- (send rc red) (send tmpc red)))
|
||||
(abs (- (send rc blue) (send tmpc blue)))
|
||||
(abs (- (send rc green) (send tmpc green))))
|
||||
|
|
@ -224,8 +224,8 @@
|
|||
(let/ec k
|
||||
(cond
|
||||
[(and before color)
|
||||
(send pen set-colour color)
|
||||
(send brush set-colour color)]
|
||||
(send pen set-color color)
|
||||
(send brush set-color color)]
|
||||
[(and (not before) (not color) b/w-bitmap)
|
||||
(send pen set-stipple b/w-bitmap)
|
||||
(send brush set-stipple b/w-bitmap)]
|
||||
|
|
@ -496,7 +496,7 @@
|
|||
(when (and (or (eq? format 'same)
|
||||
(eq? format 'copy))
|
||||
(not (eq? (get-file-format)
|
||||
'std)))
|
||||
'standard)))
|
||||
(cond
|
||||
[(eq? format 'copy)
|
||||
(set! restore-file-format
|
||||
|
|
@ -504,11 +504,11 @@
|
|||
(lambda ()
|
||||
(set! restore-file-format void)
|
||||
(set-file-format f))))
|
||||
(set-file-format 'std)]
|
||||
(set-file-format 'standard)]
|
||||
[(and (has-non-string-snips)
|
||||
(or (not (preferences:get 'framework:verify-change-format))
|
||||
(gui-utils:get-choice "Save this file as plain text?" "No" "Yes")))
|
||||
(set-file-format 'std)]
|
||||
(set-file-format 'standard)]
|
||||
[else (void)]))
|
||||
(or (super-on-save-file name format)
|
||||
(begin
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user