original commit: 6cd40de9ccf0d15a24d9590c875de9e822b99bef
This commit is contained in:
Robby Findler 1998-09-09 13:51:39 +00:00
parent 4537d37219
commit 89a5e422e1
5 changed files with 842 additions and 196 deletions

View File

@ -393,10 +393,10 @@
(public
[save-as
(opt-lambda ([format wx:const-media-ff-same])
(opt-lambda ([format 'same])
(let ([file (parameterize ([mred:finder:dialog-parent-parameter
this])
(mred:finder:put-file))])
(finder:put-file))])
(when file
(send (get-edit) save-file file format))))]
[file-menu:revert
@ -423,9 +423,9 @@
(send edit end-edit-sequence))
(begin
(send edit end-edit-sequence)
(mred:gui-utils:message-box
(format "could not read ~a" filename)
"Error Reverting"))))))
(message-box
"Error Reverting"
(format "could not read ~a" filename)))))))
#t))]
[file-menu:save (lambda ()
(send (get-edit) save-file)
@ -439,8 +439,8 @@
(lambda ()
(when (active-canvas)
(send panel split (active-canvas) panel%))))])
(send file-menu append-item "Split Horizontally" (split mred:container:horizontal-panel%))
(send file-menu append-item "Split Vertically" (split mred:container:vertical-panel%))
(send file-menu append-item "Split Horizontally" (split horizontal-panel%))
(send file-menu append-item "Split Vertically" (split vertical-panel%))
(send file-menu append-item "Collapse"
(lambda ()
(when (active-canvas)
@ -451,7 +451,7 @@
'()
#t
#t
(mred:preferences:get-preference 'mred:print-output-mode))
(preferences:get 'framework:print-output-mode))
#t)])
(private
@ -569,6 +569,682 @@
(do-title)
(let ([canvas (get-canvas)])
(send canvas set-focus)))))
(define make-searchable%
(let* ([anchor 0]
[searching-direction 1]
[old-highlight void]
[get-active-embedded-edit
(lambda (edit)
(let loop ([edit edit])
(let ([snip (send edit get-focus-snip)])
(if (or (null? snip)
(not (is-a? snip wx:media-snip%)))
edit
(loop (send snip get-this-media))))))]
[clear-highlight
(lambda ()
(begin (old-highlight)
(set! old-highlight void)))]
[reset-anchor
(let ([color (make-object wx:colour% "BLUE")])
(lambda (edit)
(old-highlight)
(let ([position
(if (= 1 searching-direction)
(send edit get-end-position)
(send edit get-start-position))])
(set! anchor position)
(set! old-highlight
(send edit highlight-range position position color #f)))))]
[replace-edit (make-object text%)]
[find-edit
(make-object
(class-asi text%
(inherit get-text)
(rename [super-after-insert after-insert]
[super-after-delete after-delete]
[super-on-focus on-focus])
(public
[searching-frame #f]
[set-searching-frame
(lambda (frame)
(set! searching-frame frame))]
[get-searching-edit
(lambda ()
(get-active-embedded-edit
(send searching-frame get-edit-to-search)))]
[search
(opt-lambda ([reset-anchor? #t] [beep? #t] [wrap? #t])
(when searching-frame
(let* ([string (get-text)]
[searching-edit (get-searching-edit)]
[not-found
(lambda (found-edit)
(send found-edit set-position anchor)
(when beep?
(wx:bell))
#f)]
[found
(lambda (edit first-pos)
(let ([last-pos (+ first-pos (* searching-direction
(string-length string)))])
(send* edit
(set-caret-owner null wx:const-focus-display)
(set-position
(min first-pos last-pos)
(max first-pos last-pos)))
#t))])
(when reset-anchor?
(reset-anchor searching-edit))
(let-values ([(found-edit first-pos)
(send searching-edit
find-string-embedded
string
searching-direction
anchor
-1 #t #t #t)])
(cond
[(= -1 first-pos)
(if wrap?
(let-values ([(found-edit pos)
(send searching-edit
find-string-embedded
string
searching-direction
(if (= 1 searching-direction)
0
(send searching-edit last-position)))])
(if (= -1 pos)
(not-found found-edit)
(found found-edit
((if (= searching-direction 1)
+
-)
pos
(string-length string)))))
(not-found found-edit))]
[else
(found found-edit first-pos)])))))]
[on-focus
(lambda (on?)
(when on?
(reset-anchor (get-searching-edit)))
(super-on-focus on?))]
[after-insert
(lambda args
(apply super-after-insert args)
(search #f))]
[after-delete
(lambda args
(apply super-after-delete args)
(search #f))])))]
[canvas%
(class editor-canvas% args
(inherit get-parent frame set-line-count)
(rename [super-on-set-focus on-set-focus])
(public
[lines 2]
[style-flags wx:const-mcanvas-hide-h-scroll]
[on-set-focus
(lambda ()
(send find-edit set-searching-frame frame)
(super-on-set-focus))])
(sequence
(apply super-init args)
(set-line-count 1)))])
(for-each (lambda (keymap)
(send keymap chain-to-keymap
keymap:global-search-keymap
#t))
(list (send find-edit get-keymap)
(send replace-edit get-keymap)))
(mixin frame:edit<%> frame:searchable<%> args
(inherit active-edit active-canvas get-edit)
(rename [super-make-root-panel make-root-panel]
[super-on-activate on-activate]
[super-do-close do-close])
(private
[super-root 'unitiaialized-super-root])
(public
[make-root-panel
(lambda (% parent)
(let* ([s-root (super-make-root-panel
vertical-panel%
parent)]
[root (make-object % s-root)])
(set! super-root s-root)
root))])
(public
[on-activate
(lambda (on?)
(unless hidden?
(if on?
(reset-anchor (get-edit-to-search))
(clear-highlight)))
(super-on-activate on?))]
[get-edit-to-search
(lambda ()
(get-edit))]
[hide-search
(opt-lambda ([startup? #f])
(send super-root delete-child search-panel)
(clear-highlight)
(unless startup?
(send
(send (get-edit-to-search) get-canvas)
set-focus))
(set! hidden? #t))]
[unhide-search
(lambda ()
(set! hidden? #f)
(send super-root add-child search-panel)
(reset-anchor (get-edit-to-search)))])
(public
[do-close
(lambda ()
(super-do-close)
(let ([close-canvas
(lambda (canvas edit)
(send edit remove-canvas canvas)
(send canvas set-media ()))])
(close-canvas find-canvas find-edit)
(close-canvas replace-canvas replace-edit))
(when (eq? this (ivar find-edit searching-frame))
(send find-edit set-searching-frame #f)))]
[set-search-direction
(lambda (x)
(set! searching-direction x)
(send dir-radio set-selection (if (= x 1) 0 1)))]
[replace&search
(lambda ()
(when (replace)
(search)))]
[replace-all
(lambda ()
(let* ([replacee-edit (get-edit-to-search)]
[pos (if (= searching-direction 1)
(send replacee-edit get-start-position)
(send replacee-edit get-end-position))]
[get-pos
(if (= searching-direction 1)
(ivar replacee-edit get-end-position)
(ivar replacee-edit get-start-position))]
[done? (if (= 1 searching-direction)
(lambda (x) (>= x (send replacee-edit last-position)))
(lambda (x) (<= x 0)))])
(send* replacee-edit
(begin-edit-sequence)
(set-position pos))
(when (search)
(send replacee-edit set-position pos)
(let loop ()
(when (send find-edit search #t #f #f)
(replace)
(loop))))
(send replacee-edit end-edit-sequence)))]
[replace
(lambda ()
(let* ([search-text (send find-edit get-text)]
[replacee-edit (get-edit-to-search)]
[replacee-start (send replacee-edit get-start-position)]
[new-text (send replace-edit get-text)]
[replacee (send replacee-edit get-text
replacee-start
(send replacee-edit get-end-position))])
(if (string=? replacee search-text)
(begin (send replacee-edit insert new-text)
(send replacee-edit set-position
replacee-start
(+ replacee-start (string-length new-text)))
#t)
#f)))]
[toggle-search-focus
(lambda ()
(when hidden?
(unhide-search))
(send (cond
[(send find-canvas is-focus-on?)
replace-canvas]
[(send replace-canvas is-focus-on?)
(send (get-edit-to-search) get-canvas)]
[else
find-canvas])
set-focus))]
[move-to-search-or-search
(lambda ()
(when hidden?
(unhide-search))
(if (or (send find-canvas is-focus-on?)
(send replace-canvas is-focus-on?))
(search 1)
(send find-canvas set-focus)))]
[move-to-search-or-reverse-search
(lambda ()
(when hidden?
(unhide-search))
(if (or (send find-canvas is-focus-on?)
(send replace-canvas is-focus-on?))
(search -1)
(send find-canvas set-focus)))]
[search
(opt-lambda ([direction searching-direction] [beep? #t])
(send find-edit set-searching-frame this)
(when hidden?
(unhide-search))
(set-search-direction direction)
(send find-edit search #t beep?))])
(sequence
(apply super-init args))
(private
[search-panel (make-object horizontal-panel% super-root)]
[left-panel (make-object vertical-panel% search-panel)]
[find-canvas (make-object canvas% left-panel)]
[replace-canvas (make-object canvas% left-panel)]
[middle-left-panel (make-object vertical-panel% search-panel)]
[middle-middle-panel (make-object vertical-panel% search-panel)]
[middle-right-panel (make-object vertical-panel% search-panel)]
[search-button (make-object button%
"Search"
middle-left-panel
(lambda args (search)))]
[replace&search-button (make-object button%
"Replace && Search"
middle-middle-panel
(lambda x (replace&search)))]
[replace-button (make-object button% "Replace" middle-left-panel (lambda x (replace)))]
[replace-all-button (make-object button%
"Replace To End"
middle-middle-panel
(lambda x (replace-all)))]
[dir-radio (make-object radio-box% middle-right-panel
(lambda (dir-radio evt)
(let ([forward (if (= 0 (send evt get-command-int))
1
-1)])
(set-search-direction forward)
(reset-anchor (get-edit-to-search))))
null
-1 -1 -1 -1
(list "Forward" "Backward"))]
[close-button (make-object button% middle-right-panel
(lambda args (hide-search)) "Hide")]
[hidden? #f])
(sequence
(let ([align
(lambda (x y)
(let ([m (max (send x get-width)
(send y get-width))])
(send x user-min-width m)
(send y user-min-width m)))])
(align search-button replace-button)
(align replace&search-button replace-all-button))
(for-each (lambda (x) (send x major-align-center))
(list middle-left-panel middle-middle-panel))
(for-each (lambda (x) (send x stretchable-in-y #f))
(list search-panel left-panel middle-left-panel middle-middle-panel middle-right-panel))
(for-each (lambda (x) (send x stretchable-in-x #f))
(list middle-left-panel middle-middle-panel middle-right-panel))
(send find-canvas set-media find-edit)
(send replace-canvas set-media replace-edit)
(send find-edit add-canvas find-canvas)
(send replace-edit add-canvas replace-canvas)
(hide-search #t)))))
(define make-info%
(let* ([time-edit (make-object text%)]
[time-semaphore (make-semaphore 1)]
[wide-time "00:00pm"]
[_ (send time-edit lock #t)]
[update-time
(lambda ()
(dynamic-wind
(lambda ()
(semaphore-wait time-semaphore)
(send time-edit lock #f))
(lambda ()
(send* time-edit
(erase)
(insert
(let* ([date (seconds->date
(current-seconds))]
[hours (date-hour date)]
[minutes (date-minute date)])
(format "~a:~a~a~a"
(cond
[(= hours 0) 12]
[(<= hours 12) hours]
[else (- hours 12)])
(quotient minutes 10)
(modulo minutes 10)
(if (< hours 12) "am" "pm"))))))
(lambda ()
(send time-edit lock #t)
(semaphore-post time-semaphore))))]
[time-thread
(thread
(rec loop
(lambda ()
(update-time)
(sleep 30)
(loop))))])
(mixin frame:edit<%> frame:info<%> args
(rename [super-make-root-panel make-root-panel])
(private
[rest-panel 'uninitialized-root]
[super-root 'uninitialized-super-root])
(public
[make-root-panel
(lambda (% parent)
(let* ([s-root (super-make-root-panel
vertical-panel%
parent)]
[r-root (make-object % s-root)])
(set! super-root s-root)
(set! rest-panel r-root)
r-root))])
(public
[determine-width
(let ([magic-space 25])
(lambda (string canvas edit)
(send edit set-autowrap-bitmap null)
(send canvas call-as-primary-owner
(lambda ()
(let ([lb (box 0)]
[rb (box 0)])
(send edit erase)
(send edit insert string)
(send edit position-location
(send edit last-position)
rb)
(send edit position-location 0 lb)
(send canvas user-min-width
(+ magic-space (- (unbox rb) (unbox lb)))))))))])
(rename [super-do-close do-close])
(private
[close-panel-callback
(preferences:add-callback
'framework:show-status-line
(lambda (p v)
(if v
(register-gc-blit)
(wx:unregister-collecting-blit gc-canvas))
(send super-root change-children
(lambda (l)
(if v
(list rest-panel info-panel)
(list rest-panel))))))])
(public
[do-close
(lambda ()
(super-do-close)
(send time-canvas set-media null)
(unregister-collecting-blit gc-canvas)
(close-panel-callback))])
(inherit get-edit)
(public
[get-info-edit
(lambda ()
(and (procedure? get-edit)
(get-edit)))])
(public
[lock-status-changed
(let ([icon-currently-locked? #f])
(lambda ()
(let ([info-edit (get-info-edit)])
(when info-edit
(let ([locked-now? (ivar info-edit locked?)])
(unless (eq? locked-now? icon-currently-locked?)
(set! icon-currently-locked? locked-now?)
(let ([label
(if locked-now?
(cons (icon:get-lock-mdc)
(icon:get-lock-bitmap))
(cons (icon:get-unlock-mdc)
(icon:get-unlock-bitmap)))])
(send lock-message
set-label
(if (send (car label) ok?)
label
(if locked-now? "Locked" "Unlocked"))))))))))])
(public
[update-info
(lambda ()
(lock-status-changed))])
(sequence
(apply super-init args))
(public
[info-panel (make-object horizontal-panel%
super-root)])
(private
[lock-message (make-object message%
(let ([b (mred:icon:get-unlock-bitmap)])
(if (send b ok?)
(cons (mred:icon:get-unlock-mdc) b)
"Unlocked"))
info-panel
'(border))]
[time-canvas (make-object editor-canvas% info-panel)]
[_ (send time-canvas set-line-count 1)]
[gc-canvas (make-object canvas% info-panel '(border))]
[register-gc-blit
(lambda ()
(let ([mdc (mred:icon:get-gc-on-dc)])
(when (send mdc ok?)
(register-collecting-blit gc-canvas
0 0
(mred:icon:get-gc-width)
(mred:icon:get-gc-height)
(mred:icon:get-gc-on-dc)
(mred:icon:get-gc-off-dc)))))])
(sequence
(unless (mred:preferences:get-preference 'mred:show-status-line)
(send super-root change-children
(lambda (l)
(list rest-panel))))
(register-gc-blit)
(let ([bw (box 0)]
[bh (box 0)]
[gc-width (icon:get-gc-width)]
[gc-height (icon:get-gc-height)])
(send* gc-canvas
(set-size 0 0 gc-width gc-height)
(get-client-size bw bh))
(send* gc-canvas
(user-min-client-width gc-width)
(user-min-client-height gc-height)
(stretchable-in-x #f)
(stretchable-in-y #f)))
(send* info-panel
(major-align-right)
(stretchable-in-y #f)
(spacing 3)
(border 3))
(send* time-canvas
(set-media time-edit)
(stretchable-in-x #f))
(semaphore-wait time-semaphore)
(determine-width wide-time time-canvas time-edit)
(semaphore-post time-semaphore)
(update-time)))))
(define make-edit-info%
(mixin (interface (frame:info<%> frame:edit<%>)) frame:edit-info<%> args
(inherit get-info-edit)
(rename [super-do-close do-close])
(private
[remove-pref-callback
(preferences:add-callback
'framework:line-offsets
(lambda (p v)
(edit-position-changed-offset v)
#t))])
(public
[do-close
(lambda ()
(super-do-close)
(remove-pref-callback))])
(public
[overwrite-status-changed
(let ([last-state? #f])
(lambda ()
(let ([info-edit (get-info-edit)])
(when info-edit
(let ([overwrite-now? (send info-edit get-overwrite-mode)])
(unless (eq? overwrite-now? last-state?)
(send overwrite-message
show
overwrite-now?)
(set! last-state? overwrite-now?)))))))]
[anchor-status-changed
(let ([last-state? #f])
(lambda ()
(let ([info-edit (get-info-edit)])
(when info-edit
(let ([anchor-now? (send info-edit get-anchor)])
(unless (eq? anchor-now? last-state?)
(send anchor-message
show
anchor-now?)
(set! last-state? anchor-now?)))))))]
[edit-position-changed-offset
(let ([last-start #f]
[last-end #f])
(lambda (offset?)
(let* ([edit (get-info-edit)]
[make-one
(lambda (pos)
(let* ([line (send edit position-line pos)]
[line-start (send edit line-start-position line)]
[char (- pos line-start)])
(if (preferences:get 'framework:display-line-numbers)
(format "~a:~a"
(if offset?
(add1 line)
line)
(if offset?
(add1 char)
char))
(format "~a"
(if offset?
(+ pos 1)
pos)))))])
(when edit
(let ([start (send edit get-start-position)]
[end (send edit get-end-position)])
(unless (and last-start
(= last-start start)
(= last-end end))
(set! last-start start)
(set! last-end end)
(when (object? position-edit)
(send* position-edit
(lock #f)
(erase)
(insert
(if (= start end)
(make-one start)
(string-append (make-one start)
"-"
(make-one end))))
(lock #t)))))))))]
[edit-position-changed
(lambda ()
(edit-position-changed-offset
(preferences:get 'framework:line-offsets)))])
(rename [super-update-info update-info])
(public
[update-info
(lambda ()
(super-update-info)
(overwrite-status-changed)
(anchor-status-changed)
(edit-position-changed))])
(sequence
(apply super-init args))
(inherit info-panel)
(private
[anchor-message
(make-object message%
(let ([b (mred:icon:get-anchor-bitmap)])
(if (send b ok?)
(cons (mred:icon:get-anchor-mdc) b)
"Anchor"))
info-panel '(border))]
[overwrite-message
(make-object mred:container:canvas-message%
"Overwrite"
info-panel
'(border))]
[position-canvas (make-object editor-canvas% info-panel)]
[_2 (send position-canvas set-line-count 1)]
[position-edit (make-object text%)])
(inherit determine-width)
(sequence
(let ([move-front
(lambda (x l)
(cons x (mzlib:function:remq x l)))])
(send info-panel change-children
(lambda (l)
(move-front
anchor-message
(move-front
overwrite-message
(move-front
position-canvas
l))))))
(send anchor-message show #f)
(send overwrite-message show #f)
(send* position-canvas
(set-media position-edit)
(stretchable-in-x #f))
(determine-width "0000:000-0000:000"
position-canvas
position-edit)
(edit-position-changed)
(send position-edit lock #t))))
(define make-file%
(lambda (super%)
(rec mred:file-frame%
(class-asi super%
(inherit get-edit)
(rename [super-can-close? can-close?])
(public
[can-close?
(lambda ()
(let* ([edit (get-edit)]
[user-allowed-or-not-modified
(or (not (send edit modified?))
(case (mred:gui-utils:unsaved-warning
(let ([fn (send edit get-filename)])
(if (string? fn)
fn
"Untitled"))
"Close"
#t)
[(continue) #t]
[(save) (send edit save-file)]
[else #f]))])
(and user-allowed-or-not-modified
(super-can-close?))))])))))
(define empty% (make-empty% frame%))
(define standard-menus% (make-standard-menus% empty%))

View File

@ -3,7 +3,7 @@
[mzlib:function : mzlib:function^]
[mzlib:file : mzlib:file^])
(define frame-group%
(define %
(let-struct frame (frame id)
(class null ()
(private
@ -194,39 +194,4 @@
frame
(loop (cdr frames))))]))))]))))
(define the-frame-group (make-object frame-group%))
(define at-most-one-maker
(lambda ()
(let ([s (make-semaphore 1)]
[test #f])
(lambda (return thunk)
(semaphore-wait s)
(if test
(begin (semaphore-post s)
return)
(begin
(set! test #t)
(semaphore-post s)
(begin0 (thunk)
(semaphore-wait s)
(set! test #f)
(semaphore-post s))))))))
(define at-most-one (at-most-one-maker))
(send the-frame-group set-empty-callbacks
(lambda ()
(at-most-one (void)
(lambda () (exit:exit #t))))
(lambda ()
(at-most-one #t
(lambda ()
(exit:run-exit-callbacks)))))
(exit:insert-exit-callback
(lambda ()
(at-most-one
#t
(lambda ()
(send the-frame-group close-all))))))
(define the-frame-group (make-object %)))

View File

@ -4,6 +4,25 @@
;; preferences
(preferences:set-default 'framework:display-line-numbers #t boolean?)
(preferences:set-preference-default 'mred:show-status-line
#t
boolean?)
(preferences:set-preference-default 'mred:line-offsets
#t
boolean?)
(preferences:set 'framework:print-output-mode
0
(lambda (x) (or (= x 0) (= x 1))))
(preferences:set-default 'framework:highlight-parens #t boolean?)
(preferences:set-default 'framework:fixup-parens #t boolean?)
(preferences:set-default 'framework:paren-match #t boolean?)
@ -23,22 +42,22 @@
sequence))
(for-each (lambda (x) (hash-table-put! hash-table x 'lambda))
'(lambda let let* letrec letrec* recur
let/cc let/ec letcc catch
let-syntax letrec-syntax syntax-case
let-signature fluid-let
let-struct let-macro let-values let*-values
case when unless match
let-enumerate
class class* class-asi class-asi*
define-some do opt-lambda send*
local catch shared
unit/sig
with-handlers with-parameterization
interface
parameterize
call-with-input-file with-input-from-file
with-input-from-port call-with-output-file
with-output-to-file with-output-to-port))
let/cc let/ec letcc catch
let-syntax letrec-syntax syntax-case
let-signature fluid-let
let-struct let-macro let-values let*-values
case when unless match
let-enumerate
class class* class-asi class-asi*
define-some do opt-lambda send*
local catch shared
unit/sig
with-handlers with-parameterization
interface
parameterize
call-with-input-file with-input-from-file
with-input-from-port call-with-output-file
with-output-to-file with-output-to-port))
(mred:preferences:set-preference-un/marshall
'mred:tabify
(lambda (t) (hash-table-map t list))
@ -46,8 +65,8 @@
(for-each (lambda (x) (apply hash-table-put! h x)) l)
h)))
(mred:preferences:set-preference-default 'mred:tabify hash-table hash-table?))
(preferences:set-default 'framework:autosave-delay 300 number?)
(preferences:set-default 'framework:autosaving-on? #t boolean?)
(preferences:set-default 'framework:verify-exit #t boolean?)
@ -120,8 +139,8 @@
[add-button (make-object mred:button% button-panel (add-callback string symbol box) "Add")]
[delete-button (make-object mred:button% button-panel (delete-callback box) "Remove")])
(send* button-panel
(major-align-center)
(stretchable-in-y #f))
(major-align-center)
(stretchable-in-y #f))
(send add-button user-min-width (send delete-button get-width))
box))]
[begin-list-box (make-column "Begin" 'begin begin-keywords)]
@ -139,11 +158,49 @@
#t))])
(mred:preferences:add-preference-callback 'mred:tabify (lambda (p v) (update-list-boxes v)))
main-panel))))
(preferences:read)
;; groups
(define at-most-one-maker
(lambda ()
(let ([s (make-semaphore 1)]
[test #f])
(lambda (return thunk)
(semaphore-wait s)
(if test
(begin (semaphore-post s)
return)
(begin
(set! test #t)
(semaphore-post s)
(begin0 (thunk)
(semaphore-wait s)
(set! test #f)
(semaphore-post s))))))))
(let ([at-most-one (at-most-one-maker)])
(send the-frame-group set-empty-callbacks
(lambda ()
(at-most-one (void)
(lambda () (exit:exit #t))))
(lambda ()
(at-most-one #t
(lambda ()
(exit:run-exit-callbacks)))))
(exit:insert-exit-callback
(lambda ()
(at-most-one
#t
(lambda ()
(send the-frame-group close-all))))))
;; misc other stuff
(exit:insert-callback
(lambda ()
(with-handlers ([(lambda (x) #t)
@ -153,5 +210,5 @@
(exn-message exn))
"Saving Prefs"))])
(save-user-preferences))))
(wx:application-file-handler edit-file))

View File

@ -32,51 +32,15 @@
pasteboard-info%
pasteboard-info-file%))
(define-signature mred:graph^
(node-snip%
make-node-snip%
graph-pasteboard%
make-graph-pasteboard%))
(define-signature mred:connections^
(connections-frame%
connections-dialog-box%
connections-media-edit%
connections-media-pasteboard%
connections-media-canvas%
connections-panel%
make-connections-frame%
make-connections-media-buffer%
make-connections-media-canvas%
make-connections-panel%))
(define-signature mred:version^
(add-version-spec
(define-signature framework:version^
(add-spec
version))
(define-signature mred:html^
(html-convert))
(define-signature mred:panel^
(make-edit-panel%
horizontal-edit-panel%
vertical-edit-panel%))
(define-signature mred:url^
((struct url (scheme host port path params query fragment))
unixpath->path
get-pure-port ; url [x list (str)] -> in-port
get-impure-port ; url [x list (str)] -> in-port
display-pure-port ; in-port -> ()
purify-port ; in-port -> list (mime-header)
netscape/string->url ; (string -> url)
string->url ; str -> url
url->string
call/input-url ; url x (url -> in-port) x
; (in-port -> ())
; [x list (str)] -> ()
combine-url/relative)) ; url x str -> url
(make-edit%
edit<%>
horizontal-edit%
vertical-edit%))
(define-signature framework:exn^
((struct exn ())
@ -84,17 +48,9 @@
(struct exn:during-preferences ())
(struct exn:url ())))
(define-signature mred:hyper-loader^
(open-hyper-make
open-hyper-view
hyper-text-require))
(define-signature framework:application^
(current-app-name))
(define-signature mred:exn-external^
(exn? exn:unknown-preference? exn:during-preferences? exn:url?))
(define-signature framework:preferences^
(get
add-callback
@ -113,57 +69,26 @@
(define-signature framework:autosave^
(register))
(define-signature mred:exit^
(define-signature framework:exit^
(insert-callback
remove-callback
run-callbacks
exit))
(define-signature mred:gui-utils^
(get-font-from-user
get-colour-from-user
get-text-from-user
message-box
cursor-delay
(define-signature framework:gui-utils^
(cursor-delay
show-busy-cursor
delay-action
local-busy-cursor
get-choice
unsaved-warning
read-snips/chars-from-buffer
open-input-buffer
print-paper-names
get-single-choice))
open-input-buffer))
(define-signature mred:console^
(credits-proc
credits
copyright-string
welcome-message
separator-snip%
console-max-save-previous-exprs
show-interactions-history
make-scheme-mode-edit%
scheme-mode-edit%
make-console-edit%
console-edit%
transparent-io-edit%
make-transparent-io-edit%
make-console-frame%
console-frame%))
(define-signature mred:path-utils^
(define-signature framework:path-utils^
(generate-autosave-name
generate-backup-name))
(define-signature mred:finder^
(define-signature framework:finder^
(filter-match?
dialog-parent-parameter
common-put-file
@ -175,12 +100,43 @@
get-file
put-file))
(define-signature mred:find-string^
(make-find-frame%
find-frame%
find-string))
(define framework:editor^
(editor:basic<%>
editor:info<%>
editor:autosave<%>
editor:make-basic%
editor:make-info%
editor:make-file%
editor:make-backup-autosave%))
(define-signature mred:edit^
(define-signature framework:text^
(text:basic<%>
text:searching<%>
text:make-basic%
text:make-return%
text:make-searching%
text:make-clever-file-format%
text:make-scheme%
text:basic%
text:return%
text:searching%
text:info%
text:clever-file-format%
text:file%
text:backup-autosave%
text:scheme%))
(define-signature framework:pasteboard%
(pasteboard:basic%
pasteboard:info%
pasteboard:file%
pasteboard:backup-autosave%))
(define-signature framework:edit^
(make-std-buffer%
make-pasteboard%
make-info-buffer%
@ -212,39 +168,33 @@
(make-wide-snip-canvas%
wide-snip-canvas%))
(define-signature mred:frame^
(frame-width
frame-height
(define-signature framework:frame^
(empty<%>
standard-menus<%>
empty-standard-menus<%>
edit<%>
searchable<%>
pasteboard<%>
info<%>
info-file<%>
make-simple-frame%
make-menu-frame%
make-standard-menus-frame%
make-searchable-frame%
make-info-frame%
make-edit-info-frame%
make-file-frame%
make-pasteboard-frame%
make-pasteboard-file-frame%
make-pasteboard-info-frame%
empty-frame%
menu-frame%
standard-menus-frame%
simple-menu-frame%
searchable-frame%
info-frame%
info-file-frame%
pasteboard-frame%
pasteboard-info-frame%
pasteboard-info-file-frame%))
(define-signature mred:editor-frame^
(make-editor-frame%
editor-frame%
make-status-frame%))
make-empty%
make-standard-menus%
make-edit%
make-searchable%
make-pasteboard%
make-info%
make-file%
empty%
standard-menus%
edit%
searchable%
info%
info-file%
pasteboard%
pasteboard-info%
pasteboard-info-file%))
(define-signature mred:group^
(frame-group%

View File

@ -1,7 +1,5 @@
(unit/sig mred:version^
(import [wx : wx^]
[mzlib:function : mzlib:function^]
[mzlib:string^ : mzlib:string^])
(import [mzlib:string^ : mzlib:string^])
(rename [-version version])