...
original commit: 382fab8691402cba8e3182ed2ae23ddbac4dfe8d
This commit is contained in:
Robby Findler
parent
f4b47c38f8
commit
6390931c40
|
|
@ -1,6 +1,9 @@
|
||||||
(module application mzscheme
|
(module application mzscheme
|
||||||
(require (lib "unitsig.ss")
|
(require (lib "unitsig.ss")
|
||||||
"../sig.ss")
|
"sig.ss"
|
||||||
|
(lib "mred-sig.ss" "mred"))
|
||||||
|
|
||||||
|
(provide application@)
|
||||||
|
|
||||||
(define application@
|
(define application@
|
||||||
(unit/sig framework:application^
|
(unit/sig framework:application^
|
||||||
|
|
|
||||||
|
|
@ -1,11 +1,14 @@
|
||||||
(module autosave mzscheme
|
(module autosave mzscheme
|
||||||
(require (lib "unitsig.ss")
|
(require (lib "unitsig.ss")
|
||||||
"../sig.ss"
|
"sig.ss"
|
||||||
(lib "mred.ss" "mred"))
|
(lib "mred-sig.ss" "mred"))
|
||||||
|
|
||||||
|
(provide autosave@)
|
||||||
|
|
||||||
(define autosave@
|
(define autosave@
|
||||||
(unit/sig framework:autosave^
|
(unit/sig framework:autosave^
|
||||||
(import [exit : framework:exit^]
|
(import [mred : mred^]
|
||||||
|
[exit : framework:exit^]
|
||||||
[preferences : framework:preferences^])
|
[preferences : framework:preferences^])
|
||||||
|
|
||||||
(define objects null)
|
(define objects null)
|
||||||
|
|
|
||||||
|
|
@ -1,11 +1,14 @@
|
||||||
(module canvas mzscheme
|
(module canvas mzscheme
|
||||||
(require (lib "unitsig.ss")
|
(require (lib "unitsig.ss")
|
||||||
"../sig.ss"
|
"sig.ss"
|
||||||
(lib "mred.ss" "mred"))
|
(lib "mred-sig.ss" "mred"))
|
||||||
|
|
||||||
|
(provide canvas@)
|
||||||
|
|
||||||
(define canvas@
|
(define canvas@
|
||||||
(unit/sig framework:canvas^
|
(unit/sig framework:canvas^
|
||||||
(import [preferences : framework:preferences^]
|
(import [mred : mred^]
|
||||||
|
[preferences : framework:preferences^]
|
||||||
[frame : framework:frame^])
|
[frame : framework:frame^])
|
||||||
|
|
||||||
(define basic<%> (interface ((class->interface editor-canvas%))))
|
(define basic<%> (interface ((class->interface editor-canvas%))))
|
||||||
|
|
|
||||||
|
|
@ -1,8 +1,11 @@
|
||||||
(module canvas mzscheme
|
(module canvas mzscheme
|
||||||
(require (lib "unitsig.ss")
|
(require (lib "unitsig.ss")
|
||||||
"../sig.ss"
|
"sig.ss"
|
||||||
|
(lib "mred-sig.ss" "mred")
|
||||||
(lib "function.ss"))
|
(lib "function.ss"))
|
||||||
|
|
||||||
|
(provide color-model@)
|
||||||
|
|
||||||
(define color-model@
|
(define color-model@
|
||||||
(unit/sig framework:color-model^
|
(unit/sig framework:color-model^
|
||||||
(import)
|
(import)
|
||||||
|
|
|
||||||
|
|
@ -1,12 +1,15 @@
|
||||||
(module editor mzscheme
|
(module editor mzscheme
|
||||||
(require (lib "unitsig.ss")
|
(require (lib "unitsig.ss")
|
||||||
"../sig.ss"
|
"sig.ss"
|
||||||
(lib "file.ss")
|
(lib "mred-sig.ss" "mred")
|
||||||
(lib "mred.ss" "mred"))
|
(lib "file.ss"))
|
||||||
|
|
||||||
|
(provide editor@)
|
||||||
|
|
||||||
(define editor@
|
(define editor@
|
||||||
(unit/sig framework:editor^
|
(unit/sig framework:editor^
|
||||||
(import [autosave : framework:autosave^]
|
(import [mred : mred^]
|
||||||
|
[autosave : framework:autosave^]
|
||||||
[finder : framework:finder^]
|
[finder : framework:finder^]
|
||||||
[path-utils : framework:path-utils^]
|
[path-utils : framework:path-utils^]
|
||||||
[keymap : framework:keymap^]
|
[keymap : framework:keymap^]
|
||||||
|
|
|
||||||
|
|
@ -1,12 +1,15 @@
|
||||||
(module exit mzscheme
|
(module exit mzscheme
|
||||||
(require (lib "unitsig.ss")
|
(require (lib "unitsig.ss")
|
||||||
"../sig.ss"
|
"sig.ss"
|
||||||
(lib "file.ss")
|
(lib "mred-sig.ss" "mred")
|
||||||
(lib "mred.ss" "mred"))
|
(lib "file.ss"))
|
||||||
|
|
||||||
|
(provide exit@)
|
||||||
|
|
||||||
(define exit@
|
(define exit@
|
||||||
(unit/sig framework:exit^
|
(unit/sig framework:exit^
|
||||||
(import [preferences : framework:preferences^]
|
(import [mred : mred^]
|
||||||
|
[preferences : framework:preferences^]
|
||||||
[gui-utils : framework:gui-utils^])
|
[gui-utils : framework:gui-utils^])
|
||||||
(rename (-exit exit))
|
(rename (-exit exit))
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,10 +1,13 @@
|
||||||
(module finder mzscheme
|
(module finder mzscheme
|
||||||
(require (lib "unitsig.ss")
|
(require (lib "unitsig.ss")
|
||||||
"../sig.ss"
|
"sig.ss"
|
||||||
|
(lib "mred-sig.ss" "mred")
|
||||||
(lib "string.ss")
|
(lib "string.ss")
|
||||||
(lib "function.ss")
|
(lib "function.ss")
|
||||||
(lib "file.ss"))
|
(lib "file.ss"))
|
||||||
|
|
||||||
|
(provide finder@)
|
||||||
|
|
||||||
(define finder@
|
(define finder@
|
||||||
(unit/sig framework:finder^
|
(unit/sig framework:finder^
|
||||||
(import [preferences : framework:preferences^]
|
(import [preferences : framework:preferences^]
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,14 @@
|
||||||
(module frame mzscheme
|
(module frame mzscheme
|
||||||
(require (lib
|
(require (lib "unitsig.ss")
|
||||||
(unit/sig framework:frame^
|
"sig.ss"
|
||||||
|
(lib "mred-sig.ss" "mred")
|
||||||
|
(lib "function.ss")
|
||||||
|
(lib "file.ss"))
|
||||||
|
|
||||||
|
(provide frame@)
|
||||||
|
|
||||||
|
(define frame@
|
||||||
|
(unit/sig framework:frame^
|
||||||
(import mred^
|
(import mred^
|
||||||
[group : framework:group^]
|
[group : framework:group^]
|
||||||
[preferences : framework:preferences^]
|
[preferences : framework:preferences^]
|
||||||
|
|
@ -16,9 +24,7 @@
|
||||||
[pasteboard : framework:pasteboard^]
|
[pasteboard : framework:pasteboard^]
|
||||||
[editor : framework:editor^]
|
[editor : framework:editor^]
|
||||||
[canvas : framework:canvas^]
|
[canvas : framework:canvas^]
|
||||||
[menu : framework:menu^]
|
[menu : framework:menu^])
|
||||||
[mzlib:function : mzlib:function^]
|
|
||||||
[mzlib:file : mzlib:file^])
|
|
||||||
|
|
||||||
(rename [-editor<%> editor<%>]
|
(rename [-editor<%> editor<%>]
|
||||||
[-pasteboard% pasteboard%]
|
[-pasteboard% pasteboard%]
|
||||||
|
|
@ -1516,6 +1522,4 @@
|
||||||
(define searchable% (searchable-text-mixin (searchable-mixin text-info-file%)))
|
(define searchable% (searchable-text-mixin (searchable-mixin text-info-file%)))
|
||||||
|
|
||||||
(define -pasteboard% (pasteboard-mixin editor%))
|
(define -pasteboard% (pasteboard-mixin editor%))
|
||||||
(define pasteboard-info-file% (file-mixin -pasteboard%))
|
(define pasteboard-info-file% (file-mixin -pasteboard%)))))
|
||||||
|
|
||||||
)
|
|
||||||
|
|
|
||||||
|
|
@ -1,231 +1,239 @@
|
||||||
(unit/sig framework:group^
|
(module group mzscheme
|
||||||
(import mred^
|
(require (lib "unitsig.ss")
|
||||||
[application : framework:application^]
|
"sig.ss"
|
||||||
[frame : framework:frame^]
|
(lib "mred-sig.ss" "mred")
|
||||||
[preferences : framework:preferences^]
|
(lib "list.ss")
|
||||||
[mzlib:function : mzlib:function^]
|
(lib "file.ss"))
|
||||||
[mzlib:file : mzlib:file^])
|
|
||||||
|
|
||||||
(define-struct frame (frame id))
|
(povide group@)
|
||||||
|
|
||||||
(define mdi-parent #f)
|
|
||||||
|
|
||||||
(define %
|
(define group@
|
||||||
(class object% ()
|
(unit/sig framework:group^
|
||||||
(private
|
(import mred^
|
||||||
[active-frame #f]
|
[application : framework:application^]
|
||||||
[frame-counter 0]
|
[frame : framework:frame^]
|
||||||
[frames null]
|
[preferences : framework:preferences^])
|
||||||
[todo-to-new-frames void]
|
|
||||||
[empty-close-down (lambda () (void))]
|
(define-struct frame (frame id))
|
||||||
[empty-test (lambda () #t)]
|
|
||||||
|
|
||||||
[windows-menus null])
|
|
||||||
|
|
||||||
(private
|
(define mdi-parent #f)
|
||||||
[get-windows-menu
|
|
||||||
(lambda (frame)
|
|
||||||
(let ([menu-bar (send frame get-menu-bar)])
|
|
||||||
(and menu-bar
|
|
||||||
(let ([menus (send menu-bar get-items)])
|
|
||||||
(ormap (lambda (x)
|
|
||||||
(if (string=? "&Windows" (send x get-label))
|
|
||||||
x
|
|
||||||
#f))
|
|
||||||
menus)))))]
|
|
||||||
[insert-windows-menu
|
|
||||||
(lambda (frame)
|
|
||||||
(let ([menu (get-windows-menu frame)])
|
|
||||||
(when menu
|
|
||||||
(set! windows-menus (cons menu windows-menus)))))]
|
|
||||||
[remove-windows-menu
|
|
||||||
(lambda (frame)
|
|
||||||
(let* ([menu (get-windows-menu frame)])
|
|
||||||
(set! windows-menus
|
|
||||||
(mzlib:function:remove
|
|
||||||
menu
|
|
||||||
windows-menus
|
|
||||||
eq?))))]
|
|
||||||
|
|
||||||
[update-windows-menus
|
(define %
|
||||||
(lambda ()
|
(class object% ()
|
||||||
(let* ([windows (length windows-menus)]
|
(private
|
||||||
[default-name "Untitled"]
|
[active-frame #f]
|
||||||
[get-name
|
[frame-counter 0]
|
||||||
(lambda (frame)
|
[frames null]
|
||||||
(let ([label (send frame get-label)])
|
[todo-to-new-frames void]
|
||||||
(if (string=? label "")
|
[empty-close-down (lambda () (void))]
|
||||||
(if (ivar-in-interface? 'get-entire-label (object-interface frame))
|
[empty-test (lambda () #t)]
|
||||||
(let ([label (send frame get-entire-label)])
|
|
||||||
(if (string=? label "")
|
[windows-menus null])
|
||||||
default-name
|
|
||||||
label))
|
(private
|
||||||
default-name)
|
[get-windows-menu
|
||||||
label)))]
|
(lambda (frame)
|
||||||
[sorted-frames
|
(let ([menu-bar (send frame get-menu-bar)])
|
||||||
(mzlib:function:quicksort
|
(and menu-bar
|
||||||
frames
|
(let ([menus (send menu-bar get-items)])
|
||||||
(lambda (f1 f2)
|
(ormap (lambda (x)
|
||||||
(string-ci<=? (get-name (frame-frame f1))
|
(if (string=? "&Windows" (send x get-label))
|
||||||
(get-name (frame-frame f2)))))])
|
x
|
||||||
(for-each
|
#f))
|
||||||
(lambda (menu)
|
menus)))))]
|
||||||
(for-each (lambda (item) (send item delete))
|
[insert-windows-menu
|
||||||
(send menu get-items))
|
(lambda (frame)
|
||||||
|
(let ([menu (get-windows-menu frame)])
|
||||||
|
(when menu
|
||||||
|
(set! windows-menus (cons menu windows-menus)))))]
|
||||||
|
[remove-windows-menu
|
||||||
|
(lambda (frame)
|
||||||
|
(let* ([menu (get-windows-menu frame)])
|
||||||
|
(set! windows-menus
|
||||||
|
(mzlib:function:remove
|
||||||
|
menu
|
||||||
|
windows-menus
|
||||||
|
eq?))))]
|
||||||
|
|
||||||
|
[update-windows-menus
|
||||||
|
(lambda ()
|
||||||
|
(let* ([windows (length windows-menus)]
|
||||||
|
[default-name "Untitled"]
|
||||||
|
[get-name
|
||||||
|
(lambda (frame)
|
||||||
|
(let ([label (send frame get-label)])
|
||||||
|
(if (string=? label "")
|
||||||
|
(if (ivar-in-interface? 'get-entire-label (object-interface frame))
|
||||||
|
(let ([label (send frame get-entire-label)])
|
||||||
|
(if (string=? label "")
|
||||||
|
default-name
|
||||||
|
label))
|
||||||
|
default-name)
|
||||||
|
label)))]
|
||||||
|
[sorted-frames
|
||||||
|
(mzlib:function:quicksort
|
||||||
|
frames
|
||||||
|
(lambda (f1 f2)
|
||||||
|
(string-ci<=? (get-name (frame-frame f1))
|
||||||
|
(get-name (frame-frame f2)))))])
|
||||||
(for-each
|
(for-each
|
||||||
(lambda (frame)
|
(lambda (menu)
|
||||||
(let ([frame (frame-frame frame)])
|
(for-each (lambda (item) (send item delete))
|
||||||
(make-object menu-item% (get-name frame)
|
(send menu get-items))
|
||||||
menu
|
(for-each
|
||||||
(lambda (_1 _2)
|
(lambda (frame)
|
||||||
(send frame show #t)))))
|
(let ([frame (frame-frame frame)])
|
||||||
sorted-frames))
|
(make-object menu-item% (get-name frame)
|
||||||
windows-menus)))])
|
menu
|
||||||
|
(lambda (_1 _2)
|
||||||
(private
|
(send frame show #t)))))
|
||||||
[update-close-menu-item-state
|
sorted-frames))
|
||||||
(lambda ()
|
windows-menus)))])
|
||||||
(let* ([set-close-menu-item-state!
|
|
||||||
(lambda (frame state)
|
(private
|
||||||
(when (is-a? frame frame:standard-menus<%>)
|
[update-close-menu-item-state
|
||||||
(let ([close-menu-item (ivar frame file-menu:close-menu)])
|
(lambda ()
|
||||||
(when close-menu-item
|
(let* ([set-close-menu-item-state!
|
||||||
(send close-menu-item enable state)))))])
|
(lambda (frame state)
|
||||||
(if (eq? (length frames) 1)
|
(when (is-a? frame frame:standard-menus<%>)
|
||||||
(set-close-menu-item-state! (car frames) #f)
|
(let ([close-menu-item (ivar frame file-menu:close-menu)])
|
||||||
(for-each (lambda (a-frame)
|
(when close-menu-item
|
||||||
(set-close-menu-item-state! a-frame #t))
|
(send close-menu-item enable state)))))])
|
||||||
frames))))])
|
(if (eq? (length frames) 1)
|
||||||
(public
|
(set-close-menu-item-state! (car frames) #f)
|
||||||
|
(for-each (lambda (a-frame)
|
||||||
|
(set-close-menu-item-state! a-frame #t))
|
||||||
|
frames))))])
|
||||||
|
(public
|
||||||
|
|
||||||
[get-mdi-parent
|
[get-mdi-parent
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(if (and (eq? (system-type) 'windows)
|
(if (and (eq? (system-type) 'windows)
|
||||||
(preferences:get 'framework:windows-mdi))
|
(preferences:get 'framework:windows-mdi))
|
||||||
(begin
|
(begin
|
||||||
(set! get-mdi-parent (lambda () mdi-parent))
|
(set! get-mdi-parent (lambda () mdi-parent))
|
||||||
(set! mdi-parent (make-object frame% (application:current-app-name)
|
(set! mdi-parent (make-object frame% (application:current-app-name)
|
||||||
#f #f #f #f #f
|
#f #f #f #f #f
|
||||||
'(mdi-parent)))
|
'(mdi-parent)))
|
||||||
(send mdi-parent show #t)
|
(send mdi-parent show #t)
|
||||||
mdi-parent)
|
mdi-parent)
|
||||||
(begin
|
(begin
|
||||||
(set! get-mdi-parent (lambda () #f))
|
(set! get-mdi-parent (lambda () #f))
|
||||||
#f)))]
|
#f)))]
|
||||||
|
|
||||||
[set-empty-callbacks
|
[set-empty-callbacks
|
||||||
(lambda (test close-down)
|
(lambda (test close-down)
|
||||||
(set! empty-test test)
|
(set! empty-test test)
|
||||||
(set! empty-close-down close-down))]
|
(set! empty-close-down close-down))]
|
||||||
[get-frames (lambda () (map frame-frame frames))]
|
[get-frames (lambda () (map frame-frame frames))]
|
||||||
|
|
||||||
[frame-label-changed
|
[frame-label-changed
|
||||||
(lambda (frame)
|
(lambda (frame)
|
||||||
(when (member frame (map frame-frame frames))
|
(when (member frame (map frame-frame frames))
|
||||||
(update-windows-menus)))]
|
(update-windows-menus)))]
|
||||||
|
|
||||||
[for-each-frame
|
[for-each-frame
|
||||||
(lambda (f)
|
(lambda (f)
|
||||||
(for-each (lambda (x) (f (frame-frame x))) frames)
|
(for-each (lambda (x) (f (frame-frame x))) frames)
|
||||||
(set! todo-to-new-frames
|
(set! todo-to-new-frames
|
||||||
(let ([old todo-to-new-frames])
|
(let ([old todo-to-new-frames])
|
||||||
(lambda (frame) (old frame) (f frame)))))]
|
(lambda (frame) (old frame) (f frame)))))]
|
||||||
[get-active-frame
|
[get-active-frame
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(cond
|
|
||||||
[active-frame active-frame]
|
|
||||||
[(null? frames) #f]
|
|
||||||
[else (frame-frame (car frames))]))]
|
|
||||||
[set-active-frame
|
|
||||||
(lambda (f)
|
|
||||||
(set! active-frame f))]
|
|
||||||
[insert-frame
|
|
||||||
(lambda (f)
|
|
||||||
(set! frame-counter (add1 frame-counter))
|
|
||||||
(let ([new-frames (cons (make-frame f frame-counter)
|
|
||||||
frames)])
|
|
||||||
(set! frames new-frames)
|
|
||||||
(update-close-menu-item-state)
|
|
||||||
(insert-windows-menu f)
|
|
||||||
(update-windows-menus))
|
|
||||||
(todo-to-new-frames f))]
|
|
||||||
|
|
||||||
[can-remove-frame?
|
|
||||||
(opt-lambda (f)
|
|
||||||
(let ([new-frames
|
|
||||||
(mzlib:function:remove
|
|
||||||
f frames
|
|
||||||
(lambda (f fr) (eq? f (frame-frame fr))))])
|
|
||||||
(if (null? new-frames)
|
|
||||||
(empty-test)
|
|
||||||
#t)))]
|
|
||||||
[remove-frame
|
|
||||||
(opt-lambda (f)
|
|
||||||
(when (eq? f active-frame)
|
|
||||||
(set! active-frame #f))
|
|
||||||
(let ([new-frames
|
|
||||||
(mzlib:function:remove
|
|
||||||
f frames
|
|
||||||
(lambda (f fr) (eq? f (frame-frame fr))))])
|
|
||||||
(set! frames new-frames)
|
|
||||||
(update-close-menu-item-state)
|
|
||||||
(remove-windows-menu f)
|
|
||||||
(update-windows-menus)
|
|
||||||
(when (null? frames)
|
|
||||||
(empty-close-down))))]
|
|
||||||
[clear
|
|
||||||
(lambda ()
|
|
||||||
(and (empty-test)
|
|
||||||
(begin (set! frames null)
|
|
||||||
(empty-close-down)
|
|
||||||
#t)))]
|
|
||||||
[on-close-all
|
|
||||||
(lambda ()
|
|
||||||
(for-each (lambda (f)
|
|
||||||
(let ([frame (frame-frame f)])
|
|
||||||
(send frame on-close)
|
|
||||||
(send frame show #f)))
|
|
||||||
frames))]
|
|
||||||
[can-close-all?
|
|
||||||
(lambda ()
|
|
||||||
(andmap (lambda (f)
|
|
||||||
(let ([frame (frame-frame f)])
|
|
||||||
(send frame can-close?)))
|
|
||||||
frames))]
|
|
||||||
[locate-file
|
|
||||||
(lambda (name)
|
|
||||||
(let* ([normalized
|
|
||||||
;; allow for the possiblity of filenames that are urls
|
|
||||||
(with-handlers ([(lambda (x) #t)
|
|
||||||
(lambda (x) name)])
|
|
||||||
(normal-case-path
|
|
||||||
(mzlib:file:normalize-path name)))]
|
|
||||||
[test-frame
|
|
||||||
(lambda (frame)
|
|
||||||
(and (is-a? frame frame:basic<%>)
|
|
||||||
(let* ([filename (send frame get-filename)])
|
|
||||||
(and (string? filename)
|
|
||||||
(string=? normalized
|
|
||||||
(with-handlers ([(lambda (x) #t)
|
|
||||||
(lambda (x) filename)])
|
|
||||||
(normal-case-path
|
|
||||||
(mzlib:file:normalize-path
|
|
||||||
filename))))))))])
|
|
||||||
(let loop ([frames frames])
|
|
||||||
(cond
|
(cond
|
||||||
[(null? frames) #f]
|
[active-frame active-frame]
|
||||||
[else
|
[(null? frames) #f]
|
||||||
(let* ([frame (frame-frame (car frames))])
|
[else (frame-frame (car frames))]))]
|
||||||
(if (test-frame frame)
|
[set-active-frame
|
||||||
frame
|
(lambda (f)
|
||||||
(loop (cdr frames))))]))))])
|
(set! active-frame f))]
|
||||||
(sequence
|
[insert-frame
|
||||||
(super-init))))
|
(lambda (f)
|
||||||
|
(set! frame-counter (add1 frame-counter))
|
||||||
(define the-frame-group #f)
|
(let ([new-frames (cons (make-frame f frame-counter)
|
||||||
|
frames)])
|
||||||
(define get-the-frame-group
|
(set! frames new-frames)
|
||||||
(lambda ()
|
(update-close-menu-item-state)
|
||||||
(set! the-frame-group (make-object %))
|
(insert-windows-menu f)
|
||||||
(set! get-the-frame-group (lambda () the-frame-group))
|
(update-windows-menus))
|
||||||
(get-the-frame-group))))
|
(todo-to-new-frames f))]
|
||||||
|
|
||||||
|
[can-remove-frame?
|
||||||
|
(opt-lambda (f)
|
||||||
|
(let ([new-frames
|
||||||
|
(mzlib:function:remove
|
||||||
|
f frames
|
||||||
|
(lambda (f fr) (eq? f (frame-frame fr))))])
|
||||||
|
(if (null? new-frames)
|
||||||
|
(empty-test)
|
||||||
|
#t)))]
|
||||||
|
[remove-frame
|
||||||
|
(opt-lambda (f)
|
||||||
|
(when (eq? f active-frame)
|
||||||
|
(set! active-frame #f))
|
||||||
|
(let ([new-frames
|
||||||
|
(mzlib:function:remove
|
||||||
|
f frames
|
||||||
|
(lambda (f fr) (eq? f (frame-frame fr))))])
|
||||||
|
(set! frames new-frames)
|
||||||
|
(update-close-menu-item-state)
|
||||||
|
(remove-windows-menu f)
|
||||||
|
(update-windows-menus)
|
||||||
|
(when (null? frames)
|
||||||
|
(empty-close-down))))]
|
||||||
|
[clear
|
||||||
|
(lambda ()
|
||||||
|
(and (empty-test)
|
||||||
|
(begin (set! frames null)
|
||||||
|
(empty-close-down)
|
||||||
|
#t)))]
|
||||||
|
[on-close-all
|
||||||
|
(lambda ()
|
||||||
|
(for-each (lambda (f)
|
||||||
|
(let ([frame (frame-frame f)])
|
||||||
|
(send frame on-close)
|
||||||
|
(send frame show #f)))
|
||||||
|
frames))]
|
||||||
|
[can-close-all?
|
||||||
|
(lambda ()
|
||||||
|
(andmap (lambda (f)
|
||||||
|
(let ([frame (frame-frame f)])
|
||||||
|
(send frame can-close?)))
|
||||||
|
frames))]
|
||||||
|
[locate-file
|
||||||
|
(lambda (name)
|
||||||
|
(let* ([normalized
|
||||||
|
;; allow for the possiblity of filenames that are urls
|
||||||
|
(with-handlers ([(lambda (x) #t)
|
||||||
|
(lambda (x) name)])
|
||||||
|
(normal-case-path
|
||||||
|
(mzlib:file:normalize-path name)))]
|
||||||
|
[test-frame
|
||||||
|
(lambda (frame)
|
||||||
|
(and (is-a? frame frame:basic<%>)
|
||||||
|
(let* ([filename (send frame get-filename)])
|
||||||
|
(and (string? filename)
|
||||||
|
(string=? normalized
|
||||||
|
(with-handlers ([(lambda (x) #t)
|
||||||
|
(lambda (x) filename)])
|
||||||
|
(normal-case-path
|
||||||
|
(mzlib:file:normalize-path
|
||||||
|
filename))))))))])
|
||||||
|
(let loop ([frames frames])
|
||||||
|
(cond
|
||||||
|
[(null? frames) #f]
|
||||||
|
[else
|
||||||
|
(let* ([frame (frame-frame (car frames))])
|
||||||
|
(if (test-frame frame)
|
||||||
|
frame
|
||||||
|
(loop (cdr frames))))]))))])
|
||||||
|
(sequence
|
||||||
|
(super-init))))
|
||||||
|
|
||||||
|
(define the-frame-group #f)
|
||||||
|
|
||||||
|
(define get-the-frame-group
|
||||||
|
(lambda ()
|
||||||
|
(set! the-frame-group (make-object %))
|
||||||
|
(set! get-the-frame-group (lambda () the-frame-group))
|
||||||
|
(get-the-frame-group))))))
|
||||||
|
|
@ -1,142 +1,150 @@
|
||||||
(unit/sig framework:handler^
|
(module handle mzscheme
|
||||||
(import mred^
|
(require (lib "unitsig.ss")
|
||||||
[gui-utils : framework:gui-utils^]
|
"sig.ss"
|
||||||
[finder : framework:finder^]
|
(lib "mred-sig.ss" "mred")
|
||||||
[group : framework:group^]
|
(lib "file.ss"))
|
||||||
[text : framework:text^]
|
|
||||||
[preferences : framework:preferences^]
|
|
||||||
[frame : framework:frame^]
|
|
||||||
[mzlib:file : mzlib:file^])
|
|
||||||
|
|
||||||
(define-struct handler (name extension handler))
|
|
||||||
|
|
||||||
(define format-handlers '())
|
(provide handler@)
|
||||||
|
|
||||||
(define make-insert-handler
|
(define handler@
|
||||||
(letrec ([string-list?
|
(unit/sig framework:handler^
|
||||||
(lambda (l)
|
(import mred^
|
||||||
(cond
|
[gui-utils : framework:gui-utils^]
|
||||||
[(null? l) #t]
|
[finder : framework:finder^]
|
||||||
[(not (pair? l)) #f]
|
[group : framework:group^]
|
||||||
[else
|
[text : framework:text^]
|
||||||
(and (string? (car l))
|
[preferences : framework:preferences^]
|
||||||
(string-list? (cdr l)))]))])
|
[frame : framework:frame^])
|
||||||
(lambda (who name extension handler)
|
|
||||||
(cond
|
(define-struct handler (name extension handler))
|
||||||
[(not (string? name))
|
|
||||||
(error who "name was not a string")]
|
|
||||||
[(and (not (procedure? extension))
|
|
||||||
(not (string? extension))
|
|
||||||
(not (string-list? extension)))
|
|
||||||
(error who
|
|
||||||
"extension was not a string, list of strings, or a predicate")]
|
|
||||||
[(not (procedure? handler))
|
|
||||||
(error who "handler was not a function")]
|
|
||||||
[else (make-handler name
|
|
||||||
extension
|
|
||||||
handler)]))))
|
|
||||||
|
|
||||||
(define insert-format-handler
|
|
||||||
(lambda args
|
|
||||||
(set! format-handlers
|
|
||||||
(cons (apply make-insert-handler 'insert-format-handler args)
|
|
||||||
format-handlers))))
|
|
||||||
|
|
||||||
(define find-handler
|
(define format-handlers '())
|
||||||
(lambda (name handlers)
|
|
||||||
(let/ec exit
|
|
||||||
(let ([extension (if (string? name)
|
|
||||||
(or (mzlib:file:filename-extension name)
|
|
||||||
"")
|
|
||||||
"")])
|
|
||||||
(for-each
|
|
||||||
(lambda (handler)
|
|
||||||
(let ([ext (handler-extension handler)])
|
|
||||||
(when (or (and (procedure? ext)
|
|
||||||
(ext name))
|
|
||||||
(and (string? ext)
|
|
||||||
(string=? ext extension))
|
|
||||||
(and (pair? ext)
|
|
||||||
(ormap (lambda (ext)
|
|
||||||
(string=? ext extension))
|
|
||||||
ext)))
|
|
||||||
(exit (handler-handler handler)))))
|
|
||||||
handlers)
|
|
||||||
#f))))
|
|
||||||
|
|
||||||
(define find-format-handler
|
|
||||||
(lambda (name)
|
|
||||||
(find-handler name format-handlers)))
|
|
||||||
|
|
||||||
; Finding format & mode handlers by name
|
(define make-insert-handler
|
||||||
(define find-named-handler
|
(letrec ([string-list?
|
||||||
(lambda (name handlers)
|
(lambda (l)
|
||||||
(let loop ([l handlers])
|
(cond
|
||||||
(cond
|
[(null? l) #t]
|
||||||
[(null? l) #f]
|
[(not (pair? l)) #f]
|
||||||
[(string-ci=? (handler-name (car l)) name)
|
[else
|
||||||
(handler-handler (car l))]
|
(and (string? (car l))
|
||||||
[else (loop (cdr l))]))))
|
(string-list? (cdr l)))]))])
|
||||||
|
(lambda (who name extension handler)
|
||||||
(define find-named-format-handler
|
(cond
|
||||||
(lambda (name)
|
[(not (string? name))
|
||||||
(find-named-handler name format-handlers)))
|
(error who "name was not a string")]
|
||||||
|
[(and (not (procedure? extension))
|
||||||
|
(not (string? extension))
|
||||||
|
(not (string-list? extension)))
|
||||||
|
(error who
|
||||||
|
"extension was not a string, list of strings, or a predicate")]
|
||||||
|
[(not (procedure? handler))
|
||||||
|
(error who "handler was not a function")]
|
||||||
|
[else (make-handler name
|
||||||
|
extension
|
||||||
|
handler)]))))
|
||||||
|
|
||||||
|
(define insert-format-handler
|
||||||
|
(lambda args
|
||||||
|
(set! format-handlers
|
||||||
|
(cons (apply make-insert-handler 'insert-format-handler args)
|
||||||
|
format-handlers))))
|
||||||
|
|
||||||
; Open a file for editing
|
(define find-handler
|
||||||
(define edit-file
|
(lambda (name handlers)
|
||||||
(opt-lambda (filename
|
(let/ec exit
|
||||||
[make-default
|
(let ([extension (if (string? name)
|
||||||
(lambda ()
|
(or (mzlib:file:filename-extension name)
|
||||||
(let ([frame (make-object frame:text-info-file% filename)])
|
"")
|
||||||
(send frame show #t)
|
"")])
|
||||||
frame))])
|
(for-each
|
||||||
(gui-utils:show-busy-cursor
|
(lambda (handler)
|
||||||
(lambda ()
|
(let ([ext (handler-extension handler)])
|
||||||
(if filename
|
(when (or (and (procedure? ext)
|
||||||
(let ([already-open (send (group:get-the-frame-group)
|
(ext name))
|
||||||
locate-file
|
(and (string? ext)
|
||||||
filename)])
|
(string=? ext extension))
|
||||||
(if already-open
|
(and (pair? ext)
|
||||||
(begin
|
(ormap (lambda (ext)
|
||||||
(send already-open show #t)
|
(string=? ext extension))
|
||||||
already-open)
|
ext)))
|
||||||
(let ([handler
|
(exit (handler-handler handler)))))
|
||||||
(if (string? filename)
|
handlers)
|
||||||
(find-format-handler filename)
|
#f))))
|
||||||
#f)])
|
|
||||||
(if handler
|
(define find-format-handler
|
||||||
(handler filename)
|
(lambda (name)
|
||||||
(make-default)))))
|
(find-handler name format-handlers)))
|
||||||
(make-default))))))
|
|
||||||
|
|
||||||
; Query the user for a file and then edit it
|
|
||||||
|
|
||||||
(define *open-directory* ; object to remember last directory
|
; Finding format & mode handlers by name
|
||||||
(make-object
|
(define find-named-handler
|
||||||
(class object% ()
|
(lambda (name handlers)
|
||||||
(private
|
(let loop ([l handlers])
|
||||||
[the-dir #f])
|
(cond
|
||||||
(public
|
[(null? l) #f]
|
||||||
[get (lambda () the-dir)]
|
[(string-ci=? (handler-name (car l)) name)
|
||||||
[set-from-file!
|
(handler-handler (car l))]
|
||||||
(lambda (file)
|
[else (loop (cdr l))]))))
|
||||||
(set! the-dir (mzlib:file:path-only file)))]
|
|
||||||
[set-to-default
|
(define find-named-format-handler
|
||||||
(lambda ()
|
(lambda (name)
|
||||||
(set! the-dir (current-directory)))])
|
(find-named-handler name format-handlers)))
|
||||||
(sequence
|
|
||||||
(set-to-default)
|
|
||||||
(super-init)))))
|
|
||||||
|
|
||||||
(define open-file
|
; Open a file for editing
|
||||||
(lambda ()
|
(define edit-file
|
||||||
(let ([file
|
(opt-lambda (filename
|
||||||
(parameterize ([finder:dialog-parent-parameter
|
[make-default
|
||||||
(get-top-level-focus-window)])
|
(lambda ()
|
||||||
(finder:get-file
|
(let ([frame (make-object frame:text-info-file% filename)])
|
||||||
(send *open-directory* get)))])
|
(send frame show #t)
|
||||||
(when file
|
frame))])
|
||||||
(send *open-directory*
|
(gui-utils:show-busy-cursor
|
||||||
set-from-file! file))
|
(lambda ()
|
||||||
(and file
|
(if filename
|
||||||
(edit-file file))))))
|
(let ([already-open (send (group:get-the-frame-group)
|
||||||
|
locate-file
|
||||||
|
filename)])
|
||||||
|
(if already-open
|
||||||
|
(begin
|
||||||
|
(send already-open show #t)
|
||||||
|
already-open)
|
||||||
|
(let ([handler
|
||||||
|
(if (string? filename)
|
||||||
|
(find-format-handler filename)
|
||||||
|
#f)])
|
||||||
|
(if handler
|
||||||
|
(handler filename)
|
||||||
|
(make-default)))))
|
||||||
|
(make-default))))))
|
||||||
|
|
||||||
|
; Query the user for a file and then edit it
|
||||||
|
|
||||||
|
(define *open-directory* ; object to remember last directory
|
||||||
|
(make-object
|
||||||
|
(class object% ()
|
||||||
|
(private
|
||||||
|
[the-dir #f])
|
||||||
|
(public
|
||||||
|
[get (lambda () the-dir)]
|
||||||
|
[set-from-file!
|
||||||
|
(lambda (file)
|
||||||
|
(set! the-dir (mzlib:file:path-only file)))]
|
||||||
|
[set-to-default
|
||||||
|
(lambda ()
|
||||||
|
(set! the-dir (current-directory)))])
|
||||||
|
(sequence
|
||||||
|
(set-to-default)
|
||||||
|
(super-init)))))
|
||||||
|
|
||||||
|
(define open-file
|
||||||
|
(lambda ()
|
||||||
|
(let ([file
|
||||||
|
(parameterize ([finder:dialog-parent-parameter
|
||||||
|
(get-top-level-focus-window)])
|
||||||
|
(finder:get-file
|
||||||
|
(send *open-directory* get)))])
|
||||||
|
(when file
|
||||||
|
(send *open-directory*
|
||||||
|
set-from-file! file))
|
||||||
|
(and file
|
||||||
|
(edit-file file))))))))
|
||||||
|
|
|
||||||
|
|
@ -1,75 +1,84 @@
|
||||||
(unit/sig framework:icon^
|
(module icon mzscheme
|
||||||
(import mred^)
|
(require (lib "unitsig.ss")
|
||||||
|
"sig.ss"
|
||||||
|
(lib "mred-sig.ss" "mred")
|
||||||
|
(lib "mred-sig.ss" "mred"))
|
||||||
|
|
||||||
(define icon-path
|
(provide icon@)
|
||||||
(with-handlers ([void (lambda (x) (collection-path "mzlib"))])
|
|
||||||
(collection-path "icons")))
|
|
||||||
|
|
||||||
(define (load-icon name type)
|
(define icon@
|
||||||
(letrec ([p (build-path icon-path name)]
|
(unit/sig framework:icon^
|
||||||
[f
|
(import mred^)
|
||||||
(lambda ()
|
|
||||||
(let ([bitmap (make-object bitmap% p type)])
|
|
||||||
(set! f (lambda () bitmap))
|
|
||||||
bitmap))])
|
|
||||||
(unless (file-exists? p)
|
|
||||||
(fprintf (current-error-port) "WARNING: couldn't find ~a~n" p))
|
|
||||||
(lambda ()
|
|
||||||
(f))))
|
|
||||||
|
|
||||||
(define (load-bitmap name type)
|
|
||||||
(letrec ([p (build-path icon-path name)]
|
|
||||||
[f
|
|
||||||
(lambda ()
|
|
||||||
(let ([bitmap (make-object bitmap% p type)])
|
|
||||||
(set! f (lambda () bitmap))
|
|
||||||
bitmap))])
|
|
||||||
(unless (file-exists? p)
|
|
||||||
(fprintf (current-error-port) "WARNING: couldn't find ~a~n" p))
|
|
||||||
(lambda ()
|
|
||||||
(f))))
|
|
||||||
|
|
||||||
(define-values (get-anchor-bitmap) (load-bitmap "anchor.gif" 'gif))
|
|
||||||
(define-values (get-lock-bitmap) (load-bitmap "lock.gif" 'gif))
|
|
||||||
(define-values (get-unlock-bitmap) (load-bitmap "unlock.gif" 'gif))
|
|
||||||
|
|
||||||
(define get-autowrap-bitmap (load-icon "return.xbm" 'xbm))
|
|
||||||
(define get-paren-highlight-bitmap (load-icon "paren.xbm" 'xbm))
|
|
||||||
|
|
||||||
(define (make-get/mask filename type)
|
|
||||||
(let ([icon #f]
|
|
||||||
[p (build-path icon-path filename)])
|
|
||||||
(unless (file-exists? p)
|
|
||||||
(fprintf (current-error-port) "WARNING: couldn't find ~a~n" p))
|
|
||||||
(lambda ()
|
|
||||||
(or icon
|
|
||||||
(begin
|
|
||||||
(set! icon (make-object bitmap% p type))
|
|
||||||
icon)))))
|
|
||||||
|
|
||||||
;(define get (make-get/mask "plt16x16.bmp" 'bmp))
|
|
||||||
;(define get-mask (make-get/mask "dot16x16.xbm" 'xbm))
|
|
||||||
|
|
||||||
(define gc-on-bitmap #f)
|
|
||||||
|
|
||||||
(define (fetch)
|
(define icon-path
|
||||||
(unless gc-on-bitmap
|
(with-handlers ([void (lambda (x) (collection-path "mzlib"))])
|
||||||
(set! gc-on-bitmap ((load-icon "recycle.gif" 'gif)))))
|
(collection-path "icons")))
|
||||||
|
|
||||||
|
(define (load-icon name type)
|
||||||
|
(letrec ([p (build-path icon-path name)]
|
||||||
|
[f
|
||||||
|
(lambda ()
|
||||||
|
(let ([bitmap (make-object bitmap% p type)])
|
||||||
|
(set! f (lambda () bitmap))
|
||||||
|
bitmap))])
|
||||||
|
(unless (file-exists? p)
|
||||||
|
(fprintf (current-error-port) "WARNING: couldn't find ~a~n" p))
|
||||||
|
(lambda ()
|
||||||
|
(f))))
|
||||||
|
|
||||||
|
(define (load-bitmap name type)
|
||||||
|
(letrec ([p (build-path icon-path name)]
|
||||||
|
[f
|
||||||
|
(lambda ()
|
||||||
|
(let ([bitmap (make-object bitmap% p type)])
|
||||||
|
(set! f (lambda () bitmap))
|
||||||
|
bitmap))])
|
||||||
|
(unless (file-exists? p)
|
||||||
|
(fprintf (current-error-port) "WARNING: couldn't find ~a~n" p))
|
||||||
|
(lambda ()
|
||||||
|
(f))))
|
||||||
|
|
||||||
|
(define-values (get-anchor-bitmap) (load-bitmap "anchor.gif" 'gif))
|
||||||
|
(define-values (get-lock-bitmap) (load-bitmap "lock.gif" 'gif))
|
||||||
|
(define-values (get-unlock-bitmap) (load-bitmap "unlock.gif" 'gif))
|
||||||
|
|
||||||
|
(define get-autowrap-bitmap (load-icon "return.xbm" 'xbm))
|
||||||
|
(define get-paren-highlight-bitmap (load-icon "paren.xbm" 'xbm))
|
||||||
|
|
||||||
|
(define (make-get/mask filename type)
|
||||||
|
(let ([icon #f]
|
||||||
|
[p (build-path icon-path filename)])
|
||||||
|
(unless (file-exists? p)
|
||||||
|
(fprintf (current-error-port) "WARNING: couldn't find ~a~n" p))
|
||||||
|
(lambda ()
|
||||||
|
(or icon
|
||||||
|
(begin
|
||||||
|
(set! icon (make-object bitmap% p type))
|
||||||
|
icon)))))
|
||||||
|
|
||||||
|
;(define get (make-get/mask "plt16x16.bmp" 'bmp))
|
||||||
|
;(define get-mask (make-get/mask "dot16x16.xbm" 'xbm))
|
||||||
|
|
||||||
|
(define gc-on-bitmap #f)
|
||||||
|
|
||||||
(define (get-gc-on-bitmap) (fetch) gc-on-bitmap)
|
(define (fetch)
|
||||||
|
(unless gc-on-bitmap
|
||||||
(define get-gc-off-bitmap
|
(set! gc-on-bitmap ((load-icon "recycle.gif" 'gif)))))
|
||||||
(let ([bitmap #f])
|
|
||||||
(lambda ()
|
(define (get-gc-on-bitmap) (fetch) gc-on-bitmap)
|
||||||
(if bitmap
|
|
||||||
bitmap
|
(define get-gc-off-bitmap
|
||||||
(begin
|
(let ([bitmap #f])
|
||||||
(let ([bdc (make-object bitmap-dc%)]
|
(lambda ()
|
||||||
[onb (get-gc-on-bitmap)])
|
(if bitmap
|
||||||
(set! bitmap (make-object bitmap%
|
bitmap
|
||||||
(send onb get-width)
|
(begin
|
||||||
(send onb get-height)))
|
(let ([bdc (make-object bitmap-dc%)]
|
||||||
(send bdc set-bitmap bitmap)
|
[onb (get-gc-on-bitmap)])
|
||||||
(send bdc clear)
|
(set! bitmap (make-object bitmap%
|
||||||
(send bdc set-bitmap #f)
|
(send onb get-width)
|
||||||
bitmap)))))))
|
(send onb get-height)))
|
||||||
|
(send bdc set-bitmap bitmap)
|
||||||
|
(send bdc clear)
|
||||||
|
(send bdc set-bitmap #f)
|
||||||
|
bitmap)))))))))
|
||||||
|
|
|
||||||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,165 +1,173 @@
|
||||||
(unit/sig framework:main^
|
(module main mzscheme
|
||||||
(import mred^
|
(require (lib "unitsig.ss")
|
||||||
[preferences : framework:preferences^]
|
"sig.ss"
|
||||||
[exit : framework:exit^]
|
(lib "mred-sig.ss" "mred"))
|
||||||
[group : framework:group^])
|
|
||||||
|
|
||||||
;; preferences
|
(provide main@)
|
||||||
|
|
||||||
(preferences:set-default 'framework:search-using-dialog? #t boolean?)
|
(define main@
|
||||||
|
(unit/sig framework:main^
|
||||||
(preferences:set-default 'framework:windows-mdi #f boolean?)
|
(import mred^
|
||||||
|
[preferences : framework:preferences^]
|
||||||
|
[exit : framework:exit^]
|
||||||
|
[group : framework:group^])
|
||||||
|
|
||||||
|
;; preferences
|
||||||
|
|
||||||
(preferences:set-default 'framework:menu-bindings #t boolean?)
|
(preferences:set-default 'framework:search-using-dialog? #t boolean?)
|
||||||
|
|
||||||
|
(preferences:set-default 'framework:windows-mdi #f boolean?)
|
||||||
|
|
||||||
(preferences:set-default 'framework:verify-change-format #f boolean?)
|
(preferences:set-default 'framework:menu-bindings #t boolean?)
|
||||||
|
|
||||||
(preferences:set-default 'framework:auto-set-wrap? #t boolean?)
|
|
||||||
|
|
||||||
(preferences:set-default 'framework:display-line-numbers #t boolean?)
|
|
||||||
|
|
||||||
(preferences:set-default 'framework:show-status-line #t boolean?)
|
|
||||||
(preferences:set-default 'framework:line-offsets #t boolean?)
|
|
||||||
|
|
||||||
(preferences:set-default
|
|
||||||
'framework:print-output-mode
|
|
||||||
'standard
|
|
||||||
(lambda (x) (or (eq? x 'standard) (eq? x 'postscript))))
|
|
||||||
|
|
||||||
(define (add-#% x)
|
|
||||||
(string->symbol (string-append "#%" (symbol->string x))))
|
|
||||||
|
|
||||||
(preferences:set-default 'framework:highlight-parens #t boolean?)
|
(preferences:set-default 'framework:verify-change-format #f boolean?)
|
||||||
(preferences:set-default 'framework:fixup-parens #t boolean?)
|
|
||||||
(preferences:set-default 'framework:paren-match #t boolean?)
|
(preferences:set-default 'framework:auto-set-wrap? #t boolean?)
|
||||||
(let ([hash-table (make-hash-table)])
|
|
||||||
(for-each (lambda (x)
|
(preferences:set-default 'framework:display-line-numbers #t boolean?)
|
||||||
(hash-table-put! hash-table (add-#% x) 'define)
|
|
||||||
(hash-table-put! hash-table x 'define))
|
(preferences:set-default 'framework:show-status-line #t boolean?)
|
||||||
'(define defmacro define-macro
|
(preferences:set-default 'framework:line-offsets #t boolean?)
|
||||||
define-values
|
|
||||||
define-signature define-syntax define-schema))
|
(preferences:set-default
|
||||||
(for-each (lambda (x)
|
'framework:print-output-mode
|
||||||
(hash-table-put! hash-table (add-#% x) 'begin)
|
'standard
|
||||||
(hash-table-put! hash-table x 'begin))
|
(lambda (x) (or (eq? x 'standard) (eq? x 'postscript))))
|
||||||
'(cond
|
|
||||||
begin begin0 delay
|
(define (add-#% x)
|
||||||
unit compound-unit compound-unit/sig
|
(string->symbol (string-append "#%" (symbol->string x))))
|
||||||
public private override
|
|
||||||
inherit sequence))
|
|
||||||
(for-each (lambda (x)
|
|
||||||
(hash-table-put! hash-table (add-#% x) 'lambda)
|
|
||||||
(hash-table-put! hash-table x 'lambda))
|
|
||||||
'(lambda let let* letrec recur
|
|
||||||
module
|
|
||||||
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* class*/names
|
|
||||||
class/d class/d* class/d*/names
|
|
||||||
rec
|
|
||||||
make-object mixin
|
|
||||||
define-some do opt-lambda send*
|
|
||||||
define-record
|
|
||||||
local catch shared
|
|
||||||
unit/sig unit/lang
|
|
||||||
with-handlers
|
|
||||||
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))
|
|
||||||
(preferences:set-un/marshall
|
|
||||||
'framework:tabify
|
|
||||||
(lambda (t) (hash-table-map t list))
|
|
||||||
(lambda (l) (let ([h (make-hash-table)])
|
|
||||||
(for-each (lambda (x) (apply hash-table-put! h x)) l)
|
|
||||||
h)))
|
|
||||||
(preferences:set-default 'framework: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?)
|
|
||||||
(preferences:set-default 'framework:delete-forward?
|
|
||||||
(not (eq? (system-type) 'unix))
|
|
||||||
boolean?)
|
|
||||||
(preferences:set-default 'framework:show-periods-in-dirlist #f boolean?)
|
|
||||||
(preferences:set-default
|
|
||||||
'framework:file-dialogs
|
|
||||||
'std
|
|
||||||
(lambda (x)
|
|
||||||
(or (eq? x 'common)
|
|
||||||
(eq? x 'std))))
|
|
||||||
|
|
||||||
;; groups
|
(preferences:set-default 'framework:highlight-parens #t boolean?)
|
||||||
|
(preferences:set-default 'framework:fixup-parens #t boolean?)
|
||||||
(preferences:set-default 'framework:exit-when-no-frames #t boolean?)
|
(preferences:set-default 'framework:paren-match #t boolean?)
|
||||||
|
(let ([hash-table (make-hash-table)])
|
||||||
|
(for-each (lambda (x)
|
||||||
|
(hash-table-put! hash-table (add-#% x) 'define)
|
||||||
|
(hash-table-put! hash-table x 'define))
|
||||||
|
'(define defmacro define-macro
|
||||||
|
define-values
|
||||||
|
define-signature define-syntax define-schema))
|
||||||
|
(for-each (lambda (x)
|
||||||
|
(hash-table-put! hash-table (add-#% x) 'begin)
|
||||||
|
(hash-table-put! hash-table x 'begin))
|
||||||
|
'(cond
|
||||||
|
begin begin0 delay
|
||||||
|
unit compound-unit compound-unit/sig
|
||||||
|
public private override
|
||||||
|
inherit sequence))
|
||||||
|
(for-each (lambda (x)
|
||||||
|
(hash-table-put! hash-table (add-#% x) 'lambda)
|
||||||
|
(hash-table-put! hash-table x 'lambda))
|
||||||
|
'(lambda let let* letrec recur
|
||||||
|
module
|
||||||
|
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* class*/names
|
||||||
|
class/d class/d* class/d*/names
|
||||||
|
rec
|
||||||
|
make-object mixin
|
||||||
|
define-some do opt-lambda send*
|
||||||
|
define-record
|
||||||
|
local catch shared
|
||||||
|
unit/sig unit/lang
|
||||||
|
with-handlers
|
||||||
|
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))
|
||||||
|
(preferences:set-un/marshall
|
||||||
|
'framework:tabify
|
||||||
|
(lambda (t) (hash-table-map t list))
|
||||||
|
(lambda (l) (let ([h (make-hash-table)])
|
||||||
|
(for-each (lambda (x) (apply hash-table-put! h x)) l)
|
||||||
|
h)))
|
||||||
|
(preferences:set-default 'framework: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?)
|
||||||
|
(preferences:set-default 'framework:delete-forward?
|
||||||
|
(not (eq? (system-type) 'unix))
|
||||||
|
boolean?)
|
||||||
|
(preferences:set-default 'framework:show-periods-in-dirlist #f boolean?)
|
||||||
|
(preferences:set-default
|
||||||
|
'framework:file-dialogs
|
||||||
|
'std
|
||||||
|
(lambda (x)
|
||||||
|
(or (eq? x 'common)
|
||||||
|
(eq? x 'std))))
|
||||||
|
|
||||||
(let ([at-most-one
|
;; groups
|
||||||
(let ([skip? #f])
|
|
||||||
(lambda (answer thunk)
|
(preferences:set-default 'framework:exit-when-no-frames #t boolean?)
|
||||||
(if skip?
|
|
||||||
answer
|
|
||||||
(begin
|
|
||||||
(set! skip? #t)
|
|
||||||
(begin0 (thunk)
|
|
||||||
(set! skip? #f))))))])
|
|
||||||
|
|
||||||
(send (group:get-the-frame-group) set-empty-callbacks
|
(let ([at-most-one
|
||||||
|
(let ([skip? #f])
|
||||||
|
(lambda (answer thunk)
|
||||||
|
(if skip?
|
||||||
|
answer
|
||||||
|
(begin
|
||||||
|
(set! skip? #t)
|
||||||
|
(begin0 (thunk)
|
||||||
|
(set! skip? #f))))))])
|
||||||
|
|
||||||
;; empty test
|
(send (group:get-the-frame-group) set-empty-callbacks
|
||||||
(lambda ()
|
|
||||||
(if (preferences:get 'framework:exit-when-no-frames)
|
|
||||||
(at-most-one #t
|
|
||||||
(lambda ()
|
|
||||||
(exit:can-exit?)))
|
|
||||||
#t))
|
|
||||||
|
|
||||||
;; empty close down
|
|
||||||
(lambda ()
|
|
||||||
(if (preferences:get 'framework:exit-when-no-frames)
|
|
||||||
(at-most-one (void)
|
|
||||||
(lambda ()
|
|
||||||
(exit:on-exit)
|
|
||||||
(queue-callback (lambda () (exit)))))
|
|
||||||
(void))))
|
|
||||||
|
|
||||||
(exit:insert-can?-callback
|
|
||||||
(lambda ()
|
|
||||||
(at-most-one
|
|
||||||
#t
|
|
||||||
(lambda ()
|
|
||||||
(send (group:get-the-frame-group) can-close-all?)))))
|
|
||||||
|
|
||||||
(exit:insert-on-callback
|
;; empty test
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(at-most-one
|
(if (preferences:get 'framework:exit-when-no-frames)
|
||||||
#t
|
(at-most-one #t
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(send (group:get-the-frame-group) on-close-all))))))
|
(exit:can-exit?)))
|
||||||
|
#t))
|
||||||
(exit:insert-on-callback
|
|
||||||
(lambda ()
|
;; empty close down
|
||||||
(with-handlers ([(lambda (x) (void))
|
(lambda ()
|
||||||
(lambda (exn)
|
(if (preferences:get 'framework:exit-when-no-frames)
|
||||||
(message-box
|
(at-most-one (void)
|
||||||
"Saving Prefs"
|
(lambda ()
|
||||||
(format "Error saving preferences: ~a"
|
(exit:on-exit)
|
||||||
(exn-message exn))))])
|
(queue-callback (lambda () (exit)))))
|
||||||
(preferences:save))))
|
(void))))
|
||||||
|
|
||||||
;(wx:application-file-handler edit-file) ;; how to handle drag and drop?
|
(exit:insert-can?-callback
|
||||||
|
(lambda ()
|
||||||
|
(at-most-one
|
||||||
|
#t
|
||||||
|
(lambda ()
|
||||||
|
(send (group:get-the-frame-group) can-close-all?)))))
|
||||||
|
|
||||||
(preferences:read)
|
(exit:insert-on-callback
|
||||||
|
(lambda ()
|
||||||
|
(at-most-one
|
||||||
|
#t
|
||||||
|
(lambda ()
|
||||||
|
(send (group:get-the-frame-group) on-close-all))))))
|
||||||
|
|
||||||
|
(exit:insert-on-callback
|
||||||
|
(lambda ()
|
||||||
|
(with-handlers ([(lambda (x) (void))
|
||||||
|
(lambda (exn)
|
||||||
|
(message-box
|
||||||
|
"Saving Prefs"
|
||||||
|
(format "Error saving preferences: ~a"
|
||||||
|
(exn-message exn))))])
|
||||||
|
(preferences:save))))
|
||||||
|
|
||||||
|
;(wx:application-file-handler edit-file) ;; how to handle drag and drop?
|
||||||
|
|
||||||
;; reset these -- they are only for the test suite.
|
(preferences:read)
|
||||||
;; they do not need to be set across starting up and shutting down
|
|
||||||
;; the application.
|
;; reset these -- they are only for the test suite.
|
||||||
(preferences:set 'framework:file-dialogs 'std)
|
;; they do not need to be set across starting up and shutting down
|
||||||
(preferences:set 'framework:exit-when-no-frames #t)
|
;; the application.
|
||||||
|
(preferences:set 'framework:file-dialogs 'std)
|
||||||
(void))
|
(preferences:set 'framework:exit-when-no-frames #t)
|
||||||
|
|
||||||
|
(void))))
|
||||||
|
|
|
||||||
|
|
@ -1,3 +1,11 @@
|
||||||
|
(module menu mzscheme
|
||||||
|
(require (lib "unitsig.ss")
|
||||||
|
"sig"
|
||||||
|
(lib "mred-sig.ss" "mred"))
|
||||||
|
|
||||||
|
(provide menu@)
|
||||||
|
|
||||||
|
(define menu@
|
||||||
(unit/sig framework:menu^
|
(unit/sig framework:menu^
|
||||||
(import mred^
|
(import mred^
|
||||||
[preferences : framework:preferences^])
|
[preferences : framework:preferences^])
|
||||||
|
|
@ -23,4 +31,4 @@
|
||||||
(set-shortcut #f)))))
|
(set-shortcut #f)))))
|
||||||
|
|
||||||
(define can-restore-menu-item% (can-restore-mixin menu-item%))
|
(define can-restore-menu-item% (can-restore-mixin menu-item%))
|
||||||
(define can-restore-checkable-menu-item% (can-restore-mixin checkable-menu-item%)))
|
(define can-restore-checkable-menu-item% (can-restore-mixin checkable-menu-item%)))))
|
||||||
|
|
@ -1,3 +1,11 @@
|
||||||
|
(module panel mzscheme
|
||||||
|
(require (lib "unitsig.ss")
|
||||||
|
"sig"
|
||||||
|
(lib "mred-sig.ss" "mred"))
|
||||||
|
|
||||||
|
(provide panel@)
|
||||||
|
|
||||||
|
(define panel@
|
||||||
(unit/sig framework:panel^
|
(unit/sig framework:panel^
|
||||||
(import mred^
|
(import mred^
|
||||||
[mzlib:function : mzlib:function^])
|
[mzlib:function : mzlib:function^])
|
||||||
|
|
@ -466,4 +474,4 @@
|
||||||
(set! thumb-canvas (make-object thumb-canvas% this)))))
|
(set! thumb-canvas (make-object thumb-canvas% this)))))
|
||||||
|
|
||||||
(define vertical-resizable% (vertical-resizable-mixin panel%))
|
(define vertical-resizable% (vertical-resizable-mixin panel%))
|
||||||
(define vertical-resizable-pane% (vertical-resizable-mixin pane%)))
|
(define vertical-resizable-pane% (vertical-resizable-mixin pane%)))))
|
||||||
|
|
@ -1,11 +1,19 @@
|
||||||
(unit/sig framework:pasteboard^
|
(module pasteboard mzscheme
|
||||||
(import mred^
|
(require (lib "unitsig.ss")
|
||||||
[editor : framework:editor^])
|
"sig"
|
||||||
|
(lib "mred-sig.ss" "mred"))
|
||||||
|
|
||||||
(rename [-keymap% keymap%])
|
(provide pasteboard@)
|
||||||
|
|
||||||
(define basic% (editor:basic-mixin pasteboard%))
|
(define pasteboard@
|
||||||
(define -keymap% (editor:keymap-mixin basic%))
|
(unit/sig framework:pasteboard^
|
||||||
(define file% (editor:file-mixin -keymap%))
|
(import mred^
|
||||||
(define backup-autosave% (editor:backup-autosave-mixin file%))
|
[editor : framework:editor^])
|
||||||
(define info% (editor:info-mixin backup-autosave%)))
|
|
||||||
|
(rename [-keymap% keymap%])
|
||||||
|
|
||||||
|
(define basic% (editor:basic-mixin pasteboard%))
|
||||||
|
(define -keymap% (editor:keymap-mixin basic%))
|
||||||
|
(define file% (editor:file-mixin -keymap%))
|
||||||
|
(define backup-autosave% (editor:backup-autosave-mixin file%))
|
||||||
|
(define info% (editor:info-mixin backup-autosave%)))))
|
||||||
|
|
@ -1,53 +1,60 @@
|
||||||
|
(module path-utils mzscheme
|
||||||
|
(require (lib "unitsig.ss")
|
||||||
|
"sig"
|
||||||
|
(lib "mred-sig.ss" "mred"))
|
||||||
|
|
||||||
(unit/sig framework:path-utils^
|
(provide path-utils@)
|
||||||
(import)
|
|
||||||
|
(define path-utils@
|
||||||
(define generate-autosave-name
|
(unit/sig framework:path-utils^
|
||||||
(lambda (name)
|
(import)
|
||||||
(let-values ([(base name dir?)
|
|
||||||
(if name
|
(define generate-autosave-name
|
||||||
(split-path name)
|
(lambda (name)
|
||||||
(values (current-directory) "mredauto" #f))])
|
(let-values ([(base name dir?)
|
||||||
(let* ([base (if (string? base)
|
(if name
|
||||||
base
|
(split-path name)
|
||||||
(current-directory))]
|
(values (current-directory) "mredauto" #f))])
|
||||||
[path (if (relative-path? base)
|
(let* ([base (if (string? base)
|
||||||
(build-path (current-directory) base)
|
base
|
||||||
base)]
|
(current-directory))]
|
||||||
[without-ext
|
[path (if (relative-path? base)
|
||||||
(if (eq? (system-type) 'windows)
|
(build-path (current-directory) base)
|
||||||
(list->string
|
base)]
|
||||||
(let loop ([list (string->list name)])
|
[without-ext
|
||||||
(if (or (null? list)
|
(if (eq? (system-type) 'windows)
|
||||||
(char=? (car list) #\.))
|
(list->string
|
||||||
()
|
(let loop ([list (string->list name)])
|
||||||
(cons (car list)
|
(if (or (null? list)
|
||||||
(loop (cdr list))))))
|
(char=? (car list) #\.))
|
||||||
name)])
|
()
|
||||||
(let loop ([n 1])
|
(cons (car list)
|
||||||
(let ([new-name
|
(loop (cdr list))))))
|
||||||
(build-path path
|
name)])
|
||||||
(if (eq? (system-type) 'windows)
|
(let loop ([n 1])
|
||||||
(string-append without-ext
|
(let ([new-name
|
||||||
"."
|
(build-path path
|
||||||
(number->string n))
|
(if (eq? (system-type) 'windows)
|
||||||
(string-append "#"
|
(string-append without-ext
|
||||||
name
|
"."
|
||||||
"#"
|
(number->string n))
|
||||||
(number->string n)
|
(string-append "#"
|
||||||
"#")))])
|
name
|
||||||
(if (file-exists? new-name)
|
"#"
|
||||||
(loop (add1 n))
|
(number->string n)
|
||||||
new-name)))))))
|
"#")))])
|
||||||
(define generate-backup-name
|
(if (file-exists? new-name)
|
||||||
(lambda (name)
|
(loop (add1 n))
|
||||||
(if (eq? (system-type) 'windows)
|
new-name)))))))
|
||||||
(list->string
|
(define generate-backup-name
|
||||||
(let loop ([list (string->list name)])
|
(lambda (name)
|
||||||
(if (or (null? list)
|
(if (eq? (system-type) 'windows)
|
||||||
(char=? (car list) #\.))
|
(list->string
|
||||||
'(#\. #\b #\a #\k)
|
(let loop ([list (string->list name)])
|
||||||
(cons (car list)
|
(if (or (null? list)
|
||||||
(loop (cdr list))))))
|
(char=? (car list) #\.))
|
||||||
(string-append name "~")))))
|
'(#\. #\b #\a #\k)
|
||||||
|
(cons (car list)
|
||||||
|
(loop (cdr list))))))
|
||||||
|
(string-append name "~")))))))
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,4 +1,11 @@
|
||||||
(unit/sig framework:preferences^
|
(module preferences mzscheme
|
||||||
|
(require (lib "unitsig.ss")
|
||||||
|
"sig"
|
||||||
|
(lib "mred-sig.ss" "mred"))
|
||||||
|
|
||||||
|
(provide preferences@)
|
||||||
|
(define preferences@
|
||||||
|
(unit/sig framework:preferences^
|
||||||
(import mred^
|
(import mred^
|
||||||
[prefs-file : framework:prefs-file^]
|
[prefs-file : framework:prefs-file^]
|
||||||
[exn : framework:exn^]
|
[exn : framework:exn^]
|
||||||
|
|
@ -642,4 +649,4 @@
|
||||||
(send popup-menu set-selection 0))
|
(send popup-menu set-selection 0))
|
||||||
(send popup-menu focus)
|
(send popup-menu focus)
|
||||||
(send frame show #t)
|
(send frame show #t)
|
||||||
frame))))
|
frame))))))
|
||||||
|
|
|
||||||
|
|
@ -3,6 +3,14 @@
|
||||||
|
|
||||||
; Scheme mode for MrEd.
|
; Scheme mode for MrEd.
|
||||||
|
|
||||||
|
(module scheme mzscheme
|
||||||
|
(require (lib "unitsig.ss")
|
||||||
|
"sig"
|
||||||
|
(lib "mred-sig.ss" "mred"))
|
||||||
|
|
||||||
|
(provide scheme@)
|
||||||
|
|
||||||
|
(define scheme@
|
||||||
(unit/sig framework:scheme^
|
(unit/sig framework:scheme^
|
||||||
(import mred^
|
(import mred^
|
||||||
[preferences : framework:preferences^]
|
[preferences : framework:preferences^]
|
||||||
|
|
@ -1021,6 +1029,4 @@
|
||||||
(reset lambda-list-box lambda-keywords)
|
(reset lambda-list-box lambda-keywords)
|
||||||
#t))])
|
#t))])
|
||||||
(preferences:add-callback 'framework:tabify (lambda (p v) (update-list-boxes v)))
|
(preferences:add-callback 'framework:tabify (lambda (p v) (update-list-boxes v)))
|
||||||
main-panel)))))
|
main-panel))))))))
|
||||||
|
|
||||||
)
|
|
||||||
|
|
@ -1,3 +1,11 @@
|
||||||
|
(module text mzscheme
|
||||||
|
(require (lib "unitsig.ss")
|
||||||
|
"sig"
|
||||||
|
(lib "mred-sig.ss" "mred"))
|
||||||
|
|
||||||
|
(provide text@)
|
||||||
|
|
||||||
|
(define text@
|
||||||
(unit/sig framework:text^
|
(unit/sig framework:text^
|
||||||
(import mred^
|
(import mred^
|
||||||
[icon : framework:icon^]
|
[icon : framework:icon^]
|
||||||
|
|
@ -470,4 +478,4 @@
|
||||||
(define clever-file-format% (clever-file-format-mixin file%))
|
(define clever-file-format% (clever-file-format-mixin file%))
|
||||||
(define backup-autosave% (editor:backup-autosave-mixin clever-file-format%))
|
(define backup-autosave% (editor:backup-autosave-mixin clever-file-format%))
|
||||||
(define searching% (searching-mixin backup-autosave%))
|
(define searching% (searching-mixin backup-autosave%))
|
||||||
(define info% (info-mixin (editor:info-mixin searching%))))
|
(define info% (info-mixin (editor:info-mixin searching%))))))
|
||||||
|
|
|
||||||
|
|
@ -1,24 +1,30 @@
|
||||||
(unit/sig framework:version^
|
(module version mzscheme
|
||||||
(import [mzlib:string : mzlib:string^]
|
(require (lib "unitsig.ss")
|
||||||
[mzlib:function : mzlib:function^])
|
"sig"
|
||||||
|
(lib "mred-sig.ss" "mred"))
|
||||||
|
|
||||||
(rename [-version version])
|
(provide version@)
|
||||||
|
|
||||||
(define specs null)
|
(define version@
|
||||||
|
(unit/sig framework:version^
|
||||||
|
(import [mzlib:string : mzlib:string^]
|
||||||
|
[mzlib:function : mzlib:function^])
|
||||||
|
|
||||||
(define -version
|
(rename [-version version])
|
||||||
(lambda ()
|
|
||||||
(mzlib:function:foldr
|
|
||||||
(lambda (entry sofar)
|
|
||||||
(match entry
|
|
||||||
[(sep num) (string-append sofar sep num)]))
|
|
||||||
(version)
|
|
||||||
specs)))
|
|
||||||
|
|
||||||
(define add-spec
|
(define specs null)
|
||||||
(lambda (sep num)
|
|
||||||
(set! specs (cons (list (mzlib:string:expr->string sep)
|
(define -version
|
||||||
(mzlib:string:expr->string num))
|
(lambda ()
|
||||||
specs))))
|
(mzlib:function:foldr
|
||||||
|
(lambda (entry sofar)
|
||||||
'(add-version-spec ': 5))
|
(match entry
|
||||||
|
[(sep num) (string-append sofar sep num)]))
|
||||||
|
(version)
|
||||||
|
specs)))
|
||||||
|
|
||||||
|
(define add-spec
|
||||||
|
(lambda (sep num)
|
||||||
|
(set! specs (cons (list (mzlib:string:expr->string sep)
|
||||||
|
(mzlib:string:expr->string num))
|
||||||
|
specs)))))))
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user