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 "list.ss")
(lib "file.ss")
(lib "etc.ss"))
(lib "etc.ss")
(prefix cb: "../comment-snip.ss"))
(provide frame@)
@ -31,7 +32,8 @@
[pasteboard : framework:pasteboard^]
[editor : framework:editor^]
[canvas : framework:canvas^]
[menu : framework:menu^])
[menu : framework:menu^]
[scheme : framework:scheme^])
(rename [-editor<%> editor<%>]
[-pasteboard% pasteboard%]
@ -91,10 +93,25 @@
[on-demand
(lambda (menu-item)
(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%)])
;; 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 set-caret-owner snip 'global)))))])
(make-object c% (string-constant insert-text-box-item)
edit-menu (edit-menu:do 'insert-text-box) #f #f on-demand)
(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)
edit-menu (edit-menu:do 'insert-image) #f #f on-demand)
(void)))
@ -1934,7 +1951,10 @@
(define memory-text% (class100 text% args (sequence (apply super-init args))))
(define memory-text (make-object memory-text%))
(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-mixin

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

@ -12,7 +12,11 @@
(import mred^)
(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")))
(define (load-icon name type)
@ -22,8 +26,6 @@
(let ([bitmap (make-object bitmap% p type)])
(set! f (lambda () bitmap))
bitmap))])
(unless (file-exists? p)
(fprintf (current-error-port) "WARNING: couldn't find ~a~n" p))
(lambda ()
(f))))
@ -34,8 +36,6 @@
(let ([bitmap (make-object bitmap% p type)])
(set! f (lambda () bitmap))
bitmap))])
(unless (file-exists? p)
(fprintf (current-error-port) "WARNING: couldn't find ~a~n" p))
(lambda ()
(f))))
@ -49,8 +49,6 @@
(define (make-get/mask filename type)
(let ([icon #f]
[p (build-path icon-path filename)])
(unless (file-exists? p)
(fprintf (current-error-port) "WARNING: couldn't find ~a~n" p))
(lambda ()
(or icon
(begin
@ -58,8 +56,8 @@
icon)))))
(define (make-cursor name mask fallback)
(let* ([msk-b (make-object bitmap% (build-path (collection-path "icons") mask))]
[csr-b (make-object bitmap% (build-path (collection-path "icons") name))])
(let* ([msk-b (make-object bitmap% (build-path icon-path mask))]
[csr-b (make-object bitmap% (build-path icon-path name))])
(if (and (send msk-b ok?)
(send csr-b ok?))
(let ([csr (make-object cursor% msk-b csr-b 7 7)])

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

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

11
collects/framework/splash.ss
View File

@ -69,8 +69,11 @@
(define funny?
(let ([date (seconds->date (current-seconds))])
(and (= (date-day date) 25)
(= (date-month date) 12))))
(and (with-handlers ([not-break-exn? (lambda (x) #f)])
(collection-path "icons")
#t)
(= (date-day date) 25)
(= (date-month date) 12))))
(define (splash-load-handler old-load f expected)
(let ([finalf (splitup-path f)])
@ -89,8 +92,8 @@
(inherit get-dc min-width min-height stretchable-width stretchable-height)
(field
[funny-value 0]
[funny-bitmap (make-object bitmap%
(build-path (collection-path "icons") "touch.bmp"))]
[funny-bitmap
(make-object bitmap% (build-path (collection-path "icons") "touch.bmp"))]
[max-value 1])
[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 arrow-cursor (make-object cursor% 'arrow))
(define up-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-up.gif")))
(define down-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-down.gif")))
(define up-click-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-up-click.gif")))
(define down-click-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-down-click.gif")))
(define-values (up-bitmap down-bitmap up-click-bitmap down-click-bitmap)
(with-handlers ([not-break-exn? (lambda (x)
(values
(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:
(define arrow-size 0)