diff --git a/collects/mred/edit-main.ss b/collects/mred/edit-main.ss new file mode 100644 index 00000000..2abb1f22 --- /dev/null +++ b/collects/mred/edit-main.ss @@ -0,0 +1,14 @@ + +;; Uses editor.ss to open a frame for each argument + +(module edit-main mzscheme + (require "edit.ss" + (lib "cmdline.ss")) + + (command-line + "Edit" + (current-command-line-arguments) + [args files + (if (null? files) + (new-text-frame #f) + (for-each new-text-frame files))])) diff --git a/collects/mred/edit.ss b/collects/mred/edit.ss new file mode 100644 index 00000000..aabd23a2 --- /dev/null +++ b/collects/mred/edit.ss @@ -0,0 +1,64 @@ + +;; Simple editor implementation; provides new-text-frame +;; and new-pasteboard-frame + +(module edit mzscheme + (require (lib "class.ss") + (lib "mred.ss" "mred")) + + (provide new-text-frame + new-pasteboard-frame) + + (define (new-text-frame file) (new-frame text% file)) + (define (new-pasteboard-frame file) (new-frame pasteboard% file)) + + (define (new-frame editor% file) + (define f (make-object frame% (or file "Simple Editor") #f 620 450)) + (define c (make-object editor-canvas% f)) + (define e (make-object editor%)) + (define mb (make-object menu-bar% f)) + + (define file-menu (make-object menu% "File" mb)) + (define edit-menu (make-object menu% "Edit" mb)) + (define font-menu (make-object menu% "Font" mb)) + + (make-object menu-item% "New Text Frame" file-menu + (lambda (item event) + (new-text-frame #f)) + #\N) + (make-object menu-item% "New Pasteboard Frame" file-menu + (lambda (item event) + (new-pasteboard-frame #f))) + + (make-object menu-item% "Open..." file-menu + (lambda (item event) + (send e load-file "")) + #\O) + (make-object menu-item% "Save As..." file-menu + (lambda (item event) + (send e save-file "")) + #\S) + (make-object separator-menu-item% file-menu) + (make-object menu-item% "Print..." file-menu + (lambda (item event) + (send e print)) + #\P) + (make-object separator-menu-item% file-menu) + (make-object menu-item% "Close" file-menu + (lambda (item event) + (send f show #f)) + #\Q) + + (append-editor-operation-menu-items edit-menu #f) + + (append-editor-font-menu-items font-menu) + ((current-text-keymap-initializer) (send e get-keymap)) + (send c set-editor e) + + (when file + (if (regexp-match "[.]((gif)|(bmp)|(jpg)|(xbm))$" file) + (send e insert (make-object image-snip% file)) + (send e load-file file))) + + (send f show #t) + f)) diff --git a/collects/mred/mred.ss b/collects/mred/mred.ss index 62839107..662ae0ba 100644 --- a/collects/mred/mred.ss +++ b/collects/mred/mred.ss @@ -6055,6 +6055,32 @@ (wx:set-dialogs get-file put-file get-ps-setup-from-user message-box) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; snip-class% and editor-data-class% loaders + +(let ([load-one + (lambda (str id %) + (let ([m (with-handlers ([void (lambda (x) #f)]) + (and (regexp-match "^[(].*[)]$" str) + (read (open-input-string str))))]) + (if (and (list? m) + (eq? 'lib (car m)) + (andmap string? (cdr m))) + (let ([result (dynamic-require m id)]) + (if (is-a? result %) + result + (error 'load-class "not a ~a% instance" id))))))]) + ;; install the getters: + (wx:set-snip-class-getter + (lambda (name) + (load-one name 'snip-class wx:snip-class%))) + (wx:set-editor-data-class-getter + (lambda (name) + (load-one name 'editor-data-class wx:editor-data-class%)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (define-syntax propagate (lambda (stx) (syntax-case stx () diff --git a/collects/mred/private/kernel.ss b/collects/mred/private/kernel.ss index f3804dbd..9c5744ef 100644 --- a/collects/mred/private/kernel.ss +++ b/collects/mred/private/kernel.ss @@ -1398,7 +1398,9 @@ set-dialogs set-executer current-gl-context - send-event) + send-event + set-snip-class-getter + set-editor-data-class-getter) ) ;; end