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

.

Browse Source 
original commit: e1792d105641c2c4c99b357d1eb77931bb33312c
This commit is contained in:
Matthew Flatt 2001-03-15 03:20:11 +00:00
parent 52b89ccaf4
commit 10de29235b
3 changed files with 164 additions and 152 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2,6 +2,7 @@
(module hierlist-unit mzscheme (module hierlist-unit mzscheme
(require (lib "unitsig.ss") (require (lib "unitsig.ss")
(lib "class.ss") (lib "class.ss")
(lib "class100.ss")
(lib "mred-sig.ss" "mred") (lib "mred-sig.ss" "mred")
"hierlist-sig.ss") "hierlist-sig.ss")
@ -27,7 +28,7 @@
(define arrow-snip-class (make-object snip-class%)) (define arrow-snip-class (make-object snip-class%))
(send arrow-snip-class set-classname "hier-arrow") (send arrow-snip-class set-classname "hier-arrow")
(define arrow-snip% (define arrow-snip%
(class snip% (click-callback) (class100 snip% (callback)
(inherit get-admin set-flags get-flags set-count set-snipclass get-style) (inherit get-admin set-flags get-flags set-count set-snipclass get-style)
(rename [super-get-extent get-extent]) (rename [super-get-extent get-extent])
(private (private
@ -61,6 +62,7 @@
(private (private
[get-width (lambda () (+ 2 size))] [get-width (lambda () (+ 2 size))]
[get-height (lambda () (+ 2 size))] [get-height (lambda () (+ 2 size))]
[click-callback callback]
[clicked? #f] [clicked? #f]
[update [update
(lambda () (lambda ()
@ -131,11 +133,11 @@
;; Hack to get whitespace matching width of arrow: derive a new ;; Hack to get whitespace matching width of arrow: derive a new
;; class that overrides the `draw' method to do nothing. ;; class that overrides the `draw' method to do nothing.
(define whitespace-snip% (define whitespace-snip%
(class arrow-snip% () (class100 arrow-snip% ()
(override [draw void]) (override [draw (lambda (dc x y left top right bottom dx dy draw-caret) (void))])
(sequence (super-init void)))) (sequence (super-init void))))
; Keymap to map clicks and double-clicks ;; Keymap to map clicks and double-clicks
(define item-keymap (make-object keymap%)) (define item-keymap (make-object keymap%))
(send item-keymap add-function "mouse-select" (send item-keymap add-function "mouse-select"
@ -155,8 +157,9 @@
get-editor is-selected? select user-data)) get-editor is-selected? select user-data))
(define hierarchical-list-item% (define hierarchical-list-item%
(class* object% (hierarchical-list-item<%>) (snip) (class100* object% (hierarchical-list-item<%>) (snp)
(private (private
[snip snp]
[data #f]) [data #f])
(public (public
[get-editor (lambda () (send snip get-item-buffer))] [get-editor (lambda () (send snip get-item-buffer))]
@ -178,7 +181,8 @@
new-item new-list delete-item get-items)) new-item new-list delete-item get-items))
(define hierarchical-list-compound-item% (define hierarchical-list-compound-item%
(class* hierarchical-list-item% (hierarchical-list-compound-item<%>) (snip) (class100* hierarchical-list-item% (hierarchical-list-compound-item<%>) (snp)
(private [snip snp])
(override (override
[get-editor (lambda () (send snip get-title-buffer))]) [get-editor (lambda () (send snip get-title-buffer))])
(public (public
@ -197,12 +201,12 @@
[new-item [new-item
(lambda x (lambda x
(begin0 (begin0
(apply (ivar (send snip get-content-buffer) new-item) x) (send (send snip get-content-buffer) new-item . x)
(send snip not-empty-anymore)))] (send snip not-empty-anymore)))]
[new-list [new-list
(lambda x (lambda x
(begin0 (begin0
(apply (ivar (send snip get-content-buffer) new-list) x) (send (send snip get-content-buffer) new-list . x)
(send snip not-empty-anymore)))] (send snip not-empty-anymore)))]
[delete-item (lambda (i) (begin0 [delete-item (lambda (i) (begin0
(send (send snip get-content-buffer) delete-item i) (send (send snip get-content-buffer) delete-item i)
@ -213,7 +217,7 @@
;; Buffer for a single list item ;; Buffer for a single list item
(define hierarchical-item-text% (define hierarchical-item-text%
(class text% (top top-select item snip depth) (class100 text% (tp tp-select itm snp dpth)
(inherit set-max-undo-history hide-caret (inherit set-max-undo-history hide-caret
last-position set-position set-keymap last-position set-position set-keymap
invalidate-bitmap-cache set-max-width invalidate-bitmap-cache set-max-width
@ -221,6 +225,11 @@
(rename [super-auto-wrap auto-wrap] (rename [super-auto-wrap auto-wrap]
[super-on-default-event on-default-event]) [super-on-default-event on-default-event])
(private (private
[top tp]
[top-select tp-select]
[item itm]
[snip snp]
[depth dpth]
[selected? #f]) [selected? #f])
(public (public
[is-selected? (lambda () selected?)] [is-selected? (lambda () selected?)]
@ -267,7 +276,7 @@
[double-select (lambda () (send top on-double-select item))] [double-select (lambda () (send top on-double-select item))]
[select-prev (lambda () (send top select-prev))]) [select-prev (lambda () (send top select-prev))])
(override (override
[on-default-char void]) [on-default-char (lambda (x) (void))])
(sequence (sequence
(super-init) (super-init)
(hide-caret #t) (hide-caret #t)
@ -276,11 +285,12 @@
;; Buffer for a compound list item (and the top-level list) ;; Buffer for a compound list item (and the top-level list)
(define (make-hierarchical-list-text% super%) (define (make-hierarchical-list-text% super%)
(class super% (top top-select depth parent-snip) (class100 super% (top top-select depth parent-snp)
(inherit set-max-undo-history hide-caret erase (inherit set-max-undo-history hide-caret erase
last-position insert delete line-start-position line-end-position last-position insert delete line-start-position line-end-position
begin-edit-sequence end-edit-sequence get-style-list) begin-edit-sequence end-edit-sequence get-style-list)
(private (private
[parent-snip parent-snp]
[children null] [children null]
[make-whitespace (lambda () (make-object whitespace-snip%))] [make-whitespace (lambda () (make-object whitespace-snip%))]
[insert-item [insert-item
@ -351,8 +361,8 @@
(send c reflow-item)) (send c reflow-item))
children))]) children))])
(override (override
[on-default-char void] [on-default-char (lambda (x) (void))]
[on-default-event void]) [on-default-event (lambda (x) (void))])
(sequence (sequence
(super-init) (super-init)
(hide-caret #t) (hide-caret #t)
@ -362,7 +372,8 @@
;; Snip for a single list item ;; Snip for a single list item
(define hierarchical-item-snip% (define hierarchical-item-snip%
(class editor-snip% (parent top top-select depth mixin) (class100 editor-snip% (prnt top top-select depth mixin)
(private [parent prnt])
(public (public
[get-parent (lambda () parent)] [get-parent (lambda () parent)]
[get-item-text% (lambda () hierarchical-item-text%)] [get-item-text% (lambda () hierarchical-item-text%)]
@ -382,13 +393,14 @@
;; Snip for a compound list item ;; Snip for a compound list item
(define hierarchical-list-snip% (define hierarchical-list-snip%
(class editor-snip% (parent top top-select depth mixin [title #f][content #f]) (class100 editor-snip% (prnt top top-select depth mixin [title #f][content #f])
(private [parent prnt])
(public (public
[get-parent (lambda () parent)] [get-parent (lambda () parent)]
[get-main-text% (lambda () (class text% args [get-main-text% (lambda () (class100 text% args
(override (override
[on-default-char void] [on-default-char (lambda (x) (void))]
[on-default-event void]) [on-default-event (lambda (x) (void))])
(sequence (sequence
(apply super-init args))))] (apply super-init args))))]
[get-title-text% (lambda () hierarchical-item-text%)] [get-title-text% (lambda () hierarchical-item-text%)]
@ -478,7 +490,7 @@
[content-buffer (make-object (get-content-text%) top top-select depth this)] [content-buffer (make-object (get-content-text%) top top-select depth this)]
[title-snip (make-object editor-snip% title-buffer #f 0 0 0 0 0 0 0 0)] [title-snip (make-object editor-snip% title-buffer #f 0 0 0 0 0 0 0 0)]
[content-snip (make-object editor-snip% content-buffer #f 4 0 0 0 0 0 0 0)] [content-snip (make-object editor-snip% content-buffer #f 4 0 0 0 0 0 0 0)]
[arrow (make-object (get-arrow-snip%) on-arrow)] [arrow (make-object (get-arrow-snip%) (lambda (a) (on-arrow a)))]
[whitespace (make-object whitespace-snip%)]) [whitespace (make-object whitespace-snip%)])
(sequence (sequence
(super-init main-buffer #f 0 0 0 0 0 0 0 0) (super-init main-buffer #f 0 0 0 0 0 0 0 0)
@ -523,7 +535,7 @@
(send list-keymap map-function "return" "toggle-open/closed") (send list-keymap map-function "return" "toggle-open/closed")
(define hierarchical-list% (define hierarchical-list%
(class editor-canvas% (parent) (class100 editor-canvas% (parent)
(inherit min-width min-height) (inherit min-width min-height)
(rename [super-on-char on-char] (rename [super-on-char on-char]
[super-on-focus on-focus]) [super-on-focus on-focus])
@ -533,12 +545,12 @@
[() selectable?] [() selectable?]
[(on?) (set! selectable? on?)])] [(on?) (set! selectable? on?)])]
[get-selected (lambda () selected-item)] [get-selected (lambda () selected-item)]
[on-item-opened void] [on-item-opened (lambda (i) (void))]
[on-item-closed void] [on-item-closed (lambda (i) (void))]
[on-double-select void] [on-double-select (lambda (i) (void))]
[on-select void] [on-select (lambda (i) (void))]
[new-item (lambda x (apply (ivar top-buffer new-item) x))] [new-item (lambda x (send top-buffer new-item . x))]
[new-list (lambda x (apply (ivar top-buffer new-list) x))] [new-list (lambda x (send top-buffer new-list . x))]
[delete-item (lambda (i) (send top-buffer delete-item i))] [delete-item (lambda (i) (send top-buffer delete-item i))]
[sort (lambda (less-than?) (send top-buffer sort less-than?))] [sort (lambda (less-than?) (send top-buffer sort less-than?))]
[get-items (lambda () (send top-buffer get-items))] [get-items (lambda () (send top-buffer get-items))]

6
collects/mred/mred.ss
View File

@ -1,6 +1,6 @@
(module mred mzscheme (module mred mzscheme
(require (prefix wx: (lib "kernel.ss" "mred" "private"))) (require (prefix wx: (lib "kernel.ss" "mred" "private")))
(require (lib "class2.ss") (require (lib "class.ss")
(lib "class100.ss")) (lib "class100.ss"))
;;;;;;;;;;;;;;; Constants ;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;; Constants ;;;;;;;;;;;;;;;;;;;;
@ -1884,7 +1884,7 @@
[set-focus (lambda () (void))] [set-focus (lambda () (void))]
[on-size (lambda () (void))] [on-size (lambda () (void))]
[enable (lambda () (void))] [enable (lambda () (void))]
[show (lambda () (void))] [show (lambda (on?) (void))]
[get-parent (lambda () parent)] [get-parent (lambda () parent)]
[get-client-size (lambda (wb hb) [get-client-size (lambda (wb hb)
(when wb (set-box! wb width)) (when wb (set-box! wb width))
@ -2467,7 +2467,7 @@
(lambda (s) (major-offset s)) (lambda (s) (major-offset s))
cadr ; child-info-y-min cadr ; child-info-y-min
cadddr ; child-info-y-stretch cadddr ; child-info-y-stretch
(lambda (s) (minor-offset s)) (lambda (s t) (minor-offset s t))
(lambda (width height) width) (lambda (width height) width)
(lambda (width height) height) (lambda (width height) height)
(lambda (major minor) major) (lambda (major minor) major)

2
collects/mred/private/kernel.ss
View File

@ -2,7 +2,7 @@
;; kernel.ss is generated by xctocc ;; kernel.ss is generated by xctocc
(module kernel mzscheme (module kernel mzscheme
(require (all-except (lib "class2.ss") object%)) (require (all-except (lib "class.ss") object%))
;; Pull pieces out of #%mred-kernel dynamically, so that ;; Pull pieces out of #%mred-kernel dynamically, so that
;; the library compiles with setup-plt in mzscheme. ;; the library compiles with setup-plt in mzscheme.