...
original commit: cfdca56769cc5f14e5fd2c474b51f0d019035074
This commit is contained in:
Robby Findler
parent
08f0d3cc22
commit
ab1095b4c3
146
collects/framework/gen-standard-menus.ss
Executable file
146
collects/framework/gen-standard-menus.ss
Executable file
|
|
@ -0,0 +1,146 @@
|
|||
#!/bin/sh
|
||||
|
||||
string=? ; exec mred -mgaqvf $0
|
||||
|
||||
(require-library "pretty.ss")
|
||||
|
||||
(load-relative "standard-menus-items.ss")
|
||||
|
||||
(define build-id
|
||||
(lambda (name post)
|
||||
(let* ([name-string (symbol->string name)]
|
||||
[answer (string->symbol (string-append name-string post))])
|
||||
answer)))
|
||||
|
||||
(define menu-name->id
|
||||
(lambda (name-string)
|
||||
(let ([file-menu? (string=? (substring name-string 0 9) "file-menu")]
|
||||
[edit-menu? (string=? (substring name-string 0 9) "edit-menu")]
|
||||
[windows-menu? (string=? (substring name-string 0 9) "windows-m")]
|
||||
[help-menu? (string=? (substring name-string 0 9) "help-menu")])
|
||||
`(,(cond
|
||||
[file-menu? 'get-file-menu]
|
||||
[edit-menu? 'get-edit-menu]
|
||||
[windows-menu? 'get-windows-menu]
|
||||
[help-menu? 'get-help-menu]
|
||||
[else (printf "WARNING: defaulting item to file-menu ~s~n" name-string)
|
||||
'get-file-menu])))))
|
||||
|
||||
(define (an-item->names item)
|
||||
(let ([name (an-item->name item)])
|
||||
(list name (build-id name "-string") (build-id name "-help-string"))))
|
||||
|
||||
(define build-fill-in-item-clause
|
||||
(lambda (item)
|
||||
(let ([help-string (an-item-help-string item)]
|
||||
[proc (an-item-proc item)])
|
||||
`(public
|
||||
,@(map (lambda (x y) `[,x ,y])
|
||||
(an-item->names item)
|
||||
(list proc `(lambda () "") `(lambda () ,help-string)))))))
|
||||
|
||||
(define build-fill-in-between/after-clause
|
||||
(lambda (->name -procedure)
|
||||
(lambda (obj)
|
||||
`(public
|
||||
[,(->name obj)
|
||||
,(case (-procedure obj)
|
||||
[(nothing) '(lambda (menu) (void))]
|
||||
[(separator) '(lambda (menu) (make-object separator-menu-item% menu))])]))))
|
||||
|
||||
(define build-fill-in-between-clause (build-fill-in-between/after-clause between->name between-procedure))
|
||||
(define build-fill-in-after-clause (build-fill-in-between/after-clause after->name after-procedure))
|
||||
|
||||
(define build-item-menu-clause
|
||||
(lambda (item)
|
||||
(let* ([name (an-item->name item)]
|
||||
[name-string (symbol->string name)]
|
||||
[menu-before-string (an-item-menu-string-before item)]
|
||||
[menu-after-string (an-item-menu-string-after item)]
|
||||
[key (an-item-key item)]
|
||||
[join '(lambda (base special suffix)
|
||||
(if (string=? special "")
|
||||
(string-append base suffix)
|
||||
(string-append base " " special suffix)))])
|
||||
`(public
|
||||
[,(build-id name "-menu")
|
||||
(and ,name
|
||||
(make-object
|
||||
(get-menu-item%)
|
||||
(,join ,menu-before-string
|
||||
,(build-id name "-string")
|
||||
,menu-after-string)
|
||||
,(menu-name->id name-string)
|
||||
,name
|
||||
,key
|
||||
(,(build-id name "-help-string"))))]))))
|
||||
|
||||
(define build-between/after-menu-clause
|
||||
(lambda (->name -menu)
|
||||
(lambda (between/after)
|
||||
`(sequence
|
||||
(,(->name between/after)
|
||||
,(menu-name->get-menu (-menu between/after)))))))
|
||||
|
||||
(define build-between-menu-clause (build-between/after-menu-clause between->name between-menu))
|
||||
(define build-after-menu-clause (build-between/after-menu-clause after->name after-menu))
|
||||
|
||||
(define menu-name->get-menu
|
||||
(lambda (menu-name)
|
||||
`(,(string->symbol
|
||||
(string-append
|
||||
"get-"
|
||||
(symbol->string
|
||||
menu-name))))))
|
||||
|
||||
(define build-between-menu-clause
|
||||
(lambda (between)
|
||||
`(sequence
|
||||
(,(between->name between)
|
||||
,(menu-name->get-menu (between-menu between))))))
|
||||
|
||||
(define (build-generic-clause x) '(sequence (void)))
|
||||
(define (build-fill-in-generic-clause generic)
|
||||
`(public [,(generic-name generic)
|
||||
,(generic-initializer generic)]))
|
||||
|
||||
(call-with-output-file "standard-menus.ss"
|
||||
(lambda (port)
|
||||
(pretty-print
|
||||
`(define standard-menus<%>
|
||||
(interface (basic<%>)
|
||||
,@(apply append (map
|
||||
(lambda (x)
|
||||
(cond
|
||||
[(an-item? x) (an-item->names x)]
|
||||
[(between? x) (list (between->name x))]
|
||||
[(after? x) (list (after->name x))]
|
||||
[(generic? x) (list (generic-name x))]))
|
||||
items))))
|
||||
port)
|
||||
|
||||
(newline port)
|
||||
|
||||
(pretty-print
|
||||
`(define standard-menus-mixin
|
||||
(mixin (basic<%>) (standard-menus<%>) args
|
||||
(inherit get-menu-bar on-close show)
|
||||
(sequence (apply super-init args))
|
||||
,@(append
|
||||
(map (lambda (x)
|
||||
(cond
|
||||
[(between? x) (build-fill-in-between-clause x)]
|
||||
[(after? x) (build-fill-in-after-clause x)]
|
||||
[(an-item? x) (build-fill-in-item-clause x)]
|
||||
[(generic? x) (build-fill-in-generic-clause x)]
|
||||
[else (printf "~a~n" x)]))
|
||||
items)
|
||||
(map (lambda (x)
|
||||
(cond
|
||||
[(between? x) (build-between-menu-clause x)]
|
||||
[(an-item? x) (build-item-menu-clause x)]
|
||||
[(after? x) (build-after-menu-clause x)]
|
||||
[(generic? x) (build-generic-clause x)]))
|
||||
items))))
|
||||
port))
|
||||
'truncate)
|
||||
|
|
@ -1,9 +1,8 @@
|
|||
(unit/sig framework:pasteboard^
|
||||
(dunit/sig framework:pasteboard^
|
||||
(import mred-interfaces^
|
||||
[editor : framework:editor^])
|
||||
|
||||
(define basic% (editor:make-basic% pasteboard%))
|
||||
(define file% (editor:make-file% basic%))
|
||||
(define clever-file-format% (editor:make-clever-file-format% file%))
|
||||
(define backup-autosave% (editor:make-backup-autosave% clever-file-format%))
|
||||
(define info% (editor:make-info% backup-autosave%)))
|
||||
(define basic% (editor:basic-mixin pasteboard%))
|
||||
(define file% (editor:file-mixin basic%))
|
||||
(define backup-autosave% (editor:backup-autosave-mixin file%))
|
||||
(define info% (editor:info-mixin backup-autosave%)))
|
||||
|
|
@ -1,10 +1,12 @@
|
|||
(unit/sig framework:preferences^
|
||||
(dunit/sig framework:preferences^
|
||||
(import mred-interfaces^
|
||||
[exn : framework:exn^]
|
||||
[exit : framework:exit^]
|
||||
[panel : framework:panel^]
|
||||
[mzlib:pretty-print : mzlib:pretty-print^]
|
||||
[mzlib:function : mzlib:function^])
|
||||
|
||||
(rename [-read read])
|
||||
|
||||
(define preferences-filename (build-path (find-system-path 'pref-dir)
|
||||
(case (system-type)
|
||||
|
|
@ -192,7 +194,7 @@
|
|||
(hash-table-map preferences marshall-pref) p))
|
||||
'truncate 'text)))))
|
||||
|
||||
(define read
|
||||
(define -read
|
||||
(let ([parse-pref
|
||||
(lambda (p marshalled)
|
||||
(let/ec k
|
||||
|
|
@ -595,7 +597,7 @@
|
|||
[ok-button (make-object button% bottom-panel ok-callback "OK")]
|
||||
[cancel-callback (lambda args
|
||||
(hide-dialog)
|
||||
(read))]
|
||||
(-read))]
|
||||
[cancel-button (make-object button% bottom-panel cancel-callback "Cancel")])
|
||||
(send ok-button user-min-width (send cancel-button get-width))
|
||||
(send* bottom-panel
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
|
||||
; Scheme mode for MrEd.
|
||||
|
||||
(unit/sig framework:scheme^
|
||||
(dunit/sig framework:scheme^
|
||||
(import mred-interfaces^
|
||||
[preferences : framework:preferences^]
|
||||
[match-cache : framework:match-cache^]
|
||||
|
|
@ -11,7 +11,7 @@
|
|||
[scheme-paren : framework:scheme-paren^]
|
||||
[icon : framework:icon^]
|
||||
[keymap : framework:keymap^]
|
||||
[editor : framework:editor^]
|
||||
[text : framework:text^]
|
||||
[frame : framework:frame^]
|
||||
[mzlib:thread : mzlib:thread^])
|
||||
|
||||
|
|
@ -56,9 +56,9 @@
|
|||
|
||||
(define init-wordbreak-map
|
||||
(lambda (map)
|
||||
(let ([v (send map get-map (char->integer #\-))])
|
||||
(let ([v (send map get-map #\-)])
|
||||
(send map set-map
|
||||
(char->integer #\-)
|
||||
#\-
|
||||
'(line)))))
|
||||
(define wordbreak-map (make-object editor-wordbreak-map%))
|
||||
(init-wordbreak-map wordbreak-map)
|
||||
|
|
@ -69,22 +69,21 @@
|
|||
(send delta set-delta 'change-family 'modern)
|
||||
delta))
|
||||
(let ([style (send style-list find-named-style "Standard")])
|
||||
(if (null? style)
|
||||
(if style
|
||||
(send style set-delta standard-style-delta)
|
||||
(send style-list new-named-style "Standard"
|
||||
(send style-list find-or-create-style
|
||||
(send style-list find-named-style "Basic")
|
||||
standard-style-delta))
|
||||
(send style set-delta standard-style-delta)))
|
||||
standard-style-delta))))
|
||||
|
||||
(define make-text%
|
||||
(mixin (editor:basic<%>) (-text<%>) args
|
||||
(define text-mixin
|
||||
(mixin (text:basic<%>) (-text<%>) args
|
||||
(inherit begin-edit-sequence
|
||||
delete
|
||||
end-edit-sequence
|
||||
find-string
|
||||
get-character
|
||||
get-keymap
|
||||
get-key-code
|
||||
get-text
|
||||
get-start-position
|
||||
get-end-position
|
||||
|
|
@ -104,9 +103,7 @@
|
|||
set-tabs
|
||||
set-style-list
|
||||
set-styles-fixed)
|
||||
(rename [super-on-char on-char]
|
||||
[super-deinstall deinstall]
|
||||
[super-install install])
|
||||
(rename [super-on-char on-char])
|
||||
|
||||
(private
|
||||
[in-single-line-comment?
|
||||
|
|
@ -133,7 +130,7 @@
|
|||
(private
|
||||
[in-highlight-parens? #f])
|
||||
|
||||
(inherit styles-fixed?)
|
||||
(inherit get-styles-fixed)
|
||||
(rename [super-on-focus on-focus]
|
||||
[super-on-change-style on-change-style]
|
||||
[super-after-change-style after-change-style]
|
||||
|
|
@ -159,7 +156,7 @@
|
|||
[after-change-style
|
||||
(lambda (start len)
|
||||
(end-edit-sequence)
|
||||
(unless styles-fixed?
|
||||
(unless (get-styles-fixed)
|
||||
(highlight-parens))
|
||||
(super-after-change-style))]
|
||||
[on-edit-sequence
|
||||
|
|
@ -773,7 +770,7 @@
|
|||
k))])
|
||||
(send keymap chain-to-keymap keymap #t)))))
|
||||
|
||||
(define -text% (make-text% frame:text-info-file%))
|
||||
(define -text% (text-mixin text:info%))
|
||||
|
||||
(define setup-keymap
|
||||
(lambda (keymap)
|
||||
|
|
@ -897,6 +894,5 @@
|
|||
(map-meta "c:t" "transpose-sexp"))
|
||||
(send keymap map-function "c:c;c:b" "remove-parens-forward")))
|
||||
|
||||
|
||||
(define keymap (make-object keymap%))
|
||||
(setup-keymap keymap))
|
||||
|
|
|
|||
|
|
@ -11,14 +11,14 @@
|
|||
version))
|
||||
|
||||
(define-signature framework:panel^
|
||||
(make-single%
|
||||
(single-mixin
|
||||
single<%>
|
||||
single%
|
||||
|
||||
make-edit%
|
||||
edit<%>
|
||||
horizontal-edit%
|
||||
vertical-edit%))
|
||||
editor-mixin
|
||||
editor<%>
|
||||
horizontal-editor%
|
||||
vertical-editor%))
|
||||
|
||||
(define-signature framework:exn^
|
||||
((struct exn ())
|
||||
|
|
@ -67,8 +67,7 @@
|
|||
generate-backup-name))
|
||||
|
||||
(define-signature framework:finder^
|
||||
(filter-match?
|
||||
dialog-parent-parameter
|
||||
(dialog-parent-parameter
|
||||
common-put-file
|
||||
common-get-file
|
||||
std-put-file
|
||||
|
|
@ -83,16 +82,14 @@
|
|||
info<%>
|
||||
backup-autosave<%>
|
||||
|
||||
make-clever-file-format%
|
||||
make-basic%
|
||||
make-info%
|
||||
make-file%
|
||||
make-backup-autosave%))
|
||||
basic-mixin
|
||||
info-mixin
|
||||
file-mixin
|
||||
backup-autosave-mixin))
|
||||
|
||||
(define-signature framework:pasteboard^
|
||||
(basic%
|
||||
file%
|
||||
clever-file-format%
|
||||
backup-autosave%
|
||||
info%))
|
||||
|
||||
|
|
@ -100,9 +97,10 @@
|
|||
(basic<%>
|
||||
searching<%>
|
||||
|
||||
make-basic%
|
||||
make-return%
|
||||
make-searching%
|
||||
basic-mixin
|
||||
return-mixin
|
||||
searching-mixin
|
||||
clever-file-format-mixin
|
||||
|
||||
basic%
|
||||
return%
|
||||
|
|
@ -120,36 +118,37 @@
|
|||
|
||||
|
||||
(define-signature framework:canvas^
|
||||
(make-wide-snip%
|
||||
(wide-snip-mixin
|
||||
wide-snip<%>
|
||||
wide-snip%))
|
||||
|
||||
(define-signature framework:frame^
|
||||
(basic<%>
|
||||
make-basic%
|
||||
basic-mixin
|
||||
|
||||
standard-menus<%>
|
||||
make-standard-menus%
|
||||
standard-menus-mixin
|
||||
|
||||
editor<%>
|
||||
make-editor%
|
||||
editor-mixin
|
||||
|
||||
text<%>
|
||||
make-text%
|
||||
text-mixin
|
||||
|
||||
pasteboard<%>
|
||||
make-pasteboard%
|
||||
pasteboard-mixin
|
||||
|
||||
searchable<%>
|
||||
make-searchable%
|
||||
searchable-mixin
|
||||
|
||||
info<%>
|
||||
make-info%
|
||||
info-mixin
|
||||
|
||||
edit-info<%>
|
||||
make-edit-info%
|
||||
editor-info<%>
|
||||
editor-info-mixin
|
||||
|
||||
file<%>
|
||||
make-file%
|
||||
file-mixin
|
||||
|
||||
empty%
|
||||
standard-menus%
|
||||
|
|
@ -183,11 +182,11 @@
|
|||
get-reset-console-bitmap
|
||||
|
||||
get-lock-bitmap
|
||||
get-lock-mdc
|
||||
get-lock-bdc
|
||||
get-unlock-bitmap
|
||||
get-unlock-mdc
|
||||
get-unlock-bdc
|
||||
get-anchor-bitmap
|
||||
get-anchor-mdc
|
||||
get-anchor-bdc
|
||||
|
||||
get-gc-on-dc
|
||||
get-gc-off-dc
|
||||
|
|
@ -229,7 +228,7 @@
|
|||
style-list
|
||||
keymap
|
||||
setup-keymap
|
||||
make-text%
|
||||
text-mixin
|
||||
text<%>
|
||||
text%))
|
||||
|
||||
|
|
@ -239,6 +238,8 @@
|
|||
backward-match
|
||||
skip-whitespace))
|
||||
|
||||
(define-signature framework:main^ ())
|
||||
|
||||
(define-signature framework^
|
||||
([unit application : framework:application^]
|
||||
[unit version : framework:version^]
|
||||
|
|
@ -269,4 +270,5 @@
|
|||
[unit panel : framework:panel^]
|
||||
|
||||
[unit frame : framework:frame^]
|
||||
[unit scheme : framework:scheme^]))
|
||||
[unit scheme : framework:scheme^]
|
||||
[unit main : framework:main^]))
|
||||
151
collects/framework/standard-menus-items.ss
Normal file
151
collects/framework/standard-menus-items.ss
Normal file
|
|
@ -0,0 +1,151 @@
|
|||
(define-struct generic (name initializer documentation))
|
||||
|
||||
(define-struct after (menu name procedure))
|
||||
(define (after->name after)
|
||||
(string->symbol (format "~a:after-~a" (after-menu after) (after-name after))))
|
||||
|
||||
(define-struct between (menu before after procedure))
|
||||
(define (between->name between)
|
||||
(string->symbol (format "~a:between-~a-and-~a"
|
||||
(between-menu between)
|
||||
(between-before between)
|
||||
(between-after between))))
|
||||
|
||||
(define-struct an-item (menu-name item-name help-string proc key menu-string-before menu-string-after))
|
||||
(define (an-item->name item)
|
||||
(string->symbol (format "~a:~a" (an-item-menu-name item) (an-item-item-name item))))
|
||||
|
||||
(define items
|
||||
(list (make-generic 'get-menu% '(lambda () menu%)
|
||||
'("The result of this method is used as the class for creating:"
|
||||
"@mlink file-menu %"
|
||||
", "
|
||||
"@mlink edit-menu %"
|
||||
", "
|
||||
"@mlink windows-menu %"
|
||||
", and"
|
||||
"@mlink help-menu %"
|
||||
". "
|
||||
""
|
||||
"@return : (derived-from \\iscmclass{menu})"
|
||||
""
|
||||
"defaultly returns"
|
||||
"@link menu"))
|
||||
(make-generic 'get-menu-item% '(lambda () menu-item%)
|
||||
'("The result of this method is used as the class for creating"
|
||||
"the menu items in this class (see "
|
||||
"@link frame:standard-menus"
|
||||
"for a list)."
|
||||
""
|
||||
"@return : (derived-from \\iscmclass{menu-item})"
|
||||
""
|
||||
"defaultly returns"
|
||||
"@link menu-item"))
|
||||
|
||||
(make-generic 'get-file-menu
|
||||
'(let ([m (make-object (get-menu%)
|
||||
(if (eq? (system-type) 'windows)
|
||||
"&File" "F&ile")
|
||||
(get-menu-bar))])
|
||||
(lambda () m))
|
||||
'("Returns the file menu"
|
||||
"See also"
|
||||
"@mlink get-menu\%"
|
||||
""
|
||||
"@return : (instance (derived-from \\iscmclass{menu}))"))
|
||||
(make-generic 'get-edit-menu
|
||||
'(let ([m (make-object (get-menu%) "&Edit" (get-menu-bar))])
|
||||
(lambda () m))
|
||||
|
||||
'("Returns the edit menu"
|
||||
"See also"
|
||||
"@mlink get-menu\%"
|
||||
""
|
||||
"@return : (instance (derived-from \\iscmclass{menu}))"))
|
||||
(make-generic 'get-windows-menu
|
||||
'(let ([m (make-object (get-menu%) "&Windows" (get-menu-bar))])
|
||||
(lambda () m))
|
||||
|
||||
'("Returns the windows menu"
|
||||
"See also"
|
||||
"@mlink get-menu\%"
|
||||
""
|
||||
"@return : (instance (derived-from \\iscmclass{menu}))"))
|
||||
(make-generic 'get-help-menu
|
||||
'(let ([m (make-object (get-menu%) "&Help" (get-menu-bar))])
|
||||
(lambda () m))
|
||||
|
||||
'("Returns the help menu"
|
||||
"See also"
|
||||
"@mlink get-menu\%"
|
||||
""
|
||||
"@return : (instance (derived-from \\iscmclass{menu}))"))
|
||||
|
||||
(make-an-item 'file-menu 'new "Open a new file"
|
||||
'(lambda (item control) (handler:edit-file #f) #t)
|
||||
#\n "&New" "")
|
||||
(make-between 'file-menu 'new 'open 'nothing)
|
||||
(make-an-item 'file-menu 'open "Open a file from disk"
|
||||
'(lambda (item control) (handler:open-file) #t)
|
||||
#\o "&Open" "...")
|
||||
(make-between 'file-menu 'open 'revert 'nothing)
|
||||
(make-an-item 'file-menu 'revert
|
||||
"Revert this file to the copy on disk"
|
||||
#f #f "&Revert" "")
|
||||
(make-between 'file-menu 'revert 'save 'nothing)
|
||||
(make-an-item 'file-menu 'save
|
||||
"Save this file to disk"
|
||||
#f "s" "&Save" "")
|
||||
(make-an-item 'file-menu 'save-as
|
||||
"Prompt for a filename and save this file to disk"
|
||||
#f #f "Save" " &As...")
|
||||
(make-between 'file-menu 'save-as 'print 'separator)
|
||||
(make-an-item 'file-menu 'print
|
||||
"Print this file"
|
||||
#f "p" "&Print" "...")
|
||||
(make-between 'file-menu 'print 'close 'separator)
|
||||
(make-an-item 'file-menu 'close
|
||||
"Close this file"
|
||||
'(lambda (item control) (when (on-close) (show #f)) #t)
|
||||
#\w "&Close" "")
|
||||
(make-between 'file-menu 'close 'quit 'nothing)
|
||||
(make-an-item 'file-menu 'quit
|
||||
"Quit"
|
||||
'(lambda (item control) (exit:exit))
|
||||
#\q
|
||||
'(if (eq? (system-type) 'windows) "E&xit" "Quit")
|
||||
"")
|
||||
(make-after 'file-menu 'quit 'nothing)
|
||||
|
||||
(make-an-item 'edit-menu 'undo "Undo the most recent action" #f #\z "&Undo" "")
|
||||
(make-an-item 'edit-menu 'redo "Redo the most recent undo" #f #\y "&Redo" "")
|
||||
(make-between 'edit-menu 'redo 'cut 'nothing)
|
||||
(make-an-item 'edit-menu 'cut "Cut the selection" #f #\x "Cu&t" "")
|
||||
(make-between 'edit-menu 'cut 'copy 'nothing)
|
||||
(make-an-item 'edit-menu 'copy "Copy the selection" #f #\c "&Copy" "")
|
||||
(make-between 'edit-menu 'copy 'paste 'nothing)
|
||||
(make-an-item 'edit-menu 'paste "Paste the most recent copy or cut over the selection" #f #\v "&Paste" "")
|
||||
(make-between 'edit-menu 'paste 'clear 'nothing)
|
||||
(make-an-item 'edit-menu 'clear "Clear the selection without affecting paste" #f #f
|
||||
'(if (eq? (system-type) 'macos)
|
||||
"Clear"
|
||||
"&Delete")
|
||||
"")
|
||||
(make-between 'edit-menu 'clear 'select-all 'nothing)
|
||||
(make-an-item 'edit-menu 'select-all "Select the entire document" #f #\a "Select A&ll" "")
|
||||
(make-between 'edit-menu 'select-all 'find 'nothing)
|
||||
(make-an-item 'edit-menu 'find "Search for a string in the window"
|
||||
'(lambda (item control) (send this move-to-search-or-search) #t)
|
||||
#\f "Find" "")
|
||||
(make-between 'edit-menu 'find 'preferences 'separator)
|
||||
(make-an-item 'edit-menu 'preferences "Configure the preferences"
|
||||
'(lambda (item control) (preferences:show-dialog) #t)
|
||||
#f "Preferences..." "")
|
||||
(make-after 'edit-menu 'preferences 'nothing)
|
||||
|
||||
(make-an-item 'help-menu 'about "Learn something about this application"
|
||||
#f
|
||||
#f
|
||||
"About "
|
||||
"...")
|
||||
(make-after 'help-menu 'about 'nothing)))
|
||||
|
|
@ -2,11 +2,6 @@
|
|||
(read-case-sensitive #t)
|
||||
(compile-allow-cond-fallthrough #t)
|
||||
(compile-allow-set!-undefined #t)
|
||||
(begin
|
||||
(require-library "launcher.ss" "launcher")
|
||||
(make-mred-launcher (list "-mvL" "test.ss" "framework")
|
||||
(mred-program-launcher-path "Test Framework")))
|
||||
|
||||
(printf "2~n")
|
||||
(require-library "loader.ss" "system")
|
||||
(printf "3~n")
|
||||
|
|
|
|||
|
|
@ -1,8 +1,9 @@
|
|||
(unit/sig framework:text^
|
||||
(dunit/sig framework:text^
|
||||
(import mred-interfaces^
|
||||
[editor : framework:editor^]
|
||||
[preferences : framework:preferences^]
|
||||
[keymap : framework:keymap^]
|
||||
[gui-utils : framework:gui-utils^]
|
||||
[mzlib:function : mzlib:function^])
|
||||
|
||||
(define-struct range (start end b/w-bitmap color caret-space?))
|
||||
|
|
@ -14,16 +15,16 @@
|
|||
(define basic<%>
|
||||
(interface (editor:basic<%> text<%>)
|
||||
highlight-range
|
||||
styles-fixed?
|
||||
get-styles-fixed
|
||||
set-styles-fixed
|
||||
move/copy-to-edit
|
||||
autowrap-bitmap))
|
||||
initial-autowrap-bitmap))
|
||||
|
||||
(define make-basic%
|
||||
(define basic-mixin
|
||||
(mixin (editor:basic<%> text<%>) (basic<%>) args
|
||||
(inherit canvases get-max-width get-admin split-snip get-snip-position
|
||||
(inherit get-canvases get-admin split-snip get-snip-position
|
||||
delete find-snip invalidate-bitmap-cache
|
||||
set-autowrap-bitmap get-keymap mode set-mode-direct
|
||||
set-autowrap-bitmap get-keymap
|
||||
set-file-format get-file-format
|
||||
get-style-list is-modified? change-style set-modified
|
||||
position-location get-extent)
|
||||
|
|
@ -100,7 +101,7 @@
|
|||
(let-values ([(min-left max-right)
|
||||
(let loop ([left #f]
|
||||
[right #f]
|
||||
[canvases canvases])
|
||||
[canvases (get-canvases)])
|
||||
(cond
|
||||
[(null? canvases)
|
||||
(values left right)]
|
||||
|
|
@ -250,9 +251,10 @@
|
|||
|
||||
|
||||
(private
|
||||
[styles-fixed? #f]
|
||||
[styles-fixed-edit-modified? #f])
|
||||
(public
|
||||
[styles-fixed? #f]
|
||||
[get-styles-fixed (lambda () styles-fixed?)]
|
||||
[set-styles-fixed (lambda (b) (set! styles-fixed? b))])
|
||||
(rename
|
||||
[super-on-change-style on-change-style]
|
||||
|
|
@ -285,7 +287,7 @@
|
|||
(split-snip end)
|
||||
(let loop ([snip (find-snip end 'before)])
|
||||
(cond
|
||||
[(or (null? snip) (< (get-snip-position snip) start))
|
||||
[(or (not snip) (< (get-snip-position snip) start))
|
||||
(void)]
|
||||
[else
|
||||
(let ([prev (send snip previous)]
|
||||
|
|
@ -301,10 +303,10 @@
|
|||
|
||||
|
||||
(public
|
||||
[autowrap-bitmap #f])
|
||||
[initial-autowrap-bitmap (lambda () #f)])
|
||||
(sequence
|
||||
(apply super-init args)
|
||||
(set-autowrap-bitmap autowrap-bitmap)
|
||||
(set-autowrap-bitmap (initial-autowrap-bitmap))
|
||||
(let ([keymap (get-keymap)])
|
||||
(keymap:set-keymap-error-handler keymap)
|
||||
(keymap:set-keymap-implied-shifts keymap)
|
||||
|
|
@ -315,7 +317,7 @@
|
|||
(define searching<%>
|
||||
(interface ()
|
||||
find-string-embedded))
|
||||
(define make-searching%
|
||||
(define searching-mixin
|
||||
(mixin (editor:basic<%> text<%>) (searching<%>) args
|
||||
(inherit get-end-position get-start-position last-position
|
||||
find-string get-snip-position get-admin find-snip
|
||||
|
|
@ -405,7 +407,7 @@
|
|||
(keymap:set-keymap-implied-shifts keymap)
|
||||
(send keymap chain-to-keymap keymap:search #f)))))
|
||||
|
||||
(define make-return%
|
||||
(define return-mixin
|
||||
(mixin (text<%>) (text<%>) (return . args)
|
||||
(rename [super-on-local-char on-local-char])
|
||||
(override
|
||||
|
|
@ -421,7 +423,7 @@
|
|||
(sequence
|
||||
(apply super-init args))))
|
||||
|
||||
(define make-info%
|
||||
(define info-mixin
|
||||
(mixin (editor:basic<%> text<%>) (editor:basic<%> text<%>) args
|
||||
(inherit get-start-position get-end-position get-canvas
|
||||
run-after-edit-sequence)
|
||||
|
|
@ -469,10 +471,56 @@
|
|||
(enqueue-for-frame 'edit-position-changed
|
||||
'framework:edit-position-changed))])))
|
||||
|
||||
(define basic% (make-basic% (editor:make-basic% text%)))
|
||||
(define return% (make-return% basic%))
|
||||
(define file% (editor:make-file% basic%))
|
||||
(define clever-file-format% (editor:make-clever-file-format% file%))
|
||||
(define backup-autosave% (editor:make-backup-autosave% clever-file-format%))
|
||||
(define searching% (make-searching% backup-autosave%))
|
||||
(define info% (make-info% (editor:make-info% searching%))))
|
||||
(define clever-file-format-mixin
|
||||
(mixin (text<%>) (text<%>) args
|
||||
(inherit get-file-format set-file-format find-first-snip)
|
||||
(rename [super-on-save-file on-save-file]
|
||||
[super-after-save-file after-save-file])
|
||||
|
||||
(private [restore-file-format void])
|
||||
|
||||
(override
|
||||
[after-save-file
|
||||
(lambda (success)
|
||||
(restore-file-format)
|
||||
(super-after-save-file success))]
|
||||
[on-save-file
|
||||
(let ([has-non-string-snips
|
||||
(lambda ()
|
||||
(let loop ([s (find-first-snip)])
|
||||
(cond
|
||||
[(null? s) #f]
|
||||
[(is-a? s string-snip%)
|
||||
(loop (send s next))]
|
||||
[else #t])))])
|
||||
(lambda (name format)
|
||||
(when (and (or (eq? format 'same)
|
||||
(eq? format 'copy))
|
||||
(not (eq? (get-file-format)
|
||||
'std)))
|
||||
(cond
|
||||
[(eq? format 'copy)
|
||||
(set! restore-file-format
|
||||
(let ([f (get-file-format)])
|
||||
(lambda ()
|
||||
(set! restore-file-format void)
|
||||
(set-file-format f))))
|
||||
(set-file-format 'std)]
|
||||
[(and (has-non-string-snips)
|
||||
(or (not (preferences:get 'framework:verify-change-format))
|
||||
(gui-utils:get-choice "Save this file as plain text?" "No" "Yes")))
|
||||
(set-file-format 'std)]
|
||||
[else (void)]))
|
||||
(or (super-on-save-file name format)
|
||||
(begin
|
||||
(restore-file-format)
|
||||
#f))))])
|
||||
(sequence (apply super-init args))))
|
||||
|
||||
(define basic% (basic-mixin (editor:basic-mixin text%)))
|
||||
(define return% (return-mixin basic%))
|
||||
(define file% (editor:file-mixin basic%))
|
||||
(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%))))
|
||||
|
|
@ -1,24 +1,24 @@
|
|||
(unit/sig framework:version^
|
||||
(import [mzlib:string : mzlib:string^]
|
||||
[mzlib:function : mzlib:function^])
|
||||
(dunit/sig framework:version^
|
||||
(import [mzlib:string : mzlib:string^]
|
||||
[mzlib:function : mzlib:function^])
|
||||
|
||||
(rename [-version version])
|
||||
(rename [-version version])
|
||||
|
||||
(define specs null)
|
||||
(define specs null)
|
||||
|
||||
(define -version
|
||||
(lambda ()
|
||||
(mzlib:function:foldr
|
||||
(lambda (entry sofar)
|
||||
(match entry
|
||||
[(sep num) (string-append sofar sep num)]))
|
||||
(version)
|
||||
specs)))
|
||||
(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))))
|
||||
|
||||
'(add-version-spec ': 5))
|
||||
(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))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user