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)]) (let-values ([(result deriv) (trace/result stx)])
(when (exn? result) (when (exn? result)
(raise result)) (raise result))
(let-values ([(_d estx) (hide/policy deriv show?)]) (let-values ([(_d estx) (hide*/policy deriv show?)])
estx))) estx)))

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

@ -7,9 +7,11 @@
"deriv-util.ss" "deriv-util.ss"
"deriv-find.ss" "deriv-find.ss"
"hide.ss" "hide.ss"
"seek.ss"
"hiding-policies.ss" "hiding-policies.ss"
"deriv.ss" "deriv.ss"
"steps.ss") "steps.ss"
"synth-derivs.ss")
(provide (all-from-out "trace.ss") (provide (all-from-out "trace.ss")
(all-from-out "reductions.ss") (all-from-out "reductions.ss")
@ -18,5 +20,7 @@
(all-from-out "deriv-find.ss") (all-from-out "deriv-find.ss")
(all-from-out "hiding-policies.ss") (all-from-out "hiding-policies.ss")
(all-from-out "hide.ss") (all-from-out "hide.ss")
(all-from-out "seek.ss")
(all-from-out "steps.ss") (all-from-out "steps.ss")
(all-from-out "synth-derivs.ss")
(all-from-out scheme/match)) (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 (deriv node) () #:transparent)
(define-struct (lift-deriv deriv) (first lift-stx second) #:transparent) (define-struct (lift-deriv deriv) (first lift-stx second) #:transparent)
(define-struct (mrule deriv) (transformation next) #:transparent) (define-struct (mrule deriv) (transformation next) #:transparent)
(define-struct (tagrule deriv) (tagged-stx next) #:transparent)
;; A DerivLL is one of ;; A DerivLL is one of
;; (make-lift/let-deriv <Node(Stx)> Deriv Stx Deriv) ;; (make-lift/let-deriv <Node(Stx)> Deriv Stx Deriv)
@ -24,7 +25,7 @@
;; A Transformation is ;; A Transformation is
;; (make-transformation <Node(Stx)> Rs ?exn ?Stx (list-of LocalAction) ?exn ?Stx Number) ;; (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 ;; A LocalAction is one of
;; (make-local-expansion <Node(Stx)> Stx ?Stx Boolean Deriv) ;; (make-local-expansion <Node(Stx)> Stx ?Stx Boolean Deriv)
@ -32,11 +33,11 @@
;; (make-local-lift Stx Identifier) ;; (make-local-lift Stx Identifier)
;; (make-local-lift-end Stx) ;; (make-local-lift-end Stx)
;; (make-local-bind BindSyntaxes) ;; (make-local-bind BindSyntaxes)
(define-struct (local-expansion node) (me1 me2 for-stx? inner) #:transparent) (define-struct (local-expansion node) (me1 me2 inner for-stx? lifted opaque)
(define-struct (local-expansion/expr node) (me1 me2 for-stx? opaque inner) #:transparent) #:transparent)
(define-struct local-lift (expr id) #:transparent) (define-struct local-lift (expr id) #:transparent)
(define-struct local-lift-end (decl) #: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 >> ;; Base = << Node(Stx) Rs ?exn >>
(define-struct (base deriv) (resolves ?1) #:transparent) (define-struct (base deriv) (resolves ?1) #:transparent)
@ -45,10 +46,11 @@
(define-struct (prule base) () #:transparent) (define-struct (prule base) () #:transparent)
(define-struct (p:variable prule) () #:transparent) (define-struct (p:variable prule) () #:transparent)
;; (make-p:module <Base> Boolean ?Deriv ?exn Deriv) ;; (make-p:module <Base> ?exn ?stx stx ?Deriv ?stx ?exn Deriv ?stx)
;; (make-p:#%module-begin <Base> ModulePass1 ModulePass2 ?exn) ;; (make-p:#%module-begin <Base> Stx ModulePass1 ModulePass2 ?exn)
(define-struct (p:module prule) (one-body-form? mb ?2 body) #:transparent) (define-struct (p:module prule) (?2 tag rename check tag2 ?3 body shift)
(define-struct (p:#%module-begin prule) (pass1 pass2 ?2) #:transparent) #:transparent)
(define-struct (p:#%module-begin prule) (me pass1 pass2 ?2) #:transparent)
;; (make-p:define-syntaxes <Base> DerivLL) ;; (make-p:define-syntaxes <Base> DerivLL)
;; (make-p:define-values <Base> Deriv) ;; (make-p:define-values <Base> Deriv)
@ -61,7 +63,7 @@
;; (make-p:set! <Base> Rs Deriv) ;; (make-p:set! <Base> Rs Deriv)
;; (make-p:set!-macro <Base> Rs Deriv) ;; (make-p:set!-macro <Base> Rs Deriv)
(define-struct (p:#%expression prule) (inner) #:transparent) (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:wcm prule) (key mark body) #:transparent)
(define-struct (p:set! prule) (id-resolves rhs) #:transparent) (define-struct (p:set! prule) (id-resolves rhs) #:transparent)
(define-struct (p:set!-macro prule) (deriv) #:transparent) (define-struct (p:set!-macro prule) (deriv) #:transparent)
@ -69,7 +71,7 @@
;; (make-p:#%app <Base> Stx LDeriv) ;; (make-p:#%app <Base> Stx LDeriv)
;; (make-p:begin <Base> LDeriv) ;; (make-p:begin <Base> LDeriv)
;; (make-p:begin0 <Base> Deriv 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:begin prule) (lderiv) #:transparent)
(define-struct (p:begin0 prule) (first lderiv) #:transparent) (define-struct (p:begin0 prule) (first lderiv) #:transparent)
@ -97,8 +99,8 @@
(define-struct (p::STOP prule) () #:transparent) (define-struct (p::STOP prule) () #:transparent)
(define-struct (p:stop p::STOP) () #:transparent) (define-struct (p:stop p::STOP) () #:transparent)
(define-struct (p:unknown p::STOP) () #:transparent) (define-struct (p:unknown p::STOP) () #:transparent)
(define-struct (p:#%top p::STOP) (tagged-stx) #:transparent) (define-struct (p:#%top p::STOP) () #:transparent)
(define-struct (p:#%datum p::STOP) (tagged-stx) #:transparent) (define-struct (p:#%datum p::STOP) () #:transparent)
(define-struct (p:quote p::STOP) () #:transparent) (define-struct (p:quote p::STOP) () #:transparent)
(define-struct (p:quote-syntax p::STOP) () #:transparent) (define-struct (p:quote-syntax p::STOP) () #:transparent)
(define-struct (p:require p::STOP) () #:transparent) (define-struct (p:require p::STOP) () #:transparent)
@ -151,21 +153,21 @@
;; A ModPass2 is (list-of ModRule2) ;; A ModPass2 is (list-of ModRule2)
;; A ModRule1 is one of ;; A ModRule1 is one of
;; (make-mod:prim Deriv ModPrim) ;; (make-mod:prim Deriv Stx ModPrim)
;; (make-mod:splice Deriv ?exn Stxs) ;; (make-mod:splice Deriv Stx ?exn Stxs)
;; (make-mod:lift Deriv Stxs) ;; (make-mod:lift Deriv ?Stxs Stxs)
;; (make-mod:lift-end Stxs) ;; (make-mod:lift-end Stxs)
;; A ModRule2 is one of ;; A ModRule2 is one of
;; (make-mod:skip) ;; (make-mod:skip)
;; (make-mod:cons Deriv) ;; (make-mod:cons Deriv)
;; (make-mod:lift Deriv Stxs) ;; (make-mod:lift Deriv Stxs)
(define-struct modrule () #:transparent) (define-struct modrule () #:transparent)
(define-struct (mod:cons modrule) (head) #:transparent) (define-struct (mod:prim modrule) (head rename prim) #:transparent)
(define-struct (mod:prim modrule) (head prim) #:transparent) (define-struct (mod:splice modrule) (head rename ?1 tail) #:transparent)
(define-struct (mod:skip modrule) () #:transparent) (define-struct (mod:lift modrule) (head renames tail) #:transparent)
(define-struct (mod:splice modrule) (head ?1 tail) #:transparent)
(define-struct (mod:lift modrule) (head tail) #:transparent)
(define-struct (mod:lift-end modrule) (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: ;; A ModPrim is a PRule in:
;; (make-p:define-values <Base> #:transparent) ;; (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) (tokens basic-tokens prim-tokens renames-tokens)
(end EOF) (end EOF)
(error deriv-error) (error deriv-error)
#;(debug "DEBUG-PARSER.txt")) #;(debug "/Users/ryanc/DEBUG-PARSER.txt")
)
;; tokens ;; tokens
(skipped-token-values (skipped-token-values
@ -60,12 +61,15 @@
enter-list exit-list enter-list exit-list
enter-check exit-check enter-check exit-check
local-post exit-local exit-local/expr local-post exit-local exit-local/expr
local-bind enter-bind exit-bind
phase-up module-body phase-up module-body
renames-lambda renames-lambda
renames-case-lambda renames-case-lambda
renames-let renames-let
renames-letrec-syntaxes renames-letrec-syntaxes
renames-block renames-block
rename-one
rename-list
IMPOSSIBLE) IMPOSSIBLE)
;; Entry point ;; Entry point
@ -76,42 +80,17 @@
(productions/I (productions/I
;; Expand/Lifts ;; Expand with possible lifting
(EE/Lifts (EE/Lifts
(#:no-wrap)
[((? EE)) $1] [((? EE)) $1]
[((? EE/Lifts+)) $1])
(EE/Lifts+
(#:no-wrap)
[(EE lift-loop (? EE/Lifts)) [(EE lift-loop (? EE/Lifts))
(let ([e1 (wderiv-e1 $1)] (let ([e1 (wderiv-e1 $1)]
[e2 (wderiv-e2 $3)]) [e2 (wderiv-e2 $3)])
(make lift-deriv e1 e2 $1 $2 $3))]) (make lift-deriv e1 e2 $1 $2 $3))])
;; Expansion of an expression ;; Expand, convert lifts to let (rhs of define-syntaxes, mostly)
;; 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)
(EE/LetLifts (EE/LetLifts
(#:no-wrap)
[((? EE)) $1] [((? EE)) $1]
[((? EE/LetLifts+)) $1])
(EE/LetLifts+
(#:wrap)
[(EE lift/let-loop (? EE/LetLifts)) [(EE lift/let-loop (? EE/LetLifts))
(let ([initial (wderiv-e1 $1)] (let ([initial (wderiv-e1 $1)]
[final (wderiv-e2 $3)]) [final (wderiv-e2 $3)])
@ -120,126 +99,128 @@
;; Evaluation ;; Evaluation
;; Answer = ?exn ;; Answer = ?exn
(Eval (Eval
(#:no-wrap)
[() #f] [() #f]
[(!!) $1] [(!!) $1]
[(start EE/Interrupted) (create-eval-exn $2)] [(start EE/Interrupted) (create-eval-exn $2)]
[(start EE (? Eval)) $3] [(start EE (? Eval)) $3]
[(start CheckImmediateMacro/Interrupted) (create-eval-exn $2)] [(start CheckImmediateMacro/Interrupted) (create-eval-exn $2)]
[(start CheckImmediateMacro (? Eval)) $3]) [(start CheckImmediateMacro (? Eval)) $3])
;; Expansion of an expression to primitive form ;; Expansion of an expression to primitive form
(CheckImmediateMacro (CheckImmediateMacro
(#:no-wrap)
[(enter-check (? CheckImmediateMacro/Inner) exit-check) [(enter-check (? CheckImmediateMacro/Inner) exit-check)
($2 $1 $3 (lambda (ce1 ce2) (make p:stop ce1 ce2 null #f)))]) ($2 $1 $3 (lambda (ce1 ce2) (make p:stop ce1 ce2 null #f)))])
(CheckImmediateMacro/Inner (CheckImmediateMacro/Inner
(#:args e1 e2 k) (#:args e1 e2 k)
(#:wrap)
[() [()
(k e1 e2)] (k e1 e2)]
[(visit (? MacroStep) return (? CheckImmediateMacro/Inner)) [(visit Resolves (? MacroStep) return (? CheckImmediateMacro/Inner))
(let ([next ($4 $3 e2 k)]) (let ([next ($5 $4 e2 k)])
(make mrule $1 (and next (wderiv-e2 next)) $2 next))]) (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 ;; Expansion of multiple expressions, next-separated
(NextEEs (NextEEs
(#:no-wrap)
(#:skipped null) (#:skipped null)
[() null] [() null]
[(next (? EE) (? NextEEs)) (cons $2 $3)]) [(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 ;; Keyword resolution
(Resolves (Resolves
(#:no-wrap)
[() null] [() null]
[(resolve Resolves) (cons $1 $2)]) [(resolve Resolves) (cons $1 $2)])
;; Single macro step (may contain local-expand calls) ;; Single macro step (may contain local-expand calls)
;; MacroStep Answer = Transformation (I,E) ;; MacroStep Answer = Transformation (I,E)
(MacroStep (MacroStep
(#:wrap) (#:args rs)
[(Resolves enter-macro ! macro-pre-transform (? LocalActions) [(enter-macro ! macro-pre-transform (? LocalActions)
! macro-post-transform exit-macro) ! macro-post-transform ! exit-macro)
(make transformation $2 $8 $1 $3 $4 $5 $6 $7 (new-sequence-number))]) (make transformation $1 $8 rs $2 $3 $4 $6 (or $5 $7) (new-sequence-number))])
;; Local actions taken by macro ;; Local actions taken by macro
;; LocalAction Answer = (list-of LocalAction) ;; LocalAction Answer = (list-of LocalAction)
(LocalActions (LocalActions
(#:no-wrap)
(#:skipped null) (#:skipped null)
[() null] [() null]
[((? LocalAction) (? LocalActions)) (cons $1 $2)] [((? LocalAction) (? LocalActions)) (cons $1 $2)]
[((? NotReallyLocalAction) (? LocalActions)) $2]) [((? NotReallyLocalAction) (? LocalActions)) $2])
(LocalAction (LocalAction
(#:no-wrap) [(enter-local OptPhaseUp
[(enter-local local-pre start (? EE) local-post exit-local) local-pre (? LocalExpand/Inner) local-post
(make local-expansion $1 $6 $2 $5 #f $4)] OptLifted OptOpaqueExpr exit-local)
[(enter-local phase-up local-pre start (? EE) local-post exit-local) (make local-expansion $1 $8 $3 $5 $4 $2 $6 $7)]
(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)]
[(lift) [(lift)
(make local-lift (cdr $1) (car $1))] (make local-lift (cdr $1) (car $1))]
[(lift-statement) [(lift-statement)
(make local-lift-end $1)] (make local-lift-end $1)]
[((? BindSyntaxes)) [(local-bind (? BindSyntaxes))
(make local-bind $1)]) (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 (NotReallyLocalAction
(#:no-wrap)
;; called 'expand' (not 'local-expand') within transformer ;; called 'expand' (not 'local-expand') within transformer
[(start (? EE)) [(start (? EE))
(make local-expansion (wderiv-e1 $2) #f])
(wderiv-e2 $2)
(wderiv-e1 $2)
(wderiv-e2 $2)
#f
$2)])
;; Primitive ;; Primitive
(PrimStep (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) (#:args e1 e2 rs)
(#:wrap) [(!!)
[(! IMPOSSIBLE) (make p:unknown e1 e2 rs $1)]
(make p:unknown e1 e2 rs $1)])
(Variable
(#:args e1 e2 rs)
(#:wrap)
[(variable) [(variable)
(make p:variable e1 e2 rs #f)]) (make p:variable e1 e2 rs #f)]
[(enter-prim (? Prim) exit-prim)
(TaggedPrim (begin
(#:args e1 e2 rs tagged-stx) (unless (eq? $3 e2)
(#:no-wrap) (fprintf (current-error-port)
[((? Prim#%App)) ($1 e1 e2 rs tagged-stx)] "warning: exit-prim and return differ:\n~s\n~s\n"
[((? Prim#%Datum)) ($1 e1 e2 rs tagged-stx)] $3 e2))
[((? Prim#%Top)) ($1 e1 e2 rs tagged-stx)]) ($2 $1 $3 rs))])
(Prim (Prim
(#:args e1 e2 rs) (#:args e1 e2 rs)
(#:no-wrap)
[((? PrimModule)) ($1 e1 e2 rs)] [((? PrimModule)) ($1 e1 e2 rs)]
[((? Prim#%ModuleBegin)) ($1 e1 e2 rs)] [((? Prim#%ModuleBegin)) ($1 e1 e2 rs)]
[((? PrimDefineSyntaxes)) ($1 e1 e2 rs)] [((? PrimDefineSyntaxes)) ($1 e1 e2 rs)]
[((? PrimDefineValues)) ($1 e1 e2 rs)] [((? PrimDefineValues)) ($1 e1 e2 rs)]
[((? PrimExpression)) ($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)] [((? PrimIf)) ($1 e1 e2 rs)]
[((? PrimWCM)) ($1 e1 e2 rs)] [((? PrimWCM)) ($1 e1 e2 rs)]
[((? PrimSet)) ($1 e1 e2 rs)] [((? PrimSet)) ($1 e1 e2 rs)]
@ -261,22 +242,24 @@
(PrimModule (PrimModule
(#:args e1 e2 rs) (#:args e1 e2 rs)
(#:wrap) [(prim-module ! next (? Eval) OptTag rename-one
;; Multiple forms after language: tagging done automatically (? OptCheckImmediateMacro) OptTag !
[(prim-module (? Eval) (? EE)) (? EE) rename-one)
(make p:module e1 e2 rs $2 #f #f #f $3)] (make p:module e1 e2 rs $2 $4 $5 $6 $7 $8 $9 $10 $11)])
;; One form after language: macro that expands into #%module-begin (OptTag
[(prim-module Eval next (? CheckImmediateMacro) next ! (? EE)) [() #f]
(make p:module e1 e2 rs #f #t $4 $6 $7)]) [(tag) $1])
(OptCheckImmediateMacro
[() #f]
[((? CheckImmediateMacro)) $1])
(Prim#%ModuleBegin (Prim#%ModuleBegin
(#:args e1 e2 rs) (#:args e1 e2 rs)
(#:wrap) [(prim-#%module-begin ! rename-one
[(prim-#%module-begin ! (? ModulePass1) next-group (? ModulePass2) !) (? ModulePass1) next-group (? ModulePass2) !)
(make p:#%module-begin e1 e2 rs $2 $3 $5 $6)]) (make p:#%module-begin e1 e2 rs $2 $3 $4 $6 $7)])
(ModulePass1 (ModulePass1
(#:no-wrap)
(#:skipped null) (#:skipped null)
[() null] [() null]
[(next (? ModulePass1-Part) (? ModulePass1)) [(next (? ModulePass1-Part) (? ModulePass1))
@ -285,16 +268,14 @@
(cons (make mod:lift-end $1) $2)]) (cons (make mod:lift-end $1) $2)])
(ModulePass1-Part (ModulePass1-Part
(#:wrap) [((? EE) rename-one (? ModulePass1/Prim))
[((? EE) (? ModulePass1/Prim)) (make mod:prim $1 $2 $3)]
(make mod:prim $1 $2)] [(EE rename-one ! splice)
[(EE ! splice) (make mod:splice $1 $2 $3 $4)]
(make mod:splice $1 $2 $3)] [(EE rename-list module-lift-loop)
[(EE module-lift-loop) (make mod:lift $1 $2 $3)])
(make mod:lift $1 $2)])
(ModulePass1/Prim (ModulePass1/Prim
(#:wrap)
[(enter-prim prim-define-values ! exit-prim) [(enter-prim prim-define-values ! exit-prim)
(make p:define-values $1 $4 null $3 #f)] (make p:define-values $1 $4 null $3 #f)]
[(enter-prim prim-define-syntaxes ! [(enter-prim prim-define-syntaxes !
@ -306,13 +287,10 @@
(make p:require-for-syntax $1 $4 null $3)] (make p:require-for-syntax $1 $4 null $3)]
[(enter-prim prim-require-for-template (? Eval) exit-prim) [(enter-prim prim-require-for-template (? Eval) exit-prim)
(make p:require-for-template $1 $4 null $3)] (make p:require-for-template $1 $4 null $3)]
[(enter-prim prim-provide ! exit-prim)
(make p:provide $1 $4 null $3)]
[() [()
#f]) #f])
(ModulePass2 (ModulePass2
(#:no-wrap)
(#:skipped null) (#:skipped null)
[() null] [() null]
[(next (? ModulePass2-Part) (? ModulePass2)) [(next (? ModulePass2-Part) (? ModulePass2))
@ -321,106 +299,98 @@
(cons (make mod:lift-end $1) $2)]) (cons (make mod:lift-end $1) $2)])
(ModulePass2-Part (ModulePass2-Part
(#:no-wrap)
;; not normal; already handled ;; not normal; already handled
[() [()
(make mod:skip)] (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 ;; normal: expand completely
[((? EE)) [((? EE))
(make mod:cons $1)] (make mod:cons $1)]
;; catch lifts ;; catch lifts
[(EE module-lift-loop) [(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 ;; Definitions
(PrimDefineSyntaxes (PrimDefineSyntaxes
(#:args e1 e2 rs) (#:args e1 e2 rs)
(#:wrap)
[(prim-define-syntaxes ! (? EE/LetLifts) (? Eval)) [(prim-define-syntaxes ! (? EE/LetLifts) (? Eval))
(make p:define-syntaxes e1 e2 rs $2 $3 $4)]) (make p:define-syntaxes e1 e2 rs $2 $3 $4)])
(PrimDefineValues (PrimDefineValues
(#:args e1 e2 rs) (#:args e1 e2 rs)
(#:wrap)
[(prim-define-values ! (? EE)) [(prim-define-values ! (? EE))
(make p:define-values e1 e2 rs $2 $3)]) (make p:define-values e1 e2 rs $2 $3)])
;; Simple expressions ;; Simple expressions
(PrimExpression (PrimExpression
(#:args e1 e2 rs) (#:args e1 e2 rs)
(#:wrap)
[(prim-expression ! (? EE)) [(prim-expression ! (? EE))
(make p:#%expression e1 e2 rs $2 $3)]) (make p:#%expression e1 e2 rs $2 $3)])
(PrimIf (PrimIf
(#:args e1 e2 rs) (#:args e1 e2 rs)
(#:wrap)
[(prim-if ! (? EE) next (? EE) next (? EE)) [(prim-if ! (? EE) next (? EE) next (? EE))
(make p:if e1 e2 rs $2 #t $3 $5 $7)] (make p:if e1 e2 rs $2 $3 $5 $7)])
[(prim-if next-group (? EE) next (? EE))
(make p:if e1 e2 rs #f #f $3 $5 #f)])
(PrimWCM (PrimWCM
(#:args e1 e2 rs) (#:args e1 e2 rs)
(#:wrap)
[(prim-wcm ! (? EE) next (? EE) next (? EE)) [(prim-wcm ! (? EE) next (? EE) next (? EE))
(make p:wcm e1 e2 rs $2 $3 $5 $7)]) (make p:wcm e1 e2 rs $2 $3 $5 $7)])
;; Sequence-containing expressions ;; Sequence-containing expressions
(PrimBegin (PrimBegin
(#:args e1 e2 rs) (#:args e1 e2 rs)
(#:wrap)
[(prim-begin ! (? EL)) [(prim-begin ! (? EL))
(make p:begin e1 e2 rs $2 $3)]) (make p:begin e1 e2 rs $2 $3)])
(PrimBegin0 (PrimBegin0
(#:args e1 e2 rs) (#:args e1 e2 rs)
(#:wrap)
[(prim-begin0 ! next (? EE) next (? EL)) [(prim-begin0 ! next (? EE) next (? EL))
(make p:begin0 e1 e2 rs $2 $4 $6)]) (make p:begin0 e1 e2 rs $2 $4 $6)])
(Prim#%App (Prim#%App
(#:args e1 e2 rs tagged-stx) (#:args e1 e2 rs)
(#:wrap)
[(prim-#%app !) [(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)) [(prim-#%app (? EL))
(make p:#%app e1 e2 rs #f tagged-stx $2)]) (make p:#%app e1 e2 rs #f $2)])
;; Binding expressions ;; Binding expressions
(PrimLambda (PrimLambda
(#:args e1 e2 rs) (#:args e1 e2 rs)
(#:wrap)
[(prim-lambda ! renames-lambda (? EB)) [(prim-lambda ! renames-lambda (? EB))
(make p:lambda e1 e2 rs $2 $3 $4)]) (make p:lambda e1 e2 rs $2 $3 $4)])
(PrimCaseLambda (PrimCaseLambda
(#:args e1 e2 rs) (#:args e1 e2 rs)
(#:wrap)
[(prim-case-lambda ! (? NextCaseLambdaClauses)) [(prim-case-lambda ! (? NextCaseLambdaClauses))
(make p:case-lambda e1 e2 rs $2 $3)]) (make p:case-lambda e1 e2 rs $2 $3)])
(NextCaseLambdaClauses (NextCaseLambdaClauses
(#:skipped null) (#:skipped null)
(#:no-wrap)
[(next (? CaseLambdaClause) (? NextCaseLambdaClauses)) [(next (? CaseLambdaClause) (? NextCaseLambdaClauses))
(cons $2 $3)] (cons $2 $3)]
[() null]) [() null])
(CaseLambdaClause (CaseLambdaClause
(#:wrap)
[(! renames-case-lambda (? EB)) [(! renames-case-lambda (? EB))
(make clc $1 $2 $3)]) (make clc $1 $2 $3)])
(PrimLetValues (PrimLetValues
(#:args e1 e2 rs) (#:args e1 e2 rs)
(#:wrap)
[(prim-let-values ! renames-let (? NextEEs) next-group (? EB)) [(prim-let-values ! renames-let (? NextEEs) next-group (? EB))
(make p:let-values e1 e2 rs $2 $3 $4 $6)]) (make p:let-values e1 e2 rs $2 $3 $4 $6)])
(PrimLet*Values (PrimLet*Values
(#:args e1 e2 rs) (#:args e1 e2 rs)
(#:wrap)
;; let*-values with bindings is "macro-like" ;; let*-values with bindings is "macro-like"
[(prim-let*-values !!) [(prim-let*-values !!)
(let ([tx (make transformation e1 #f rs $2 (let ([tx (make transformation e1 #f rs $2
@ -429,7 +399,7 @@
[(prim-let*-values (? EE)) [(prim-let*-values (? EE))
(let* ([next-e1 (wderiv-e1 $2)] (let* ([next-e1 (wderiv-e1 $2)]
[tx (make transformation e1 next-e1 rs #f [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))] (make mrule e1 e2 tx $2))]
;; No bindings... model as "let" ;; No bindings... model as "let"
[(prim-let*-values renames-let (? NextEEs) next-group (? EB)) [(prim-let*-values renames-let (? NextEEs) next-group (? EB))
@ -437,13 +407,11 @@
(PrimLetrecValues (PrimLetrecValues
(#:args e1 e2 rs) (#:args e1 e2 rs)
(#:wrap)
[(prim-letrec-values ! renames-let (? NextEEs) next-group (? EB)) [(prim-letrec-values ! renames-let (? NextEEs) next-group (? EB))
(make p:letrec-values e1 e2 rs $2 $3 $4 $6)]) (make p:letrec-values e1 e2 rs $2 $3 $4 $6)])
(PrimLetrecSyntaxes+Values (PrimLetrecSyntaxes+Values
(#:args e1 e2 rs) (#:args e1 e2 rs)
(#:wrap)
[(prim-letrec-syntaxes+values ! renames-letrec-syntaxes [(prim-letrec-syntaxes+values ! renames-letrec-syntaxes
(? NextBindSyntaxess) next-group (? EB)) (? NextBindSyntaxess) next-group (? EB))
(make p:letrec-syntaxes+values e1 e2 rs $2 $3 $4 #f null $6)] (make p:letrec-syntaxes+values e1 e2 rs $2 $3 $4 #f null $6)]
@ -455,66 +423,55 @@
;; Atomic expressions ;; Atomic expressions
(Prim#%Datum (Prim#%Datum
(#:args e1 e2 rs tagged-stx) (#:args e1 e2 rs)
(#:wrap) [(prim-#%datum !) (make p:#%datum e1 e2 rs $2)])
[(prim-#%datum !) (make p:#%datum e1 e2 rs $2 tagged-stx)])
(Prim#%Top (Prim#%Top
(#:args e1 e2 rs tagged-stx) (#:args e1 e2 rs)
(#:wrap) [(prim-#%top !) (make p:#%top e1 e2 rs $2)])
[(prim-#%top !) (make p:#%top e1 e2 rs $2 tagged-stx)])
(PrimSTOP (PrimSTOP
(#:args e1 e2 rs) (#:args e1 e2 rs)
(#:wrap)
[(prim-stop !) (make p:stop e1 e2 rs $2)]) [(prim-stop !) (make p:stop e1 e2 rs $2)])
(PrimQuote (PrimQuote
(#:args e1 e2 rs) (#:args e1 e2 rs)
(#:wrap)
[(prim-quote !) (make p:quote e1 e2 rs $2)]) [(prim-quote !) (make p:quote e1 e2 rs $2)])
(PrimQuoteSyntax (PrimQuoteSyntax
(#:args e1 e2 rs) (#:args e1 e2 rs)
(#:wrap)
[(prim-quote-syntax !) (make p:quote-syntax e1 e2 rs $2)]) [(prim-quote-syntax !) (make p:quote-syntax e1 e2 rs $2)])
(PrimRequire (PrimRequire
(#:args e1 e2 rs) (#:args e1 e2 rs)
(#:wrap)
[(prim-require (? Eval)) [(prim-require (? Eval))
(make p:require e1 e2 rs $2)]) (make p:require e1 e2 rs $2)])
(PrimRequireForSyntax (PrimRequireForSyntax
(#:args e1 e2 rs) (#:args e1 e2 rs)
(#:wrap)
[(prim-require-for-syntax (? Eval)) [(prim-require-for-syntax (? Eval))
(make p:require-for-syntax e1 e2 rs $2)]) (make p:require-for-syntax e1 e2 rs $2)])
(PrimRequireForTemplate (PrimRequireForTemplate
(#:args e1 e2 rs) (#:args e1 e2 rs)
(#:wrap)
[(prim-require-for-template (? Eval)) [(prim-require-for-template (? Eval))
(make p:require-for-template e1 e2 rs $2)]) (make p:require-for-template e1 e2 rs $2)])
(PrimProvide (PrimProvide
(#:args e1 e2 rs) (#:args e1 e2 rs)
(#:wrap)
[(prim-provide !) (make p:provide e1 e2 rs $2)]) [(prim-provide !) (make p:provide e1 e2 rs $2)])
(PrimSet (PrimSet
(#:args e1 e2 rs) (#:args e1 e2 rs)
(#:wrap)
[(prim-set! ! Resolves next (? EE)) [(prim-set! ! Resolves next (? EE))
(make p:set! e1 e2 rs $2 $3 $5)] (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 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 ;; Blocks
;; EB Answer = BlockDerivation ;; EB Answer = BlockDerivation
(EB (EB
(#:wrap)
[(enter-block (? BlockPass1) block->list (? EL)) [(enter-block (? BlockPass1) block->list (? EL))
(make bderiv $1 (and $4 (wlderiv-es2 $4)) (make bderiv $1 (and $4 (wlderiv-es2 $4))
$2 'list $4)] $2 'list $4)]
@ -524,7 +481,6 @@
;; BlockPass1 Answer = (list-of BRule) ;; BlockPass1 Answer = (list-of BRule)
(BlockPass1 (BlockPass1
(#:no-wrap)
(#:skipped null) (#:skipped null)
[() null] [() null]
[((? BRule) (? BlockPass1)) [((? BRule) (? BlockPass1))
@ -532,7 +488,6 @@
;; BRule Answer = BRule ;; BRule Answer = BRule
(BRule (BRule
(#:wrap)
[(next !!) [(next !!)
(make b:error $2)] (make b:error $2)]
[(next renames-block (? CheckImmediateMacro)) [(next renames-block (? CheckImmediateMacro))
@ -547,13 +502,11 @@
;; BindSyntaxes Answer = Derivation ;; BindSyntaxes Answer = Derivation
(BindSyntaxes (BindSyntaxes
(#:wrap) [(enter-bind (? EE/LetLifts) next (? Eval) exit-bind)
[(phase-up (? EE/LetLifts) (? Eval)) (make bind-syntaxes $2 $4)])
(make bind-syntaxes $2 $3)])
;; NextBindSyntaxess Answer = (list-of Derivation) ;; NextBindSyntaxess Answer = (list-of Derivation)
(NextBindSyntaxess (NextBindSyntaxess
(#:no-wrap)
(#:skipped null) (#:skipped null)
[() null] [() null]
[(next (? BindSyntaxes) (? NextBindSyntaxess)) (cons $2 $3)]) [(next (? BindSyntaxes) (? NextBindSyntaxess)) (cons $2 $3)])
@ -561,7 +514,6 @@
;; Lists ;; Lists
;; EL Answer = ListDerivation ;; EL Answer = ListDerivation
(EL (EL
(#:wrap)
(#:skipped #f) (#:skipped #f)
[(enter-list ! (? EL*) exit-list) [(enter-list ! (? EL*) exit-list)
;; FIXME: Workaround for bug in events ;; FIXME: Workaround for bug in events
@ -571,7 +523,6 @@
;; EL* Answer = (listof Derivation) ;; EL* Answer = (listof Derivation)
(EL* (EL*
(#:no-wrap)
(#:skipped null) (#:skipped null)
[() null] [() null]
[(next (? EE) (? EL*)) (cons $2 $3)]) [(next (? EE) (? EL*)) (cons $2 $3)])

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

@ -44,7 +44,16 @@
enter-local/expr ; syntax enter-local/expr ; syntax
exit-local/expr ; (cons syntax expanded-expression) 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 IMPOSSIBLE ; useful for error-handling clauses that have no NoError counterpart
)) ))
@ -142,6 +151,13 @@
(139 . ,token-enter-local/expr) (139 . ,token-enter-local/expr)
(140 . ,token-exit-local/expr) (140 . ,token-exit-local/expr)
(141 . ,token-start) (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) (define (tokenize sig-n val pos)

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

@ -59,8 +59,8 @@
[?1 (?? exn?)] [?1 (?? exn?)]
[me1 (?? syntax?)] [me1 (?? syntax?)]
[locals (?? (listof localaction/c))] [locals (?? (listof localaction/c))]
[?2 (?? exn?)]
[me2 (?? syntax?)] [me2 (?? syntax?)]
[?2 (?? exn?)]
[seq number?])) [seq number?]))
(struct (local-expansion node) (struct (local-expansion node)
([z1 syntax?] ([z1 syntax?]

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

@ -2,100 +2,103 @@
#lang scheme/base #lang scheme/base
(require (for-syntax scheme/base) (require (for-syntax scheme/base)
scheme/match scheme/match
syntax/boundmap) syntax/boundmap
(provide (all-defined-out)) "synth-engine.ss")
(provide make-policy
standard-policy
base-policy
hide-all-policy
hide-none-policy)
(define-struct hiding-policy ;; make-policy : bool^4 (listof (identifier bindinglist (bool -> void) -> void))
(opaque-modules opaque-ids opaque-kernel opaque-libs transparent-ids) ;; -> identifier -> bool
#:mutable) (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) (define standard-policy
(hash-table-put! (hiding-policy-opaque-modules p) m #t)) (make-policy #t #t #t #t null))
(define (policy-unhide-module p m)
(hash-table-remove! (hiding-policy-opaque-modules p) m))
(define (policy-hide-kernel p) (define base-policy
(set-hiding-policy-opaque-kernel! p #t)) (make-policy #t #f #f #f null))
(define (policy-unhide-kernel p)
(set-hiding-policy-opaque-kernel! p #f))
(define (policy-hide-libs p) (define (hide-all-policy id) #f)
(set-hiding-policy-opaque-libs! p #t)) (define (hide-none-policy id) #t)
(define (policy-unhide-libs p)
(set-hiding-policy-opaque-libs! p #f))
(define (policy-hide-id p id)
(policy-unshow-id p id)
(module-identifier-mapping-put! (hiding-policy-opaque-ids p) id #t))
(define (policy-unhide-id p id)
(module-identifier-mapping-put! (hiding-policy-opaque-ids p) id #f))
(define (policy-show-id p id) ;;
(policy-unhide-id p id)
(module-identifier-mapping-put! (hiding-policy-transparent-ids p) id #t))
(define (policy-unshow-id p id)
(module-identifier-mapping-put! (hiding-policy-transparent-ids p) id #f))
(define (new-hiding-policy) (define (scheme-module? mpi)
(make-hiding-policy (make-hash-table) (let ([abs (find-absolute-module-path mpi)])
(make-module-identifier-mapping) (and abs
#f (or (base-module-path? abs)
#f (scheme-lib-module-path? abs)))))
(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 (lib-module? mpi) (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) (and (module-path-index? mpi)
(let-values ([(path rel) (module-path-index-split mpi)]) (let-values ([(path rel) (module-path-index-split mpi)])
(cond [(pair? path) (memq (car path) '(lib planet))] (cond [(and (pair? path) (memq (car path) '(quote lib planet)))
[(string? path) (lib-module? rel)] path]
[(symbol? path) path]
[(string? path) (find-absolute-module-path rel)]
[else #f])))) [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) [(CC HOLE expr pattern)
#'(syntax-copier 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 ;; An R-clause is one of
;; [! expr] ;; [! expr]
;; [#:pattern pattern] ;; [#:pattern pattern]
;; [#:bind pattern stx-expr] ;; [#:bind pattern stx-expr]
;; [#:let-values (var ...) expr] ;; [#:let-values (var ...) expr]
;; [#:set-syntax stx-expr]
;; [#:walk term2 foci1 foci2 description]
;; [#:walk term2 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] ;; [#:rename/no-step pattern stx stx]
;; [#:reductions expr] ;; [#:reductions expr]
;; [#:learn ids] ;; [#:learn ids]
@ -176,26 +179,22 @@
;; [#:if/np test R-clause ...] ;; [#:if/np test R-clause ...]
;; [generator hole fill] ;; [generator hole fill]
;; R
;; the threaded reductions engine
;; (R form . clauses) : (values (list-of Step) ?stx ?exn)
(define-syntax R (define-syntax R
(syntax-rules () (syntax-rules ()
[(R form . clauses) [(R form . clauses)
(R** #f _ [#:set-syntax form] . clauses)])) (let ([form-var form])
(R** form-var _ . clauses))]))
(define-syntax R** (define-syntax R**
(syntax-rules (! =>) (syntax-rules (! =>)
;; Base: done ;; Base: done
[(R** form-var pattern) [(R** form-var pattern)
(RSunit form-var)] (RSunit form-var)]
;; Base: explicit continuation ;; Base: explicit continuation
[(R** f p => k) [(R** f p => k)
(k f)] (k f)]
;; Error-point case ;; Error-point case
[(R** f p [! maybe-exn] . more) [(R** f p [! maybe-exn] . more)
(let ([x maybe-exn]) (let ([x maybe-exn])
@ -204,34 +203,26 @@
(if x (if x
(values (list (stumble f x)) #f x) (values (list (stumble f x)) #f x)
(R** f p . more)))] (R** f p . more)))]
;; Change patterns ;; Change patterns
[(R** f p [#:pattern p2] . more) [(R** f p [#:pattern p2] . more)
(R** f p2 . more)] (R** f p2 . more)]
;; Bind pattern variables ;; Bind pattern variables
[(R** f p [#:bind pattern rhs] . more) [(R** f p [#:bind pattern rhs] . more)
(with-syntax ([pattern (with-syntax ([p f]) rhs)]) (with-syntax ([pattern (with-syntax ([p f]) rhs)])
(R** f p . more))] (R** f p . more))]
;; Bind variables ;; Bind variables
[(R** f p [#:let-values (var ...) rhs] . more) [(R** f p [#:let-values (var ...) rhs] . more)
(let-values ([(var ...) (with-syntax ([p f]) rhs)]) (let-values ([(var ...) (with-syntax ([p f]) rhs)])
(R** f p . more))] (R** f p . more))]
;; Change syntax ;; Change syntax
[(R** f p [#:set-syntax form] . more) [(R** f p [#:set-syntax form] . more)
(let ([form-variable form]) (let ([form-variable form])
(R** form-variable p . more))] (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) ;; Change syntax and Step (infer foci)
[(R** f p [#:walk form2 description] . more) [(R** f p [#:walk form2 description] . more)
(let-values ([(form2-var description-var) (let-values ([(form2-var description-var)
@ -239,8 +230,52 @@
(values form2 description))]) (values form2 description))])
(RSadd (list (walk f form2-var description-var)) (RSadd (list (walk f form2-var description-var))
(lambda () (R** form2-var p . more))))] (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 ;; Change syntax with rename
#;
[(R** f p [#:rename form2 foci1 foci2 description] . more) [(R** f p [#:rename form2 foci1 foci2 description] . more)
(let-values ([(form2-var foci1-var foci2-var description-var) (let-values ([(form2-var foci1-var foci2-var description-var)
(with-syntax ([p f]) (with-syntax ([p f])
@ -251,7 +286,7 @@
f form2-var f form2-var
description-var)) description-var))
(lambda () (R** form2-var p . more)))))] (lambda () (R** form2-var p . more)))))]
;; Change syntax with rename (but no step) ;; Change syntax with rename (but no step)
[(R** f p [#:rename/no-step pvar from to] . more) [(R** f p [#:rename/no-step pvar from to] . more)
(let-values ([(from-var to-var) (let-values ([(from-var to-var)
@ -262,42 +297,42 @@
(rename-frontier from-var to-var) (rename-frontier from-var to-var)
(with-context (make-renames from-var to-var) (with-context (make-renames from-var to-var)
(R** f2 p . more))))] (R** f2 p . more))))]
;; Add in arbitrary other steps ;; Add in arbitrary other steps
[(R** f p [#:reductions steps] . more) [(R** f p [#:reductions steps] . more)
(RSseq (lambda () steps) (RSseq (lambda () steps)
(lambda () (R** f p . more)))] (lambda () (R** f p . more)))]
;; Add to definites ;; Add to definites
[(R** f p [#:learn ids] . more) [(R** f p [#:learn ids] . more)
(begin (learn-definites (with-syntax ([p f]) ids)) (begin (learn-definites (with-syntax ([p f]) ids))
(R** f p . more))] (R** f p . more))]
;; Add to frontier ;; Add to frontier
[(R** f p [#:frontier stxs] . more) [(R** f p [#:frontier stxs] . more)
(begin (add-frontier (with-syntax ([p f]) stxs)) (begin (add-frontier (with-syntax ([p f]) stxs))
(R** f p . more))] (R** f p . more))]
;; Conditional (pattern changes lost afterwards ...) ;; Conditional (pattern changes lost afterwards ...)
[(R** f p [#:if/np test [consequent ...] [alternate ...]] . more) [(R** f p [#:if/np test [consequent ...] [alternate ...]] . more)
(let ([continue (lambda (f2) (R** f2 p . more))]) (let ([continue (lambda (f2) (R** f2 p . more))])
(if (with-syntax ([p f]) test) (if (with-syntax ([p f]) test)
(R** f p consequent ... => continue) (R** f p consequent ... => continue)
(R** f p alternate ... => continue)))] (R** f p alternate ... => continue)))]
;; Conditional (pattern changes lost afterwards ...) ;; Conditional (pattern changes lost afterwards ...)
[(R** f p [#:when/np test consequent ...] . more) [(R** f p [#:when/np test consequent ...] . more)
(let ([continue (lambda (f2) (R** f2 p . more))]) (let ([continue (lambda (f2) (R** f2 p . more))])
(if (with-syntax ([p f]) test) (if (with-syntax ([p f]) test)
(R** f p consequent ... => continue) (R** f p consequent ... => continue)
(continue f)))] (continue f)))]
;; Conditional ;; Conditional
[(R** f p [#:when test consequent ...] . more) [(R** f p [#:when test consequent ...] . more)
(if (with-syntax ([p f]) test) (if (with-syntax ([p f]) test)
(R** f p consequent ... . more) (R** f p consequent ... . more)
(R** f p . more))] (R** f p . more))]
;; Subterm handling ;; Subterm handling
[(R** f p [generator hole fill] . more) [(R** f p [generator hole fill] . more)
(let ([k (lambda (f2) (R** f2 p . more))]) (let ([k (lambda (f2) (R** f2 p . more))])
@ -307,22 +342,28 @@
(define-syntax Run (define-syntax Run
(syntax-rules () (syntax-rules ()
[(Run f p generator hole fill k) [(Run f p generator hole fill k)
(let ([reducer (with-syntax ([p f]) (generator))]) (let ([reducer (generator)])
(Run* reducer f p hole fill k))])) (Run* reducer f p hole fill k))]))
(define-syntax (Run* stx) (define-syntax (Run* stx)
(syntax-case stx () (syntax-case stx ()
;; Implementation of subterm handling for (hole ...) sequences ;; Implementation of subterm handling for (hole ...) sequences
[(Run* f form-var pattern (hole :::) fills k) [(Run* reducer f p (hole :::) fills k)
(and (identifier? #':::) (and (identifier? #':::)
(free-identifier=? #'::: (quote-syntax ...))) (free-identifier=? #'::: (quote-syntax ...)))
#'(let ([ctx (CC (hole :::) form-var pattern)]) #'(let ([ctx (CC (hole :::) f p)])
(let ([e1s (with-syntax ([pattern form-var]) (syntax->list #'(hole :::)))]) (let ([e1s (with-syntax ([p f]) (syntax->list #'(hole :::)))])
(run-multiple f ctx fills e1s k)))] (run-multiple reducer ctx fills e1s k)))]
;; Implementation of subterm handling ;; Implementation of subterm handling
[(Run* f form-var pattern hole fill k) [(Run* reducer f p hole fill k)
#'(let ([ctx (CC hole form-var pattern)]) #'(let ([init-e (with-syntax ([p f]) #'hole)]
(run-one f ctx fill k))])) [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)) ;; run-multiple : (a -> RS(b)) ((list-of b) -> c) (list-of a) (list-of b) (c -> RS(d))
;; -> RS(d) ;; -> RS(d)
@ -334,21 +375,15 @@
(RSbind (lambda () (RSbind (lambda ()
(with-context ctx (with-context ctx
(with-context (lambda (x) (revappend prefix (cons x (cdr suffix)))) (with-context (lambda (x) (revappend prefix (cons x (cdr suffix))))
(f (car fills))))) (f (car fills) (car suffix)))))
(lambda (final) (lambda (final)
(loop (cdr fills) (loop (cdr fills)
(cons final prefix) (cons final prefix)
(cdr suffix))))] (cdr suffix))))]
[(null? fills) [(null? fills)
(let ([form (ctx (reverse prefix))]) (let ([form (ctx (reverse prefix))])
(k form))]))) (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 ;; Rename mapping
(define (rename-frontier from to) (define (rename-frontier from to)
@ -367,7 +402,8 @@
[(syntax? to) [(syntax? to)
(loop from (syntax-e to))] (loop from (syntax-e to))]
[(pair? from) [(pair? from)
#;(unless (pair? to) #;
(unless (pair? to)
(fprintf (current-error-port) (fprintf (current-error-port)
"from:\n~s\n\n" (syntax->datum from0)) "from:\n~s\n\n" (syntax->datum from0))
(fprintf (current-error-port) (fprintf (current-error-port)

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

@ -19,14 +19,14 @@
transformation-reductions) transformation-reductions)
(define (BindSyntaxes) (define (BindSyntaxes)
bind-syntaxes-reductions) bind-syntaxes-reductions)
(define ((CaseLambdaClauses e1)) (define (CaseLambdaClauses)
(mk-case-lambda-clauses-reductions e1)) case-lambda-clauses-reductions)
(define ((SynthItems e1)) (define (SynthItems)
(mk-synth-items-reductions e1)) synth-items-reductions)
(define ((BRules es1)) (define (BRules)
(mk-brules-reductions es1)) brules-reductions)
(define ((ModulePass es1)) (define (ModulePass)
(mk-mbrules-reductions es1)) mbrules-reductions)
;; Syntax ;; Syntax
@ -41,24 +41,28 @@
;; reductions : WDeriv -> ReductionSequence ;; reductions : WDeriv -> ReductionSequence
(define (reductions d) (define (reductions d)
(parameterize ((current-definites null) (let-values ([(steps definites estx exn) (reductions+ d)])
(current-frontier null)) steps))
(when d (add-frontier (list (wderiv-e1 d))))
(RS-steps (reductions* d))))
;; reductions+ : WDeriv -> (list-of step) (list-of identifier) ?stx ?exn ;; reductions+ : WDeriv -> (list-of step) (list-of identifier) ?stx ?exn
(define (reductions+ d) (define (reductions+ d)
(parameterize ((current-definites null) (parameterize ((current-definites null)
(current-frontier null)) (current-frontier null))
(when d (add-frontier (list (wderiv-e1 d)))) (when d (add-frontier (list (wderiv-e1 d))))
(let-values ([(rs stx exn) (reductions* d)]) (let-values ([(steps stx exn) (reductions* d (wderiv-e1 d))])
(values rs (current-definites) stx exn)))) (values steps (current-definites) stx exn))))
;; reductions* : WDeriv -> RS(stx) ;; reductions* : WDeriv Syntax -> RS(stx)
(define (reductions* d) (define (reductions* d init-e1)
(match d (match d
[(Wrap deriv (e1 e2)) [(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)]) [_ (void)])
(match d (match d
[(Wrap prule (e1 e2 rs ?1)) [(Wrap prule (e1 e2 rs ?1))
@ -70,38 +74,41 @@
(R e1 (R e1
[#:learn (list e2)] [#:learn (list e2)]
[#:when/np (not (bound-identifier=? e1 e2)) [#:when/np (not (bound-identifier=? e1 e2))
[#:walk e2 e1 e2 'resolve-variable]])] [#:walk e2 'resolve-variable]])]
[(Wrap p:module (e1 e2 rs ?1 #f #f #f body)) [(Wrap p:module (e1 e2 rs ?1 ?2 tag rename check tag2 ?3 body shift))
(R e1 (R e1
[! ?1] [! ?1]
[#:pattern (?module ?name ?language . ?_body)] [#:pattern (?module ?name ?language . ?body-parts)]
[#:walk (d->so e1 `(,#'?module ,#'?name ,#'?language ,(wderiv-e1 body))) #;[#:frontier null (list #'?language #'?body-parts)]
'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]
[! ?2] [! ?2]
[#:when/np (not (eq? (wderiv-e2 mb) (wderiv-e1 body))) #;[#:frontier (list #'?language) null]
[#:walk [#:when/np tag
(d->so e1 `(,#'?module ,#'?name ,#'?language [#:walk/ctx ?body-parts
,(wderiv-e1 body))) (list tag)
'tag-module-begin]] 'tag-module-begin]]
[Expr ?body body])] [#:pattern (?module ?name ?language ?body)]
[(Wrap p:#%module-begin (e1 e2 rs ?1 pass1 pass2 ?2)) [#: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 (R e1
[! ?1] [! ?1]
#;[#:let-values (_) (printf "#%module-begin:\n~s\n" me)]
[#:pattern ?form]
[#:rename* ?form me]
[#:pattern (?module-begin . ?forms)] [#:pattern (?module-begin . ?forms)]
[#:frontier (stx->list* #'?forms)] #;[#:frontier (syntax->list #'?forms)]
[(ModulePass #'?forms) #;[#:let-values (_) (printf "#%module-begin ?forms:\n~s\n" #'?forms)]
?forms pass1] [ModulePass ?forms pass1]
[(ModulePass #'?forms) [ModulePass ?forms pass2]
?forms pass2]
[! ?1])] [! ?1])]
[(Wrap p:define-syntaxes (e1 e2 rs ?1 rhs ?2)) [(Wrap p:define-syntaxes (e1 e2 rs ?1 rhs ?2))
(R e1 (R e1
@ -124,21 +131,14 @@
[#:pattern (?expr ?inner)] [#:pattern (?expr ?inner)]
[#:frontier (list #'?inner)] [#:frontier (list #'?inner)]
[Expr ?inner inner])] [Expr ?inner inner])]
[(Wrap p:if (e1 e2 rs ?1 full? test then else)) [(Wrap p:if (e1 e2 rs ?1 test then else))
(if full? (R e1
(R e1 [! ?1]
[! ?1] [#:pattern (?if TEST THEN ELSE)]
[#:pattern (?if TEST THEN ELSE)] [#:frontier (list #'TEST #'THEN #'ELSE)]
[#:frontier (list #'TEST #'THEN #'ELSE)] [Expr TEST test]
[Expr TEST test] [Expr THEN then]
[Expr THEN then] [Expr ELSE else])]
[Expr ELSE else])
(R e1
[! ?1]
[#:pattern (?if TEST THEN)]
[#:frontier (list #'TEST #'THEN)]
[Expr TEST test]
[Expr THEN then]))]
[(Wrap p:wcm (e1 e2 rs ?1 key mark body)) [(Wrap p:wcm (e1 e2 rs ?1 key mark body))
(R e1 (R e1
[! ?1] [! ?1]
@ -160,42 +160,31 @@
[#:frontier (cons #'FIRST (stx->list* #'LDERIV))] [#:frontier (cons #'FIRST (stx->list* #'LDERIV))]
[Expr FIRST first] [Expr FIRST first]
[List LDERIV lderiv])] [List LDERIV lderiv])]
[(Wrap p:#%app (e1 e2 rs ?1 tagged-stx lderiv)) [(Wrap p:#%app (e1 e2 rs ?1 lderiv))
(R e1 (R e1
[! ?1] [! ?1]
[#:when/np (not (eq? tagged-stx e1))
[#:walk tagged-stx 'tag-app]]
[#:pattern (?app . LDERIV)] [#:pattern (?app . LDERIV)]
[#:frontier (stx->list* #'LDERIV)] [#:frontier (stx->list* #'LDERIV)]
[List LDERIV lderiv])] [List LDERIV lderiv])]
[(Wrap p:lambda (e1 e2 rs ?1 renames body)) [(Wrap p:lambda (e1 e2 rs ?1 renames body))
(R e1 (R e1
[! ?1] [! ?1]
[#:bind (?formals* . ?body*) renames]
[#:pattern (?lambda ?formals . ?body)] [#:pattern (?lambda ?formals . ?body)]
[#:frontier (stx->list* #'?body)] [#:frontier (stx->list* #'?body)]
[#:rename (syntax/skeleton e1 (?lambda ?formals* . ?body*)) [#:rename* (?formals . ?body) renames 'rename-lambda]
#'?formals #'?formals*
'rename-lambda]
[Block ?body body])] [Block ?body body])]
[(Wrap p:case-lambda (e1 e2 rs ?1 clauses)) [(Wrap p:case-lambda (e1 e2 rs ?1 clauses))
(R e1 (R e1
[! ?1] [! ?1]
[#:pattern (?case-lambda . ?clauses)] [#:pattern (?case-lambda . ?clauses)]
[#:frontier (stx->list* #'?clauses)] [#:frontier (stx->list* #'?clauses)]
[(CaseLambdaClauses (stx->list* #'?clauses)) [CaseLambdaClauses ?clauses clauses])]
?clauses clauses])]
[(Wrap p:let-values (e1 e2 rs ?1 renames rhss body)) [(Wrap p:let-values (e1 e2 rs ?1 renames rhss body))
(R e1 (R e1
[! ?1] [! ?1]
[#:pattern (?let-values ([?vars ?rhs] ...) . ?body)] [#:pattern (?let-values ([?vars ?rhs] ...) . ?body)]
[#:frontier (append (syntax->list #'(?rhs ...)) (stx->list* #'?body))] [#:frontier (append (syntax->list #'(?rhs ...)) (stx->list* #'?body))]
[#:bind (([?vars* ?rhs*] ...) . ?body*) renames] [#:rename* (((?vars ?rhs) ...) . ?body) renames 'rename-let-values]
[#:rename
(syntax/skeleton e1 (?let-values ([?vars* ?rhs*] ...) . ?body*))
(syntax->list #'(?vars ...))
(syntax->list #'(?vars* ...))
'rename-let-values]
[Expr (?rhs ...) rhss] [Expr (?rhs ...) rhss]
[Block ?body body])] [Block ?body body])]
[(Wrap p:letrec-values (e1 e2 rs ?1 renames rhss body)) [(Wrap p:letrec-values (e1 e2 rs ?1 renames rhss body))
@ -203,12 +192,7 @@
[! ?1] [! ?1]
[#:pattern (?letrec-values ([?vars ?rhs] ...) . ?body)] [#:pattern (?letrec-values ([?vars ?rhs] ...) . ?body)]
[#:frontier (append (syntax->list #'(?rhs ...)) (stx->list* #'?body))] [#:frontier (append (syntax->list #'(?rhs ...)) (stx->list* #'?body))]
[#:bind (([?vars* ?rhs*] ...) . ?body*) renames] [#:rename* (((?vars ?rhs) ...) . ?body) renames 'rename-letrec-values]
[#:rename
(syntax/skeleton e1 (?letrec-values ([?vars* ?rhs*] ...) . ?body*))
(syntax->list #'(?vars ...))
(syntax->list #'(?vars* ...))
'rename-letrec-values]
[Expr (?rhs ...) rhss] [Expr (?rhs ...) rhss]
[Block ?body body])] [Block ?body body])]
[(Wrap p:letrec-syntaxes+values [(Wrap p:letrec-syntaxes+values
@ -219,49 +203,39 @@
[#:frontier (append (syntax->list #'(?srhs ...)) [#:frontier (append (syntax->list #'(?srhs ...))
(syntax->list #'(?vrhs ...)) (syntax->list #'(?vrhs ...))
(stx->list* #'?body))] (stx->list* #'?body))]
[#:bind (([?svars* ?srhs*] ...) ([?vvars* ?vrhs*] ...) . ?body*) srenames] [#:rename* (((?svars ?srhs) ...) ((?vvars ?vrhs) ...) . ?body) srenames
[#:rename 'rename-lsv]
(syntax/skeleton e1
(?lsv ([?svars* ?srhs*] ...) ([?vvars* ?vrhs*] ...)
. ?body*))
(syntax->list #'(?svars ...))
(syntax->list #'(?svars* ...))
'rename-lsv]
[BindSyntaxes (?srhs ...) srhss] [BindSyntaxes (?srhs ...) srhss]
;; If vrenames is #f, no var bindings to rename ;; If vrenames is #f, no var bindings to rename
[#:when/np vrenames [#:when/np vrenames
[#:bind (([?vvars** ?vrhs**] ...) . ?body**) vrenames] [#:bind (([?vvars** ?vrhs**] ...) . ?body**) vrenames]
[#:rename [#:rename* (((?vars ?vrhs) ...) . ?body) vrenames 'rename-lsv]]
(syntax/skeleton e1 (?lsv ([?svars* ?srhs*] ...)
([?vvars** ?vrhs**] ...)
. ?body**))
(syntax->list #'(?vvars* ...))
(syntax->list #'(?vvars** ...))
'rename-lsv]]
[Expr (?vrhs ...) vrhss] [Expr (?vrhs ...) vrhss]
[Block ?body body] [Block ?body body]
[#:pattern ?form] [#:pattern ?form]
[#:when/np (not (eq? #'?form e2)) ;; FIXME: correct comparison? [#:when/np (not (eq? #'?form e2)) ;; FIXME: correct comparison?
[#:walk e2 'lsv-remove-syntax]])] [#: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 (R e1
[#:when/np (not (eq? e1 tagged-stx)) [! ?1]
[#:walk tagged-stx 'tag-datum]] [#:walk e2 'macro])]
[! ?1])] [(Wrap p:#%top (e1 e2 rs ?1))
[(Wrap p:#%top (e1 e2 rs ?1 tagged-stx))
(R e1 (R e1
[#:when/np (not (eq? e1 tagged-stx))
[#:walk tagged-stx 'tag-top]]
[#:pattern (?top . ?var)] [#:pattern (?top . ?var)]
[#:learn (list #'?var)] [#:learn (list #'?var)]
[! ?1])] [! ?1])]
[(Wrap p:provide (e1 e2 rs ?1))
(R e1
[! ?1]
[#:walk e2 'provide])]
;; The rest of the automatic primitives ;; The rest of the automatic primitives
[(Wrap p::STOP (e1 e2 rs ?1)) [(Wrap p::STOP (e1 e2 rs ?1))
(R e1 (R e1
[! ?1])] [! ?1])]
[(Wrap p:set!-macro (e1 e2 rs ?1 deriv)) [(Wrap p:set!-macro (e1 e2 rs ?1 deriv))
(R e1 (R e1
[! ?1] [! ?1]
@ -275,7 +249,7 @@
[#:frontier (list #'?rhs)] [#:frontier (list #'?rhs)]
[#:learn id-rs] [#:learn id-rs]
[Expr ?rhs rhs])] [Expr ?rhs rhs])]
;; Synthetic primitives ;; Synthetic primitives
;; These have their own subterm replacement mechanisms ;; These have their own subterm replacement mechanisms
[(Wrap p:synth (e1 e2 rs ?1 subterms ?2)) [(Wrap p:synth (e1 e2 rs ?1 subterms ?2))
@ -299,17 +273,18 @@
(rename-frontier (s:rename-after (car subterms)) (rename-frontier (s:rename-after (car subterms))
(s:rename-before (car subterms)))])) (s:rename-before (car subterms)))]))
(current-frontier))] (current-frontier))]
[(SynthItems e1) ?form subterms] [SynthItems ?form subterms]
[! ?2])] [! ?2])]
;; FIXME: elimiate => ?? ;; FIXME: elimiate => ??
[(Wrap p:rename (e1 e2 rs ?1 rename inner)) [(Wrap p:rename (e1 e2 rs ?1 rename inner))
(R e1 (R e1
[! ?1] [! ?1]
[#:pattern ?form]
=> =>
(lambda (e) (lambda (e)
(rename-frontier (car rename) (cdr rename)) (rename-frontier (car rename) (cdr rename))
(reductions* inner)))] (reductions* inner (wderiv-e1 inner))))]
;; Macros ;; Macros
[(Wrap mrule (e1 e2 transformation next)) [(Wrap mrule (e1 e2 transformation next))
@ -318,9 +293,21 @@
[Transformation ?form transformation] [Transformation ?form transformation]
[#:frontier (list (wderiv-e1 next))] [#:frontier (list (wderiv-e1 next))]
[Expr ?form 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 ;; Lifts
[(Wrap lift-deriv (e1 e2 first lifted-stx second)) [(Wrap lift-deriv (e1 e2 first lifted-stx second))
(R e1 (R e1
[#:pattern ?form] [#:pattern ?form]
@ -328,7 +315,7 @@
[#:frontier (list lifted-stx)] [#:frontier (list lifted-stx)]
[#:walk lifted-stx 'capture-lifts] [#:walk lifted-stx 'capture-lifts]
[Expr ?form second])] [Expr ?form second])]
[(Wrap lift/let-deriv (e1 e2 first lifted-stx second)) [(Wrap lift/let-deriv (e1 e2 first lifted-stx second))
(R e1 (R e1
[#:pattern ?form] [#:pattern ?form]
@ -336,13 +323,13 @@
[#:frontier (list lifted-stx)] [#:frontier (list lifted-stx)]
[#:walk lifted-stx 'capture-lifts] [#:walk lifted-stx 'capture-lifts]
[Expr ?form second])] [Expr ?form second])]
;; Skipped
[#f (RSzero)]))
;; mk-case-lambda-clauses-reductions : stxs -> ;; Skipped
;; (list-of (W (list ?exn rename (W BDeriv)))) -> (RS stxs) [#f (RSunit init-e1)]))
(define ((mk-case-lambda-clauses-reductions es1) clauses)
;; 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) (blaze-frontier es1)
(match clauses (match clauses
['() ['()
@ -352,16 +339,12 @@
[! ?1] [! ?1]
[#:pattern ((?formals . ?body) . ?rest)] [#:pattern ((?formals . ?body) . ?rest)]
[#:frontier (list #'?body #'?rest)] [#:frontier (list #'?body #'?rest)]
[#:bind (?formals* . ?body*) rename] [#:rename* (?formals . ?body) rename 'rename-case-lambda]
[#:rename (syntax/skeleton es1 ((?formals* . ?body*) . ?rest))
#'?formals #'?formals*
'rename-case-lambda]
[Block ?body body] [Block ?body body]
[(CaseLambdaClauses (cdr es1)) [CaseLambdaClauses ?rest rest])]))
?rest rest])]))
;; mk-synth-items-reductions : syntax -> (list-of SynthItem) -> (RS syntax) ;; synth-items-reductions : (list-of SynthItem) syntax -> (RS syntax)
(define ((mk-synth-items-reductions e1) subterms) (define (synth-items-reductions subterms e1)
(let loop ([term e1] [subterms subterms]) (let loop ([term e1] [subterms subterms])
(cond [(null? subterms) (cond [(null? subterms)
(RSunit e1)] (RSunit e1)]
@ -369,9 +352,12 @@
(let* ([subterm0 (car subterms)] (let* ([subterm0 (car subterms)]
[path0 (s:subterm-path subterm0)] [path0 (s:subterm-path subterm0)]
[deriv0 (s:subterm-deriv 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 () (RSseq (lambda ()
(with-context ctx (reductions* deriv0))) (with-context ctx
(reductions* deriv0 (wderiv-e1 deriv0))))
(lambda () (lambda ()
(loop (path-replace term path0 (wderiv-e2 deriv0)) (loop (path-replace term path0 (wderiv-e2 deriv0))
(cdr subterms))))))] (cdr subterms))))))]
@ -386,20 +372,17 @@
(s:rename-after subterm0)) (s:rename-after subterm0))
(cdr subterms)))]))) (cdr subterms)))])))
;; transformation-reductions : Transformation -> (RS Stx) ;; transformation-reductions : Transformation stx -> (RS Stx)
(define (transformation-reductions tx) (define (transformation-reductions tx init-e1)
(match tx (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 (R e1
[! ?1] [! ?1]
[#:pattern ?form] [#:pattern ?form]
[#:learn rs] [#:learn rs]
[#:reductions (reductions-locals e1 locals)] [#:reductions (reductions-locals e1 locals)]
[! ?2] [! ?2]
[#:walk e2 [#:walk e2 'macro])]))
(list #'?form)
(list e2)
'macro])]))
;; reductions-locals : syntax (list-of LocalAction) -> (RS void) ;; reductions-locals : syntax (list-of LocalAction) -> (RS void)
(define (reductions-locals stx locals) (define (reductions-locals stx locals)
@ -409,23 +392,24 @@
;; reductions-local : LocalAction -> (RS void) ;; reductions-local : LocalAction -> (RS void)
(define (reductions-local local) (define (reductions-local local)
(match/with-derivation local (match/with-derivation local
[(struct local-expansion (e1 e2 me1 me2 for-stx? deriv)) [(struct local-expansion (e1 e2 me1 me2 deriv for-stx? lifted opaque))
(reductions* deriv)] ;; FIXME
[(struct local-expansion/expr (e1 e2 me1 me2 for-stx? opaque deriv)) ;; When lifted is present, need to locally rearrange lifts!
(fprintf (current-error-port) (when (or lifted opaque)
"reductions: local-expand-expr not fully implemented") (fprintf (current-error-port)
(reductions* deriv)] "reductions: local-expand-expr not fully implemented"))
(reductions* deriv me1)]
[(struct local-lift (expr id)) [(struct local-lift (expr id))
(RSadd (list (walk expr id 'local-lift)) (RSadd (list (walk expr id 'local-lift))
RSzero)] RSzero)]
[(struct local-lift-end (decl)) [(struct local-lift-end (decl))
(RSadd (list (walk/mono decl 'module-lift)) (RSadd (list (walk/mono decl 'module-lift))
RSzero)] RSzero)]
[(struct local-bind (bindrhs)) [(struct local-bind (names bindrhs))
(bind-syntaxes-reductions bindrhs)])) (bind-syntaxes-reductions bindrhs)]))
;; list-reductions : ListDerivation -> (RS Stxs) ;; list-reductions : ListDerivation stxs -> (RS Stxs)
(define (list-reductions ld) (define (list-reductions ld init-es1)
(match/with-derivation ld (match/with-derivation ld
[(Wrap lderiv (es1 es2 ?1 derivs)) [(Wrap lderiv (es1 es2 ?1 derivs))
(R es1 (R es1
@ -434,13 +418,13 @@
[Expr (?form ...) derivs])] [Expr (?form ...) derivs])]
[#f (RSunit null)])) [#f (RSunit null)]))
;; block-reductions : BlockDerivation -> (RS Stxs) ;; block-reductions : BlockDerivation stxs -> (RS Stxs)
(define (block-reductions bd) (define (block-reductions bd init-es1)
(match/with-derivation bd (match/with-derivation bd
[(Wrap bderiv (es1 es2 pass1 trans pass2)) [(Wrap bderiv (es1 es2 pass1 trans pass2))
(R es1 (R es1
[#:pattern ?form] [#:pattern ?form]
[(BRules es1) ?form pass1] [BRules ?form pass1]
[#:when/np (eq? trans 'letrec) [#:when/np (eq? trans 'letrec)
[#:walk (wlderiv-es1 pass2) 'block->letrec]] [#:walk (wlderiv-es1 pass2) 'block->letrec]]
[#:frontier (stx->list* (wlderiv-es1 pass2))] [#:frontier (stx->list* (wlderiv-es1 pass2))]
@ -448,8 +432,8 @@
[List ?form pass2])] [List ?form pass2])]
[#f (RSunit null)])) [#f (RSunit null)]))
;; mk-brules-reductions : stxs -> (list-of BRule) -> (RS Stxs) ;; brules-reductions : (list-of BRule) stxs -> (RS Stxs)
(define ((mk-brules-reductions es1) brules) (define (brules-reductions brules es1)
(match brules (match brules
['() ['()
(RSunit null)] (RSunit null)]
@ -459,7 +443,7 @@
[#:bind ?first* (cdr renames)] [#:bind ?first* (cdr renames)]
[#:rename/no-step ?first (car renames) (cdr renames)] [#:rename/no-step ?first (car renames) (cdr renames)]
[Expr ?first head] [Expr ?first head]
[(BRules (stx-cdr es1)) ?rest rest])] [BRules ?rest rest])]
[(cons (Wrap b:defvals (renames head ?1)) rest) [(cons (Wrap b:defvals (renames head ?1)) rest)
(R es1 (R es1
[#:pattern (?first . ?rest)] [#:pattern (?first . ?rest)]
@ -469,7 +453,7 @@
[! ?1] [! ?1]
[#:pattern ((?define-values ?vars ?rhs) . ?rest)] [#:pattern ((?define-values ?vars ?rhs) . ?rest)]
[#:learn (syntax->list #'?vars)] [#:learn (syntax->list #'?vars)]
[(BRules (stx-cdr es1)) ?rest rest])] [BRules ?rest rest])]
[(cons (Wrap b:defstx (renames head ?1 bindrhs)) rest) [(cons (Wrap b:defstx (renames head ?1 bindrhs)) rest)
(R es1 (R es1
[#:pattern (?first . ?rest)] [#:pattern (?first . ?rest)]
@ -480,7 +464,7 @@
[#:pattern ((?define-syntaxes ?vars ?rhs) . ?rest)] [#:pattern ((?define-syntaxes ?vars ?rhs) . ?rest)]
[#:learn (syntax->list #'?vars)] [#:learn (syntax->list #'?vars)]
[BindSyntaxes ?rhs bindrhs] [BindSyntaxes ?rhs bindrhs]
[(BRules (stx-cdr es1)) ?rest rest])] [BRules ?rest rest])]
[(cons (Wrap b:splice (renames head ?1 tail ?2)) rest) [(cons (Wrap b:splice (renames head ?1 tail ?2)) rest)
(R es1 (R es1
[#:pattern (?first . ?rest)] [#:pattern (?first . ?rest)]
@ -488,20 +472,20 @@
[#:rename/no-step ?first (car renames) (cdr renames)] [#:rename/no-step ?first (car renames) (cdr renames)]
[Expr ?first head] [Expr ?first head]
[! ?1] [! ?1]
[#:walk tail [#:walk/foci tail
(list #'?first) (list #'?first)
(stx-take tail (- (stx-improper-length tail) (stx-take tail (- (stx-improper-length tail)
(stx-improper-length #'?rest))) (stx-improper-length #'?rest)))
'splice-block] 'splice-block]
[! ?2] [! ?2]
[#:pattern ?forms] [#:pattern ?forms]
[(BRules (stx->list* #'?forms)) ?forms rest])] [BRules ?forms rest])]
[(cons (Wrap b:error (exn)) rest) [(cons (Wrap b:error (exn)) rest)
(R es1 (R es1
[! exn])])) [! exn])]))
;; bind-syntaxes-reductions : BindSyntaxes -> (RS stx) ;; bind-syntaxes-reductions : BindSyntaxes stx -> (RS stx)
(define (bind-syntaxes-reductions bindrhs) (define (bind-syntaxes-reductions bindrhs init-e1)
(match bindrhs (match bindrhs
[(Wrap bind-syntaxes (rhs ?1)) [(Wrap bind-syntaxes (rhs ?1))
(R (wderiv-e1 rhs) (R (wderiv-e1 rhs)
@ -509,54 +493,58 @@
[Expr ?form rhs] [Expr ?form rhs]
[! ?1])])) [! ?1])]))
;; mk-mbrules-reductions : stx -> (list-of MBRule) -> (RS stxs) ;; mbrules-reductions : -> (list-of MBRule) stxs -> (RS stxs)
(define ((mk-mbrules-reductions es1) mbrules) (define (mbrules-reductions mbrules es1)
(match mbrules (match mbrules
['() ['()
(RSunit null)] (RSunit null)]
[(cons (Wrap mod:skip ()) rest) [(cons (Wrap mod:prim (head rename prim)) rest)
(R es1 (R es1
[#:pattern (?first . ?rest)] [#:pattern (?firstP . ?rest)]
[(ModulePass (stx-cdr es1)) ?rest rest])] [Expr ?firstP head]
[(cons (Wrap mod:cons (head)) rest) [#:rename* ?firstP rename]
[Expr ?firstP prim]
[ModulePass ?rest rest])]
[(cons (Wrap mod:splice (head rename ?1 tail)) rest)
(R es1 (R es1
[#:pattern (?first . ?rest)] [#:pattern (?firstB . ?rest)]
[Expr ?first head] [Expr ?firstB head]
[(ModulePass (stx-cdr es1)) ?rest rest])] [#:rename* ?firstB rename]
[(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]
[! ?1] [! ?1]
[#:walk tail [#:walk/foci tail
(list #'?first) (list #'?firstB)
(stx-take tail (- (stx-improper-length tail) (stx-take tail (- (stx-improper-length tail)
(stx-improper-length #'?rest))) (stx-improper-length #'?rest)))
'splice-module] 'splice-module]
[#:pattern ?forms] [#:pattern ?forms]
[(ModulePass #'?forms) ?forms rest])] [ModulePass ?forms rest])]
[(cons (Wrap mod:lift (head stxs)) rest) [(cons (Wrap mod:lift (head renames stxs)) rest)
(R es1 (R es1
[#:pattern (?first . ?rest)] [#:pattern (?firstL . ?rest)]
[Expr ?first head] [Expr ?firstL head]
[#:pattern ?forms] [#:pattern ?forms]
[#:walk (append stxs #'?forms) [#:when/np renames
null [#:rename* ?forms renames]]
stxs [#:walk/foci (append stxs #'?forms)
'splice-lifts] null
[(ModulePass #'?forms) ?forms rest])] stxs
'splice-lifts]
[ModulePass ?forms rest])]
[(cons (Wrap mod:lift-end (stxs)) rest) [(cons (Wrap mod:lift-end (stxs)) rest)
(R es1 (R es1
[#:pattern ?forms] [#:pattern ?forms]
[#:when/np (pair? stxs) [#:when/np (pair? stxs)
[#:walk (append stxs #'?forms) [#:walk/foci (append stxs #'?forms)
null null
stxs stxs
'splice-module-lifts]] 'splice-module-lifts]]
[(ModulePass #'?forms) ?forms rest])])) [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-datum . "Tag datum")
(tag-top . "Tag top-level variable") (tag-top . "Tag top-level variable")
(capture-lifts . "Capture lifts") (capture-lifts . "Capture lifts")
(provide . "Expand provide-specs")
(local-lift . "Macro lifted expression to top-level") (local-lift . "Macro lifted expression to top-level")
(module-lift . "Macro lifted declaration to end of module") (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? (define wrap?
(let ([wrap? (assq '#:wrap options)] (let ([wrap? (assq '#:wrap options)]
[no-wrap? (assq '#:no-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?))) (unless (and (or wrap? no-wrap?) (not (and wrap? no-wrap?)))
(raise-syntax-error 'split (raise-syntax-error 'split
"must specify exactly one of #:wrap, #:no-wrap" "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/reductions.ss"
"model/steps.ss" "model/steps.ss"
"model/hide.ss" "model/hide.ss"
"model/hiding-policies.ss"
"syntax-browser/partition.ss" "syntax-browser/partition.ss"
"syntax-browser/pretty-helper.ss") "syntax-browser/pretty-helper.ss")
(provide expand/step-text (provide expand/step-text
@ -125,8 +124,6 @@
(lambda (id) (lambda (id)
(ormap (lambda (x) (free-identifier=? x id)) (ormap (lambda (x) (free-identifier=? x id))
show))] show))]
[(hiding-policy? show)
(lambda (x) (policy-show-macro? show x))]
[(eq? show #f) [(eq? show #f)
#f] #f]
[else [else

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

@ -176,11 +176,6 @@
(let ([end (get-end-position)]) (let ([end (get-end-position)])
;; Pretty printer always inserts final newline; we remove it here. ;; Pretty printer always inserts final newline; we remove it here.
(send text delete (sub1 end) end)) (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)]) (let ([offset (get-start-position)])
(fixup-parentheses text range offset) (fixup-parentheses text range offset)
(for-each (for-each
@ -191,8 +186,13 @@
(send text set-clickback (+ offset start) (+ offset end) (send text set-clickback (+ offset start) (+ offset end)
(lambda (_1 _2 _3) (lambda (_1 _2 _3)
(send controller set-selected-syntax stx))))) (send controller set-selected-syntax stx)))))
(send range all-ranges)) (send range all-ranges)))
range))) ;; Set font to standard
(send text change-style
(code-style text)
(get-start-position)
(get-end-position))
range))
;; fixup-parentheses : text range -> void ;; fixup-parentheses : text range -> void
(define (fixup-parentheses text range offset) (define (fixup-parentheses text range offset)

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

@ -4,35 +4,73 @@
scheme/gui scheme/gui
"interfaces.ss" "interfaces.ss"
"partition.ss") "partition.ss")
(provide syntax-keymap% (provide smart-keymap%
context-menu%) syntax-keymap%)
(define syntax-keymap% (define smart-keymap%
(class keymap% (class keymap%
(init editor) (init editor)
(init-field controller)
(inherit add-function (inherit add-function
map-function map-function
chain-to-keymap) chain-to-keymap)
(super-new) (super-new)
(define/public (get-context-menu%) (define/public (get-context-menu%)
context-menu%) smart-context-menu%)
(define/public (make-context-menu) (field (the-context-menu #f))
(new (get-context-menu%) (controller controller) (keymap this))) (set! the-context-menu (new (get-context-menu%)))
;; Key mappings
(map-function "rightbutton" "popup-context-window") (map-function "rightbutton" "popup-context-window")
;; Functionality
(add-function "popup-context-window" (add-function "popup-context-window"
(lambda (editor event) (lambda (editor event)
(do-popup-context-window 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" (add-function "copy-text"
(lambda (_ event) (lambda (_ event)
(define stx (send controller get-selected-syntax)) (define stx (send controller get-selected-syntax))
@ -48,38 +86,17 @@
(add-function "show-syntax-properties" (add-function "show-syntax-properties"
(lambda (i e) (lambda (i e)
(error 'show-syntax-properties "not provided by this keymap"))) (send config set-props-shown? #t)))
;; Attach to editor (add-function "hide-syntax-properties"
(lambda (i e)
(chain-to-keymap (send editor get-keymap) #t) (send config set-props-shown? #f)))
(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])
(define/public (add-edit-items) (define/public (add-edit-items)
(set! copy-menu (set! copy-menu
(new menu-item% (label "Copy") (parent this) (new menu-item% (label "Copy") (parent the-context-menu)
(callback (lambda (i e) (callback (lambda (i e)
(send keymap call-function "copy-text" i e))))) (call-function "copy-text" i e)))))
(void)) (void))
(define/public (after-edit-items) (define/public (after-edit-items)
@ -89,24 +106,26 @@
(set! clear-menu (set! clear-menu
(new menu-item% (new menu-item%
(label "Clear selection") (label "Clear selection")
(parent this) (parent the-context-menu)
(callback (callback
(lambda (i e) (lambda (i e)
(send keymap call-function "clear-syntax-selection" i e))))) (call-function "clear-syntax-selection" i e)))))
(set! props-menu (set! props-menu
(new menu-item% (new menu-item%
(label "Show syntax properties") (label "Show syntax properties")
(parent this) (parent the-context-menu)
(callback (callback
(lambda (i e) (lambda (i e)
(send keymap call-function "show-syntax-properties" i e))))) (if (send config get-props-shown?)
(call-function "hide-syntax-properties" i e)
(call-function "show-syntax-properties" i e))))))
(void)) (void))
(define/public (after-selection-items) (define/public (after-selection-items)
(void)) (void))
(define/public (add-partition-items) (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 (for-each
(lambda (name func) (lambda (name func)
(let ([this-choice (let ([this-choice
@ -128,15 +147,10 @@
(void)) (void))
(define/public (add-separator) (define/public (add-separator)
(new separator-menu-item% (parent this))) (new separator-menu-item% (parent the-context-menu)))
(define/override (on-demand) ;; Initialize menu
(define stx (send controller get-selected-syntax))
(send copy-menu enable (and stx #t))
(send clear-menu enable (and stx #t))
(super on-demand))
;; Initialization
(add-edit-items) (add-edit-items)
(after-edit-items) (after-edit-items)
@ -147,4 +161,15 @@
(add-separator) (add-separator)
(add-partition-items) (add-partition-items)
(after-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 (require scheme/class
framework/framework framework/framework
"interfaces.ss" "interfaces.ss"
"../util/notify.ss"
"../util/misc.ss") "../util/misc.ss")
(provide syntax-prefs% (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:Width 700 number?)
(preferences:set-default 'SyntaxBrowser:Height 600 number?) (preferences:set-default 'SyntaxBrowser:Height 600 number?)
@ -18,14 +22,28 @@
(pref:get/set pref:height SyntaxBrowser:Height) (pref:get/set pref:height SyntaxBrowser:Height)
(pref:get/set pref:props-percentage SyntaxBrowser:PropertiesPanelPercentage) (pref:get/set pref:props-percentage SyntaxBrowser:PropertiesPanelPercentage)
(pref:get/set pref:props-shown? SyntaxBrowser:PropertiesPanelShown) (pref:get/set pref:props-shown? SyntaxBrowser:PropertiesPanelShown)
(pref:get/set pref:tabify framework:tabify) (pref:get/set pref:tabify framework:tabify)
(define syntax-prefs-mixin (define syntax-prefs-base%
(closure-mixin (syntax-prefs<%>) (class object%
(pref:width pref:width) (notify-methods width)
(pref:height pref:height) (notify-methods height)
(pref:props-percentage pref:props-percentage) (notify-methods props-percentage)
(pref:props-shown? pref:props-shown?))) (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])) [else #f]))
(define (pp-better-style-table) (define (pp-better-style-table)
(basic-style-list)
#; ;; Messes up formatting too much :(
(let* ([pref (pref:tabify)] (let* ([pref (pref:tabify)]
[table (car pref)] [table (car pref)]
[begin-rx (cadr pref)] [begin-rx (cadr pref)]

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

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

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

@ -6,26 +6,57 @@
mzlib/match mzlib/match
mzlib/list mzlib/list
mzlib/string mzlib/string
"../util/notify.ss"
"interfaces.ss" "interfaces.ss"
"display.ss" "display.ss"
"controller.ss" "controller.ss"
"keymap.ss"
"properties.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% ;; syntax-value-snip%
(define syntax-value-snip% (define syntax-value-snip%
(class* editor-snip% (readable-snip<%>) (class* editor-snip% (readable-snip<%>)
(init-field ((stx syntax))) (init-field ((stx syntax)))
(init-field host) (init-field (host (new dumb-host%)))
(inherit set-margin (inherit set-margin
set-inset) set-inset)
(define text (new text:standard-style-list%)) (define text (new text:standard-style-list%))
(super-new (editor text) (with-border? #f)) (super-new (editor text) (with-border? #f))
(set-margin 0 0 0 0) (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 begin-edit-sequence)
(send text change-style (make-object style-delta% 'change-alignment 'top)) (send text change-style (make-object style-delta% 'change-alignment 'top))
(define display (define display
@ -48,12 +79,18 @@
#'(p))) #'(p)))
)) ))
;; syntax-snip% (define top-aligned
#; (make-object style-delta% 'change-alignment 'top))
(define syntax-snip%
(class* editor-snip% (readable-snip<%>) (define-struct styled (contents style clickback))
(init-field ((stx syntax)))
(init-field primary-partition) ;; clicky-snip%
(define clicky-snip%
(class* editor-snip% ()
(init-field [open-style '(border)]
[closed-style '(tight-text-fit)])
(inherit set-margin (inherit set-margin
set-inset set-inset
set-snipclass set-snipclass
@ -61,76 +98,54 @@
show-border show-border
get-admin) get-admin)
(define properties-snip (new properties-snip%))
(define -outer (new text%)) (define -outer (new text%))
(super-new (editor -outer) (with-border? #f)) (super-new (editor -outer) (with-border? #f))
(set-margin 0 0 0 0) (set-margin 2 2 2 2)
(set-inset 0 0 0 0) (set-inset 2 2 2 2)
(set-snipclass snip-class) ;;(set-margin 3 0 0 0)
(send -outer select-all) ;;(set-inset 1 0 0 0)
;;(set-margin 0 0 0 0)
;;(set-inset 0 0 0 0)
(define the-syntax-snip (define/public (closed-contents) null)
(new syntax-value-snip% (define/public (open-contents) null)
(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 shown? #f) (define open? #f)
(define/public (refresh)
(if shown?
(refresh/shown)
(refresh/hidden)))
(define/private (refresh/hidden) (define/public (refresh-contents)
(send* -outer (send* -outer
(begin-edit-sequence) (begin-edit-sequence)
(lock #f) (lock #f)
(erase)) (erase))
(set-tight-text-fit #t) (do-style (if open? open-style closed-style))
(show-border #f) (outer:insert (if open? (hide-icon) (show-icon))
(outer:insert (show-icon) style:hyper style:hyper
(lambda _ (set! shown? #t) (refresh))) (if open?
(outer:insert the-summary) (lambda _
(send* -outer (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) (lock #t)
(end-edit-sequence))) (end-edit-sequence)))
(define/private (refresh/shown) (define/private (do-style style)
(send* -outer (show-border (memq 'border style))
(begin-edit-sequence) (set-tight-text-fit (memq 'tight-text-fit style)))
(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 outer:insert (define/private outer:insert
(case-lambda (case-lambda
[(obj) [(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) [(text style)
(outer:insert text style #f)] (outer:insert text style #f)]
[(text style clickback) [(text style clickback)
@ -141,78 +156,78 @@
(when clickback (when clickback
(send -outer set-clickback start end 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 ;; Snip methods
(define/override (copy) (define/override (copy)
(new syntax-snip% (syntax stx))) (new syntax-snip% (syntax stx)))
(define/override (write stream) (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) (define/public (read-special src line col pos)
(send the-syntax-snip read-special src line col pos)) (send the-syntax-snip read-special src line col pos))
(define/private (find-primary-partition) (send config listen-props-shown?
#;(define editor (send (get-admin) get-editor)) (lambda (?) (refresh-contents)))
(new-bound-partition))
(super-new)
(set-snipclass snip-class)))
;; syntax-properties-controller methods (define properties-container-snip%
(define properties-shown? #f) (class clicky-snip%
(define/public (props-shown?) (init controller)
properties-shown?)
(define/public (show ?)
(set! properties-shown? ?)
(refresh))
(define/public (set-syntax stx)
(send properties-snip set-syntax stx))
(refresh) (define properties-snip
(send -outer hide-caret #t) (new properties-snip% (controller controller)))
(send -outer lock #t)
))
;; independent-properties-controller% (define/override (open-contents)
#; (list #;(show-properties-icon)
(define independent-properties-controller% properties-snip))
(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 (closed-contents)
(list (show-properties-icon)))
(super-new (open-style '())
(closed-style '()))))
(define style:normal (make-object style-delta% 'change-normal)) (define style:normal (make-object style-delta% 'change-normal))
(define style:hyper (define style:hyper
@ -276,7 +291,6 @@
[else (string->symbol (format "unknown-object: ~s" obj))])) [else (string->symbol (format "unknown-object: ~s" obj))]))
;; COPIED AND MODIFIED from mrlib/syntax-browser.ss ;; COPIED AND MODIFIED from mrlib/syntax-browser.ss
#;
(define syntax-snipclass% (define syntax-snipclass%
(class snip-class% (class snip-class%
(define/override (read stream) (define/override (read stream)
@ -284,12 +298,12 @@
(unmarshall-syntax (read-from-string (send stream get-bytes))))) (unmarshall-syntax (read-from-string (send stream get-bytes)))))
(super-instantiate ()))) (super-instantiate ())))
#;(define snip-class (make-object syntax-snipclass%)) (define snip-class (make-object syntax-snipclass%))
#;(send snip-class set-version 2) (send snip-class set-version 2)
#;(send snip-class set-classname (send snip-class set-classname
(format "~s" '(lib "implementation.ss" "macro-debugger" "syntax-browser"))) (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) (define (unmarshall-syntax stx)
(match stx (match stx
[`(syntax [`(syntax

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

@ -2,9 +2,7 @@
#lang scheme/base #lang scheme/base
(require scheme/class) (require scheme/class)
(provide with-unlock (provide with-unlock
make-text-port make-text-port)
mpi->string
mpi->list)
;; with-unlock SYNTAX (expression) ;; with-unlock SYNTAX (expression)
;; (with-unlock text-expression . body) ;; (with-unlock text-expression . body)
@ -31,29 +29,3 @@
(lambda (special buffer? enable-break?) (lambda (special buffer? enable-break?)
(send text insert special (end-position)) (send text insert special (end-position))
#t))) #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" "properties.ss"
"text.ss" "text.ss"
"util.ss") "util.ss")
(provide widget% (provide widget%)
widget-keymap%
widget-context-menu%)
;; widget% ;; widget%
;; A syntax widget creates its own syntax-controller. ;; A syntax widget creates its own syntax-controller.
@ -27,7 +25,7 @@
(init parent) (init parent)
(init-field config) (init-field config)
(define controller (new controller%)) (field [controller (new controller%)])
(define -main-panel (define -main-panel
(new vertical-panel% (parent parent))) (new vertical-panel% (parent parent)))
@ -41,19 +39,15 @@
(new properties-view% (new properties-view%
(parent -props-panel) (parent -props-panel)
(controller controller))) (controller controller)))
(define props-percentage (send config pref:props-percentage))
(define/public (setup-keymap) (define/public (setup-keymap)
(new widget-keymap% (new syntax-keymap%
(editor -text) (editor -text)
(widget this))) (config config)))
(send -text set-styles-sticky #f) (send -text set-styles-sticky #f)
(send -text lock #t) (send -text lock #t)
(send -split-panel set-percentages
(list (- 1 props-percentage) props-percentage))
;; syntax-properties-controller<%> methods ;; syntax-properties-controller<%> methods
(define/public (props-shown?) (define/public (props-shown?)
@ -65,16 +59,25 @@
(define/public (show-props show?) (define/public (show-props show?)
(if show? (if show?
(unless (send -props-panel is-shown?) (unless (send -props-panel is-shown?)
(send -split-panel add-child -props-panel) (let ([p (send config get-props-percentage)])
(send -split-panel set-percentages (send -split-panel add-child -props-panel)
(list (- 1 props-percentage) props-percentage)) (update-props-percentage p))
(send -props-panel show #t)) (send -props-panel show #t))
(when (send -props-panel is-shown?) (when (send -props-panel is-shown?)
(set! props-percentage
(cadr (send -split-panel get-percentages)))
(send -split-panel delete-child -props-panel) (send -split-panel delete-child -props-panel)
(send -props-panel show #f)))) (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) (define/public (get-controller) controller)
@ -84,8 +87,9 @@
(define/public (get-main-panel) -main-panel) (define/public (get-main-panel) -main-panel)
(define/public (shutdown) (define/public (shutdown)
(unless (= props-percentage (send config pref:props-percentage)) (when (props-shown?)
(send config pref:props-percentage props-percentage))) (send config set-props-percentage
(cadr (send -split-panel get-percentages)))))
;; syntax-browser<%> Methods ;; syntax-browser<%> Methods
@ -99,7 +103,7 @@
(send -text insert text) (send -text insert text)
(let ([b (send -text last-position)]) (let ([b (send -text last-position)])
(send -text change-style error-text-style a b))))) (send -text change-style error-text-style a b)))))
(define/public (add-clickback text handler) (define/public (add-clickback text handler)
(with-unlock -text (with-unlock -text
(let ([a (send -text last-position)]) (let ([a (send -text last-position)])
@ -215,35 +219,6 @@
;; Specialized classes for widget ;; 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% (define browser-text%
(class (text:arrows-mixin (class (text:arrows-mixin
(text:tacking-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 (write (map serialize-context-frame
(continuation-mark-set->context (continuation-mark-set->context
(exn-continuation-marks exn))))) (exn-continuation-marks exn)))))
'replace)) #:exists 'replace))
(define (serialize-datum d) (define (serialize-datum d)
(cond [(number? d) `(quote ,d)] (cond [(number? d) `(quote ,d)]

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

@ -12,6 +12,7 @@
"warning.ss" "warning.ss"
"hiding-panel.ss" "hiding-panel.ss"
(prefix-in s: "../syntax-browser/widget.ss") (prefix-in s: "../syntax-browser/widget.ss")
(prefix-in s: "../syntax-browser/keymap.ss")
"../model/deriv.ss" "../model/deriv.ss"
"../model/deriv-util.ss" "../model/deriv-util.ss"
"../model/trace.ss" "../model/trace.ss"
@ -20,22 +21,24 @@
"cursor.ss" "cursor.ss"
"../util/notify.ss") "../util/notify.ss")
(provide stepper-keymap% (provide stepper-keymap%
stepper-context-menu%
stepper-syntax-widget%) stepper-syntax-widget%)
;; Extensions ;; Extensions
(define stepper-keymap% (define stepper-keymap%
(class s:widget-keymap% (class s:syntax-keymap%
(init-field macro-stepper) (init-field macro-stepper)
(inherit-field controller) (inherit-field config
(inherit add-function) controller
the-context-menu)
(inherit add-function
call-function)
(define show-macro #f)
(define hide-macro #f)
(super-new) (super-new)
(define/override (get-context-menu%)
stepper-context-menu%)
(define/public (get-hiding-panel) (define/public (get-hiding-panel)
(send macro-stepper get-macro-hiding-prefs)) (send macro-stepper get-macro-hiding-prefs))
@ -44,54 +47,50 @@
(send* (get-hiding-panel) (send* (get-hiding-panel)
(add-show-identifier) (add-show-identifier)
(refresh)))) (refresh))))
(add-function "hiding:hide-macro" (add-function "hiding:hide-macro"
(lambda (i e) (lambda (i e)
(send* (get-hiding-panel) (send* (get-hiding-panel)
(add-hide-identifier) (add-hide-identifier)
(refresh)))))) (refresh))))
;; Menu
(define stepper-context-menu%
(class s:widget-context-menu%
(inherit-field keymap)
(inherit add-separator) (inherit add-separator)
(field [show-macro #f]
[hide-macro #f])
(define/override (after-selection-items) (define/override (after-selection-items)
(super after-selection-items) (super after-selection-items)
(add-separator) (add-separator)
(set! show-macro (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) (callback (lambda (i e)
(send keymap call-function "hiding:show-macro" i e))))) (call-function "hiding:show-macro" i e)))))
(set! hide-macro (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) (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)) (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% (define stepper-syntax-widget%
(class s:widget% (class s:widget%
(init-field macro-stepper) (init-field macro-stepper)
(inherit get-text) (inherit get-text)
(inherit-field controller)
(define/override (setup-keymap) (define/override (setup-keymap)
(new stepper-keymap% (new stepper-keymap%
(editor (get-text)) (editor (get-text))
(widget this) (config (send macro-stepper get-config))
(controller controller)
(macro-stepper macro-stepper))) (macro-stepper macro-stepper)))
(define/override (show-props show?) (define/override (show-props show?)
@ -99,13 +98,4 @@
(send macro-stepper update/preserve-view)) (send macro-stepper update/preserve-view))
(super-new (super-new
(config (new config-adapter% (config (send macro-stepper get-config)))))
(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)))

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

@ -92,8 +92,10 @@
(new (get-macro-stepper-widget%) (new (get-macro-stepper-widget%)
(parent (get-area-container)) (parent (get-area-container))
(config config))) (config config)))
(define controller (send widget get-controller))
(define/public (get-widget) widget) (define/public (get-widget) widget)
(define/public (get-controller) controller)
(define/public (add-obsoleted-warning) (define/public (add-obsoleted-warning)
(unless obsoleted? (unless obsoleted?
@ -116,7 +118,6 @@
"Show syntax properties" "Show syntax properties"
(get-field show-syntax-properties? config)) (get-field show-syntax-properties? config))
;; FIXME: rewrite with notify-box
(let ([id-menu (let ([id-menu
(new (get-menu%) (new (get-menu%)
(label "Identifier=?") (label "Identifier=?")
@ -128,24 +129,24 @@
(parent id-menu) (parent id-menu)
(callback (callback
(lambda _ (lambda _
(send (send widget get-controller) (send controller set-identifier=? p))))])
set-identifier=? p))))]) (send controller listen-identifier=?
(send (send widget get-controller)
listen-identifier=?
(lambda (name+func) (lambda (name+func)
(send this-choice check (send this-choice check
(eq? (car name+func) (car p))))))) (eq? (car name+func) (car p)))))))
(sb:identifier=-choices))) (sb:identifier=-choices)))
(let ([identifier=? (send config get-identifier=?)]) (let ([identifier=? (send config get-identifier=?)])
(when identifier=? (when identifier=?
(let ([p (assoc identifier=? (sb:identifier=-choices))]) (let ([p (assoc identifier=? (sb:identifier=-choices))])
(send (send widget get-controller) set-identifier=? p)))) (send controller set-identifier=? p))))
(new (get-menu-item%) (new (get-menu-item%)
(label "Clear selection") (label "Clear selection")
(parent stepper-menu) (parent stepper-menu)
(callback (callback
(lambda _ (send (send widget get-controller) select-syntax #f)))) (lambda _ (send controller set-selected-syntax #f))))
(new separator-menu-item% (parent stepper-menu)) (new separator-menu-item% (parent stepper-menu))
(menu-option/notify-box 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/gui
scheme/list scheme/list
syntax/boundmap syntax/boundmap
"../model/synth-engine.ss" "../model/hiding-policies.ss"
"../syntax-browser/util.ss" "../util/mpi.ss"
"../util/notify.ss" "../util/notify.ss")
"../util/hiding.ss")
(provide macro-hiding-prefs-widget%) (provide macro-hiding-prefs-widget%)
(define mode:disable "Disable") (define mode:disable "Disable")
(define mode:standard "Standard") (define mode:standard "Standard")
(define mode:custom "Custom ...") (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% ;; macro-hiding-prefs-widget%
(define macro-hiding-prefs-widget% (define macro-hiding-prefs-widget%
(class object% (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:Width 700 number?)
(preferences:set-default 'MacroStepper:Frame:Height 600 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:PropertiesPanelPercentage 1/3 number?)
(preferences:set-default 'MacroStepper:MacroHidingMode "Standard" string?) (preferences:set-default 'MacroStepper:MacroHidingMode "Standard" string?)
(preferences:set-default 'MacroStepper:ShowSyntaxProperties? #f boolean?) (preferences:set-default 'MacroStepper:ShowSyntaxProperties? #f boolean?)
@ -26,6 +27,7 @@
(pref:get/set pref:width MacroStepper:Frame:Width) (pref:get/set pref:width MacroStepper:Frame:Width)
(pref:get/set pref:height MacroStepper:Frame:Height) (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:props-percentage MacroStepper:PropertiesPanelPercentage)
(pref:get/set pref:macro-hiding-mode MacroStepper:MacroHidingMode) (pref:get/set pref:macro-hiding-mode MacroStepper:MacroHidingMode)
(pref:get/set pref:show-syntax-properties? MacroStepper:ShowSyntaxProperties?) (pref:get/set pref:show-syntax-properties? MacroStepper:ShowSyntaxProperties?)
@ -44,8 +46,9 @@
(class object% (class object%
(notify-methods width) (notify-methods width)
(notify-methods height) (notify-methods height)
(notify-methods macro-hiding-mode) (notify-methods props-shown?)
(notify-methods props-percentage) (notify-methods props-percentage)
(notify-methods macro-hiding-mode)
(notify-methods show-syntax-properties?) (notify-methods show-syntax-properties?)
(notify-methods show-hiding-panel?) (notify-methods show-hiding-panel?)
(notify-methods identifier=?) (notify-methods identifier=?)
@ -63,8 +66,9 @@
(class macro-stepper-config-base% (class macro-stepper-config-base%
(connect-to-pref width pref:width) (connect-to-pref width pref:width)
(connect-to-pref height pref:height) (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 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-syntax-properties? pref:show-syntax-properties?)
(connect-to-pref show-hiding-panel? pref:show-hiding-panel?) (connect-to-pref show-hiding-panel? pref:show-hiding-panel?)
(connect-to-pref identifier=? pref:identifier=?) (connect-to-pref identifier=? pref:identifier=?)

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

@ -173,7 +173,7 @@
synth-warnings)))) synth-warnings))))
(force-letrec-transformation (force-letrec-transformation
force-letrec?)) force-letrec?))
(hide/policy deriv show-macro?)) (hide*/policy deriv show-macro?))
(values deriv (wderiv-e2 deriv)))) (values deriv (wderiv-e2 deriv))))
(set! synth-deriv synth-deriv*) (set! synth-deriv synth-deriv*)
(set! synth-estx estx*))))))) (set! synth-estx estx*)))))))
@ -390,7 +390,7 @@
(define/public (add-syntax stx binders definites) (define/public (add-syntax stx binders definites)
(send sbview add-syntax stx (send sbview add-syntax stx
'#:alpha-table binders '#:alpha-table binders
'#:definites definites)) '#:definites (or definites null)))
(define/private (add-final stx error binders definites) (define/private (add-final stx error binders definites)
(when stx (when stx
@ -483,9 +483,10 @@
(send sbview add-error-text (exn-message (misstep-exn step))) (send sbview add-error-text (exn-message (misstep-exn step)))
(send sbview add-text "\n") (send sbview add-text "\n")
(when (exn:fail:syntax? (misstep-exn step)) (when (exn:fail:syntax? (misstep-exn step))
(for-each (lambda (e) (send sbview add-syntax e (for-each (lambda (e)
'#:alpha-table binders (send sbview add-syntax e
'#:definites (protostep-definites step))) '#:alpha-table binders
'#:definites (or (protostep-definites step) null)))
(exn:fail:syntax-exprs (misstep-exn step)))) (exn:fail:syntax-exprs (misstep-exn step))))
(show-lctx step binders)) (show-lctx step binders))
@ -493,7 +494,7 @@
;; insert-syntax/color : syntax syntaxes identifiers syntaxes string -> void ;; insert-syntax/color : syntax syntaxes identifiers syntaxes string -> void
(define/private (insert-syntax/color stx foci binders definites frontier hi-color) (define/private (insert-syntax/color stx foci binders definites frontier hi-color)
(send sbview add-syntax stx (send sbview add-syntax stx
'#:definites definites '#:definites (or definites null)
'#:alpha-table binders '#:alpha-table binders
'#:hi-color hi-color '#:hi-color hi-color
'#:hi-stxs (if (send config get-highlight-foci?) foci null) '#:hi-stxs (if (send config get-highlight-foci?) foci null)