suzanne.soy/macro-debugger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

sync Ryan's macro-debugger changes

Browse Source 
svn: r9166

original commit: 5165d9e8559eda1245acee8296c81613c3770c7a
This commit is contained in:
Matthew Flatt 2008-04-04 17:38:23 +00:00
parent d81ac1a5e9
commit b5e5c83b91
27 changed files with 888 additions and 898 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/macro-debugger/expand.ss
View File

@ -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)))

6
collects/macro-debugger/model/debug.ss
View File

@ -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))

42
collects/macro-debugger/model/deriv-c.ss
View File

@ -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 <Node(Stx)> Deriv Stx Deriv)
@ -24,7 +25,7 @@
;; A Transformation is
;; (make-transformation <Node(Stx)> 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 <Node(Stx)> 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 <Base> Boolean ?Deriv ?exn Deriv)
;; (make-p:#%module-begin <Base> 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 <Base> ?exn ?stx stx ?Deriv ?stx ?exn Deriv ?stx)
;; (make-p:#%module-begin <Base> 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 <Base> DerivLL)
;; (make-p:define-values <Base> Deriv)
@ -61,7 +63,7 @@
;; (make-p:set! <Base> Rs Deriv)
;; (make-p:set!-macro <Base> 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 <Base> Stx LDeriv)
;; (make-p:begin <Base> LDeriv)
;; (make-p:begin0 <Base> 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 <Base> #:transparent)

273
collects/macro-debugger/model/deriv-parser.ss
View File

@ -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)])

18
collects/macro-debugger/model/deriv-tokens.ss
View File

@ -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)

2
collects/macro-debugger/model/deriv.ss
View File

@ -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?]

173
collects/macro-debugger/model/hiding-policies.ss
View File

@ -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)))))

144
collects/macro-debugger/model/reductions-engine.ss
View File

@ -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)

380
collects/macro-debugger/model/reductions.ss
View File

@ -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])]))

1
collects/macro-debugger/model/steps.ss
View File

@ -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")

5
collects/macro-debugger/model/yacc-interrupted.ss
View File

@ -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"

3
collects/macro-debugger/stepper-text.ss
View File

@ -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

14
collects/macro-debugger/syntax-browser/display.ss
View File

@ -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)

131
collects/macro-debugger/syntax-browser/keymap.ss
View File

@ -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"))))))

38
collects/macro-debugger/syntax-browser/prefs.ss
View File

@ -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)))

2
collects/macro-debugger/syntax-browser/pretty-printer.ss
View File

@ -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)]

3
collects/macro-debugger/syntax-browser/properties.ss
View File

@ -3,7 +3,8 @@
(require scheme/class
scheme/gui
"interfaces.ss"
"util.ss")
"util.ss"
"../util/mpi.ss")
(provide properties-view%
properties-snip%)

272
collects/macro-debugger/syntax-browser/syntax-snip.ss
View File

@ -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 "#<syntax:~s:~s>" line col)
"#<syntax>")))
(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

30
collects/macro-debugger/syntax-browser/util.ss
View File

@ -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)]))

69
collects/macro-debugger/syntax-browser/widget.ss
View File

@ -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

23
collects/macro-debugger/util/mpi.ss Normal file
View File

@ -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)))

2
collects/macro-debugger/view/debug-format.ss
View File

@ -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)]

72
collects/macro-debugger/view/extensions.ss
View File

@ -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)))))

15
collects/macro-debugger/view/frame.ss
View File

@ -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

45
collects/macro-debugger/view/hiding-panel.ss
View File

@ -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%

8
collects/macro-debugger/view/prefs.ss
View File

@ -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=?)

13
collects/macro-debugger/view/term-record.ss
View File

@ -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)