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

...

Browse Source 
original commit: cfa23802335d6008cfecf57406d9e1cb1ce9524f
This commit is contained in:
Robby Findler 2002-07-29 05:50:17 +00:00
parent 8aa16354d9
commit e4cb2634e5
6 changed files with 158 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
collects/framework/comment-snip.ss Normal file
View File

@ -0,0 +1,37 @@
(module comment-snip mzscheme
(require (lib "class.ss")
(lib "mred.ss" "mred"))
(provide snip-class comment-box-snip%)
(define comment-box-snipclass%
(class snip-class%
(define/override (read stream-in)
(let* ([snip (instantiate comment-box-snip% ())])
(send (send snip get-editor) read-from-file stream-in)
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 comment-box-snip%
(class* editor-snip% (readable-snip<%>)
(inherit get-editor get-style)
(define/override (write stream-out)
(send (get-editor) write-to-file stream-out 0 'eof))
(define/override (copy)
(let ([snip (make-object comment-box-snip%)])
(send snip set-editor (send (get-editor) copy-self))
(send snip set-style (get-style))
snip))
(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))))

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

@ -11,7 +11,8 @@
(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@)
@ -31,7 +32,8 @@
[pasteboard : framework:pasteboard^] [pasteboard : framework:pasteboard^]
[editor : framework:editor^] [editor : framework:editor^]
[canvas : framework:canvas^] [canvas : framework:canvas^]
[menu : framework:menu^]) [menu : framework:menu^]
[scheme : framework:scheme^])
(rename [-editor<%> editor<%>] (rename [-editor<%> editor<%>]
[-pasteboard% pasteboard%] [-pasteboard% pasteboard%]
@ -91,10 +93,25 @@
[on-demand [on-demand
(lambda (menu-item) (lambda (menu-item)
(let ([edit (get-edit-target-object)]) (let ([edit (get-edit-target-object)])
(send menu-item enable (and edit (is-a? edit editor<%>)))))]) (send menu-item enable (and edit (is-a? edit editor<%>)))))]
[insert-comment-box
(lambda ()
(let ([text (get-edit-target-object)])
(when text
(let ([snip (make-object cb:comment-box-snip%)])
(make-object c% (string-constant insert-text-box-item) ;; we have to do this here to avoid cycles in the
edit-menu (edit-menu:do 'insert-text-box) #f #f on-demand) ;; module imports
(send (send snip get-editor) set-style-list (scheme:get-style-list))
(send text insert snip)
(send text set-caret-owner snip 'global)))))])
(make-object c% (string-constant insert-comment-box-menu-item-label)
edit-menu
(lambda (x y) (insert-comment-box))
#f #f
on-demand)
(make-object c% (string-constant insert-image-item) (make-object c% (string-constant insert-image-item)
edit-menu (edit-menu:do 'insert-image) #f #f on-demand) edit-menu (edit-menu:do 'insert-image) #f #f on-demand)
(void))) (void)))
@ -1934,7 +1951,10 @@
(define memory-text% (class100 text% args (sequence (apply super-init args)))) (define memory-text% (class100 text% args (sequence (apply super-init args))))
(define memory-text (make-object memory-text%)) (define memory-text (make-object memory-text%))
(send memory-text hide-caret #t) (send memory-text hide-caret #t)
(define show-memory-text? (directory-exists? (build-path (collection-path "framework") "CVS"))) (define show-memory-text?
(with-handlers ([not-break-exn?
(lambda (x) #f)])
(directory-exists? (build-path (collection-path "framework") "CVS"))))
(define file<%> (interface (-editor<%>))) (define file<%> (interface (-editor<%>)))
(define file-mixin (define file-mixin

16
collects/framework/private/icon.ss
View File

@ -12,7 +12,11 @@
(import mred^) (import mred^)
(define icon-path (define icon-path
(with-handlers ([void (lambda (x) (collection-path "mzlib"))]) (with-handlers ([not-break-exn?
(lambda (x)
(case (system-type)
[(windows) "C:"] ;; just avoid quering the floppy drive
[else (car (filesystem-root-list))]))])
(collection-path "icons"))) (collection-path "icons")))
(define (load-icon name type) (define (load-icon name type)
@ -22,8 +26,6 @@
(let ([bitmap (make-object bitmap% p type)]) (let ([bitmap (make-object bitmap% p type)])
(set! f (lambda () bitmap)) (set! f (lambda () bitmap))
bitmap))]) bitmap))])
(unless (file-exists? p)
(fprintf (current-error-port) "WARNING: couldn't find ~a~n" p))
(lambda () (lambda ()
(f)))) (f))))
@ -34,8 +36,6 @@
(let ([bitmap (make-object bitmap% p type)]) (let ([bitmap (make-object bitmap% p type)])
(set! f (lambda () bitmap)) (set! f (lambda () bitmap))
bitmap))]) bitmap))])
(unless (file-exists? p)
(fprintf (current-error-port) "WARNING: couldn't find ~a~n" p))
(lambda () (lambda ()
(f)))) (f))))
@ -49,8 +49,6 @@
(define (make-get/mask filename type) (define (make-get/mask filename type)
(let ([icon #f] (let ([icon #f]
[p (build-path icon-path filename)]) [p (build-path icon-path filename)])
(unless (file-exists? p)
(fprintf (current-error-port) "WARNING: couldn't find ~a~n" p))
(lambda () (lambda ()
(or icon (or icon
(begin (begin
@ -58,8 +56,8 @@
icon))))) icon)))))
(define (make-cursor name mask fallback) (define (make-cursor name mask fallback)
(let* ([msk-b (make-object bitmap% (build-path (collection-path "icons") mask))] (let* ([msk-b (make-object bitmap% (build-path icon-path mask))]
[csr-b (make-object bitmap% (build-path (collection-path "icons") name))]) [csr-b (make-object bitmap% (build-path icon-path name))])
(if (and (send msk-b ok?) (if (and (send msk-b ok?)
(send csr-b ok?)) (send csr-b ok?))
(let ([csr (make-object cursor% msk-b csr-b 7 7)]) (let ([csr (make-object cursor% msk-b csr-b 7 7)])

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

@ -6,6 +6,7 @@
(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")
@ -358,7 +359,8 @@
set-tabs set-tabs
set-style-list set-style-list
set-styles-fixed set-styles-fixed
change-style) change-style
get-snip-position)
(rename [super-on-char on-char]) (rename [super-on-char on-char])
(define (in-single-line-comment? position) (define (in-single-line-comment? position)
@ -836,44 +838,79 @@
(opt-lambda ([start-pos (get-start-position)] (opt-lambda ([start-pos (get-start-position)]
[end-pos (get-end-position)]) [end-pos (get-end-position)])
(begin-edit-sequence) (begin-edit-sequence)
(let ([first-pos-is-first-para-pos? (split-snip start-pos)
(= (paragraph-start-position (position-paragraph start-pos)) (split-snip end-pos)
start-pos)]) (let* ([cb (instantiate cb:comment-box-snip% ())]
(let* ([first-para (position-paragraph start-pos)] [text (send cb get-editor)])
[last-para (calc-last-para end-pos)]) (send text set-style-list style-list)
(let para-loop ([curr-para first-para]) (let loop ([snip (find-snip start-pos 'after-or-none)])
(if (<= curr-para last-para) (cond
(let ([first-on-para (paragraph-start-position curr-para)]) [(not snip) (void)]
(insert #\; first-on-para) [((get-snip-position snip) . >= . end-pos) (void)]
(para-loop (add1 curr-para)))))) [else
(when first-pos-is-first-para-pos? (send text insert (send snip copy)
(set-position (send text last-position)
(paragraph-start-position (position-paragraph (get-start-position))) (send text last-position))
(get-end-position)))) (loop (send snip next))]))
(delete start-pos end-pos)
(insert cb start-pos)
(set-position start-pos start-pos))
(end-edit-sequence) (end-edit-sequence)
#t)) #t))
(define uncomment-selection (define uncomment-selection
(opt-lambda ([start-pos (get-start-position)] (opt-lambda ([start-pos (get-start-position)]
[end-pos (get-end-position)]) [end-pos (get-end-position)])
(begin-edit-sequence) (let ([snip-before (find-snip start-pos 'before-or-none)]
(let* ([last-pos (last-position)] [snip-after (find-snip start-pos 'after-or-none)])
[first-para (position-paragraph start-pos)]
[last-para (calc-last-para end-pos)]) (begin-edit-sequence)
(let para-loop ([curr-para first-para]) (cond
(if (<= curr-para last-para) [(and (= start-pos end-pos)
(let ([first-on-para snip-before
(paren:skip-whitespace (is-a? snip-before cb:comment-box-snip%))
this (extract-contents start-pos snip-before)]
(paragraph-start-position curr-para) [(and (= start-pos end-pos)
'forward)]) snip-after
(when (and (< first-on-para last-pos) (is-a? snip-after cb:comment-box-snip%))
(char=? #\; (get-character first-on-para))) (extract-contents start-pos snip-after)]
(delete first-on-para (+ first-on-para 1))) [(and (= (+ start-pos 1) end-pos)
(para-loop (add1 curr-para)))))) snip-after
(end-edit-sequence) (is-a? snip-after cb:comment-box-snip%))
(extract-contents start-pos snip-after)]
[else
(let* ([last-pos (last-position)]
[first-para (position-paragraph start-pos)]
[last-para (calc-last-para end-pos)])
(let para-loop ([curr-para first-para])
(if (<= curr-para last-para)
(let ([first-on-para
(paren:skip-whitespace
this
(paragraph-start-position curr-para)
'forward)])
(when (and (< first-on-para last-pos)
(char=? #\; (get-character first-on-para)))
(delete first-on-para (+ first-on-para 1)))
(para-loop (add1 curr-para))))))])
(end-edit-sequence))
#t)) #t))
;; extract-contents : number (is-a?/c cb: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)
(let ([editor (send snip get-editor)])
(let loop ([snip (send editor find-snip (send editor last-position) 'before-or-none)])
(cond
[snip
(insert (send snip copy) pos)
(loop (send snip previous))]
[else (void)]))
(let ([snip-pos (get-snip-position snip)])
(delete snip-pos (+ snip-pos 1)))
(set-position pos pos)))
[define get-forward-sexp [define get-forward-sexp
(lambda (start-pos) (lambda (start-pos)
(scheme-paren:forward-match (scheme-paren:forward-match

11
collects/framework/splash.ss
View File

@ -69,8 +69,11 @@
(define funny? (define funny?
(let ([date (seconds->date (current-seconds))]) (let ([date (seconds->date (current-seconds))])
(and (= (date-day date) 25) (and (with-handlers ([not-break-exn? (lambda (x) #f)])
(= (date-month date) 12)))) (collection-path "icons")
#t)
(= (date-day date) 25)
(= (date-month date) 12))))
(define (splash-load-handler old-load f expected) (define (splash-load-handler old-load f expected)
(let ([finalf (splitup-path f)]) (let ([finalf (splitup-path f)])
@ -89,8 +92,8 @@
(inherit get-dc min-width min-height stretchable-width stretchable-height) (inherit get-dc min-width min-height stretchable-width stretchable-height)
(field (field
[funny-value 0] [funny-value 0]
[funny-bitmap (make-object bitmap% [funny-bitmap
(build-path (collection-path "icons") "touch.bmp"))] (make-object bitmap% (build-path (collection-path "icons") "touch.bmp"))]
[max-value 1]) [max-value 1])
[define/public set-range (lambda (r) (set! max-value r))] [define/public set-range (lambda (r) (set! max-value r))]

16
collects/hierlist/hierlist-unit.ss
View File

@ -21,10 +21,18 @@
(define black-xor (make-object brush% "BLACK" 'xor)) (define black-xor (make-object brush% "BLACK" 'xor))
(define arrow-cursor (make-object cursor% 'arrow)) (define arrow-cursor (make-object cursor% 'arrow))
(define up-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-up.gif"))) (define-values (up-bitmap down-bitmap up-click-bitmap down-click-bitmap)
(define down-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-down.gif"))) (with-handlers ([not-break-exn? (lambda (x)
(define up-click-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-up-click.gif"))) (values
(define down-click-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-down-click.gif"))) (make-object bitmap% 10 10)
(make-object bitmap% 10 10)
(make-object bitmap% 10 10)
(make-object bitmap% 10 10)))])
(values
(make-object bitmap% (build-path (collection-path "icons") "turn-up.gif"))
(make-object bitmap% (build-path (collection-path "icons") "turn-down.gif"))
(make-object bitmap% (build-path (collection-path "icons") "turn-up-click.gif"))
(make-object bitmap% (build-path (collection-path "icons") "turn-down-click.gif")))))
;; Hack for implementing auto-wrapping items: ;; Hack for implementing auto-wrapping items:
(define arrow-size 0) (define arrow-size 0)