diff --git a/collects/macro-debugger/view/gui.ss b/collects/macro-debugger/view/gui.ss index 6f933830cf..b971dda4af 100644 --- a/collects/macro-debugger/view/gui.ss +++ b/collects/macro-debugger/view/gui.ss @@ -12,6 +12,7 @@ "warning.ss" "hiding-panel.ss" (prefix sb: "../syntax-browser/embed.ss") + (prefix sb: "../syntax-browser/params.ss") "../model/deriv.ss" "../model/deriv-util.ss" "../model/trace.ss" @@ -78,6 +79,8 @@ (notify-box/pref pref:hide-libs?)) (field/notify highlight-foci? (notify-box/pref pref:highlight-foci?)) + (field/notify highlight-frontier? + (notify-box/pref pref:highlight-frontier?)) (field/notify show-rename-steps? (notify-box/pref pref:show-rename-steps?)) (field/notify suppress-warnings? @@ -88,6 +91,8 @@ (notify-box/pref pref:extra-navigation?)) (field/notify debug-catch-errors? (notify-box/pref pref:debug-catch-errors?)) + (field/notify force-letrec-transformation? + (notify-box/pref pref:force-letrec-transformation?)) (super-new))) (define macro-stepper-frame% @@ -189,13 +194,28 @@ (menu-option/notify-box stepper-menu "Show macro hiding panel" (get-field show-hiding-panel? config)) + (new (get-menu-item%) (label "Show in new frame") (parent stepper-menu) + (callback (lambda _ (send widget show-in-new-frame)))) (let ([extras-menu (new (get-menu%) (label "Extra options") (parent stepper-menu))]) + (new checkable-menu-item% + (label "Always suffix marked identifiers") + (parent extras-menu) + (callback + (lambda (i e) + (sb:current-suffix-option + (if (send i is-checked?) + 'always + 'over-limit)) + (send widget update/preserve-view)))) (menu-option/notify-box extras-menu "Highlight redex/contractum" (get-field highlight-foci? config)) + (menu-option/notify-box extras-menu + "Highlight frontier" + (get-field highlight-frontier? config)) (menu-option/notify-box extras-menu "Include renaming steps" (get-field show-rename-steps? config)) @@ -208,6 +228,9 @@ (menu-option/notify-box extras-menu "Extra navigation" (get-field extra-navigation? config)) + (menu-option/notify-box extras-menu + "Force block->letrec transformation" + (get-field force-letrec-transformation? config)) (menu-option/notify-box extras-menu "(Debug) Catch internal errors?" (get-field debug-catch-errors? config))) @@ -252,6 +275,7 @@ (for-each (lambda (id) (module-identifier-mapping-put! alpha-table id id)) (extract-all-fresh-names d)) (cursor:add-to-end! terms (list (new-trec d))) + (trim-navigator) (if needs-display? (refresh/move) (update)))) @@ -297,22 +321,20 @@ (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?))) - (send sbc add-selection-listener (lambda (stx) (send macro-hiding-prefs set-syntax stx))) - (send config listen-highlight-foci? (lambda (_) (update/preserve-view))) - + (send config listen-highlight-frontier? + (lambda (_) (update/preserve-view))) (send config listen-show-rename-steps? (lambda (_) (refresh/re-reduce))) - (send config listen-one-by-one? (lambda (_) (refresh/re-reduce))) - + (send config listen-force-letrec-transformation? + (lambda (_) (refresh/resynth))) (send config listen-extra-navigation? (lambda (show?) (show-extra-navigation show?))) @@ -335,6 +357,23 @@ (new button% (label "Next term") (parent navigator) (callback (lambda (b e) (navigate-down))))) + (define/private (trim-navigator) + (if (> (length (cursor->list terms)) 1) + (send navigator change-children + (lambda _ + (list nav:up + nav:start + nav:previous + nav:next + nav:end + nav:down))) + (send navigator change-children + (lambda _ + (list nav:start + nav:previous + nav:next + nav:end))))) + (define/public (show-macro-hiding-prefs show?) (send area change-children (lambda (children) @@ -342,6 +381,10 @@ (append (remq control-pane children) (list control-pane)) (remq control-pane children))))) + (define/public (show-in-new-frame) + (when (cursor:next terms) + (go/deriv (trec-deriv (cursor:next terms))))) + (define/private (show-extra-navigation show?) (send supernavigator change-children (lambda (children) @@ -563,29 +606,23 @@ 'start) (enable/disable-buttons)) + ;; insert-syntax/color : syntax syntaxes identifiers syntaxes string -> void + (define/private (insert-syntax/color stx foci definites frontier hi-color) + (send sbview add-syntax stx + #:definites definites + #:alpha-table alpha-table + #:hi-color hi-color + #:hi-stxs (if (send config get-highlight-foci?) foci null) + #:hi2-color "WhiteSmoke" + #:hi2-stxs (if (send config get-highlight-frontier?) frontier null))) + ;; insert-syntax/redex : syntax syntaxes identifiers syntaxes -> void (define/private (insert-syntax/redex stx foci definites frontier) - (if (send config get-highlight-foci?) - (send sbview add-syntax stx - #:hi-stxs foci #:hi-color "MistyRose" - #:alpha-table alpha-table - #:definites definites - #:hi2-stxs frontier #:hi2-color "WhiteSmoke") - (send sbview add-syntax stx - #:alpha-table alpha-table - #:definites definites))) + (insert-syntax/color stx foci definites frontier "MistyRose")) ;; insert-syntax/contractum : syntax syntaxes identifiers syntaxes -> void (define/private (insert-syntax/contractum stx foci definites frontier) - (if (send config get-highlight-foci?) - (send sbview add-syntax stx - #:hi-stxs foci #:hi-color "LightCyan" - #:alpha-table alpha-table - #:definites definites - #:hi2-stxs frontier #:hi2-color "WhiteSmoke") - (send sbview add-syntax stx - #:alpha-table alpha-table - #:definites definites))) + (insert-syntax/color stx foci definites frontier "LightCyan")) ;; enable/disable-buttons : -> void (define/private (enable/disable-buttons) @@ -605,7 +642,7 @@ (for-each trec:invalidate-synth! (cursor->list terms)) (refresh)) - ;; refres/re-reduce : -> void + ;; refresh/re-reduce : -> void ;; Reduction config has changed; invalidate cached parts of trec (define/private (refresh/re-reduce) (for-each trec:invalidate-steps! (cursor->list terms)) @@ -748,8 +785,10 @@ (unless (send config get-suppress-warnings?) (unless warnings-frame (set! warnings-frame (new warnings-frame%))) - (send warnings-frame add-warning tag) - (send warnings-frame show #t))))) + (send warnings-frame add-warning tag message) + (send warnings-frame show #t)))) + (force-letrec-transformation + (send config get-force-letrec-transformation?))) (hide/policy deriv show-macro?)) (values deriv (lift/deriv-e2 deriv))))) diff --git a/collects/macro-debugger/view/interfaces.ss b/collects/macro-debugger/view/interfaces.ss index ed114cf9f7..b8ad2a5188 100644 --- a/collects/macro-debugger/view/interfaces.ss +++ b/collects/macro-debugger/view/interfaces.ss @@ -27,10 +27,12 @@ pref:identifier=? pref:show-rename-steps? pref:highlight-foci? + pref:highlight-frontier? pref:suppress-warnings? pref:one-by-one? pref:extra-navigation? pref:debug-catch-errors? + pref:force-letrec-transformation? )) ;; macro-stepper-config% diff --git a/collects/macro-debugger/view/prefs.ss b/collects/macro-debugger/view/prefs.ss index a6d5115e36..1c642db526 100644 --- a/collects/macro-debugger/view/prefs.ss +++ b/collects/macro-debugger/view/prefs.ss @@ -13,27 +13,29 @@ [() (preferences:get 'prop)] [(newval) (preferences:set 'prop newval)]))])) + (preferences:set-default 'MacroStepper:Frame:Width 700 number?) + (preferences:set-default 'MacroStepper:Frame:Height 600 number?) + (preferences:set-default 'MacroStepper:PropertiesPanelPercentage 1/3 number?) + (preferences:set-default 'MacroStepper:MacroHiding? #t boolean?) + (preferences:set-default 'MacroStepper:ShowSyntaxProperties? #f boolean?) + (preferences:set-default 'MacroStepper:ShowHidingPanel? #t boolean?) + (preferences:set-default 'MacroStepper:HidePrimitives? #t boolean?) + (preferences:set-default 'MacroStepper:HideLibs? #t boolean?) + (preferences:set-default 'MacroStepper:IdentifierComparison "bound-identifier=?" string?) + (preferences:set-default 'MacroStepper:HighlightFoci? #t boolean?) + (preferences:set-default 'MacroStepper:HighlightFrontier? #t boolean?) + (preferences:set-default 'MacroStepper:ShowRenameSteps? #f boolean?) + (preferences:set-default 'MacroStepper:SuppressWarnings? #f boolean?) + (preferences:set-default 'MacroStepper:OneByOne? #f boolean?) + (preferences:set-default 'MacroStepper:ExtraNavigation? #f boolean?) + (preferences:set-default 'MacroStepper:DebugCatchErrors? #t boolean?) + (preferences:set-default 'MacroStepper:ForceLetrecTransformation? #f boolean?) + (define prefs@ (unit (import) (export prefs^) - (preferences:set-default 'MacroStepper:Frame:Width 700 number?) - (preferences:set-default 'MacroStepper:Frame:Height 600 number?) - (preferences:set-default 'MacroStepper:PropertiesPanelPercentage 1/3 number?) - (preferences:set-default 'MacroStepper:MacroHiding? #t boolean?) - (preferences:set-default 'MacroStepper:ShowSyntaxProperties? #f boolean?) - (preferences:set-default 'MacroStepper:ShowHidingPanel? #t boolean?) - (preferences:set-default 'MacroStepper:HidePrimitives? #t boolean?) - (preferences:set-default 'MacroStepper:HideLibs? #t boolean?) - (preferences:set-default 'MacroStepper:IdentifierComparison "bound-identifier=?" string?) - (preferences:set-default 'MacroStepper:HighlightFoci? #t boolean?) - (preferences:set-default 'MacroStepper:ShowRenameSteps? #f boolean?) - (preferences:set-default 'MacroStepper:SuppressWarnings? #f boolean?) - (preferences:set-default 'MacroStepper:OneByOne? #f boolean?) - (preferences:set-default 'MacroStepper:ExtraNavigation? #f boolean?) - (preferences:set-default 'MacroStepper:DebugCatchErrors? #t boolean?) - (pref:get/set pref:width MacroStepper:Frame:Width) (pref:get/set pref:height MacroStepper:Frame:Height) (pref:get/set pref:props-percentage MacroStepper:PropertiesPanelPercentage) @@ -44,11 +46,13 @@ (pref:get/set pref:hide-libs? MacroStepper:HideLibs?) (pref:get/set pref:identifier=? MacroStepper:IdentifierComparison) (pref:get/set pref:highlight-foci? MacroStepper:HighlightFoci?) + (pref:get/set pref:highlight-frontier? MacroStepper:HighlightFrontier?) (pref:get/set pref:show-rename-steps? MacroStepper:ShowRenameSteps?) (pref:get/set pref:suppress-warnings? MacroStepper:SuppressWarnings?) (pref:get/set pref:one-by-one? MacroStepper:OneByOne?) (pref:get/set pref:extra-navigation? MacroStepper:ExtraNavigation?) (pref:get/set pref:debug-catch-errors? MacroStepper:DebugCatchErrors?) + (pref:get/set pref:force-letrec-transformation? MacroStepper:ForceLetrecTransformation?) )) ) diff --git a/collects/macro-debugger/view/warning.ss b/collects/macro-debugger/view/warning.ss index f34b677a88..d3d47a02ca 100644 --- a/collects/macro-debugger/view/warning.ss +++ b/collects/macro-debugger/view/warning.ss @@ -5,6 +5,8 @@ (lib "framework.ss" "framework")) (provide warnings-frame%) + (define include-message? #f) + ;; warnings-frame% (define warnings-frame% (class frame% @@ -44,14 +46,16 @@ (send text insert "\n\n") (send text lock #t)) - (define/public (add-warning tag) + (define/public (add-warning tag message) (case tag ((nonlinearity) (add-nonlinearity-text)) ((localactions) (add-localactions-text)) ((lifts) - (add-lifts-text)))) + (add-lifts-text))) + (when include-message? + (add-text message))) (send this show #t)))