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

macro stepper: changed syntax browser classes to use iop

Browse Source 
-- This line, and those below, will be ignored--

M    macro-debugger/syntax-browser/properties.ss
M    macro-debugger/syntax-browser/display.ss
M    macro-debugger/syntax-browser/widget.ss
M    macro-debugger/syntax-browser/controller.ss
M    macro-debugger/syntax-browser/interfaces.ss
M    macro-debugger/syntax-browser/frame.ss
M    macro-debugger/util/class-iop.ss

svn: r13092

original commit: 3b8c1640745e810b044a62188930834345fdfeca
This commit is contained in:
Ryan Culpepper 2009-01-13 20:36:16 +00:00
parent 30f9d07cc2
commit 4e683ad102
6 changed files with 155 additions and 146 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/macro-debugger/syntax-browser/controller.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base
(require scheme/class
macro-debugger/util/class-iop
"interfaces.ss"
"partition.ss"
"../util/notify.ss")
@ -31,7 +32,7 @@
(super-new)
(listen-selected-syntax
(lambda (new-value)
(for-each (lambda (display) (send display refresh))
(for-each (lambda (display) (send: display display<%> refresh))
displays)))))
;; mark-manager-mixin
@ -62,7 +63,7 @@
(new partition% (relation (cdr name+proc)))))))
(listen-secondary-partition
(lambda (p)
(for-each (lambda (d) (send d refresh))
(for-each (lambda (d) (send: d display<%> refresh))
displays)))
(super-new)))

45
collects/macro-debugger/syntax-browser/display.ss
View File

@ -3,6 +3,7 @@
(require scheme/class
scheme/gui
scheme/match
macro-debugger/util/class-iop
"pretty-printer.ss"
"interfaces.ss"
"util.ss")
@ -17,7 +18,7 @@
(define output-port (open-output-string/count-lines))
(define range
(pretty-print-syntax stx output-port
(send controller get-primary-partition)
(send: controller controller<%> get-primary-partition)
(send config get-colors)
(send config get-suffix-option)
columns))
@ -42,13 +43,14 @@
;; add-clickbacks : text% range% controller<%> number -> void
(define (add-clickbacks text range controller insertion-point)
(for ([range (send range all-ranges)])
(for ([range (send: range range<%> all-ranges)])
(let ([stx (range-obj range)]
[start (range-start range)]
[end (range-end range)])
(send text set-clickback (+ insertion-point start) (+ insertion-point end)
(lambda (_1 _2 _3)
(send controller set-selected-syntax stx))))))
(send: controller selection-manager<%>
set-selected-syntax stx))))))
;; set-standard-font : text% config number number -> void
(define (set-standard-font text config start end)
@ -81,7 +83,9 @@
(begin-edit-sequence)
(change-style unhighlight-d start-position end-position))
(apply-extra-styles)
(let ([selected-syntax (send controller get-selected-syntax)])
(let ([selected-syntax
(send: controller selection-manager<%>
get-selected-syntax)])
(apply-secondary-partition-styles selected-syntax)
(apply-selection-styles selected-syntax))
(send* text
@ -126,9 +130,11 @@
(let ([delta (new style-delta%)])
(send delta set-delta-foreground color)
delta))
(define color-styles (list->vector (map color-style (send config get-colors))))
(define color-styles
(list->vector (map color-style (send config get-colors))))
(define overflow-style (color-style "darkgray"))
(define color-partition (send controller get-primary-partition))
(define color-partition
(send: controller mark-manager<%> get-primary-partition))
(define offset start-position)
(for-each
(lambda (range)
@ -139,12 +145,12 @@
(primary-style stx color-partition color-styles overflow-style)
(+ offset start)
(+ offset end))))
(send range all-ranges)))
(send: range range<%> all-ranges)))
;; primary-style : syntax partition (vector-of style-delta%) style-delta%
;; -> style-delta%
(define/private (primary-style stx partition color-vector overflow)
(let ([n (send partition get-partition stx)])
(let ([n (send: partition partition<%> get-partition stx)])
(cond [(< n (vector-length color-vector))
(vector-ref color-vector n)]
[else
@ -157,7 +163,7 @@
;; Applies externally-added styles (such as highlighting)
(define/private (apply-extra-styles)
(for ([(stx style-deltas) extra-styles])
(for ([r (send range get-ranges stx)])
(for ([r (send: range range<%> get-ranges stx)])
(for ([style-delta style-deltas])
(restyle-range r style-delta)))))
@ -166,23 +172,25 @@
;; in the same partition in blue.
(define/private (apply-secondary-partition-styles selected-syntax)
(when (identifier? selected-syntax)
(let ([partition (send controller get-secondary-partition)])
(let ([partition
(send: controller secondary-partition<%>
get-secondary-partition)])
(when partition
(for-each (lambda (id)
(when (send partition same-partition? selected-syntax id)
(draw-secondary-connection id)))
(send range get-identifier-list))))))
(for ([id (send: range range<%> get-identifier-list)])
(when (send: partition partition<%>
same-partition? selected-syntax id)
(draw-secondary-connection id)))))))
;; apply-selection-styles : syntax -> void
;; Styles subterms eq to the selected syntax
(define/private (apply-selection-styles selected-syntax)
(let ([rs (send range get-ranges selected-syntax)])
(for-each (lambda (r) (restyle-range r select-highlight-d)) rs)))
(for ([r (send: range range<%> get-ranges selected-syntax)])
(restyle-range r select-highlight-d)))
;; draw-secondary-connection : syntax -> void
(define/private (draw-secondary-connection stx2)
(let ([rs (send range get-ranges stx2)])
(for-each (lambda (r) (restyle-range r select-sub-highlight-d)) rs)))
(for ([r (send range get-ranges stx2)])
(restyle-range r select-sub-highlight-d)))
;; restyle-range : (cons num num) style-delta% -> void
(define/private (restyle-range r style)
@ -258,4 +266,3 @@
(define select-sub-highlight-d (highlight-style-delta subselection-color #f))
(define unhighlight-d (highlight-style-delta "white" #f))

6
collects/macro-debugger/syntax-browser/frame.ss
View File

@ -1,4 +1,3 @@
#lang scheme/base
(require scheme/class
scheme/gui
@ -20,10 +19,9 @@
;; browse-syntaxes : (list-of syntax) -> void
(define (browse-syntaxes stxs)
(let ((w (make-syntax-browser)))
(for-each (lambda (stx)
(for ([stx stxs])
(send w add-syntax stx)
(send w add-separator))
stxs)))
(send w add-separator))))
;; make-syntax-browser : -> syntax-browser<%>
(define (make-syntax-browser)

102
collects/macro-debugger/syntax-browser/interfaces.ss
View File

@ -1,37 +1,33 @@
#lang scheme/base
(require scheme/class)
(require scheme/class
macro-debugger/util/class-iop)
(provide (all-defined-out))
;; displays-manager<%>
(define displays-manager<%>
(interface ()
;; add-syntax-display : display<%> -> void
(define-interface displays-manager<%>
(;; add-syntax-display : display<%> -> void
add-syntax-display
;; remove-all-syntax-displays : -> void
remove-all-syntax-displays))
;; selection-manager<%>
(define selection-manager<%>
(interface ()
;; selected-syntax : syntax/#f
(define-interface selection-manager<%>
(;; selected-syntax : syntax/#f
set-selected-syntax
get-selected-syntax
listen-selected-syntax
))
listen-selected-syntax))
;; mark-manager<%>
;; Manages marks, mappings from marks to colors
(define mark-manager<%>
(interface ()
;; get-primary-partition : -> partition
(define-interface mark-manager<%>
(;; get-primary-partition : -> partition
get-primary-partition))
;; secondary-partition<%>
(define secondary-partition<%>
(interface (displays-manager<%>)
;; get-secondary-partition : -> partition<%>
(define-interface secondary-partition<%>
(;; get-secondary-partition : -> partition<%>
get-secondary-partition
;; set-secondary-partition : partition<%> -> void
@ -50,32 +46,44 @@
listen-identifier=?))
;; controller<%>
(define controller<%>
(define-interface/dynamic controller<%>
(interface (displays-manager<%>
selection-manager<%>
mark-manager<%>
secondary-partition<%>)))
secondary-partition<%>))
(add-syntax-display
remove-all-syntax-displays
set-selected-syntax
get-selected-syntax
listen-selected-syntax
get-primary-partition
get-secondary-partition
set-secondary-partition
listen-secondary-partition
get-identifier=?
set-identifier=?
listen-identifier=?))
;; host<%>
(define host<%>
(interface ()
;; get-controller : -> controller<%>
(define-interface host<%>
(;; get-controller : -> controller<%>
get-controller
;; add-keymap : text snip
add-keymap
))
add-keymap))
;; display<%>
(define display<%>
(interface ()
;; refresh : -> void
(define-interface display<%>
(;; refresh : -> void
refresh
;; highlight-syntaxes : (list-of syntax) color -> void
highlight-syntaxes
;; underline-syntaxes : (listof syntax) -> void
underline-syntaxes
;; get-start-position : -> number
get-start-position
@ -86,9 +94,8 @@
get-range))
;; range<%>
(define range<%>
(interface ()
;; get-ranges : datum -> (list-of (cons number number))
(define-interface range<%>
(;; get-ranges : datum -> (list-of (cons number number))
get-ranges
;; all-ranges : (list-of Range)
@ -98,41 +105,37 @@
;; get-identifier-list : (list-of identifier)
get-identifier-list))
;; A Range is (make-range datum number number)
(define-struct range (obj start end))
;; syntax-prefs<%>
(define syntax-prefs<%>
(interface ()
pref:width
(define-interface syntax-prefs<%>
(pref:width
pref:height
pref:props-percentage
pref:props-shown?))
;; widget-hooks<%>
(define widget-hooks<%>
(interface ()
;; setup-keymap : -> void
(define-interface widget-hooks<%>
(;; setup-keymap : -> void
setup-keymap
;; shutdown : -> void
shutdown
))
shutdown))
;; keymap-hooks<%>
(define keymap-hooks<%>
(interface ()
;; make-context-menu : -> context-menu<%>
(define-interface keymap-hooks<%>
(;; make-context-menu : -> context-menu<%>
make-context-menu
;; get-context-menu% : -> class
get-context-menu%))
;; context-menu-hooks<%>
(define context-menu-hooks<%>
(interface ()
add-edit-items
(define-interface context-menu-hooks<%>
(add-edit-items
after-edit-items
add-selection-items
after-selection-items
@ -143,19 +146,16 @@
;;----------
;; Convenience widget, specialized for displaying stx and not much else
(define syntax-browser<%>
(interface ()
add-syntax
(define-interface syntax-browser<%>
(add-syntax
add-text
add-separator
erase-all
select-syntax
get-text
))
get-text))
(define partition<%>
(interface ()
;; get-partition : any -> number
(define-interface partition<%>
(;; get-partition : any -> number
get-partition
;; same-partition? : any any -> number

3
collects/macro-debugger/syntax-browser/properties.ss
View File

@ -2,6 +2,7 @@
#lang scheme/base
(require scheme/class
scheme/gui
macro-debugger/util/class-iop
"interfaces.ss"
"util.ss"
"../util/mpi.ss")
@ -24,7 +25,7 @@
(field (text (new text%)))
(field (pdisplayer (new properties-displayer% (text text))))
(send controller listen-selected-syntax
(send: controller selection-manager<%> listen-selected-syntax
(lambda (stx)
(set! selected-syntax stx)
(refresh)))

20
collects/macro-debugger/syntax-browser/widget.ss
View File

@ -6,6 +6,7 @@
scheme/list
scheme/match
syntax/boundmap
macro-debugger/util/class-iop
"interfaces.ss"
"controller.ss"
"display.ss"
@ -119,7 +120,8 @@
(let ([display (internal-add-syntax stx)]
[definite-table (make-hasheq)])
(for-each (lambda (hi-stxs hi-color)
(send display highlight-syntaxes hi-stxs hi-color))
(send: display display<%>
highlight-syntaxes hi-stxs hi-color))
hi-stxss
hi-colors)
(for ([definite definites])
@ -128,20 +130,20 @@
(for ([shifted-definite (hash-ref shift-table definite null)])
(hash-set! definite-table shifted-definite #t))))
(when alpha-table
(let ([range (send display get-range)]
[start (send display get-start-position)])
(let ([range (send: display display<%> get-range)]
[start (send: display display<%> get-start-position)])
(let* ([binders0
(module-identifier-mapping-map alpha-table (lambda (k v) k))]
[binders
(apply append (map get-binders binders0))])
(send display underline-syntaxes binders))
(for ([id (send range get-identifier-list)])
(send: display display<%> underline-syntaxes binders))
(for ([id (send: range range<%> get-identifier-list)])
(define definite? (hash-ref definite-table id #f))
(when #f ;; DISABLED
(add-binding-billboard start range id definite?))
(for ([binder (get-binders id)])
(for ([binder-r (send range get-ranges binder)])
(for ([id-r (send range get-ranges id)])
(for ([binder-r (send: range range<%> get-ranges binder)])
(for ([id-r (send: range range<%> get-ranges id)])
(add-binding-arrow start binder-r id-r definite?)))))))
(void)))
@ -169,7 +171,7 @@
(+ start (cdr id-r))
(string-append "from " (mpi->string src-mod))
(if definite? "blue" "purple")))
(send range get-ranges id))]
(send: range range<%> get-ranges id))]
[_ (void)]))
(define/public (add-separator)
@ -182,7 +184,7 @@
(with-unlock -text
(send -text erase)
(send -text delete-all-drawings))
(send controller remove-all-syntax-displays))
(send: controller displays-manager<%> remove-all-syntax-displays))
(define/public (get-text) -text)