...
original commit: 382fab8691402cba8e3182ed2ae23ddbac4dfe8d
This commit is contained in:
Robby Findler
parent
f4b47c38f8
commit
6390931c40
|
|
@ -1,6 +1,9 @@
|
|||
(module application mzscheme
|
||||
(require (lib "unitsig.ss")
|
||||
"../sig.ss")
|
||||
"sig.ss"
|
||||
(lib "mred-sig.ss" "mred"))
|
||||
|
||||
(provide application@)
|
||||
|
||||
(define application@
|
||||
(unit/sig framework:application^
|
||||
|
|
|
|||
|
|
@ -1,11 +1,14 @@
|
|||
(module autosave mzscheme
|
||||
(require (lib "unitsig.ss")
|
||||
"../sig.ss"
|
||||
(lib "mred.ss" "mred"))
|
||||
"sig.ss"
|
||||
(lib "mred-sig.ss" "mred"))
|
||||
|
||||
(provide autosave@)
|
||||
|
||||
(define autosave@
|
||||
(unit/sig framework:autosave^
|
||||
(import [exit : framework:exit^]
|
||||
(import [mred : mred^]
|
||||
[exit : framework:exit^]
|
||||
[preferences : framework:preferences^])
|
||||
|
||||
(define objects null)
|
||||
|
|
|
|||
|
|
@ -1,11 +1,14 @@
|
|||
(module canvas mzscheme
|
||||
(require (lib "unitsig.ss")
|
||||
"../sig.ss"
|
||||
(lib "mred.ss" "mred"))
|
||||
"sig.ss"
|
||||
(lib "mred-sig.ss" "mred"))
|
||||
|
||||
(provide canvas@)
|
||||
|
||||
(define canvas@
|
||||
(unit/sig framework:canvas^
|
||||
(import [preferences : framework:preferences^]
|
||||
(import [mred : mred^]
|
||||
[preferences : framework:preferences^]
|
||||
[frame : framework:frame^])
|
||||
|
||||
(define basic<%> (interface ((class->interface editor-canvas%))))
|
||||
|
|
|
|||
|
|
@ -1,8 +1,11 @@
|
|||
(module canvas mzscheme
|
||||
(require (lib "unitsig.ss")
|
||||
"../sig.ss"
|
||||
"sig.ss"
|
||||
(lib "mred-sig.ss" "mred")
|
||||
(lib "function.ss"))
|
||||
|
||||
(provide color-model@)
|
||||
|
||||
(define color-model@
|
||||
(unit/sig framework:color-model^
|
||||
(import)
|
||||
|
|
|
|||
|
|
@ -1,12 +1,15 @@
|
|||
(module editor mzscheme
|
||||
(require (lib "unitsig.ss")
|
||||
"../sig.ss"
|
||||
(lib "file.ss")
|
||||
(lib "mred.ss" "mred"))
|
||||
"sig.ss"
|
||||
(lib "mred-sig.ss" "mred")
|
||||
(lib "file.ss"))
|
||||
|
||||
(provide editor@)
|
||||
|
||||
(define editor@
|
||||
(unit/sig framework:editor^
|
||||
(import [autosave : framework:autosave^]
|
||||
(import [mred : mred^]
|
||||
[autosave : framework:autosave^]
|
||||
[finder : framework:finder^]
|
||||
[path-utils : framework:path-utils^]
|
||||
[keymap : framework:keymap^]
|
||||
|
|
|
|||
|
|
@ -1,12 +1,15 @@
|
|||
(module exit mzscheme
|
||||
(require (lib "unitsig.ss")
|
||||
"../sig.ss"
|
||||
(lib "file.ss")
|
||||
(lib "mred.ss" "mred"))
|
||||
"sig.ss"
|
||||
(lib "mred-sig.ss" "mred")
|
||||
(lib "file.ss"))
|
||||
|
||||
(provide exit@)
|
||||
|
||||
(define exit@
|
||||
(unit/sig framework:exit^
|
||||
(import [preferences : framework:preferences^]
|
||||
(import [mred : mred^]
|
||||
[preferences : framework:preferences^]
|
||||
[gui-utils : framework:gui-utils^])
|
||||
(rename (-exit exit))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,10 +1,13 @@
|
|||
(module finder mzscheme
|
||||
(require (lib "unitsig.ss")
|
||||
"../sig.ss"
|
||||
"sig.ss"
|
||||
(lib "mred-sig.ss" "mred")
|
||||
(lib "string.ss")
|
||||
(lib "function.ss")
|
||||
(lib "file.ss"))
|
||||
|
||||
(provide finder@)
|
||||
|
||||
(define finder@
|
||||
(unit/sig framework:finder^
|
||||
(import [preferences : framework:preferences^]
|
||||
|
|
|
|||
|
|
@ -1,6 +1,14 @@
|
|||
(module frame mzscheme
|
||||
(require (lib
|
||||
(unit/sig framework:frame^
|
||||
(require (lib "unitsig.ss")
|
||||
"sig.ss"
|
||||
(lib "mred-sig.ss" "mred")
|
||||
(lib "function.ss")
|
||||
(lib "file.ss"))
|
||||
|
||||
(provide frame@)
|
||||
|
||||
(define frame@
|
||||
(unit/sig framework:frame^
|
||||
(import mred^
|
||||
[group : framework:group^]
|
||||
[preferences : framework:preferences^]
|
||||
|
|
@ -16,9 +24,7 @@
|
|||
[pasteboard : framework:pasteboard^]
|
||||
[editor : framework:editor^]
|
||||
[canvas : framework:canvas^]
|
||||
[menu : framework:menu^]
|
||||
[mzlib:function : mzlib:function^]
|
||||
[mzlib:file : mzlib:file^])
|
||||
[menu : framework:menu^])
|
||||
|
||||
(rename [-editor<%> editor<%>]
|
||||
[-pasteboard% pasteboard%]
|
||||
|
|
@ -1516,6 +1522,4 @@
|
|||
(define searchable% (searchable-text-mixin (searchable-mixin text-info-file%)))
|
||||
|
||||
(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^
|
||||
(import mred^
|
||||
[application : framework:application^]
|
||||
[frame : framework:frame^]
|
||||
[preferences : framework:preferences^]
|
||||
[mzlib:function : mzlib:function^]
|
||||
[mzlib:file : mzlib:file^])
|
||||
(module group mzscheme
|
||||
(require (lib "unitsig.ss")
|
||||
"sig.ss"
|
||||
(lib "mred-sig.ss" "mred")
|
||||
(lib "list.ss")
|
||||
(lib "file.ss"))
|
||||
|
||||
(define-struct frame (frame id))
|
||||
|
||||
(define mdi-parent #f)
|
||||
(povide group@)
|
||||
|
||||
(define %
|
||||
(class object% ()
|
||||
(private
|
||||
[active-frame #f]
|
||||
[frame-counter 0]
|
||||
[frames null]
|
||||
[todo-to-new-frames void]
|
||||
[empty-close-down (lambda () (void))]
|
||||
[empty-test (lambda () #t)]
|
||||
|
||||
[windows-menus null])
|
||||
(define group@
|
||||
(unit/sig framework:group^
|
||||
(import mred^
|
||||
[application : framework:application^]
|
||||
[frame : framework:frame^]
|
||||
[preferences : framework:preferences^])
|
||||
|
||||
(define-struct frame (frame id))
|
||||
|
||||
(private
|
||||
[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?))))]
|
||||
(define mdi-parent #f)
|
||||
|
||||
[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
|
||||
(lambda (menu)
|
||||
(for-each (lambda (item) (send item delete))
|
||||
(send menu get-items))
|
||||
(define %
|
||||
(class object% ()
|
||||
(private
|
||||
[active-frame #f]
|
||||
[frame-counter 0]
|
||||
[frames null]
|
||||
[todo-to-new-frames void]
|
||||
[empty-close-down (lambda () (void))]
|
||||
[empty-test (lambda () #t)]
|
||||
|
||||
[windows-menus null])
|
||||
|
||||
(private
|
||||
[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
|
||||
(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
|
||||
(lambda (frame)
|
||||
(let ([frame (frame-frame frame)])
|
||||
(make-object menu-item% (get-name frame)
|
||||
menu
|
||||
(lambda (_1 _2)
|
||||
(send frame show #t)))))
|
||||
sorted-frames))
|
||||
windows-menus)))])
|
||||
|
||||
(private
|
||||
[update-close-menu-item-state
|
||||
(lambda ()
|
||||
(let* ([set-close-menu-item-state!
|
||||
(lambda (frame state)
|
||||
(when (is-a? frame frame:standard-menus<%>)
|
||||
(let ([close-menu-item (ivar frame file-menu:close-menu)])
|
||||
(when close-menu-item
|
||||
(send close-menu-item enable state)))))])
|
||||
(if (eq? (length frames) 1)
|
||||
(set-close-menu-item-state! (car frames) #f)
|
||||
(for-each (lambda (a-frame)
|
||||
(set-close-menu-item-state! a-frame #t))
|
||||
frames))))])
|
||||
(public
|
||||
(lambda (menu)
|
||||
(for-each (lambda (item) (send item delete))
|
||||
(send menu get-items))
|
||||
(for-each
|
||||
(lambda (frame)
|
||||
(let ([frame (frame-frame frame)])
|
||||
(make-object menu-item% (get-name frame)
|
||||
menu
|
||||
(lambda (_1 _2)
|
||||
(send frame show #t)))))
|
||||
sorted-frames))
|
||||
windows-menus)))])
|
||||
|
||||
(private
|
||||
[update-close-menu-item-state
|
||||
(lambda ()
|
||||
(let* ([set-close-menu-item-state!
|
||||
(lambda (frame state)
|
||||
(when (is-a? frame frame:standard-menus<%>)
|
||||
(let ([close-menu-item (ivar frame file-menu:close-menu)])
|
||||
(when close-menu-item
|
||||
(send close-menu-item enable state)))))])
|
||||
(if (eq? (length frames) 1)
|
||||
(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
|
||||
(lambda ()
|
||||
(if (and (eq? (system-type) 'windows)
|
||||
(preferences:get 'framework:windows-mdi))
|
||||
(begin
|
||||
(set! get-mdi-parent (lambda () mdi-parent))
|
||||
(set! mdi-parent (make-object frame% (application:current-app-name)
|
||||
#f #f #f #f #f
|
||||
'(mdi-parent)))
|
||||
(send mdi-parent show #t)
|
||||
mdi-parent)
|
||||
(begin
|
||||
(set! get-mdi-parent (lambda () #f))
|
||||
#f)))]
|
||||
[get-mdi-parent
|
||||
(lambda ()
|
||||
(if (and (eq? (system-type) 'windows)
|
||||
(preferences:get 'framework:windows-mdi))
|
||||
(begin
|
||||
(set! get-mdi-parent (lambda () mdi-parent))
|
||||
(set! mdi-parent (make-object frame% (application:current-app-name)
|
||||
#f #f #f #f #f
|
||||
'(mdi-parent)))
|
||||
(send mdi-parent show #t)
|
||||
mdi-parent)
|
||||
(begin
|
||||
(set! get-mdi-parent (lambda () #f))
|
||||
#f)))]
|
||||
|
||||
[set-empty-callbacks
|
||||
(lambda (test close-down)
|
||||
(set! empty-test test)
|
||||
(set! empty-close-down close-down))]
|
||||
[get-frames (lambda () (map frame-frame frames))]
|
||||
|
||||
[frame-label-changed
|
||||
(lambda (frame)
|
||||
(when (member frame (map frame-frame frames))
|
||||
(update-windows-menus)))]
|
||||
|
||||
[for-each-frame
|
||||
(lambda (f)
|
||||
(for-each (lambda (x) (f (frame-frame x))) frames)
|
||||
(set! todo-to-new-frames
|
||||
(let ([old todo-to-new-frames])
|
||||
(lambda (frame) (old frame) (f frame)))))]
|
||||
[get-active-frame
|
||||
(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])
|
||||
[set-empty-callbacks
|
||||
(lambda (test close-down)
|
||||
(set! empty-test test)
|
||||
(set! empty-close-down close-down))]
|
||||
[get-frames (lambda () (map frame-frame frames))]
|
||||
|
||||
[frame-label-changed
|
||||
(lambda (frame)
|
||||
(when (member frame (map frame-frame frames))
|
||||
(update-windows-menus)))]
|
||||
|
||||
[for-each-frame
|
||||
(lambda (f)
|
||||
(for-each (lambda (x) (f (frame-frame x))) frames)
|
||||
(set! todo-to-new-frames
|
||||
(let ([old todo-to-new-frames])
|
||||
(lambda (frame) (old frame) (f frame)))))]
|
||||
[get-active-frame
|
||||
(lambda ()
|
||||
(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))))
|
||||
[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
|
||||
[(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^
|
||||
(import mred^
|
||||
[gui-utils : framework:gui-utils^]
|
||||
[finder : framework:finder^]
|
||||
[group : framework:group^]
|
||||
[text : framework:text^]
|
||||
[preferences : framework:preferences^]
|
||||
[frame : framework:frame^]
|
||||
[mzlib:file : mzlib:file^])
|
||||
|
||||
(define-struct handler (name extension handler))
|
||||
(module handle mzscheme
|
||||
(require (lib "unitsig.ss")
|
||||
"sig.ss"
|
||||
(lib "mred-sig.ss" "mred")
|
||||
(lib "file.ss"))
|
||||
|
||||
(define format-handlers '())
|
||||
(provide handler@)
|
||||
|
||||
(define make-insert-handler
|
||||
(letrec ([string-list?
|
||||
(lambda (l)
|
||||
(cond
|
||||
[(null? l) #t]
|
||||
[(not (pair? l)) #f]
|
||||
[else
|
||||
(and (string? (car l))
|
||||
(string-list? (cdr l)))]))])
|
||||
(lambda (who name extension handler)
|
||||
(cond
|
||||
[(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 handler@
|
||||
(unit/sig framework:handler^
|
||||
(import mred^
|
||||
[gui-utils : framework:gui-utils^]
|
||||
[finder : framework:finder^]
|
||||
[group : framework:group^]
|
||||
[text : framework:text^]
|
||||
[preferences : framework:preferences^]
|
||||
[frame : framework:frame^])
|
||||
|
||||
(define-struct handler (name extension handler))
|
||||
|
||||
(define find-handler
|
||||
(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)))
|
||||
(define format-handlers '())
|
||||
|
||||
; Finding format & mode handlers by name
|
||||
(define find-named-handler
|
||||
(lambda (name handlers)
|
||||
(let loop ([l handlers])
|
||||
(cond
|
||||
[(null? l) #f]
|
||||
[(string-ci=? (handler-name (car l)) name)
|
||||
(handler-handler (car l))]
|
||||
[else (loop (cdr l))]))))
|
||||
|
||||
(define find-named-format-handler
|
||||
(lambda (name)
|
||||
(find-named-handler name format-handlers)))
|
||||
(define make-insert-handler
|
||||
(letrec ([string-list?
|
||||
(lambda (l)
|
||||
(cond
|
||||
[(null? l) #t]
|
||||
[(not (pair? l)) #f]
|
||||
[else
|
||||
(and (string? (car l))
|
||||
(string-list? (cdr l)))]))])
|
||||
(lambda (who name extension handler)
|
||||
(cond
|
||||
[(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))))
|
||||
|
||||
; Open a file for editing
|
||||
(define edit-file
|
||||
(opt-lambda (filename
|
||||
[make-default
|
||||
(lambda ()
|
||||
(let ([frame (make-object frame:text-info-file% filename)])
|
||||
(send frame show #t)
|
||||
frame))])
|
||||
(gui-utils:show-busy-cursor
|
||||
(lambda ()
|
||||
(if filename
|
||||
(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 find-handler
|
||||
(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)))
|
||||
|
||||
(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)))))
|
||||
; Finding format & mode handlers by name
|
||||
(define find-named-handler
|
||||
(lambda (name handlers)
|
||||
(let loop ([l handlers])
|
||||
(cond
|
||||
[(null? l) #f]
|
||||
[(string-ci=? (handler-name (car l)) name)
|
||||
(handler-handler (car l))]
|
||||
[else (loop (cdr l))]))))
|
||||
|
||||
(define find-named-format-handler
|
||||
(lambda (name)
|
||||
(find-named-handler name format-handlers)))
|
||||
|
||||
(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))))))
|
||||
; Open a file for editing
|
||||
(define edit-file
|
||||
(opt-lambda (filename
|
||||
[make-default
|
||||
(lambda ()
|
||||
(let ([frame (make-object frame:text-info-file% filename)])
|
||||
(send frame show #t)
|
||||
frame))])
|
||||
(gui-utils:show-busy-cursor
|
||||
(lambda ()
|
||||
(if filename
|
||||
(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^
|
||||
(import mred^)
|
||||
(module icon mzscheme
|
||||
(require (lib "unitsig.ss")
|
||||
"sig.ss"
|
||||
(lib "mred-sig.ss" "mred")
|
||||
(lib "mred-sig.ss" "mred"))
|
||||
|
||||
(define icon-path
|
||||
(with-handlers ([void (lambda (x) (collection-path "mzlib"))])
|
||||
(collection-path "icons")))
|
||||
(provide icon@)
|
||||
|
||||
(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 icon@
|
||||
(unit/sig framework:icon^
|
||||
(import mred^)
|
||||
|
||||
(define (fetch)
|
||||
(unless gc-on-bitmap
|
||||
(set! gc-on-bitmap ((load-icon "recycle.gif" 'gif)))))
|
||||
(define icon-path
|
||||
(with-handlers ([void (lambda (x) (collection-path "mzlib"))])
|
||||
(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 get-gc-off-bitmap
|
||||
(let ([bitmap #f])
|
||||
(lambda ()
|
||||
(if bitmap
|
||||
bitmap
|
||||
(begin
|
||||
(let ([bdc (make-object bitmap-dc%)]
|
||||
[onb (get-gc-on-bitmap)])
|
||||
(set! bitmap (make-object bitmap%
|
||||
(send onb get-width)
|
||||
(send onb get-height)))
|
||||
(send bdc set-bitmap bitmap)
|
||||
(send bdc clear)
|
||||
(send bdc set-bitmap #f)
|
||||
bitmap)))))))
|
||||
(define (fetch)
|
||||
(unless gc-on-bitmap
|
||||
(set! gc-on-bitmap ((load-icon "recycle.gif" 'gif)))))
|
||||
|
||||
(define (get-gc-on-bitmap) (fetch) gc-on-bitmap)
|
||||
|
||||
(define get-gc-off-bitmap
|
||||
(let ([bitmap #f])
|
||||
(lambda ()
|
||||
(if bitmap
|
||||
bitmap
|
||||
(begin
|
||||
(let ([bdc (make-object bitmap-dc%)]
|
||||
[onb (get-gc-on-bitmap)])
|
||||
(set! bitmap (make-object bitmap%
|
||||
(send onb get-width)
|
||||
(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^
|
||||
(import mred^
|
||||
[preferences : framework:preferences^]
|
||||
[exit : framework:exit^]
|
||||
[group : framework:group^])
|
||||
(module main mzscheme
|
||||
(require (lib "unitsig.ss")
|
||||
"sig.ss"
|
||||
(lib "mred-sig.ss" "mred"))
|
||||
|
||||
;; preferences
|
||||
(provide main@)
|
||||
|
||||
(preferences:set-default 'framework:search-using-dialog? #t boolean?)
|
||||
|
||||
(preferences:set-default 'framework:windows-mdi #f boolean?)
|
||||
(define main@
|
||||
(unit/sig framework:main^
|
||||
(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: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:menu-bindings #t boolean?)
|
||||
|
||||
(preferences:set-default 'framework:highlight-parens #t boolean?)
|
||||
(preferences:set-default 'framework:fixup-parens #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))))
|
||||
(preferences:set-default 'framework:verify-change-format #f 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))))
|
||||
|
||||
;; groups
|
||||
|
||||
(preferences:set-default 'framework:exit-when-no-frames #t boolean?)
|
||||
(preferences:set-default 'framework:highlight-parens #t boolean?)
|
||||
(preferences:set-default 'framework:fixup-parens #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
|
||||
(let ([skip? #f])
|
||||
(lambda (answer thunk)
|
||||
(if skip?
|
||||
answer
|
||||
(begin
|
||||
(set! skip? #t)
|
||||
(begin0 (thunk)
|
||||
(set! skip? #f))))))])
|
||||
;; groups
|
||||
|
||||
(preferences:set-default 'framework:exit-when-no-frames #t boolean?)
|
||||
|
||||
(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
|
||||
(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?)))))
|
||||
(send (group:get-the-frame-group) set-empty-callbacks
|
||||
|
||||
(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?
|
||||
;; empty test
|
||||
(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?)))))
|
||||
|
||||
(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.
|
||||
;; they do not need to be set across starting up and shutting down
|
||||
;; the application.
|
||||
(preferences:set 'framework:file-dialogs 'std)
|
||||
(preferences:set 'framework:exit-when-no-frames #t)
|
||||
|
||||
(void))
|
||||
(preferences:read)
|
||||
|
||||
;; reset these -- they are only for the test suite.
|
||||
;; they do not need to be set across starting up and shutting down
|
||||
;; the application.
|
||||
(preferences:set 'framework:file-dialogs 'std)
|
||||
(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^
|
||||
(import mred^
|
||||
[preferences : framework:preferences^])
|
||||
|
|
@ -23,4 +31,4 @@
|
|||
(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%)))
|
||||
(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^
|
||||
(import mred^
|
||||
[mzlib:function : mzlib:function^])
|
||||
|
|
@ -466,4 +474,4 @@
|
|||
(set! thumb-canvas (make-object thumb-canvas% this)))))
|
||||
|
||||
(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^
|
||||
(import mred^
|
||||
[editor : framework:editor^])
|
||||
(module pasteboard mzscheme
|
||||
(require (lib "unitsig.ss")
|
||||
"sig"
|
||||
(lib "mred-sig.ss" "mred"))
|
||||
|
||||
(rename [-keymap% keymap%])
|
||||
(provide pasteboard@)
|
||||
|
||||
(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%)))
|
||||
(define pasteboard@
|
||||
(unit/sig framework:pasteboard^
|
||||
(import mred^
|
||||
[editor : framework:editor^])
|
||||
|
||||
(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^
|
||||
(import)
|
||||
|
||||
(define generate-autosave-name
|
||||
(lambda (name)
|
||||
(let-values ([(base name dir?)
|
||||
(if name
|
||||
(split-path name)
|
||||
(values (current-directory) "mredauto" #f))])
|
||||
(let* ([base (if (string? base)
|
||||
base
|
||||
(current-directory))]
|
||||
[path (if (relative-path? base)
|
||||
(build-path (current-directory) base)
|
||||
base)]
|
||||
[without-ext
|
||||
(if (eq? (system-type) 'windows)
|
||||
(list->string
|
||||
(let loop ([list (string->list name)])
|
||||
(if (or (null? list)
|
||||
(char=? (car list) #\.))
|
||||
()
|
||||
(cons (car list)
|
||||
(loop (cdr list))))))
|
||||
name)])
|
||||
(let loop ([n 1])
|
||||
(let ([new-name
|
||||
(build-path path
|
||||
(if (eq? (system-type) 'windows)
|
||||
(string-append without-ext
|
||||
"."
|
||||
(number->string n))
|
||||
(string-append "#"
|
||||
name
|
||||
"#"
|
||||
(number->string n)
|
||||
"#")))])
|
||||
(if (file-exists? new-name)
|
||||
(loop (add1 n))
|
||||
new-name)))))))
|
||||
(define generate-backup-name
|
||||
(lambda (name)
|
||||
(if (eq? (system-type) 'windows)
|
||||
(list->string
|
||||
(let loop ([list (string->list name)])
|
||||
(if (or (null? list)
|
||||
(char=? (car list) #\.))
|
||||
'(#\. #\b #\a #\k)
|
||||
(cons (car list)
|
||||
(loop (cdr list))))))
|
||||
(string-append name "~")))))
|
||||
(provide path-utils@)
|
||||
|
||||
(define path-utils@
|
||||
(unit/sig framework:path-utils^
|
||||
(import)
|
||||
|
||||
(define generate-autosave-name
|
||||
(lambda (name)
|
||||
(let-values ([(base name dir?)
|
||||
(if name
|
||||
(split-path name)
|
||||
(values (current-directory) "mredauto" #f))])
|
||||
(let* ([base (if (string? base)
|
||||
base
|
||||
(current-directory))]
|
||||
[path (if (relative-path? base)
|
||||
(build-path (current-directory) base)
|
||||
base)]
|
||||
[without-ext
|
||||
(if (eq? (system-type) 'windows)
|
||||
(list->string
|
||||
(let loop ([list (string->list name)])
|
||||
(if (or (null? list)
|
||||
(char=? (car list) #\.))
|
||||
()
|
||||
(cons (car list)
|
||||
(loop (cdr list))))))
|
||||
name)])
|
||||
(let loop ([n 1])
|
||||
(let ([new-name
|
||||
(build-path path
|
||||
(if (eq? (system-type) 'windows)
|
||||
(string-append without-ext
|
||||
"."
|
||||
(number->string n))
|
||||
(string-append "#"
|
||||
name
|
||||
"#"
|
||||
(number->string n)
|
||||
"#")))])
|
||||
(if (file-exists? new-name)
|
||||
(loop (add1 n))
|
||||
new-name)))))))
|
||||
(define generate-backup-name
|
||||
(lambda (name)
|
||||
(if (eq? (system-type) 'windows)
|
||||
(list->string
|
||||
(let loop ([list (string->list name)])
|
||||
(if (or (null? list)
|
||||
(char=? (car list) #\.))
|
||||
'(#\. #\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^
|
||||
[prefs-file : framework:prefs-file^]
|
||||
[exn : framework:exn^]
|
||||
|
|
@ -642,4 +649,4 @@
|
|||
(send popup-menu set-selection 0))
|
||||
(send popup-menu focus)
|
||||
(send frame show #t)
|
||||
frame))))
|
||||
frame))))))
|
||||
|
|
|
|||
|
|
@ -3,6 +3,14 @@
|
|||
|
||||
; 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^
|
||||
(import mred^
|
||||
[preferences : framework:preferences^]
|
||||
|
|
@ -1021,6 +1029,4 @@
|
|||
(reset lambda-list-box lambda-keywords)
|
||||
#t))])
|
||||
(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^
|
||||
(import mred^
|
||||
[icon : framework:icon^]
|
||||
|
|
@ -470,4 +478,4 @@
|
|||
(define clever-file-format% (clever-file-format-mixin file%))
|
||||
(define backup-autosave% (editor:backup-autosave-mixin clever-file-format%))
|
||||
(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^
|
||||
(import [mzlib:string : mzlib:string^]
|
||||
[mzlib:function : mzlib:function^])
|
||||
(module version mzscheme
|
||||
(require (lib "unitsig.ss")
|
||||
"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
|
||||
(lambda ()
|
||||
(mzlib:function:foldr
|
||||
(lambda (entry sofar)
|
||||
(match entry
|
||||
[(sep num) (string-append sofar sep num)]))
|
||||
(version)
|
||||
specs)))
|
||||
(rename [-version version])
|
||||
|
||||
(define add-spec
|
||||
(lambda (sep num)
|
||||
(set! specs (cons (list (mzlib:string:expr->string sep)
|
||||
(mzlib:string:expr->string num))
|
||||
specs))))
|
||||
|
||||
'(add-version-spec ': 5))
|
||||
(define specs null)
|
||||
|
||||
(define -version
|
||||
(lambda ()
|
||||
(mzlib:function:foldr
|
||||
(lambda (entry sofar)
|
||||
(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