commit 06aad5203aa196a756adbbd2a2620d2cfe245c26 Author: Ryan Culpepper <ryanc@racket-lang.org> Date: Tue, 8 Aug 2006 20:32:58 +0000 Added the macro stepper svn: r3987 original commit: d91e2b45022c0c043578a5f08b152825db417c07 Diffstat:
| A | collects/macro-debugger/expand.ss | | | 8 | ++++++++ |
| A | collects/macro-debugger/info.ss | | | 6 | ++++++ |
| A | collects/macro-debugger/model/context.ss | | | 142 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | collects/macro-debugger/model/deriv-c.ss | | | 160 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | collects/macro-debugger/model/deriv-parser.ss | | | 470 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | collects/macro-debugger/model/deriv-tokens.ss | | | 143 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | collects/macro-debugger/model/deriv-util.ss | | | 165 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | collects/macro-debugger/model/deriv.ss | | | 311 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | collects/macro-debugger/model/hiding-policies.ss | | | 82 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | collects/macro-debugger/model/reductions-engine.ss | | | 197 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | collects/macro-debugger/model/reductions.ss | | | 523 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | collects/macro-debugger/model/stx-util.ss | | | 97 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | collects/macro-debugger/model/trace-raw.ss | | | 38 | ++++++++++++++++++++++++++++++++++++++ |
| A | collects/macro-debugger/model/trace.ss | | | 79 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | collects/macro-debugger/model/yacc-ext.ss | | | 44 | ++++++++++++++++++++++++++++++++++++++++++++ |
| A | collects/macro-debugger/model/yacc-interrupted.ss | | | 220 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | collects/macro-debugger/syntax-browser.ss | | | 7 | +++++++ |
| A | collects/macro-debugger/syntax-browser/controller.ss | | | 69 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | collects/macro-debugger/syntax-browser/hrule-snip.ss | | | 34 | ++++++++++++++++++++++++++++++++++ |
| A | collects/macro-debugger/syntax-browser/interfaces.ss | | | 123 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | collects/macro-debugger/syntax-browser/partition.ss | | | 161 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | collects/macro-debugger/syntax-browser/prefs.ss | | | 27 | +++++++++++++++++++++++++++ |
| A | collects/macro-debugger/syntax-browser/pretty-helper.ss | | | 81 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | collects/macro-debugger/syntax-browser/pretty-printer.ss | | | 94 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | collects/macro-debugger/syntax-browser/properties.ss | | | 174 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | collects/macro-debugger/syntax-browser/syntax-snip.ss | | | 154 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | collects/macro-debugger/syntax-browser/util.ss | | | 51 | +++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | collects/macro-debugger/syntax-browser/widget.ss | | | 184 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | collects/macro-debugger/view/cursor.ss | | | 88 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
29 files changed, 3932 insertions(+), 0 deletions(-)
diff --git a/collects/macro-debugger/expand.ss b/collects/macro-debugger/expand.ss @@ -0,0 +1,8 @@ + +(module expand mzscheme + (require "view/gui.ss") + (provide expand/step) + + (define (expand/step stx) + (go stx)) + ) diff --git a/collects/macro-debugger/info.ss b/collects/macro-debugger/info.ss @@ -0,0 +1,6 @@ + +(module info (lib "infotab.ss" "setup") + (define name "Macro Debugger") + (define tools '(["tool.ss"])) + (define tool-names '("Macro Stepper")) + (define doc.txt '"doc.txt")) diff --git a/collects/macro-debugger/model/context.ss b/collects/macro-debugger/model/context.ss @@ -0,0 +1,142 @@ + +(module context mzscheme + (require (lib "stx.ss" "syntax")) + (provide (struct ref (n)) + (struct tail (n)) + path-get + pathseg-get + path-replace + pathseg-replace + find-subterm-paths) + + ;; A Path is a (list-of PathSeg) + ;; where the PathSegs are listed outermost to innermost + ;; for example: (path-get #'((a b) (c d)) (list (make-ref 0) (make-ref 1))) = #'b, not #'c + + ;; A PathSeg is one of: + ;; - (make-ref number) + ;; - (make-tail number) + + (define-struct pathseg () #f) + (define-struct (ref pathseg) (n) #f) + (define-struct (tail pathseg) (n) #f) + + ;; path:ref->splicing-tail : PathSeg -> ??? + ;; ???? + (define (path:ref->splicing-tail path) + (unless (ref? path) + (raise-type-error 'path:ref->splicing-tail "ref path" path)) + (make-tail (sub1 (ref-n path)))) + + ;; path-get : syntax Path -> syntax + (define (path-get stx path) + (let loop ([stx stx] [path path]) + (cond [(null? path) stx] + [(pair? path) + (loop (pathseg-get stx (car path)) (cdr path))] + [else + (error 'path-get "bad path: ~s" path)]))) + + ;; pathseg-get : syntax PathSeg -> syntax + (define (pathseg-get stx path) + (cond [(ref? path) (pathseg-get/ref stx (ref-n path))] + [(tail? path) (pathseg-get/tail stx (tail-n path))])) + + ;; pathseg-get/ref : syntax number -> syntax + (define (pathseg-get/ref stx0 n0) + (let loop ([n n0] [stx stx0]) + (unless (stx-pair? stx) + (error 'pathseg-get "ref path out of bounds for syntax: ~s, ~s" + n0 + (syntax-object->datum stx0))) + (if (zero? n) + (stx-car stx) + (loop (sub1 n) (stx-cdr stx))))) + + ;; pathseg-get/tail : syntax number -> syntax + (define (pathseg-get/tail stx0 n0) + (let loop ([n n0] [stx stx0]) + (unless (stx-pair? stx) + (error 'pathseg-get "tail path out of bounds for syntax: ~s, ~s" n0 stx0)) + (if (zero? n) + (stx-cdr stx) + (loop (sub1 n) (stx-cdr stx))))) + + ;; path-replace : syntax Path syntax -> syntax + (define (path-replace stx path x) + (cond [(null? path) x] + [(pair? path) + (let ([pathseg0 (car path)]) + (pathseg-replace stx + pathseg0 + (path-replace (pathseg-get stx pathseg0) + (cdr path) + x)))] + [else + (error 'path-replace "bad path: ~s" path)])) + + ;; pathseg-replace : syntax PathSeg syntax -> syntax + (define (pathseg-replace stx pathseg x) + (cond [(ref? pathseg) (pathseg-replace/ref stx (ref-n pathseg) x)] + [(tail? pathseg) (pathseg-replace/tail stx (tail-n pathseg) x)] + [else (error 'pathseg-replace "bad path: ~s" pathseg)])) + + ;; pathseg-replace/ref : syntax number syntax -> syntax + (define (pathseg-replace/ref stx0 n0 x) + (let loop ([n n0] [stx stx0]) + (unless (stx-pair? stx) + (error 'pathseg-replace "ref path out of bounds for syntax: ~s, ~s" n0 stx0)) + (if (zero? n) + (stx-replcar stx x) + (stx-replcdr stx (loop (sub1 n) (stx-cdr stx)))))) + + ;; pathseg-replace/tail : syntax number syntax -> syntax + (define (pathseg-replace/tail stx0 n0 x) + (let loop ([n n0] [stx stx0]) + (unless (stx-pair? stx) + (error 'pathseg-replace "tail path out of bounds for syntax: ~s, ~s" n0 stx0)) + (if (zero? n) + (stx-replcdr stx x) + (stx-replcdr stx (loop (sub1 n) (stx-cdr stx)))))) + + ;; stx-replcar : syntax syntax -> syntax + (define (stx-replcar stx x) + (cond [(pair? stx) + (cons x (cdr stx))] + [(syntax? stx) + (datum->syntax-object stx (cons x (stx-cdr stx)))] + [else (raise-type-error 'stx-replcar "stx-pair" stx)])) + + ;; stx-replcdr : syntax syntax -> syntax + (define (stx-replcdr stx x) + (cond [(pair? stx) + (cons (car stx) x)] + [(and (syntax? stx) (pair? (syntax-e stx))) + (datum->syntax-object stx (cons (stx-car stx) x))] + [else (raise-type-error 'stx-replcdr "stx-pair" stx)])) + + (define (sd x) + (syntax-object->datum (datum->syntax-object #f x))) + + ;;======= + + ;; find-subterm-paths : syntax syntax -> (list-of Path) + (define (find-subterm-paths subterm term) + (let outer-loop ([term term]) + (cond [(eq? subterm term) + (list null)] + [(stx-pair? term) + ;; Optimized for lists... + (let loop ([term term] [n 0]) + (if (stx-pair? term) + (let* ([seg0 (make-ref n)]) + (append (map (lambda (p) (cons seg0 p)) (outer-loop (stx-car term))) + (if (eq? subterm (stx-cdr term)) + (list (list (make-tail n))) + (loop (stx-cdr term) (add1 n))))) + (let ([seg0 (make-tail n)]) + (map (lambda (p) (cons seg0 p)) + (outer-loop term)))))] + ;; FIXME: more structured cases here: box, vector, ... + [else null]))) + ) diff --git a/collects/macro-debugger/model/deriv-c.ss b/collects/macro-debugger/model/deriv-c.ss @@ -0,0 +1,160 @@ + +(module deriv-c mzscheme + (provide (all-defined)) + + ;; A Derivation is either + ;; - a PRule + ;; - (make-mrule syntax syntax Transformation Derivation) + ;; - (make-lift-deriv syntax syntax Derivation syntax Derivation) + (define-struct deriv (e1 e2) #f) + (define-struct (mrule deriv) (transformation next) #f) + (define-struct (lift-deriv deriv) (first lift-stx second) #f) + + ;; A Transformation is + ;; (make-transformation syntax syntax (listof identifier) syntax syntax (listof LocalAction)) + ;; - resolves is the list of identifiers resolved by the macro keyword + ;; - me1 is the marked version of the input syntax + ;; - me2 is the marked version of the output syntax + (define-struct transformation (e1 e2 resolves me1 me2 locals) #f) + + ;; A LocalAction is one of + ;; - (make-local-expansion Syntax Syntax Syntax Syntax Derivation) + ;; - (make-local-lift Syntax Identifier) + (define-struct local-expansion (e1 e2 me1 me2 deriv) #f) + (define-struct local-lift (expr id) #f) + (define-struct local-lift-end (decl) #f) + + ;; A PRule is one of ... + (define-struct (prule deriv) (resolves) #f) + + ;; Lexical or Mapped Variable + (define-struct (p:variable prule) () #f) + + ;; Definitions: one subterm each + (define-struct (p:define-syntaxes prule) (rhs) #f) + (define-struct (p:define-values prule) (rhs) #f) + + ;; Simple expressions + (define-struct (p:if prule) (full? test then else) #f) + (define-struct (p:wcm prule) (key mark body) #f) + (define-struct (p:set! prule) (id-resolves rhs) #f) + (define-struct (p:set!-macro prule) (deriv) #f) + + ;; Sequence-containing expressions + (define-struct (p:begin prule) (lderiv) #f) + (define-struct (p:begin0 prule) (first lderiv) #f) + (define-struct (p:#%app prule) (tagged-stx lderiv) #f) + + ;; Binding expressions + (define-struct (p:lambda prule) (renames body) #f) + (define-struct (p:case-lambda prule) (renames+bodies) #f) + (define-struct (p:let-values prule) (renames rhss body) #f) + (define-struct (p:let*-values prule) (inner) #f) + (define-struct (p:letrec-values prule) (renames rhss body) #f) + (define-struct (p:letrec-syntaxes+values prule) (srenames srhss vrenames vrhss body) #f) + + ;; Atomic primitives: no subterms + (define-struct (p::STOP prule) () #f) + (define-struct (p:#%datum p::STOP) (tagged-stx) #f) + (define-struct (p:#%top p::STOP) (tagged-stx) #f) + (define-struct (p:quote p::STOP) () #f) + (define-struct (p:quote-syntax p::STOP) () #f) + (define-struct (p:require p::STOP) () #f) + (define-struct (p:require-for-syntax p::STOP) () #f) + (define-struct (p:require-for-template p::STOP) () #f) + (define-struct (p:provide p::STOP) () #f) + + ;; for stop expander + (define-struct (p:stop p::STOP) () #f) + ;; for early primitive errors + (define-struct (p:unknown p::STOP) () #f) + + ;; Module stuff.... hairy + (define-struct (p:module prule) (body) #f) + (define-struct (p:#%module-begin prule) (pass1 pass2) #f) + ;; where pass1 is a ModPass1 + ;; and pass2 is a ModPass2 + + ;; Artificial Rename + ;; FIXME: Go back and add more info later, such as rename-identity + (define-struct (p:rename prule) (renames inner) #f) + + ;; Synthetic primitive + (define-struct (p:synth prule) (subterms) #f) + ;; where subterms is list-of-Subterm + + ;; A Subterm is one of + ;; - (make-s:subterm Path Derivation) + (define-struct s:subterm (path deriv) #f) + + + + ;; A ListDerivation is (make-lderiv Syntaxes Syntaxes (listof Derivation)) + (define-struct lderiv (es1 es2 derivs) #f) + + ;; A BlockDerivation is (make-bderiv syntax-list syntax-list BlockPass1 Transition LDeriv) + ;; where Transition = (union 'letrec 'list) + (define-struct bderiv (es1 es2 pass1 trans pass2) #f) + + ;; A BlockPass1 is list-of-BRule + ;; A BRule is one of + ;; - (make-b:defvals BlockRename Derivation/#f) + ;; - (make-b:devstx BlockRename Derivation Derivation) + ;; - (make-b:splice BlockRename Derivation Syntaxes) + ;; - (make-b:expr BlockRename Derivation) + ;; - (make-b:begin BlockRename Derivation List-of-BRule) + ;; This last only used in macro-hiding + ;; A BlockRename is (cons syntax syntax) + ;; It always applies only to the current block element + + (define-struct brule (renames)) + (define-struct (b:defvals brule) (head) #f) + (define-struct (b:defstx brule) (deriv rhs) #f) + (define-struct (b:splice brule) (head tail) #f) + (define-struct (b:expr brule) (head) #f) + (define-struct (b:begin brule) (head inner) #f) + + ;; A ModPass1 is a list of ModRule1 + ;; A ModRule1 is one of + ;; - (make-mod:prim Derivation ModPrim) + ;; - (make-mod:splice Derivation tail) + ;; - (make-mod:lift Derivation tail) + ;; - (make-mod:begin Derivation (list-of ModRule1)) + + ;; A ModPrim is a PRule in: + ;; - (make-p:define-values syntax syntax () #f) + ;; - (make-p:define-syntaxes syntax syntax () Derivation) + ;; - (make-p:require syntax syntax ()) + ;; - (make-p:require-for-syntax syntax syntax ()) + ;; - (make-p:require-for-template syntax syntax ()) + ;; - (make-p:provide syntax syntax ()) + ;; - #f + + ;; A ModPass2 is a list of ModRule2 + ;; A ModRule2 is one of + ;; - (make-mod:skip) + ;; - (make-mod:cons Derivation) + ;; - (make-mod:lift Derivation syntaxes) + + (define-struct modrule ()) + (define-struct (mod:cons modrule) (head) #f) + (define-struct (mod:prim modrule) (head prim) #f) + (define-struct (mod:skip modrule) () #f) + (define-struct (mod:splice modrule) (head tail) #f) + (define-struct (mod:lift modrule) (head tail) #f) + (define-struct (mod:lift-end modrule) (tail) #f) + (define-struct (mod:begin modrule) (head inner) #f) + + ;; Handling Syntax Errors + ;; ---------------------- + + ;; An interrupted node is (make-interrupted-wrap symbol node) + ;; where node is one of Derivation, ListDerivation, BlockDerivation, + ;; PRule, MRule, BRule, or ModRule + (define-struct interrupted-wrap (tag inner) #f) + + ;; An error-wrapped node is (make-error-wrap exception symbol node) + ;; where node is one of PRule, MRule, BRule, or ModRule + (define-struct error-wrap (exn tag inner) #f) + + ) diff --git a/collects/macro-debugger/model/deriv-parser.ss b/collects/macro-debugger/model/deriv-parser.ss @@ -0,0 +1,470 @@ + +(module deriv-parser mzscheme + (require "yacc-ext.ss" + "yacc-interrupted.ss" + "deriv.ss" + "deriv-tokens.ss") + (provide parse-derivation) + + (define (deriv-error ok? name value start end) + (if ok? + (error 'derivation-parser "error on token #~a: <~s, ~s>" start name value) + (error 'derivation-parser "bad token #~a" start))) + + ;; PARSER + + (define parse-derivation + (parser + (options (start Expansion) + (src-pos) + (tokens basic-tokens prim-tokens renames-tokens) + (end EOF) + (error deriv-error) + #;(debug "debug-parser.txt")) + + ;; Required (non-hygienically) by productions/I + (productions + #;(Error [(syntax-error) $1]) + (NoError [() #f])) + + ;; tokens + (skipped-token-values visit resolve next next-group return + enter-macro macro-pre-transform macro-post-transform exit-macro + enter-prim exit-prim + enter-block block->list block->letrec splice + enter-list exit-list + enter-check exit-check + local-post exit-local + phase-up module-body + renames-lambda + renames-case-lambda + renames-let + renames-letrec-syntaxes + renames-block + IMPOSSIBLE) + + ;; Entry point + (productions + (Expansion + [(EE/Lifts) $1] + [(EE/Lifts/Interrupted) $1])) + + (productions/I + + ;; Expansion of an expression + ;; EE Answer = Derivation (I) + (EE + (#:no-wrap) + [(visit (? PrimStep 'prim) return) + $2] + [(visit (? TaggedPrimStep 'prim) return) + ($2 $1)] + [((? EE/Macro)) + $1]) + (EE/Macro + [(visit (? MacroStep 'macro) (? EE 'next)) + (make-mrule $1 (and (deriv? $3) (deriv-e2 $3)) $2 $3)]) + + ;; Expand/Lifts + ;; Expand/Lifts Answer = Derivation (I) + (EE/Lifts + (#:no-wrap) + [((? EE)) $1] + [((? EE/Lifts+)) $1]) + (EE/Lifts+ + [(EE lift-loop (? EE/Lifts)) + (let ([initial (deriv-e1 $1)] + [final (and (deriv? $3) (deriv-e2 $3))]) + (make-lift-deriv initial final $1 $2 $3))]) + + ;; Evaluation + (Eval + [() #f]) + + ;; Expansion of an expression to primitive form + ;; CheckImmediateMacro Answer = Derivation (I) + (CheckImmediateMacro + (#:no-wrap) + [(enter-check (? CheckImmediateMacro/Inner) exit-check) + ($2 $1 $3 (lambda (ce1 ce2) (make-p:stop ce1 ce2 null)))]) + (CheckImmediateMacro/Inner + (#:args e1 e2 k) + [() + (k e1 e2)] + [(visit (? MacroStep 'macro) return (? CheckImmediateMacro/Inner 'next)) + (let ([next ($4 $3 e2 k)]) + (make-mrule $1 (and (deriv? next) (deriv-e2 next)) $2 next))]) + + ;; Expansion of multiple expressions, next-separated + ;; NextEEs Answer = (listof Derivation) + (NextEEs + (#:no-wrap) + (#:skipped null) + [() null] + [(next (? EE 'first) (? NextEEs 'rest)) (cons $2 $3)]) + + ;; Keyword resolution + ;; Resolves Answer = (listof identifier) + (Resolves [() null] + [(resolve Resolves) (cons $1 $2)]) + + ;; Single macro step (may contain local-expand calls) + ;; MacroStep Answer = Transformation (I,E) + (MacroStep + [(Resolves enter-macro + macro-pre-transform (? LocalActions 'locals) (! 'transform) macro-post-transform + exit-macro) + (make-transformation $2 $7 $1 $3 $6 $4)]) + + ;; Local actions taken by macro + ;; LocalAction Answer = (list-of LocalAction) + (LocalActions + (#:no-wrap) + (#:skipped null) + [() null] + [((? LocalAction) (? LocalActions)) (cons $1 $2)]) + + (LocalAction + [(enter-local local-pre (? EE) local-post exit-local) + (make-local-expansion $1 $5 $2 $4 $3)] + [(lift) + (make-local-lift (car $1) (cdr $1))] + [(lift-statement) + (make-local-lift-end $1)]) + + ;; Multiple calls to local-expand + ;; EEs Answer = (listof Derivation) + (EEs + (#:skipped null) + (#:no-wrap) + [() null] + [((? EE 'first) (? EEs 'rest)) (cons $1 $2)]) + + ;; Primitive syntax step + ;; PrimStep Answer = PRule + (PrimStep + (#:no-wrap) + [(Resolves NoError enter-prim (? Prim) exit-prim) + ($4 $3 $5 $1)] + [(Resolves variable) + (make-p:variable (car $2) (cdr $2) $1)]) + + ;; Tagged Primitive syntax + ;; TaggedPrimStep Answer = syntax -> PRule + (TaggedPrimStep + (#:no-wrap) + (#:args orig-stx) + [(Resolves ! IMPOSSIBLE) + (make-p:unknown orig-stx #f $1)] + [(Resolves NoError enter-prim (? TaggedPrim) exit-prim) + ($4 orig-stx $5 $1 $3)]) + + ;; Primitive + ;; Prim Answer = syntax syntax (listof identifier) -> PRule + (Prim + (#:args e1 e2 rs) + (#:no-wrap) + [((? PrimModule)) ($1 e1 e2 rs)] + [((? Prim#%ModuleBegin)) ($1 e1 e2 rs)] + [((? PrimDefineSyntaxes)) ($1 e1 e2 rs)] + [((? PrimDefineValues)) ($1 e1 e2 rs)] + [((? PrimIf)) ($1 e1 e2 rs)] + [((? PrimWCM)) ($1 e1 e2 rs)] + [((? PrimSet)) ($1 e1 e2 rs)] + [((? PrimBegin)) ($1 e1 e2 rs)] + [((? PrimBegin0)) ($1 e1 e2 rs)] + [((? PrimLambda)) ($1 e1 e2 rs)] + [((? PrimCaseLambda)) ($1 e1 e2 rs)] + [((? PrimLetValues)) ($1 e1 e2 rs)] + [((? PrimLet*Values)) ($1 e1 e2 rs)] + [((? PrimLetrecValues)) ($1 e1 e2 rs)] + [((? PrimLetrecSyntaxes+Values)) ($1 e1 e2 rs)] + [((? PrimSTOP)) ($1 e1 e2 rs)] + [((? PrimQuote)) ($1 e1 e2 rs)] + [((? PrimQuoteSyntax)) ($1 e1 e2 rs)] + [((? PrimRequire)) ($1 e1 e2 rs)] + [((? PrimRequireForSyntax)) ($1 e1 e2 rs)] + [((? PrimRequireForTemplate)) ($1 e1 e2 rs)] + [((? PrimProvide)) ($1 e1 e2 rs)]) + + ;; Tagged Primitive + ;; TaggedPrim Answer = syntax syntax (list-of identifier) syntax -> PRule + (TaggedPrim + (#:args e1 e2 rs tagged-stx) + (#:no-wrap) + [((? Prim#%App)) ($1 e1 e2 rs tagged-stx)] + [((? Prim#%Datum)) ($1 e1 e2 rs tagged-stx)] + [((? Prim#%Top)) ($1 e1 e2 rs tagged-stx)]) + + ;; Modules + (PrimModule + (#:args e1 e2 rs) + [(prim-module ! (? EE 'body)) + (make-p:module e1 e2 rs $3)] + + ;; One form after language ... macro that expands into #%module-begin + [(prim-module NoError next + enter-check (? CheckImmediateMacro/Inner) exit-check + (! 'module-begin) next (? EE)) + (make-p:module e1 e2 rs + ($5 $4 + (and (deriv? $9) (deriv-e2 $9)) + (lambda (ce1 ce2) $9)))]) + + (Prim#%ModuleBegin + (#:args e1 e2 rs) + [(prim-#%module-begin ! (? ModulePass1 'pass1) next-group (? ModulePass2 'pass2)) + (make-p:#%module-begin e1 e2 rs $3 $5)]) + + (ModulePass1 + (#:skipped null) + (#:no-wrap) + [() null] + [(next (? ModulePass1-Part) (? ModulePass1)) + (cons $2 $3)] + [(lift-end-loop (? ModulePass1)) + (cons (make-mod:lift-end $1) $2)]) + + (ModulePass1-Part + [((? EE) (? ModulePass1/Prim)) + (make-mod:prim $1 $2)] + [(EE splice) + (make-mod:splice $1 $2)] + [(EE lift-loop) + (make-mod:lift $1 $2)]) + + (ModulePass1/Prim + [(enter-prim prim-define-values ! exit-prim) + (make-p:define-values $1 $4 null #f)] + [(enter-prim prim-define-syntaxes ! phase-up (? EE) exit-prim) + (make-p:define-syntaxes $1 $6 null $5)] + [(enter-prim prim-require ! exit-prim) + (make-p:require $1 $4 null)] + [(enter-prim prim-require-for-syntax ! exit-prim) + (make-p:require-for-syntax $1 $4 null)] + [(enter-prim prim-require-for-template ! exit-prim) + (make-p:require-for-template $1 $4 null)] + [(enter-prim prim-provide ! exit-prim) + (make-p:provide $1 $4 null)] + [() + #f]) + + (ModulePass2 + (#:skipped null) + (#:no-wrap) + [() null] + [(next (? ModulePass2-Part) (? ModulePass2)) + (cons $2 $3)] + [(lift-end-loop (? ModulePass2)) + (cons (make-mod:lift-end $1) $2)]) + + (ModulePass2-Part + ;; not normal; already handled + [() + (make-mod:skip)] + ;; normal: expand completely + [((? EE)) + (make-mod:cons $1)] + ;; catch lifts + [(EE lift-loop) + (make-mod:lift $1 $2)]) + + ;; Definitions + (PrimDefineSyntaxes + (#:args e1 e2 rs) + [(prim-define-syntaxes ! (? EE/Lifts)) + (make-p:define-syntaxes e1 e2 rs $3)]) + + (PrimDefineValues + (#:args e1 e2 rs) + [(prim-define-values ! (? EE)) + (make-p:define-values e1 e2 rs $3)]) + + ;; Simple expressions + (PrimIf + (#:args e1 e2 rs) + [(prim-if ! (? EE 'test) next (? EE 'then) next (? EE 'else)) + (make-p:if e1 e2 rs #t $3 $5 $7)] + [(prim-if NoError next-group (? EE 'test) next (? EE 'then)) + (make-p:if e1 e2 rs #f $4 $6 #f)]) + + (PrimWCM + (#:args e1 e2 rs) + [(prim-wcm ! (? EE 'key) next (? EE 'mark) next (? EE 'body)) + (make-p:wcm e1 e2 rs $3 $5 $7)]) + + ;; Sequence-containing expressions + (PrimBegin + (#:args e1 e2 rs) + [(prim-begin ! (? EL)) + (make-p:begin e1 e2 rs $3)]) + + (PrimBegin0 + (#:args e1 e2 rs) + [(prim-begin0 ! next (? EE) next (? EL)) + (make-p:begin0 e1 e2 rs $4 $6)]) + + (Prim#%App + (#:args e1 e2 rs tagged-stx) + [(prim-#%app !) + (make-p:#%app e1 e2 rs tagged-stx (make-lderiv null null null))] + [(prim-#%app NoError (? EL)) + (make-p:#%app e1 e2 rs tagged-stx $3)]) + + ;; Binding expressions + (PrimLambda + (#:args e1 e2 rs) + [(prim-lambda ! renames-lambda (? EB)) + (make-p:lambda e1 e2 rs $3 $4)]) + + (PrimCaseLambda + (#:args e1 e2 rs) + [(prim-case-lambda ! (? NextCaseLambdaClauses)) + (make-p:case-lambda e1 e2 rs $3)]) + + (NextCaseLambdaClauses + (#:skipped null) + [(next ! renames-case-lambda (? EB 'first) (? NextCaseLambdaClauses 'rest)) + (cons (cons $3 $4) $5)] + [() null]) + + (PrimLetValues + (#:args e1 e2 rs) + [(prim-let-values ! renames-let (? NextEEs 'rhss) next-group (? EB 'body)) + (make-p:let-values e1 e2 rs $3 $4 $6)]) + + (PrimLet*Values + (#:args e1 e2 rs) + ;; let*-values with bindings is "macro-like" + [(prim-let*-values ! (? EE)) + (make-p:let*-values e1 e2 rs $3)] + ;; No bindings... model as "let" + [(prim-let*-values NoError renames-let (? NextEEs 'rhss) next-group (? EB 'body)) + (make-p:let-values e1 e2 rs $3 $4 $6)]) + + (PrimLetrecValues + (#:args e1 e2 rs) + [(prim-letrec-values ! renames-let (? NextEEs 'rhss) next-group (? EB 'body)) + (make-p:letrec-values e1 e2 rs $3 $4 $6)]) + + ;; Might have to deal with let*-values + + (PrimLetrecSyntaxes+Values + (#:args e1 e2 rs) + [(prim-letrec-syntaxes+values (! 'bad-syntax) renames-letrec-syntaxes + (? NextBindSyntaxess 'srhss) next-group (? EB 'body)) + (make-p:letrec-syntaxes+values e1 e2 rs $3 $4 #f null $6)] + [(prim-letrec-syntaxes+values NoError renames-letrec-syntaxes + NextBindSyntaxess next-group + prim-letrec-values (! 'impossible?) + renames-let (? NextEEs 'vrhss) next-group (? EB 'body)) + (make-p:letrec-syntaxes+values e1 e2 rs $3 $4 $8 $9 $11)]) + + ;; Atomic expressions + (Prim#%Datum + (#:args e1 e2 rs tagged-stx) + [(prim-#%datum !) (make-p:#%datum e1 e2 rs tagged-stx)]) + + (Prim#%Top + (#:args e1 e2 rs tagged-stx) + [(prim-#%top !) (make-p:#%top e1 e2 rs tagged-stx)]) + + (PrimSTOP + (#:args e1 e2 rs) + [(prim-stop !) (make-p:stop e1 e2 rs)]) + + (PrimQuote + (#:args e1 e2 rs) + [(prim-quote !) (make-p:quote e1 e2 rs)]) + + (PrimQuoteSyntax + (#:args e1 e2 rs) + [(prim-quote-syntax !) (make-p:quote-syntax e1 e2 rs)]) + + (PrimRequire + (#:args e1 e2 rs) + [(prim-require !) (make-p:require e1 e2 rs)]) + + (PrimRequireForSyntax + (#:args e1 e2 rs) + [(prim-require-for-syntax !) (make-p:require-for-syntax e1 e2 rs)]) + + (PrimRequireForTemplate + (#:args e1 e2 rs) + [(prim-require-for-template !) (make-p:require-for-template e1 e2 rs)]) + + (PrimProvide + (#:args e1 e2 rs) + [(prim-provide !) (make-p:provide e1 e2 rs)]) + + (PrimSet + (#:args e1 e2 rs) + [(prim-set! ! Resolves next (? EE)) + (make-p:set! e1 e2 rs $3 $5)] + [(prim-set! NoError (? MacroStep 'macro) (? EE 'continue)) + (make-p:set!-macro e1 e2 rs (make-mrule e1 (and (deriv? $4) (deriv-e2 $4)) $3 $4))]) + + ;; Blocks + ;; EB Answer = BlockDerivation + (EB + [(enter-block (? BlockPass1 'pass1) block->list (? EL 'pass2)) + (make-bderiv $1 + (and (lderiv? $4) (lderiv-es2 $4)) + $2 + 'list + $4)] + [(enter-block BlockPass1 block->letrec (? EL 'pass2)) + (make-bderiv $1 + (and (lderiv? $4) (lderiv-es2 $4)) + $2 + 'letrec + $4)]) + + ;; BlockPass1 Answer = (list-of BRule) + (BlockPass1 + (#:no-wrap) + (#:skipped null) + [() null] + [((? BRule) (? BlockPass1)) + (cons $1 $2)]) + + ;; BRule Answer = BRule + (BRule + [(next ! IMPOSSIBLE) + #f] + [(next NoError renames-block (? CheckImmediateMacro 'check)) + (make-b:expr $3 $4)] + [(next NoError renames-block CheckImmediateMacro prim-begin ! splice !) + (make-b:splice $3 $4 $7)] + [(next NoError renames-block CheckImmediateMacro prim-define-values !) + (make-b:defvals $3 $4)] + [(next NoError renames-block CheckImmediateMacro + prim-define-syntaxes (? BindSyntaxes 'bind)) + (make-b:defstx $3 $4 $5)]) + + ;; BindSyntaxes Answer = Derivation + (BindSyntaxes + [(phase-up (? EE/Lifts) Eval) $2]) + + ;; NextBindSyntaxess Answer = (list-of Derivation) + (NextBindSyntaxess + (#:skipped null) + [() null] + [(next (? BindSyntaxes 'first) (? NextBindSyntaxess 'rest)) (cons $2 $3)]) + + ;; Lists + ;; EL Answer = ListDerivation + (EL + (#:skipped #f) + [(enter-list ! (? EL*) exit-list) (make-lderiv $1 $4 $3)]) + + ;; EL* Answer = (listof Derivation) + (EL* + (#:no-wrap) + (#:skipped null) + [() null] + [(next (? EE 'first) (? EL* 'rest)) (cons $2 $3)]) + + ))) + + ) diff --git a/collects/macro-debugger/model/deriv-tokens.ss b/collects/macro-debugger/model/deriv-tokens.ss @@ -0,0 +1,143 @@ + +(module deriv-tokens mzscheme + (require (lib "lex.ss" "parser-tools") + "deriv.ss") + (provide (all-defined)) + + (define-tokens basic-tokens + (visit ; syntax + resolve ; identifier + next ; . + next-group ; . + enter-macro ; syntax + macro-pre-transform ; syntax + macro-post-transform ; syntax + exit-macro ; syntax + enter-prim ; syntax + exit-prim ; syntax + return ; syntax + enter-block ; syntaxes + block->list ; syntaxes + block->letrec ; syntax(es?) + splice ; syntaxes + enter-list ; syntaxes + exit-list ; syntaxes + enter-check ; syntax + exit-check ; syntax + phase-up ; . + module-body ; (list-of (cons syntax boolean)) + ... ; . + EOF ; . + syntax-error ; exn + lift-loop ; syntax + lift-end-loop ; syntax + lift ; (cons syntax id) + lift-statement ; syntax + enter-local ; syntax + local-pre ; syntax + local-post ; syntax + exit-local ; syntax + + IMPOSSIBLE ; useful for error-handling clauses that have no NoError counterpart + )) + + (define-tokens renames-tokens + (renames-lambda ; (cons syntax syntax) + renames-case-lambda ; (cons syntax syntax) + renames-let ; (cons (listof syntax) syntax) + renames-letrec-syntaxes ; (cons (listof syntax) (cons (listof syntax) syntax)) + renames-block ; (cons syntax syntax) ... different, contains both pre+post + )) + (define-tokens prim-tokens + (prim-module prim-#%module-begin + prim-define-syntaxes prim-define-values + prim-if prim-wcm prim-begin prim-begin0 prim-#%app prim-lambda + prim-case-lambda prim-let-values prim-let*-values prim-letrec-values + prim-letrec-syntaxes+values prim-#%datum prim-#%top prim-stop + prim-quote prim-quote-syntax prim-require prim-require-for-syntax + prim-require-for-template prim-provide + prim-set! + + variable ; (cons identifier identifier) + )) + + ;; ** Signals to tokens + + (define signal-mapping + `((EOF . EOF) + (error . ,token-syntax-error) + (0 . ,token-visit) + (1 . ,token-resolve) + (2 . ,token-return) + (3 . ,token-next) + (4 . ,token-enter-list) + (5 . ,token-exit-list) + (6 . ,token-enter-prim) + (7 . ,token-exit-prim) + (8 . ,token-enter-macro) + (9 . ,token-exit-macro) + (10 . ,token-enter-block) + (11 . ,token-splice) + (12 . ,token-block->list) + (13 . ,token-next-group) + (14 . ,token-block->letrec) + #;(15 . renamer) + (16 . ,token-renames-let) + (17 . ,token-renames-lambda) + (18 . ,token-renames-case-lambda) + (19 . ,token-renames-letrec-syntaxes) + (20 . phase-up) + (21 . ,token-macro-pre-transform) + (22 . ,token-macro-post-transform) + (23 . ,token-module-body) + (24 . ,token-renames-block) + + (100 . prim-stop) + (101 . prim-module) + (102 . prim-#%module-begin) + (103 . prim-define-syntaxes) + (104 . prim-define-values) + (105 . prim-if) + (106 . prim-wcm) + (107 . prim-begin) + (108 . prim-begin0) + (109 . prim-#%app) + (110 . prim-lambda) + (111 . prim-case-lambda) + (112 . prim-let-values) + (113 . prim-letrec-values) + (114 . prim-letrec-syntaxes+values) + (115 . prim-#%datum) + (116 . prim-#%top) + (117 . prim-quote) + (118 . prim-quote-syntax) + (119 . prim-require) + (120 . prim-require-for-syntax) + (121 . prim-require-for-template) + (122 . prim-provide) + (123 . prim-set!) + (124 . prim-let*-values) + (125 . ,token-variable) + (126 . ,token-enter-check) + (127 . ,token-exit-check) + (128 . ,token-lift-loop) + (129 . ,token-lift) + (130 . ,token-enter-local) + (131 . ,token-exit-local) + (132 . ,token-local-pre) + (133 . ,token-local-post) + (134 . ,token-lift-statement) + (135 . ,token-lift-end-loop) + )) + + (define (tokenize sig-n val pos) + (let ([p (assv sig-n signal-mapping)]) + (if (pair? p) + (make-position-token + (cond [(procedure? (cdr p)) ((cdr p) val)] + [(symbol? (cdr p)) (cdr p)]) + pos + pos) + (error 'tokenize "bad signal: ~s" sig-n)))) + + ) diff --git a/collects/macro-debugger/model/deriv-util.ss b/collects/macro-debugger/model/deriv-util.ss @@ -0,0 +1,165 @@ + +(module deriv-util mzscheme + (require "deriv.ss" + (lib "plt-match.ss")) + (provide IntW + ErrW + AnyQ + IntQ + + $$ + $$I + $$E + Wrap + lift/wrap + rewrap + rewrap/nt + outer-rewrap + lift/deriv-e1 + lift/deriv-e2 + wrapped?) + + ;; IntW + ;; Matches only interrupted wraps + (define-match-expander IntW + (syntax-rules () + [(IntW S (var ...)) + (struct interrupted-wrap (_ (struct S (var ...))))] + [(IntW S (var ...) tag) + (struct interrupted-wrap (tag (struct S (var ...))))])) + + ;; ErrW + ;; Matches only error wraps + (define-match-expander ErrW + (syntax-rules () + [(ErrW S (var ...)) + (struct error-wrap (_ _ (struct S (var ...))))] + [(ErrW S (var ...) exn) + (struct error-wrap (exn _ (struct S (var ...))))] + [(ErrW S (var ...) tag exn) + (struct error-wrap (exn tag (struct S (var ...))))])) + + ;; AnyQ matcher + ;; Matches unwrapped, interrupted wrapped, or error wrapped + (define-match-expander AnyQ + (syntax-rules () + [(AnyQ S (var ...)) + (or (struct S (var ...)) + (struct interrupted-wrap (_ (struct S (var ...)))) + (struct error-wrap (_ _ (struct S (var ...)))))] + [(AnyQ S (var ...) exni) + (or (and (struct S (var ...)) + (app (lambda (_) #f) exni)) + (and (struct interrupted-wrap (tag (struct S (var ...)))) + (app (lambda (ew) (cons #f (interrupted-wrap-tag ew))) exni)) + (and (struct error-wrap (exn tag (struct S (var ...)))) + (app (lambda (ew) (cons (error-wrap-exn ew) (error-wrap-tag ew))) exni)))])) + + ;; IntQ + ;; Matches interrupted wraps and unwrapped structs + (define-match-expander IntQ + (syntax-rules () + [(IntQ S (var ...)) + (or (struct S (var ...)) + (struct interrupted-wrap (_ (struct S (var ...)))))] + [(IntQ S (var ...) tag) + (or (and (struct S (var ...)) + (app (lambda (_) #f) tag)) + (struct interrupted-wrap (tag (struct S (var ...)))))])) + + ;; $$ match form + ;; ($$ struct-name (var ...) info) + ;; If normal instance of struct-name, binds info to #f + ;; If interrupted-wrapped, binds info to (cons #f symbol/#f) + ;; If error-wrapped, binds info to (cons exn symbol/#f) + (define-match-expander $$ + (lambda (stx) + (syntax-case stx () + [($$ S (var ...) info) + #'(or (and (struct S (var ...)) + (app (lambda (_) #f) info)) + (and (struct interrupted-wrap (tag (struct S (var ...)))) + (app (lambda (ew) (cons #f (interrupted-wrap-tag ew))) info)) + (and (struct error-wrap (exn tag (struct S (var ...)))) + (app (lambda (ew) (cons (error-wrap-exn ew) (error-wrap-tag ew))) + info)))] + [($$ S (var ...)) + #'(struct S (var ...))]))) + + (define-match-expander $$I + (lambda (stx) + (syntax-case stx () + [($$I S (var ...)) + #'(or (struct interrupted-wrap (tag (struct S (var ...)))) + (struct S (var ...)))] + [($$I S (var ...) tag) + #'(or (struct interrupted-wrap (tag (struct S (var ...)))) + (and (app (lambda (_) #f) tag) + (struct S (var ...))))]))) + + (define-match-expander $$E + (lambda (stx) + (syntax-case stx () + [($$E S (var ...)) + #'(or (struct interrupted-wrap (_tag (struct S (var ...)))) + (struct error-wrap (_exn _tag (struct S (var ...)))) + (struct S (var ...)))]))) + + (define-match-expander Wrap + (syntax-rules () + [(Wrap x) + (or (struct interrupted-wrap (_tag x)) + (struct error-wrap (_exn _tag x)) + x)])) + + ;; lift/wrap : ('a -> 'b) boolean -> Wrap('a) -> Wrap('b) + (define (lift/wrap f preserve-tag?) + (lambda (x) + (match x + [(struct interrupted-wrap (tag inner)) + (make-interrupted-wrap (and preserve-tag? tag) (f inner))] + [(struct error-wrap (exn tag inner)) + (make-error-wrap exn (and preserve-tag? tag) (f inner))] + [x + (f x)]))) + + ;; rewrap : Wrap('a) 'b -> Wrap('b) + (define (rewrap x y) + (if (wrapped? y) + y + ((lift/wrap (lambda (x) y) #t) x))) + + ;; rewrap/nt : Wrap('a) 'b -> Wrap('b) + (define (rewrap/nt x y) + (if (wrapped? y) + y + ((lift/wrap (lambda (x) y) #f) x))) + + (define (outer-rewrap x y) + (if (and (wrapped? x) (not (wrapped? y))) + (make-interrupted-wrap #f y) + y)) + + (define (lift/deriv-e1 x) + (match x + [(AnyQ deriv (e1 _)) e1])) + + (define (lift/deriv-e2 x) + (match x + [(AnyQ deriv (_ e2)) e2])) + + (define (wrapped? x) + (or (interrupted-wrap? x) + (error-wrap? x))) + +; (define-match-expander $$E +; (lambda (stx) +; (syntax-case stx (@) +; [($$E S (var ...)) +; #'($$ S (var ...) _exni)] +; [($$E S (var ...) @ tag) +; #'($$ S (var ...) (cons #f tag))] +; [($$E S (var ...) @ tag exn) +; #'($$ S (var ...) (cons exn tag))]))) + + ) diff --git a/collects/macro-debugger/model/deriv.ss b/collects/macro-debugger/model/deriv.ss @@ -0,0 +1,311 @@ + +(module deriv mzscheme + (require (lib "contract.ss") + (lib "stx.ss" "syntax") + "deriv-c.ss") + + ;; NO CONTRACTS + +; (provide (all-from "deriv-c.ss")) + + + ;; CONTRACTS + + (define (stx-list-like? x) + (or (syntax? x) + (null? x) + (and (pair? x) (syntax? (car x)) (stx-list-like? (cdr x))))) + + (define (maybe c) (or/c c false/c)) + + (define node/c (or/c deriv? lderiv? bderiv? transformation? brule? modrule?)) + (define errnode/c (or/c prule? transformation? lderiv? brule? modrule?)) + (define tag/c (maybe symbol?)) + (define syntax/f (maybe syntax?)) + (define syntaxes/c stx-list-like?) + (define syntaxes/f (maybe syntaxes/c)) + + (define (anyw C) + (or/c (struct/c error-wrap exn? tag/c C) + (struct/c interrupted-wrap tag/c C))) + (define (anyq C) + (or/c C (anyw C))) + (define (intw C) + (struct/c interrupted-wrap tag/c C)) + (define (intq C) + (or/c C (intw C))) + + (define resolves/c (listof identifier?)) + + (provide/contract + (struct deriv + ([e1 syntax?] + [e2 syntax/f])) + (struct (mrule deriv) + ([e1 syntax?] + [e2 syntax/f] + [transformation (anyq transformation?)] + [next (maybe (anyq deriv?))])) + (struct (lift-deriv deriv) + ([e1 syntax?] + [e2 syntax/f] + [first deriv?] + [lift-stx syntax?] + [second (anyq deriv?)])) + (struct transformation + ([e1 syntax?] + [e2 syntax/f] + [resolves resolves/c] + [me1 syntax?] + [me2 syntax/f] + [locals (listof (or/c local-expansion? local-lift? local-lift-end?))])) + (struct (prule deriv) + ([e1 syntax?] + [e2 syntax/f] + [resolves resolves/c])) + + (struct lderiv + ([es1 syntaxes/c] + [es2 syntaxes/f] + [derivs (listof (anyq deriv?))])) + + (struct interrupted-wrap + ([tag (or/c symbol? false/c)] + [inner node/c])) + (struct error-wrap + ([exn exn?] + [tag (or/c symbol? false/c)] + [inner errnode/c]))) + + + (provide ;(struct deriv (e1 e2)) + ;(struct mrule (transformation next)) + ;(struct lift-deriv (first lift-stx second)) + + ;(struct transformation (e1 e2 resolves me1 me2 locals)) + + (struct local-expansion (e1 e2 me1 me2 deriv)) + (struct local-lift (expr id)) + (struct local-lift-end (decl)) + + ;(struct prule (resolves)) + (struct p:variable ()) + (struct p:define-syntaxes (rhs)) + (struct p:define-values (rhs)) + (struct p:if (full? test then else)) + (struct p:wcm (key mark body)) + (struct p:set! (id-resolves rhs)) + (struct p:set!-macro (deriv)) + (struct p:begin (lderiv)) + (struct p:begin0 (first lderiv)) + (struct p:#%app (tagged-stx lderiv)) + (struct p:lambda (renames body)) + (struct p:case-lambda (renames+bodies)) + (struct p:let-values (renames body)) + (struct p:let*-values (inner)) + (struct p:letrec-values (renames rhss body)) + (struct p:letrec-syntaxes+values (srenames srhss vrenames vrhss body)) + (struct p:module (body)) + (struct p:#%module-begin (pass1 pass2)) + (struct p::STOP ()) + (struct p:#%datum (tagged-stx)) + (struct p:#%top (tagged-stx)) + (struct p:quote ()) + (struct p:quote-syntax ()) + (struct p:require ()) + (struct p:require-for-syntax ()) + (struct p:require-for-template ()) + (struct p:provide ()) + (struct p:stop ()) + (struct p:unknown ()) + (struct p:rename (renames inner)) + + (struct p:synth (subterms)) + (struct s:subterm (path deriv)) + + ;(struct lderiv (es1 es2 derivs)) + (struct bderiv (es1 es2 pass1 trans pass2)) + + (struct brule (renames)) + (struct b:defvals (head)) + (struct b:defstx (deriv rhs)) + (struct b:splice (head tail)) + (struct b:expr (head)) + (struct b:begin (head inner)) + + (struct modrule ()) + (struct mod:cons (head)) + (struct mod:prim (head prim)) + (struct mod:skip ()) + (struct mod:splice (head tail)) + (struct mod:lift (head tail)) + (struct mod:lift-end (tail)) + (struct mod:begin (head inner)) + + ;(struct interrupted-wrap (tag inner)) + ;(struct error-wrap (exn tag inner)) + ) + + + ;; Well-formedness + + ;; Predicates on well-formed derivations + #; + (define (wf-ok-deriv? x) + (match x + [($ pderiv e1 e2 prule) + (and (syntax? e1) + (syntax? e2) + (wf-ok-prule? prule))] + [($ mderiv e1 e2 mrule next) + (and (syntax? e1) + (syntax? e2) + (wf-ok-mrule? mrule) + (wf-ok-deriv? next))] + [else #f])) + + #; + (define (wf-ok-mrule? x) + (match x + [($ mrule e1 e2 rs me1 me2 locals) + (and (syntax? e1) + (syntax? e2) + (list? rs) + (andmap identifier? rs) + (syntax? me1) + (syntax? me2) + (list? locals) + (andmap wf-ok-deriv? locals))] + [else #f])) + + #; + (define (wf-ok-basic-prule? x) + (match x + [($ prule e1 e2 rs) + (and (syntax? e1) + (syntax? e2) + (list? rs) + (andmap identifier? rs))] + [else #f])) + + #; + (define (wf-ok-prule? x) + (and (wf-ok-basic-prule? x) + (match x + [($ p:variable _ _ _) #t] + [($ p:define-syntaxes _ _ _ rhs) + (wf-ok-deriv? rhs)] + [($ p:define-values _ _ _ rhs) + (wf-ok-deriv? rhs)] + [($ p:if _ _ _ test then else) + (and (wf-ok-deriv? test) + (wf-ok-deriv? then) + (wf-ok-deriv? else))] + [($ p:wcm _ _ _ key value body) + (and (wf-ok-deriv? key) + (wf-ok-deriv? value) + (wf-ok-deriv? body))] + [($ p:set! _ _ _ id-rs rhs) + (and (list? id-rs) + (andmap identifier? id-rs) + (wf-ok-deriv? rhs))] + [($ p:set!-macro _ _ _ deriv) + (wf-ok-deriv? deriv)] + [($ p:begin _ _ _ lderiv) + (wf-ok-lderiv? lderiv)] + [($ p:begin0 _ _ _ first lderiv) + (and (wf-ok-deriv? first) + (wf-ok-lderiv? lderiv))] + [($ p:#%app _ _ _ lderiv) + (wf-ok-lderiv? lderiv)] + [($ p:lambda _ _ _ renames body) + (and (pair? renames) + (syntax? (car renames)) + (syntax? (cdr renames)) + (wf-ok-bderiv? body))] + [($ p:case-lambda _ _ _ (renames+bodies ...)) + (andmap (lambda (r+b) + (and (pair? r+b) + (pair? (car r+b)) + (syntax? (caar r+b)) + (syntax? (cdar r+b)) + (wf-ok-bderiv? (cdr r+b)))) + renames+bodies)] + [($ p:let-values _ _ _ (renames ...) (rhss ...) body) + (and (andmap (lambda (r) + (and (pair? r) + (syntax? (car r)) + (syntax? (cdr r)))) + renames) + (andmap wf-ok-deriv? rhss) + (= (length renames) (length rhss)) + (wf-ok-bderiv? body))] + [($ p:letrec-values _ _ _ (renames ...) (rhss ...) body) + (and (andmap (lambda (r) + (and (pair? r) + (syntax? (car r)) + (syntax? (cdr r)))) + renames) + (andmap wf-ok-deriv? rhss) + (= (length renames) (length rhss)) + (wf-ok-bderiv? body))] + [($ p:letrec-syntaxes+values _ _ _ + (srenames ...) (srhss ...) (vrenames ...) (vrhss ...) body) + (and (andmap (lambda (r) + (and (pair? r) (syntax? (car r)) (syntax? (cdr r)))) + srenames) + (andmap wf-ok-deriv? srhss) + (= (length srenames) (length srhss)) + (andmap (lambda (r) + (and (pair? r) (syntax? (car r)) (syntax? (cdr r)))) + vrenames) + (andmap wf-ok-deriv? vrhss) + (= (length vrenames) (length vrhss)) + (wf-ok-bderiv? body))] + [($ p::STOP _ _ _) #t] + [else #f]))) + + #; + (define (wf-ok-lderiv? x) + (match x + [($ lderiv es1 es2 derivs) + (and (list? es1) + (andmap syntax? es1) + (list? es2) + (andmap syntax? es2) + (list? derivs) + (andmap wf-ok-lderiv? derivs))] + [else #f])) + + #; + (define (wf-ok-bderiv? x) + (define (wf-ok-brule? x) + (match x + [($ brskip renames next) + (and (void renames) + (wf-ok-brule? next))] + [($ brcons renames head next) + (and (void renames) + (wf-ok-deriv? head) + (wf-ok-brule? next))] + [($ brdefstx renames deriv rhs next) + (and (void renames) + (wf-ok-deriv? deriv) + (wf-ok-deriv? rhs) + (wf-ok-brule? next))] + [($ brsplice tail next) + (and (list? tail) + (andmap syntax? tail) + (wf-ok-brule? next))] + [else #f])) + (match x + [($ bderiv es1 es2 pass1 trans pass2) + (and (wf-ok-brule? pass1) + (wf-ok-lderiv? pass2))] + [else #f])) + + #; + (define (wf-exn-deriv? x) + #f) + + ) diff --git a/collects/macro-debugger/model/hiding-policies.ss b/collects/macro-debugger/model/hiding-policies.ss @@ -0,0 +1,81 @@ + +(module hiding-policies mzscheme + (require (lib "plt-match.ss") + (lib "boundmap.ss" "syntax")) + (provide (all-defined)) + + (define-struct hiding-policy + (opaque-modules opaque-ids opaque-kernel transparent-ids)) + + (define (policy-hide-module p m) + (hash-table-put! (hiding-policy-opaque-modules p) m #t)) + (define (policy-unhide-module p m) + (hash-table-remove! (hiding-policy-opaque-modules p) m)) + (define (policy-hide-kernel p) + (set-hiding-policy-opaque-kernel! p #t)) + (define (policy-unhide-kernel p) + (set-hiding-policy-opaque-kernel! p #f)) + + (define (policy-hide-id p id) + (policy-unshow-id p id) + (module-identifier-mapping-put! (hiding-policy-opaque-ids p) id #t)) + (define (policy-unhide-id p id) + (module-identifier-mapping-put! (hiding-policy-opaque-ids p) id #f)) + + (define (policy-show-id p id) + (policy-unhide-id p id) + (module-identifier-mapping-put! (hiding-policy-transparent-ids p) id #t)) + (define (policy-unshow-id p id) + (module-identifier-mapping-put! (hiding-policy-transparent-ids p) id #f)) + + (define (new-hiding-policy) + (make-hiding-policy (make-hash-table) + (make-module-identifier-mapping) + #f + (make-module-identifier-mapping))) + + (define (new-standard-hiding-policy) + (let ([p (new-hiding-policy)]) + (policy-hide-kernel p) + p)) + + ;; --- + + (define-syntax inline + (syntax-rules () + [(inline ([name expr] ...) . body) + (let-syntax ([name + (lambda (x) + (syntax-case x () + [xx (identifier? #'xx) #'expr]))] ...) + . body)])) + + (define (/false) #f) + + (define (policy-show-macro? policy id) + (match policy + [(struct hiding-policy (opaque-modules + opaque-identifiers + opaque-kernel + transparent-identifiers)) + (let ([binding (identifier-binding id)]) + (if (list? binding) + (let-values ([(srcmod srcname nommod nomname _) (apply values binding)]) + (inline ([opaque-srcmod (hash-table-get opaque-modules srcmod /false)] + [opaque-nommod (hash-table-get opaque-modules nommod /false)] + ;; FIXME + [in-kernel? + (and (symbol? srcmod) + (eq? #\# (string-ref (symbol->string srcmod) 0)))] + [not-opaque-id + (not (module-identifier-mapping-get opaque-identifiers id /false))] + [transparent-id + (module-identifier-mapping-get transparent-identifiers id /false)]) + (or transparent-id + (and (not opaque-srcmod) + (not opaque-nommod) + (not (and in-kernel? opaque-kernel)) + not-opaque-id)))) + #f))])) + + ) +\ No newline at end of file diff --git a/collects/macro-debugger/model/reductions-engine.ss b/collects/macro-debugger/model/reductions-engine.ss @@ -0,0 +1,196 @@ + +(module reductions-engine mzscheme + (require "deriv.ss" + "stx-util.ss") + (provide (all-defined)) + + ;; A ReductionSequence is a (list-of Reduction) + + ;; A Reduction is one of + ;; - (make-step Syntaxes Syntaxes Syntax Syntax BigContext) + ;; - (make-misstep Syntax Syntax Exception) + (define-struct step (redex contractum e1 e2 note lctx) #f) + ;(define-struct lift-step (expr id note lctxt) #t) + (define-struct misstep (redex e1 exn) #f) + + ;; ------------------------- + + ;; A Context is (syntax -> syntax) + ;; A BigContext is (list-of (cons Syntaxes Syntax)) + ;; local expansion contexts: pairs of foci, term + + ;; context: parameter of Context + (define context (make-parameter (lambda (x) x))) + + ;; big-context: parameter of BigContext + (define big-context (make-parameter null)) + + (define-syntax with-context + (syntax-rules () + [(with-context f . body) + (let ([E (context)]) + (parameterize ([context (lambda (x) (E (f x)))]) + . body))])) + + (define-syntax with-new-local-context + (syntax-rules () + [(with-new-local-context e . body) + (parameterize ([big-context (cons (cons (list e) (E e)) (big-context))] + [context (lambda (x) x)]) + . body)])) + + ;; E : syntax -> syntax + (define (E stx) ((context) stx)) + + ;; ----------------------------------- + + ;; CC + ;; the context constructor + (define-syntax (CC stx) + (syntax-case stx () + [(CC HOLE expr pattern) + #'(syntax-copier HOLE expr pattern)])) + + ;; R + ;; the threaded reductions engine + (define-syntax R + (syntax-rules () + [(R form pattern . clauses) + (R** #f _ [#:set-syntax form] [#:pattern pattern] . clauses)])) + + (define-syntax (R** stx) + (syntax-case stx (! @ List Block =>) + [(R** form-var pattern) + #'null] + + [(R** f p => k) + #'(k f)] + + ;; Change patterns + [(R** f p [#:pattern p2] . more) + #'(R** f p2 . more)] + ;; Bind pattern variables + [(R** f p [#:bind pattern rhs] . more) + #'(with-syntax ([pattern rhs]) + (R** f p . more))] + ;; Change syntax + [(R** f p [#:set-syntax form] . more) + #'(let ([form-variable form]) + (R** form-variable p . more))] + ;; Change syntax with step + [(R** f p [#:walk form2 foci1 foci2 description] . more) + #'(let-values ([(form2-var foci1-var foci2-var description-var) + (with-syntax ([p f]) + (values form2 foci1 foci2 description))]) + (cons (walk/foci/E foci1-var foci2-var f form2-var description-var) + (R** form2-var p . more)))] + [(R** f p [#:walk form2 description] . more) + #'(let-values ([(form2-var description-var) + (with-syntax ([p f]) + (values form2 description))]) + (cons (walk f form2-var description-var) + (R** form2-var p . more)))] + + ;; Conditional + [(R** f p [#:if test consequent ...] . more) + #'(if (with-syntax ([p f]) test) + (R** f p consequent ... . more) + (R** f p . more))] + + ;; Error-point case + [(R** f p [! info] . more) + #'(R** f p [! info #f] . more)] + [(R** f p [! info key] . more) + #'(let ([continue (lambda () (R** f p . more))]) + (cond [(and (pair? info) (car info)) + ;; error-wrap + ;; If this is the key, then insert the misstep here and stop. + ;; This stops processing *within* an error-wrapped prim. + (if (or (eq? key #f) (eq? key (cdr info))) + (list (make-misstep f (E f) (car info))) + (continue))] + [else + (continue)]))] + + [(R** f p [Generator hole0 fill0] . more) + #'(let-values ([(reducer get-e1 get-e2) Generator]) + (R** f p [reducer get-e1 get-e2 hole0 fill0] . more))] + +; ;; Expression case +; [(R** f p [hole0 fill0] . more) +; #'(R** f p [reductions deriv-e1 deriv-e2 hole0 fill0] . more)] +; ;; List case +; [(R** f p [List hole0 fill0] . more) +; #'(R** f p [list-reductions lderiv-es1 lderiv-es2 hole0 fill0] . more)] +; ;; Block case +; [(R** f p [Block hole0 fill0] . more) +; #'(R** f p [block-reductions bderiv-es1 bderiv-es2 hole0 fill0] . more)] + + ;; Implementation for (hole ...) sequences + [(R** form-var pattern + [f0 get-e1 get-e2 (hole0 :::) fill0s] . more) + (module-identifier=? #'::: (quote-syntax ...)) + #'(let ([ctx0 (CC (hole0 :::) form-var pattern)]) + (let ([e1s (with-syntax ([pattern form-var]) (syntax->list #'(hole0 :::)))]) + (let loop ([fills fill0s] [prefix null] [suffix e1s]) + (cond + [(pair? fills) + (append + (with-context ctx0 + (with-context (lambda (x) (revappend prefix (cons x (cdr suffix)))) + (f0 (car fills)))) + (cond [(interrupted-wrap? (car fills)) + null] + [(error-wrap? (car fills)) + null] + [else + (loop (cdr fills) + (cons (get-e2 (car fills)) prefix) + (cdr suffix))]))] + [(null? fills) + (let ([form-var (ctx0 (reverse prefix))]) + (R** form-var pattern . more))]))))] + ;; Implementation + [(R** form-var pattern + [f0 get-e1 get-e2 hole0 fill0] . more) + #'(let ([ctx0 (CC hole0 form-var pattern)]) + (append (with-context ctx0 + (f0 fill0)) + ;; If the last thing we ran through was interrupted, + ;; then there's nothing left to do. + ;; This stops processing *after* an error-wrapped deriv. + (cond [(interrupted-wrap? fill0) null] + [(error-wrap? fill0) null] + [else + (let ([form-var (ctx0 (get-e2 fill0))]) + (R** form-var pattern . more))])))])) + + + ;; ----------------------------------- + + ;; walk : syntax(s) syntax(s) [string] -> Reduction + ;; Lifts a local step into a term step. + (define walk + (case-lambda + [(e1 e2) (walk e1 e2 #f)] + [(e1 e2 note) (make-step e1 e2 (E e1) (E e2) note (big-context))])) + + ;; walk/foci/E : syntax(s) syntax(s) syntax syntax string -> Reduction + (define (walk/foci/E focus1 focus2 e1 e2 note) + (walk/foci focus1 focus2 (E e1) (E e2) note)) + + ;; walk/foci : syntax(s) syntax(s) syntax syntax string -> Reduction + (define (walk/foci focus1 focus2 Ee1 Ee2 note) + (make-step focus1 focus2 Ee1 Ee2 note (big-context))) + + ;; stumble : syntax exception -> Reduction + (define (stumble stx exn) + (make-misstep stx (E stx) exn)) + ;; ------------------------------------ + + (define (revappend a b) + (cond [(pair? a) (revappend (cdr a) (cons (car a) b))] + [(null? a) b])) + + + ) +\ No newline at end of file diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss @@ -0,0 +1,523 @@ + +(module reductions mzscheme + (require (lib "plt-match.ss") + "stx-util.ss" + "deriv-util.ss" + "context.ss" + "deriv.ss" + "reductions-engine.ss") + (provide reductions + (struct step (redex contractum e1 e2 note lctx)) + (struct misstep (redex e1 exn))) + + ;; Setup for reduction-engines + + (define-syntax Expr + (syntax-id-rules () + [Expr (values reductions deriv-e1 deriv-e2)])) + (define-syntax List + (syntax-id-rules () + [List (values list-reductions lderiv-es1 lderiv-es2)])) + (define-syntax Block + (syntax-id-rules () + [Block (values block-reductions bderiv-es1 bderiv-es2)])) + + ;; Reductions + + ;; reductions : Derivation -> ReductionSequence + (define (reductions d) + (match d + ;; Primitives + [(struct p:variable (e1 e2 rs)) + null] + [(IntQ p:module (e1 e2 rs body)) + (with-syntax ([(?module name language . BODY) e1]) + (let ([ctx (lambda (x) (d->so e1 `(,#'?module ,#'name ,#'language ,x)))] + [body-e1 (match body [($$ deriv (body-e1 _) _) body-e1])]) + (cons (walk e1 (ctx body-e1) "Tag #%module-begin") + (with-context ctx + (reductions body)))))] + [(IntQ p:#%module-begin (e1 e2 rs pass1 pass2)) + #;(R e1 (?module-begin . MBODY) + [! exni 'blah] + [ModulePass1 MBODY pass1] + => (lambda (e1prime) + (R e1prime (?module-begin2 . MBODY2) + [ModulePass2 MBODY2 pass2]))) + (with-syntax ([(?#%module-begin form ...) e1]) + (let-values ([(reductions1 final-stxs1) + (with-context (lambda (x) (d->so e1 (cons #'?#%module-begin x))) + (mbrules-reductions pass1 (syntax->list #'(form ...)) #t))]) + (let-values ([(reductions2 final-stxs2) + (with-context (lambda (x) (d->so e1 (cons #'?#%module-begin x))) + (mbrules-reductions pass2 final-stxs1 #f))]) + (append reductions1 reductions2))))] + [(AnyQ p:define-syntaxes (e1 e2 rs rhs) exni) + (R e1 _ + [! exni] + [#:pattern (?define-syntaxes formals RHS)] + [Expr RHS rhs])] + [(AnyQ p:define-values (e1 e2 rs rhs) exni) + (R e1 _ + [! exni] + [#:pattern (?define-values formals RHS)] + [Expr RHS rhs])] + [(AnyQ p:if (e1 e2 rs full? test then else) exni) + (if full? + (R e1 _ + [! exni] + [#:pattern (?if TEST THEN ELSE)] + [Expr TEST test] + [Expr THEN then] + [Expr ELSE else]) + (R e1 _ + [! exni] + [#:pattern (?if TEST THEN)] + [Expr TEST test] + [Expr THEN then]))] + [(AnyQ p:wcm (e1 e2 rs key mark body) exni) + (R e1 _ + [! exni] + [#:pattern (?wcm KEY MARK BODY)] + [Expr KEY key] + [Expr MARK mark] + [Expr BODY body])] + [(AnyQ p:begin (e1 e2 rs lderiv) exni) + (R e1 _ + [! exni] + [#:pattern (?begin . LDERIV)] + [List LDERIV lderiv])] + [(AnyQ p:begin0 (e1 e2 rs first lderiv) exni) + (R e1 _ + [! exni] + [#:pattern (?begin0 FIRST . LDERIV)] + [Expr FIRST first] + [List LDERIV lderiv])] + [(AnyQ p:#%app (e1 e2 rs tagged-stx lderiv) exni) + (let ([tail + (R tagged-stx (?#%app . LDERIV) + [! exni] + [List LDERIV lderiv])]) + (if (eq? tagged-stx e1) + tail + (cons (walk e1 tagged-stx "Tag application") tail)))] + [(AnyQ p:lambda (e1 e2 rs renames body) exni) + (R e1 _ + [! exni] + [#:bind (?formals* . ?body*) renames] + [#:pattern (?lambda ?formals . ?body)] + [#:walk (syntax/skeleton e1 (?lambda ?formals* . ?body*)) + #'?formals #'?formals* + "Rename formal parameters"] + [Block ?body body]) + #; + (R e1 _1 + [! exni] + => + (lambda (stx) + (with-syntax ([(?lambda ?formals . ?body) stx] + [(?formals* . ?body*) renames]) + (let ([mid (syntax/skeleton e1 (?lambda ?formals* . ?body*))]) + (append + (if (stx-pair? #'?formals) + (list (walk/foci/E #'?formals #'?formals* e1 mid + "Rename formal parameters")) + null) + (R mid (LAMBDA FORMALS . BODY) + [Block BODY body])))))) + #;(with-syntax ([(?lambda ?formals . ?body) e1] + [(?formals* . ?body*) renames]) + (let ([mid (syntax/skeleton e1 (?lambda ?formals* . ?body*))]) + (append + (if (stx-pair? #'?formals) + (list (walk/foci/E #'?formals #'?formals* e1 mid + "Rename formal parameters")) + null) + (R mid (LAMBDA FORMALS . BODY) + [Block BODY body]))))] + [(struct p:case-lambda (e1 e2 rs renames+bodies)) + #; + (R e1 _ + [! exni] + [#:pattern (?case-lambda [?formals . ?body] ...)] + [#:bind [(?formals* . ?body*) ...] (map car renames+bodies)] + [#:walk (syntax/skeleton e1 (?case-lambda [?formals* . ?body*] ...)) + (syntax->list #'(?formals ...)) + (syntax->list #'(?formals* ...)) + "Rename formal parameters"] + [Block (?body ...) (map cdr renames+bodies)]) + (with-syntax ([(?case-lambda [?formals . ?body] ...) e1] + [((?formals* . ?body*) ...) (map car renames+bodies)]) + (let ([mid (syntax/skeleton e1 (?case-lambda [?formals* . ?body*] ...))]) + (cons (walk/foci/E (syntax->list #'(?formals ...)) + (syntax->list #'(?formals* ...)) + e1 mid "Rename formal parameters") + (R mid (CASE-LAMBDA [FORMALS . BODY] ...) + [Block (BODY ...) (map cdr renames+bodies)]))))] + [(AnyQ p:let-values (e1 e2 rs renames rhss body) exni) + (R e1 _ + [! exni] + [#:pattern (?let-values ([?vars ?rhs] ...) . ?body)] + [#:bind (([?vars* ?rhs*] ...) . ?body*) renames] + [#:walk (syntax/skeleton e1 (?let-values ([?vars* ?rhs*] ...) . ?body*)) + (syntax->list #'(?vars ...)) + (syntax->list #'(?vars* ...)) + "Rename bound variables"] + [Expr (?rhs ...) rhss] + [Block ?body body]) + #; + (with-syntax ([(?let-values ([?vars ?rhs] ...) . ?body) e1] + [(([?vars* ?rhs*] ...) . ?body*) renames]) + (let ([mid (syntax/skeleton e1 (?let-values ([?vars* ?rhs*] ...) . ?body*))]) + (cons (walk/foci/E (syntax->list #'(?vars ...)) + (syntax->list #'(?vars* ...)) + e1 mid "Rename let-bound variables") + (R mid (LET-VALUES ([VARS RHS] ...) . BODY) + [Expr (RHS ...) rhss] + [Block BODY body]))))] + [(AnyQ p:letrec-values (e1 e2 rs renames rhss body) exni) + (R e1 _ + [! exni] + [#:pattern (?letrec-values ([?vars ?rhs] ...) . ?body)] + [#:bind (([?vars* ?rhs*] ...) . ?body*) renames] + [#:walk (syntax/skeleton e1 (?letrec-values ([?vars* ?rhs*] ...) . ?body*)) + (syntax->list #'(?vars ...)) + (syntax->list #'(?vars* ...)) + "Rename bound variables"] + [Expr (?rhs ...) rhss] + [Block ?body body]) + #; + (with-syntax ([(?letrec-values ([?vars ?rhs] ...) . ?body) e1] + [(([?vars* ?rhs*] ...) . ?body*) renames]) + (let ([mid (syntax/skeleton e1 (?letrec-values ([?vars* ?rhs*] ...) . ?body*))]) + (cons (walk/foci/E (syntax->list #'(?vars ...)) + (syntax->list #'(?vars* ...)) + e1 mid "Rename letrec-bound variables") + (R mid (LETREC-VALUES ([VARS RHS] ...) . BODY) + [Expr (RHS ...) rhss] + [Block BODY body]))))] + + [(AnyQ p:letrec-syntaxes+values (e1 e2 rs srenames srhss vrenames vrhss body) exni) + (R e1 _ + [! exni] + [#:pattern (?lsv ([?svars ?srhs] ...) ([?vvars ?vrhs] ...) . ?body)] + [#:bind (([?svars* ?srhs*] ...) ([?vvars* ?vrhs] ...) . ?body*) srenames] + [#:walk (syntax/skeleton e1 (?lsv ([?svars* ?srhs*] ...) ([?vvars* ?vrhs*] ...) . ?body*)) + (syntax->list #'(?svars ...)) + (syntax->list #'(?svars* ...)) + "Rename bound variables"] + [Expr (?srhs ...) srhss] + [#:bind (([?vvars** ?vrhs**] ...) . ?body**) vrenames] + [#:walk (syntax/skeleton e1 (?lsv ([?svars* ?srhs*] ...) ([?vars** ?vrhs**] ...) . ?body**)) + (syntax->list #'(?vvars* ...)) + (syntax->list #'(?vvars** ...)) + "Rename bound variables"] + [Expr (?vrhs ...) vrhss] + [Block ?body body] + => (lambda (mid) + (if (eq? mid e2) + null + (list (walk mid e2 "Remove syntax bindings"))))) + #; + (with-syntax ([(?lsv ([?svars ?srhs] ...) ([?vvars ?vrhs] ...) . ?body) e1] + [(([?svars* ?srhs*] ...) ?vpart* . ?body*) srenames]) + (with-syntax ([(([?vvars* ?vrhs*] ...) . ?body**) + (or vrenames #'(?vpart* . ?body*))]) + (let ([mid (syntax/skeleton + e1 + (?lsv ([?svars* ?srhs*] ...) ([?vvars* ?vrhs] ...) . ?body**))]) + (cons + (walk/foci/E (syntax->list #'(?svars ... ?vvars ...)) + (syntax->list #'(?svars* ... ?vvars* ...)) + e1 mid "Rename local variables") + (R mid (LETREC-SYNTAXES+VALUES ([SVARS SRHS] ...) ([VVARS VRHS] ...) . BODY) + [Expr (SRHS ...) srhss] + [Expr (VRHS ...) vrhss] + [Block BODY body] + => (lambda (mid) + (if (eq? mid e2) + null + (list (walk mid e2 "Finish letrec-syntaxes+values")))))))))] + + ;; The auto-tagged atomic primitives + [(AnyQ p:#%datum (e1 e2 rs tagged-stx) exni) + (append (if (eq? e1 tagged-stx) + null + (list (walk e1 tagged-stx "Tag datum"))) + (if exni + (list (stumble tagged-stx (car exni))) + null))] + [(AnyQ p:#%top (e1 e2 rs tagged-stx) exni) + (append (if (eq? e1 tagged-stx) + null + (list (walk e1 tagged-stx "Tag top-level variable"))) + (if exni + (list (stumble tagged-stx (car exni))) + null))] + + ;; The rest of the automatic primitives + [(AnyQ p::STOP (e1 e2 rs) exni) + (R e1 _ + [! exni])] + + [(AnyQ p:set!-macro (e1 e2 rs deriv) exni) + (R e1 _ + [! exni] + => (lambda (mid) + (reductions deriv)))] + [(AnyQ p:set! (e1 e2 rs id-rs rhs) exni) + (R e1 _ + [! exni] + [#:pattern (SET! VAR RHS)] + [Expr RHS rhs])] + + ;; Synthetic primitives + ;; These have their own subterm replacement mechanisms + [(and d (AnyQ p:synth (e1 e2 rs subterms))) + (let loop ([term e1] [subterms subterms]) + (cond [(null? subterms) + (let ([exn (and (error-wrap? d) (error-wrap-exn d))]) + (if exn + (list (stumble term exn)) + null))] + [(pair? subterms) + (let* ([subterm0 (car subterms)] + [path0 (s:subterm-path subterm0)] + [deriv0 (s:subterm-deriv subterm0)]) + (let ([ctx (lambda (x) (path-replace term path0 x))]) + (append (with-context ctx + (reductions deriv0)) + (loop (path-replace term path0 (deriv-e2 deriv0)) + (cdr subterms)))))]))] + + ;; FIXME + [(IntQ p:rename (e1 e2 rs rename inner)) + (reductions inner)] + + ;; Error + +; [(struct error-wrap (exn tag (? prule? prule))) +; ;; Let's take the attitude that all primitive syntax errors +; ;; occur "at the beginning" +; (list (make-misstep (deriv-e1 prule) (E (deriv-e1 prule)) exn))] +; +; #; +; [($$ interrupted-wrap (tag prule)) +; (reductions prule orig-stx)] + + ;; Macros + [(IntQ mrule (e1 e2 transformation next)) + (append (reductions-transformation transformation) + (reductions next))] + + ;; Lifts + + [(IntQ lift-deriv (e1 e2 first lifted-stx second)) + (append (reductions first) + (list (walk (deriv-e2 first) lifted-stx "Capture lifts")) + (reductions second))] + + ;; Skipped + + [#f null])) + + ;; reductions-transformation : Transformation -> ReductionSequence + (define (reductions-transformation tx) + (match tx + [(struct transformation (e1 e2 rs me1 me2 locals)) + (append (reductions-locals e1 locals) + (list (walk e1 e2 "Macro transformation")))] + [(IntW transformation (e1 e2 rs me1 me2 locals) 'locals) + (reductions-locals e1 locals)] + [(ErrW transformation (e1 e2 rs me1 me2 locals) 'transform exn) + (append (reductions-locals e1 locals) + (list (stumble e1 exn)))])) + + ;; reductions-locals : syntax (list-of LocalAction) -> ReductionSequence + (define (reductions-locals stx locals) + (with-new-local-context stx + (apply append (map reductions-local locals)))) + + ;; reductions-local : LocalAction -> ReductionSequence + (define (reductions-local local) + (match local + [(IntQ local-expansion (e1 e2 me1 me2 deriv)) + (reductions deriv)] + [(struct local-lift (expr id)) + (list (walk expr id "Macro lifted expression to top-level"))] + [(struct local-lift-end (decl)) + (list (walk decl decl "Declaration lifted to end of module"))])) + + ;; list-reductions : ListDerivation -> ReductionSequence + (define (list-reductions ld) + (match ld + [(IntQ lderiv (es1 es2 derivs)) + (let loop ([derivs derivs] [suffix es1]) + (cond [(pair? derivs) + (append + (with-context (lambda (x) (cons x (stx-cdr suffix))) + (reductions (car derivs))) + (with-context (lambda (x) (cons (deriv-e2 (car derivs)) x)) + (loop (cdr derivs) (stx-cdr suffix))))] + [(null? derivs) + null]))] + [(ErrW lderiv (es1 es2 derivs) _ exn) + (list (stumble es1 exn))] + + [#f null])) + + ;; block-reductions : BlockDerivation -> ReductionSequence + (define (block-reductions bd) + (match bd + ;; If interrupted in pass1, skip pass2 + [(IntW bderiv (es1 es2 pass1 trans pass2) 'pass1) + (let-values ([(reductions stxs) (brules-reductions pass1 es1)]) + reductions)] + ;; Otherwise, do both + [(IntQ bderiv (es1 es2 pass1 trans pass2)) + (let-values ([(reductions1 stxs1) (brules-reductions pass1 es1)]) + (append reductions1 + (if (eq? trans 'letrec) + (match pass2 + [($$ lderiv (pass2-es1 _ _) _exni) + (list (walk stxs1 pass2-es1 "Transform block to letrec"))]) + null) + (list-reductions pass2)))] + [#f null])) + + ;; brules-reductions : (list-of-BRule) syntax-list -> ReductionSequence syntax-list + (define (brules-reductions brules all-stxs) + (let loop ([brules brules] [suffix all-stxs] [prefix null] [rss null]) + (match brules + [(cons (struct b:expr (renames head)) next) + (let ([estx (deriv-e2 head)]) + (loop next (stx-cdr suffix) (cons estx prefix) + (cons (with-context (lambda (x) + (revappend prefix (cons x (stx-cdr suffix)))) + (reductions head)) + rss)))] + [(cons (IntW b:expr (renames head) tag) '()) + (loop '() #f #f + (cons (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix)))) + (reductions head)) + rss))] + [(cons (struct b:defvals (renames head)) next) + (let ([head-rs + (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix)))) + (reductions head))]) + (loop next (stx-cdr suffix) (cons (deriv-e2 head) prefix) + (cons head-rs rss)))] + [(cons ($$ b:defstx (renames head rhs) _exni) next) + (let* ([estx (deriv-e2 head)] + [estx2 (with-syntax ([(?ds ?vars ?rhs) estx] + [?rhs* (deriv-e2 rhs)]) + ;;FIXME + #'(?ds ?vars ?rhs*))]) + (loop next (cdr suffix) (cons estx2 prefix) + (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix)))) + (cons (with-context (CC (?ds ?vars ?rhs) estx ?rhs) + (reductions rhs)) + (cons (reductions head) + rss)))))] + [(cons (struct b:splice (renames head tail)) next) + (loop next tail prefix + (cons (list (walk/foci (deriv-e2 head) + (take-until tail (stx-cdr suffix)) + (E (revappend prefix + (cons (deriv-e2 head) (stx-cdr suffix)))) + (E (revappend prefix tail)) + "Splice block-level begin")) + (cons (with-context (lambda (x) + (revappend prefix (cons x (stx-cdr suffix)))) + (reductions head)) + rss)))] + [(cons (struct b:begin (renames head derivs)) next) + ;; FIXME + (error 'unimplemented)] + [(cons (struct error-wrap (exn tag _inner)) '()) + (values (list (make-misstep suffix (E (revappend prefix suffix)) exn)) + (revappend prefix suffix))] + ['() + (values (apply append (reverse rss)) + (revappend prefix suffix))]))) + + ;; mbrules-reductions : MBRules (list-of syntax) -> ReductionSequence + ;; The reprocess-on-lift? argument controls the behavior of a mod:lift event. + ;; In Pass1, #t; in Pass2, #f. + (define (mbrules-reductions mbrules all-stxs reprocess-on-lift?) + ;(printf "**** MB Reductions, pass ~s~n" (if reprocess-on-lift? 1 2)) + (let* ([final-stxs #f] + [reductions + (let loop ([mbrules mbrules] [suffix all-stxs] [prefix null]) + ;(printf "** MB loop~n") + ;(printf " rules: ~s~n" mbrules) + ;(printf " suffix: ~s~n" suffix) + ;(printf " prefix: ~s~n" prefix) + (match mbrules + [(cons ($$ mod:skip ()) next) + (loop next (stx-cdr suffix) (cons (stx-car suffix) prefix))] + [(cons ($$ mod:cons (head) _exni) next) + (append (with-context (lambda (x) + (revappend prefix (cons x (stx-cdr suffix)))) + (append (reductions head))) + (let ([estx (and (deriv? head) (deriv-e2 head))]) + (loop next (stx-cdr suffix) (cons estx prefix))))] + [(cons ($$ mod:prim (head prim) _exni) next) + (append (with-context (lambda (x) + (revappend prefix (cons x (stx-cdr suffix)))) + (if (and prim (not (p:define-values? prim))) + (append (reductions head) + (reductions prim)) + (reductions head))) + (let ([estx (and (deriv? head) (deriv-e2 head))]) + (loop next (stx-cdr suffix) (cons estx prefix))))] + [(cons ($$ mod:splice (head stxs)) next) + ;(printf "suffix is: ~s~n~n" suffix) + ;(printf "stxs is: ~s~n" stxs) + (append + (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix)))) + (reductions head)) + (let ([suffix-tail (stx-cdr suffix)] + [head-e2 (deriv-e2 head)]) + (cons (walk/foci head-e2 + (stx-take stxs + (- (stx-improper-length stxs) + (stx-improper-length suffix-tail))) + (E (revappend prefix (cons head-e2 suffix-tail))) + (E (revappend prefix stxs)) + "Splice module-level begin") + (loop next stxs prefix))))] + [(cons ($$ mod:lift (head stxs)) next) + ;(printf "suffix is: ~s~n~n" suffix) + ;(printf "stxs is: ~s~n" stxs) + (append + (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix)))) + (reductions head)) + (let ([suffix-tail (stx-cdr suffix)] + [head-e2 (deriv-e2 head)]) + (let ([new-suffix (append stxs (cons head-e2 suffix-tail))]) + (cons (walk/foci null + stxs + (E (revappend prefix (cons head-e2 suffix-tail))) + (E (revappend prefix new-suffix)) + "Splice definitions from lifted expressions") + (loop next + new-suffix + prefix)))))] + [(cons ($$ mod:lift-end (tail)) next) + (append + (if (pair? tail) + (list (walk/foci null + tail + (E (revappend prefix suffix)) + (E (revappend prefix tail)) + "Splice lifted module declarations")) + null) + (loop next tail prefix))] + ['() + (set! final-stxs (reverse prefix)) + null]))]) + (values reductions final-stxs))) + + + ) diff --git a/collects/macro-debugger/model/stx-util.ss b/collects/macro-debugger/model/stx-util.ss @@ -0,0 +1,97 @@ + +(module stx-util mzscheme + (require (lib "stx.ss" "syntax")) + + (provide (all-defined) + (all-from (lib "stx.ss" "syntax"))) + + #; + (define-syntax (CC stx) + (syntax-case stx () + [(CC HOLE expr pattern) + #'(lambda (in-the-hole) + (with-syntax ([pattern expr]) + (with-syntax ([HOLE in-the-hole]) + #'pattern)))])) + + + (define (d->so template datum) + (let ([template (and (syntax? template) #f)]) + (datum->syntax-object template datum template template))) + + (define-syntax (syntax-copier stx) + (syntax-case stx () + [(syntax-copier hole expr pattern) + #'(let ([expr-var expr]) + (lambda (in-the-hole) + (with-syntax ([pattern expr-var]) + (with-syntax ([hole in-the-hole]) + (syntax/restamp pattern #'pattern expr-var)))))])) + + (define-syntax syntax/skeleton + (syntax-rules () + [(syntax/skeleton old-expr pattern) + (syntax/restamp pattern #'pattern old-expr)])) + + + ;; FIXME: Need to avoid turning syntax lists into syntax pairs + (define-syntax (syntax/restamp stx) + (syntax-case stx (...) + [(syntax/restamp (pa (... ...)) new-expr old-expr) + #`(let ([new-parts (stx->list new-expr)] + [old-parts (stx->list old-expr)]) + (unless (= (length new-parts) (length old-parts)) + (printf "** syntax/restamp~n~s~n" (quote-syntax #,stx)) + (printf "pattern : ~s~n" (syntax-object->datum #'(pa (... ...)))) + (printf "old parts: ~s~n" old-parts) + (printf "new parts: ~s~n" new-parts)) + (d->so + old-expr + (map (lambda (new old) (syntax/restamp pa new old)) + new-parts + old-parts)))] + #;[(syntax/restamp (pa ...) new-expr old-expr) + (with-syntax ([(na ...) (generate-temporaries #'(pa ...))] + [(oa ...) (generate-temporaries #'(pa ...))]) + #'(with-syntax ([(na ...) new-expr] + [(oa ...) old-expr]) + (d->so + old-expr + (list (syntax/restamp pa #'na #'oa) ...))))] + [(syntax/restamp (pa . pb) new-expr old-expr) + #'(let ([na (stx-car new-expr)] + [nb (stx-cdr new-expr)] + [oa (stx-car old-expr)] + [ob (stx-cdr old-expr)]) + (d->so old-expr + (cons (syntax/restamp pa na oa) + (syntax/restamp pb nb ob))))] + [(syntax/restamp pvar new-expr old-expr) + #'new-expr])) + + (define (iota n) + (let loop ([i 0]) + (if (< i n) + (cons i (loop (add1 i))) + null))) + + ;; stx-take : syntax-list number -> (list-of syntax) + (define (stx-take items n) + (cond [(zero? n) null] + [else (cons (stx-car items) (stx-take (stx-cdr items) (sub1 n)))])) + + (define *args* #f) + + (define (take-until stxs tail) + (set! *args* (list stxs tail)) + (let loop ([stxs stxs]) + (if (eq? stxs tail) + null + (cons (stx-car stxs) (loop (stx-cdr stxs)))))) + + (define (stx-improper-length stx) + (if (stx-pair? stx) + (add1 (stx-improper-length (stx-cdr stx))) + 0)) + + ) diff --git a/collects/macro-debugger/model/trace-raw.ss b/collects/macro-debugger/model/trace-raw.ss @@ -0,0 +1,37 @@ + +(module trace-raw mzscheme + (require "../syntax-browser/syntax-browser.ss" + (lib "class.ss") + (lib "lex.ss" "parser-tools") + "deriv-tokens.ss" + "deriv-parser.ss") + (provide (all-defined)) + + (define current-expand-observe + (dynamic-require '#%expobs 'current-expand-observe)) + + (define (go-trace sexpr) + (define browser + (parameterize (#;(identifier=-choices + (list (cons "related by table" + (lambda (a b) (related-by-table table a b)))))) + (make-syntax-browser))) + (define table #f) + (define pos 0) + (parameterize ((current-expand-observe + (lambda (sig val) + (define t (tokenize sig val pos)) + (send browser add-text + (format "Signal: ~s: ~s~n" + pos + (token-name (position-token-token t)))) + (send browser add-syntax + (datum->syntax-object #f val)) + (set! pos (add1 pos))))) + (expand sexpr))) + + (define (related-by-table table a b) + (or (eq? a b) + #;(and table '...))) + + ) +\ No newline at end of file diff --git a/collects/macro-debugger/model/trace.ss b/collects/macro-debugger/model/trace.ss @@ -0,0 +1,79 @@ + +(module trace mzscheme + (require (lib "lex.ss" "parser-tools") + (lib "class.ss")) + (require "deriv.ss" + "deriv-parser.ss" + "deriv-tokens.ss" + "reductions.ss" + "hide.ss" + "hiding-policies.ss") + + (provide trace-verbose? + trace + trace/result + trace+reductions + (all-from "reductions.ss")) + + (define current-expand-observe + (dynamic-require '#%expobs 'current-expand-observe)) + + (define trace-verbose? (make-parameter #f)) + + ;; trace : syntax -> Derivation + (define (trace stx) + (let-values ([(result tracer) (expand+tracer stx)]) + (parse-derivation tracer))) + + ;; trace/result : syntax -> (values syntax/exn Derivation) + (define (trace/result stx) + (let-values ([(result tracer) (expand+tracer stx)]) + (values result + (parse-derivation tracer)))) + + ;; trace+reductions : syntax -> ReductionSequence + (define (trace+reductions stx) + (reductions (trace stx))) + + ;; expand+tracer : syntax/sexpr -> (values syntax/exn (-> event)) + (define (expand+tracer sexpr) + (let* ([s (make-semaphore 1)] + [head (cons #f #f)] + [tail head] + [pos 0]) + (define (add! x) + (semaphore-wait s) + (set-car! tail x) + (set-cdr! tail (cons #f #f)) + (set! tail (cdr tail)) + (semaphore-post s)) + (define get + (let ([head head]) + (lambda () + (semaphore-wait s) + (let ([result (car head)]) + (set! head (cdr head)) + (semaphore-post s) + result)))) + (parameterize ((current-expand-observe + (lambda (sig val) + (add! (cons sig val))))) + (let ([result + (with-handlers ([(lambda (exn) #t) + (lambda (exn) + (add! (cons 'error exn)) + exn)]) + (expand sexpr))]) + (add! (cons 'EOF pos)) + (values result + (lambda () + (let* ([sig+val (get)] + [sig (car sig+val)] + [val (cdr sig+val)] + [t (tokenize sig val pos)]) + (when (trace-verbose?) + (printf "~s: ~s~n" pos (token-name (position-token-token t)))) + (set! pos (add1 pos)) + t))))))) + + ) diff --git a/collects/macro-debugger/model/yacc-ext.ss b/collects/macro-debugger/model/yacc-ext.ss @@ -0,0 +1,44 @@ + +(module yacc-ext mzscheme + + (require (prefix yacc: (lib "yacc.ss" "parser-tools"))) + (provide parser + options + productions) + + (define-syntax options + (lambda (stx) + (raise-syntax-error #f "options keyword used out of context" stx))) + + (define-syntax productions + (lambda (stx) + (raise-syntax-error #f "productions keyword used out of context" stx))) + + (define-syntax (parser stx) + (syntax-case stx () + [(parser form ...) + (let* ([stop-list (list #'begin #'options #'productions)] + [forms (syntax->list #'(form ...))] + [options+productions + (let loop ([forms forms] [opts null] [prods null]) + (if (pair? forms) + (let ([eform0 (local-expand (car forms) 'expression stop-list)] + [forms (cdr forms)]) + (syntax-case eform0 (begin options productions) + [(begin subform ...) + (loop (append (syntax->list #'(subform ...)) forms) opts prods)] + [(options subform ...) + (loop forms (append (syntax->list #'(subform ...)) opts) prods)] + [(productions subform ...) + (loop forms opts (append (syntax->list #'(subform ...)) prods))] + [else + (raise-syntax-error #f "bad parser subform" eform0)])) + (cons opts (reverse prods))))] + [opts (car options+productions)] + [prods (cdr options+productions)]) + (with-syntax ([(opt ...) opts] + [(prod ...) prods]) + #'(yacc:parser opt ... (grammar prod ...))))])) + + + ) diff --git a/collects/macro-debugger/model/yacc-interrupted.ss b/collects/macro-debugger/model/yacc-interrupted.ss @@ -0,0 +1,219 @@ + +(module yacc-interrupted mzscheme + (require "deriv.ss" + "yacc-ext.ss") + (provide ! ? + production/I + productions/I + skipped-token-values + %skipped + %action) + + ;; Grammar macros for "interrupted parses" + ;; Uses interrupted-wrap and error-wrap from deriv.ss + + (define-syntax ! + (lambda (stx) + (raise-syntax-error #f "keyword ! used out of context" stx))) + + (define-syntax ? + (lambda (stx) + (raise-syntax-error #f "keyword ? used out of context" stx))) + + (define-syntax (productions/I stx) + (syntax-case stx () + [(productions/I def ...) + #'(begin (production/I def) ...)])) + + (define-for-syntax (partition-options/alternates forms) + (let loop ([forms forms] [options null] [alts null]) + (if (pair? forms) + (syntax-case (car forms) () + [(#:args . args) + (loop (cdr forms) (cons (cons #:args #'args) options) alts)] + [(#:skipped expr) + (loop (cdr forms) (cons (cons #:skipped #'expr) options) alts)] + [(#:no-interrupted) + (loop (cdr forms) (cons (cons #:no-interrupted #t) options) alts)] + [(#:no-wrap) + (loop (cdr forms) (cons (cons #:no-wrap #t) options) alts)] + [(#:no-wrap-error) + (loop (cdr forms) (cons (cons #:no-wrap-error #t) options) alts)] + [(kw . args) + (keyword? (syntax-e #'kw)) + (raise-syntax-error #f "bad keyword" (car forms))] + [(pattern action) + (loop (cdr forms) options (cons (cons #'pattern #'action) alts))]) + (values options (reverse alts))))) + + (define-for-syntax (symbol+ . args) + (define (norm x) + (cond [(identifier? x) (norm (syntax-e x))] + [(string? x) x] + [(number? x) (number->string x)] + [(symbol? x) (symbol->string x)])) + (string->symbol (apply string-append (map norm args)))) + + (define-for-syntax (I symbol) + (syntax-local-introduce + (syntax-local-get-shadower (datum->syntax-object #f symbol)))) + + (define-for-syntax (elaborate-skipped-tail head tail action) + (define new-tail + (let loop ([parts tail]) + (syntax-case parts (? !) + [() #'()] + [(! . parts-rest) (loop #'((! #f) . parts-rest))] + [((! expr) . parts-rest) + (with-syntax ([NoError (I 'NoError)] + [parts-rest (loop #'parts-rest)]) + #'(NoError . parts-rest))] + [((? NT) . parts-rest) + (loop #'((? NT #f) . parts-rest))] + [((? NT expr) . parts-rest) + (loop #'(NT . parts-rest))] + [(part0 . parts-rest) + (identifier? #'part0) + (with-syntax ([part0/Skipped (I (symbol+ #'part0 '/Skipped))] + [parts-rest (loop #'parts-rest)]) + #'(part0/Skipped . parts-rest))]))) + (with-syntax ([head head] + [new-tail new-tail]) + (cons #'(head . new-tail) + action))) + + (define-for-syntax (elaborate-successful-alternate alt) + (define pattern (car alt)) + (define action (cdr alt)) + (cons (let loop ([parts pattern]) + (syntax-case parts (? !) + [() #'()] + [(! . parts-rest) + (loop #'((! #f) . parts-rest))] + [((! expr) . parts-rest) + (with-syntax ([NoError (I 'NoError)] + [parts-rest (loop #'parts-rest)]) + #'(NoError . parts-rest))] + [((? NT) . parts-rest) + (loop #'((? NT #f) . parts-rest))] + [((? NT expr) . parts-rest) + (with-syntax ([parts-rest (loop #'parts-rest)]) + #'(NT . parts-rest))] + [(part0 . parts-rest) + (identifier? #'part0) + (with-syntax ([parts-rest (loop #'parts-rest)]) + #'(part0 . parts-rest))])) + action)) + + (define-for-syntax (elaborate-interrupted-alternate alt wrap? wrap-error?) + (define pattern (car alt)) + (define action (cdr alt)) + (let loop ([parts pattern] [position 1]) + (syntax-case parts (? !) + [() + ;; Can't be interrupted + null] + [(! . parts-rest) + (loop #'((! #f) . parts-rest) position)] + [((! expr) . parts-rest) + (cons + ;; Error occurs + (with-syntax ([Error (I 'syntax-error #;Error)] + [action action] + [position-argument (I (symbol+ '$ position))]) + (elaborate-skipped-tail + #'Error + #'parts-rest + (if wrap-error? + #'(make-error-wrap position-argument expr action) + #'action))) + ;; Error doesn't occur + (with-syntax ([NoError (I 'NoError)]) + (loop #'(NoError . parts-rest) position)))] + [((? NT) . parts-rest) + (loop #'((? NT #f) . parts-rest) position)] + [((? NT expr) . parts-rest) + (cons + ;; NT is interrupted + (with-syntax ([NT/I (I (symbol+ #'NT '/Interrupted))] + [action action]) + (elaborate-skipped-tail + #'NT/I + #'parts-rest + (if wrap? + #'(make-interrupted-wrap expr action) + #'action))) + ;; NT is not interrupted + (loop #'(NT . parts-rest) position))] + [(part0 . parts-rest) + (identifier? #'part0) + (map (lambda (clause) (cons #`(part0 . #,(car clause)) (cdr clause))) + (loop #'parts-rest (add1 position)))]))) + + (define-syntax (production/I stx) + (syntax-case stx () + [(production/I (name form ...)) + (let () + (define-values (options alternates) + (partition-options/alternates (syntax->list #'(form ...)))) + (define successful-alternates + (map elaborate-successful-alternate alternates)) + (define interrupted-alternates + (apply append + (map (lambda (a) + (elaborate-interrupted-alternate a + (not (assq #:no-wrap options)) + (not (assq #:no-wrap-error options)))) + alternates))) + (with-syntax ([((success-pattern . success-action) ...) + successful-alternates] + [((interrupted-pattern . interrupted-action) ...) + interrupted-alternates] + [skip-spec (assq #:skipped options)] + [args-spec (assq #:args options)] + [name/Skipped (I (symbol+ #'name '/Skipped))] + [name/Interrupted (I (symbol+ #'name '/Interrupted))] + [%action ((syntax-local-certifier) #'%action)]) + #`(begin + (productions + (name [success-pattern + (%action args-spec success-action)] + ...) + (name/Skipped [() (%skipped args-spec skip-spec)])) + #,(if (and (not (assq #:no-interrupted options)) + (pair? interrupted-alternates)) + #'(productions + (name/Interrupted [interrupted-pattern + (%action args-spec interrupted-action)] + ...)) + #'(begin)))))])) + + (define-syntax (skipped-token-values stx) + (syntax-case stx () + [(skipped-token-values) + #'(begin)] + [(skipped-token-values name . more) + (identifier? #'name) + (with-syntax ([name/Skipped (I (symbol+ #'name '/Skipped))]) + #'(begin (productions (name/Skipped [() #f])) + (skipped-token-values . more)))] + [(skipped-token-values (name value) . more) + (with-syntax ([name/Skipped (I (symbol+ #'name '/Skipped))]) + #'(begin (productions (name/Skipped [() value])) + (skipped-token-values . more)))])) + + (define-syntax (%skipped stx) + (syntax-case stx () + [(%skipped args (#:skipped . expr)) + #'(%action args expr)] + [(%skipped args #f) + #'(%action args #f)])) + + (define-syntax (%action stx) + (syntax-case stx () + [(elaborate-action (#:args . args) action) + #'(lambda args action)] + [(elaborate-action #f action) + #'action])) + + ) +\ No newline at end of file diff --git a/collects/macro-debugger/syntax-browser.ss b/collects/macro-debugger/syntax-browser.ss @@ -0,0 +1,7 @@ + +(module syntax-browser mzscheme + (require "syntax-browser/syntax-browser.ss") + + (provide browse-syntax + browse-syntaxes + syntax-snip)) diff --git a/collects/macro-debugger/syntax-browser/controller.ss b/collects/macro-debugger/syntax-browser/controller.ss @@ -0,0 +1,69 @@ + +(module controller mzscheme + (require (lib "class.ss") + "interfaces.ss" + "partition.ss" + "properties.ss") + + (provide syntax-controller%) + + ;; syntax-controller% + (define syntax-controller% + (class* object% (syntax-controller<%> + syntax-pp-snip-controller<%> + color-controller<%>) + + (define colorers null) + (define selection-listeners null) + (define selected-syntax #f) + (init-field (properties-controller + (new independent-properties-controller% (controller this)))) + + ;; syntax-controller<%> Methods + + (define/public (select-syntax stx) + (set! selected-syntax stx) + (send properties-controller set-syntax stx) + (for-each (lambda (c) (send c select-syntax stx)) colorers) + (for-each (lambda (p) (p stx)) selection-listeners)) + + (define/public (get-selected-syntax) + selected-syntax) + + (define/public (get-properties-controller) properties-controller) + + (define/public (add-view-colorer c) + (set! colorers (cons c colorers)) + (send c select-syntax selected-syntax)) + + (define/public (get-view-colorers) colorers) + + (define/public (add-selection-listener p) + (set! selection-listeners (cons p selection-listeners))) + + (define/public (on-update-identifier=? id=?) + (set! -secondary-partition + (and id=? (new partition% (relation id=?)))) + (for-each (lambda (c) (send c refresh)) colorers)) + + (define/public (erase) + (set! colorers null)) + + ;; syntax-pp-snip-controller<%> Methods + + (define/public (on-select-syntax stx) + (select-syntax stx)) + + ;; color-controller<%> Methods + + (define -primary-partition (new-bound-partition)) + (define -secondary-partition #f) + + (define/public (get-primary-partition) -primary-partition) + (define/public (get-secondary-partition) -secondary-partition) + + ;; Initialization + (super-new) + )) + + ) diff --git a/collects/macro-debugger/syntax-browser/hrule-snip.ss b/collects/macro-debugger/syntax-browser/hrule-snip.ss @@ -0,0 +1,34 @@ + +(module hrule-snip mzscheme + (require (lib "class.ss") + (lib "mred.ss" "mred")) + (provide hrule-snip%) + + ;; hrule-snip% + ;; A snip for drawing horizontal separating lines. + (define hrule-snip% + (class snip% + (inherit get-admin) + (define/override (get-extent dc x y bw bh bdescent bspace blspace brspace) + (let-values [((h) (get-xheight dc)) + ((fw fh) (send dc get-size))] + (let ([ad-x (box 0)] + [ad-y (box 0)]) + (send (get-admin) get-view-size ad-x ad-y) + #;(set-box?! bw fw) + (set-box?! bw (unbox ad-x)) + (set-box?! bh h)))) + (define/override (draw dc x y left top right bottom dx dy draw-caret) + (let* [(xh (get-xheight dc)) + (ny (+ y (/ xh 2)))] + (send dc draw-line x ny right ny))) + (define/private (set-box?! b v) + (when (box? b) (set-box! b v))) + (define/private (get-xheight dc) + (or cached-xheight + (let-values [((w h descent extra) (send dc get-text-extent "x"))] + (set! cached-xheight h) + h))) + (define cached-xheight #f) + (super-new))) + ) diff --git a/collects/macro-debugger/syntax-browser/interfaces.ss b/collects/macro-debugger/syntax-browser/interfaces.ss @@ -0,0 +1,123 @@ + +(module interfaces mzscheme + (require (lib "class.ss")) + (provide (all-defined)) + + ;; syntax-controller<%> + ;; A syntax-controller coordinates state shared by many different syntax views. + ;; Syntax views can share: + ;; - selection + ;; - partitioning configuration + ;; - property display + (define syntax-controller<%> + (interface () + ;; select-syntax : syntax -> void + select-syntax + + ;; get-selected-syntax : -> syntax/#f + get-selected-syntax + + ;; get-properties-controller : -> syntax-properties-controller<%> + get-properties-controller + + ;; add-view-colorer : syntax-colorer<%> -> void + add-view-colorer + + ;; get-view-colorers : -> (list-of syntax-colorer<%>) + get-view-colorers + + ;; add-selection-listener : syntax -> void + add-selection-listener + )) + + ;; syntax-properties-controller<%> + (define syntax-properties-controller<%> + (interface () + ;; set-syntax : syntax -> void + set-syntax + + ;; show : boolean -> void + #;show + + ;; is-shown? : -> boolean + #;is-shown?)) + + ;; syntax-configuration<%> + (define syntax-configuration<%> + (interface () + ;; get-primary-partition : -> partition<%> + get-primary-partition + + ;; get-secondary-partition : -> partition<%> + get-secondary-partition + + ;; update-identifier=? : ... -> void + update-identifier=?)) + + + ;; syntax-colorer<%> + (define syntax-colorer<%> + (interface () + select-syntax + apply-styles)) + + ;;---------- + + ;; Convenience widget, specialized for displaying stx and not much else + (define syntax-browser<%> + (interface () + add-syntax + add-text + add-separator + erase-all + select-syntax + get-text + )) + + (define partition<%> + (interface () + ;; get-partition : any -> number + get-partition + + ;; same-partition? : any any -> number + same-partition? + + ;; count : -> number + count)) + + ;; Internal interfaces + + (define syntax-pp-snip-controller<%> + (interface () + on-select-syntax + )) + + (define color-controller<%> + (interface () + get-primary-partition + get-secondary-partition + )) + + (define syntax-pp<%> + (interface () + pretty-print-syntax + + get-range + get-identifier-list + flat=>stx + stx=>flat)) + + (define typesetter<%> + (interface () + get-output-port + get-current-position)) + + (define range<%> + (interface () + get-start + set-start + get-ranges + add-range + all-ranges)) + + ) diff --git a/collects/macro-debugger/syntax-browser/partition.ss b/collects/macro-debugger/syntax-browser/partition.ss @@ -0,0 +1,160 @@ + +(module partition mzscheme + (require (lib "class.ss") + (lib "boundmap.ss" "syntax") + (lib "stx.ss" "syntax") + "interfaces.ss") + (provide new-bound-partition + partition% + identifier=-choices) + + (define (new-bound-partition) + #;(define p (new partition% (relation id:same-marks?))) + (define p (new bound-partition%)) + (send p get-partition (datum->syntax-object #f 'no-marks)) + p) + + ;; representative-symbol : symbol + ;; Must be fresh---otherwise, using it could detect rename wraps + ;; instead of only marks. + ;; For example, in (lambda (representative) representative) + (define representative-symbol + (gensym 'representative)) + + ;; unmarked-syntax : identifier + ;; Has no marks---used to initialize bound partition so that + ;; unmarked syntax always gets colored "black" + (define unmarked-syntax + (datum->syntax-object #f representative-symbol)) + + (define partition% + (class* object% (partition<%>) + (init relation) + + (define related? relation) + (field (rep=>num (make-hash-table))) + (field (obj=>rep (make-hash-table 'weak))) + (field (reps null)) + (field (next-num 0)) + + (define/public (get-partition obj) + (rep->partition (obj->rep obj))) + + (define/public (same-partition? A B) + (= (get-partition A) (get-partition B))) + + (define/private (obj->rep obj) + (hash-table-get obj=>rep obj (lambda () (obj->rep* obj)))) + + (define/public (count) + next-num) + + (define/private (obj->rep* obj) + (let loop ([reps reps]) + (cond [(null? reps) + (new-rep obj)] + [(related? obj (car reps)) + (hash-table-put! obj=>rep obj (car reps)) + (car reps)] + [else + (loop (cdr reps))]))) + + (define/private (new-rep rep) + (hash-table-put! rep=>num rep next-num) + (set! next-num (add1 next-num)) + (set! reps (cons rep reps)) + rep) + + (define/private (rep->partition rep) + (hash-table-get rep=>num rep)) + + ;; Nearly useless as it stands + (define/public (dump) + (hash-table-for-each + rep=>num + (lambda (k v) + (printf "~s => ~s~n" k v)))) + + (super-new) + )) + + ;; bound-partition% + (define bound-partition% + (class* object% (partition<%>) + ;; numbers : bound-identifier-mapping[identifier => number] + (define numbers (make-bound-identifier-mapping)) + (define next-number 0) + + (define/public (get-partition stx) + (let* ([r (representative stx)] + [n (bound-identifier-mapping-get numbers r (lambda _ #f))]) + (or n + (begin0 next-number + (bound-identifier-mapping-put! numbers r next-number) + (set! next-number (add1 next-number)))))) + + (define/public (same-partition? a b) + (= (get-partition a) (get-partition b))) + + (define/public (count) + next-number) + + (define/private (representative stx) + (datum->syntax-object stx representative-symbol)) + + (super-new))) + + ;; Different identifier relations for highlighting. + + (define (lift/rep id=?) + (lambda (A B) + (let ([ra (datum->syntax-object A representative-symbol)] + [rb (datum->syntax-object B representative-symbol)]) + (id=? ra rb)))) + + (define (lift id=?) + (lambda (A B) + (and (identifier? A) (identifier? B) (id=? A B)))) + + ;; id:same-marks? : syntax syntax -> boolean + (define id:same-marks? + (lift/rep bound-identifier=?)) + + ;; id:X-module=? : identifier identifier -> boolean + ;; If both module-imported, do they come from the same module? + ;; If both top-bound, then same source. + (define (id:source-module=? a b) + (let ([ba (identifier-binding a)] + [bb (identifier-binding b)]) + (cond [(or (eq? 'lexical ba) (eq? 'lexical bb)) + (module-identifier=? a b)] + [(and (not ba) (not bb)) + #t] + [(or (not ba) (not bb)) + #f] + [else + (eq? (car ba) (car bb))]))) + (define (id:nominal-module=? A B) + (let ([ba (identifier-binding A)] + [bb (identifier-binding B)]) + (cond [(or (eq? 'lexical ba) (eq? 'lexical bb)) + (module-identifier=? A B)] + [(or (not ba) (not bb)) + (and (not ba) (not bb))] + [else (eq? (caddr ba) (caddr bb))]))) + + (define (symbolic-identifier=? A B) + (eq? (syntax-e A) (syntax-e B))) + + (define identifier=-choices + (make-parameter + `(("<nothing>" . #f) + ("bound-identifier=?" . ,bound-identifier=?) + ("same marks" . ,id:same-marks?) + ("module-identifier=?" . ,module-identifier=?) + ("module-or-top-identifier=?" . ,module-or-top-identifier=?) + ("symbolic-identifier=?" . ,symbolic-identifier=?) + ("same source module" . ,id:source-module=?) + ("same nominal module" . ,id:nominal-module=?)))) + + ) +\ No newline at end of file diff --git a/collects/macro-debugger/syntax-browser/prefs.ss b/collects/macro-debugger/syntax-browser/prefs.ss @@ -0,0 +1,27 @@ + +(module prefs mzscheme + (require (lib "framework.ss" "framework")) + (provide (all-defined)) + + (define current-syntax-font-size (make-parameter 16)) + (define current-default-columns (make-parameter 40)) + + (define-syntax pref:get/set + (syntax-rules () + [(_ get/set prop) + (define get/set + (case-lambda + [() (preferences:get 'prop)] + [(newval) (preferences:set 'prop newval)]))])) + + (preferences:set-default 'SyntaxBrowser:Width 700 number?) + (preferences:set-default 'SyntaxBrowser:Height 600 number?) + (preferences:set-default 'SyntaxBrowser:PropertiesPanelPercentage 1/3 number?) + (preferences:set-default 'SyntaxBrowser:PropertiesPanelShown #t boolean?) + + (pref:get/set pref:width SyntaxBrowser:Width) + (pref:get/set pref:height SyntaxBrowser:Height) + (pref:get/set pref:props-percentage SyntaxBrowser:PropertiesPanelPercentage) + (pref:get/set pref:props-shown? SyntaxBrowser:PropertiesPanelShown) + + ) diff --git a/collects/macro-debugger/syntax-browser/pretty-helper.ss b/collects/macro-debugger/syntax-browser/pretty-helper.ss @@ -0,0 +1,81 @@ +(module pretty-helper mzscheme + (require (lib "class.ss") + "partition.ss") + (provide (all-defined)) + + ;; Fixme: null object still confusable. + + ;; Problem: If stx1 and stx2 are two distinguishable syntax objects, it + ;; still may be the case that (syntax-e stx1) and (syntax-e stx2) are + ;; indistinguishable. + + ;; Solution: Rather than map stx to (syntax-e stx), in the cases where + ;; (syntax-e stx) is confusable, map it to a different, unique, value. + ;; - stx is identifier : map it to an uninterned symbol w/ same rep + ;; (Symbols are useful: see pretty-print's style table) + ;; - else : map it to a syntax-dummy object + + (define-struct syntax-dummy (val)) + + ;; syntax->datum/tables : stx [partition% num boolean] + ;; -> (values s-expr hashtable hashtable) + ;; When partition is not false, tracks the partititions that subterms belong to + ;; When limit is a number, restarts processing with numbering? set to true + ;; When numbering? is true, suffixes identifiers with partition numbers. + ;; + ;; Returns three values: + ;; - an S-expression + ;; - a hashtable mapping S-expressions to syntax objects + ;; - a hashtable mapping syntax objects to S-expressions + ;; Syntax objects which are eq? will map to same flat values + (define syntax->datum/tables + (case-lambda + [(stx) (table stx #f #f #f)] + [(stx partition limit numbering?) (table stx partition limit numbering?)])) + + ;; table : syntax partition%-or-#f num-or-#f -> (values s-expr hashtable hashtable) + (define (table stx partition limit numbering?) + (define (make-identifier-proxy id) + (let ([n (send partition get-partition id)]) + (cond [(or (zero? n) (not numbering?)) + (string->uninterned-symbol (symbol->string (syntax-e id)))] + [else + (string->uninterned-symbol + (format "~a:~a" (syntax-e id) n))]))) + (let/ec escape + (let ([flat=>stx (make-hash-table)] + [stx=>flat (make-hash-table)]) + (values (let loop ([obj stx]) + (cond + [(hash-table-get stx=>flat obj (lambda _ #f)) + => (lambda (datum) datum)] + [(and partition (identifier? obj)) + (let ([lp-datum (make-identifier-proxy obj)]) + (when (and limit (> (send partition count) limit)) + (call-with-values (lambda () (table stx partition #f #t)) + escape)) + (hash-table-put! flat=>stx lp-datum obj) + (hash-table-put! stx=>flat obj lp-datum) + lp-datum)] + [(syntax? obj) + (void (send partition get-partition obj)) + (let ([lp-datum (loop (syntax-e obj))]) + (hash-table-put! flat=>stx lp-datum obj) + (hash-table-put! stx=>flat obj lp-datum) + lp-datum)] + [(pair? obj) + (cons (loop (car obj)) + (loop (cdr obj)))] + [(vector? obj) + (list->vector (map loop (vector->list obj)))] + [(symbol? obj) + #;(make-syntax-dummy obj) + (string->uninterned-symbol (symbol->string obj))] + [(number? obj) + (make-syntax-dummy obj)] + #;[(null? obj) + (make-syntax-dummy obj)] + [else obj])) + flat=>stx + stx=>flat)))) + ) diff --git a/collects/macro-debugger/syntax-browser/pretty-printer.ss b/collects/macro-debugger/syntax-browser/pretty-printer.ss @@ -0,0 +1,94 @@ + +(module pretty-printer mzscheme + (require (lib "list.ss") + (lib "class.ss") + (lib "pretty.ss") + (lib "mred.ss" "mred") + "pretty-range.ss" + "pretty-helper.ss" + "interfaces.ss" + "prefs.ss") + (provide syntax-pp% + (struct range (obj start end))) + + ;; syntax-pp% + ;; Pretty printer for syntax objects. + (define syntax-pp% + (class* object% (syntax-pp<%>) + (init-field main-stx) + (init-field typesetter) + (init-field (primary-partition #f)) + (init-field (columns (current-default-columns))) + + (unless (syntax? main-stx) + (error 'syntax-snip% "got non-syntax object: ~s" main-stx)) + + (define datum #f) + (define ht:flat=>stx #f) + (define ht:stx=>flat #f) + (define identifier-list null) + (define -range #f) + + (define/public (get-range) -range) + (define/public (get-identifier-list) identifier-list) + (define/public (flat=>stx obj) + (hash-table-get ht:flat=>stx obj)) + (define/public (stx=>flat obj) + (hash-table-get ht:stx=>flat obj)) + + (define/public (pretty-print-syntax) + (define range (new ranges%)) + (define (pp-pre-hook obj port) + (send range set-start obj (send typesetter get-current-position))) + (define (pp-post-hook obj port) + (let ([start (send range get-start obj)] + [end (send typesetter get-current-position)]) + (when start + (send range add-range + (flat=>stx obj) + (cons start end))))) + (define (pp-size-hook obj display-like? port) + (cond [(is-a? obj editor-snip%) + columns] + [(syntax-dummy? obj) + (let ((ostring (open-output-string))) + ((if display-like? display write) (syntax-dummy-val obj) ostring) + (string-length (get-output-string ostring)))] + [else #f])) + (define (pp-print-hook obj display-like? port) + (cond [(syntax-dummy? obj) + ((if display-like? display write) (syntax-dummy-val obj) port)] + [(is-a? obj editor-snip%) + (write-special obj port)] + [else + (error 'pretty-print-hook "unexpected special value: ~e" obj)])) + (define (pp-extend-style-table) + (let* ([ids identifier-list] + [syms (map (lambda (x) (stx=>flat x)) ids)] + [like-syms (map syntax-e ids)]) + (pretty-print-extend-style-table (pretty-print-current-style-table) + syms + like-syms))) + + (parameterize + ([pretty-print-pre-print-hook pp-pre-hook] + [pretty-print-post-print-hook pp-post-hook] + [pretty-print-size-hook pp-size-hook] + [pretty-print-print-hook pp-print-hook] + [pretty-print-columns columns] + [pretty-print-current-style-table (pp-extend-style-table)]) + (pretty-print datum (send typesetter get-output-port)) + (set! -range range))) + + ;; recompute-tables : -> void + (define/private (recompute-tables) + (set!-values (datum ht:flat=>stx ht:stx=>flat) + (syntax->datum/tables main-stx primary-partition 12 #f)) + (set! identifier-list + (filter identifier? (hash-table-map ht:stx=>flat (lambda (k v) k))))) + + ;; Initialization + (recompute-tables) + (super-new))) + + ) diff --git a/collects/macro-debugger/syntax-browser/properties.ss b/collects/macro-debugger/syntax-browser/properties.ss @@ -0,0 +1,173 @@ + +(module properties mzscheme + (require "prefs.ss" + "interfaces.ss" + "partition.ss" + "util.ss" + (lib "class.ss") + (lib "mred.ss" "mred")) + (provide properties-view% + independent-properties-controller%) + + ;; independent-properties-controller% + (define independent-properties-controller% + (class* object% (syntax-properties-controller<%>) + (init-field controller) + + ;; Properties display + (define parent + (new frame% (label "Properties and Configuration") (height (pref:height)) + (width (floor (* (pref:props-percentage) (pref:width)))))) + (define choice (new choice% (label "identifer=?") (parent parent) + (choices (map car (identifier=-choices))) + (callback (lambda _ (on-update-identifier=?-choice))))) + (new message% (label " ") (parent parent)) + (define pv (new properties-view% (parent parent))) + + (define/private (show-properties) + (unless (send parent is-shown?) + (send parent show #t))) + + (define/private (on-update-identifier=?-choice) + (let ([id=? (get-identifier=?)]) + (send controller on-update-identifier=? id=?))) + + (define/private (get-identifier=?) + (cond [(assoc (send choice get-string-selection) + (identifier=-choices)) + => cdr] + [else #f])) + + (define/public (set-syntax stx) + (send pv set-syntax stx)) + (define/public (show ?) + (send parent show ?)) + (define/public (is-shown?) + (send parent is-shown?)) + (super-new))) + + ;; properties-view% + (define properties-view% + (class* object% () + (init parent) + (define selected-syntax #f) + + (define tab-panel (new tab-panel% + (choices (list "Binding" "Source" "Properties")) + (parent parent) + (callback (lambda _ (refresh))))) + (define text (new text%)) + (send text set-styles-sticky #f) + (define ecanvas (new editor-canvas% (editor text) (parent tab-panel))) + + (define/public (set-syntax stx) + (set! selected-syntax stx) + (refresh)) + + (define/private (refresh) + (send* text + (lock #f) + (begin-edit-sequence) + (erase)) + (when (syntax? selected-syntax) + (let ([s (send tab-panel get-item-label (send tab-panel get-selection))]) + (cond [(equal? s "Binding") + (display-binding-info)] + [(equal? s "Source") + (display-source-info)] + [(equal? s "Properties") + (display-properties)]))) + (send* text + (end-edit-sequence) + (lock #t) + (scroll-to-position 0))) + + (define/private (display-binding-info) + (for-each (lambda (p) (display-binding-kv (car p) ((cdr p) selected-syntax))) + binding-properties)) + + (define/private (display-binding-kv k v) + (display (format "~a~n" k) key-sd) + (cond [(eq? v 'lexical) + (display "lexical\n" #f)] + [(eq? v #f) + (display "#f (top-level or unbound)\n" #f)] + [(list? v) + (display-subkv "source module" (mpi->string (list-ref v 0))) + (display-subkv "source id" (list-ref v 1)) + (display-subkv "nom. module" (mpi->string (list-ref v 2))) + (display-subkv "nom. id" (list-ref v 3)) + (if (list-ref v 4) + (display-subkv "phase" "via define-for-syntax"))] + [(void? v) + (display "Not applicable\n" n/a-sd)]) + (display "\n" #f)) + + (define/private (display-subkv k v) + (display (format "~a: " k) sub-key-sd) + (display (format "~a~n" v) #f)) + + (define/private (display-source-info) + (for-each (lambda (p) (display-subkv (car p) ((cdr p) selected-syntax))) + source-properties)) + + (define/private (display-properties) + (let ([keys (syntax-property-symbol-keys selected-syntax)]) + (if (null? keys) + (display "No properties available" n/a-sd) + (for-each (lambda (k) (display-kv k (syntax-property selected-syntax k))) + keys)))) + + (define/private (display-kv key value) + (display (format "~a~n" key) key-sd) + (display (format "~s~n~n" value) #f)) + + (define/private (display item sd) + (let ([p0 (send text last-position)]) + (send text insert item) + (let ([p1 (send text last-position)]) + (send text change-style sd p0 p1)))) + + (send text lock #t) + (super-new))) + + ;; lift/id : (identifier -> void) 'a -> void + (define (lift/id f) + (lambda (stx) (when (identifier? stx) (f stx)))) + + ;; binding-properties : (listof (cons string (syntax -> any))) + (define binding-properties + (list (cons "identifier-binding" + (lift/id identifier-binding)) + (cons "identifier-transformer-binding" + (lift/id identifier-transformer-binding)) + (cons "identifier-template-binding" + (lift/id identifier-template-binding)))) + + ;; source-properties : (listof (cons string (syntax -> any))) + (define source-properties + (list (cons "syntax-source" syntax-source) + (cons "syntax-source-module" + (lambda (stx) (mpi->string (syntax-source-module stx)))) + (cons "syntax-line" syntax-line) + (cons "syntax-position" syntax-position) + (cons "syntax-span" syntax-span) + (cons "syntax-original?" syntax-original?))) + + (define key-sd + (let ([sd (new style-delta%)]) + (send sd set-delta-foreground "blue") + (send sd set-weight-on 'bold) + sd)) + + (define sub-key-sd + (let ([sd (new style-delta%)]) + (send sd set-delta-foreground "blue") + sd)) + + (define n/a-sd + (let ([sd (new style-delta%)]) + (send sd set-delta-foreground "gray") + sd)) + + ) +\ No newline at end of file diff --git a/collects/macro-debugger/syntax-browser/syntax-snip.ss b/collects/macro-debugger/syntax-browser/syntax-snip.ss @@ -0,0 +1,154 @@ + +(module syntax-snip mzscheme + (require (lib "class.ss") + (lib "mred.ss" "mred") + "interfaces.ss" + "prefs.ss" + "properties.ss" + "typesetter.ss" + "widget.ss" + "partition.ss") + (provide syntax-snip% + super-syntax-snip%) + + (define current-syntax-controller (make-parameter #f)) + + (define (the-syntax-controller) + (let ([controller (current-syntax-controller)]) + (or controller + (let ([controller (new syntax-controller%)]) + (current-syntax-controller controller) + controller)))) + + + ;; syntax-snip% + (define syntax-snip% + (class* editor-snip% () + (init-field ((stx syntax))) + (init-field controller) + + (define -outer (new text%)) + (super-new (editor -outer)) + + ;; Initialization + (send -outer begin-edit-sequence) + (initialize -outer) + (outer:insert "Syntax browser" style:bold) + (outer:insert " ") + (outer:insert "Clear" style:hyper + (lambda (x y z) (send controller select-syntax #f))) + (outer:insert " ") + (outer:insert "Properties" style:hyper + (lambda (x y z) + (send (send controller get-properties-controller) + show #t))) + (outer:insert "\n") + (new typesetter-for-text% + (syntax stx) + (controller controller) + (text -outer)) + (send -outer lock #t) + (send -outer end-edit-sequence) + (send -outer hide-caret #t) + + (define/public (initialize outer) + (void)) + + (define/private outer:insert + (case-lambda + [(obj) + (outer:insert obj style:normal)] + [(text style) + (outer:insert text style #f)] + [(text style clickback) + (let ([start (send -outer last-position)]) + (send -outer insert text) + (let ([end (send -outer last-position)]) + (send -outer change-style style start end #f) + (when clickback + (send -outer set-clickback start end clickback))))])) + + ;; snip% Methods + + (define/override (copy) + (new syntax-snip% (controller controller) (syntax stx))) + + )) + + (define subservient-syntax-snip% + (class syntax-snip% + (init-field f) + (define/override (initialize outer) + (f outer)) + (super-new))) + + (define style:normal (make-object style-delta% 'change-normal)) + (define style:hyper + (let ([s (make-object style-delta% 'change-normal)]) + (send s set-delta 'change-toggle-underline) + (send s set-delta-foreground "blue") + s)) + (define style:bold + (let ([s (make-object style-delta% 'change-normal)]) + (send s set-delta 'change-bold) + s)) + + (define (show-icon) (make-object image-snip% (build-path (collection-path "icons") "turn-up.png"))) + (define (hide-icon) (make-object image-snip% (build-path (collection-path "icons") "turn-down.png"))) + + (define super-syntax-snip% + (class* editor-snip% () + (init-field ((stx syntax))) + (init-field (controller (the-syntax-controller))) + + (define -outer (new text%)) + (super-new (editor -outer) (with-border? #f)) + + (define/private (hide-me) + (send* -outer + (lock #f) + (erase)) + (outer:insert (show-icon) style:hyper (lambda _ (show-me))) + (outer:insert "#<syntax>") + (send -outer lock #t)) + + (define/private (show-me) + (send* -outer + (lock #f) + (erase)) + (outer:insert (new subservient-syntax-snip% + (syntax stx) + (controller controller) + (f (lambda (t) + (let* ([start (send t last-position)] + [_ (send t insert (hide-icon))] + [end (send t last-position)]) + (send t insert " ") + (send t change-style style:hyper start end #f) + (send t set-clickback start end (lambda _ (hide-me)))))))) + (send* -outer + (lock #t))) + + (define/private outer:insert + (case-lambda + [(obj) + (outer:insert obj style:normal)] + [(text style) + (outer:insert text style #f)] + [(text style clickback) + (let ([start (send -outer last-position)]) + (send -outer insert text) + (let ([end (send -outer last-position)]) + (send -outer change-style style start end #f) + (when clickback + (send -outer set-clickback start end clickback))))])) + + (define/override (copy) + (new super-syntax-snip% (controller controller) (syntax stx))) + + (hide-me) + (send -outer hide-caret #t) + (send -outer lock #t) + )) + + ) diff --git a/collects/macro-debugger/syntax-browser/util.ss b/collects/macro-debugger/syntax-browser/util.ss @@ -0,0 +1,50 @@ + +(module util mzscheme + (require (lib "class.ss")) + (provide with-unlock + mpi->string + mpi->list) + + (define-syntax with-unlock + (syntax-rules () + [(with-unlock text . body) + (let* ([t text] + [locked? (send t is-locked?)]) + (send t lock #f) + (let () . body) + (send t lock locked?))])) + + (define (mpi->string mpi) + (if (module-path-index? mpi) + (let ([mps (mpi->list mpi)]) + (cond [(and (pair? mps) (pair? (cdr mps))) + (apply string-append + (format "~s" (car mps)) + (map (lambda (x) (format " <= ~s" x)) (cdr mps)))] + [(and (pair? mps) (null? (cdr mps))) + (format "~s" (car mps))] + [(null? mps) "self"])) + (format "~s" mpi))) + + (define (mpi->list mpi) + (if mpi + (let-values ([(path rel) (module-path-index-split mpi)]) + (if (and (pair? path) (memq (car path) '(file lib planet))) + (cons path null) + (cons path (mpi->list rel)))) + '())) + +; ;; mpi->string : module-path-index -> string +; ;; Human-readable form of module-path-index +; (define (mpi->string x) +; (cond [(module-path-index? x) +; (let-values ([(path base) (module-path-index-split x)]) +; (cond [(eq? path #f) +; "self module"] +; [(eq? base #f) +; (format "top-level => ~a" path)] +; [else +; (format "~a => ~a" (mpi->string base) path)]))] +; [else x])) + + ) +\ No newline at end of file diff --git a/collects/macro-debugger/syntax-browser/widget.ss b/collects/macro-debugger/syntax-browser/widget.ss @@ -0,0 +1,184 @@ + +(module widget mzscheme + (require "interfaces.ss" + "controller.ss" + "typesetter.ss" + "hrule-snip.ss" + "properties.ss" + "partition.ss" + "prefs.ss" + "util.ss" + (lib "list.ss") + (lib "class.ss") + (lib "framework.ss" "framework") + (lib "mred.ss" "mred")) + (provide syntax-controller% + syntax-widget% + syntax-browser-frame%) + + ;; syntax-widget% + ;; A syntax-widget creates its own syntax-controller. + (define syntax-widget% + (class* object% (syntax-browser<%> syntax-properties-controller<%>) + (init parent) + + (define -main-panel (new vertical-panel% (parent parent))) + (define -split-panel (new panel:horizontal-dragable% (parent -main-panel))) + (define -text (new text%)) + (define -ecanvas (new editor-canvas% (parent -split-panel) (editor -text))) + (define -props-panel (new horizontal-panel% (parent -split-panel))) + (define props (new properties-view% (parent -props-panel))) + (define -saved-panel-percentages #f) + + (define controller + (new syntax-controller% + (properties-controller this))) + + #;(send -text hide-caret #t) + (send -text lock #t) + (send -split-panel set-percentages + (let ([pp (pref:props-percentage)]) (list (- 1 pp) pp))) + (toggle-props) + + ;; syntax-properties-controller<%> methods + + (define/public (set-syntax stx) + (send props set-syntax stx)) + + (define/public (show ?) + (if ? (show-props) (hide-props))) + + (define/public (is-shown?) + (send -props-panel is-shown?)) + + (define/public (toggle-props) + (if (send -props-panel is-shown?) + (hide-props) + (show-props))) + + (define/public (hide-props) + (when (send -props-panel is-shown?) + (set! -saved-panel-percentages (send -split-panel get-percentages)) + (send -split-panel delete-child -props-panel) + (send -props-panel show #f))) + + (define/public (show-props) + (unless (send -props-panel is-shown?) + (send -split-panel add-child -props-panel) + (send -split-panel set-percentages -saved-panel-percentages) + (send -props-panel show #t))) + + ;; + + (define/public (get-controller) controller) + + ;; + + (define/public (get-main-panel) -main-panel) + + (define/public (on-close) + (unless (= (cadr -saved-panel-percentages) (pref:props-percentage)) + (pref:props-percentage (cadr -saved-panel-percentages)))) + + ;; syntax-browser<%> Methods + + (define/public (add-text text) + (with-unlock -text + (send -text insert text))) + + (define/public add-syntax + (case-lambda + [(stx) + (internal-add-syntax stx null #f)] + [(stx hi-stxs hi-color) + (internal-add-syntax stx hi-stxs hi-color)])) + + (define/public (add-separator) + (with-unlock -text + (send* -text + (insert (new hrule-snip%)) + (insert "\n")))) + + (define/public (erase-all) + (with-unlock -text (send -text erase)) + (send controller erase)) + + (define/public (select-syntax stx) + (send controller select-syntax stx)) + + (define/public (get-text) -text) + + (define/private (internal-add-syntax stx hi-stxs hi-color) + (with-unlock -text + (let ([current-position (send -text last-position)]) + (let* ([new-ts (new typesetter-for-text% + (controller controller) + (syntax stx) + (text -text))] + [new-colorer (send new-ts get-colorer)]) + (send* -text + (insert "\n") + (scroll-to-position current-position)) + (unless (null? hi-stxs) + (send new-colorer highlight-syntaxes hi-stxs hi-color)))))) + + (super-new))) + + ;; syntax-widget/controls% + (define syntax-widget/controls% + (class* syntax-widget% () + (inherit get-main-panel + get-controller + toggle-props) + + (super-new) + + (define -control-panel + (new horizontal-pane% (parent (get-main-panel)) (stretchable-height #f))) + + ;; Put the control panel up front + (send (get-main-panel) change-children + (lambda (children) + (cons -control-panel (remq -control-panel children)))) + + (define -identifier=-choices (identifier=-choices)) + (define -choice + (new choice% (label "identifer=?") (parent -control-panel) + (choices (map car -identifier=-choices)) + (callback (lambda _ (on-update-identifier=?-choice))))) + (new button% + (label "Clear") + (parent -control-panel) + (callback (lambda _ (send (get-controller) select-syntax #f)))) + (new button% + (label "Properties") + (parent -control-panel) + (callback (lambda _ (toggle-props)))) + + (define/private (on-update-identifier=?-choice) + (let ([id=? (get-identifier=?)]) + (send (get-controller) on-update-identifier=? id=?))) + + (define/private (get-identifier=?) + (cond [(assoc (send -choice get-string-selection) + -identifier=-choices) + => cdr] + [else #f])))) + + + ;; syntax-browser-frame% + (define syntax-browser-frame% + (class* frame% () + (super-new (label "Syntax Browser") + (width (pref:width)) + (height (pref:height))) + (define widget (new syntax-widget/controls% (parent this))) + (define/public (get-widget) widget) + (define/augment (on-close) + (pref:width (send this get-width)) + (pref:height (send this get-height)) + (send widget on-close) + (preferences:save) + (inner (void) on-close)) + )) + ) diff --git a/collects/macro-debugger/view/cursor.ss b/collects/macro-debugger/view/cursor.ss @@ -0,0 +1,87 @@ + +(module cursor mzscheme + (provide (all-defined)) + + ;; Cursors + +;; (define-struct cursor (v n)) +;; +;; (define (cursor:new items) +;; (if (pair? items) +;; (make-cursor (list->vector items) 0) +;; (make-cursor #f #f))) +;; +;; (define (cursor:current c) +;; (when (cursor-n c) +;; (vector-ref (cursor-v c) (cursor-n c)))) +;; (define (cursor:move-next c) +;; (when (cursor:can-move-next? c) +;; (set-cursor-n! c (add1 (cursor-n c))))) +;; (define (cursor:move-previous c) +;; (when (cursor:can-move-previous? c) +;; (set-cursor-n! c (sub1 (cursor-n c))))) +;; (define (cursor:move-to-start c) +;; (when (cursor-n c) +;; (set-cursor-n! c 0))) +;; (define (cursor:move-to-end c) +;; (when (cursor-n c) +;; (set-cursor-n! c (sub1 (vector-length (cursor-v c)))))) +;; +;; (define (cursor:can-move-next? c) +;; (and (cursor-n c) (< (cursor-n c) (sub1 (vector-length (cursor-v c)))))) +;; +;; (define (cursor:can-move-previous? c) +;; (and (cursor-n c) (> (cursor-n c) 0))) + + + (define-struct cursor (prefix suffixp)) + + (define (cursor-suffix c) + (if (promise? (cursor-suffixp c)) + (force (cursor-suffixp c)) + (cursor-suffixp c))) + (define set-cursor-suffix! set-cursor-suffixp!) + + (define (cursor:new items) + (if (pair? items) + (make-cursor null items) + ; A convenient lie + (make-cursor null (list #f)))) + + (define (cursor:current c) + (let ([suffix (cursor-suffix c)]) + (car suffix))) + + (define (cursor:move-to-start c) + (when (cursor:can-move-previous? c) + (cursor:move-previous c) + (cursor:move-to-start c))) + + (define (cursor:move-to-end c) + (when (cursor:can-move-next? c) + (cursor:move-next c) + (cursor:move-to-end c))) + + (define (cursor:move-previous c) + (when (pair? (cursor-prefix c)) + (let ([old-prefix-cell (cursor-prefix c)]) + (set-cursor-prefix! c (cdr old-prefix-cell)) + (set-cdr! old-prefix-cell (cursor-suffix c)) + (set-cursor-suffix! c old-prefix-cell)))) + + (define (cursor:move-next c) + (when (cursor:can-move-next? c) + (let ([old-suffix-cell (cursor-suffix c)]) + (set-cursor-suffix! c (cdr old-suffix-cell)) + (set-cdr! old-suffix-cell (cursor-prefix c)) + (set-cursor-prefix! c old-suffix-cell)))) + + (define (cursor:can-move-next? c) + (pair? (cdr (cursor-suffix c)))) + + (define (cursor:can-move-previous? c) + (pair? (cursor-prefix c))) + + + + ) +\ No newline at end of file