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

macro stepper: simplified prefs/params, fixed menu bugs

Browse Source 
svn: r12681

original commit: 2648a3b03f01c04755469c5341fb380c6838e853
This commit is contained in:
Ryan Culpepper 2008-12-02 19:54:36 +00:00
parent cb3e3770a9
commit 5fee1897e5
15 changed files with 141 additions and 156 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -3,7 +3,6 @@
(require scheme/class
scheme/gui
scheme/match
"params.ss"
"pretty-printer.ss"
"interfaces.ss"
"util.ss")
@ -11,8 +10,8 @@
code-style)
;; print-syntax-to-editor : syntax text controller<%> -> display<%>
(define (print-syntax-to-editor stx text controller)
(new display% (syntax stx) (text text) (controller controller)))
(define (print-syntax-to-editor stx text controller config)
(new display% (syntax stx) (text text) (controller controller) (config config)))
;; FIXME: assumes text never moves
@ -22,6 +21,7 @@
(init ((stx syntax)))
(init-field text)
(init-field controller)
(init-field config)
(define start-anchor (new anchor-snip%))
(define end-anchor (new anchor-snip%))
@ -33,7 +33,7 @@
(with-unlock text
(send text delete (get-start-position) (get-end-position))
(set! range
(print-syntax stx text controller
(print-syntax stx text controller config
(lambda () (get-start-position))
(lambda () (get-end-position))))
(apply-primary-partition-styles))
@ -131,7 +131,7 @@
(let ([delta (new style-delta%)])
(send delta set-delta-foreground color)
delta))
(define color-styles (list->vector (map color-style (current-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 offset (get-start-position))
@ -162,16 +162,20 @@
(render-syntax stx)
(send controller add-syntax-display this)))
;; print-syntax : syntax controller (-> number) (-> number)
;; print-syntax : syntax text% controller config (-> number) (-> number)
;; -> range%
(define (print-syntax stx text controller
(define (print-syntax stx text controller config
get-start-position get-end-position)
(define primary-partition (send controller get-primary-partition))
(define real-output-port (make-text-port text get-end-position))
(define output-port (open-output-string))
(define colors (send config get-colors))
(define suffix-option (send config get-suffix-option))
(define columns (send config get-columns))
(port-count-lines! output-port)
(let ([range (pretty-print-syntax stx output-port primary-partition)])
(let ([range (pretty-print-syntax stx output-port primary-partition
colors suffix-option columns)])
(write-string (get-output-string output-port) real-output-port)
(let ([end (get-end-position)])
;; Pretty printer always inserts final newline; we remove it here.
@ -189,7 +193,7 @@
(send range all-ranges)))
;; Set font to standard
(send text change-style
(code-style text)
(code-style text (send config get-syntax-font-size))
(get-start-position)
(get-end-position))
range))
@ -212,11 +216,10 @@
(send text insert char pos (add1 pos)))
(for-each fixup (send range all-ranges)))
;; code-style : text<%> -> style<%>
(define (code-style text)
;; code-style : text<%> number/#f -> style<%>
(define (code-style text font-size)
(let* ([style-list (send text get-style-list)]
[style (send style-list find-named-style "Standard")]
[font-size (current-syntax-font-size)])
[style (send style-list find-named-style "Standard")])
(if font-size
(send style-list find-or-create-style
style

2
collects/macro-debugger/syntax-browser/embed.ss
View File

@ -3,11 +3,9 @@
(require "interfaces.ss"
"widget.ss"
"keymap.ss"
"params.ss"
"partition.ss")
(provide (all-from-out "interfaces.ss")
(all-from-out "widget.ss")
(all-from-out "keymap.ss")
(all-from-out "params.ss")
identifier=-choices)

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

@ -54,8 +54,7 @@
(define syntax-widget/controls%
(class* widget% ()
(inherit get-main-panel
get-controller
toggle-props)
get-controller)
(super-new)
(inherit-field config)
@ -85,7 +84,10 @@
(new button%
(label "Properties")
(parent -control-panel)
(callback (lambda _ (toggle-props))))
(callback
(lambda _
(send config set-props-shown?
(not (send config get-props-shown?))))))
(send (get-controller) listen-identifier=?
(lambda (name+func)

83
collects/macro-debugger/syntax-browser/keymap.ss
View File

@ -2,6 +2,7 @@
#lang scheme/base
(require scheme/class
scheme/gui
"../util/notify.ss"
"interfaces.ss"
"partition.ss")
(provide smart-keymap%
@ -48,6 +49,7 @@
(set! on-demand-actions (cons p on-demand-actions)))
(define/override (on-demand)
(super on-demand)
(for-each (lambda (p) (p)) on-demand-actions))
(super-new)))
@ -92,28 +94,42 @@
(lambda (i e)
(send config set-props-shown? #f)))
(define/public (add-edit-items)
(define/private (selected-syntax)
(send controller get-selected-syntax))
(define/public (add-menu-items)
(set! copy-menu
(new menu-item% (label "Copy") (parent the-context-menu)
(callback (lambda (i e)
(call-function "copy-text" i e)))))
(void))
(define/public (after-edit-items)
(void))
(define/public (add-selection-items)
(demand-callback
(lambda (i)
(send i enable (and (selected-syntax) #t))))
(callback
(lambda (i e)
(call-function "copy-text" i e)))))
(add-separator)
(set! clear-menu
(new menu-item%
(label "Clear selection")
(parent the-context-menu)
(demand-callback
(lambda (i)
(send i enable (and (selected-syntax) #t))))
(callback
(lambda (i e)
(call-function "clear-syntax-selection" i e)))))
(set! props-menu
(menu-option/notify-box the-context-menu
"View syntax properties"
(get-field props-shown? config))
#;
(new menu-item%
(label "Show syntax properties")
(parent the-context-menu)
(demand-callback
(lambda (i)
(if (send config get-props-shown?)
(send i set-label "Hide syntax properties")
(send i set-label "Show syntax properties"))))
(callback
(lambda (i e)
(if (send config get-props-shown?)
@ -121,55 +137,10 @@
(call-function "show-syntax-properties" i e))))))
(void))
(define/public (after-selection-items)
(void))
(define/public (add-partition-items)
(let ([secondary (new menu% (label "identifier=?") (parent the-context-menu))])
(for-each
(lambda (name func)
(let ([this-choice
(new checkable-menu-item%
(label name)
(parent secondary)
(callback
(lambda (i e)
(send controller set-identifier=?
(cons name func)))))])
(send controller listen-identifier=?
(lambda (name+proc)
(send this-choice check (eq? name (car name+proc)))))))
(map car (identifier=-choices))
(map cdr (identifier=-choices))))
(void))
(define/public (after-partition-items)
(void))
(define/public (add-separator)
(new separator-menu-item% (parent the-context-menu)))
;; Initialize menu
(add-edit-items)
(after-edit-items)
(add-separator)
(add-selection-items)
(after-selection-items)
(add-separator)
(add-partition-items)
(after-partition-items)
(send the-context-menu add-on-demand
(lambda ()
(define stx (send controller get-selected-syntax))
(send copy-menu enable (and stx #t))
(send clear-menu enable (and stx #t))))
(send config listen-props-shown?
(lambda (shown?)
(send props-menu set-label
(if shown?
"Hide syntax properties"
"Show syntax properties"))))))
(add-menu-items)
))

36
collects/macro-debugger/syntax-browser/prefs.ss
View File

@ -5,13 +5,9 @@
"interfaces.ss"
"../util/notify.ss"
"../util/misc.ss")
(provide syntax-prefs%
syntax-prefs/readonly%
#;pref:tabify
#;pref:height
#;pref:width
#;pref:props-percentage)
(provide syntax-prefs-base%
syntax-prefs%
syntax-prefs/readonly%)
(preferences:set-default 'SyntaxBrowser:Width 700 number?)
(preferences:set-default 'SyntaxBrowser:Height 600 number?)
@ -22,13 +18,37 @@
(pref:get/set pref:height SyntaxBrowser:Height)
(pref:get/set pref:props-percentage SyntaxBrowser:PropertiesPanelPercentage)
(pref:get/set pref:props-shown? SyntaxBrowser:PropertiesPanelShown)
(pref:get/set pref:tabify framework:tabify)
(define syntax-prefs-base%
(class object%
;; columns : number
(field/notify columns (new notify-box% (value 60)))
;; suffix-option : SuffixOption
(field/notify suffix-option (new notify-box% (value 'over-limit)))
;; syntax-font-size : number/#f
;; When non-false, overrides the default font size
(field/notify syntax-font-size (new notify-box% (value #f)))
;; colors : (listof string)
(field/notify colors
(new notify-box%
(value '("black" "red" "blue"
"mediumforestgreen" "darkgreen"
"darkred"
"cornflowerblue" "royalblue" "steelblue" "darkslategray" "darkblue"
"indigo" "purple"
"orange" "salmon" "darkgoldenrod" "olive"))))
;; width, height : number
(notify-methods width)
(notify-methods height)
;; props-percentage : ...
(notify-methods props-percentage)
;; props-shown? : boolean
(notify-methods props-shown?)
(super-new)))

11
collects/macro-debugger/syntax-browser/pretty-helper.ss
View File

@ -1,8 +1,7 @@
#lang scheme/base
(require scheme/class
syntax/stx
"partition.ss")
syntax/stx)
(provide (all-defined-out))
;; Problem: If stx1 and stx2 are two distinguishable syntax objects, it
@ -27,7 +26,7 @@
;; - 'over-limit -- suffix > limit
;; - 'all-if-over-limit -- suffix > 0 if any over limit
;; syntax->datum/tables : stx [partition% num SuffixOption]
;; syntax->datum/tables : stx partition% num SuffixOption
;; -> (values s-expr hashtable hashtable)
;; When partition is not false, tracks the partititions that subterms belong to
;; When limit is a number, restarts processing with numbering? set to true
@ -37,10 +36,8 @@
;; - a hashtable mapping S-expressions to syntax objects
;; - a hashtable mapping syntax objects to S-expressions
;; Syntax objects which are eq? will map to same flat values
(define syntax->datum/tables
(case-lambda
[(stx) (table stx #f #f 'never)]
[(stx partition limit suffixopt) (table stx partition limit suffixopt)]))
(define (syntax->datum/tables stx partition limit suffixopt)
(table stx partition limit suffixopt))
;; table : syntax maybe-partition% maybe-num SuffixOption -> (values s-expr hashtable hashtable)
(define (table stx partition limit suffixopt)

17
collects/macro-debugger/syntax-browser/pretty-printer.ss
View File

@ -7,19 +7,18 @@
scheme/pretty
scheme/gui
"pretty-helper.ss"
"interfaces.ss"
"params.ss"
"prefs.ss")
"interfaces.ss")
(provide pretty-print-syntax)
;; pretty-print-syntax : syntax port partition -> range%
(define (pretty-print-syntax stx port primary-partition)
;; pretty-print-syntax :
;; syntax port partition (listof string) SuffixOption number
;; -> range%
(define (pretty-print-syntax stx port primary-partition colors suffix-option columns)
(define range-builder (new range-builder%))
(define-values (datum ht:flat=>stx ht:stx=>flat)
(syntax->datum/tables stx primary-partition
(length (current-colors))
(current-suffix-option)))
(length colors)
suffix-option))
(define identifier-list
(filter identifier? (hash-map ht:stx=>flat (lambda (k v) k))))
(define (flat=>stx obj)
@ -53,7 +52,7 @@
[pretty-print-size-hook pp-size-hook]
[pretty-print-print-hook pp-print-hook]
[pretty-print-current-style-table (pp-extend-style-table identifier-list)]
[pretty-print-columns (current-default-columns)]
[pretty-print-columns columns]
;; Printing parameters (mzscheme manual 7.9.1.4)
[print-unreadable #t]
[print-graph #f]

4
collects/macro-debugger/syntax-browser/syntax-snip.ss
View File

@ -60,7 +60,9 @@
(send text begin-edit-sequence)
(send text change-style (make-object style-delta% 'change-alignment 'top))
(define display
(print-syntax-to-editor stx text (send host get-controller)))
(print-syntax-to-editor stx text
(send host get-controller)
(send host get-config)))
(send text lock #t)
(send text end-edit-sequence)
(send text hide-caret #t)

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

@ -8,7 +8,6 @@
mzlib/kw
syntax/boundmap
"interfaces.ss"
"params.ss"
"controller.ss"
"display.ss"
"keymap.ss"
@ -48,15 +47,10 @@
(send -text set-styles-sticky #f)
(send -text lock #t)
;; syntax-properties-controller<%> methods
(define/public (props-shown?)
(send -props-panel is-shown?))
(define/public (toggle-props)
(show-props (not (send -props-panel is-shown?))))
(define/public (show-props show?)
(internal-show-props show?))
(define/private (internal-show-props show?)
(if show?
(unless (send -props-panel is-shown?)
(let ([p (send config get-props-percentage)])
@ -67,27 +61,25 @@
(send -split-panel delete-child -props-panel)
(send -props-panel show #f))))
(send config listen-props-percentage
(lambda (p)
(update-props-percentage p)))
(send config listen-props-shown?
(lambda (show?)
(show-props show?)))
(define/private (update-props-percentage p)
(send -split-panel set-percentages
(list (- 1 p) p)))
;;
(define/public (get-controller) controller)
(define/private (props-panel-shown?)
(send -props-panel is-shown?))
;;
(define/public (get-main-panel) -main-panel)
(define/public (get-controller)
controller)
;;
(define/public (get-main-panel)
-main-panel)
(define/public (shutdown)
(when (props-shown?)
(when (props-panel-shown?)
(send config set-props-percentage
(cadr (send -split-panel get-percentages)))))
@ -187,23 +179,31 @@
;; internal-add-syntax : syntax -> display
(define/private (internal-add-syntax stx)
(with-unlock -text
(parameterize ((current-default-columns (calculate-columns)))
(let ([display (print-syntax-to-editor stx -text controller)])
(send* -text
(insert "\n")
;(scroll-to-position current-position)
)
display))))
(let ([display (print-syntax-to-editor stx -text controller config)])
(send* -text
(insert "\n")
;;(scroll-to-position current-position)
)
display)))
(define/private (calculate-columns)
(define style (code-style -text))
(define style (code-style -text (send config get-syntax-font-size)))
(define char-width (send style get-text-width (send -ecanvas get-dc)))
(define-values (canvas-w canvas-h) (send -ecanvas get-client-size))
(sub1 (inexact->exact (floor (/ canvas-w char-width)))))
;; Initialize
(super-new)
(setup-keymap)))
(setup-keymap)
(send config listen-props-shown?
(lambda (show?)
(show-props show?)))
(send config listen-props-percentage
(lambda (p)
(update-props-percentage p)))
(internal-show-props (send config get-props-shown?))))
(define clickback-style
(let ([sd (new style-delta%)])

4
collects/macro-debugger/view/extensions.ss
View File

@ -57,8 +57,8 @@
(inherit add-separator)
(define/override (after-selection-items)
(super after-selection-items)
(define/override (add-menu-items)
(super add-menu-items)
(add-separator)
(set! show-macro
(new menu-item% (label "Show selected identifier") (parent the-context-menu)

13
collects/macro-debugger/view/frame.ss
View File

@ -14,7 +14,6 @@
"warning.ss"
"hiding-panel.ss"
(prefix-in sb: "../syntax-browser/embed.ss")
(prefix-in sb: "../syntax-browser/params.ss")
"../model/deriv.ss"
"../model/deriv-util.ss"
"../model/trace.ss"
@ -120,8 +119,8 @@
(callback (lambda _ (send widget show-in-new-frame)))))
(menu-option/notify-box stepper-menu
"Show syntax properties"
(get-field show-syntax-properties? config))
"View syntax properties"
(get-field props-shown? config))
(let ([id-menu
(new (get-menu%)
@ -175,10 +174,10 @@
(parent extras-menu)
(callback
(lambda (i e)
(sb:current-suffix-option
(if (send i is-checked?)
'always
'over-limit))
(send config set-suffix-option
(if (send i is-checked?)
'always
'over-limit))
(send widget update/preserve-view))))
(menu-option/notify-box extras-menu
"Highlight redex/contractum"

4
collects/macro-debugger/view/interfaces.ss
View File

@ -5,6 +5,7 @@
;; Signatures
#;
(define-signature view^
(macro-stepper-frame%
macro-stepper-widget%
@ -12,12 +13,15 @@
go
go/deriv))
#;
(define-signature view-base^
(base-frame%))
#;
(define-signature prefs^
(pref:width
pref:height
pref:props-shown?
pref:props-percentage
pref:macro-hiding-mode
pref:show-syntax-properties?

13
collects/macro-debugger/view/prefs.ss
View File

@ -2,6 +2,7 @@
#lang scheme/base
(require scheme/class
framework/framework
"../syntax-browser/prefs.ss"
"../util/notify.ss"
"../util/misc.ss")
(provide macro-stepper-config-base%
@ -30,7 +31,6 @@
(pref:get/set pref:props-shown? MacroStepper:PropertiesShown?)
(pref:get/set pref:props-percentage MacroStepper:PropertiesPanelPercentage)
(pref:get/set pref:macro-hiding-mode MacroStepper:MacroHidingMode)
(pref:get/set pref:show-syntax-properties? MacroStepper:ShowSyntaxProperties?)
(pref:get/set pref:show-hiding-panel? MacroStepper:ShowHidingPanel?)
(pref:get/set pref:identifier=? MacroStepper:IdentifierComparison)
(pref:get/set pref:highlight-foci? MacroStepper:HighlightFoci?)
@ -43,13 +43,8 @@
(pref:get/set pref:force-letrec-transformation? MacroStepper:ForceLetrecTransformation?)
(define macro-stepper-config-base%
(class object%
(notify-methods width)
(notify-methods height)
(notify-methods props-shown?)
(notify-methods props-percentage)
(class syntax-prefs-base%
(notify-methods macro-hiding-mode)
(notify-methods show-syntax-properties?)
(notify-methods show-hiding-panel?)
(notify-methods identifier=?)
(notify-methods highlight-foci?)
@ -66,10 +61,9 @@
(class macro-stepper-config-base%
(connect-to-pref width pref:width)
(connect-to-pref height pref:height)
(connect-to-pref props-shown? pref:props-shown?)
(connect-to-pref props-percentage pref:props-percentage)
(connect-to-pref props-shown? pref:props-shown?)
(connect-to-pref macro-hiding-mode pref:macro-hiding-mode)
(connect-to-pref show-syntax-properties? pref:show-syntax-properties?)
(connect-to-pref show-hiding-panel? pref:show-hiding-panel?)
(connect-to-pref identifier=? pref:identifier=?)
(connect-to-pref highlight-foci? pref:highlight-foci?)
@ -88,7 +82,6 @@
(connect-to-pref/readonly height pref:height)
(connect-to-pref/readonly macro-hiding-mode pref:macro-hiding-mode)
(connect-to-pref/readonly props-percentage pref:props-percentage)
(connect-to-pref/readonly show-syntax-properties? pref:show-syntax-properties?)
(connect-to-pref/readonly show-hiding-panel? pref:show-hiding-panel?)
(connect-to-pref/readonly identifier=? pref:identifier=?)
(connect-to-pref/readonly highlight-foci? pref:highlight-foci?)

11
collects/macro-debugger/view/stepper.ss
View File

@ -13,8 +13,6 @@
"warning.ss"
"hiding-panel.ss"
"term-record.ss"
(prefix-in s: "../syntax-browser/widget.ss")
(prefix-in s: "../syntax-browser/params.ss")
"../model/deriv.ss"
"../model/deriv-util.ss"
"../model/deriv-find.ss"
@ -138,10 +136,11 @@
(stepper this)
(config config)))
#;
(send config listen-show-syntax-properties?
(lambda (show?) (send sbview show-props show?)))
(send config listen-show-hiding-panel?
(lambda (show?) (show-macro-hiding-prefs show?)))
(lambda (show?) (show-macro-hiding-panel show?)))
(send sbc listen-selected-syntax
(lambda (stx) (send macro-hiding-prefs set-syntax stx)))
(send config listen-highlight-foci?
@ -215,7 +214,7 @@
nav:next
nav:end)))))
(define/public (show-macro-hiding-prefs show?)
(define/public (show-macro-hiding-panel show?)
(send area change-children
(lambda (children)
(if show?
@ -423,8 +422,8 @@
;; Initialization
(super-new)
(send sbview show-props (send config get-show-syntax-properties?))
(show-macro-hiding-prefs (send config get-show-hiding-panel?))
#;(send sbview show-props (send config get-show-syntax-properties?))
(show-macro-hiding-panel (send config get-show-hiding-panel?))
(show-extra-navigation (send config get-extra-navigation?))
(refresh/move)
))

2
collects/macro-debugger/view/term-record.ss
View File

@ -12,8 +12,6 @@
"extensions.ss"
"warning.ss"
"hiding-panel.ss"
(prefix-in s: "../syntax-browser/widget.ss")
(prefix-in s: "../syntax-browser/params.ss")
"../model/deriv.ss"
"../model/deriv-util.ss"
"../model/deriv-find.ss"