diff --git a/collects/macro-debugger/emit.rkt b/collects/macro-debugger/emit.rkt new file mode 100644 index 0000000..6b24190 --- /dev/null +++ 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 index 09966bf..9221dfc 100644 --- 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 index 9124ea6..3c3c153 100644 --- 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 index 9dc8b0d..9f7d48a 100644 --- 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 index 35b6d1c..160255c 100644 --- 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 index 574a211..82943aa 100644 --- 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 index b75d7b4..4412186 100644 --- 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 index 075c0d1..f33eb92 100644 --- 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)