no message
original commit: 758d95bd56d2716bd3c1404bd94efc222b22d2da
This commit is contained in:
Robby Findler
parent
7561d5face
commit
88df9a66f3
|
|
@ -15,32 +15,31 @@
|
|||
|
||||
(define basic<%> (interface ((class->interface editor-canvas%))))
|
||||
(define basic-mixin
|
||||
(mixin ((class->interface editor-canvas%)) (basic<%>) args
|
||||
(sequence
|
||||
(apply super-init args))))
|
||||
(mixin ((class->interface editor-canvas%)) (basic<%>)
|
||||
(super-instantiate ())))
|
||||
|
||||
(define info<%> (interface (basic<%>)))
|
||||
;; (basic<%> -> (class (is-a? (send this get-top-level-window) frame:info<%>)))
|
||||
(define info-mixin
|
||||
(mixin (basic<%>) (info<%>) (parent [editor #f] . args)
|
||||
(mixin (basic<%>) (info<%>)
|
||||
(inherit has-focus? get-top-level-window)
|
||||
(rename [super-on-focus on-focus]
|
||||
[super-set-editor set-editor])
|
||||
(override
|
||||
[on-focus
|
||||
(override on-focus)
|
||||
[define on-focus
|
||||
(lambda (on?)
|
||||
(super-on-focus on?)
|
||||
(send (get-top-level-window) set-info-canvas (and on? this))
|
||||
(when on?
|
||||
(send (get-top-level-window) update-info)))]
|
||||
[set-editor
|
||||
[define set-editor
|
||||
(lambda (m)
|
||||
(super-set-editor m)
|
||||
(let ([tlw (get-top-level-window)])
|
||||
(when (eq? this (send tlw get-info-canvas))
|
||||
(send tlw update-info))))])
|
||||
(sequence
|
||||
(apply super-init parent editor args)
|
||||
(send tlw update-info))))]
|
||||
|
||||
(super-instantiate ())
|
||||
|
||||
(unless (is-a? (get-top-level-window) frame:info<%>)
|
||||
(error 'canvas:text-info-mixin
|
||||
|
|
@ -48,24 +47,22 @@
|
|||
(get-top-level-window)))
|
||||
|
||||
(when (has-focus?)
|
||||
(send (get-top-level-window) update-info)))))
|
||||
(send (get-top-level-window) update-info))))
|
||||
|
||||
(define wide-snip<%> (interface (basic<%>)
|
||||
recalc-snips
|
||||
add-wide-snip
|
||||
add-tall-snip))
|
||||
|
||||
;; wx: this need to collude with
|
||||
;; wx: this needs to collude with
|
||||
;; the edit, since the edit has the right callbacks.
|
||||
(define wide-snip-mixin
|
||||
(mixin (basic<%>) (wide-snip<%>) args
|
||||
(mixin (basic<%>) (wide-snip<%>)
|
||||
(inherit get-editor)
|
||||
(rename [super-on-size on-size])
|
||||
(private-field
|
||||
[wide-snips null]
|
||||
[tall-snips null])
|
||||
(private
|
||||
[update-snip-size
|
||||
[define wide-snips null]
|
||||
[define tall-snips null]
|
||||
[define update-snip-size
|
||||
(lambda (width?)
|
||||
(lambda (s)
|
||||
(let* ([width (box 0)]
|
||||
|
|
@ -149,28 +146,26 @@
|
|||
(unbox bottomm)))])
|
||||
(send* s
|
||||
(set-min-height snip-height)
|
||||
(set-max-height snip-height)))))))))))])
|
||||
(public
|
||||
[recalc-snips
|
||||
(set-max-height snip-height)))))))))))]
|
||||
(public recalc-snips add-wide-snip add-tall-snip)
|
||||
[define recalc-snips
|
||||
(lambda ()
|
||||
(for-each (update-snip-size #t) wide-snips)
|
||||
(for-each (update-snip-size #f) tall-snips))])
|
||||
(public
|
||||
[add-wide-snip
|
||||
(for-each (update-snip-size #f) tall-snips))]
|
||||
[define add-wide-snip
|
||||
(lambda (snip)
|
||||
(set! wide-snips (cons snip wide-snips))
|
||||
((update-snip-size #t) snip))]
|
||||
[add-tall-snip
|
||||
[define add-tall-snip
|
||||
(lambda (snip)
|
||||
(set! tall-snips (cons snip tall-snips))
|
||||
((update-snip-size #f) snip))])
|
||||
(override
|
||||
[on-size
|
||||
((update-snip-size #f) snip))]
|
||||
(override on-size)
|
||||
[define on-size
|
||||
(lambda (width height)
|
||||
(recalc-snips)
|
||||
(super-on-size width height))])
|
||||
(sequence
|
||||
(apply super-init args))))
|
||||
(super-on-size width height))]
|
||||
(super-instantiate ())))
|
||||
|
||||
(define basic% (basic-mixin editor-canvas%))
|
||||
(define info% (info-mixin basic%))
|
||||
|
|
|
|||
|
|
@ -38,15 +38,15 @@
|
|||
save-file-out-of-date?))
|
||||
|
||||
(define basic-mixin
|
||||
(mixin (editor<%>) (basic<%>) args
|
||||
(mixin (editor<%>) (basic<%>)
|
||||
(inherit get-filename save-file
|
||||
refresh-delayed?
|
||||
get-canvas
|
||||
get-max-width get-admin)
|
||||
|
||||
(rename [super-can-save-file? can-save-file?])
|
||||
(override
|
||||
[can-save-file?
|
||||
(override can-save-file?)
|
||||
[define can-save-file?
|
||||
(lambda (filename format)
|
||||
(and (if (equal? filename (get-filename))
|
||||
(if (save-file-out-of-date?)
|
||||
|
|
@ -59,14 +59,13 @@
|
|||
(get-top-level-focus-window))
|
||||
#t)
|
||||
#t)
|
||||
(super-can-save-file? filename format)))])
|
||||
(super-can-save-file? filename format)))]
|
||||
|
||||
(rename [super-after-save-file after-save-file]
|
||||
[super-after-load-file after-load-file])
|
||||
(private-field
|
||||
[last-saved-file-time #f])
|
||||
(override
|
||||
[after-save-file
|
||||
[define last-saved-file-time #f]
|
||||
(override after-save-file after-load-file)
|
||||
[define after-save-file
|
||||
(lambda (sucess?)
|
||||
(when sucess?
|
||||
(let ([filename (get-filename)])
|
||||
|
|
@ -75,7 +74,7 @@
|
|||
(file-exists? filename)
|
||||
(file-or-directory-modify-seconds filename)))))
|
||||
(super-after-save-file sucess?))]
|
||||
[after-load-file
|
||||
[define after-load-file
|
||||
(lambda (sucess?)
|
||||
(when sucess?
|
||||
(let ([filename (get-filename)])
|
||||
|
|
@ -83,9 +82,9 @@
|
|||
(and filename
|
||||
(file-exists? filename)
|
||||
(file-or-directory-modify-seconds filename)))))
|
||||
(super-after-load-file sucess?))])
|
||||
(public
|
||||
[save-file-out-of-date?
|
||||
(super-after-load-file sucess?))]
|
||||
(public save-file-out-of-date?)
|
||||
[define save-file-out-of-date?
|
||||
(lambda ()
|
||||
(and
|
||||
last-saved-file-time
|
||||
|
|
@ -93,41 +92,22 @@
|
|||
(and fn
|
||||
(file-exists? fn)
|
||||
(let ([ms (file-or-directory-modify-seconds fn)])
|
||||
(< last-saved-file-time ms))))))])
|
||||
(< last-saved-file-time ms))))))]
|
||||
|
||||
(private-field
|
||||
[has-focus #f])
|
||||
[define has-focus #f]
|
||||
(rename [super-on-focus on-focus])
|
||||
(override
|
||||
[on-focus
|
||||
(override on-focus)
|
||||
[define on-focus
|
||||
(lambda (x)
|
||||
(set! has-focus x))])
|
||||
(public
|
||||
[has-focus?
|
||||
(set! has-focus x))]
|
||||
(public has-focus?)
|
||||
[define has-focus?
|
||||
(lambda ()
|
||||
has-focus)])
|
||||
has-focus)]
|
||||
|
||||
(rename [super-begin-edit-sequence begin-edit-sequence]
|
||||
[super-end-edit-sequence end-edit-sequence])
|
||||
(private-field
|
||||
[edit-sequence-count 0])
|
||||
(override
|
||||
[begin-edit-sequence
|
||||
(case-lambda
|
||||
[() (begin-edit-sequence #t)]
|
||||
[(undoable?)
|
||||
(set! edit-sequence-count (+ edit-sequence-count 1))
|
||||
(super-begin-edit-sequence undoable?)])]
|
||||
[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))])
|
||||
|
||||
(public
|
||||
[on-close (lambda () (void))]
|
||||
[get-top-level-window
|
||||
(public on-close get-top-level-window)
|
||||
[define on-close (lambda () (void))]
|
||||
[define get-top-level-window
|
||||
(lambda ()
|
||||
(let loop ([text this])
|
||||
(let ([editor-admin (send text get-admin)])
|
||||
|
|
@ -139,29 +119,27 @@
|
|||
[(send text get-canvas) => (lambda (canvas)
|
||||
(send canvas get-top-level-window))]
|
||||
[else
|
||||
#f]))))])
|
||||
#f]))))]
|
||||
|
||||
(public [editing-this-file? (lambda () #f)])
|
||||
(public editing-this-file?)
|
||||
[define editing-this-file? (lambda () #f)]
|
||||
|
||||
(private-field
|
||||
[edit-sequence-queue null]
|
||||
[edit-sequence-ht (make-hash-table)])
|
||||
|
||||
(private-field
|
||||
[in-local-edit-sequence? #f])
|
||||
(public
|
||||
[local-edit-sequence? (lambda () in-local-edit-sequence?)]
|
||||
[run-after-edit-sequence
|
||||
[define edit-sequence-queue null]
|
||||
[define edit-sequence-ht (make-hash-table)]
|
||||
[define in-local-edit-sequence? #f]
|
||||
(public local-edit-sequence? run-after-edit-sequence extend-edit-sequence-queue)
|
||||
[define local-edit-sequence? (lambda () in-local-edit-sequence?)]
|
||||
[define run-after-edit-sequence
|
||||
(case-lambda
|
||||
[(t) (run-after-edit-sequence t #f)]
|
||||
[(t sym)
|
||||
(unless (and (procedure? t)
|
||||
(= 0 (procedure-arity t)))
|
||||
(error 'media-buffer::run-after-edit-sequence
|
||||
(error 'editor:basic::run-after-edit-sequence
|
||||
"expected procedure of arity zero, got: ~s~n" t))
|
||||
(unless (or (symbol? sym) (not sym))
|
||||
(error 'media-buffer::run-after-edit-sequence
|
||||
"expected second argument to be a symbol, got: ~s~n"
|
||||
(error 'editor:basic::run-after-edit-sequence
|
||||
"expected second argument to be a symbol or #f, got: ~s~n"
|
||||
sym))
|
||||
(if (refresh-delayed?)
|
||||
(if in-local-edit-sequence?
|
||||
|
|
@ -184,22 +162,22 @@
|
|||
'(t)])))
|
||||
(t))
|
||||
(void)])]
|
||||
[extend-edit-sequence-queue
|
||||
[define extend-edit-sequence-queue
|
||||
(lambda (l ht)
|
||||
(hash-table-for-each ht (lambda (k t)
|
||||
(hash-table-put!
|
||||
edit-sequence-ht
|
||||
k t)))
|
||||
(set! edit-sequence-queue (append l edit-sequence-queue)))])
|
||||
(set! edit-sequence-queue (append l edit-sequence-queue)))]
|
||||
(rename
|
||||
[super-after-edit-sequence after-edit-sequence]
|
||||
[super-on-edit-sequence on-edit-sequence])
|
||||
(override
|
||||
[on-edit-sequence
|
||||
(override on-edit-sequence after-edit-sequence)
|
||||
[define on-edit-sequence
|
||||
(lambda ()
|
||||
(super-on-edit-sequence)
|
||||
(set! in-local-edit-sequence? #t))]
|
||||
[after-edit-sequence
|
||||
[define after-edit-sequence
|
||||
(lambda ()
|
||||
(set! in-local-edit-sequence? #f)
|
||||
(super-after-edit-sequence)
|
||||
|
|
@ -221,74 +199,70 @@
|
|||
[edit (send edit extend-edit-sequence-queue queue ht)]
|
||||
[else
|
||||
(hash-table-for-each ht (lambda (k t) (t)))
|
||||
(for-each (lambda (t) (t)) queue)]))))])
|
||||
(for-each (lambda (t) (t)) queue)]))))]
|
||||
|
||||
(override
|
||||
[on-new-box
|
||||
(override on-new-box)
|
||||
[define on-new-box
|
||||
(lambda (type)
|
||||
(cond
|
||||
[(eq? type 'text) (make-object editor-snip% (make-object text:basic%))]
|
||||
[else (make-object editor-snip% (make-object pasteboard:basic%))]))])
|
||||
[else (make-object editor-snip% (make-object pasteboard:basic%))]))]
|
||||
|
||||
|
||||
(override
|
||||
[get-file (lambda (d)
|
||||
(override get-file put-file)
|
||||
[define get-file (lambda (d)
|
||||
(parameterize ([finder:dialog-parent-parameter
|
||||
(get-top-level-window)])
|
||||
(finder:get-file d)))]
|
||||
[put-file (lambda (d f) (parameterize ([finder:dialog-parent-parameter
|
||||
[define put-file (lambda (d f) (parameterize ([finder:dialog-parent-parameter
|
||||
(get-top-level-window)])
|
||||
(finder:put-file f d)))])
|
||||
(finder:put-file f d)))]
|
||||
|
||||
|
||||
(sequence
|
||||
(apply super-init args))))
|
||||
|
||||
(super-instantiate ())))
|
||||
|
||||
(define -keymap<%> (interface (basic<%>) get-keymaps))
|
||||
(define keymap-mixin
|
||||
(mixin (basic<%>) (-keymap<%>) args
|
||||
(public
|
||||
[get-keymaps
|
||||
(mixin (basic<%>) (-keymap<%>)
|
||||
(public get-keymaps)
|
||||
[define get-keymaps
|
||||
(lambda ()
|
||||
(list (keymap:get-global)))])
|
||||
(list (keymap:get-global)))]
|
||||
(inherit set-keymap)
|
||||
(sequence
|
||||
(apply super-init args)
|
||||
|
||||
(super-instantiate ())
|
||||
(let ([keymap (make-object keymap:aug-keymap%)])
|
||||
(set-keymap keymap)
|
||||
(for-each (lambda (k) (send keymap chain-to-keymap k #f))
|
||||
(get-keymaps))))))
|
||||
(get-keymaps)))))
|
||||
|
||||
(define autowrap<%> (interface (basic<%>)))
|
||||
(define autowrap-mixin
|
||||
(mixin (basic<%>) (autowrap<%>) args
|
||||
(mixin (basic<%>) (autowrap<%>)
|
||||
|
||||
(rename [super-on-close on-close])
|
||||
(override
|
||||
[on-close
|
||||
(override on-close)
|
||||
[define on-close
|
||||
(lambda ()
|
||||
(remove-callback)
|
||||
(super-on-close))])
|
||||
(super-on-close))]
|
||||
|
||||
(inherit auto-wrap)
|
||||
(sequence
|
||||
(apply super-init args)
|
||||
(super-instantiate ())
|
||||
(auto-wrap
|
||||
(preferences:get
|
||||
'framework:auto-set-wrap?)))
|
||||
(private-field
|
||||
[remove-callback
|
||||
'framework:auto-set-wrap?))
|
||||
[define remove-callback
|
||||
(preferences:add-callback
|
||||
'framework:auto-set-wrap?
|
||||
(let ([autowrap-mixin-pref-callback
|
||||
(lambda (p v)
|
||||
(auto-wrap v))])
|
||||
autowrap-mixin-pref-callback))])))
|
||||
autowrap-mixin-pref-callback))]))
|
||||
|
||||
(define file<%> (interface (-keymap<%>)))
|
||||
(define file-mixin
|
||||
(mixin (-keymap<%>) (file<%>) args
|
||||
(mixin (-keymap<%>) (file<%>)
|
||||
(inherit get-filename lock get-style-list
|
||||
is-modified? change-style set-modified
|
||||
get-top-level-window)
|
||||
|
|
@ -297,12 +271,11 @@
|
|||
[super-get-keymaps get-keymaps]
|
||||
[super-set-filename set-filename])
|
||||
|
||||
(override
|
||||
[editing-this-file? (lambda () #t)])
|
||||
(override editing-this-file?)
|
||||
[define editing-this-file? (lambda () #t)]
|
||||
|
||||
(inherit get-canvases)
|
||||
(private
|
||||
[check-lock
|
||||
[define check-lock
|
||||
(lambda ()
|
||||
(let* ([filename (get-filename)]
|
||||
[lock? (and filename
|
||||
|
|
@ -312,7 +285,7 @@
|
|||
(file-or-directory-permissions
|
||||
filename))))])
|
||||
(lock lock?)))]
|
||||
[update-filename
|
||||
[define update-filename
|
||||
(lambda (name)
|
||||
(let ([filename (if name
|
||||
(file-name-from-path (normalize-path name))
|
||||
|
|
@ -321,21 +294,21 @@
|
|||
(let ([tlw (send canvas get-top-level-window)])
|
||||
(when (is-a? tlw frame:editor<%>)
|
||||
(send tlw set-label filename))))
|
||||
(get-canvases))))])
|
||||
(override
|
||||
[after-save-file
|
||||
(get-canvases))))]
|
||||
(override after-save-file after-load-file set-filename get-keymaps)
|
||||
[define after-save-file
|
||||
(lambda (success)
|
||||
(when success
|
||||
(check-lock))
|
||||
(super-after-save-file success))]
|
||||
|
||||
[after-load-file
|
||||
[define after-load-file
|
||||
(lambda (sucessful?)
|
||||
(when sucessful?
|
||||
(check-lock))
|
||||
(super-after-load-file sucessful?))]
|
||||
|
||||
[set-filename
|
||||
[define set-filename
|
||||
(case-lambda
|
||||
[(name) (set-filename name #f)]
|
||||
[(name temp?)
|
||||
|
|
@ -343,11 +316,10 @@
|
|||
(unless temp?
|
||||
(update-filename name))])]
|
||||
|
||||
[get-keymaps
|
||||
[define get-keymaps
|
||||
(lambda ()
|
||||
(cons (keymap:get-file) (super-get-keymaps)))])
|
||||
(sequence
|
||||
(apply super-init args))))
|
||||
(cons (keymap:get-file) (super-get-keymaps)))]
|
||||
(super-instantiate ())))
|
||||
|
||||
(define backup-autosave<%>
|
||||
(interface (basic<%>)
|
||||
|
|
@ -358,29 +330,27 @@
|
|||
|
||||
; what about checking the autosave files when a file is opened?
|
||||
(define backup-autosave-mixin
|
||||
(mixin (basic<%>) (backup-autosave<%>) args
|
||||
(mixin (basic<%>) (backup-autosave<%>)
|
||||
(inherit is-modified? get-filename save-file)
|
||||
(rename [super-on-save-file on-save-file]
|
||||
[super-on-change on-change]
|
||||
[super-on-close on-close]
|
||||
[super-set-modified set-modified])
|
||||
(private-field
|
||||
[auto-saved-name #f]
|
||||
[auto-save-out-of-date? #t]
|
||||
[auto-save-error? #f])
|
||||
(private
|
||||
[file-old?
|
||||
[define auto-saved-name #f]
|
||||
[define auto-save-out-of-date? #t]
|
||||
[define auto-save-error? #f]
|
||||
[define file-old?
|
||||
(lambda (filename)
|
||||
(if (and filename
|
||||
(file-exists? filename))
|
||||
(let ([modified-seconds (file-or-directory-modify-seconds filename)]
|
||||
[old-seconds (- (current-seconds) (* 7 24 60 60))])
|
||||
(< modified-seconds old-seconds))
|
||||
#t))])
|
||||
(public
|
||||
[backup? (lambda () #t)])
|
||||
(override
|
||||
[on-save-file
|
||||
#t))]
|
||||
(public backup?)
|
||||
[define backup? (lambda () #t)]
|
||||
(override on-save-file on-close on-change set-modified)
|
||||
[define on-save-file
|
||||
(lambda (name format)
|
||||
(super-on-save-file name format)
|
||||
(set! auto-save-error? #f)
|
||||
|
|
@ -394,27 +364,26 @@
|
|||
(delete-file back-name))
|
||||
(with-handlers ([(lambda (x) #t) void])
|
||||
(copy-file name back-name))))))]
|
||||
[on-close
|
||||
[define on-close
|
||||
(lambda ()
|
||||
(super-on-close)
|
||||
(remove-autosave)
|
||||
(set! do-autosave? #f))]
|
||||
[on-change
|
||||
[define on-change
|
||||
(lambda ()
|
||||
(super-on-change)
|
||||
(set! auto-save-out-of-date? #t))]
|
||||
[set-modified
|
||||
[define set-modified
|
||||
(lambda (modified?)
|
||||
(when auto-saved-name
|
||||
(if modified?
|
||||
(set! auto-save-out-of-date? #t)
|
||||
(remove-autosave)))
|
||||
(super-set-modified modified?))])
|
||||
(private-field
|
||||
[do-autosave? #t])
|
||||
(public
|
||||
[autosave? (lambda () do-autosave?)]
|
||||
[do-autosave
|
||||
(super-set-modified modified?))]
|
||||
[define do-autosave? #t]
|
||||
(public autosave? do-autosave remove-autosave)
|
||||
[define autosave? (lambda () do-autosave?)]
|
||||
[define do-autosave
|
||||
(lambda ()
|
||||
(when (and (autosave?)
|
||||
(not auto-save-error?)
|
||||
|
|
@ -439,23 +408,22 @@
|
|||
"Autosaving is turned off"
|
||||
"until the file is saved."))
|
||||
(set! auto-save-error? #t))))))]
|
||||
[remove-autosave
|
||||
[define remove-autosave
|
||||
(lambda ()
|
||||
(when auto-saved-name
|
||||
(when (file-exists? auto-saved-name)
|
||||
(delete-file auto-saved-name))
|
||||
(set! auto-saved-name #f)))])
|
||||
(sequence
|
||||
(apply super-init args)
|
||||
(autosave:register this))))
|
||||
(set! auto-saved-name #f)))]
|
||||
(super-instantiate ())
|
||||
(autosave:register this)))
|
||||
|
||||
(define info<%> (interface (basic<%>)))
|
||||
(define info-mixin
|
||||
(mixin (basic<%>) (info<%>) args
|
||||
(mixin (basic<%>) (info<%>)
|
||||
(inherit get-top-level-window run-after-edit-sequence)
|
||||
(rename [super-lock lock])
|
||||
(override
|
||||
[lock
|
||||
(override lock)
|
||||
[define lock
|
||||
(lambda (x)
|
||||
(super-lock x)
|
||||
(run-after-edit-sequence
|
||||
|
|
@ -464,5 +432,5 @@
|
|||
(let ([frame (get-top-level-window)])
|
||||
(when (is-a? frame frame:info<%>)
|
||||
(send frame lock-status-changed)))))
|
||||
'framework:update-lock-icon))])
|
||||
(sequence (apply super-init args)))))))
|
||||
'framework:update-lock-icon))]
|
||||
(super-instantiate ()))))))
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,44 +1,54 @@
|
|||
(module gen-standard-menus mzscheme
|
||||
(require (lib "pretty.ss"))
|
||||
(require (lib "list.ss"))
|
||||
(require (lib "standard-menus-items.ss" "framework" "private"))
|
||||
(require "standard-menus-items.ss")
|
||||
|
||||
;; build-before-super-item-clause : an-item -> sexp
|
||||
;; calculates a `public' class expression
|
||||
;; build-before-super-item-clause : an-item -> (listof clause)
|
||||
(define build-before-super-item-clause
|
||||
(lambda (item)
|
||||
`(public
|
||||
[,(an-item->callback-name item)
|
||||
(list
|
||||
`(public ,(an-item->callback-name item)
|
||||
,(an-item->get-item-name item)
|
||||
,(an-item->string-name item)
|
||||
,(an-item->help-string-name item)
|
||||
,(an-item->on-demand-name item)
|
||||
,(an-item->create-menu-item-name item))
|
||||
`[define ,(an-item->callback-name item)
|
||||
,(or (an-item-proc item) `(lambda (x y) (void)))]
|
||||
[,(an-item->get-item-name item)
|
||||
`[define ,(an-item->get-item-name item)
|
||||
(lambda () ,(an-item->item-name item))]
|
||||
[,(an-item->string-name item)
|
||||
`[define ,(an-item->string-name item)
|
||||
(lambda () "")]
|
||||
[,(an-item->help-string-name item)
|
||||
`[define ,(an-item->help-string-name item)
|
||||
(lambda () ,(an-item-help-string item))]
|
||||
[,(an-item->on-demand-name item)
|
||||
`[define ,(an-item->on-demand-name item)
|
||||
,(an-item-on-demand item)]
|
||||
[,(an-item->create-menu-item-name item)
|
||||
`[define ,(an-item->create-menu-item-name item)
|
||||
(lambda () ,(not (not (an-item-proc item))))])))
|
||||
|
||||
;; build-before-super-clause : ((X -> sym) (X sexp) -> X -> (listof clause))
|
||||
(define build-before-super-clause
|
||||
(lambda (->name -procedure)
|
||||
(lambda (obj)
|
||||
`(public
|
||||
[,(->name obj)
|
||||
(list `(public ,(->name obj))
|
||||
`[define ,(->name obj)
|
||||
,(case (-procedure obj)
|
||||
[(nothing) '(lambda (menu) (void))]
|
||||
[(separator) '(lambda (menu) (make-object separator-menu-item% menu))])]))))
|
||||
|
||||
;; build-before-super-between-clause : between -> (listof clause)
|
||||
(define build-before-super-between-clause
|
||||
(build-before-super-clause
|
||||
between->name
|
||||
between-procedure))
|
||||
|
||||
;; build-before-super-before/after-clause : before/after -> (listof clause)
|
||||
(define build-before-super-before/after-clause
|
||||
(build-before-super-clause
|
||||
before/after->name
|
||||
before/after-procedure))
|
||||
|
||||
;; build-after-super-item-clause : an-item -> (list clause)
|
||||
(define (build-after-super-item-clause item)
|
||||
(let* ([callback-name (an-item->callback-name item)]
|
||||
[create-menu-item-name (an-item->create-menu-item-name item)]
|
||||
|
|
@ -53,58 +63,57 @@
|
|||
(if (string=? special "")
|
||||
(string-append base suffix)
|
||||
(string-append base " " special suffix))))])
|
||||
`(private-field
|
||||
[,(an-item->item-name item)
|
||||
(list `(define
|
||||
,(an-item->item-name item)
|
||||
(and (,create-menu-item-name)
|
||||
(make-object (class100 (get-menu-item%) args
|
||||
(rename [super-on-demand on-demand])
|
||||
(override
|
||||
[on-demand
|
||||
(lambda ()
|
||||
(,(an-item->on-demand-name item) this)
|
||||
(super-on-demand))])
|
||||
(sequence
|
||||
(apply super-init args)))
|
||||
,(join menu-before-string menu-after-string
|
||||
`(,(an-item->string-name item)))
|
||||
,(menu-item-menu-name item)
|
||||
(let ([,callback-name (lambda (item evt) (,callback-name item evt))])
|
||||
,callback-name)
|
||||
,key
|
||||
(,(an-item->help-string-name item))))])))
|
||||
(instantiate (get-menu-item%) ()
|
||||
(label ,(join menu-before-string menu-after-string
|
||||
`(,(an-item->string-name item))))
|
||||
(parent ,(menu-item-menu-name item))
|
||||
(callback (let ([,callback-name (lambda (item evt) (,callback-name item evt))])
|
||||
,callback-name))
|
||||
(shortcut ,key)
|
||||
(help (,(an-item->help-string-name item)))
|
||||
(demand-callback (lambda (menu-item) (,(an-item->on-demand-name item) menu-item)))))))))
|
||||
|
||||
;; build-after-super-clause : ((X -> symbol) -> X -> (listof clause))
|
||||
(define build-after-super-clause
|
||||
(lambda (->name)
|
||||
(lambda (between/after)
|
||||
`(sequence
|
||||
(,(->name between/after)
|
||||
(list
|
||||
`(,(->name between/after)
|
||||
(,(menu-name->get-menu-name between/after)))))))
|
||||
|
||||
;; build-after-super-between-clause : between -> (listof clause)
|
||||
(define build-after-super-between-clause (build-after-super-clause between->name))
|
||||
;; build-after-super-before/after-clause : before/after -> (listof clause)
|
||||
(define build-after-super-before/after-clause (build-after-super-clause before/after->name))
|
||||
|
||||
;; build-after-super-generic-clause : generic -> (listof clause)
|
||||
(define (build-after-super-generic-clause x)
|
||||
(cond
|
||||
[(generic-private-field? x)
|
||||
`(private-field
|
||||
[,(generic-name x)
|
||||
,(generic-initializer x)])]
|
||||
(list `(define
|
||||
,(generic-name x)
|
||||
,(generic-initializer x)))]
|
||||
[(generic-override? x)
|
||||
`(rename [,(string->symbol (format "super-~a" (generic-name x)))
|
||||
,(generic-name x)])]
|
||||
(list `(rename [,(string->symbol (format "super-~a" (generic-name x)))
|
||||
,(generic-name x)]))]
|
||||
[(generic-method? x)
|
||||
`(sequence (void))]))
|
||||
null]))
|
||||
|
||||
;; build-before-super-generic-clause : generic -> (listof clause)
|
||||
(define (build-before-super-generic-clause generic)
|
||||
(cond
|
||||
[(generic-private-field? generic)
|
||||
`(sequence (void))]
|
||||
null]
|
||||
[(generic-override? generic)
|
||||
`(override
|
||||
[,(generic-name generic)
|
||||
(list `(override ,(generic-name generic))
|
||||
`[define ,(generic-name generic)
|
||||
,(generic-initializer generic)])]
|
||||
[(generic-method? generic)
|
||||
`(public
|
||||
[,(generic-name generic)
|
||||
(list `(public ,(generic-name generic) )
|
||||
`[define ,(generic-name generic)
|
||||
,(generic-initializer generic)])]))
|
||||
|
||||
|
||||
|
|
@ -141,10 +150,9 @@
|
|||
|
||||
(pretty-print
|
||||
`(define standard-menus-mixin
|
||||
(mixin (basic<%>) (standard-menus<%>) args
|
||||
(mixin (basic<%>) (standard-menus<%>)
|
||||
(inherit on-menu-char on-traverse-char)
|
||||
(private-field
|
||||
[remove-prefs-callback
|
||||
(define remove-prefs-callback
|
||||
(preferences:add-callback
|
||||
'framework:menu-bindings
|
||||
(lambda (p v)
|
||||
|
|
@ -157,26 +165,26 @@
|
|||
(when (is-a? menu menu:can-restore<%>)
|
||||
(if v
|
||||
(send menu restore-keybinding)
|
||||
(send menu set-shortcut #f)))])))))])
|
||||
(send menu set-shortcut #f)))]))))))
|
||||
|
||||
(inherit get-menu-bar show can-close? get-edit-target-object)
|
||||
,@(map (lambda (x)
|
||||
,@(apply append (map (lambda (x)
|
||||
(cond
|
||||
[(between? x) (build-before-super-between-clause x)]
|
||||
[(or (after? x) (before? x)) (build-before-super-before/after-clause x)]
|
||||
[(an-item? x) (build-before-super-item-clause x)]
|
||||
[(generic? x) (build-before-super-generic-clause x)]
|
||||
[else (printf "~a~n" x)]))
|
||||
items)
|
||||
(sequence (apply super-init args))
|
||||
,@(map (lambda (x)
|
||||
items))
|
||||
(super-instantiate ())
|
||||
,@(apply append (map (lambda (x)
|
||||
(cond
|
||||
[(between? x) (build-after-super-between-clause x)]
|
||||
[(an-item? x) (build-after-super-item-clause x)]
|
||||
[(or (after? x) (before? x)) (build-after-super-before/after-clause x)]
|
||||
[(generic? x) (build-after-super-generic-clause x)]))
|
||||
items)
|
||||
(sequence (reorder-menus this))))
|
||||
items))
|
||||
(reorder-menus this)))
|
||||
port))
|
||||
'text
|
||||
'truncate))
|
||||
|
|
@ -26,38 +26,38 @@
|
|||
get-map-function-table/ht))
|
||||
|
||||
(define aug-keymap-mixin
|
||||
(mixin ((class->interface keymap%)) (aug-keymap<%>) args
|
||||
(private-field
|
||||
[chained-keymaps null])
|
||||
(public
|
||||
[get-chained-keymaps
|
||||
(mixin ((class->interface keymap%)) (aug-keymap<%>)
|
||||
(define chained-keymaps null)
|
||||
(public get-chained-keymaps)
|
||||
[define get-chained-keymaps
|
||||
(lambda ()
|
||||
chained-keymaps)])
|
||||
chained-keymaps)]
|
||||
(rename [super-chain-to-keymap chain-to-keymap])
|
||||
(override
|
||||
[chain-to-keymap
|
||||
(override chain-to-keymap)
|
||||
[define chain-to-keymap
|
||||
(lambda (keymap prefix?)
|
||||
(super-chain-to-keymap keymap prefix?)
|
||||
(set! chained-keymaps
|
||||
(if prefix?
|
||||
(cons keymap chained-keymaps)
|
||||
(append chained-keymaps (list keymap)))))])
|
||||
(append chained-keymaps (list keymap)))))]
|
||||
|
||||
(private-field [function-table (make-hash-table)])
|
||||
(public [get-function-table (lambda () function-table)])
|
||||
[define function-table (make-hash-table)]
|
||||
(public get-function-table)
|
||||
[define get-function-table (lambda () function-table)]
|
||||
(rename [super-map-function map-function])
|
||||
(override
|
||||
[map-function
|
||||
(override map-function)
|
||||
[define map-function
|
||||
(lambda (keyname fname)
|
||||
(super-map-function (canonicalize-keybinding-string keyname) fname)
|
||||
(hash-table-put! function-table (string->symbol keyname) fname))])
|
||||
(hash-table-put! function-table (string->symbol keyname) fname))]
|
||||
|
||||
(public
|
||||
[get-map-function-table
|
||||
(public get-map-function-table get-map-function-table/ht)
|
||||
[define get-map-function-table
|
||||
(lambda ()
|
||||
(get-map-function-table/ht (make-hash-table)))]
|
||||
|
||||
[get-map-function-table/ht
|
||||
[define get-map-function-table/ht
|
||||
(lambda (table)
|
||||
(hash-table-for-each
|
||||
function-table
|
||||
|
|
@ -69,10 +69,9 @@
|
|||
(when (is-a? chained-keymap aug-keymap<%>)
|
||||
(send chained-keymap get-map-function-table/ht table)))
|
||||
chained-keymaps)
|
||||
table)])
|
||||
table)]
|
||||
|
||||
(sequence
|
||||
(apply super-init args))))
|
||||
(super-instantiate ())))
|
||||
|
||||
(define aug-keymap% (aug-keymap-mixin keymap%))
|
||||
|
||||
|
|
|
|||
|
|
@ -18,20 +18,19 @@
|
|||
restore-keybinding))
|
||||
|
||||
(define can-restore-mixin
|
||||
(mixin (selectable-menu-item<%>) (can-restore<%>) args
|
||||
(mixin (selectable-menu-item<%>) (can-restore<%>)
|
||||
(inherit set-shortcut get-shortcut)
|
||||
(private-field
|
||||
[saved-shortcut 'not-yet])
|
||||
(public
|
||||
[restore-keybinding
|
||||
[define saved-shortcut 'not-yet]
|
||||
(public restore-keybinding)
|
||||
[define restore-keybinding
|
||||
(lambda ()
|
||||
(unless (eq? saved-shortcut 'not-yet)
|
||||
(set-shortcut saved-shortcut)))])
|
||||
(sequence
|
||||
(apply super-init args)
|
||||
(set-shortcut saved-shortcut)))]
|
||||
|
||||
(super-instantiate ())
|
||||
(set! saved-shortcut (get-shortcut))
|
||||
(unless (preferences:get 'framework:menu-bindings)
|
||||
(set-shortcut #f)))))
|
||||
(set-shortcut #f))))
|
||||
|
||||
(define can-restore-menu-item% (can-restore-mixin menu-item%))
|
||||
(define can-restore-checkable-menu-item% (can-restore-mixin checkable-menu-item%)))))
|
||||
|
|
@ -27,21 +27,21 @@
|
|||
|
||||
(define single<%> (interface (area-container<%>) active-child))
|
||||
(define single-mixin
|
||||
(mixin (area-container<%>) (single<%>) args
|
||||
(mixin (area-container<%>) (single<%>)
|
||||
(inherit get-alignment)
|
||||
(rename [super-after-new-child after-new-child])
|
||||
(override
|
||||
[after-new-child
|
||||
(override after-new-child container-size place-children)
|
||||
[define after-new-child
|
||||
(lambda (c)
|
||||
(if current-active-child
|
||||
(send c show #f)
|
||||
(set! current-active-child c)))]
|
||||
[container-size
|
||||
[define container-size
|
||||
(lambda (l)
|
||||
(if (null? l)
|
||||
(values 0 0)
|
||||
(values (apply max (map car l)) (apply max (map cadr l)))))]
|
||||
[place-children
|
||||
[define place-children
|
||||
(lambda (l width height)
|
||||
(let-values ([(h-align-spec v-align-spec) (get-alignment)])
|
||||
(let ([align
|
||||
|
|
@ -61,12 +61,12 @@
|
|||
(values 0 height)
|
||||
(values (align height v-align-spec min-height) min-height))])
|
||||
(list x y this-width this-height)))
|
||||
l))))])
|
||||
l))))]
|
||||
|
||||
(inherit get-children)
|
||||
(private-field [current-active-child #f])
|
||||
(public
|
||||
[active-child
|
||||
[define current-active-child #f]
|
||||
(public active-child)
|
||||
[define active-child
|
||||
(case-lambda
|
||||
[() current-active-child]
|
||||
[(x)
|
||||
|
|
@ -76,17 +76,16 @@
|
|||
(for-each (lambda (x) (send x show #f))
|
||||
(get-children))
|
||||
(set! current-active-child x)
|
||||
(send current-active-child show #t))])])
|
||||
(sequence
|
||||
(apply super-init args))))
|
||||
(send current-active-child show #t))])]
|
||||
(super-instantiate ())))
|
||||
|
||||
(define single-window<%> (interface (single<%> window<%>)))
|
||||
(define single-window-mixin
|
||||
(mixin (single<%> window<%>) (single-window<%>) args
|
||||
(mixin (single<%> window<%>) (single-window<%>)
|
||||
(inherit get-client-size get-size)
|
||||
(rename [super-container-size container-size])
|
||||
(override
|
||||
[container-size
|
||||
(override container-size)
|
||||
[define container-size
|
||||
(lambda (l)
|
||||
(let-values ([(super-width super-height) (super-container-size l)]
|
||||
[(client-width client-height) (get-client-size)]
|
||||
|
|
@ -97,9 +96,8 @@
|
|||
|
||||
(values
|
||||
(calc-size super-width client-width window-width)
|
||||
(calc-size super-height client-height window-height))))])
|
||||
(sequence
|
||||
(apply super-init args))))
|
||||
(calc-size super-height client-height window-height))))]
|
||||
(super-instantiate ())))
|
||||
|
||||
(define multi-view<%>
|
||||
(interface (area-container<%>)
|
||||
|
|
@ -108,25 +106,22 @@
|
|||
collapse))
|
||||
|
||||
(define multi-view-mixin
|
||||
(mixin (area-container<%>) (multi-view<%>) (_parent _editor)
|
||||
|
||||
(private-field [parent _parent]
|
||||
[editor _editor])
|
||||
|
||||
(public
|
||||
[get-editor-canvas%
|
||||
(mixin (area-container<%>) (multi-view<%>)
|
||||
(init-field parent editor)
|
||||
(public get-editor-canvas% get-vertical% get-horizontal%)
|
||||
[define get-editor-canvas%
|
||||
(lambda ()
|
||||
editor-canvas%)]
|
||||
[get-vertical%
|
||||
[define get-vertical%
|
||||
(lambda ()
|
||||
vertical-panel%)]
|
||||
[get-horizontal%
|
||||
[define get-horizontal%
|
||||
(lambda ()
|
||||
horizontal-panel%)])
|
||||
horizontal-panel%)]
|
||||
|
||||
(public split-vertically split-horizontally)
|
||||
|
||||
(private
|
||||
[split
|
||||
[define split
|
||||
(lambda (p%)
|
||||
(let ([canvas (send (send parent get-top-level-window) get-edit-target-window)]
|
||||
[ec% (get-editor-canvas%)])
|
||||
|
|
@ -137,10 +132,16 @@
|
|||
(send p change-children (lambda (x) null))
|
||||
(let ([pc (make-object p% p)])
|
||||
(send (make-object ec% (make-object vertical-panel% pc) editor) focus)
|
||||
(make-object ec% (make-object vertical-panel% pc) editor))))))])
|
||||
(make-object ec% (make-object vertical-panel% pc) editor))))))]
|
||||
[define split-vertically
|
||||
(lambda ()
|
||||
(split (get-vertical%)))]
|
||||
[define split-horizontally
|
||||
(lambda ()
|
||||
(split (get-horizontal%)))]
|
||||
|
||||
(public
|
||||
[collapse
|
||||
(public collapse)
|
||||
(define collapse
|
||||
(lambda ()
|
||||
(let ([canvas (send (send parent get-top-level-window) get-edit-target-window)]
|
||||
[ec% (get-editor-canvas%)])
|
||||
|
|
@ -153,18 +154,11 @@
|
|||
(let* ([sp (send p get-parent)]
|
||||
[p-to-remain (send sp get-parent)])
|
||||
(send p-to-remain change-children (lambda (x) null))
|
||||
(send (make-object ec% p-to-remain editor) focus)))))))])
|
||||
(send (make-object ec% p-to-remain editor) focus))))))))
|
||||
|
||||
(public
|
||||
[split-vertically
|
||||
(lambda ()
|
||||
(split (get-vertical%)))]
|
||||
[split-horizontally
|
||||
(lambda ()
|
||||
(split (get-horizontal%)))])
|
||||
(sequence
|
||||
(super-init parent)
|
||||
(make-object (get-editor-canvas%) this editor))))
|
||||
|
||||
(super-instantiate () (parent parent))
|
||||
(make-object (get-editor-canvas%) this editor)))
|
||||
|
||||
(define single% (single-window-mixin (single-mixin panel%)))
|
||||
(define single-pane% (single-mixin pane%))
|
||||
|
|
@ -377,30 +371,29 @@
|
|||
set-percentages))
|
||||
|
||||
(define vertical-resizable-mixin
|
||||
(mixin (area-container<%>) (vertical-resizable<%>) args
|
||||
(mixin (area-container<%>) (vertical-resizable<%>)
|
||||
(inherit get-children)
|
||||
|
||||
(private-field [thumb-canvas #f])
|
||||
(public
|
||||
[on-between-click
|
||||
(define thumb-canvas #f)
|
||||
(public on-between-click)
|
||||
[define on-between-click
|
||||
(lambda (num pct)
|
||||
(void))])
|
||||
(void))]
|
||||
|
||||
;; preserve the invariant that the thumb-canvas is
|
||||
;; the first child and that the thumb-canvas percentages
|
||||
;; match up with the children
|
||||
(private
|
||||
[fix-percentage-length
|
||||
[define fix-percentage-length
|
||||
(lambda (children)
|
||||
(let ([len (length children)])
|
||||
(unless (= (- len 1) (length (send thumb-canvas get-percentages)))
|
||||
(send thumb-canvas set-percentages
|
||||
(build-list
|
||||
(- len 1)
|
||||
(lambda (i) (/ 1 (- len 1))))))))])
|
||||
(lambda (i) (/ 1 (- len 1))))))))]
|
||||
(rename [super-change-children change-children])
|
||||
(override
|
||||
[change-children
|
||||
(override change-children after-new-child)
|
||||
[define change-children
|
||||
(lambda (f)
|
||||
(super-change-children
|
||||
(lambda (l)
|
||||
|
|
@ -413,13 +406,13 @@
|
|||
(fix-percentage-length res)
|
||||
res)
|
||||
(f l)))))]
|
||||
[after-new-child
|
||||
[define after-new-child
|
||||
(lambda (child)
|
||||
(when thumb-canvas
|
||||
(fix-percentage-length (get-children))))])
|
||||
(fix-percentage-length (get-children))))]
|
||||
|
||||
(override
|
||||
[container-size
|
||||
(override container-size place-children)
|
||||
[define container-size
|
||||
(lambda (_lst)
|
||||
;; remove the thumb canvas from the computation
|
||||
(let ([lst (if (null? _lst) null (cdr _lst))])
|
||||
|
|
@ -431,7 +424,7 @@
|
|||
(+ (send thumb-canvas min-width)
|
||||
(apply max (map car lst)))])
|
||||
(apply + (map cadr lst)))))]
|
||||
[place-children
|
||||
[define place-children
|
||||
(lambda (_infos width height)
|
||||
(cond
|
||||
[(null? _infos) null]
|
||||
|
|
@ -471,19 +464,18 @@
|
|||
(cons (list 0 y main-width this-space)
|
||||
(loop (cdr percentages)
|
||||
(cdr infos)
|
||||
(+ y this-space))))]))))]))])
|
||||
(+ y this-space))))]))))]))]
|
||||
(inherit reflow-container get-top-level-window set-alignment get-alignment)
|
||||
(public
|
||||
[on-percentage-change (lambda () (void))]
|
||||
[get-percentages (lambda () (send thumb-canvas get-percentages))]
|
||||
[set-percentages
|
||||
(public on-percentage-change get-percentages set-percentages)
|
||||
[define on-percentage-change (lambda () (void))]
|
||||
[define get-percentages (lambda () (send thumb-canvas get-percentages))]
|
||||
[define set-percentages
|
||||
(lambda (p)
|
||||
(send thumb-canvas set-percentages p)
|
||||
(refresh-panel this))])
|
||||
(refresh-panel this))]
|
||||
|
||||
(sequence
|
||||
(apply super-init args)
|
||||
(set! thumb-canvas (make-object thumb-canvas% this)))))
|
||||
(super-instantiate ())
|
||||
(set! thumb-canvas (make-object thumb-canvas% this))))
|
||||
|
||||
(define vertical-resizable% (vertical-resizable-mixin panel%))
|
||||
(define vertical-resizable-pane% (vertical-resizable-mixin pane%)))))
|
||||
|
|
|
|||
|
|
@ -30,6 +30,8 @@
|
|||
(rename [-text% text%]
|
||||
[-text<%> text<%>])
|
||||
|
||||
(define-struct string/pos (string pos))
|
||||
|
||||
(define -text<%>
|
||||
(interface ()
|
||||
highlight-parens
|
||||
|
|
@ -98,7 +100,7 @@
|
|||
(define mismatch-color (make-object color% "PINK"))
|
||||
|
||||
(define text-mixin
|
||||
(mixin (text:basic<%> editor:keymap<%>) (-text<%>) args
|
||||
(mixin (text:basic<%> editor:keymap<%>) (-text<%>)
|
||||
(inherit begin-edit-sequence
|
||||
delete
|
||||
end-edit-sequence
|
||||
|
|
@ -127,9 +129,7 @@
|
|||
set-styles-fixed)
|
||||
(rename [super-on-char on-char])
|
||||
|
||||
(private
|
||||
[in-single-line-comment?
|
||||
(lambda (position)
|
||||
(define (in-single-line-comment? position)
|
||||
(let ([line (position-line position)])
|
||||
(ormap
|
||||
(lambda (comment-start)
|
||||
|
|
@ -149,21 +149,16 @@
|
|||
[else
|
||||
#f])
|
||||
#f)))
|
||||
(scheme-paren:get-comments))))])
|
||||
(private-field
|
||||
[remove-indents-callback
|
||||
(scheme-paren:get-comments))))
|
||||
(define remove-indents-callback
|
||||
(preferences:add-callback
|
||||
'framework:tabify
|
||||
(lambda (p value)
|
||||
(set! indents value)))]
|
||||
[indents (preferences:get 'framework:tabify)]
|
||||
[backward-cache (make-object match-cache:%)]
|
||||
[forward-cache (make-object match-cache:%)]
|
||||
[in-highlight-parens? #f])
|
||||
|
||||
(private
|
||||
[delay-highlight? (lambda () (local-edit-sequence?))])
|
||||
|
||||
(set! indents value))))
|
||||
(define indents (preferences:get 'framework:tabify))
|
||||
[define backward-cache (make-object match-cache:%)]
|
||||
[define forward-cache (make-object match-cache:%)]
|
||||
[define in-highlight-parens? #f]
|
||||
|
||||
(inherit get-styles-fixed)
|
||||
(rename [super-on-focus on-focus]
|
||||
|
|
@ -174,63 +169,55 @@
|
|||
[super-after-set-size-constraint after-set-size-constraint]
|
||||
[super-after-set-position after-set-position])
|
||||
(inherit has-focus? find-snip split-snip)
|
||||
(override
|
||||
[on-focus
|
||||
(lambda (on?)
|
||||
(override on-focus after-change-style after-edit-sequence
|
||||
after-insert after-delete
|
||||
after-set-size-constraint after-set-position)
|
||||
(define (on-focus on?)
|
||||
(super-on-focus on?)
|
||||
(highlight-parens (not on?)))]
|
||||
[after-change-style
|
||||
(lambda (start len)
|
||||
(unless (delay-highlight?)
|
||||
(highlight-parens (not on?)))
|
||||
(define (after-change-style start len)
|
||||
(unless (local-edit-sequence?)
|
||||
(unless (get-styles-fixed)
|
||||
(when (has-focus?)
|
||||
(highlight-parens))))
|
||||
(super-after-change-style start len))]
|
||||
[after-edit-sequence
|
||||
(lambda ()
|
||||
(super-after-change-style start len))
|
||||
(define (after-edit-sequence)
|
||||
(super-after-edit-sequence)
|
||||
(unless (delay-highlight?)
|
||||
(unless (local-edit-sequence?)
|
||||
(when (has-focus?)
|
||||
(unless in-highlight-parens?
|
||||
(highlight-parens)))))]
|
||||
[after-insert
|
||||
(lambda (start size)
|
||||
(highlight-parens)))))
|
||||
(define (after-insert start size)
|
||||
(send backward-cache invalidate start)
|
||||
(send forward-cache forward-invalidate start size)
|
||||
(unless (delay-highlight?)
|
||||
(unless (local-edit-sequence?)
|
||||
(when (has-focus?)
|
||||
(highlight-parens)))
|
||||
(super-after-insert start size))]
|
||||
[after-delete
|
||||
(lambda (start size)
|
||||
(super-after-insert start size))
|
||||
(define (after-delete start size)
|
||||
(super-after-delete start size)
|
||||
(send backward-cache invalidate start)
|
||||
(send forward-cache forward-invalidate (+ start size) (- size))
|
||||
(unless (delay-highlight?)
|
||||
(unless (local-edit-sequence?)
|
||||
(when (has-focus?)
|
||||
(highlight-parens))))]
|
||||
[after-set-size-constraint
|
||||
(lambda ()
|
||||
(unless (delay-highlight?)
|
||||
(highlight-parens))))
|
||||
(define (after-set-size-constraint)
|
||||
(unless (local-edit-sequence?)
|
||||
(when (has-focus?)
|
||||
(highlight-parens)))
|
||||
(super-after-set-size-constraint))]
|
||||
[after-set-position
|
||||
(lambda ()
|
||||
(unless (delay-highlight?)
|
||||
(super-after-set-size-constraint))
|
||||
(define (after-set-position )
|
||||
(unless (local-edit-sequence?)
|
||||
(when (has-focus?)
|
||||
(highlight-parens)))
|
||||
(super-after-set-position))])
|
||||
(super-after-set-position))
|
||||
|
||||
(private-field
|
||||
[highlight-parens? (preferences:get 'framework:highlight-parens)]
|
||||
[remove-paren-callback (preferences:add-callback
|
||||
[define highlight-parens? (preferences:get 'framework:highlight-parens)]
|
||||
[define remove-paren-callback (preferences:add-callback
|
||||
'framework:highlight-parens
|
||||
(lambda (p value)
|
||||
(set! highlight-parens? value)))])
|
||||
(private
|
||||
[find-enclosing-paren
|
||||
(lambda (pos)
|
||||
(set! highlight-parens? value)))]
|
||||
(define (find-enclosing-paren pos)
|
||||
(let loop ([pos pos])
|
||||
(let ([paren-pos
|
||||
(let loop ([pairs (scheme-paren:get-paren-pairs)]
|
||||
|
|
@ -253,11 +240,13 @@
|
|||
(< semi-pos (paragraph-start-position
|
||||
(position-paragraph paren-pos))))
|
||||
paren-pos]
|
||||
[else (loop (- semi-pos 1))]))]))))])
|
||||
(private-field
|
||||
[clear-old-locations void])
|
||||
(public
|
||||
[highlight-parens
|
||||
[else (loop (- semi-pos 1))]))]))))
|
||||
|
||||
[define clear-old-locations 'dummy]
|
||||
(set! clear-old-locations void)
|
||||
|
||||
(public highlight-parens)
|
||||
(define highlight-parens
|
||||
(opt-lambda ([just-clear? #f])
|
||||
(when highlight-parens?
|
||||
(set! in-highlight-parens? #t)
|
||||
|
|
@ -341,12 +330,16 @@
|
|||
[before (handle-single before)]
|
||||
[else (void)])))))
|
||||
(end-edit-sequence)
|
||||
(set! in-highlight-parens? #f)))]
|
||||
(set! in-highlight-parens? #f))))
|
||||
|
||||
[get-limit (lambda (pos) 0)]
|
||||
(public get-limit balance-quotes balance-parens tabify-on-return? tabify tabify-selection
|
||||
tabify-all insert-return calc-last-para comment-out-selection uncomment-selection
|
||||
get-forward-sexp remove-sexp forward-sexp flash-forward-sexp get-backward-sexp
|
||||
flash-backward-sexp backward-sexp find-up-sexp up-sexp find-down-sexp down-sexp
|
||||
remove-parens-forward)
|
||||
(define (get-limit pos) 0)
|
||||
|
||||
[balance-quotes
|
||||
(lambda (key)
|
||||
(define (balance-quotes key)
|
||||
(let* ([char (send key get-key-code)]) ;; must be a character because of the mapping setup
|
||||
;; this function is only bound to ascii-returning keys
|
||||
(insert char)
|
||||
|
|
@ -355,10 +348,9 @@
|
|||
[match (scheme-paren:backward-match
|
||||
this start-pos limit backward-cache)])
|
||||
(when match
|
||||
(flash-on match (add1 match))))))]
|
||||
[balance-parens
|
||||
(lambda (key-event)
|
||||
(let-struct string/pos (string pos)
|
||||
(flash-on match (add1 match))))))
|
||||
|
||||
(define (balance-parens key-event)
|
||||
(letrec ([char (send key-event get-key-code)] ;; must be a character. See above.
|
||||
[here (get-start-position)]
|
||||
[limit (get-limit here)]
|
||||
|
|
@ -401,9 +393,10 @@
|
|||
(insert char)]))]
|
||||
[else (insert char)]))]
|
||||
[else (insert char)])
|
||||
#t)))]
|
||||
[tabify-on-return? (lambda () #t)]
|
||||
[tabify
|
||||
#t))
|
||||
|
||||
(define (tabify-on-return?) #t)
|
||||
(define tabify
|
||||
(opt-lambda ([pos (get-start-position)])
|
||||
(let* ([last-pos (last-position)]
|
||||
[para (position-paragraph pos)]
|
||||
|
|
@ -528,8 +521,9 @@
|
|||
(indent-first-arg (+ contains
|
||||
name-length)))))]
|
||||
[else
|
||||
(do-indent (indent-first-arg (paragraph-start-position last-para)))]))))]
|
||||
[tabify-selection
|
||||
(do-indent (indent-first-arg (paragraph-start-position last-para)))])))))
|
||||
|
||||
(define tabify-selection
|
||||
(opt-lambda ([start-pos (get-start-position)]
|
||||
[end-pos (get-end-position)])
|
||||
(let ([first-para (position-paragraph start-pos)]
|
||||
|
|
@ -561,10 +555,10 @@
|
|||
(lambda ()
|
||||
(end-edit-sequence)
|
||||
(when (< first-para end-para)
|
||||
(end-busy-cursor)))))))]
|
||||
[tabify-all (lambda () (tabify-selection 0 (last-position)))]
|
||||
[insert-return
|
||||
(lambda ()
|
||||
(end-busy-cursor))))))))
|
||||
|
||||
(define (tabify-all) (tabify-selection 0 (last-position)))
|
||||
(define (insert-return)
|
||||
(if (tabify-on-return?)
|
||||
(begin
|
||||
(begin-edit-sequence)
|
||||
|
|
@ -578,11 +572,9 @@
|
|||
(loop (add1 new-pos))
|
||||
new-pos)))
|
||||
(end-edit-sequence))
|
||||
(insert #\newline)))]
|
||||
(insert #\newline)))
|
||||
|
||||
|
||||
[calc-last-para
|
||||
(lambda (last-pos)
|
||||
(define (calc-last-para last-pos)
|
||||
(let ([last-para (position-paragraph last-pos #t)])
|
||||
(if (and (> last-pos 0)
|
||||
(> last-para 0))
|
||||
|
|
@ -591,8 +583,9 @@
|
|||
(if (member 'hard-newline (send snip get-flags))
|
||||
(- last-para 1)
|
||||
last-para)))
|
||||
last-para)))]
|
||||
[comment-out-selection
|
||||
last-para)))
|
||||
|
||||
(define comment-out-selection
|
||||
(opt-lambda ([start-pos (get-start-position)]
|
||||
[end-pos (get-end-position)])
|
||||
(begin-edit-sequence)
|
||||
|
|
@ -611,8 +604,9 @@
|
|||
(paragraph-start-position (position-paragraph (get-start-position)))
|
||||
(get-end-position))))
|
||||
(end-edit-sequence)
|
||||
#t)]
|
||||
[uncomment-selection
|
||||
#t))
|
||||
|
||||
(define uncomment-selection
|
||||
(opt-lambda ([start-pos (get-start-position)]
|
||||
[end-pos (get-end-position)])
|
||||
(begin-edit-sequence)
|
||||
|
|
@ -631,35 +625,36 @@
|
|||
(delete first-on-para (+ first-on-para 1)))
|
||||
(para-loop (add1 curr-para))))))
|
||||
(end-edit-sequence)
|
||||
#t)]
|
||||
[get-forward-sexp
|
||||
#t))
|
||||
|
||||
[define get-forward-sexp
|
||||
(lambda (start-pos)
|
||||
(scheme-paren:forward-match
|
||||
this start-pos
|
||||
(last-position)
|
||||
forward-cache))]
|
||||
[remove-sexp
|
||||
[define remove-sexp
|
||||
(lambda (start-pos)
|
||||
(let ([end-pos (get-forward-sexp start-pos)])
|
||||
(if end-pos
|
||||
(kill 0 start-pos end-pos)
|
||||
(bell))
|
||||
#t))]
|
||||
[forward-sexp
|
||||
[define forward-sexp
|
||||
(lambda (start-pos)
|
||||
(let ([end-pos (get-forward-sexp start-pos)])
|
||||
(if end-pos
|
||||
(set-position end-pos)
|
||||
(bell))
|
||||
#t))]
|
||||
[flash-forward-sexp
|
||||
[define flash-forward-sexp
|
||||
(lambda (start-pos)
|
||||
(let ([end-pos (get-forward-sexp start-pos)])
|
||||
(if end-pos
|
||||
(flash-on end-pos (add1 end-pos))
|
||||
(bell))
|
||||
#t))]
|
||||
[get-backward-sexp
|
||||
[define get-backward-sexp
|
||||
(lambda (start-pos)
|
||||
(let* ([limit (get-limit start-pos)]
|
||||
[end-pos
|
||||
|
|
@ -675,21 +670,21 @@
|
|||
end-pos
|
||||
#f)])
|
||||
ans))]
|
||||
[flash-backward-sexp
|
||||
[define flash-backward-sexp
|
||||
(lambda (start-pos)
|
||||
(let ([end-pos (get-backward-sexp start-pos)])
|
||||
(if end-pos
|
||||
(flash-on end-pos (add1 end-pos))
|
||||
(bell))
|
||||
#t))]
|
||||
[backward-sexp
|
||||
[define backward-sexp
|
||||
(lambda (start-pos)
|
||||
(let ([end-pos (get-backward-sexp start-pos)])
|
||||
(if end-pos
|
||||
(set-position end-pos)
|
||||
(bell))
|
||||
#t))]
|
||||
[find-up-sexp
|
||||
[define find-up-sexp
|
||||
(lambda (start-pos)
|
||||
(let* ([exp-pos
|
||||
(scheme-paren:backward-containing-sexp
|
||||
|
|
@ -716,14 +711,14 @@
|
|||
#f
|
||||
(- (apply max poss) 1))) ;; subtract one to move outside the paren
|
||||
#f)))]
|
||||
[up-sexp
|
||||
[define up-sexp
|
||||
(lambda (start-pos)
|
||||
(let ([exp-pos (find-up-sexp start-pos)])
|
||||
(if exp-pos
|
||||
(set-position exp-pos)
|
||||
(bell))
|
||||
#t))]
|
||||
[find-down-sexp
|
||||
[define find-down-sexp
|
||||
(lambda (start-pos)
|
||||
(let ([last (last-position)])
|
||||
(let loop ([pos start-pos])
|
||||
|
|
@ -739,14 +734,14 @@
|
|||
back-pos
|
||||
(loop next-pos)))
|
||||
#f)))))]
|
||||
[down-sexp
|
||||
[define down-sexp
|
||||
(lambda (start-pos)
|
||||
(let ([pos (find-down-sexp start-pos)])
|
||||
(if pos
|
||||
(set-position pos)
|
||||
(bell))
|
||||
#t))]
|
||||
[remove-parens-forward
|
||||
[define remove-parens-forward
|
||||
(lambda (start-pos)
|
||||
(let* ([pos (paren:skip-whitespace this start-pos 'forward)]
|
||||
[first-char (get-character pos)]
|
||||
|
|
@ -762,10 +757,9 @@
|
|||
(delete (- closer 2) (- closer 1))
|
||||
(end-edit-sequence))
|
||||
(bell))
|
||||
#t))])
|
||||
#t))]
|
||||
|
||||
(private
|
||||
[select-text
|
||||
[define select-text
|
||||
(lambda (f forward?)
|
||||
(let* ([start-pos (get-start-position)]
|
||||
[end-pos (get-end-position)])
|
||||
|
|
@ -776,14 +770,16 @@
|
|||
(if (and new-start new-end)
|
||||
(set-position new-start new-end)
|
||||
(bell))
|
||||
#t)))])
|
||||
(public
|
||||
[select-forward-sexp (lambda () (select-text (lambda (x) (get-forward-sexp x)) #t))]
|
||||
[select-backward-sexp (lambda () (select-text (lambda (x) (get-backward-sexp x)) #f))]
|
||||
[select-up-sexp (lambda () (select-text (lambda (x) (find-up-sexp x)) #f))]
|
||||
[select-down-sexp (lambda () (select-text (lambda (x) (find-down-sexp x)) #t))]
|
||||
#t)))]
|
||||
(public select-forward-sexp select-backward-sexp select-up-sexp select-down-sexp
|
||||
transpose-sexp)
|
||||
|
||||
[transpose-sexp
|
||||
[define select-forward-sexp (lambda () (select-text (lambda (x) (get-forward-sexp x)) #t))]
|
||||
[define select-backward-sexp (lambda () (select-text (lambda (x) (get-backward-sexp x)) #f))]
|
||||
[define select-up-sexp (lambda () (select-text (lambda (x) (find-up-sexp x)) #f))]
|
||||
[define select-down-sexp (lambda () (select-text (lambda (x) (find-down-sexp x)) #t))]
|
||||
|
||||
[define transpose-sexp
|
||||
(lambda (pos)
|
||||
(let ([start-1 (get-backward-sexp pos)])
|
||||
(if (not start-1)
|
||||
|
|
@ -806,28 +802,26 @@
|
|||
(insert text-1 start-2 end-2)
|
||||
(insert text-2 start-1 end-1)
|
||||
(set-position end-2)
|
||||
(end-edit-sequence)))))))))))])
|
||||
(private-field
|
||||
[tab-size 8])
|
||||
(public
|
||||
[get-tab-size (lambda () tab-size)]
|
||||
[set-tab-size (lambda (s) (set! tab-size s))])
|
||||
(end-edit-sequence)))))))))))]
|
||||
[define tab-size 8]
|
||||
(public get-tab-size set-tab-size)
|
||||
[define get-tab-size (lambda () tab-size)]
|
||||
[define set-tab-size (lambda (s) (set! tab-size s))]
|
||||
|
||||
(rename [super-get-keymaps get-keymaps])
|
||||
(override
|
||||
[get-keymaps
|
||||
(override get-keymaps)
|
||||
[define get-keymaps
|
||||
(lambda ()
|
||||
(cons keymap (super-get-keymaps)))])
|
||||
(cons keymap (super-get-keymaps)))]
|
||||
|
||||
(sequence
|
||||
(apply super-init args)
|
||||
(super-instantiate ())
|
||||
|
||||
(highlight-parens #t)
|
||||
(set-load-overwrites-styles #f)
|
||||
(set-wordbreak-map wordbreak-map)
|
||||
(set-tabs null tab-size #f)
|
||||
(set-style-list style-list)
|
||||
(set-styles-fixed #t))))
|
||||
(set-styles-fixed #t)))
|
||||
|
||||
(define -text% (text-mixin text:info%))
|
||||
|
||||
|
|
|
|||
|
|
@ -131,18 +131,21 @@
|
|||
|
||||
(define-signature framework:text^
|
||||
(basic<%>
|
||||
hide/selection<%>
|
||||
searching<%>
|
||||
return<%>
|
||||
info<%>
|
||||
clever-file-format<%>
|
||||
|
||||
basic-mixin
|
||||
hide/selection-mixin
|
||||
searching-mixin
|
||||
return-mixin
|
||||
info-mixin
|
||||
clever-file-format-mixin
|
||||
|
||||
basic%
|
||||
hide/selection%
|
||||
keymap%
|
||||
return%
|
||||
autowrap%
|
||||
|
|
|
|||
|
|
@ -1,36 +1,23 @@
|
|||
(module standard-menus-items mzscheme
|
||||
(provide
|
||||
;(struct generic (name initializer))
|
||||
generic? generic-name generic-initializer
|
||||
(struct generic (name initializer))
|
||||
|
||||
;(generic/docs (documentation))
|
||||
generic/docs? generic/docs-documentation
|
||||
(struct generic/docs (documentation))
|
||||
|
||||
;(struct generic-override ())
|
||||
generic-override?
|
||||
;(struct generic-method ())
|
||||
generic-method?
|
||||
;(struct generic-private-field ())
|
||||
generic-private-field?
|
||||
(struct generic-override ())
|
||||
(struct generic-method ())
|
||||
(struct generic-private-field ())
|
||||
|
||||
;(struct menu-item (menu-name))
|
||||
menu-item-menu-name
|
||||
(struct menu-item (menu-name))
|
||||
menu-name->get-menu-name ;; : menu-item -> symbol
|
||||
|
||||
;(struct before/after (name procedure))
|
||||
;(struct before ())
|
||||
;(struct after ())
|
||||
before? after?
|
||||
before/after-name before/after-procedure
|
||||
(struct before/after (name procedure))
|
||||
(struct before ())
|
||||
(struct after ())
|
||||
|
||||
;(struct between (before after procedure))
|
||||
between?
|
||||
between-before between-after between-procedure
|
||||
(struct between (before after procedure))
|
||||
|
||||
;(struct an-item (item-name help-string proc key menu-string-before menu-string-after on-demand))
|
||||
an-item?
|
||||
an-item-item-name an-item-help-string an-item-proc an-item-key
|
||||
an-item-menu-string-before an-item-menu-string-after an-item-on-demand
|
||||
(struct an-item (item-name help-string proc key menu-string-before menu-string-after on-demand))
|
||||
|
||||
;; an-item -> symbol
|
||||
;; calcualates the names of various identifiers associated with the item.
|
||||
|
|
|
|||
|
|
@ -37,8 +37,11 @@
|
|||
move/copy-to-edit
|
||||
initial-autowrap-bitmap))
|
||||
|
||||
(define highlight-pen (make-object pen% "BLACK" 0 'solid))
|
||||
(define highlight-brush (make-object brush% "black" 'solid))
|
||||
|
||||
(define basic-mixin
|
||||
(mixin (editor:basic<%> (class->interface text%)) (basic<%>) args
|
||||
(mixin (editor:basic<%> (class->interface text%)) (basic<%>)
|
||||
(inherit get-canvases get-admin split-snip get-snip-position
|
||||
begin-edit-sequence end-edit-sequence
|
||||
set-autowrap-bitmap
|
||||
|
|
@ -47,20 +50,15 @@
|
|||
get-style-list is-modified? change-style set-modified
|
||||
position-location get-extent)
|
||||
|
||||
(private-field
|
||||
[b1 (box 0)]
|
||||
(define range-rectangles null)
|
||||
(define ranges null)
|
||||
|
||||
(define (invalidate-rectangles rectangles)
|
||||
(let ([b1 (box 0)]
|
||||
[b2 (box 0)]
|
||||
[b3 (box 0)]
|
||||
[b4 (box 0)]
|
||||
[range-rectangles null]
|
||||
[ranges null]
|
||||
[pen (make-object pen% "BLACK" 0 'solid)]
|
||||
[brush (make-object brush% "black" 'solid)])
|
||||
(private
|
||||
[invalidate-rectangles
|
||||
(lambda (rectangles)
|
||||
(let-values
|
||||
([(min-left max-right)
|
||||
[b4 (box 0)])
|
||||
(let-values ([(min-left max-right)
|
||||
(let loop ([left #f]
|
||||
[right #f]
|
||||
[canvases (get-canvases)])
|
||||
|
|
@ -124,11 +122,12 @@
|
|||
this-top
|
||||
this-right
|
||||
this-bottom
|
||||
(cdr rectangles))))])))))]
|
||||
(cdr rectangles))))]))))))
|
||||
|
||||
[recompute-range-rectangles
|
||||
(lambda ()
|
||||
(let ([new-rectangles
|
||||
(define (recompute-range-rectangles)
|
||||
(let* ([b1 (box 0)]
|
||||
[b2 (box 0)]
|
||||
[new-rectangles
|
||||
(lambda (range)
|
||||
(let* ([start (range-start range)]
|
||||
[end (range-end range)]
|
||||
|
|
@ -190,10 +189,10 @@
|
|||
|
||||
(set! range-rectangles
|
||||
(foldl (lambda (x l) (append (new-rectangles x) l))
|
||||
null ranges))))])
|
||||
(public
|
||||
;; the bitmap is used in b/w and the color is used in color.
|
||||
[highlight-range
|
||||
null ranges))))
|
||||
|
||||
(public highlight-range)
|
||||
(define highlight-range
|
||||
(opt-lambda (start end color bitmap [caret-space? #f] [priority 'low])
|
||||
(unless (let ([exact-pos-int?
|
||||
(lambda (x) (and (integer? x) (exact? x) (x . >= . 0)))])
|
||||
|
|
@ -219,13 +218,16 @@
|
|||
(cdr r)
|
||||
(cons (car r) (loop (cdr r))))])))
|
||||
(recompute-range-rectangles)
|
||||
(invalidate-rectangles old-rectangles)))))])
|
||||
(invalidate-rectangles old-rectangles))))))
|
||||
(rename [super-on-paint on-paint])
|
||||
(override
|
||||
[on-paint
|
||||
(lambda (before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret)
|
||||
(override on-paint)
|
||||
(define (on-paint before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret)
|
||||
(super-on-paint before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret)
|
||||
(recompute-range-rectangles)
|
||||
(let ([b1 (box 0)]
|
||||
[b2 (box 0)]
|
||||
[b3 (box 0)]
|
||||
[b4 (box 0)])
|
||||
(for-each
|
||||
(lambda (rectangle)
|
||||
(let-values ([(view-x view-y view-width view-height)
|
||||
|
|
@ -266,61 +268,52 @@
|
|||
(let/ec k
|
||||
(cond
|
||||
[(and before color)
|
||||
(send pen set-color color)
|
||||
(send brush set-color color)]
|
||||
(send highlight-pen set-color color)
|
||||
(send highlight-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)]
|
||||
(send highlight-pen set-stipple b/w-bitmap)
|
||||
(send highlight-brush set-stipple b/w-bitmap)]
|
||||
[else (k (void))])
|
||||
(send dc set-pen pen)
|
||||
(send dc set-brush brush)
|
||||
(send dc draw-rectangle
|
||||
(+ left dx)
|
||||
(+ top dy)
|
||||
width
|
||||
height)
|
||||
(send dc set-pen highlight-pen)
|
||||
(send dc set-brush highlight-brush)
|
||||
(send dc draw-rectangle (+ left dx) (+ top dy) width height)
|
||||
(send dc set-pen old-pen)
|
||||
(send dc set-brush old-brush)))))
|
||||
range-rectangles))])
|
||||
range-rectangles)))
|
||||
|
||||
(define styles-fixed? #f)
|
||||
(define styles-fixed-edit-modified? #f)
|
||||
(public get-styles-fixed set-styles-fixed)
|
||||
(define (get-styles-fixed) styles-fixed?)
|
||||
(define (set-styles-fixed b) (set! styles-fixed? b))
|
||||
|
||||
(private-field
|
||||
[styles-fixed? #f]
|
||||
[styles-fixed-edit-modified? #f])
|
||||
(public
|
||||
[get-styles-fixed (lambda () styles-fixed?)]
|
||||
[set-styles-fixed (lambda (b) (set! styles-fixed? b))])
|
||||
(rename
|
||||
[super-on-change-style on-change-style]
|
||||
[super-after-change-style after-change-style]
|
||||
[super-on-insert on-insert]
|
||||
[super-after-insert after-insert])
|
||||
(override
|
||||
[on-change-style
|
||||
(lambda (start len)
|
||||
(override on-change-style on-insert after-insert after-change-style)
|
||||
(define (on-change-style start len)
|
||||
(when styles-fixed?
|
||||
(set! styles-fixed-edit-modified? (is-modified?)))
|
||||
(super-on-change-style start len))]
|
||||
[on-insert
|
||||
(lambda (start len)
|
||||
(super-on-change-style start len))
|
||||
(define (on-insert start len)
|
||||
(begin-edit-sequence)
|
||||
(super-on-insert start len))]
|
||||
[after-insert
|
||||
(lambda (start len)
|
||||
(super-on-insert start len))
|
||||
(define (after-insert start len)
|
||||
(when styles-fixed?
|
||||
(change-style (send (get-style-list) find-named-style "Standard")
|
||||
start
|
||||
(+ start len)))
|
||||
(super-after-insert start len)
|
||||
(end-edit-sequence))]
|
||||
[after-change-style
|
||||
(lambda (start len)
|
||||
(end-edit-sequence))
|
||||
(define (after-change-style start len)
|
||||
(super-after-change-style start len)
|
||||
(when styles-fixed?
|
||||
(set-modified styles-fixed-edit-modified?)))])
|
||||
(set-modified styles-fixed-edit-modified?)))
|
||||
|
||||
(public
|
||||
[move/copy-to-edit
|
||||
(lambda (dest-edit start end dest-position)
|
||||
(public move/copy-to-edit)
|
||||
(define (move/copy-to-edit dest-edit start end dest-position)
|
||||
(split-snip start)
|
||||
(split-snip end)
|
||||
(let loop ([snip (find-snip end 'before)])
|
||||
|
|
@ -337,36 +330,39 @@
|
|||
(delete snip-start snip-end)
|
||||
snip))])
|
||||
(send dest-edit insert released/copied dest-position dest-position)
|
||||
(loop prev))])))])
|
||||
(loop prev))])))
|
||||
|
||||
(public
|
||||
[initial-autowrap-bitmap (lambda () (icon:get-autowrap-bitmap))])
|
||||
(public initial-autowrap-bitmap)
|
||||
(define (initial-autowrap-bitmap) (icon:get-autowrap-bitmap))
|
||||
|
||||
(sequence
|
||||
(apply super-init args)
|
||||
(set-autowrap-bitmap (initial-autowrap-bitmap)))))
|
||||
(super-instantiate ())
|
||||
(set-autowrap-bitmap (initial-autowrap-bitmap))))
|
||||
|
||||
(define hide/selection<%> (interface (basic<%>)))
|
||||
(define hide/selection-mixin
|
||||
(mixin (basic<%>) (hide/selection<%>)
|
||||
(override after-set-position)
|
||||
(inherit get-start-position get-end-position hide-caret)
|
||||
(define (after-set-position)
|
||||
(hide-caret (= (get-start-position) (get-end-position))))
|
||||
(super-instantiate ())))
|
||||
|
||||
(define searching<%> (interface (editor:keymap<%> basic<%>)))
|
||||
(define searching-mixin
|
||||
(mixin (editor:keymap<%> basic<%>) (searching<%>) args
|
||||
(mixin (editor:keymap<%> basic<%>) (searching<%>)
|
||||
(rename [super-get-keymaps get-keymaps])
|
||||
(override
|
||||
[get-keymaps
|
||||
(lambda ()
|
||||
(cons (keymap:get-search) (super-get-keymaps)))])
|
||||
|
||||
(sequence
|
||||
(apply super-init args))))
|
||||
(override get-keymaps)
|
||||
(define (get-keymaps)
|
||||
(cons (keymap:get-search) (super-get-keymaps)))
|
||||
(super-instantiate ())))
|
||||
|
||||
(define return<%> (interface ((class->interface text%))))
|
||||
|
||||
(define return-mixin
|
||||
(mixin ((class->interface text%)) (return<%>) (_return . args)
|
||||
(mixin ((class->interface text%)) (return<%>)
|
||||
(init-field return)
|
||||
(rename [super-on-local-char on-local-char])
|
||||
(private-field [return _return])
|
||||
(override
|
||||
[on-local-char
|
||||
(lambda (key)
|
||||
(override on-local-char)
|
||||
(define (on-local-char key)
|
||||
(let ([cr-code #\return]
|
||||
[lf-code #\newline]
|
||||
[code (send key get-key-code)])
|
||||
|
|
@ -374,14 +370,13 @@
|
|||
(or (char=? lf-code code)
|
||||
(char=? cr-code code))
|
||||
(return))
|
||||
(super-on-local-char key))))])
|
||||
(sequence
|
||||
(apply super-init args))))
|
||||
(super-on-local-char key))))
|
||||
(super-instantiate ())))
|
||||
|
||||
(define info<%> (interface (basic<%>)))
|
||||
|
||||
(define info-mixin
|
||||
(mixin (editor:keymap<%> basic<%>) (info<%>) args
|
||||
(mixin (editor:keymap<%> basic<%>) (info<%>)
|
||||
(inherit get-start-position get-end-position get-canvas
|
||||
run-after-edit-sequence)
|
||||
(rename [super-after-set-position after-set-position]
|
||||
|
|
@ -391,9 +386,7 @@
|
|||
[super-after-delete after-delete]
|
||||
[super-set-overwrite-mode set-overwrite-mode]
|
||||
[super-set-anchor set-anchor])
|
||||
(private
|
||||
[enqueue-for-frame
|
||||
(lambda (call-method tag)
|
||||
(define (enqueue-for-frame call-method tag)
|
||||
(run-after-edit-sequence
|
||||
(rec from-enqueue-for-frame
|
||||
(lambda ()
|
||||
|
|
@ -402,59 +395,50 @@
|
|||
(let ([frame (send canvas get-top-level-window)])
|
||||
(when (is-a? frame frame:text-info<%>)
|
||||
(call-method frame)))))))
|
||||
tag))])
|
||||
(override
|
||||
[set-anchor
|
||||
(lambda (x)
|
||||
tag))
|
||||
(override set-anchor set-overwrite-mode after-set-position after-insert after-delete)
|
||||
(define (set-anchor x)
|
||||
(super-set-anchor x)
|
||||
(enqueue-for-frame
|
||||
(lambda (x) (send x anchor-status-changed))
|
||||
'framework:anchor-status-changed))]
|
||||
[set-overwrite-mode
|
||||
(lambda (x)
|
||||
'framework:anchor-status-changed))
|
||||
(define (set-overwrite-mode x)
|
||||
(super-set-overwrite-mode x)
|
||||
(enqueue-for-frame
|
||||
(lambda (x) (send x overwrite-status-changed))
|
||||
'framework:overwrite-status-changed))]
|
||||
[after-set-position
|
||||
(lambda ()
|
||||
'framework:overwrite-status-changed))
|
||||
(define (after-set-position)
|
||||
(super-after-set-position)
|
||||
(enqueue-for-frame
|
||||
(lambda (x) (send x editor-position-changed))
|
||||
'framework:editor-position-changed))]
|
||||
[after-insert
|
||||
(lambda (start len)
|
||||
'framework:editor-position-changed))
|
||||
(define (after-insert start len)
|
||||
(super-after-insert start len)
|
||||
(enqueue-for-frame
|
||||
(lambda (x) (send x editor-position-changed))
|
||||
'framework:editor-position-changed))]
|
||||
[after-delete
|
||||
(lambda (start len)
|
||||
'framework:editor-position-changed))
|
||||
(define (after-delete start len)
|
||||
(super-after-delete start len)
|
||||
(enqueue-for-frame
|
||||
(lambda (x) (send x editor-position-changed))
|
||||
'framework:editor-position-changed))])
|
||||
(sequence
|
||||
(apply super-init args))))
|
||||
'framework:editor-position-changed))
|
||||
(super-instantiate ())))
|
||||
|
||||
(define clever-file-format<%> (interface ((class->interface text%))))
|
||||
|
||||
(define clever-file-format-mixin
|
||||
(mixin ((class->interface text%)) (clever-file-format<%>) args
|
||||
(mixin ((class->interface text%)) (clever-file-format<%>)
|
||||
(inherit get-file-format set-file-format find-first-snip)
|
||||
(rename [super-on-save-file on-save-file])
|
||||
(private
|
||||
[all-string-snips
|
||||
(lambda ()
|
||||
(define (all-string-snips)
|
||||
(let loop ([s (find-first-snip)])
|
||||
(cond
|
||||
[(not s) #t]
|
||||
[(is-a? s string-snip%)
|
||||
(loop (send s next))]
|
||||
[else #f])))])
|
||||
(override
|
||||
[on-save-file
|
||||
(lambda (name format)
|
||||
[else #f])))
|
||||
(override on-save-file)
|
||||
(define (on-save-file name format)
|
||||
(let ([all-strings? (all-string-snips)])
|
||||
(cond
|
||||
[(and all-strings?
|
||||
|
|
@ -472,11 +456,11 @@
|
|||
"Save this file in drscheme-specific non-text format?" "Yes" "No")))
|
||||
(set-file-format 'standard)]
|
||||
[else (void)]))
|
||||
(super-on-save-file name format))])
|
||||
(sequence
|
||||
(apply super-init args))))
|
||||
(super-on-save-file name format))
|
||||
(super-instantiate ())))
|
||||
|
||||
(define basic% (basic-mixin (editor:basic-mixin text%)))
|
||||
(define hide/selection% (hide/selection-mixin basic%))
|
||||
(define -keymap% (editor:keymap-mixin basic%))
|
||||
(define return% (return-mixin -keymap%))
|
||||
(define autowrap% (editor:autowrap-mixin -keymap%))
|
||||
|
|
|
|||
|
|
@ -12,7 +12,8 @@
|
|||
(define (splash filename title width-default)
|
||||
(let/ec k
|
||||
(letrec-values
|
||||
([(no-splash) (lambda () (k void void void))]
|
||||
([(splash-eventspace) (make-eventspace)]
|
||||
[(no-splash) (lambda () (k #f #f splash-eventspace void void void))]
|
||||
[(funny?) (let ([date (seconds->date (current-seconds))])
|
||||
(and (= (date-day date) 25)
|
||||
(= (date-month date) 12)))]
|
||||
|
|
@ -116,7 +117,6 @@
|
|||
(when quit-on-close?
|
||||
(exit)))])
|
||||
(sequence (super-init title)))]
|
||||
[(splash-eventspace) (make-eventspace)]
|
||||
[(frame) (parameterize ([current-eventspace splash-eventspace])
|
||||
(make-object splash-frame% title))]
|
||||
[(_0) (send frame accept-drop-files #t)]
|
||||
|
|
@ -133,7 +133,7 @@
|
|||
[else 'xpm]))))]
|
||||
[(bitmap) (make-object bitmap% filename bitmap-flag)]
|
||||
[(_2) (unless (send bitmap ok?)
|
||||
(fprintf (current-error-port) "WARNING: bad bitmap ~s" filename)
|
||||
(fprintf (current-error-port) "WARNING: bad bitmap ~s~n" filename)
|
||||
(no-splash))]
|
||||
[(splash-canvas%)
|
||||
(class100 canvas% args
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user