diff --git a/collects/macro-debugger/view/cursor.rkt b/collects/macro-debugger/view/cursor.rkt index a83a8ab876..981d4d5df5 100644 --- a/collects/macro-debugger/view/cursor.rkt +++ b/collects/macro-debugger/view/cursor.rkt @@ -24,7 +24,8 @@ cursor->list cursor:prefix->list - cursor:suffix->list) + cursor:suffix->list + cursor-count) (define-struct cursor (vector count position) #:mutable) diff --git a/collects/macro-debugger/view/interfaces.rkt b/collects/macro-debugger/view/interfaces.rkt index 270e406824..54f8088d15 100644 --- a/collects/macro-debugger/view/interfaces.rkt +++ b/collects/macro-debugger/view/interfaces.rkt @@ -62,6 +62,7 @@ (get-raw-deriv get-deriv-hidden? get-step-index + get-step-count invalidate-synth! invalidate-steps! diff --git a/collects/macro-debugger/view/stepper.rkt b/collects/macro-debugger/view/stepper.rkt index f4f2e5f8cc..ec1edfbadb 100644 --- a/collects/macro-debugger/view/stepper.rkt +++ b/collects/macro-debugger/view/stepper.rkt @@ -14,7 +14,6 @@ "interfaces.ss" "prefs.ss" "extensions.ss" - "warning.ss" "hiding-panel.ss" "term-record.ss" "step-display.ss" @@ -103,7 +102,6 @@ (define/public (get-controller) sbc) (define/public (get-view) sbview) (define/public (get-step-displayer) step-displayer) - (define/public (get-warnings-area) warnings-area) (define/public (get-macro-hiding-prefs) macro-hiding-prefs) (define/public (reset-primary-partition) @@ -129,9 +127,7 @@ (stretchable-height #f) (alignment '(left center)) (style '(deleted)))) - - (define warnings-area (new stepper-warnings% (parent area))) - + (define: sbview sb:syntax-browser<%> (new stepper-syntax-widget% (parent area) @@ -206,7 +202,16 @@ (navigate-to (sub1 step))] [(equal? value "end") (navigate-to-end)]))))))) + + (define nav:step-count + (new message% + (label "") + (parent extra-navigator) + (auto-resize #t) + (stretchable-width #f) + (stretchable-height #f))) (send nav:text set-value "") + (listen-current-step-index (lambda (n) (send nav:text set-value @@ -388,9 +393,15 @@ ;; refresh : -> void (define/public (refresh) - (send warnings-area clear) (when (focused-term) (send: (focused-term) term-record<%> on-get-focus)) + (send nav:step-count set-label "") + (let ([term (focused-term)]) + (when term + (let ([step-count (send: term term-record<%> get-step-count)]) + (when step-count + ;; +1 for end of expansion "step" + (send nav:step-count set-label (format "of ~s" (add1 step-count))))))) (update)) (define/private (foci x) (if (list? x) x (list x))) diff --git a/collects/macro-debugger/view/term-record.rkt b/collects/macro-debugger/view/term-record.rkt index 1839dfdd1d..de4769741d 100644 --- a/collects/macro-debugger/view/term-record.rkt +++ b/collects/macro-debugger/view/term-record.rkt @@ -207,7 +207,11 @@ (and (get-steps) (not (cursor:at-end? (get-steps))))) (define/public-final (get-step-index) - (and (get-steps) (cursor-position (get-steps)))) + (let ([steps (get-steps)]) + (and steps (cursor-position steps)))) + (define/public-final (get-step-count) + (let ([steps (get-steps)]) + (and steps (cursor-count steps)))) (define/public-final (navigate-to-start) (cursor:move-to-start (get-steps)) diff --git a/collects/macro-debugger/view/warning.rkt b/collects/macro-debugger/view/warning.rkt deleted file mode 100644 index 66c96c9ec1..0000000000 --- a/collects/macro-debugger/view/warning.rkt +++ /dev/null @@ -1,130 +0,0 @@ - -#lang scheme/base -(require scheme/class - mred - framework) -(provide warnings% - stepper-warnings%) - -;; warnings% -(define warnings% - (class object% - (init parent) - (super-new) - - (define super-panel - (new vertical-panel% - (parent parent) - (stretchable-height #f))) - (define main-panel - (new horizontal-panel% - (parent super-panel) - (style '(deleted border)))) - (define label (new message% (parent main-panel) (label "Warnings"))) - (define text (new text:hide-caret/selection% (auto-wrap #t))) - (define ec - (new editor-canvas% - (parent main-panel) - (editor text) - (style '(auto-vscroll auto-hscroll)) - (line-count 3))) - (define dismiss - (new button% - (parent main-panel) - (label "Hide") - (stretchable-height #t) - (callback (lambda _ (show #f))))) - (send text set-autowrap-bitmap #f) - (send text lock #t) - - (define/public (get-text) text) - - (define/public (show ?) - (send super-panel change-children - (lambda _ - (if ? - (list main-panel) - null)))) - - ;; Warning management - (define keys null) - - ;; clear : -> void - (define/public (clear) - (set! keys null) - (send* text - (lock #f) - (erase) - (lock #t)) - (show #f)) - - ;; add : symbol string ... -> void - (define/public (add key . strs) - (unless (memq key keys) - (send text lock #f) - (for-each (lambda (s) (send text insert s)) strs) - (send text insert "\n\n") - (send text scroll-to-position 0) - (send text lock #t) - (show #t))) - - )) - -(define stepper-warnings% - (class warnings% - (super-new) - (inherit add) - - (define/private (add-nonlinearity-warning) - (add - 'nonlinearity - "An opaque macro duplicated one of its subterms. " - "Macro hiding requires opaque macros to use their subterms linearly. " - "The macro stepper is showing the expansion of that macro use.")) - (define/private (add-localactions-warning) - (add - 'localactions - "An opaque macro called local-expand, syntax-local-lift-expression, " - "etc. Macro hiding cannot currently handle local actions. " - "The macro stepper is showing the expansion of that macro use.")) - (define/private (add-lifts-warning) - (add - 'lifts - "A transparent macro called syntax-local-lift-expression or " - "syntax-local-lift-module-end-declaration. " - "The macro stepper is only hiding macro after the " - "lifts are caught.")) - - (define/private (add-lift/let-warning) - (add - 'lift/let - "Lifts occurred during the expansion of phase 1 or higher code. " - "The macro stepper is showing some expansions that should be hidden.")) - - (define/private (add-hidden-lift-site-warning) - (add - 'hidden-lift-site - "An opaque macro contained the target of a lifted declaration." - "The macro stepper is showing the expansion of that macro use.")) - - (define/private (add-hidden-lift-site/continuing-warning) - (add - 'hidden-lift-site/continuing - "The target of a lifted declaration was a hidden #%module-begin context. " - "The macro stepper is omitting the lifted declaration.")) - - (define/public (add-warning tag args) - (case tag - ((nonlinearity) - (add-nonlinearity-warning)) - ((localactions) - (add-localactions-warning)) - ((lifts) - (add-lifts-warning)) - ((lift/let) - (add-lift/let-warning)) - ((hidden-lift-site) - (add-hidden-lift-site-warning)) - ((hidden-lift-site/continuing) - (add-hidden-lift-site/continuing-warning)))) - ))