commit cedc2417f42f18e10b26461397f22b7b6f655e6f
parent 50d21a212d307cee2588bdb0dab4e4c0f894bc9c
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Wed, 9 Jun 2010 16:04:28 -0600
macro-stepper: added api for macro "remarks" (no docs yet)
original commit: 2068acc22b65415072d753828d182e970b7def0b
Diffstat:
8 files changed, 72 insertions(+), 3 deletions(-)
diff --git a/collects/macro-debugger/emit.rkt b/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)))))
diff --git a/collects/macro-debugger/model/deriv-c.rkt b/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)
diff --git a/collects/macro-debugger/model/deriv-parser.rkt b/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]
diff --git a/collects/macro-debugger/model/deriv-tokens.rkt b/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)
diff --git a/collects/macro-debugger/model/reductions-config.rkt b/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)]
diff --git a/collects/macro-debugger/model/reductions.rkt b/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)
diff --git a/collects/macro-debugger/model/steps.rkt b/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)
diff --git a/collects/macro-debugger/view/step-display.rkt b/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)
