.
original commit: 76fc48e868652b6922f99550e191c16ab9883000
This commit is contained in:
Robby Findler
parent
a612b0834d
commit
57b4aee87d
|
|
@ -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
|
||||
"#<module-path-index "
|
||||
(let loop ([mpi mpi])
|
||||
|
|
@ -147,46 +135,45 @@ needed to really make this work:
|
|||
[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)))
|
||||
|
||||
(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%
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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%)))]
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user