suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

..

Browse Source 
original commit: 809da2617d30761153b619d236d93b8aea8afff0
This commit is contained in:
Robby Findler 2002-08-21 18:36:33 +00:00
parent 31c28374fa
commit 7c0d3f5da1
8 changed files with 239 additions and 160 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
collects/framework/comment-snip.ss
View File

@ -1,87 +1,5 @@
(module comment-snip mzscheme (module comment-snip mzscheme
(require (lib "class.ss") (require (lib "framework.ss" "framework"))
(lib "mred.ss" "mred")
"decorated-editor-snip.ss"
(lib "string-constant.ss" "string-constants"))
(provide snip-class comment-box-snip%) (provide (rename comment-box:snipclass snip-class)))
(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))))

1
collects/framework/decorated-editor-snip.ss
View File

@ -1,3 +1,4 @@
(module decorated-editor-snip mzscheme (module decorated-editor-snip mzscheme
(provide decorated-editor-snip% (provide decorated-editor-snip%
decorated-editor-snipclass%) decorated-editor-snipclass%)

112
collects/framework/private/comment-box.ss Normal file
View File

@ -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))))))

14
collects/framework/private/editor.ss
View File

@ -68,9 +68,7 @@
(format (string-constant error-saving-file/name) (format (string-constant error-saving-file/name)
filename) filename)
"\n\n" "\n\n"
(if (exn? exn) (format-error-message exn)))
(exn-message exn)
(format "~s" exn))))
#f)]) #f)])
(when filename (when filename
(save-file filename fmt #f)) (save-file filename fmt #f))
@ -97,11 +95,19 @@
(format (string-constant error-loading-file/name) (format (string-constant error-loading-file/name)
filename) filename)
"\n\n" "\n\n"
(if (exn? exn) (exn-message exn) (format "~s" exn)))) (format-error-message exn)))
#f)]) #f)])
(load-file input-filename fmt show-errors?) (load-file input-filename fmt show-errors?)
#t)))) #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? (inherit refresh-delayed?
get-canvas get-canvas
get-max-width get-admin) get-max-width get-admin)

13
collects/framework/private/frame.ss
View File

@ -11,8 +11,7 @@
(lib "mred-sig.ss" "mred") (lib "mred-sig.ss" "mred")
(lib "list.ss") (lib "list.ss")
(lib "file.ss") (lib "file.ss")
(lib "etc.ss") (lib "etc.ss"))
(prefix cb: "../comment-snip.ss"))
(provide frame@) (provide frame@)
@ -33,7 +32,8 @@
[canvas : framework:canvas^] [canvas : framework:canvas^]
[menu : framework:menu^] [menu : framework:menu^]
[scheme : framework:scheme^] [scheme : framework:scheme^]
[exit : framework:exit^]) [exit : framework:exit^]
[comment-box : framework:comment-box^])
(rename [-editor<%> editor<%>] (rename [-editor<%> editor<%>]
[-pasteboard% pasteboard%] [-pasteboard% pasteboard%]
@ -98,12 +98,7 @@
(lambda () (lambda ()
(let ([text (get-edit-target-object)]) (let ([text (get-edit-target-object)])
(when text (when text
(let ([snip (make-object cb:comment-box-snip%)]) (let ([snip (make-object 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))
(send text insert snip) (send text insert snip)
(send text set-caret-owner snip 'global)))))]) (send text set-caret-owner snip 'global)))))])

134
collects/framework/private/keymap.ss
View File

@ -233,41 +233,6 @@
(send event get-y))]) (send event get-y))])
(send a popup-menu m (+ x 1) (+ y 1))))))))] (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 [toggle-anchor
(lambda (edit event) (lambda (edit event)
(send edit set-anchor (send edit set-anchor
@ -787,7 +752,78 @@
[toggle-overwrite [toggle-overwrite
(lambda (edit event) (lambda (edit event)
(send edit set-overwrite-mode (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) (lambda (kmap)
(let* ([map (lambda (key func) (let* ([map (lambda (key func)
(send kmap map-function key func))] (send kmap map-function key func))]
@ -797,8 +833,14 @@
(send kmap add-function name func))] (send kmap add-function name func))]
[add-m (lambda (name func) [add-m (lambda (name func)
(send kmap add-function name func))]) (send kmap add-function name func))])
; Map names to keyboard functions ; 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 "toggle-overwrite" toggle-overwrite)
(add "exit" (lambda (edit event) (add "exit" (lambda (edit event)
@ -811,10 +853,6 @@
(add "ring-bell" ring-bell) (add "ring-bell" ring-bell)
(add "flash-paren-match" flash-paren-match) (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 "toggle-anchor" toggle-anchor)
(add "center-view-on-line" center-view-on-line) (add "center-view-on-line" center-view-on-line)
@ -858,6 +896,16 @@
(add "mouse-popup-menu" mouse-popup-menu) (add "mouse-popup-menu" mouse-popup-menu)
; Map keys to functions ; 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 "c:g" "ring-bell")
(map-meta "c:g" "ring-bell") (map-meta "c:g" "ring-bell")
(map "c:x;c:g" "ring-bell") (map "c:x;c:g" "ring-bell")
@ -994,10 +1042,6 @@
(map "c:space" "toggle-anchor") (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 "insert" "toggle-overwrite")
(map-meta "o" "toggle-overwrite") (map-meta "o" "toggle-overwrite")

22
collects/framework/private/scheme.ss
View File

@ -6,7 +6,6 @@
(lib "string-constant.ss" "string-constants") (lib "string-constant.ss" "string-constants")
(lib "unitsig.ss") (lib "unitsig.ss")
(lib "class.ss") (lib "class.ss")
(prefix cb: "../comment-snip.ss")
"sig.ss" "sig.ss"
"../macro.ss" "../macro.ss"
(lib "mred-sig.ss" "mred") (lib "mred-sig.ss" "mred")
@ -28,7 +27,8 @@
[keymap : framework:keymap^] [keymap : framework:keymap^]
[text : framework:text^] [text : framework:text^]
[editor : framework:editor^] [editor : framework:editor^]
[frame : framework:frame^]) [frame : framework:frame^]
[comment-box : framework:comment-box^])
(rename [-text% text%] (rename [-text% text%]
[-text<%> text<%>]) [-text<%> text<%>])
@ -869,9 +869,8 @@
(begin-edit-sequence) (begin-edit-sequence)
(split-snip start-pos) (split-snip start-pos)
(split-snip end-pos) (split-snip end-pos)
(let* ([cb (instantiate cb:comment-box-snip% ())] (let* ([cb (instantiate comment-box:snip% ())]
[text (send cb get-editor)]) [text (send cb get-editor)])
(send text set-style-list style-list)
(let loop ([snip (find-snip start-pos 'after-or-none)]) (let loop ([snip (find-snip start-pos 'after-or-none)])
(cond (cond
[(not snip) (void)] [(not snip) (void)]
@ -897,15 +896,15 @@
(cond (cond
[(and (= start-pos end-pos) [(and (= start-pos end-pos)
snip-before snip-before
(is-a? snip-before cb:comment-box-snip%)) (is-a? snip-before comment-box:snip%))
(extract-contents start-pos snip-before)] (extract-contents start-pos snip-before)]
[(and (= start-pos end-pos) [(and (= start-pos end-pos)
snip-after snip-after
(is-a? snip-after cb:comment-box-snip%)) (is-a? snip-after comment-box:snip%))
(extract-contents start-pos snip-after)] (extract-contents start-pos snip-after)]
[(and (= (+ start-pos 1) end-pos) [(and (= (+ start-pos 1) end-pos)
snip-after snip-after
(is-a? snip-after cb:comment-box-snip%)) (is-a? snip-after comment-box:snip%))
(extract-contents start-pos snip-after)] (extract-contents start-pos snip-after)]
[else [else
(let* ([last-pos (last-position)] (let* ([last-pos (last-position)]
@ -925,7 +924,7 @@
(end-edit-sequence)) (end-edit-sequence))
#t)) #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 ;; copies the contents of the comment-box-snip out of the snip
;; and into this editor as `pos'. Deletes the comment box snip ;; and into this editor as `pos'. Deletes the comment box snip
(define/private (extract-contents pos 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 "|" "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 (let ([map-meta
(lambda (key func) (lambda (key func)
(keymap:send-map-function-meta keymap key func))] (keymap:send-map-function-meta keymap key func))]
@ -1265,7 +1258,6 @@
(map-meta "down" "down-sexp") (map-meta "down" "down-sexp")
(map "a:down" "down-sexp") (map "a:down" "down-sexp")
(map-meta "c:down" "down-sexp")
(map-meta "s:down" "select-down-sexp") (map-meta "s:down" "select-down-sexp")
(map "a:s:down" "select-down-sexp") (map "a:s:down" "select-down-sexp")
(map-meta "s:c:down" "select-down-sexp") (map-meta "s:c:down" "select-down-sexp")

15
collects/framework/private/sig.ss
View File

@ -76,8 +76,19 @@
framework:main-fun^ framework:main-fun^
framework:color-model^ framework:color-model^
framework:color-model-class^ 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^ (define-signature framework:menu-class^
(can-restore<%> (can-restore<%>
can-restore-mixin can-restore-mixin