macro-stepper: added api for macro "remarks" (no docs yet)

original commit: 2068acc22b65415072d753828d182e970b7def0b

collects/macro-debugger/emit.rkt

@@ -0,0 +1,22 @@
+#lang racket/base
+(require racket/contract/base)
+
+(provide/contract
+ [emit-remark
+  (->* () (#:unmark? any/c) #:rest (listof (or/c string? syntax?))
+       any)])
+
+(define current-expand-observe
+  (dynamic-require ''#%expobs 'current-expand-observe))
+
+(define (emit-remark #:unmark? [unmark? #t] . args)
+  (let ([observe (current-expand-observe)])
+    (when observe
+      (let ([args
+             (if unmark?
+                 (for/list ([arg (in-list args)])
+                   (if (syntax? arg)
+                       (syntax-local-introduce arg)
+                       arg))
+                 args)])
+        (observe 'local-remark args)))))

collects/macro-debugger/model/deriv-c.rkt

@@ -40,6 +40,8 @@
 (define-struct local-lift-require (req expr mexpr) #:transparent)
 (define-struct local-lift-provide (prov) #:transparent)
 (define-struct local-bind (names ?1 renames bindrhs) #:transparent)
+(define-struct local-remark (contents) #:transparent)
+  ;; contents : (listof (U string syntax))
 
 ;; A PrimDeriv is one of
 (define-struct (prule base) () #:transparent)

collects/macro-debugger/model/deriv-parser.rkt

@@ -202,6 +202,8 @@
       (make local-bind $1 $2 $3 #f)]
      [(local-bind rename-list (? BindSyntaxes))
       (make local-bind $1 #f $2 $3)]
+     [(local-remark)
+      (make local-remark $1)]
      ;; -- Not really local actions, but can occur during evaluation
      ;; called 'expand' (not 'local-expand') within transformer
      [(start (? EE)) #f]

collects/macro-debugger/model/deriv-tokens.rkt

@@ -59,6 +59,8 @@
 
    top-begin            ; identifier
    top-non-begin        ; .
+
+   local-remark         ; (listof (U string syntax))
    ))
 
 (define-tokens renames-tokens
@@ -93,6 +95,7 @@
     (#f  start                   ,token-start)
     (#f  top-begin               ,token-top-begin)
     (#f  top-non-begin           ,token-top-non-begin)
+    (#f  local-remark            ,token-local-remark)
 
     ;; Standard signals
     (0   visit                   ,token-visit)

collects/macro-debugger/model/reductions-config.rkt

@@ -60,6 +60,9 @@
         [#:foci1 syntaxish? #:foci2 syntaxish?]
         . ->* . step?)]
  [stumble ([syntaxish? exn?] [#:focus syntaxish?] . ->* . misstep?)]
+ [walk/talk
+  (-> (or/c symbol? string?) (listof (or/c syntax? string? 'arrow))
+      remarkstep?)]
 
  [current-pass-hides? (parameterlike/c boolean?)]
 
@@ -343,6 +346,11 @@
         (current-state-with stx focus)
         exn))
 
+(define (walk/talk type contents)
+  (make remarkstep type
+        (current-state-with #f null)
+        contents))
+
 (define (foci x)
   (cond [(syntax? x)
          (list x)]

collects/macro-debugger/model/reductions.rkt

@@ -419,7 +419,15 @@
      ;; FIXME: add action
      (R [#:do (take-lift!)]
         [#:binders ids]
-        [#:reductions (list (walk expr ids 'local-lift))])]
+        [#:reductions
+         (list
+          (walk/talk 'local-lift
+                     (list "The macro lifted an expression"
+                           ""
+                           "Expression:"
+                           expr
+                           "Identifiers:"
+                           (datum->syntax #f ids))))])]
 
     [(struct local-lift-end (decl))
      ;; (walk/mono decl 'module-lift)
@@ -436,7 +444,9 @@
      [R [! ?1]
         ;; FIXME: use renames
         [#:binders names]
-        [#:when bindrhs => (BindSyntaxes bindrhs)]]]))
+        [#:when bindrhs => (BindSyntaxes bindrhs)]]]
+    [(struct local-remark (contents))
+     (R [#:reductions (list (walk/talk 'remark contents))])]))
 
 ;; List : ListDerivation -> RST
 (define (List ld)

collects/macro-debugger/model/steps.rkt

@@ -1,10 +1,10 @@
-
 #lang scheme/base
 (require "deriv.ss"
          "deriv-util.ss")
 (provide (struct-out protostep)
          (struct-out step)
          (struct-out misstep)
+         (struct-out remarkstep)
          (struct-out state)
          (struct-out bigframe)
          context-fill
@@ -22,9 +22,11 @@
 ;; A Step is one of
 ;;  - (make-step StepType State State)
 ;;  - (make-misstep StepType State exn)
+;;  - (make-remarkstep StepType State (listof (U string syntax 'arrow)))
 (define-struct protostep (type s1) #:transparent)
 (define-struct (step protostep) (s2) #:transparent)
 (define-struct (misstep protostep) (exn) #:transparent)
+(define-struct (remarkstep protostep) (contents) #:transparent)
 
 ;; A State is
 ;;  (make-state stx stxs Context BigContext (listof id) (listof id) (listof stx) nat/#f)
@@ -89,6 +91,8 @@
     (splice-lifts     . "Splice definitions from lifted expressions")
     (splice-module-lifts . "Splice lifted module declarations")
 
+    (remark           . "Macro made a remark")
+
     (error            . "Error")))
 
 (define (step-type->string x)

collects/macro-debugger/view/step-display.rkt

@@ -87,6 +87,8 @@
              (show-step step shift-table)]
             [(misstep? step)
              (show-misstep step shift-table)]
+            [(remarkstep? step)
+             (show-remarkstep step shift-table)]
             [(prestep? step)
              (show-prestep step shift-table)]
             [(poststep? step)
@@ -229,6 +231,22 @@
                  #:shift-table shift-table)))
       (show-lctx step shift-table))
 
+    (define/private (show-remarkstep step shift-table)
+      (define state (protostep-s1 step))
+      (for ([content (in-list (remarkstep-contents step))])
+        (cond [(string? content)
+               (send*: sbview sb:syntax-browser<%>
+                       (add-text content)
+                       (add-text "\n"))]
+              [(syntax? content)
+               (send*: sbview sb:syntax-browser<%>
+                 (add-syntax content
+                             #:binders (or (state-binders state) null)
+                             #:definites (or (state-uses state) null)
+                             #:shift-table shift-table)
+                 (add-text "\n"))]))
+      (show-lctx step shift-table))
+
     ;; insert-syntax/color
     (define/private (insert-syntax/color stx foci binders shift-table
                                          definites frontier hi-color)