From 57b4aee87db4e23ddf5fe55d585be2fa066f40f9 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 23 Jan 2005 21:04:41 +0000 Subject: [PATCH] . original commit: 76fc48e868652b6922f99550e191c16ab9883000 --- collects/drscheme/private/syntax-browser.ss | 226 ++++++++++---------- collects/framework/private/group.ss | 84 ++++---- collects/framework/private/panel.ss | 29 ++- collects/framework/private/scheme.ss | 23 +- collects/framework/private/text.ss | 16 +- 5 files changed, 186 insertions(+), 192 deletions(-) diff --git a/collects/drscheme/private/syntax-browser.ss b/collects/drscheme/private/syntax-browser.ss index d1065fe2..41fdcc68 100644 --- a/collects/drscheme/private/syntax-browser.ss +++ b/collects/drscheme/private/syntax-browser.ss @@ -72,46 +72,34 @@ needed to really make this work: ;; range-ht : hash-table[obj -o> (listof (cons number number))] (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 (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-post-print-hook range-pretty-print-post-hook] - [pretty-print-columns 30]) - (pretty-print datum)) - (make-modern output-text))) + (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))]) + (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 - (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) + (define/private (show-info stx) (insert/big "General Info\n") (piece-of-info "Source" (syntax-source 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)) properties)))) - (define (render-mpi mpi) + (define/private (render-mpi mpi) (string-append "#")) - (define (show-property stx prop) + (define/private (show-property stx prop) (piece-of-info (format "'~a" prop) (syntax-property stx prop))) - (define (piece-of-info label info) - (insert/bold label) - (newline info-port) - - ;; should just be using generic `print' - ;; 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)) - - (optional-newline) - (small-newline info-port info-text)) + (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) + (newline info-port) + + ;; should just be using generic `print' + ;; 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)) + + (optional-newline) + (small-newline info-port info-text))) - (define (small-newline port text) - (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) + (define/private (replace-syntaxes obj) (cond [(cons? obj) (cons (replace-syntaxes (car obj)) (replace-syntaxes (cdr obj)))] [(syntax? obj) (make-object syntax-snip% obj)] [else obj])) - (define (insert/bold str) + (define/private (insert/bold str) (let ([pos (send info-text last-position)]) (send info-text insert str (send info-text last-position) @@ -196,7 +183,7 @@ needed to really make this work: pos (send info-text last-position)))) - (define (insert/big str) + (define/private (insert/big str) (let ([sd (make-object style-delta% 'change-bold)]) (send sd set-delta-foreground "Navy") (let ([pos (send info-text last-position)]) @@ -208,13 +195,13 @@ needed to really make this work: pos (send info-text last-position))))) - (define (optional-newline) + (define/private (optional-newline) (unless (equal? (send info-text get-character (- (send info-text last-position) 1)) #\newline) (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 lock #f) (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) (inherit show-border set-tight-text-fit) - (define (hide-details) + (define/private (hide-details) (when details-shown? (send outer-t lock #f) (show-border #f) @@ -270,7 +257,7 @@ needed to really make this work: (send outer-t lock #t) (set! details-shown? #f))) - (define (show-details) + (define/private (show-details) (unless details-shown? (send outer-t lock #f) (show-border #t) @@ -284,47 +271,61 @@ needed to really make this work: (send outer-t lock #t) (set! details-shown? #t))) - (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 (format "~s\n" main-stx)) - (send outer-t insert inner-es) - (make-modern outer-t) - - (send inner-t insert (instantiate editor-snip% () - (editor output-text) - (with-border? #f) - (left-margin 0) - (top-margin 0) - (right-margin 0) - (bottom-margin 0) - (left-inset 0) - (top-inset 0) - (right-inset 0) - (bottom-inset 0))) - (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 info-text auto-wrap #t) - (send info-text set-styles-sticky #f) - (let/ec k - (when (null? ranges) - (k (void))) - (let* ([rng (car ranges)] - [obj (hash-table-get stx-ht (range-obj rng) - (lambda () - (k (void))))]) - (show-range obj (range-start rng) (range-end rng)))) + (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 + (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 (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 inner-es) + (make-modern outer-t) + + (send inner-t insert (instantiate editor-snip% () + (editor output-text) + (with-border? #f) + (left-margin 0) + (top-margin 0) + (right-margin 0) + (bottom-margin 0) + (left-inset 0) + (top-inset 0) + (right-inset 0) + (bottom-inset 0))) + (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 info-text auto-wrap #t) + (send info-text set-styles-sticky #f) + (let/ec k + (when (null? ranges) + (k (void))) + (let* ([rng (car ranges)] + [obj (hash-table-get stx-ht (range-obj rng) + (lambda () + (k (void))))]) + (show-range obj (range-start rng) (range-end rng))))) (send output-text hide-caret #t) (send info-text hide-caret #t) @@ -343,7 +344,8 @@ needed to really make this work: (define black-style-delta (make-object style-delta% 'change-normal-color)) (define green-style-delta (make-object style-delta%)) (send green-style-delta set-delta-foreground "forest green") - + (define small-style (make-object style-delta% 'change-size 4)) + (define turn-snip% (class snip% diff --git a/collects/framework/private/group.ss b/collects/framework/private/group.ss index 7cf521bf..36549620 100644 --- a/collects/framework/private/group.ss +++ b/collects/framework/private/group.ss @@ -37,37 +37,34 @@ [define windows-menus null] ;; get-windows-menu : (is-a?/c frame%) -> (union false? (is-a?/c menu%)) - [define get-windows-menu - (lambda (frame) - (let ([menu-bar (send frame get-menu-bar)]) - (and menu-bar - (let ([menus (send menu-bar get-items)]) - (ormap (lambda (x) - (if (string=? (string-constant windows-menu) - (send x get-plain-label)) - x - #f)) - menus)))))] - [define insert-windows-menu - (lambda (frame) - (let ([menu (get-windows-menu frame)]) - (when menu - (set! windows-menus (cons menu windows-menus)))))] - [define remove-windows-menu - (lambda (frame) - (let ([menu (get-windows-menu frame)]) + (define/private (get-windows-menu frame) + (let ([menu-bar (send frame get-menu-bar)]) + (and menu-bar + (let ([menus (send menu-bar get-items)]) + (ormap (lambda (x) + (if (string=? (string-constant windows-menu) + (send x get-plain-label)) + x + #f)) + menus))))) + (define/private (insert-windows-menu frame) + (let ([menu (get-windows-menu frame)]) + (when menu + (set! windows-menus (cons menu windows-menus))))) + (define/private (remove-windows-menu frame) + (let ([menu (get-windows-menu frame)]) + + (when menu + ;; to help the (conservative) gc. + (for-each (lambda (i) (send i delete)) (send menu get-items)) - (when menu - ;; to help the (conservative) gc. - (for-each (lambda (i) (send i delete)) (send menu get-items)) - - (set! windows-menus - (remove - menu - windows-menus - eq?)))))] + (set! windows-menus + (remove + menu + windows-menus + eq?))))) - [define (update-windows-menus) + (define/private (update-windows-menus) (let* ([windows (length windows-menus)] [default-name (string-constant untitled)] [get-name @@ -113,28 +110,27 @@ (lambda (_1 _2) (send frame show #t))))) sorted/visible-frames)) - windows-menus))] + windows-menus))) ;; most-recent-window-to-front : -> void? ;; 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)]) (when most-recent-window (send most-recent-window show #t)))) - [define update-close-menu-item-state - (lambda () - (let* ([set-close-menu-item-state! - (lambda (frame state) - (when (is-a? frame frame:standard-menus<%>) - (let ([close-menu-item (send frame file-menu:get-close-menu)]) - (when close-menu-item - (send close-menu-item enable state)))))]) - (if (eq? (length frames) 1) - (set-close-menu-item-state! (car frames) #f) - (for-each (lambda (a-frame) - (set-close-menu-item-state! a-frame #t)) - frames))))] + (define/private (update-close-menu-item-state) + (let* ([set-close-menu-item-state! + (lambda (frame state) + (when (is-a? frame frame:standard-menus<%>) + (let ([close-menu-item (send frame file-menu:get-close-menu)]) + (when close-menu-item + (send close-menu-item enable state)))))]) + (if (eq? (length frames) 1) + (set-close-menu-item-state! (car frames) #f) + (for-each (lambda (a-frame) + (set-close-menu-item-state! a-frame #t)) + frames)))) (field [open-here-frame #f]) (define/public (set-open-here-frame fr) (set! open-here-frame fr)) diff --git a/collects/framework/private/panel.ss b/collects/framework/private/panel.ss index fe0b62bc..a488660d 100644 --- a/collects/framework/private/panel.ss +++ b/collects/framework/private/panel.ss @@ -130,24 +130,21 @@ (lambda () horizontal-panel%)] - (public split-vertically split-horizontally) - - [define split - (lambda (p%) - (let ([canvas (send (send parent get-top-level-window) get-edit-target-window)] - [ec% (get-editor-canvas%)]) - (when (and canvas - (is-a? canvas ec%) - (eq? (send canvas get-editor) editor)) - (let ([p (send canvas get-parent)]) - (send p change-children (lambda (x) null)) - (let ([pc (make-object p% p)]) - (send (make-object ec% (make-object vertical-panel% pc) editor) focus) - (make-object ec% (make-object vertical-panel% pc) editor))))))] - [define split-vertically + (define/private (split p%) + (let ([canvas (send (send parent get-top-level-window) get-edit-target-window)] + [ec% (get-editor-canvas%)]) + (when (and canvas + (is-a? canvas ec%) + (eq? (send canvas get-editor) editor)) + (let ([p (send canvas get-parent)]) + (send p change-children (lambda (x) null)) + (let ([pc (make-object p% p)]) + (send (make-object ec% (make-object vertical-panel% pc) editor) focus) + (make-object ec% (make-object vertical-panel% pc) editor)))))) + [define/public split-vertically (lambda () (split (get-vertical%)))] - [define split-horizontally + [define/public split-horizontally (lambda () (split (get-horizontal%)))] diff --git a/collects/framework/private/scheme.ss b/collects/framework/private/scheme.ss index 0c27676c..165182b2 100644 --- a/collects/framework/private/scheme.ss +++ b/collects/framework/private/scheme.ss @@ -862,18 +862,17 @@ (bell)) #t))] - [define select-text - (lambda (f forward?) - (let* ([start-pos (get-start-position)] - [end-pos (get-end-position)]) - (let-values ([(new-start new-end) - (if forward? - (values start-pos (f end-pos)) - (values (f start-pos) end-pos))]) - (if (and new-start new-end) - (set-position new-start new-end) - (bell)) - #t)))] + (define/private (select-text f forward?) + (let* ([start-pos (get-start-position)] + [end-pos (get-end-position)]) + (let-values ([(new-start new-end) + (if forward? + (values start-pos (f end-pos)) + (values (f start-pos) end-pos))]) + (if (and new-start new-end) + (set-position new-start new-end) + (bell)) + #t))) (public select-forward-sexp select-backward-sexp select-up-sexp select-down-sexp transpose-sexp mark-matching-parenthesis) diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index 9b25cf60..10a97733 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -78,7 +78,7 @@ WARNING: printf is rebound in the body of the unit to always (define/public (get-fixed-style) (send (get-style-list) find-named-style "Standard")) - (define (invalidate-rectangles rectangles) + (define/private (invalidate-rectangles rectangles) (let ([b1 (box 0)] [b2 (box 0)] [b3 (box 0)] @@ -163,7 +163,7 @@ WARNING: printf is rebound in the body of the unit to always this-bottom (cdr rectangles))))])))))) - (define (recompute-range-rectangles) + (define/private (recompute-range-rectangles) (let* ([b1 (box 0)] [b2 (box 0)] [new-rectangles @@ -512,7 +512,7 @@ WARNING: printf is rebound in the body of the unit to always (super insert s len pos)) ;; 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)] [len 0] [blank? #t]) @@ -751,7 +751,7 @@ WARNING: printf is rebound in the body of the unit to always (mixin (editor:keymap<%> basic<%>) (info<%>) (inherit get-start-position get-end-position get-canvas run-after-edit-sequence) - (define (enqueue-for-frame call-method tag) + (define/private (enqueue-for-frame call-method tag) (run-after-edit-sequence (rec from-enqueue-for-frame (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 ;; 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)]) (when canvas (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 (mixin ((class->interface text%)) (clever-file-format<%>) (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)]) (cond [(not s) #t] @@ -1640,7 +1640,7 @@ WARNING: printf is rebound in the body of the unit to always [else (void)]))) ;; dequeue-n : queue number -> queue - (define (dequeue-n queue n) + (define/private (dequeue-n queue n) (let loop ([q queue] [n n]) (cond @@ -1649,7 +1649,7 @@ WARNING: printf is rebound in the body of the unit to always [else (loop (queue-rest q) (- n 1))]))) ;; peek-n : queue number -> queue - (define (peek-n queue init-n) + (define/private (peek-n queue init-n) (let loop ([q queue] [n init-n]) (cond