From 7c0d3f5da12249db2d8dde611f90d907467bbaff Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 21 Aug 2002 18:36:33 +0000 Subject: [PATCH] .. original commit: 809da2617d30761153b619d236d93b8aea8afff0 --- collects/framework/comment-snip.ss | 88 +------------ collects/framework/decorated-editor-snip.ss | 1 + collects/framework/private/comment-box.ss | 112 ++++++++++++++++ collects/framework/private/editor.ss | 14 +- collects/framework/private/frame.ss | 13 +- collects/framework/private/keymap.ss | 134 +++++++++++++------- collects/framework/private/scheme.ss | 22 +--- collects/framework/private/sig.ss | 15 ++- 8 files changed, 239 insertions(+), 160 deletions(-) create mode 100644 collects/framework/private/comment-box.ss diff --git a/collects/framework/comment-snip.ss b/collects/framework/comment-snip.ss index 23acda98..d0f71cde 100644 --- a/collects/framework/comment-snip.ss +++ b/collects/framework/comment-snip.ss @@ -1,87 +1,5 @@ + (module comment-snip mzscheme - (require (lib "class.ss") - (lib "mred.ss" "mred") - "decorated-editor-snip.ss" - (lib "string-constant.ss" "string-constants")) + (require (lib "framework.ss" "framework")) - (provide snip-class comment-box-snip%) - - (define comment-box-snipclass% - (class decorated-editor-snipclass% - (define/override (make-snip stream-in) (instantiate comment-box-snip% ())) - (super-instantiate ()))) - - (define snip-class (make-object comment-box-snipclass%)) - (send snip-class set-version 1) - (send snip-class set-classname (format "~s" '(lib "comment-snip.ss" "framework"))) - (send (get-the-snip-class-list) add snip-class) - - (define bm (let ([file (build-path (collection-path "icons") "semicolon.gif")]) - (and (file-exists? file) - (let ([bm (make-object bitmap% file)]) - (and (send bm ok?) - bm))))) - - (define comment-box-snip% - (class* decorated-editor-snip% (readable-snip<%>) - (inherit get-editor get-style) - (define/override (make-snip) (make-object comment-box-snip%)) - (define/override (get-corner-bitmap) bm) - - (define/override (get-menu) - (let ([menu (make-object popup-menu%)]) - (make-object menu-item% - (string-constant convert-to-semicolon-comment) - menu - (lambda (x y) - (let ([editor (find-containing-editor)]) - (when editor - (let ([this-pos (find-this-position)]) - (when this-pos - (move-contents-with-semicolons-to-position editor (+ this-pos 1)) - (send editor delete this-pos (+ this-pos 1)))))))))) - - (inherit get-admin) - ;; find-containing-editor : -> (union #f editor) - (define/private (find-containing-editor) - (let ([admin (get-admin)]) - (and admin - (send admin get-editor)))) - - ;; find-this-position : -> (union #f number) - (define (find-this-position) - (let ([ed (find-containing-editor)]) - (and ed - (send ed get-snip-position this)))) - - ;; move-contents-with-semicolons-to-position : (is-a? text%) number -> void - (define (move-contents-with-semicolons-to-position to-ed pos) - (let ([from-ed (get-editor)]) - (let loop ([snip (find-last-snip)]) - (cond - [snip - (when (or (memq 'hard-newline (send snip get-flags)) - (memq 'newline (send snip get-flags))) - (send to-ed insert ";" pos)) - (send from-ed release-snip) - (send to-ed insert snip pos) - (loop (send snip prev))] - [else (void)])))) - - ;; find-last-snip : editor -> snip - ;; returns the last snip in the editor - (define (find-last-snip ed) - (let loop ([snip (send ed find-first-snip)] - [acc (send ed find-first-snip)]) - (cond - [snip (loop (send snip next) snip)] - [else acc]))) - - (define/public (read-one-special index source line column position) - (raise (make-exn:special-comment - "msg" - (current-continuation-marks) - 1))) - (super-instantiate ()) - (inherit set-snipclass) - (set-snipclass snip-class)))) \ No newline at end of file + (provide (rename comment-box:snipclass snip-class))) diff --git a/collects/framework/decorated-editor-snip.ss b/collects/framework/decorated-editor-snip.ss index 60ab4d50..f42da2be 100644 --- a/collects/framework/decorated-editor-snip.ss +++ b/collects/framework/decorated-editor-snip.ss @@ -1,3 +1,4 @@ + (module decorated-editor-snip mzscheme (provide decorated-editor-snip% decorated-editor-snipclass%) diff --git a/collects/framework/private/comment-box.ss b/collects/framework/private/comment-box.ss new file mode 100644 index 00000000..52ee508a --- /dev/null +++ b/collects/framework/private/comment-box.ss @@ -0,0 +1,112 @@ + +(module comment-box mzscheme + (require (lib "class.ss") + (lib "mred.ss" "mred") + (lib "unitsig.ss") + "sig.ss" + "../decorated-editor-snip.ss" + (lib "string-constant.ss" "string-constants")) + + (provide comment-box@) + + (define comment-box@ + (unit/sig framework:comment-box^ + (import [text : framework:text^] + [scheme : framework:scheme^]) + (rename [-snip% snip%]) + + (define snipclass% + (class decorated-editor-snipclass% + (define/override (make-snip stream-in) (instantiate -snip% ())) + (super-instantiate ()))) + + (define snipclass (make-object snipclass%)) + (send snipclass set-version 1) + (send snipclass set-classname (format "~s" '(lib "comment-snip.ss" "framework"))) + (send (get-the-snip-class-list) add snipclass) + + (define bm (let ([file (build-path (collection-path "icons") "semicolon.gif")]) + (and (file-exists? file) + (let ([bm (make-object bitmap% file)]) + (and (send bm ok?) + bm))))) + + (define -snip% + (class* decorated-editor-snip% (readable-snip<%>) + (inherit get-editor get-style) + + (define/override (make-editor) (make-object (scheme:text-mixin text:keymap%))) + (define/override (make-snip) (make-object -snip%)) + (define/override (get-corner-bitmap) bm) + + (rename [super-get-text get-text]) + (define/override (get-text . args) + (let* ([super-res (super-get-text . args)] + [replaced (string-append "; " (regexp-replace* "\n" super-res "\n; "))]) + (if (char=? #\newline (string-ref replaced (- (string-length replaced) 1))) + replaced + (string-append replaced "\n")))) + + + (define/override (get-menu) + (let ([menu (make-object popup-menu%)]) + (make-object menu-item% + (string-constant convert-to-semicolon-comment) + menu + (lambda (x y) + (let ([to-ed (find-containing-editor)]) + (when to-ed + (let ([this-pos (find-this-position)]) + (when this-pos + (let ([from-ed (get-editor)]) + (send to-ed begin-edit-sequence) + (send from-ed begin-edit-sequence) + (copy-contents-with-semicolons-to-position to-ed from-ed (+ this-pos 1)) + (send to-ed delete this-pos (+ this-pos 1)) + (send to-ed end-edit-sequence) + (send from-ed end-edit-sequence)))))))) + menu)) + + (inherit get-admin) + ;; find-containing-editor : -> (union #f editor) + (define/private (find-containing-editor) + (let ([admin (get-admin)]) + (and admin + (send admin get-editor)))) + + ;; find-this-position : -> (union #f number) + (define (find-this-position) + (let ([ed (find-containing-editor)]) + (and ed + (send ed get-snip-position this)))) + + ;; copy-contents-with-semicolons-to-position : (is-a? text%) number -> void + (define (copy-contents-with-semicolons-to-position to-ed from-ed pos) + (let loop ([snip (find-last-snip from-ed)]) + (cond + [snip + (when (or (memq 'hard-newline (send snip get-flags)) + (memq 'newline (send snip get-flags))) + (send to-ed insert "; " pos)) + (send to-ed insert (send snip copy) pos) + (loop (send snip previous))] + [else + (send to-ed insert "; " pos)]))) + + ;; find-last-snip : editor -> snip + ;; returns the last snip in the editor + (define (find-last-snip ed) + (let loop ([snip (send ed find-first-snip)] + [acc (send ed find-first-snip)]) + (cond + [snip (loop (send snip next) snip)] + [else acc]))) + + (define/public (read-one-special index source line column position) + (raise (make-exn:special-comment + "msg" + (current-continuation-marks) + 1))) + (super-instantiate ()) + (inherit set-snipclass) + (set-snipclass snipclass)))))) \ No newline at end of file diff --git a/collects/framework/private/editor.ss b/collects/framework/private/editor.ss index 84f60d48..6f572107 100644 --- a/collects/framework/private/editor.ss +++ b/collects/framework/private/editor.ss @@ -68,9 +68,7 @@ (format (string-constant error-saving-file/name) filename) "\n\n" - (if (exn? exn) - (exn-message exn) - (format "~s" exn)))) + (format-error-message exn))) #f)]) (when filename (save-file filename fmt #f)) @@ -97,11 +95,19 @@ (format (string-constant error-loading-file/name) filename) "\n\n" - (if (exn? exn) (exn-message exn) (format "~s" exn)))) + (format-error-message exn))) #f)]) (load-file input-filename fmt show-errors?) #t)))) + (define/private (format-error-message exn) + (let ([sp (open-output-string)]) + (parameterize ([current-output-port sp]) + ((error-display-handler) + (if (exn? exn) (exn-message exn) (format "uncaught exn: ~s" exn)) + exn)) + (get-output-string sp))) + (inherit refresh-delayed? get-canvas get-max-width get-admin) diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index 19897424..976e62eb 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -11,8 +11,7 @@ (lib "mred-sig.ss" "mred") (lib "list.ss") (lib "file.ss") - (lib "etc.ss") - (prefix cb: "../comment-snip.ss")) + (lib "etc.ss")) (provide frame@) @@ -33,7 +32,8 @@ [canvas : framework:canvas^] [menu : framework:menu^] [scheme : framework:scheme^] - [exit : framework:exit^]) + [exit : framework:exit^] + [comment-box : framework:comment-box^]) (rename [-editor<%> editor<%>] [-pasteboard% pasteboard%] @@ -98,12 +98,7 @@ (lambda () (let ([text (get-edit-target-object)]) (when text - (let ([snip (make-object cb:comment-box-snip%)]) - - ;; we have to do this here to avoid cycles in the - ;; module imports - (send (send snip get-editor) set-style-list (scheme:get-style-list)) - + (let ([snip (make-object comment-box:snip%)]) (send text insert snip) (send text set-caret-owner snip 'global)))))]) diff --git a/collects/framework/private/keymap.ss b/collects/framework/private/keymap.ss index 8ef9b0d4..347669c9 100644 --- a/collects/framework/private/keymap.ss +++ b/collects/framework/private/keymap.ss @@ -233,41 +233,6 @@ (send event get-y))]) (send a popup-menu m (+ x 1) (+ y 1))))))))] - [up-out-of-editor-snip - (lambda (text event) - (let ([editor-admin (send text get-admin)]) - (when (is-a? editor-admin editor-snip-editor-admin<%>) - (let* ([snip (send editor-admin get-snip)] - [snip-admin (send snip get-admin)]) - (when snip-admin - (let ([editor (send snip-admin get-editor)]) - (when (is-a? editor text%) - (let ([new-pos (+ (send editor get-snip-position snip) - (if (= 0 (send text get-end-position)) - 0 - (send snip get-count)))]) - (send editor set-position new-pos new-pos)) - (send editor set-caret-owner #f 'display))))))) - #t)] - - [down-into-editor-snip - (lambda (dir get-pos) - (lambda (text event) - (when (= (send text get-start-position) - (send text get-end-position)) - (let* ([pos (send text get-start-position)] - [snip (send text find-snip pos dir)]) - (when (and snip - (is-a? snip editor-snip%)) - (let ([embedded-editor (send snip get-editor)]) - (when (is-a? embedded-editor text%) - (send embedded-editor set-position (get-pos embedded-editor))) - (send text set-caret-owner snip 'display))))) - #t))] - - [right-into-editor-snip (down-into-editor-snip 'after-or-none (lambda (x) 0))] - [left-into-editor-snip (down-into-editor-snip 'before-or-none (lambda (x) (send x last-position)))] - [toggle-anchor (lambda (edit event) (send edit set-anchor @@ -787,7 +752,78 @@ [toggle-overwrite (lambda (edit event) (send edit set-overwrite-mode - (not (send edit get-overwrite-mode))))]) + (not (send edit get-overwrite-mode))))] + + [down-into-embedded-editor + (lambda (text event) + (let ([start (send text get-start-position)] + [end (send text get-end-position)]) + (when (= start end) + (let* ([bx (box 0)] + [after-snip (send text find-snip start 'after-or-none bx)]) + (cond + [(and (= (unbox bx) start) + after-snip + (is-a? after-snip editor-snip%)) + (let ([embedded-editor (send after-snip get-editor)]) + (when (is-a? embedded-editor text%) + (send embedded-editor set-position 0)) + (send embedded-editor set-caret-owner #f 'global))] + [else + (let ([before-snip (send text find-snip start 'before-or-none bx)]) + (when (and (= (+ (unbox bx) 1) start) + before-snip + (is-a? before-snip editor-snip%)) + (let ([embedded-editor (send before-snip get-editor)]) + (when (is-a? embedded-editor text%) + (send embedded-editor set-position + (send embedded-editor last-position))) + (send embedded-editor set-caret-owner #f 'global))))])))) + #t)] + + [forward-to-next-embedded-editor + (lambda (text event) + (let ([start-pos (send text get-start-position)] + [end-pos (send text get-end-position)]) + (when (= start-pos end-pos) + (let loop ([snip (send text find-snip start-pos 'after-or-none)]) + (cond + [(not snip) (void)] + [(is-a? snip editor-snip%) + (send text set-position (send text get-snip-position snip))] + [else (loop (send snip next))])))) + #t)] + + [back-to-prev-embedded-editor + (lambda (text event) + (let ([start-pos (send text get-start-position)] + [end-pos (send text get-end-position)]) + (when (= start-pos end-pos) + (let loop ([snip (send text find-snip start-pos 'before-or-none)]) + (cond + [(not snip) (void)] + [(is-a? snip editor-snip%) + (send text set-position (+ (send text get-snip-position snip) 1))] + [else (loop (send snip previous))])))) + #t)] + + [up-out-of-embedded-editor + (lambda (text event) + (let ([start (send text get-start-position)] + [end (send text get-end-position)]) + (when (= start end) + (let ([editor-admin (send text get-admin)]) + (when (is-a? editor-admin editor-snip-editor-admin<%>) + (let* ([snip (send editor-admin get-snip)] + [snip-admin (send snip get-admin)]) + (when snip-admin + (let ([editor (send snip-admin get-editor)]) + (when (is-a? editor text%) + (let ([new-pos (send editor get-snip-position snip)]) + (send editor set-position new-pos new-pos)) + (send editor set-caret-owner #f 'display))))))))) + #t)]) + (lambda (kmap) (let* ([map (lambda (key func) (send kmap map-function key func))] @@ -797,8 +833,14 @@ (send kmap add-function name func))] [add-m (lambda (name func) (send kmap add-function name func))]) - + ; Map names to keyboard functions + + (add "down-into-embedded-editor" down-into-embedded-editor) + (add "up-out-of-embedded-editor" up-out-of-embedded-editor) + (add "forward-to-next-embedded-editor" forward-to-next-embedded-editor) + (add "back-to-prev-embedded-editor" back-to-prev-embedded-editor) + (add "toggle-overwrite" toggle-overwrite) (add "exit" (lambda (edit event) @@ -811,10 +853,6 @@ (add "ring-bell" ring-bell) (add "flash-paren-match" flash-paren-match) - - (add "left-into-editor-snip" left-into-editor-snip) - (add "right-into-editor-snip" right-into-editor-snip) - (add "up-out-of-editor-snip" up-out-of-editor-snip) (add "toggle-anchor" toggle-anchor) (add "center-view-on-line" center-view-on-line) @@ -858,6 +896,16 @@ (add "mouse-popup-menu" mouse-popup-menu) ; Map keys to functions + + (map-meta "c:down" "down-into-embedded-editor") + (map "a:c:down" "down-into-embedded-editor") + (map-meta "c:up" "up-out-of-embedded-editor") + (map "a:c:up" "up-out-of-embedded-editor") + (map-meta "c:right" "forward-to-next-embedded-editor") + (map "a:c:right" "forward-to-next-embedded-editor") + (map-meta "c:left" "back-to-prev-embedded-editor") + (map "a:c:left" "back-to-prev-embedded-editor") + (map "c:g" "ring-bell") (map-meta "c:g" "ring-bell") (map "c:x;c:g" "ring-bell") @@ -994,10 +1042,6 @@ (map "c:space" "toggle-anchor") - (map-meta "c:left" "left-into-editor-snip") - (map-meta "c:right" "right-into-editor-snip") - (map-meta "c:up" "up-out-of-editor-snip") - (map "insert" "toggle-overwrite") (map-meta "o" "toggle-overwrite") diff --git a/collects/framework/private/scheme.ss b/collects/framework/private/scheme.ss index 62ee8cf4..bf808ebd 100644 --- a/collects/framework/private/scheme.ss +++ b/collects/framework/private/scheme.ss @@ -6,7 +6,6 @@ (lib "string-constant.ss" "string-constants") (lib "unitsig.ss") (lib "class.ss") - (prefix cb: "../comment-snip.ss") "sig.ss" "../macro.ss" (lib "mred-sig.ss" "mred") @@ -28,7 +27,8 @@ [keymap : framework:keymap^] [text : framework:text^] [editor : framework:editor^] - [frame : framework:frame^]) + [frame : framework:frame^] + [comment-box : framework:comment-box^]) (rename [-text% text%] [-text<%> text<%>]) @@ -869,9 +869,8 @@ (begin-edit-sequence) (split-snip start-pos) (split-snip end-pos) - (let* ([cb (instantiate cb:comment-box-snip% ())] + (let* ([cb (instantiate comment-box:snip% ())] [text (send cb get-editor)]) - (send text set-style-list style-list) (let loop ([snip (find-snip start-pos 'after-or-none)]) (cond [(not snip) (void)] @@ -897,15 +896,15 @@ (cond [(and (= start-pos end-pos) snip-before - (is-a? snip-before cb:comment-box-snip%)) + (is-a? snip-before comment-box:snip%)) (extract-contents start-pos snip-before)] [(and (= start-pos end-pos) snip-after - (is-a? snip-after cb:comment-box-snip%)) + (is-a? snip-after comment-box:snip%)) (extract-contents start-pos snip-after)] [(and (= (+ start-pos 1) end-pos) snip-after - (is-a? snip-after cb:comment-box-snip%)) + (is-a? snip-after comment-box:snip%)) (extract-contents start-pos snip-after)] [else (let* ([last-pos (last-position)] @@ -925,7 +924,7 @@ (end-edit-sequence)) #t)) - ;; extract-contents : number (is-a?/c cb:comment-box-snip%) -> void + ;; extract-contents : number (is-a?/c comment-box:snip%) -> void ;; copies the contents of the comment-box-snip out of the snip ;; and into this editor as `pos'. Deletes the comment box snip (define/private (extract-contents pos snip) @@ -1243,12 +1242,6 @@ (send keymap map-function "\"" "balance-quotes") (send keymap map-function "|" "balance-quotes") - ;(send keymap map-function "c:up" "up-sexp") ;; paragraph - ;(send keymap map-function "s:c:up" "select-up-sexp") - - ;(send keymap map-function "c:down" "down-sexp") ;; paragraph - ;(send keymap map-function "s:c:down" "select-down-sexp") - (let ([map-meta (lambda (key func) (keymap:send-map-function-meta keymap key func))] @@ -1265,7 +1258,6 @@ (map-meta "down" "down-sexp") (map "a:down" "down-sexp") - (map-meta "c:down" "down-sexp") (map-meta "s:down" "select-down-sexp") (map "a:s:down" "select-down-sexp") (map-meta "s:c:down" "select-down-sexp") diff --git a/collects/framework/private/sig.ss b/collects/framework/private/sig.ss index 1e541473..c5c45292 100644 --- a/collects/framework/private/sig.ss +++ b/collects/framework/private/sig.ss @@ -76,8 +76,19 @@ framework:main-fun^ framework:color-model^ framework:color-model-class^ - framework:color-model-fun^) - + framework:color-model-fun^ + framework:comment-box-fun^ + framework:comment-box-class^ + framework:comment-box^) + + (define-signature framework:comment-box-fun^ + ()) + (define-signature framework:comment-box-class^ + (snipclass snip%)) + (define-signature framework:comment-box^ + ((open framework:comment-box-fun^) + (open framework:comment-box-class^))) + (define-signature framework:menu-class^ (can-restore<%> can-restore-mixin