From b5e5c83b911db531f29ffe107b4af2ad8498b055 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 4 Apr 2008 17:38:23 +0000 Subject: [PATCH] sync Ryan's macro-debugger changes svn: r9166 original commit: 5165d9e8559eda1245acee8296c81613c3770c7a --- collects/macro-debugger/expand.ss | 2 +- collects/macro-debugger/model/debug.ss | 6 +- collects/macro-debugger/model/deriv-c.ss | 42 +- collects/macro-debugger/model/deriv-parser.ss | 273 ++++++------- collects/macro-debugger/model/deriv-tokens.ss | 18 +- collects/macro-debugger/model/deriv.ss | 2 +- .../macro-debugger/model/hiding-policies.ss | 173 ++++---- .../macro-debugger/model/reductions-engine.ss | 144 ++++--- collects/macro-debugger/model/reductions.ss | 380 +++++++++--------- collects/macro-debugger/model/steps.ss | 1 + .../macro-debugger/model/yacc-interrupted.ss | 5 + collects/macro-debugger/stepper-text.ss | 3 - .../macro-debugger/syntax-browser/display.ss | 14 +- .../macro-debugger/syntax-browser/keymap.ss | 131 +++--- .../macro-debugger/syntax-browser/prefs.ss | 38 +- .../syntax-browser/pretty-printer.ss | 2 + .../syntax-browser/properties.ss | 3 +- .../syntax-browser/syntax-snip.ss | 272 +++++++------ .../macro-debugger/syntax-browser/util.ss | 30 +- .../macro-debugger/syntax-browser/widget.ss | 69 +--- collects/macro-debugger/util/mpi.ss | 23 ++ collects/macro-debugger/view/debug-format.ss | 2 +- collects/macro-debugger/view/extensions.ss | 72 ++-- collects/macro-debugger/view/frame.ss | 15 +- collects/macro-debugger/view/hiding-panel.ss | 45 +-- collects/macro-debugger/view/prefs.ss | 8 +- collects/macro-debugger/view/term-record.ss | 13 +- 27 files changed, 888 insertions(+), 898 deletions(-) create mode 100644 collects/macro-debugger/util/mpi.ss diff --git a/collects/macro-debugger/expand.ss b/collects/macro-debugger/expand.ss index ecb9f1e..058dadf 100644 --- a/collects/macro-debugger/expand.ss +++ b/collects/macro-debugger/expand.ss @@ -20,5 +20,5 @@ (let-values ([(result deriv) (trace/result stx)]) (when (exn? result) (raise result)) - (let-values ([(_d estx) (hide/policy deriv show?)]) + (let-values ([(_d estx) (hide*/policy deriv show?)]) estx))) diff --git a/collects/macro-debugger/model/debug.ss b/collects/macro-debugger/model/debug.ss index d345a20..3447f46 100644 --- a/collects/macro-debugger/model/debug.ss +++ b/collects/macro-debugger/model/debug.ss @@ -7,9 +7,11 @@ "deriv-util.ss" "deriv-find.ss" "hide.ss" + "seek.ss" "hiding-policies.ss" "deriv.ss" - "steps.ss") + "steps.ss" + "synth-derivs.ss") (provide (all-from-out "trace.ss") (all-from-out "reductions.ss") @@ -18,5 +20,7 @@ (all-from-out "deriv-find.ss") (all-from-out "hiding-policies.ss") (all-from-out "hide.ss") + (all-from-out "seek.ss") (all-from-out "steps.ss") + (all-from-out "synth-derivs.ss") (all-from-out scheme/match)) diff --git a/collects/macro-debugger/model/deriv-c.ss b/collects/macro-debugger/model/deriv-c.ss index 7a7d597..64863aa 100644 --- a/collects/macro-debugger/model/deriv-c.ss +++ b/collects/macro-debugger/model/deriv-c.ss @@ -16,6 +16,7 @@ (define-struct (deriv node) () #:transparent) (define-struct (lift-deriv deriv) (first lift-stx second) #:transparent) (define-struct (mrule deriv) (transformation next) #:transparent) +(define-struct (tagrule deriv) (tagged-stx next) #:transparent) ;; A DerivLL is one of ;; (make-lift/let-deriv Deriv Stx Deriv) @@ -24,7 +25,7 @@ ;; A Transformation is ;; (make-transformation Rs ?exn ?Stx (list-of LocalAction) ?exn ?Stx Number) -(define-struct (transformation node) (resolves ?1 me1 locals ?2 me2 seq) #:transparent) +(define-struct (transformation node) (resolves ?1 me1 locals me2 ?2 seq) #:transparent) ;; A LocalAction is one of ;; (make-local-expansion Stx ?Stx Boolean Deriv) @@ -32,11 +33,11 @@ ;; (make-local-lift Stx Identifier) ;; (make-local-lift-end Stx) ;; (make-local-bind BindSyntaxes) -(define-struct (local-expansion node) (me1 me2 for-stx? inner) #:transparent) -(define-struct (local-expansion/expr node) (me1 me2 for-stx? opaque inner) #:transparent) +(define-struct (local-expansion node) (me1 me2 inner for-stx? lifted opaque) + #:transparent) (define-struct local-lift (expr id) #:transparent) (define-struct local-lift-end (decl) #:transparent) -(define-struct local-bind (bindrhs) #:transparent) +(define-struct local-bind (names bindrhs) #:transparent) ;; Base = << Node(Stx) Rs ?exn >> (define-struct (base deriv) (resolves ?1) #:transparent) @@ -45,10 +46,11 @@ (define-struct (prule base) () #:transparent) (define-struct (p:variable prule) () #:transparent) -;; (make-p:module Boolean ?Deriv ?exn Deriv) -;; (make-p:#%module-begin ModulePass1 ModulePass2 ?exn) -(define-struct (p:module prule) (one-body-form? mb ?2 body) #:transparent) -(define-struct (p:#%module-begin prule) (pass1 pass2 ?2) #:transparent) +;; (make-p:module ?exn ?stx stx ?Deriv ?stx ?exn Deriv ?stx) +;; (make-p:#%module-begin Stx ModulePass1 ModulePass2 ?exn) +(define-struct (p:module prule) (?2 tag rename check tag2 ?3 body shift) + #:transparent) +(define-struct (p:#%module-begin prule) (me pass1 pass2 ?2) #:transparent) ;; (make-p:define-syntaxes DerivLL) ;; (make-p:define-values Deriv) @@ -61,7 +63,7 @@ ;; (make-p:set! Rs Deriv) ;; (make-p:set!-macro Rs Deriv) (define-struct (p:#%expression prule) (inner) #:transparent) -(define-struct (p:if prule) (full? test then else) #:transparent) +(define-struct (p:if prule) (test then else) #:transparent) (define-struct (p:wcm prule) (key mark body) #:transparent) (define-struct (p:set! prule) (id-resolves rhs) #:transparent) (define-struct (p:set!-macro prule) (deriv) #:transparent) @@ -69,7 +71,7 @@ ;; (make-p:#%app Stx LDeriv) ;; (make-p:begin LDeriv) ;; (make-p:begin0 Deriv LDeriv) -(define-struct (p:#%app prule) (tagged-stx lderiv) #:transparent) +(define-struct (p:#%app prule) (lderiv) #:transparent) (define-struct (p:begin prule) (lderiv) #:transparent) (define-struct (p:begin0 prule) (first lderiv) #:transparent) @@ -97,8 +99,8 @@ (define-struct (p::STOP prule) () #:transparent) (define-struct (p:stop p::STOP) () #:transparent) (define-struct (p:unknown p::STOP) () #:transparent) -(define-struct (p:#%top p::STOP) (tagged-stx) #:transparent) -(define-struct (p:#%datum p::STOP) (tagged-stx) #:transparent) +(define-struct (p:#%top p::STOP) () #:transparent) +(define-struct (p:#%datum p::STOP) () #:transparent) (define-struct (p:quote p::STOP) () #:transparent) (define-struct (p:quote-syntax p::STOP) () #:transparent) (define-struct (p:require p::STOP) () #:transparent) @@ -151,21 +153,21 @@ ;; A ModPass2 is (list-of ModRule2) ;; A ModRule1 is one of -;; (make-mod:prim Deriv ModPrim) -;; (make-mod:splice Deriv ?exn Stxs) -;; (make-mod:lift Deriv Stxs) +;; (make-mod:prim Deriv Stx ModPrim) +;; (make-mod:splice Deriv Stx ?exn Stxs) +;; (make-mod:lift Deriv ?Stxs Stxs) ;; (make-mod:lift-end Stxs) ;; A ModRule2 is one of ;; (make-mod:skip) ;; (make-mod:cons Deriv) ;; (make-mod:lift Deriv Stxs) (define-struct modrule () #:transparent) -(define-struct (mod:cons modrule) (head) #:transparent) -(define-struct (mod:prim modrule) (head prim) #:transparent) -(define-struct (mod:skip modrule) () #:transparent) -(define-struct (mod:splice modrule) (head ?1 tail) #:transparent) -(define-struct (mod:lift modrule) (head tail) #:transparent) +(define-struct (mod:prim modrule) (head rename prim) #:transparent) +(define-struct (mod:splice modrule) (head rename ?1 tail) #:transparent) +(define-struct (mod:lift modrule) (head renames tail) #:transparent) (define-struct (mod:lift-end modrule) (tail) #:transparent) +(define-struct (mod:cons modrule) (head) #:transparent) +(define-struct (mod:skip modrule) () #:transparent) ;; A ModPrim is a PRule in: ;; (make-p:define-values #:transparent) diff --git a/collects/macro-debugger/model/deriv-parser.ss b/collects/macro-debugger/model/deriv-parser.ss index 277d9fd..b6161d5 100644 --- a/collects/macro-debugger/model/deriv-parser.ss +++ b/collects/macro-debugger/model/deriv-parser.ss @@ -49,7 +49,8 @@ (tokens basic-tokens prim-tokens renames-tokens) (end EOF) (error deriv-error) - #;(debug "DEBUG-PARSER.txt")) + #;(debug "/Users/ryanc/DEBUG-PARSER.txt") + ) ;; tokens (skipped-token-values @@ -60,12 +61,15 @@ enter-list exit-list enter-check exit-check local-post exit-local exit-local/expr + local-bind enter-bind exit-bind phase-up module-body renames-lambda renames-case-lambda renames-let renames-letrec-syntaxes renames-block + rename-one + rename-list IMPOSSIBLE) ;; Entry point @@ -76,42 +80,17 @@ (productions/I - ;; Expand/Lifts + ;; Expand with possible lifting (EE/Lifts - (#:no-wrap) [((? EE)) $1] - [((? EE/Lifts+)) $1]) - - (EE/Lifts+ - (#:no-wrap) [(EE lift-loop (? EE/Lifts)) (let ([e1 (wderiv-e1 $1)] [e2 (wderiv-e2 $3)]) (make lift-deriv e1 e2 $1 $2 $3))]) - ;; Expansion of an expression - ;; EE Answer = Derivation (I) - (EE - (#:no-wrap) - [(visit (? PrimStep) return) - ($2 $1 $3)] - [((? EE/Macro)) - $1]) - - (EE/Macro - (#:wrap) - [(visit (? MacroStep) (? EE)) - (make mrule $1 (and $3 (wderiv-e2 $3)) $2 $3)]) - - ;; Expand/LetLifts - ;; Used for expand_lift_to_let (rhs of define-syntaxes, mostly) + ;; Expand, convert lifts to let (rhs of define-syntaxes, mostly) (EE/LetLifts - (#:no-wrap) [((? EE)) $1] - [((? EE/LetLifts+)) $1]) - - (EE/LetLifts+ - (#:wrap) [(EE lift/let-loop (? EE/LetLifts)) (let ([initial (wderiv-e1 $1)] [final (wderiv-e2 $3)]) @@ -120,126 +99,128 @@ ;; Evaluation ;; Answer = ?exn (Eval - (#:no-wrap) [() #f] [(!!) $1] [(start EE/Interrupted) (create-eval-exn $2)] [(start EE (? Eval)) $3] [(start CheckImmediateMacro/Interrupted) (create-eval-exn $2)] [(start CheckImmediateMacro (? Eval)) $3]) - + ;; Expansion of an expression to primitive form (CheckImmediateMacro - (#:no-wrap) [(enter-check (? CheckImmediateMacro/Inner) exit-check) ($2 $1 $3 (lambda (ce1 ce2) (make p:stop ce1 ce2 null #f)))]) (CheckImmediateMacro/Inner (#:args e1 e2 k) - (#:wrap) [() (k e1 e2)] - [(visit (? MacroStep) return (? CheckImmediateMacro/Inner)) - (let ([next ($4 $3 e2 k)]) - (make mrule $1 (and next (wderiv-e2 next)) $2 next))]) + [(visit Resolves (? MacroStep) return (? CheckImmediateMacro/Inner)) + (let ([next ($5 $4 e2 k)]) + (make mrule $1 (and next (wderiv-e2 next)) ($3 $2) next))] + [(visit Resolves tag (? MacroStep) return (? CheckImmediateMacro/Inner)) + (let ([next ($6 $5 e2 k)]) + (let ([mnode (make mrule $1 (and next (wderiv-e2 next)) ($4 $2) next)]) + (make tagrule $1 (wderiv-e2 mnode) $3 mnode)))]) ;; Expansion of multiple expressions, next-separated (NextEEs - (#:no-wrap) (#:skipped null) [() null] [(next (? EE) (? NextEEs)) (cons $2 $3)]) + ;; EE + + ;; Expand expression (term) + (EE + [(visit Resolves (? EE/k)) + ($3 $1 $2)] + [(visit Resolves tag (? EE/k)) + (let ([next ($4 $1 $2)]) + (make tagrule $1 (wderiv-e2 next) $3 next))]) + + (EE/k + (#:args e1 rs) + [((? PrimStep) return) + ($1 e1 $2 rs)] + [((? MacroStep) (? EE)) + (make mrule e1 (and $2 (wderiv-e2 $2)) ($1 rs) $2)]) + ;; Keyword resolution (Resolves - (#:no-wrap) [() null] [(resolve Resolves) (cons $1 $2)]) ;; Single macro step (may contain local-expand calls) ;; MacroStep Answer = Transformation (I,E) (MacroStep - (#:wrap) - [(Resolves enter-macro ! macro-pre-transform (? LocalActions) - ! macro-post-transform exit-macro) - (make transformation $2 $8 $1 $3 $4 $5 $6 $7 (new-sequence-number))]) + (#:args rs) + [(enter-macro ! macro-pre-transform (? LocalActions) + ! macro-post-transform ! exit-macro) + (make transformation $1 $8 rs $2 $3 $4 $6 (or $5 $7) (new-sequence-number))]) ;; Local actions taken by macro ;; LocalAction Answer = (list-of LocalAction) (LocalActions - (#:no-wrap) (#:skipped null) [() null] [((? LocalAction) (? LocalActions)) (cons $1 $2)] [((? NotReallyLocalAction) (? LocalActions)) $2]) (LocalAction - (#:no-wrap) - [(enter-local local-pre start (? EE) local-post exit-local) - (make local-expansion $1 $6 $2 $5 #f $4)] - [(enter-local phase-up local-pre start (? EE) local-post exit-local) - (make local-expansion $1 $7 $3 $6 #t $5)] - [(enter-local/expr local-pre start (? EE) local-post exit-local/expr) - (make local-expansion/expr $1 (car $6) $2 $5 #f (cdr $6) $4)] - [(enter-local/expr local-pre phase-up start (? EE) local-post exit-local/expr) - (make local-expansion/expr $1 (car $7) $3 $6 #t (cdr $7) $5)] + [(enter-local OptPhaseUp + local-pre (? LocalExpand/Inner) local-post + OptLifted OptOpaqueExpr exit-local) + (make local-expansion $1 $8 $3 $5 $4 $2 $6 $7)] [(lift) (make local-lift (cdr $1) (car $1))] [(lift-statement) (make local-lift-end $1)] - [((? BindSyntaxes)) - (make local-bind $1)]) + [(local-bind (? BindSyntaxes)) + (make local-bind $1 $2)]) + + (LocalExpand/Inner + [(start (? EE)) $2] + [((? CheckImmediateMacro)) $1]) + (OptLifted + [(lift-loop) $1] + [() #f]) + (OptOpaqueExpr + [(opaque) $1] + [() #f]) + (OptPhaseUp + [(phase-up) #t] + [() #f]) (NotReallyLocalAction - (#:no-wrap) ;; called 'expand' (not 'local-expand') within transformer [(start (? EE)) - (make local-expansion (wderiv-e1 $2) - (wderiv-e2 $2) - (wderiv-e1 $2) - (wderiv-e2 $2) - #f - $2)]) + #f]) ;; Primitive (PrimStep - (#:args e1 e2) - (#:no-wrap) - [(Resolves (? PrimError)) - ($2 e1 e2 $1)] - [(Resolves Variable) - ($2 e1 e2 $1)] - [(Resolves enter-prim (? Prim) exit-prim) - ($3 e1 e2 $1)] - [(Resolves enter-prim (? TaggedPrim) exit-prim) - ($3 e1 $4 $1 $2)]) - - (PrimError (#:args e1 e2 rs) - (#:wrap) - [(! IMPOSSIBLE) - (make p:unknown e1 e2 rs $1)]) - - (Variable - (#:args e1 e2 rs) - (#:wrap) + [(!!) + (make p:unknown e1 e2 rs $1)] [(variable) - (make p:variable e1 e2 rs #f)]) - - (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)]) + (make p:variable e1 e2 rs #f)] + [(enter-prim (? Prim) exit-prim) + (begin + (unless (eq? $3 e2) + (fprintf (current-error-port) + "warning: exit-prim and return differ:\n~s\n~s\n" + $3 e2)) + ($2 $1 $3 rs))]) (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)] [((? PrimExpression)) ($1 e1 e2 rs)] + [((? Prim#%App)) ($1 e1 e2 rs)] + [((? Prim#%Datum)) ($1 e1 e2 rs)] + [((? Prim#%Top)) ($1 e1 e2 rs)] [((? PrimIf)) ($1 e1 e2 rs)] [((? PrimWCM)) ($1 e1 e2 rs)] [((? PrimSet)) ($1 e1 e2 rs)] @@ -261,22 +242,24 @@ (PrimModule (#:args e1 e2 rs) - (#:wrap) - ;; Multiple forms after language: tagging done automatically - [(prim-module (? Eval) (? EE)) - (make p:module e1 e2 rs $2 #f #f #f $3)] - ;; One form after language: macro that expands into #%module-begin - [(prim-module Eval next (? CheckImmediateMacro) next ! (? EE)) - (make p:module e1 e2 rs #f #t $4 $6 $7)]) - + [(prim-module ! next (? Eval) OptTag rename-one + (? OptCheckImmediateMacro) OptTag ! + (? EE) rename-one) + (make p:module e1 e2 rs $2 $4 $5 $6 $7 $8 $9 $10 $11)]) + (OptTag + [() #f] + [(tag) $1]) + (OptCheckImmediateMacro + [() #f] + [((? CheckImmediateMacro)) $1]) + (Prim#%ModuleBegin (#:args e1 e2 rs) - (#:wrap) - [(prim-#%module-begin ! (? ModulePass1) next-group (? ModulePass2) !) - (make p:#%module-begin e1 e2 rs $2 $3 $5 $6)]) + [(prim-#%module-begin ! rename-one + (? ModulePass1) next-group (? ModulePass2) !) + (make p:#%module-begin e1 e2 rs $2 $3 $4 $6 $7)]) (ModulePass1 - (#:no-wrap) (#:skipped null) [() null] [(next (? ModulePass1-Part) (? ModulePass1)) @@ -285,16 +268,14 @@ (cons (make mod:lift-end $1) $2)]) (ModulePass1-Part - (#:wrap) - [((? EE) (? ModulePass1/Prim)) - (make mod:prim $1 $2)] - [(EE ! splice) - (make mod:splice $1 $2 $3)] - [(EE module-lift-loop) - (make mod:lift $1 $2)]) + [((? EE) rename-one (? ModulePass1/Prim)) + (make mod:prim $1 $2 $3)] + [(EE rename-one ! splice) + (make mod:splice $1 $2 $3 $4)] + [(EE rename-list module-lift-loop) + (make mod:lift $1 $2 $3)]) (ModulePass1/Prim - (#:wrap) [(enter-prim prim-define-values ! exit-prim) (make p:define-values $1 $4 null $3 #f)] [(enter-prim prim-define-syntaxes ! @@ -306,13 +287,10 @@ (make p:require-for-syntax $1 $4 null $3)] [(enter-prim prim-require-for-template (? Eval) exit-prim) (make p:require-for-template $1 $4 null $3)] - [(enter-prim prim-provide ! exit-prim) - (make p:provide $1 $4 null $3)] [() #f]) (ModulePass2 - (#:no-wrap) (#:skipped null) [() null] [(next (? ModulePass2-Part) (? ModulePass2)) @@ -321,106 +299,98 @@ (cons (make mod:lift-end $1) $2)]) (ModulePass2-Part - (#:no-wrap) ;; not normal; already handled [() (make mod:skip)] + ;; provide: special + [(enter-prim prim-provide (? ModuleProvide/Inner) exit-prim) + (make mod:cons (make p:provide $1 $4 null $3))] ;; normal: expand completely [((? EE)) (make mod:cons $1)] ;; catch lifts [(EE module-lift-loop) - (make mod:lift $1 $2)]) + (make mod:lift $1 #f $2)]) + + (ModuleProvide/Inner + [() #f] + [(!!) $1] + [(EE/Interrupted) $1] + [(EE (? ModuleProvide/Inner)) $2]) ;; Definitions (PrimDefineSyntaxes (#:args e1 e2 rs) - (#:wrap) [(prim-define-syntaxes ! (? EE/LetLifts) (? Eval)) (make p:define-syntaxes e1 e2 rs $2 $3 $4)]) (PrimDefineValues (#:args e1 e2 rs) - (#:wrap) [(prim-define-values ! (? EE)) (make p:define-values e1 e2 rs $2 $3)]) ;; Simple expressions (PrimExpression (#:args e1 e2 rs) - (#:wrap) [(prim-expression ! (? EE)) (make p:#%expression e1 e2 rs $2 $3)]) (PrimIf (#:args e1 e2 rs) - (#:wrap) [(prim-if ! (? EE) next (? EE) next (? EE)) - (make p:if e1 e2 rs $2 #t $3 $5 $7)] - [(prim-if next-group (? EE) next (? EE)) - (make p:if e1 e2 rs #f #f $3 $5 #f)]) + (make p:if e1 e2 rs $2 $3 $5 $7)]) (PrimWCM (#:args e1 e2 rs) - (#:wrap) [(prim-wcm ! (? EE) next (? EE) next (? EE)) (make p:wcm e1 e2 rs $2 $3 $5 $7)]) ;; Sequence-containing expressions (PrimBegin (#:args e1 e2 rs) - (#:wrap) [(prim-begin ! (? EL)) (make p:begin e1 e2 rs $2 $3)]) (PrimBegin0 (#:args e1 e2 rs) - (#:wrap) [(prim-begin0 ! next (? EE) next (? EL)) (make p:begin0 e1 e2 rs $2 $4 $6)]) (Prim#%App - (#:args e1 e2 rs tagged-stx) - (#:wrap) + (#:args e1 e2 rs) [(prim-#%app !) - (make p:#%app e1 e2 rs $2 tagged-stx (make lderiv null null #f null))] + (make p:#%app e1 e2 rs $2 (make lderiv null null #f null))] [(prim-#%app (? EL)) - (make p:#%app e1 e2 rs #f tagged-stx $2)]) + (make p:#%app e1 e2 rs #f $2)]) ;; Binding expressions (PrimLambda (#:args e1 e2 rs) - (#:wrap) [(prim-lambda ! renames-lambda (? EB)) (make p:lambda e1 e2 rs $2 $3 $4)]) (PrimCaseLambda (#:args e1 e2 rs) - (#:wrap) [(prim-case-lambda ! (? NextCaseLambdaClauses)) (make p:case-lambda e1 e2 rs $2 $3)]) (NextCaseLambdaClauses (#:skipped null) - (#:no-wrap) [(next (? CaseLambdaClause) (? NextCaseLambdaClauses)) (cons $2 $3)] [() null]) (CaseLambdaClause - (#:wrap) [(! renames-case-lambda (? EB)) (make clc $1 $2 $3)]) (PrimLetValues (#:args e1 e2 rs) - (#:wrap) [(prim-let-values ! renames-let (? NextEEs) next-group (? EB)) (make p:let-values e1 e2 rs $2 $3 $4 $6)]) (PrimLet*Values (#:args e1 e2 rs) - (#:wrap) ;; let*-values with bindings is "macro-like" [(prim-let*-values !!) (let ([tx (make transformation e1 #f rs $2 @@ -429,7 +399,7 @@ [(prim-let*-values (? EE)) (let* ([next-e1 (wderiv-e1 $2)] [tx (make transformation e1 next-e1 rs #f - e1 null #f next-e1 (new-sequence-number))]) + e1 null next-e1 #f (new-sequence-number))]) (make mrule e1 e2 tx $2))] ;; No bindings... model as "let" [(prim-let*-values renames-let (? NextEEs) next-group (? EB)) @@ -437,13 +407,11 @@ (PrimLetrecValues (#:args e1 e2 rs) - (#:wrap) [(prim-letrec-values ! renames-let (? NextEEs) next-group (? EB)) (make p:letrec-values e1 e2 rs $2 $3 $4 $6)]) (PrimLetrecSyntaxes+Values (#:args e1 e2 rs) - (#:wrap) [(prim-letrec-syntaxes+values ! renames-letrec-syntaxes (? NextBindSyntaxess) next-group (? EB)) (make p:letrec-syntaxes+values e1 e2 rs $2 $3 $4 #f null $6)] @@ -455,66 +423,55 @@ ;; Atomic expressions (Prim#%Datum - (#:args e1 e2 rs tagged-stx) - (#:wrap) - [(prim-#%datum !) (make p:#%datum e1 e2 rs $2 tagged-stx)]) + (#:args e1 e2 rs) + [(prim-#%datum !) (make p:#%datum e1 e2 rs $2)]) (Prim#%Top - (#:args e1 e2 rs tagged-stx) - (#:wrap) - [(prim-#%top !) (make p:#%top e1 e2 rs $2 tagged-stx)]) + (#:args e1 e2 rs) + [(prim-#%top !) (make p:#%top e1 e2 rs $2)]) (PrimSTOP (#:args e1 e2 rs) - (#:wrap) [(prim-stop !) (make p:stop e1 e2 rs $2)]) (PrimQuote (#:args e1 e2 rs) - (#:wrap) [(prim-quote !) (make p:quote e1 e2 rs $2)]) (PrimQuoteSyntax (#:args e1 e2 rs) - (#:wrap) [(prim-quote-syntax !) (make p:quote-syntax e1 e2 rs $2)]) (PrimRequire (#:args e1 e2 rs) - (#:wrap) [(prim-require (? Eval)) (make p:require e1 e2 rs $2)]) (PrimRequireForSyntax (#:args e1 e2 rs) - (#:wrap) [(prim-require-for-syntax (? Eval)) (make p:require-for-syntax e1 e2 rs $2)]) (PrimRequireForTemplate (#:args e1 e2 rs) - (#:wrap) [(prim-require-for-template (? Eval)) (make p:require-for-template e1 e2 rs $2)]) (PrimProvide (#:args e1 e2 rs) - (#:wrap) [(prim-provide !) (make p:provide e1 e2 rs $2)]) (PrimSet (#:args e1 e2 rs) - (#:wrap) [(prim-set! ! Resolves next (? EE)) (make p:set! e1 e2 rs $2 $3 $5)] - [(prim-set! (? MacroStep) (? EE)) + [(prim-set! Resolves (? MacroStep) (? EE)) (make p:set!-macro e1 e2 rs #f - (make mrule e1 (and $3 (wderiv-e2 $3)) $2 $3))]) + (make mrule e1 (and $4 (wderiv-e2 $4)) ($3 $2) $4))]) ;; Blocks ;; EB Answer = BlockDerivation (EB - (#:wrap) [(enter-block (? BlockPass1) block->list (? EL)) (make bderiv $1 (and $4 (wlderiv-es2 $4)) $2 'list $4)] @@ -524,7 +481,6 @@ ;; BlockPass1 Answer = (list-of BRule) (BlockPass1 - (#:no-wrap) (#:skipped null) [() null] [((? BRule) (? BlockPass1)) @@ -532,7 +488,6 @@ ;; BRule Answer = BRule (BRule - (#:wrap) [(next !!) (make b:error $2)] [(next renames-block (? CheckImmediateMacro)) @@ -547,13 +502,11 @@ ;; BindSyntaxes Answer = Derivation (BindSyntaxes - (#:wrap) - [(phase-up (? EE/LetLifts) (? Eval)) - (make bind-syntaxes $2 $3)]) + [(enter-bind (? EE/LetLifts) next (? Eval) exit-bind) + (make bind-syntaxes $2 $4)]) ;; NextBindSyntaxess Answer = (list-of Derivation) (NextBindSyntaxess - (#:no-wrap) (#:skipped null) [() null] [(next (? BindSyntaxes) (? NextBindSyntaxess)) (cons $2 $3)]) @@ -561,7 +514,6 @@ ;; Lists ;; EL Answer = ListDerivation (EL - (#:wrap) (#:skipped #f) [(enter-list ! (? EL*) exit-list) ;; FIXME: Workaround for bug in events @@ -571,7 +523,6 @@ ;; EL* Answer = (listof Derivation) (EL* - (#:no-wrap) (#:skipped null) [() null] [(next (? EE) (? EL*)) (cons $2 $3)]) diff --git a/collects/macro-debugger/model/deriv-tokens.ss b/collects/macro-debugger/model/deriv-tokens.ss index 7cf5f05..cd5284b 100644 --- a/collects/macro-debugger/model/deriv-tokens.ss +++ b/collects/macro-debugger/model/deriv-tokens.ss @@ -44,7 +44,16 @@ enter-local/expr ; syntax exit-local/expr ; (cons syntax expanded-expression) - variable ; (cons identifier identifier) + local-bind ; (list-of identifier) + enter-bind ; . + exit-bind ; . + opaque ; opaque-syntax + + variable ; (cons identifier identifier) + tag ; syntax + + rename-one ; syntax + rename-list ; (list-of syntax) IMPOSSIBLE ; useful for error-handling clauses that have no NoError counterpart )) @@ -142,6 +151,13 @@ (139 . ,token-enter-local/expr) (140 . ,token-exit-local/expr) (141 . ,token-start) + (142 . ,token-tag) + (143 . ,token-local-bind) + (144 . ,token-enter-bind) + (145 . ,token-exit-bind) + (146 . ,token-opaque) + (147 . ,token-rename-list) + (148 . ,token-rename-one) )) (define (tokenize sig-n val pos) diff --git a/collects/macro-debugger/model/deriv.ss b/collects/macro-debugger/model/deriv.ss index 21c1eab..a7be9bd 100644 --- a/collects/macro-debugger/model/deriv.ss +++ b/collects/macro-debugger/model/deriv.ss @@ -59,8 +59,8 @@ [?1 (?? exn?)] [me1 (?? syntax?)] [locals (?? (listof localaction/c))] - [?2 (?? exn?)] [me2 (?? syntax?)] + [?2 (?? exn?)] [seq number?])) (struct (local-expansion node) ([z1 syntax?] diff --git a/collects/macro-debugger/model/hiding-policies.ss b/collects/macro-debugger/model/hiding-policies.ss index 9c10ea9..753f3c6 100644 --- a/collects/macro-debugger/model/hiding-policies.ss +++ b/collects/macro-debugger/model/hiding-policies.ss @@ -2,100 +2,103 @@ #lang scheme/base (require (for-syntax scheme/base) scheme/match - syntax/boundmap) -(provide (all-defined-out)) + syntax/boundmap + "synth-engine.ss") +(provide make-policy + standard-policy + base-policy + hide-all-policy + hide-none-policy) -(define-struct hiding-policy - (opaque-modules opaque-ids opaque-kernel opaque-libs transparent-ids) - #:mutable) +;; make-policy : bool^4 (listof (identifier bindinglist (bool -> void) -> void)) +;; -> identifier -> bool +(define (make-policy hide-mzscheme? + hide-libs? + hide-contracts? + hide-transformers? + specialized-policies) + (lambda (id) + (define now (phase)) + (define binding + (cond [(= now 0) (identifier-binding id)] + [(= now 1) (identifier-transformer-binding id)] + [else #f])) + (define-values (def-mod def-name nom-mod nom-name) + (if (pair? binding) + (values (car binding) + (cadr binding) + (caddr binding) + (cadddr binding)) + (values #f #f #f #f))) + (let/ec return + (let loop ([policies specialized-policies]) + (when (pair? policies) + ((car policies) id binding return) + (loop (cdr policies)))) + (cond [(and hide-mzscheme? def-mod (scheme-module? def-mod)) + #f] + [(and hide-libs? def-mod (lib-module? def-mod)) + #f] + [(and hide-contracts? def-name + (regexp-match #rx"^provide/contract-id-" + (symbol->string def-name))) + #f] + [(and hide-transformers? (positive? now)) + #f] + [else #t])))) -(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 standard-policy + (make-policy #t #t #t #t null)) -(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 base-policy + (make-policy #t #f #f #f null)) -(define (policy-hide-libs p) - (set-hiding-policy-opaque-libs! p #t)) -(define (policy-unhide-libs p) - (set-hiding-policy-opaque-libs! p #f)) +(define (hide-all-policy id) #f) +(define (hide-none-policy id) #t) -(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 - #f - (make-module-identifier-mapping))) - -(define (new-standard-hiding-policy) - (let ([p (new-hiding-policy)]) - (policy-hide-kernel p) - (policy-hide-libs 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 - opaque-libs - transparent-identifiers)) - (inline ([not-opaque-id - (not (module-identifier-mapping-get opaque-identifiers id /false))] - [transparent-id - (module-identifier-mapping-get transparent-identifiers id /false)]) - (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)))] - [in-lib-module? - (lib-module? srcmod)]) - (or transparent-id - (and (not opaque-srcmod) - (not opaque-nommod) - (not (and in-kernel? opaque-kernel)) - (not (and in-lib-module? opaque-libs)) - not-opaque-id)))) - (or transparent-id - not-opaque-id))))])) +(define (scheme-module? mpi) + (let ([abs (find-absolute-module-path mpi)]) + (and abs + (or (base-module-path? abs) + (scheme-lib-module-path? abs))))) (define (lib-module? mpi) + (let ([abs (find-absolute-module-path mpi)]) + (and abs (lib-module-path? abs)))) + + +(define (find-absolute-module-path mpi) (and (module-path-index? mpi) (let-values ([(path rel) (module-path-index-split mpi)]) - (cond [(pair? path) (memq (car path) '(lib planet))] - [(string? path) (lib-module? rel)] + (cond [(and (pair? path) (memq (car path) '(quote lib planet))) + path] + [(symbol? path) path] + [(string? path) (find-absolute-module-path rel)] [else #f])))) + +(define (base-module-path? mp) + (and (pair? mp) + (eq? 'quote (car mp)) + (regexp-match #rx"^#%" (symbol->string (cadr mp))))) + +(define (scheme-lib-module-path? mp) + (cond [(symbol? mp) + (scheme-collection-name? (symbol->string mp))] + [(and (pair? mp) (eq? (car mp) 'lib)) + (cond [(string? (cadr mp)) (null? (cddr mp)) + (scheme-collection-name? (cadr mp))] + [(symbol? (cadr mp)) + (scheme-collection-name? (symbol->string (cadr mp)))] + [else #f])] + [else #f])) + +(define (scheme-collection-name? path) + (or (regexp-match? #rx"^scheme/base(/.)?" path) + (regexp-match? #rx"^mzscheme(/.)?" path))) + +(define (lib-module-path? mp) + (or (symbol? mp) + (and (pair? mp) (memq (car mp) '(lib planet))))) diff --git a/collects/macro-debugger/model/reductions-engine.ss b/collects/macro-debugger/model/reductions-engine.ss index 66b1d5d..ac2e9bf 100644 --- a/collects/macro-debugger/model/reductions-engine.ss +++ b/collects/macro-debugger/model/reductions-engine.ss @@ -158,16 +158,19 @@ [(CC HOLE expr pattern) #'(syntax-copier HOLE expr pattern)])) -;; (R stx R-clause ...) +;; R +;; the threaded reductions engine + +;; (R stx R-clause ...) : (values (list-of Step) ?stx ?exn) ;; An R-clause is one of ;; [! expr] ;; [#:pattern pattern] ;; [#:bind pattern stx-expr] ;; [#:let-values (var ...) expr] -;; [#:set-syntax stx-expr] -;; [#:walk term2 foci1 foci2 description] ;; [#:walk term2 description] -;; [#:rename form2 foci1 foci2 description] +;; [#:walk/ctx pattern term2 description] +;; [#:walk/foci term2 foci1 foci2 description] +;; [#:rename* pattern rename [description]] ;; [#:rename/no-step pattern stx stx] ;; [#:reductions expr] ;; [#:learn ids] @@ -176,26 +179,22 @@ ;; [#:if/np test R-clause ...] ;; [generator hole fill] -;; R -;; the threaded reductions engine - -;; (R form . clauses) : (values (list-of Step) ?stx ?exn) - (define-syntax R (syntax-rules () [(R form . clauses) - (R** #f _ [#:set-syntax form] . clauses)])) + (let ([form-var form]) + (R** form-var _ . clauses))])) (define-syntax R** (syntax-rules (! =>) ;; Base: done [(R** form-var pattern) (RSunit form-var)] - + ;; Base: explicit continuation [(R** f p => k) (k f)] - + ;; Error-point case [(R** f p [! maybe-exn] . more) (let ([x maybe-exn]) @@ -204,34 +203,26 @@ (if x (values (list (stumble f x)) #f x) (R** f p . more)))] - + ;; 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 (with-syntax ([p f]) rhs)]) (R** f p . more))] - + ;; Bind variables [(R** f p [#:let-values (var ...) rhs] . more) (let-values ([(var ...) (with-syntax ([p f]) 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 and Step (explicit foci) - [(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))]) - (RSadd (list (walk/foci foci1-var foci2-var f form2-var description-var)) - (lambda () (R** form2-var p . more))))] - + ;; Change syntax and Step (infer foci) [(R** f p [#:walk form2 description] . more) (let-values ([(form2-var description-var) @@ -239,8 +230,52 @@ (values form2 description))]) (RSadd (list (walk f form2-var description-var)) (lambda () (R** form2-var p . more))))] - + + ;; Change syntax and Step (explicit foci) + [(R** f p [#:walk/foci form2 foci1 foci2 description] . more) + (let-values ([(form2-var foci1-var foci2-var description-var) + (with-syntax ([p f]) + (values form2 foci1 foci2 description))]) + (RSadd (list (walk/foci foci1-var foci2-var f form2-var description-var)) + (lambda () (R** form2-var p . more))))] + + [(R** f p [#:walk/ctx hole form2 desc] . more) + (let-values ([(form2-var desc-var) + (with-syntax ([p f]) + (values form2 desc))]) + (let ([k (lambda (f2) (R** f2 p . more))] + [generator + (lambda () + (lambda (d init-e1) + (R init-e1 + [#:walk form2-var desc-var])))]) + (Run f p generator hole form2 k)))] + + ;; Rename + [(R** f p [#:rename* pattern renames] . more) + (R** f p [#:rename* pattern renames #f] . more)] + + [(R** f p [#:rename* pattern renames description] . more) + (let-values ([(renames-var description-var) + (with-syntax ([p f]) + (values renames description))]) + (let ([pre-renames-var + (with-syntax ([p f]) (syntax pattern))] + [f2 + (with-syntax ([p f]) + (with-syntax ([pattern renames]) + (syntax p)))]) + (rename-frontier pre-renames-var renames-var) + (with-context (make-renames pre-renames-var renames-var) + (RSadd (if description-var + (list (walk/foci pre-renames-var renames-var + f f2 + description-var)) + null) + (lambda () (R** f2 p . more))))))] + ;; Change syntax with rename + #; [(R** f p [#:rename form2 foci1 foci2 description] . more) (let-values ([(form2-var foci1-var foci2-var description-var) (with-syntax ([p f]) @@ -251,7 +286,7 @@ f form2-var description-var)) (lambda () (R** form2-var p . more)))))] - + ;; Change syntax with rename (but no step) [(R** f p [#:rename/no-step pvar from to] . more) (let-values ([(from-var to-var) @@ -262,42 +297,42 @@ (rename-frontier from-var to-var) (with-context (make-renames from-var to-var) (R** f2 p . more))))] - + ;; Add in arbitrary other steps [(R** f p [#:reductions steps] . more) (RSseq (lambda () steps) (lambda () (R** f p . more)))] - + ;; Add to definites [(R** f p [#:learn ids] . more) (begin (learn-definites (with-syntax ([p f]) ids)) (R** f p . more))] - + ;; Add to frontier [(R** f p [#:frontier stxs] . more) (begin (add-frontier (with-syntax ([p f]) stxs)) (R** f p . more))] - + ;; Conditional (pattern changes lost afterwards ...) [(R** f p [#:if/np test [consequent ...] [alternate ...]] . more) (let ([continue (lambda (f2) (R** f2 p . more))]) (if (with-syntax ([p f]) test) (R** f p consequent ... => continue) (R** f p alternate ... => continue)))] - + ;; Conditional (pattern changes lost afterwards ...) [(R** f p [#:when/np test consequent ...] . more) (let ([continue (lambda (f2) (R** f2 p . more))]) (if (with-syntax ([p f]) test) (R** f p consequent ... => continue) (continue f)))] - + ;; Conditional [(R** f p [#:when test consequent ...] . more) (if (with-syntax ([p f]) test) (R** f p consequent ... . more) (R** f p . more))] - + ;; Subterm handling [(R** f p [generator hole fill] . more) (let ([k (lambda (f2) (R** f2 p . more))]) @@ -307,22 +342,28 @@ (define-syntax Run (syntax-rules () [(Run f p generator hole fill k) - (let ([reducer (with-syntax ([p f]) (generator))]) + (let ([reducer (generator)]) (Run* reducer f p hole fill k))])) (define-syntax (Run* stx) (syntax-case stx () ;; Implementation of subterm handling for (hole ...) sequences - [(Run* f form-var pattern (hole :::) fills k) + [(Run* reducer f p (hole :::) fills k) (and (identifier? #':::) (free-identifier=? #'::: (quote-syntax ...))) - #'(let ([ctx (CC (hole :::) form-var pattern)]) - (let ([e1s (with-syntax ([pattern form-var]) (syntax->list #'(hole :::)))]) - (run-multiple f ctx fills e1s k)))] + #'(let ([ctx (CC (hole :::) f p)]) + (let ([e1s (with-syntax ([p f]) (syntax->list #'(hole :::)))]) + (run-multiple reducer ctx fills e1s k)))] ;; Implementation of subterm handling - [(Run* f form-var pattern hole fill k) - #'(let ([ctx (CC hole form-var pattern)]) - (run-one f ctx fill k))])) + [(Run* reducer f p hole fill k) + #'(let ([init-e (with-syntax ([p f]) #'hole)] + [ctx (CC hole f p)]) + (run-one reducer init-e ctx fill k))])) + +;; run-one : (a stx -> RS(b)) stx (b -> c) (c -> RS(d)) -> RS(d) +(define (run-one f init-e ctx fill k) + (RSbind (lambda () (with-context ctx (f fill init-e))) + (lambda (final) (k (ctx final))))) ;; run-multiple : (a -> RS(b)) ((list-of b) -> c) (list-of a) (list-of b) (c -> RS(d)) ;; -> RS(d) @@ -334,21 +375,15 @@ (RSbind (lambda () (with-context ctx (with-context (lambda (x) (revappend prefix (cons x (cdr suffix)))) - (f (car fills))))) - (lambda (final) - (loop (cdr fills) - (cons final prefix) - (cdr suffix))))] + (f (car fills) (car suffix))))) + (lambda (final) + (loop (cdr fills) + (cons final prefix) + (cdr suffix))))] [(null? fills) (let ([form (ctx (reverse prefix))]) (k form))]))) -;; run-one : (a -> RS(b)) (b -> c) (c -> RS(d)) -> RS(d) -(define (run-one f ctx fill k) - (RSbind (lambda () (with-context ctx (f fill))) - (lambda (final) - (k (ctx final))))) - ;; Rename mapping (define (rename-frontier from to) @@ -367,7 +402,8 @@ [(syntax? to) (loop from (syntax-e to))] [(pair? from) - #;(unless (pair? to) + #; + (unless (pair? to) (fprintf (current-error-port) "from:\n~s\n\n" (syntax->datum from0)) (fprintf (current-error-port) diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss index 56cd7ba..ad898eb 100644 --- a/collects/macro-debugger/model/reductions.ss +++ b/collects/macro-debugger/model/reductions.ss @@ -19,14 +19,14 @@ transformation-reductions) (define (BindSyntaxes) bind-syntaxes-reductions) -(define ((CaseLambdaClauses e1)) - (mk-case-lambda-clauses-reductions e1)) -(define ((SynthItems e1)) - (mk-synth-items-reductions e1)) -(define ((BRules es1)) - (mk-brules-reductions es1)) -(define ((ModulePass es1)) - (mk-mbrules-reductions es1)) +(define (CaseLambdaClauses) + case-lambda-clauses-reductions) +(define (SynthItems) + synth-items-reductions) +(define (BRules) + brules-reductions) +(define (ModulePass) + mbrules-reductions) ;; Syntax @@ -41,24 +41,28 @@ ;; reductions : WDeriv -> ReductionSequence (define (reductions d) - (parameterize ((current-definites null) - (current-frontier null)) - (when d (add-frontier (list (wderiv-e1 d)))) - (RS-steps (reductions* d)))) + (let-values ([(steps definites estx exn) (reductions+ d)]) + steps)) ;; reductions+ : WDeriv -> (list-of step) (list-of identifier) ?stx ?exn (define (reductions+ d) (parameterize ((current-definites null) (current-frontier null)) (when d (add-frontier (list (wderiv-e1 d)))) - (let-values ([(rs stx exn) (reductions* d)]) - (values rs (current-definites) stx exn)))) + (let-values ([(steps stx exn) (reductions* d (wderiv-e1 d))]) + (values steps (current-definites) stx exn)))) -;; reductions* : WDeriv -> RS(stx) -(define (reductions* d) +;; reductions* : WDeriv Syntax -> RS(stx) +(define (reductions* d init-e1) (match d [(Wrap deriv (e1 e2)) - (blaze-frontier e1)] + (begin (blaze-frontier e1) + (unless (eq? init-e1 e1) + (void) + #;(fprintf (current-error-port) + "starting points don't match:\n~s\n~s\n" + init-e1 e1) + #;(error 'reductions* "starting points don't match for: ~s" d)))] [_ (void)]) (match d [(Wrap prule (e1 e2 rs ?1)) @@ -70,38 +74,41 @@ (R e1 [#:learn (list e2)] [#:when/np (not (bound-identifier=? e1 e2)) - [#:walk e2 e1 e2 'resolve-variable]])] - [(Wrap p:module (e1 e2 rs ?1 #f #f #f body)) + [#:walk e2 'resolve-variable]])] + [(Wrap p:module (e1 e2 rs ?1 ?2 tag rename check tag2 ?3 body shift)) (R e1 [! ?1] - [#:pattern (?module ?name ?language . ?_body)] - [#:walk (d->so e1 `(,#'?module ,#'?name ,#'?language ,(wderiv-e1 body))) - 'tag-module-begin] - [#:pattern (?module ?name ?language ?body)] - [#:frontier (list #'?body)] - [Expr ?body body])] - [(Wrap p:module (e1 e2 rs ?1 #t mb ?2 body)) - (R e1 - [! ?1] - [#:pattern (?module ?name ?language ?body)] - [#:frontier (list #'?body)] - [Expr ?body mb] + [#:pattern (?module ?name ?language . ?body-parts)] + #;[#:frontier null (list #'?language #'?body-parts)] [! ?2] - [#:when/np (not (eq? (wderiv-e2 mb) (wderiv-e1 body))) - [#:walk - (d->so e1 `(,#'?module ,#'?name ,#'?language - ,(wderiv-e1 body))) - 'tag-module-begin]] - [Expr ?body body])] - [(Wrap p:#%module-begin (e1 e2 rs ?1 pass1 pass2 ?2)) + #;[#:frontier (list #'?language) null] + [#:when/np tag + [#:walk/ctx ?body-parts + (list tag) + 'tag-module-begin]] + [#:pattern (?module ?name ?language ?body)] + [#:rename* ?body rename] + [#:when/np check + [Expr ?body check]] + [#:when/np tag2 + [#:walk/ctx ?body + tag2 + 'tag-module-begin]] + [! ?3] + [Expr ?body body] + [#:pattern ?form] + [#:rename* ?form shift])] + [(Wrap p:#%module-begin (e1 e2 rs ?1 me pass1 pass2 ?2)) (R e1 [! ?1] + #;[#:let-values (_) (printf "#%module-begin:\n~s\n" me)] + [#:pattern ?form] + [#:rename* ?form me] [#:pattern (?module-begin . ?forms)] - [#:frontier (stx->list* #'?forms)] - [(ModulePass #'?forms) - ?forms pass1] - [(ModulePass #'?forms) - ?forms pass2] + #;[#:frontier (syntax->list #'?forms)] + #;[#:let-values (_) (printf "#%module-begin ?forms:\n~s\n" #'?forms)] + [ModulePass ?forms pass1] + [ModulePass ?forms pass2] [! ?1])] [(Wrap p:define-syntaxes (e1 e2 rs ?1 rhs ?2)) (R e1 @@ -124,21 +131,14 @@ [#:pattern (?expr ?inner)] [#:frontier (list #'?inner)] [Expr ?inner inner])] - [(Wrap p:if (e1 e2 rs ?1 full? test then else)) - (if full? - (R e1 - [! ?1] - [#:pattern (?if TEST THEN ELSE)] - [#:frontier (list #'TEST #'THEN #'ELSE)] - [Expr TEST test] - [Expr THEN then] - [Expr ELSE else]) - (R e1 - [! ?1] - [#:pattern (?if TEST THEN)] - [#:frontier (list #'TEST #'THEN)] - [Expr TEST test] - [Expr THEN then]))] + [(Wrap p:if (e1 e2 rs ?1 test then else)) + (R e1 + [! ?1] + [#:pattern (?if TEST THEN ELSE)] + [#:frontier (list #'TEST #'THEN #'ELSE)] + [Expr TEST test] + [Expr THEN then] + [Expr ELSE else])] [(Wrap p:wcm (e1 e2 rs ?1 key mark body)) (R e1 [! ?1] @@ -160,42 +160,31 @@ [#:frontier (cons #'FIRST (stx->list* #'LDERIV))] [Expr FIRST first] [List LDERIV lderiv])] - [(Wrap p:#%app (e1 e2 rs ?1 tagged-stx lderiv)) + [(Wrap p:#%app (e1 e2 rs ?1 lderiv)) (R e1 [! ?1] - [#:when/np (not (eq? tagged-stx e1)) - [#:walk tagged-stx 'tag-app]] [#:pattern (?app . LDERIV)] [#:frontier (stx->list* #'LDERIV)] [List LDERIV lderiv])] [(Wrap p:lambda (e1 e2 rs ?1 renames body)) (R e1 [! ?1] - [#:bind (?formals* . ?body*) renames] [#:pattern (?lambda ?formals . ?body)] [#:frontier (stx->list* #'?body)] - [#:rename (syntax/skeleton e1 (?lambda ?formals* . ?body*)) - #'?formals #'?formals* - 'rename-lambda] + [#:rename* (?formals . ?body) renames 'rename-lambda] [Block ?body body])] [(Wrap p:case-lambda (e1 e2 rs ?1 clauses)) (R e1 [! ?1] [#:pattern (?case-lambda . ?clauses)] [#:frontier (stx->list* #'?clauses)] - [(CaseLambdaClauses (stx->list* #'?clauses)) - ?clauses clauses])] + [CaseLambdaClauses ?clauses clauses])] [(Wrap p:let-values (e1 e2 rs ?1 renames rhss body)) (R e1 [! ?1] [#:pattern (?let-values ([?vars ?rhs] ...) . ?body)] [#:frontier (append (syntax->list #'(?rhs ...)) (stx->list* #'?body))] - [#:bind (([?vars* ?rhs*] ...) . ?body*) renames] - [#:rename - (syntax/skeleton e1 (?let-values ([?vars* ?rhs*] ...) . ?body*)) - (syntax->list #'(?vars ...)) - (syntax->list #'(?vars* ...)) - 'rename-let-values] + [#:rename* (((?vars ?rhs) ...) . ?body) renames 'rename-let-values] [Expr (?rhs ...) rhss] [Block ?body body])] [(Wrap p:letrec-values (e1 e2 rs ?1 renames rhss body)) @@ -203,12 +192,7 @@ [! ?1] [#:pattern (?letrec-values ([?vars ?rhs] ...) . ?body)] [#:frontier (append (syntax->list #'(?rhs ...)) (stx->list* #'?body))] - [#:bind (([?vars* ?rhs*] ...) . ?body*) renames] - [#:rename - (syntax/skeleton e1 (?letrec-values ([?vars* ?rhs*] ...) . ?body*)) - (syntax->list #'(?vars ...)) - (syntax->list #'(?vars* ...)) - 'rename-letrec-values] + [#:rename* (((?vars ?rhs) ...) . ?body) renames 'rename-letrec-values] [Expr (?rhs ...) rhss] [Block ?body body])] [(Wrap p:letrec-syntaxes+values @@ -219,49 +203,39 @@ [#:frontier (append (syntax->list #'(?srhs ...)) (syntax->list #'(?vrhs ...)) (stx->list* #'?body))] - [#:bind (([?svars* ?srhs*] ...) ([?vvars* ?vrhs*] ...) . ?body*) srenames] - [#:rename - (syntax/skeleton e1 - (?lsv ([?svars* ?srhs*] ...) ([?vvars* ?vrhs*] ...) - . ?body*)) - (syntax->list #'(?svars ...)) - (syntax->list #'(?svars* ...)) - 'rename-lsv] + [#:rename* (((?svars ?srhs) ...) ((?vvars ?vrhs) ...) . ?body) srenames + 'rename-lsv] [BindSyntaxes (?srhs ...) srhss] ;; If vrenames is #f, no var bindings to rename [#:when/np vrenames [#:bind (([?vvars** ?vrhs**] ...) . ?body**) vrenames] - [#:rename - (syntax/skeleton e1 (?lsv ([?svars* ?srhs*] ...) - ([?vvars** ?vrhs**] ...) - . ?body**)) - (syntax->list #'(?vvars* ...)) - (syntax->list #'(?vvars** ...)) - 'rename-lsv]] + [#:rename* (((?vars ?vrhs) ...) . ?body) vrenames 'rename-lsv]] [Expr (?vrhs ...) vrhss] [Block ?body body] [#:pattern ?form] [#:when/np (not (eq? #'?form e2)) ;; FIXME: correct comparison? [#:walk e2 'lsv-remove-syntax]])] - ;; The auto-tagged atomic primitives - [(Wrap p:#%datum (e1 e2 rs ?1 tagged-stx)) + + [(Wrap p:#%datum (e1 e2 rs ?1)) (R e1 - [#:when/np (not (eq? e1 tagged-stx)) - [#:walk tagged-stx 'tag-datum]] - [! ?1])] - [(Wrap p:#%top (e1 e2 rs ?1 tagged-stx)) + [! ?1] + [#:walk e2 'macro])] + [(Wrap p:#%top (e1 e2 rs ?1)) (R e1 - [#:when/np (not (eq? e1 tagged-stx)) - [#:walk tagged-stx 'tag-top]] [#:pattern (?top . ?var)] [#:learn (list #'?var)] [! ?1])] - + + [(Wrap p:provide (e1 e2 rs ?1)) + (R e1 + [! ?1] + [#:walk e2 'provide])] + ;; The rest of the automatic primitives [(Wrap p::STOP (e1 e2 rs ?1)) (R e1 [! ?1])] - + [(Wrap p:set!-macro (e1 e2 rs ?1 deriv)) (R e1 [! ?1] @@ -275,7 +249,7 @@ [#:frontier (list #'?rhs)] [#:learn id-rs] [Expr ?rhs rhs])] - + ;; Synthetic primitives ;; These have their own subterm replacement mechanisms [(Wrap p:synth (e1 e2 rs ?1 subterms ?2)) @@ -299,17 +273,18 @@ (rename-frontier (s:rename-after (car subterms)) (s:rename-before (car subterms)))])) (current-frontier))] - [(SynthItems e1) ?form subterms] + [SynthItems ?form subterms] [! ?2])] ;; FIXME: elimiate => ?? [(Wrap p:rename (e1 e2 rs ?1 rename inner)) (R e1 [! ?1] + [#:pattern ?form] => (lambda (e) (rename-frontier (car rename) (cdr rename)) - (reductions* inner)))] + (reductions* inner (wderiv-e1 inner))))] ;; Macros [(Wrap mrule (e1 e2 transformation next)) @@ -318,9 +293,21 @@ [Transformation ?form transformation] [#:frontier (list (wderiv-e1 next))] [Expr ?form next])] - + + [(Wrap tagrule (e1 e2 tagged-stx next)) + (R e1 + [#:pattern ?form] + [#:walk tagged-stx + (case (syntax-e (stx-car tagged-stx)) + ((#%app) 'tag-app) + ((#%datum) 'tag-datum) + ((#%top) 'tag-top) + (else + (error 'reductions "unknown tagged syntax: ~s" tagged-stx)))] + [Expr ?form next])] + ;; Lifts - + [(Wrap lift-deriv (e1 e2 first lifted-stx second)) (R e1 [#:pattern ?form] @@ -328,7 +315,7 @@ [#:frontier (list lifted-stx)] [#:walk lifted-stx 'capture-lifts] [Expr ?form second])] - + [(Wrap lift/let-deriv (e1 e2 first lifted-stx second)) (R e1 [#:pattern ?form] @@ -336,13 +323,13 @@ [#:frontier (list lifted-stx)] [#:walk lifted-stx 'capture-lifts] [Expr ?form second])] - - ;; Skipped - [#f (RSzero)])) -;; mk-case-lambda-clauses-reductions : stxs -> -;; (list-of (W (list ?exn rename (W BDeriv)))) -> (RS stxs) -(define ((mk-case-lambda-clauses-reductions es1) clauses) + ;; Skipped + [#f (RSunit init-e1)])) + +;; case-lambda-clauses-reductions : +;; (list-of (W (list ?exn rename (W BDeriv)))) stxs -> (RS stxs) +(define (case-lambda-clauses-reductions clauses es1) (blaze-frontier es1) (match clauses ['() @@ -352,16 +339,12 @@ [! ?1] [#:pattern ((?formals . ?body) . ?rest)] [#:frontier (list #'?body #'?rest)] - [#:bind (?formals* . ?body*) rename] - [#:rename (syntax/skeleton es1 ((?formals* . ?body*) . ?rest)) - #'?formals #'?formals* - 'rename-case-lambda] + [#:rename* (?formals . ?body) rename 'rename-case-lambda] [Block ?body body] - [(CaseLambdaClauses (cdr es1)) - ?rest rest])])) + [CaseLambdaClauses ?rest rest])])) -;; mk-synth-items-reductions : syntax -> (list-of SynthItem) -> (RS syntax) -(define ((mk-synth-items-reductions e1) subterms) +;; synth-items-reductions : (list-of SynthItem) syntax -> (RS syntax) +(define (synth-items-reductions subterms e1) (let loop ([term e1] [subterms subterms]) (cond [(null? subterms) (RSunit e1)] @@ -369,9 +352,12 @@ (let* ([subterm0 (car subterms)] [path0 (s:subterm-path subterm0)] [deriv0 (s:subterm-deriv subterm0)]) - (let ([ctx (lambda (x) (path-replace term path0 x))]) + (let ([ctx (lambda (x) (path-replace term path0 x))] + ;; unused: may not be the same, due to mark/unmark??? + [init-e (path-get term path0)]) (RSseq (lambda () - (with-context ctx (reductions* deriv0))) + (with-context ctx + (reductions* deriv0 (wderiv-e1 deriv0)))) (lambda () (loop (path-replace term path0 (wderiv-e2 deriv0)) (cdr subterms))))))] @@ -386,20 +372,17 @@ (s:rename-after subterm0)) (cdr subterms)))]))) -;; transformation-reductions : Transformation -> (RS Stx) -(define (transformation-reductions tx) +;; transformation-reductions : Transformation stx -> (RS Stx) +(define (transformation-reductions tx init-e1) (match tx - [(Wrap transformation (e1 e2 rs ?1 me1 locals ?2 me2 seq)) + [(Wrap transformation (e1 e2 rs ?1 me1 locals me2 ?2 seq)) (R e1 [! ?1] [#:pattern ?form] [#:learn rs] [#:reductions (reductions-locals e1 locals)] [! ?2] - [#:walk e2 - (list #'?form) - (list e2) - 'macro])])) + [#:walk e2 'macro])])) ;; reductions-locals : syntax (list-of LocalAction) -> (RS void) (define (reductions-locals stx locals) @@ -409,23 +392,24 @@ ;; reductions-local : LocalAction -> (RS void) (define (reductions-local local) (match/with-derivation local - [(struct local-expansion (e1 e2 me1 me2 for-stx? deriv)) - (reductions* deriv)] - [(struct local-expansion/expr (e1 e2 me1 me2 for-stx? opaque deriv)) - (fprintf (current-error-port) - "reductions: local-expand-expr not fully implemented") - (reductions* deriv)] + [(struct local-expansion (e1 e2 me1 me2 deriv for-stx? lifted opaque)) + ;; FIXME + ;; When lifted is present, need to locally rearrange lifts! + (when (or lifted opaque) + (fprintf (current-error-port) + "reductions: local-expand-expr not fully implemented")) + (reductions* deriv me1)] [(struct local-lift (expr id)) (RSadd (list (walk expr id 'local-lift)) RSzero)] [(struct local-lift-end (decl)) (RSadd (list (walk/mono decl 'module-lift)) RSzero)] - [(struct local-bind (bindrhs)) + [(struct local-bind (names bindrhs)) (bind-syntaxes-reductions bindrhs)])) -;; list-reductions : ListDerivation -> (RS Stxs) -(define (list-reductions ld) +;; list-reductions : ListDerivation stxs -> (RS Stxs) +(define (list-reductions ld init-es1) (match/with-derivation ld [(Wrap lderiv (es1 es2 ?1 derivs)) (R es1 @@ -434,13 +418,13 @@ [Expr (?form ...) derivs])] [#f (RSunit null)])) -;; block-reductions : BlockDerivation -> (RS Stxs) -(define (block-reductions bd) +;; block-reductions : BlockDerivation stxs -> (RS Stxs) +(define (block-reductions bd init-es1) (match/with-derivation bd [(Wrap bderiv (es1 es2 pass1 trans pass2)) (R es1 [#:pattern ?form] - [(BRules es1) ?form pass1] + [BRules ?form pass1] [#:when/np (eq? trans 'letrec) [#:walk (wlderiv-es1 pass2) 'block->letrec]] [#:frontier (stx->list* (wlderiv-es1 pass2))] @@ -448,8 +432,8 @@ [List ?form pass2])] [#f (RSunit null)])) -;; mk-brules-reductions : stxs -> (list-of BRule) -> (RS Stxs) -(define ((mk-brules-reductions es1) brules) +;; brules-reductions : (list-of BRule) stxs -> (RS Stxs) +(define (brules-reductions brules es1) (match brules ['() (RSunit null)] @@ -459,7 +443,7 @@ [#:bind ?first* (cdr renames)] [#:rename/no-step ?first (car renames) (cdr renames)] [Expr ?first head] - [(BRules (stx-cdr es1)) ?rest rest])] + [BRules ?rest rest])] [(cons (Wrap b:defvals (renames head ?1)) rest) (R es1 [#:pattern (?first . ?rest)] @@ -469,7 +453,7 @@ [! ?1] [#:pattern ((?define-values ?vars ?rhs) . ?rest)] [#:learn (syntax->list #'?vars)] - [(BRules (stx-cdr es1)) ?rest rest])] + [BRules ?rest rest])] [(cons (Wrap b:defstx (renames head ?1 bindrhs)) rest) (R es1 [#:pattern (?first . ?rest)] @@ -480,7 +464,7 @@ [#:pattern ((?define-syntaxes ?vars ?rhs) . ?rest)] [#:learn (syntax->list #'?vars)] [BindSyntaxes ?rhs bindrhs] - [(BRules (stx-cdr es1)) ?rest rest])] + [BRules ?rest rest])] [(cons (Wrap b:splice (renames head ?1 tail ?2)) rest) (R es1 [#:pattern (?first . ?rest)] @@ -488,20 +472,20 @@ [#:rename/no-step ?first (car renames) (cdr renames)] [Expr ?first head] [! ?1] - [#:walk tail - (list #'?first) - (stx-take tail (- (stx-improper-length tail) - (stx-improper-length #'?rest))) - 'splice-block] + [#:walk/foci tail + (list #'?first) + (stx-take tail (- (stx-improper-length tail) + (stx-improper-length #'?rest))) + 'splice-block] [! ?2] [#:pattern ?forms] - [(BRules (stx->list* #'?forms)) ?forms rest])] + [BRules ?forms rest])] [(cons (Wrap b:error (exn)) rest) (R es1 [! exn])])) -;; bind-syntaxes-reductions : BindSyntaxes -> (RS stx) -(define (bind-syntaxes-reductions bindrhs) +;; bind-syntaxes-reductions : BindSyntaxes stx -> (RS stx) +(define (bind-syntaxes-reductions bindrhs init-e1) (match bindrhs [(Wrap bind-syntaxes (rhs ?1)) (R (wderiv-e1 rhs) @@ -509,54 +493,58 @@ [Expr ?form rhs] [! ?1])])) -;; mk-mbrules-reductions : stx -> (list-of MBRule) -> (RS stxs) -(define ((mk-mbrules-reductions es1) mbrules) +;; mbrules-reductions : -> (list-of MBRule) stxs -> (RS stxs) +(define (mbrules-reductions mbrules es1) (match mbrules ['() (RSunit null)] - [(cons (Wrap mod:skip ()) rest) + [(cons (Wrap mod:prim (head rename prim)) rest) (R es1 - [#:pattern (?first . ?rest)] - [(ModulePass (stx-cdr es1)) ?rest rest])] - [(cons (Wrap mod:cons (head)) rest) + [#:pattern (?firstP . ?rest)] + [Expr ?firstP head] + [#:rename* ?firstP rename] + [Expr ?firstP prim] + [ModulePass ?rest rest])] + [(cons (Wrap mod:splice (head rename ?1 tail)) rest) (R es1 - [#:pattern (?first . ?rest)] - [Expr ?first head] - [(ModulePass (stx-cdr es1)) ?rest rest])] - [(cons (Wrap mod:prim (head prim)) rest) - (R es1 - [#:pattern (?first . ?rest)] - [Expr ?first head] - [Expr ?first prim] - [(ModulePass (stx-cdr es1)) ?rest rest])] - [(cons (Wrap mod:splice (head ?1 tail)) rest) - (R es1 - [#:pattern (?first . ?rest)] - [Expr ?first head] + [#:pattern (?firstB . ?rest)] + [Expr ?firstB head] + [#:rename* ?firstB rename] [! ?1] - [#:walk tail - (list #'?first) - (stx-take tail (- (stx-improper-length tail) - (stx-improper-length #'?rest))) - 'splice-module] + [#:walk/foci tail + (list #'?firstB) + (stx-take tail (- (stx-improper-length tail) + (stx-improper-length #'?rest))) + 'splice-module] [#:pattern ?forms] - [(ModulePass #'?forms) ?forms rest])] - [(cons (Wrap mod:lift (head stxs)) rest) + [ModulePass ?forms rest])] + [(cons (Wrap mod:lift (head renames stxs)) rest) (R es1 - [#:pattern (?first . ?rest)] - [Expr ?first head] + [#:pattern (?firstL . ?rest)] + [Expr ?firstL head] [#:pattern ?forms] - [#:walk (append stxs #'?forms) - null - stxs - 'splice-lifts] - [(ModulePass #'?forms) ?forms rest])] + [#:when/np renames + [#:rename* ?forms renames]] + [#:walk/foci (append stxs #'?forms) + null + stxs + 'splice-lifts] + [ModulePass ?forms rest])] [(cons (Wrap mod:lift-end (stxs)) rest) (R es1 [#:pattern ?forms] [#:when/np (pair? stxs) - [#:walk (append stxs #'?forms) - null - stxs - 'splice-module-lifts]] - [(ModulePass #'?forms) ?forms rest])])) + [#:walk/foci (append stxs #'?forms) + null + stxs + 'splice-module-lifts]] + [ModulePass ?forms rest])] + [(cons (Wrap mod:skip ()) rest) + (R es1 + [#:pattern (?firstS . ?rest)] + [ModulePass ?rest rest])] + [(cons (Wrap mod:cons (head)) rest) + (R es1 + [#:pattern (?firstC . ?rest)] + [Expr ?firstC head] + [ModulePass ?rest rest])])) diff --git a/collects/macro-debugger/model/steps.ss b/collects/macro-debugger/model/steps.ss index f8c6f26..fcb832d 100644 --- a/collects/macro-debugger/model/steps.ss +++ b/collects/macro-debugger/model/steps.ss @@ -87,6 +87,7 @@ (tag-datum . "Tag datum") (tag-top . "Tag top-level variable") (capture-lifts . "Capture lifts") + (provide . "Expand provide-specs") (local-lift . "Macro lifted expression to top-level") (module-lift . "Macro lifted declaration to end of module") diff --git a/collects/macro-debugger/model/yacc-interrupted.ss b/collects/macro-debugger/model/yacc-interrupted.ss index 4fb494e..f83832b 100644 --- a/collects/macro-debugger/model/yacc-interrupted.ss +++ b/collects/macro-debugger/model/yacc-interrupted.ss @@ -234,6 +234,11 @@ (define wrap? (let ([wrap? (assq '#:wrap options)] [no-wrap? (assq '#:no-wrap options)]) + (when (and wrap? no-wrap?) + (raise-syntax-error 'split + "cannot specify both #:wrap and #:no-wrap" + stx)) + #; (unless (and (or wrap? no-wrap?) (not (and wrap? no-wrap?))) (raise-syntax-error 'split "must specify exactly one of #:wrap, #:no-wrap" diff --git a/collects/macro-debugger/stepper-text.ss b/collects/macro-debugger/stepper-text.ss index 3d9ab99..36fb532 100644 --- a/collects/macro-debugger/stepper-text.ss +++ b/collects/macro-debugger/stepper-text.ss @@ -6,7 +6,6 @@ "model/reductions.ss" "model/steps.ss" "model/hide.ss" - "model/hiding-policies.ss" "syntax-browser/partition.ss" "syntax-browser/pretty-helper.ss") (provide expand/step-text @@ -125,8 +124,6 @@ (lambda (id) (ormap (lambda (x) (free-identifier=? x id)) show))] - [(hiding-policy? show) - (lambda (x) (policy-show-macro? show x))] [(eq? show #f) #f] [else diff --git a/collects/macro-debugger/syntax-browser/display.ss b/collects/macro-debugger/syntax-browser/display.ss index f7abc68..e8c6ae5 100644 --- a/collects/macro-debugger/syntax-browser/display.ss +++ b/collects/macro-debugger/syntax-browser/display.ss @@ -176,11 +176,6 @@ (let ([end (get-end-position)]) ;; Pretty printer always inserts final newline; we remove it here. (send text delete (sub1 end) end)) - ;; Set font to standard - (send text change-style - (code-style text) - (get-start-position) - (get-end-position)) (let ([offset (get-start-position)]) (fixup-parentheses text range offset) (for-each @@ -191,8 +186,13 @@ (send text set-clickback (+ offset start) (+ offset end) (lambda (_1 _2 _3) (send controller set-selected-syntax stx))))) - (send range all-ranges)) - range))) + (send range all-ranges))) + ;; Set font to standard + (send text change-style + (code-style text) + (get-start-position) + (get-end-position)) + range)) ;; fixup-parentheses : text range -> void (define (fixup-parentheses text range offset) diff --git a/collects/macro-debugger/syntax-browser/keymap.ss b/collects/macro-debugger/syntax-browser/keymap.ss index b9f1af6..dab85ad 100644 --- a/collects/macro-debugger/syntax-browser/keymap.ss +++ b/collects/macro-debugger/syntax-browser/keymap.ss @@ -4,35 +4,73 @@ scheme/gui "interfaces.ss" "partition.ss") -(provide syntax-keymap% - context-menu%) +(provide smart-keymap% + syntax-keymap%) -(define syntax-keymap% +(define smart-keymap% (class keymap% (init editor) - (init-field controller) (inherit add-function map-function chain-to-keymap) + (super-new) (define/public (get-context-menu%) - context-menu%) + smart-context-menu%) - (define/public (make-context-menu) - (new (get-context-menu%) (controller controller) (keymap this))) - - ;; Key mappings + (field (the-context-menu #f)) + (set! the-context-menu (new (get-context-menu%))) (map-function "rightbutton" "popup-context-window") - - ;; Functionality - (add-function "popup-context-window" (lambda (editor event) (do-popup-context-window editor event))) + (chain-to-keymap (send editor get-keymap) #t) + (send editor set-keymap this) + + (define/private (do-popup-context-window editor event) + (define-values (x y) + (send editor dc-location-to-editor-location + (send event get-x) + (send event get-y))) + (define admin (send editor get-admin)) + (send admin popup-menu the-context-menu x y)) + + )) + +(define smart-context-menu% + (class popup-menu% + (define on-demand-actions null) + (define/public (add-on-demand p) + (set! on-demand-actions (cons p on-demand-actions))) + + (define/override (on-demand) + (for-each (lambda (p) (p)) on-demand-actions)) + + (super-new))) + +(define syntax-keymap% + (class smart-keymap% + (init-field controller + config) + + (inherit add-function + map-function + call-function + chain-to-keymap) + (inherit-field the-context-menu) + (field [copy-menu #f] + [clear-menu #f] + [props-menu #f]) + (super-new) + + ;; Functionality + + (define/public (get-controller) controller) + (add-function "copy-text" (lambda (_ event) (define stx (send controller get-selected-syntax)) @@ -48,38 +86,17 @@ (add-function "show-syntax-properties" (lambda (i e) - (error 'show-syntax-properties "not provided by this keymap"))) + (send config set-props-shown? #t))) - ;; Attach to editor - - (chain-to-keymap (send editor get-keymap) #t) - (send editor set-keymap this) - - (define/public (get-controller) controller) - - (define/private (do-popup-context-window editor event) - (define-values (x y) - (send editor dc-location-to-editor-location - (send event get-x) - (send event get-y))) - (define admin (send editor get-admin)) - (send admin popup-menu (make-context-menu) x y)))) - -(define context-menu% - (class popup-menu% - (init-field keymap) - (init-field controller) - (super-new) - - (field [copy-menu #f] - [clear-menu #f] - [props-menu #f]) + (add-function "hide-syntax-properties" + (lambda (i e) + (send config set-props-shown? #f))) (define/public (add-edit-items) (set! copy-menu - (new menu-item% (label "Copy") (parent this) + (new menu-item% (label "Copy") (parent the-context-menu) (callback (lambda (i e) - (send keymap call-function "copy-text" i e))))) + (call-function "copy-text" i e))))) (void)) (define/public (after-edit-items) @@ -89,24 +106,26 @@ (set! clear-menu (new menu-item% (label "Clear selection") - (parent this) + (parent the-context-menu) (callback (lambda (i e) - (send keymap call-function "clear-syntax-selection" i e))))) + (call-function "clear-syntax-selection" i e))))) (set! props-menu (new menu-item% (label "Show syntax properties") - (parent this) + (parent the-context-menu) (callback - (lambda (i e) - (send keymap call-function "show-syntax-properties" i e))))) + (lambda (i e) + (if (send config get-props-shown?) + (call-function "hide-syntax-properties" i e) + (call-function "show-syntax-properties" i e)))))) (void)) (define/public (after-selection-items) (void)) (define/public (add-partition-items) - (let ([secondary (new menu% (label "identifier=?") (parent this))]) + (let ([secondary (new menu% (label "identifier=?") (parent the-context-menu))]) (for-each (lambda (name func) (let ([this-choice @@ -128,15 +147,10 @@ (void)) (define/public (add-separator) - (new separator-menu-item% (parent this))) + (new separator-menu-item% (parent the-context-menu))) - (define/override (on-demand) - (define stx (send controller get-selected-syntax)) - (send copy-menu enable (and stx #t)) - (send clear-menu enable (and stx #t)) - (super on-demand)) + ;; Initialize menu - ;; Initialization (add-edit-items) (after-edit-items) @@ -147,4 +161,15 @@ (add-separator) (add-partition-items) (after-partition-items) - )) + + (send the-context-menu add-on-demand + (lambda () + (define stx (send controller get-selected-syntax)) + (send copy-menu enable (and stx #t)) + (send clear-menu enable (and stx #t)))) + (send config listen-props-shown? + (lambda (shown?) + (send props-menu set-label + (if shown? + "Hide syntax properties" + "Show syntax properties")))))) diff --git a/collects/macro-debugger/syntax-browser/prefs.ss b/collects/macro-debugger/syntax-browser/prefs.ss index 6777899..9575465 100644 --- a/collects/macro-debugger/syntax-browser/prefs.ss +++ b/collects/macro-debugger/syntax-browser/prefs.ss @@ -3,11 +3,15 @@ (require scheme/class framework/framework "interfaces.ss" + "../util/notify.ss" "../util/misc.ss") (provide syntax-prefs% - syntax-prefs-mixin + syntax-prefs/readonly% - pref:tabify) + #;pref:tabify + #;pref:height + #;pref:width + #;pref:props-percentage) (preferences:set-default 'SyntaxBrowser:Width 700 number?) (preferences:set-default 'SyntaxBrowser:Height 600 number?) @@ -18,14 +22,28 @@ (pref:get/set pref:height SyntaxBrowser:Height) (pref:get/set pref:props-percentage SyntaxBrowser:PropertiesPanelPercentage) (pref:get/set pref:props-shown? SyntaxBrowser:PropertiesPanelShown) - (pref:get/set pref:tabify framework:tabify) -(define syntax-prefs-mixin - (closure-mixin (syntax-prefs<%>) - (pref:width pref:width) - (pref:height pref:height) - (pref:props-percentage pref:props-percentage) - (pref:props-shown? pref:props-shown?))) +(define syntax-prefs-base% + (class object% + (notify-methods width) + (notify-methods height) + (notify-methods props-percentage) + (notify-methods props-shown?) + (super-new))) -(define syntax-prefs% (syntax-prefs-mixin object%)) +(define syntax-prefs% + (class syntax-prefs-base% + (connect-to-pref width pref:width) + (connect-to-pref height pref:height) + (connect-to-pref props-percentage pref:props-percentage) + (connect-to-pref props-shown? pref:props-shown?) + (super-new))) + +(define syntax-prefs/readonly% + (class syntax-prefs-base% + (connect-to-pref/readonly width pref:width) + (connect-to-pref/readonly height pref:height) + (connect-to-pref/readonly props-percentage pref:props-percentage) + (connect-to-pref/readonly props-shown? pref:props-shown?) + (super-new))) diff --git a/collects/macro-debugger/syntax-browser/pretty-printer.ss b/collects/macro-debugger/syntax-browser/pretty-printer.ss index 8731b22..fd975d4 100644 --- a/collects/macro-debugger/syntax-browser/pretty-printer.ss +++ b/collects/macro-debugger/syntax-browser/pretty-printer.ss @@ -85,6 +85,8 @@ [else #f])) (define (pp-better-style-table) + (basic-style-list) + #; ;; Messes up formatting too much :( (let* ([pref (pref:tabify)] [table (car pref)] [begin-rx (cadr pref)] diff --git a/collects/macro-debugger/syntax-browser/properties.ss b/collects/macro-debugger/syntax-browser/properties.ss index a93fd62..24dba8c 100644 --- a/collects/macro-debugger/syntax-browser/properties.ss +++ b/collects/macro-debugger/syntax-browser/properties.ss @@ -3,7 +3,8 @@ (require scheme/class scheme/gui "interfaces.ss" - "util.ss") + "util.ss" + "../util/mpi.ss") (provide properties-view% properties-snip%) diff --git a/collects/macro-debugger/syntax-browser/syntax-snip.ss b/collects/macro-debugger/syntax-browser/syntax-snip.ss index dcc59c2..4ab5b17 100644 --- a/collects/macro-debugger/syntax-browser/syntax-snip.ss +++ b/collects/macro-debugger/syntax-browser/syntax-snip.ss @@ -6,26 +6,57 @@ mzlib/match mzlib/list mzlib/string + "../util/notify.ss" "interfaces.ss" "display.ss" "controller.ss" + "keymap.ss" "properties.ss" - "partition.ss") + "partition.ss" + "prefs.ss") - (provide syntax-value-snip%) + (provide syntax-snip% + syntax-value-snip%) + + (define syntax-snip-config-base% + (class object% + (notify-methods props-shown?) + (super-new))) + (define syntax-snip-config% + (class syntax-snip-config-base% + (define/override (init-props-shown?) (new notify-box% (value #f))) + (super-new))) + + (define dumb-host% + (class object% + (define controller (new controller%)) + (define config (new syntax-snip-config%)) + (super-new) + (define/public (get-controller) controller) + (define/public (get-config) config) + (define/public (add-keymap text snip) + (send text set-keymap + (new syntax-keymap% + (controller controller) + (editor text) + (config config)))))) ;; syntax-value-snip% (define syntax-value-snip% (class* editor-snip% (readable-snip<%>) (init-field ((stx syntax))) - (init-field host) + (init-field (host (new dumb-host%))) (inherit set-margin set-inset) (define text (new text:standard-style-list%)) (super-new (editor text) (with-border? #f)) + (set-margin 0 0 0 0) - (set-inset 2 2 2 2) + ;;(set-inset 2 2 2 2) + ;;(set-margin 2 2 2 2) + (set-inset 0 0 0 0) + (send text begin-edit-sequence) (send text change-style (make-object style-delta% 'change-alignment 'top)) (define display @@ -48,12 +79,18 @@ #'(p))) )) - ;; syntax-snip% - #; - (define syntax-snip% - (class* editor-snip% (readable-snip<%>) - (init-field ((stx syntax))) - (init-field primary-partition) + (define top-aligned + (make-object style-delta% 'change-alignment 'top)) + + (define-struct styled (contents style clickback)) + + ;; clicky-snip% + (define clicky-snip% + (class* editor-snip% () + + (init-field [open-style '(border)] + [closed-style '(tight-text-fit)]) + (inherit set-margin set-inset set-snipclass @@ -61,76 +98,54 @@ show-border get-admin) - (define properties-snip (new properties-snip%)) - (define -outer (new text%)) (super-new (editor -outer) (with-border? #f)) - (set-margin 0 0 0 0) - (set-inset 0 0 0 0) - (set-snipclass snip-class) - (send -outer select-all) + (set-margin 2 2 2 2) + (set-inset 2 2 2 2) + ;;(set-margin 3 0 0 0) + ;;(set-inset 1 0 0 0) + ;;(set-margin 0 0 0 0) + ;;(set-inset 0 0 0 0) - (define the-syntax-snip - (new syntax-value-snip% - (syntax stx) - (controller controller) - ;; FIXME - #;(syntax-keymap% syntax-keymap%) - )) - (define the-summary - (let ([line (syntax-line stx)] - [col (syntax-column stx)]) - (if (and line col) - (format "#" line col) - "#"))) + (define/public (closed-contents) null) + (define/public (open-contents) null) - (define shown? #f) - (define/public (refresh) - (if shown? - (refresh/shown) - (refresh/hidden))) + (define open? #f) - (define/private (refresh/hidden) + (define/public (refresh-contents) (send* -outer (begin-edit-sequence) (lock #f) (erase)) - (set-tight-text-fit #t) - (show-border #f) - (outer:insert (show-icon) style:hyper - (lambda _ (set! shown? #t) (refresh))) - (outer:insert the-summary) - (send* -outer + (do-style (if open? open-style closed-style)) + (outer:insert (if open? (hide-icon) (show-icon)) + style:hyper + (if open? + (lambda _ + (set! open? #f) + (refresh-contents)) + (lambda _ + (set! open? #t) + (refresh-contents)))) + (for-each (lambda (s) (outer:insert s)) + (if open? (open-contents) (closed-contents))) + (send* -outer + (change-style top-aligned 0 (send -outer last-position)) (lock #t) (end-edit-sequence))) - (define/private (refresh/shown) - (send* -outer - (begin-edit-sequence) - (lock #f) - (erase)) - (set-tight-text-fit #f) - (show-border #t) - (outer:insert (hide-icon) style:hyper - (lambda _ (set! shown? #f) (refresh))) - (outer:insert " ") - (outer:insert the-syntax-snip) - (outer:insert " ") - (if (props-shown?) - (begin (outer:insert "<" style:green (lambda _ (show #f))) - (outer:insert properties-snip)) - (begin (outer:insert ">" style:green (lambda _ (show #t))))) - (send* -outer - (change-style (make-object style-delta% 'change-alignment 'top) - 0 - (send -outer last-position)) - (lock #t) - (end-edit-sequence))) + (define/private (do-style style) + (show-border (memq 'border style)) + (set-tight-text-fit (memq 'tight-text-fit style))) (define/private outer:insert (case-lambda [(obj) - (outer:insert obj style:normal)] + (if (styled? obj) + (outer:insert (styled-contents obj) + (styled-style obj) + (styled-clickback obj)) + (outer:insert obj style:normal))] [(text style) (outer:insert text style #f)] [(text style clickback) @@ -141,78 +156,78 @@ (when clickback (send -outer set-clickback start end clickback))))])) + (send -outer hide-caret #t) + (send -outer lock #t) + (refresh-contents) + )) + + ;; syntax-snip% + (define syntax-snip% + (class* clicky-snip% (readable-snip<%>) + (init-field ((stx syntax))) + (init-field (host (new dumb-host%))) + (define config (send host get-config)) + (inherit set-snipclass + refresh-contents) + + (define the-syntax-snip + (new syntax-value-snip% + (syntax stx) + (host host))) + (define the-summary + (let* ([t (new text%)] + [es (new editor-snip% (editor t) (with-border? #f))]) + (send es set-margin 0 0 0 0) + (send es set-inset 0 0 0 0) + (send t insert (format "~s" stx)) + es)) + + (define properties-snip + (new properties-container-snip% + (controller (send host get-controller)))) + + (define/override (closed-contents) + (list the-summary)) + + (define/override (open-contents) + (list " " + the-syntax-snip + " " + properties-snip)) + ;; Snip methods (define/override (copy) (new syntax-snip% (syntax stx))) (define/override (write stream) - (send stream put (string->bytes/utf-8 (format "~s" (marshall-syntax stx))))) + (send stream put + (string->bytes/utf-8 + (format "~s" (marshall-syntax stx))))) (define/public (read-special src line col pos) (send the-syntax-snip read-special src line col pos)) - (define/private (find-primary-partition) - #;(define editor (send (get-admin) get-editor)) - (new-bound-partition)) + (send config listen-props-shown? + (lambda (?) (refresh-contents))) + + (super-new) + (set-snipclass snip-class))) - ;; syntax-properties-controller methods - (define properties-shown? #f) - (define/public (props-shown?) - properties-shown?) - (define/public (show ?) - (set! properties-shown? ?) - (refresh)) - (define/public (set-syntax stx) - (send properties-snip set-syntax stx)) + (define properties-container-snip% + (class clicky-snip% + (init controller) - (refresh) - (send -outer hide-caret #t) - (send -outer lock #t) - )) + (define properties-snip + (new properties-snip% (controller controller))) - ;; independent-properties-controller% - #; - (define independent-properties-controller% - (class* object% (syntax-properties-controller<%>) - (init-field controller) - (init-field ((stx syntax) #f)) - - ;; Properties display - (define parent - (new frame% (label "Properties") (height (pref:height)) - (width (floor (* (pref:props-percentage) (pref:width)))))) - (define pv (new properties-view% (parent parent))) - - (define/private (show-properties) - (unless (send parent is-shown?) - (send parent show #t))) - - (define/public (set-syntax stx) - (send pv set-syntax stx)) - (define/public (show ?) - (send parent show ?)) - (define/public (props-shown?) - (send parent is-shown?)) - - (super-new))) - - - #; - (define snip-keymap-extension@ - (unit - (import (prefix pre: keymap^)) - (export keymap^) - - (define syntax-keymap% - (class pre:syntax-keymap% - (init-field snip) - (inherit add-function) - (super-new (controller (send snip get-controller))) - - (add-function "show-syntax-properties" - (lambda (i e) - (send snip show-props))))))) + (define/override (open-contents) + (list #;(show-properties-icon) + properties-snip)) + (define/override (closed-contents) + (list (show-properties-icon))) + (super-new (open-style '()) + (closed-style '())))) (define style:normal (make-object style-delta% 'change-normal)) (define style:hyper @@ -276,7 +291,6 @@ [else (string->symbol (format "unknown-object: ~s" obj))])) ;; COPIED AND MODIFIED from mrlib/syntax-browser.ss - #; (define syntax-snipclass% (class snip-class% (define/override (read stream) @@ -284,12 +298,12 @@ (unmarshall-syntax (read-from-string (send stream get-bytes))))) (super-instantiate ()))) - #;(define snip-class (make-object syntax-snipclass%)) - #;(send snip-class set-version 2) - #;(send snip-class set-classname + (define snip-class (make-object syntax-snipclass%)) + (send snip-class set-version 2) + (send snip-class set-classname (format "~s" '(lib "implementation.ss" "macro-debugger" "syntax-browser"))) - #;(send (get-the-snip-class-list) add snip-class) - + (send (get-the-snip-class-list) add snip-class) + (define (unmarshall-syntax stx) (match stx [`(syntax diff --git a/collects/macro-debugger/syntax-browser/util.ss b/collects/macro-debugger/syntax-browser/util.ss index 7e5e1af..4c587a4 100644 --- a/collects/macro-debugger/syntax-browser/util.ss +++ b/collects/macro-debugger/syntax-browser/util.ss @@ -2,9 +2,7 @@ #lang scheme/base (require scheme/class) (provide with-unlock - make-text-port - mpi->string - mpi->list) + make-text-port) ;; with-unlock SYNTAX (expression) ;; (with-unlock text-expression . body) @@ -31,29 +29,3 @@ (lambda (special buffer? enable-break?) (send text insert special (end-position)) #t))) - -;; mpi->string : module-path-index -> string -(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) "this module"])) - (format "~s" mpi))) - -;; mpi->list : module-path-index -> (list-of module-spec) -(define (mpi->list mpi) - (cond [(module-path-index? mpi) - (let-values ([(path rel) (module-path-index-split mpi)]) - (cond [(and (pair? path) (memq (car path) '(file lib planet))) - (cons path null)] - [path - (cons path (mpi->list rel))] - [else '()]))] - [(not mpi) - '()] - [else (list mpi)])) diff --git a/collects/macro-debugger/syntax-browser/widget.ss b/collects/macro-debugger/syntax-browser/widget.ss index 0ea7d76..a8303f0 100644 --- a/collects/macro-debugger/syntax-browser/widget.ss +++ b/collects/macro-debugger/syntax-browser/widget.ss @@ -16,9 +16,7 @@ "properties.ss" "text.ss" "util.ss") -(provide widget% - widget-keymap% - widget-context-menu%) +(provide widget%) ;; widget% ;; A syntax widget creates its own syntax-controller. @@ -27,7 +25,7 @@ (init parent) (init-field config) - (define controller (new controller%)) + (field [controller (new controller%)]) (define -main-panel (new vertical-panel% (parent parent))) @@ -41,19 +39,15 @@ (new properties-view% (parent -props-panel) (controller controller))) - (define props-percentage (send config pref:props-percentage)) (define/public (setup-keymap) - (new widget-keymap% + (new syntax-keymap% (editor -text) - (widget this))) + (config config))) (send -text set-styles-sticky #f) (send -text lock #t) - (send -split-panel set-percentages - (list (- 1 props-percentage) props-percentage)) - ;; syntax-properties-controller<%> methods (define/public (props-shown?) @@ -65,16 +59,25 @@ (define/public (show-props show?) (if show? (unless (send -props-panel is-shown?) - (send -split-panel add-child -props-panel) - (send -split-panel set-percentages - (list (- 1 props-percentage) props-percentage)) + (let ([p (send config get-props-percentage)]) + (send -split-panel add-child -props-panel) + (update-props-percentage p)) (send -props-panel show #t)) (when (send -props-panel is-shown?) - (set! props-percentage - (cadr (send -split-panel get-percentages))) (send -split-panel delete-child -props-panel) (send -props-panel show #f)))) + (send config listen-props-percentage + (lambda (p) + (update-props-percentage p))) + (send config listen-props-shown? + (lambda (show?) + (show-props show?))) + + (define/private (update-props-percentage p) + (send -split-panel set-percentages + (list (- 1 p) p))) + ;; (define/public (get-controller) controller) @@ -84,8 +87,9 @@ (define/public (get-main-panel) -main-panel) (define/public (shutdown) - (unless (= props-percentage (send config pref:props-percentage)) - (send config pref:props-percentage props-percentage))) + (when (props-shown?) + (send config set-props-percentage + (cadr (send -split-panel get-percentages))))) ;; syntax-browser<%> Methods @@ -99,7 +103,7 @@ (send -text insert text) (let ([b (send -text last-position)]) (send -text change-style error-text-style a b))))) - + (define/public (add-clickback text handler) (with-unlock -text (let ([a (send -text last-position)]) @@ -215,35 +219,6 @@ ;; Specialized classes for widget -(define widget-keymap% - (class syntax-keymap% - (init-field widget) - (super-new (controller (send widget get-controller))) - (inherit add-function) - (inherit-field controller) - - (define/override (get-context-menu%) - widget-context-menu%) - - (add-function "show-syntax-properties" - (lambda (i e) - (send widget toggle-props))) - - (define/public (get-widget) widget))) - -(define widget-context-menu% - (class context-menu% - (inherit-field keymap) - (inherit-field props-menu) - - (define/override (on-demand) - (send props-menu set-label - (if (send (send keymap get-widget) props-shown?) - "Hide syntax properties" - "Show syntax properties")) - (super on-demand)) - (super-new))) - (define browser-text% (class (text:arrows-mixin (text:tacking-mixin diff --git a/collects/macro-debugger/util/mpi.ss b/collects/macro-debugger/util/mpi.ss new file mode 100644 index 0000000..240bc53 --- /dev/null +++ b/collects/macro-debugger/util/mpi.ss @@ -0,0 +1,23 @@ +#lang scheme/base +(provide mpi->list + mpi->string) + +(define (mpi->list mpi) + (cond [(module-path-index? mpi) + (let-values ([(path relto) (module-path-index-split mpi)]) + (cond [(not path) null] + [(not relto) (list path)] + [else (cons path (mpi->list relto))]))] + [(not mpi) null] + [else (list mpi)])) + +;; mpi->string : module-path-index -> string +(define (mpi->string mpi) + (if (module-path-index? mpi) + (let ([mps (mpi->list mpi)]) + (cond [(pair? mps) + (apply string-append + (format "~s" (car mps)) + (map (lambda (x) (format " <= ~s" x)) (cdr mps)))] + [(null? mps) "this module"])) + (format "~s" mpi))) diff --git a/collects/macro-debugger/view/debug-format.ss b/collects/macro-debugger/view/debug-format.ss index 4bedfc5..0cdb024 100644 --- a/collects/macro-debugger/view/debug-format.ss +++ b/collects/macro-debugger/view/debug-format.ss @@ -14,7 +14,7 @@ (write (map serialize-context-frame (continuation-mark-set->context (exn-continuation-marks exn))))) - 'replace)) + #:exists 'replace)) (define (serialize-datum d) (cond [(number? d) `(quote ,d)] diff --git a/collects/macro-debugger/view/extensions.ss b/collects/macro-debugger/view/extensions.ss index 8a43414..4a156a8 100644 --- a/collects/macro-debugger/view/extensions.ss +++ b/collects/macro-debugger/view/extensions.ss @@ -12,6 +12,7 @@ "warning.ss" "hiding-panel.ss" (prefix-in s: "../syntax-browser/widget.ss") + (prefix-in s: "../syntax-browser/keymap.ss") "../model/deriv.ss" "../model/deriv-util.ss" "../model/trace.ss" @@ -20,22 +21,24 @@ "cursor.ss" "../util/notify.ss") (provide stepper-keymap% - stepper-context-menu% stepper-syntax-widget%) ;; Extensions (define stepper-keymap% - (class s:widget-keymap% + (class s:syntax-keymap% (init-field macro-stepper) - (inherit-field controller) - (inherit add-function) + (inherit-field config + controller + the-context-menu) + (inherit add-function + call-function) + + (define show-macro #f) + (define hide-macro #f) (super-new) - (define/override (get-context-menu%) - stepper-context-menu%) - (define/public (get-hiding-panel) (send macro-stepper get-macro-hiding-prefs)) @@ -44,54 +47,50 @@ (send* (get-hiding-panel) (add-show-identifier) (refresh)))) - + (add-function "hiding:hide-macro" (lambda (i e) (send* (get-hiding-panel) (add-hide-identifier) - (refresh)))))) + (refresh)))) + + ;; Menu -(define stepper-context-menu% - (class s:widget-context-menu% - (inherit-field keymap) (inherit add-separator) - - (field [show-macro #f] - [hide-macro #f]) - + (define/override (after-selection-items) (super after-selection-items) (add-separator) (set! show-macro - (new menu-item% (label "Show this macro") (parent this) + (new menu-item% (label "Show selected identifier") (parent the-context-menu) (callback (lambda (i e) - (send keymap call-function "hiding:show-macro" i e))))) + (call-function "hiding:show-macro" i e))))) (set! hide-macro - (new menu-item% (label "Hide this macro") (parent this) + (new menu-item% (label "Hide selected identifier") (parent the-context-menu) (callback (lambda (i e) - (send keymap call-function "hiding:hide-macro" i e))))) + (call-function "hiding:hide-macro" i e))))) + (enable/disable-hide/show #f) (void)) - - (define/override (on-demand) - (define hiding-panel (send keymap get-hiding-panel)) - (define controller (send keymap get-controller)) - (define stx (send controller get-selected-syntax)) - (define id? (identifier? stx)) - (send show-macro enable id?) - (send hide-macro enable id?) - (super on-demand)) - (super-new))) + (define/private (enable/disable-hide/show ?) + (send show-macro enable ?) + (send hide-macro enable ?)) + + (send controller listen-selected-syntax + (lambda (stx) + (enable/disable-hide/show (identifier? stx)))))) (define stepper-syntax-widget% (class s:widget% (init-field macro-stepper) (inherit get-text) + (inherit-field controller) (define/override (setup-keymap) (new stepper-keymap% (editor (get-text)) - (widget this) + (config (send macro-stepper get-config)) + (controller controller) (macro-stepper macro-stepper))) (define/override (show-props show?) @@ -99,13 +98,4 @@ (send macro-stepper update/preserve-view)) (super-new - (config (new config-adapter% - (config (send macro-stepper get-config))))))) - -(define config-adapter% - (class object% - (init-field config) - (define/public pref:props-percentage - (case-lambda [() (send config get-props-percentage)] - [(v) (send config set-props-percentage v)])) - (super-new))) + (config (send macro-stepper get-config))))) diff --git a/collects/macro-debugger/view/frame.ss b/collects/macro-debugger/view/frame.ss index 3e37b88..3d5eb74 100644 --- a/collects/macro-debugger/view/frame.ss +++ b/collects/macro-debugger/view/frame.ss @@ -92,8 +92,10 @@ (new (get-macro-stepper-widget%) (parent (get-area-container)) (config config))) + (define controller (send widget get-controller)) (define/public (get-widget) widget) + (define/public (get-controller) controller) (define/public (add-obsoleted-warning) (unless obsoleted? @@ -116,7 +118,6 @@ "Show syntax properties" (get-field show-syntax-properties? config)) - ;; FIXME: rewrite with notify-box (let ([id-menu (new (get-menu%) (label "Identifier=?") @@ -128,24 +129,24 @@ (parent id-menu) (callback (lambda _ - (send (send widget get-controller) - set-identifier=? p))))]) - (send (send widget get-controller) - listen-identifier=? + (send controller set-identifier=? p))))]) + (send controller listen-identifier=? (lambda (name+func) (send this-choice check (eq? (car name+func) (car p))))))) (sb:identifier=-choices))) + (let ([identifier=? (send config get-identifier=?)]) (when identifier=? (let ([p (assoc identifier=? (sb:identifier=-choices))]) - (send (send widget get-controller) set-identifier=? p)))) + (send controller set-identifier=? p)))) (new (get-menu-item%) (label "Clear selection") (parent stepper-menu) (callback - (lambda _ (send (send widget get-controller) select-syntax #f)))) + (lambda _ (send controller set-selected-syntax #f)))) + (new separator-menu-item% (parent stepper-menu)) (menu-option/notify-box stepper-menu diff --git a/collects/macro-debugger/view/hiding-panel.ss b/collects/macro-debugger/view/hiding-panel.ss index 2b62c2b..002b7c1 100644 --- a/collects/macro-debugger/view/hiding-panel.ss +++ b/collects/macro-debugger/view/hiding-panel.ss @@ -4,54 +4,15 @@ scheme/gui scheme/list syntax/boundmap - "../model/synth-engine.ss" - "../syntax-browser/util.ss" - "../util/notify.ss" - "../util/hiding.ss") + "../model/hiding-policies.ss" + "../util/mpi.ss" + "../util/notify.ss") (provide macro-hiding-prefs-widget%) (define mode:disable "Disable") (define mode:standard "Standard") (define mode:custom "Custom ...") -(define (make-policy hide-mzscheme? - hide-libs? - hide-contracts? - hide-transformers? - specialized-policies) - (lambda (id) - (define now (phase)) - (define binding - (cond [(= now 0) (identifier-binding id)] - [(= now 1) (identifier-transformer-binding id)] - [else #f])) - (define-values (def-mod def-name nom-mod nom-name) - (if (pair? binding) - (values (car binding) - (cadr binding) - (caddr binding) - (cadddr binding)) - (values #f #f #f #f))) - (let/ec return - (let loop ([policies specialized-policies]) - (when (pair? policies) - ((car policies) id binding return) - (loop (cdr policies)))) - (cond [(and hide-mzscheme? def-mod (scheme-module? def-mod)) - #f] - [(and hide-libs? def-mod (lib-module? def-mod)) - #f] - [(and hide-contracts? def-name - (regexp-match #rx"^provide/contract-id-" - (symbol->string def-name))) - #f] - [(and hide-transformers? (positive? now)) - #f] - [else #t])))) - -(define standard-policy - (make-policy #t #t #t #t null)) - ;; macro-hiding-prefs-widget% (define macro-hiding-prefs-widget% (class object% diff --git a/collects/macro-debugger/view/prefs.ss b/collects/macro-debugger/view/prefs.ss index 10a25b2..e21cd97 100644 --- a/collects/macro-debugger/view/prefs.ss +++ b/collects/macro-debugger/view/prefs.ss @@ -10,6 +10,7 @@ (preferences:set-default 'MacroStepper:Frame:Width 700 number?) (preferences:set-default 'MacroStepper:Frame:Height 600 number?) +(preferences:set-default 'MacroStepper:PropertiesShown? #f boolean?) (preferences:set-default 'MacroStepper:PropertiesPanelPercentage 1/3 number?) (preferences:set-default 'MacroStepper:MacroHidingMode "Standard" string?) (preferences:set-default 'MacroStepper:ShowSyntaxProperties? #f boolean?) @@ -26,6 +27,7 @@ (pref:get/set pref:width MacroStepper:Frame:Width) (pref:get/set pref:height MacroStepper:Frame:Height) +(pref:get/set pref:props-shown? MacroStepper:PropertiesShown?) (pref:get/set pref:props-percentage MacroStepper:PropertiesPanelPercentage) (pref:get/set pref:macro-hiding-mode MacroStepper:MacroHidingMode) (pref:get/set pref:show-syntax-properties? MacroStepper:ShowSyntaxProperties?) @@ -44,8 +46,9 @@ (class object% (notify-methods width) (notify-methods height) - (notify-methods macro-hiding-mode) + (notify-methods props-shown?) (notify-methods props-percentage) + (notify-methods macro-hiding-mode) (notify-methods show-syntax-properties?) (notify-methods show-hiding-panel?) (notify-methods identifier=?) @@ -63,8 +66,9 @@ (class macro-stepper-config-base% (connect-to-pref width pref:width) (connect-to-pref height pref:height) - (connect-to-pref macro-hiding-mode pref:macro-hiding-mode) + (connect-to-pref props-shown? pref:props-shown?) (connect-to-pref props-percentage pref:props-percentage) + (connect-to-pref macro-hiding-mode pref:macro-hiding-mode) (connect-to-pref show-syntax-properties? pref:show-syntax-properties?) (connect-to-pref show-hiding-panel? pref:show-hiding-panel?) (connect-to-pref identifier=? pref:identifier=?) diff --git a/collects/macro-debugger/view/term-record.ss b/collects/macro-debugger/view/term-record.ss index 9c54325..2b67632 100644 --- a/collects/macro-debugger/view/term-record.ss +++ b/collects/macro-debugger/view/term-record.ss @@ -173,7 +173,7 @@ synth-warnings)))) (force-letrec-transformation force-letrec?)) - (hide/policy deriv show-macro?)) + (hide*/policy deriv show-macro?)) (values deriv (wderiv-e2 deriv)))) (set! synth-deriv synth-deriv*) (set! synth-estx estx*))))))) @@ -390,7 +390,7 @@ (define/public (add-syntax stx binders definites) (send sbview add-syntax stx '#:alpha-table binders - '#:definites definites)) + '#:definites (or definites null))) (define/private (add-final stx error binders definites) (when stx @@ -483,9 +483,10 @@ (send sbview add-error-text (exn-message (misstep-exn step))) (send sbview add-text "\n") (when (exn:fail:syntax? (misstep-exn step)) - (for-each (lambda (e) (send sbview add-syntax e - '#:alpha-table binders - '#:definites (protostep-definites step))) + (for-each (lambda (e) + (send sbview add-syntax e + '#:alpha-table binders + '#:definites (or (protostep-definites step) null))) (exn:fail:syntax-exprs (misstep-exn step)))) (show-lctx step binders)) @@ -493,7 +494,7 @@ ;; insert-syntax/color : syntax syntaxes identifiers syntaxes string -> void (define/private (insert-syntax/color stx foci binders definites frontier hi-color) (send sbview add-syntax stx - '#:definites definites + '#:definites (or definites null) '#:alpha-table binders '#:hi-color hi-color '#:hi-stxs (if (send config get-highlight-foci?) foci null)