macro-stepper: added step count

also removed some dead code (warnings)

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)

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!
 

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)
@@ -130,8 +128,6 @@
            (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)))

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))

collects/macro-debugger/view/warning.rkt

@@ -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))))
-    ))