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

.

Browse Source 
original commit: 76fc48e868652b6922f99550e191c16ab9883000
This commit is contained in:
Robby Findler 2005-01-23 21:04:41 +00:00
parent a612b0834d
commit 57b4aee87d
5 changed files with 186 additions and 192 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

98
collects/drscheme/private/syntax-browser.ss
View File

@ -72,9 +72,18 @@ needed to really make this work:
;; range-ht : hash-table[obj -o> (listof (cons number number))] ;; range-ht : hash-table[obj -o> (listof (cons number number))]
(define range-ht (make-hash-table)) (define range-ht (make-hash-table))
(define (range-pretty-print-pre-hook x v)
(hash-table-put! range-start-ht x (send output-text last-position))) (define/private (make-modern text)
(define (range-pretty-print-post-hook x port) (send text change-style
(make-object style-delta% 'change-family 'modern)
0
(send text last-position)))
(let ([range-pretty-print-pre-hook
(lambda (x v)
(hash-table-put! range-start-ht x (send output-text last-position)))]
[range-pretty-print-post-hook
(lambda (x port)
(let ([range-start (hash-table-get range-start-ht x (lambda () #f))]) (let ([range-start (hash-table-get range-start-ht x (lambda () #f))])
(when range-start (when range-start
(hash-table-put! range-ht x (hash-table-put! range-ht x
@ -82,36 +91,15 @@ needed to really make this work:
(cons (cons
range-start range-start
(send output-text last-position)) (send output-text last-position))
(hash-table-get range-ht x (lambda () null))))))) (hash-table-get range-ht x (lambda () null)))))))])
(parameterize ([current-output-port output-port]
(define (make-modern text)
(send text change-style
(make-object style-delta% 'change-family 'modern)
0
(send text last-position)))
(define dummy
(begin (parameterize ([current-output-port output-port]
[pretty-print-pre-print-hook range-pretty-print-pre-hook] [pretty-print-pre-print-hook range-pretty-print-pre-hook]
[pretty-print-post-print-hook range-pretty-print-post-hook] [pretty-print-post-print-hook range-pretty-print-post-hook]
[pretty-print-columns 30]) [pretty-print-columns 30])
(pretty-print datum)) (pretty-print datum)
(make-modern output-text))) (make-modern output-text)))
(define ranges (define/private (show-info stx)
(quicksort
(apply append
(hash-table-map
range-ht
(lambda (k vs)
(map
(lambda (v) (make-range k (car v) (cdr v)))
vs))))
(lambda (x y)
(>= (- (range-end x) (range-start x))
(- (range-end y) (range-start y))))))
(define (show-info stx)
(insert/big "General Info\n") (insert/big "General Info\n")
(piece-of-info "Source" (syntax-source stx)) (piece-of-info "Source" (syntax-source stx))
(piece-of-info "Source module" (syntax-source-module stx)) (piece-of-info "Source module" (syntax-source-module stx))
@ -131,7 +119,7 @@ needed to really make this work:
(lambda (prop) (show-property stx prop)) (lambda (prop) (show-property stx prop))
properties)))) properties))))
(define (render-mpi mpi) (define/private (render-mpi mpi)
(string-append (string-append
"#<module-path-index " "#<module-path-index "
(let loop ([mpi mpi]) (let loop ([mpi mpi])
@ -147,10 +135,16 @@ needed to really make this work:
[else (format "~s" mpi)])) [else (format "~s" mpi)]))
">")) ">"))
(define (show-property stx prop) (define/private (show-property stx prop)
(piece-of-info (format "'~a" prop) (syntax-property stx prop))) (piece-of-info (format "'~a" prop) (syntax-property stx prop)))
(define (piece-of-info label info) (define/private (piece-of-info label info)
(let ([small-newline
(lambda (port text)
(let ([before-newline (send text last-position)])
(newline port)
(send info-text change-style small-style before-newline (+ before-newline 1))))])
(insert/bold label) (insert/bold label)
(newline info-port) (newline info-port)
@ -170,23 +164,16 @@ needed to really make this work:
(pretty-print (replace-syntaxes info) info-port)) (pretty-print (replace-syntaxes info) info-port))
(optional-newline) (optional-newline)
(small-newline info-port info-text)) (small-newline info-port info-text)))
(define (small-newline port text) (define/private (replace-syntaxes obj)
(let ([before-newline (send text last-position)])
(newline port)
(send info-text change-style small-style before-newline (+ before-newline 1))))
(define small-style (make-object style-delta% 'change-size 4))
(define (replace-syntaxes obj)
(cond (cond
[(cons? obj) (cons (replace-syntaxes (car obj)) [(cons? obj) (cons (replace-syntaxes (car obj))
(replace-syntaxes (cdr obj)))] (replace-syntaxes (cdr obj)))]
[(syntax? obj) (make-object syntax-snip% obj)] [(syntax? obj) (make-object syntax-snip% obj)]
[else obj])) [else obj]))
(define (insert/bold str) (define/private (insert/bold str)
(let ([pos (send info-text last-position)]) (let ([pos (send info-text last-position)])
(send info-text insert str (send info-text insert str
(send info-text last-position) (send info-text last-position)
@ -196,7 +183,7 @@ needed to really make this work:
pos pos
(send info-text last-position)))) (send info-text last-position))))
(define (insert/big str) (define/private (insert/big str)
(let ([sd (make-object style-delta% 'change-bold)]) (let ([sd (make-object style-delta% 'change-bold)])
(send sd set-delta-foreground "Navy") (send sd set-delta-foreground "Navy")
(let ([pos (send info-text last-position)]) (let ([pos (send info-text last-position)])
@ -208,13 +195,13 @@ needed to really make this work:
pos pos
(send info-text last-position))))) (send info-text last-position)))))
(define (optional-newline) (define/private (optional-newline)
(unless (equal? (unless (equal?
(send info-text get-character (- (send info-text last-position) 1)) (send info-text get-character (- (send info-text last-position) 1))
#\newline) #\newline)
(send info-text insert "\n" (send info-text last-position)))) (send info-text insert "\n" (send info-text last-position))))
(define (show-range stx start end) (define/private (show-range stx start end)
(send output-text begin-edit-sequence) (send output-text begin-edit-sequence)
(send output-text lock #f) (send output-text lock #f)
(send output-text change-style black-style-delta 0 (send output-text last-position)) (send output-text change-style black-style-delta 0 (send output-text last-position))
@ -260,7 +247,7 @@ needed to really make this work:
(define details-shown? #t) (define details-shown? #t)
(inherit show-border set-tight-text-fit) (inherit show-border set-tight-text-fit)
(define (hide-details) (define/private (hide-details)
(when details-shown? (when details-shown?
(send outer-t lock #f) (send outer-t lock #f)
(show-border #f) (show-border #f)
@ -270,7 +257,7 @@ needed to really make this work:
(send outer-t lock #t) (send outer-t lock #t)
(set! details-shown? #f))) (set! details-shown? #f)))
(define (show-details) (define/private (show-details)
(unless details-shown? (unless details-shown?
(send outer-t lock #f) (send outer-t lock #f)
(show-border #t) (show-border #t)
@ -284,6 +271,18 @@ needed to really make this work:
(send outer-t lock #t) (send outer-t lock #t)
(set! details-shown? #t))) (set! details-shown? #t)))
(let ([ranges
(quicksort
(apply append
(hash-table-map
range-ht
(lambda (k vs)
(map
(lambda (v) (make-range k (car v) (cdr v)))
vs))))
(lambda (x y)
(>= (- (range-end x) (range-start x))
(- (range-end y) (range-start y)))))])
(for-each (for-each
(lambda (range) (lambda (range)
(let* ([obj (range-obj range)] (let* ([obj (range-obj range)]
@ -296,7 +295,9 @@ needed to really make this work:
(show-range stx start end)))))) (show-range stx start end))))))
ranges) ranges)
(send outer-t insert (make-object turn-snip% hide-details show-details)) (send outer-t insert (new turn-snip%
[on-up (lambda () (hide-details))]
[on-down (lambda () (show-details))]))
(send outer-t insert (format "~s\n" main-stx)) (send outer-t insert (format "~s\n" main-stx))
(send outer-t insert inner-es) (send outer-t insert inner-es)
(make-modern outer-t) (make-modern outer-t)
@ -324,7 +325,7 @@ needed to really make this work:
[obj (hash-table-get stx-ht (range-obj rng) [obj (hash-table-get stx-ht (range-obj rng)
(lambda () (lambda ()
(k (void))))]) (k (void))))])
(show-range obj (range-start rng) (range-end rng)))) (show-range obj (range-start rng) (range-end rng)))))
(send output-text hide-caret #t) (send output-text hide-caret #t)
(send info-text hide-caret #t) (send info-text hide-caret #t)
@ -343,6 +344,7 @@ needed to really make this work:
(define black-style-delta (make-object style-delta% 'change-normal-color)) (define black-style-delta (make-object style-delta% 'change-normal-color))
(define green-style-delta (make-object style-delta%)) (define green-style-delta (make-object style-delta%))
(send green-style-delta set-delta-foreground "forest green") (send green-style-delta set-delta-foreground "forest green")
(define small-style (make-object style-delta% 'change-size 4))
(define turn-snip% (define turn-snip%
(class snip% (class snip%

26
collects/framework/private/group.ss
View File

@ -37,8 +37,7 @@
[define windows-menus null] [define windows-menus null]
;; get-windows-menu : (is-a?/c frame%) -> (union false? (is-a?/c menu%)) ;; get-windows-menu : (is-a?/c frame%) -> (union false? (is-a?/c menu%))
[define get-windows-menu (define/private (get-windows-menu frame)
(lambda (frame)
(let ([menu-bar (send frame get-menu-bar)]) (let ([menu-bar (send frame get-menu-bar)])
(and menu-bar (and menu-bar
(let ([menus (send menu-bar get-items)]) (let ([menus (send menu-bar get-items)])
@ -47,14 +46,12 @@
(send x get-plain-label)) (send x get-plain-label))
x x
#f)) #f))
menus)))))] menus)))))
[define insert-windows-menu (define/private (insert-windows-menu frame)
(lambda (frame)
(let ([menu (get-windows-menu frame)]) (let ([menu (get-windows-menu frame)])
(when menu (when menu
(set! windows-menus (cons menu windows-menus)))))] (set! windows-menus (cons menu windows-menus)))))
[define remove-windows-menu (define/private (remove-windows-menu frame)
(lambda (frame)
(let ([menu (get-windows-menu frame)]) (let ([menu (get-windows-menu frame)])
(when menu (when menu
@ -65,9 +62,9 @@
(remove (remove
menu menu
windows-menus windows-menus
eq?)))))] eq?)))))
[define (update-windows-menus) (define/private (update-windows-menus)
(let* ([windows (length windows-menus)] (let* ([windows (length windows-menus)]
[default-name (string-constant untitled)] [default-name (string-constant untitled)]
[get-name [get-name
@ -113,17 +110,16 @@
(lambda (_1 _2) (lambda (_1 _2)
(send frame show #t))))) (send frame show #t)))))
sorted/visible-frames)) sorted/visible-frames))
windows-menus))] windows-menus)))
;; most-recent-window-to-front : -> void? ;; most-recent-window-to-front : -> void?
;; brings the most recent window to the front ;; brings the most recent window to the front
(define (most-recent-window-to-front) (define/private (most-recent-window-to-front)
(let ([most-recent-window (weak-box-value most-recent-window-box)]) (let ([most-recent-window (weak-box-value most-recent-window-box)])
(when most-recent-window (when most-recent-window
(send most-recent-window show #t)))) (send most-recent-window show #t))))
[define update-close-menu-item-state (define/private (update-close-menu-item-state)
(lambda ()
(let* ([set-close-menu-item-state! (let* ([set-close-menu-item-state!
(lambda (frame state) (lambda (frame state)
(when (is-a? frame frame:standard-menus<%>) (when (is-a? frame frame:standard-menus<%>)
@ -134,7 +130,7 @@
(set-close-menu-item-state! (car frames) #f) (set-close-menu-item-state! (car frames) #f)
(for-each (lambda (a-frame) (for-each (lambda (a-frame)
(set-close-menu-item-state! a-frame #t)) (set-close-menu-item-state! a-frame #t))
frames))))] frames))))
(field [open-here-frame #f]) (field [open-here-frame #f])
(define/public (set-open-here-frame fr) (set! open-here-frame fr)) (define/public (set-open-here-frame fr) (set! open-here-frame fr))

11
collects/framework/private/panel.ss
View File

@ -130,10 +130,7 @@
(lambda () (lambda ()
horizontal-panel%)] horizontal-panel%)]
(public split-vertically split-horizontally) (define/private (split p%)
[define split
(lambda (p%)
(let ([canvas (send (send parent get-top-level-window) get-edit-target-window)] (let ([canvas (send (send parent get-top-level-window) get-edit-target-window)]
[ec% (get-editor-canvas%)]) [ec% (get-editor-canvas%)])
(when (and canvas (when (and canvas
@ -143,11 +140,11 @@
(send p change-children (lambda (x) null)) (send p change-children (lambda (x) null))
(let ([pc (make-object p% p)]) (let ([pc (make-object p% p)])
(send (make-object ec% (make-object vertical-panel% pc) editor) focus) (send (make-object ec% (make-object vertical-panel% pc) editor) focus)
(make-object ec% (make-object vertical-panel% pc) editor))))))] (make-object ec% (make-object vertical-panel% pc) editor))))))
[define split-vertically [define/public split-vertically
(lambda () (lambda ()
(split (get-vertical%)))] (split (get-vertical%)))]
[define split-horizontally [define/public split-horizontally
(lambda () (lambda ()
(split (get-horizontal%)))] (split (get-horizontal%)))]

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

@ -862,8 +862,7 @@
(bell)) (bell))
#t))] #t))]
[define select-text (define/private (select-text f forward?)
(lambda (f forward?)
(let* ([start-pos (get-start-position)] (let* ([start-pos (get-start-position)]
[end-pos (get-end-position)]) [end-pos (get-end-position)])
(let-values ([(new-start new-end) (let-values ([(new-start new-end)
@ -873,7 +872,7 @@
(if (and new-start new-end) (if (and new-start new-end)
(set-position new-start new-end) (set-position new-start new-end)
(bell)) (bell))
#t)))] #t)))
(public select-forward-sexp select-backward-sexp select-up-sexp select-down-sexp (public select-forward-sexp select-backward-sexp select-up-sexp select-down-sexp
transpose-sexp mark-matching-parenthesis) transpose-sexp mark-matching-parenthesis)

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

@ -78,7 +78,7 @@ WARNING: printf is rebound in the body of the unit to always
(define/public (get-fixed-style) (define/public (get-fixed-style)
(send (get-style-list) find-named-style "Standard")) (send (get-style-list) find-named-style "Standard"))
(define (invalidate-rectangles rectangles) (define/private (invalidate-rectangles rectangles)
(let ([b1 (box 0)] (let ([b1 (box 0)]
[b2 (box 0)] [b2 (box 0)]
[b3 (box 0)] [b3 (box 0)]
@ -163,7 +163,7 @@ WARNING: printf is rebound in the body of the unit to always
this-bottom this-bottom
(cdr rectangles))))])))))) (cdr rectangles))))]))))))
(define (recompute-range-rectangles) (define/private (recompute-range-rectangles)
(let* ([b1 (box 0)] (let* ([b1 (box 0)]
[b2 (box 0)] [b2 (box 0)]
[new-rectangles [new-rectangles
@ -512,7 +512,7 @@ WARNING: printf is rebound in the body of the unit to always
(super insert s len pos)) (super insert s len pos))
;; for-each/sections : string -> dc number number -> void ;; for-each/sections : string -> dc number number -> void
(define (for-each/sections str) (define/private (for-each/sections str)
(let loop ([n (string-length str)] (let loop ([n (string-length str)]
[len 0] [len 0]
[blank? #t]) [blank? #t])
@ -751,7 +751,7 @@ WARNING: printf is rebound in the body of the unit to always
(mixin (editor:keymap<%> basic<%>) (info<%>) (mixin (editor:keymap<%> basic<%>) (info<%>)
(inherit get-start-position get-end-position get-canvas (inherit get-start-position get-end-position get-canvas
run-after-edit-sequence) run-after-edit-sequence)
(define (enqueue-for-frame call-method tag) (define/private (enqueue-for-frame call-method tag)
(run-after-edit-sequence (run-after-edit-sequence
(rec from-enqueue-for-frame (rec from-enqueue-for-frame
(lambda () (lambda ()
@ -760,7 +760,7 @@ WARNING: printf is rebound in the body of the unit to always
;; call-with-frame : ((is-a?/c frame:text-info<%>) -> void) -> void ;; call-with-frame : ((is-a?/c frame:text-info<%>) -> void) -> void
;; calls the argument thunk with the frame showing this editor. ;; calls the argument thunk with the frame showing this editor.
(define (call-with-frame call-method) (define/private (call-with-frame call-method)
(let ([canvas (get-canvas)]) (let ([canvas (get-canvas)])
(when canvas (when canvas
(let ([frame (send canvas get-top-level-window)]) (let ([frame (send canvas get-top-level-window)])
@ -810,7 +810,7 @@ WARNING: printf is rebound in the body of the unit to always
(define clever-file-format-mixin (define clever-file-format-mixin
(mixin ((class->interface text%)) (clever-file-format<%>) (mixin ((class->interface text%)) (clever-file-format<%>)
(inherit get-file-format set-file-format find-first-snip) (inherit get-file-format set-file-format find-first-snip)
(define (all-string-snips) (define/private (all-string-snips)
(let loop ([s (find-first-snip)]) (let loop ([s (find-first-snip)])
(cond (cond
[(not s) #t] [(not s) #t]
@ -1640,7 +1640,7 @@ WARNING: printf is rebound in the body of the unit to always
[else (void)]))) [else (void)])))
;; dequeue-n : queue number -> queue ;; dequeue-n : queue number -> queue
(define (dequeue-n queue n) (define/private (dequeue-n queue n)
(let loop ([q queue] (let loop ([q queue]
[n n]) [n n])
(cond (cond
@ -1649,7 +1649,7 @@ WARNING: printf is rebound in the body of the unit to always
[else (loop (queue-rest q) (- n 1))]))) [else (loop (queue-rest q) (- n 1))])))
;; peek-n : queue number -> queue ;; peek-n : queue number -> queue
(define (peek-n queue init-n) (define/private (peek-n queue init-n)
(let loop ([q queue] (let loop ([q queue]
[n init-n]) [n init-n])
(cond (cond