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

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

@ -72,46 +72,34 @@ 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 (range-pretty-print-post-hook x port)
(let ([range-start (hash-table-get range-start-ht x (lambda () #f))])
(when range-start
(hash-table-put! range-ht x
(cons
(cons
range-start
(send output-text last-position))
(hash-table-get range-ht x (lambda () null)))))))
(define (make-modern text) (define/private (make-modern text)
(send text change-style (send text change-style
(make-object style-delta% 'change-family 'modern) (make-object style-delta% 'change-family 'modern)
0 0
(send text last-position))) (send text last-position)))
(define dummy (let ([range-pretty-print-pre-hook
(begin (parameterize ([current-output-port output-port] (lambda (x v)
[pretty-print-pre-print-hook range-pretty-print-pre-hook] (hash-table-put! range-start-ht x (send output-text last-position)))]
[pretty-print-post-print-hook range-pretty-print-post-hook] [range-pretty-print-post-hook
[pretty-print-columns 30]) (lambda (x port)
(pretty-print datum)) (let ([range-start (hash-table-get range-start-ht x (lambda () #f))])
(make-modern output-text))) (when range-start
(hash-table-put! range-ht x
(cons
(cons
range-start
(send output-text last-position))
(hash-table-get range-ht x (lambda () null)))))))])
(parameterize ([current-output-port output-port]
[pretty-print-pre-print-hook range-pretty-print-pre-hook]
[pretty-print-post-print-hook range-pretty-print-post-hook]
[pretty-print-columns 30])
(pretty-print datum)
(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,46 +135,45 @@ 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)
(insert/bold label) (let ([small-newline
(newline info-port) (lambda (port text)
(let ([before-newline (send text last-position)])
(newline port)
(send info-text change-style small-style before-newline (+ before-newline 1))))])
;; should just be using generic `print' (insert/bold label)
;; but won't work without built-in support for (newline info-port)
;; editors as output ports
(parameterize ([pretty-print-size-hook
(lambda (val d/p port)
(if (is-a? val syntax-snip%)
(+ (string-length (format "~a" (send val get-syntax))) 2)
#f))]
[pretty-print-print-hook
(lambda (val d/p port)
(send info-text insert (send val copy)
(send info-text last-position)
(send info-text last-position)))])
(pretty-print (replace-syntaxes info) info-port))
(optional-newline) ;; should just be using generic `print'
(small-newline info-port info-text)) ;; but won't work without built-in support for
;; editors as output ports
(parameterize ([pretty-print-size-hook
(lambda (val d/p port)
(if (is-a? val syntax-snip%)
(+ (string-length (format "~a" (send val get-syntax))) 2)
#f))]
[pretty-print-print-hook
(lambda (val d/p port)
(send info-text insert (send val copy)
(send info-text last-position)
(send info-text last-position)))])
(pretty-print (replace-syntaxes info) info-port))
(define (small-newline port text) (optional-newline)
(let ([before-newline (send text last-position)]) (small-newline info-port info-text)))
(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/private (replace-syntaxes obj)
(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,47 +271,61 @@ needed to really make this work:
(send outer-t lock #t) (send outer-t lock #t)
(set! details-shown? #t))) (set! details-shown? #t)))
(for-each (let ([ranges
(lambda (range) (quicksort
(let* ([obj (range-obj range)] (apply append
[stx (hash-table-get stx-ht obj (lambda () #f))] (hash-table-map
[start (range-start range)] range-ht
[end (range-end range)]) (lambda (k vs)
(when (syntax? stx) (map
(send output-text set-clickback start end (lambda (v) (make-range k (car v) (cdr v)))
(lambda (_1 _2 _3) vs))))
(show-range stx start end)))))) (lambda (x y)
ranges) (>= (- (range-end x) (range-start x))
(- (range-end y) (range-start y)))))])
(for-each
(lambda (range)
(let* ([obj (range-obj range)]
[stx (hash-table-get stx-ht obj (lambda () #f))]
[start (range-start range)]
[end (range-end range)])
(when (syntax? stx)
(send output-text set-clickback start end
(lambda (_1 _2 _3)
(show-range stx start end))))))
ranges)
(send outer-t insert (make-object turn-snip% hide-details show-details)) (send outer-t insert (new turn-snip%
(send outer-t insert (format "~s\n" main-stx)) [on-up (lambda () (hide-details))]
(send outer-t insert inner-es) [on-down (lambda () (show-details))]))
(make-modern outer-t) (send outer-t insert (format "~s\n" main-stx))
(send outer-t insert inner-es)
(make-modern outer-t)
(send inner-t insert (instantiate editor-snip% () (send inner-t insert (instantiate editor-snip% ()
(editor output-text) (editor output-text)
(with-border? #f) (with-border? #f)
(left-margin 0) (left-margin 0)
(top-margin 0) (top-margin 0)
(right-margin 0) (right-margin 0)
(bottom-margin 0) (bottom-margin 0)
(left-inset 0) (left-inset 0)
(top-inset 0) (top-inset 0)
(right-inset 0) (right-inset 0)
(bottom-inset 0))) (bottom-inset 0)))
(send inner-t insert (make-object editor-snip% info-text)) (send inner-t insert (make-object editor-snip% info-text))
(send inner-t change-style (make-object style-delta% 'change-alignment 'top) 0 2) (send inner-t change-style (make-object style-delta% 'change-alignment 'top) 0 2)
(send info-text auto-wrap #t) (send info-text auto-wrap #t)
(send info-text set-styles-sticky #f) (send info-text set-styles-sticky #f)
(let/ec k (let/ec k
(when (null? ranges) (when (null? ranges)
(k (void))) (k (void)))
(let* ([rng (car ranges)] (let* ([rng (car ranges)]
[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%

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

@ -37,37 +37,34 @@
[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)]) (ormap (lambda (x)
(ormap (lambda (x) (if (string=? (string-constant windows-menu)
(if (string=? (string-constant windows-menu) (send x get-plain-label))
(send x get-plain-label)) x
x #f))
#f)) menus)))))
menus)))))] (define/private (insert-windows-menu frame)
[define insert-windows-menu (let ([menu (get-windows-menu frame)])
(lambda (frame) (when menu
(let ([menu (get-windows-menu frame)]) (set! windows-menus (cons menu windows-menus)))))
(when menu (define/private (remove-windows-menu frame)
(set! windows-menus (cons menu windows-menus)))))] (let ([menu (get-windows-menu frame)])
[define remove-windows-menu
(lambda (frame)
(let ([menu (get-windows-menu frame)])
(when menu (when menu
;; to help the (conservative) gc. ;; to help the (conservative) gc.
(for-each (lambda (i) (send i delete)) (send menu get-items)) (for-each (lambda (i) (send i delete)) (send menu get-items))
(set! windows-menus (set! windows-menus
(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,28 +110,27 @@
(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<%>) (let ([close-menu-item (send frame file-menu:get-close-menu)])
(let ([close-menu-item (send frame file-menu:get-close-menu)]) (when close-menu-item
(when close-menu-item (send close-menu-item enable state)))))])
(send close-menu-item enable state)))))]) (if (eq? (length frames) 1)
(if (eq? (length frames) 1) (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))

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

@ -130,24 +130,21 @@
(lambda () (lambda ()
horizontal-panel%)] horizontal-panel%)]
(public split-vertically split-horizontally) (define/private (split p%)
(let ([canvas (send (send parent get-top-level-window) get-edit-target-window)]
[define split [ec% (get-editor-canvas%)])
(lambda (p%) (when (and canvas
(let ([canvas (send (send parent get-top-level-window) get-edit-target-window)] (is-a? canvas ec%)
[ec% (get-editor-canvas%)]) (eq? (send canvas get-editor) editor))
(when (and canvas (let ([p (send canvas get-parent)])
(is-a? canvas ec%) (send p change-children (lambda (x) null))
(eq? (send canvas get-editor) editor)) (let ([pc (make-object p% p)])
(let ([p (send canvas get-parent)]) (send (make-object ec% (make-object vertical-panel% pc) editor) focus)
(send p change-children (lambda (x) null)) (make-object ec% (make-object vertical-panel% pc) editor))))))
(let ([pc (make-object p% p)]) [define/public split-vertically
(send (make-object ec% (make-object vertical-panel% pc) editor) focus)
(make-object ec% (make-object vertical-panel% pc) editor))))))]
[define 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%)))]

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

@ -862,18 +862,17 @@
(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) (if forward?
(if forward? (values start-pos (f end-pos))
(values start-pos (f end-pos)) (values (f start-pos) end-pos))])
(values (f start-pos) end-pos))]) (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