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

Added the macro stepper

Browse Source 
svn: r3987

original commit: d91e2b45022c0c043578a5f08b152825db417c07
This commit is contained in:
Ryan Culpepper 2006-08-08 20:32:58 +00:00
commit 06aad5203a
29 changed files with 3924 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/macro-debugger/expand.ss Normal file
View File

@ -0,0 +1,8 @@
(module expand mzscheme
(require "view/gui.ss")
(provide expand/step)
(define (expand/step stx)
(go stx))
)

6
collects/macro-debugger/info.ss Normal file
View File

@ -0,0 +1,6 @@
(module info (lib "infotab.ss" "setup")
(define name "Macro Debugger")
(define tools '(["tool.ss"]))
(define tool-names '("Macro Stepper"))
(define doc.txt '"doc.txt"))

142
collects/macro-debugger/model/context.ss Normal file
View File

@ -0,0 +1,142 @@
(module context mzscheme
(require (lib "stx.ss" "syntax"))
(provide (struct ref (n))
(struct tail (n))
path-get
pathseg-get
path-replace
pathseg-replace
find-subterm-paths)
;; A Path is a (list-of PathSeg)
;; where the PathSegs are listed outermost to innermost
;; for example: (path-get #'((a b) (c d)) (list (make-ref 0) (make-ref 1))) = #'b, not #'c
;; A PathSeg is one of:
;; - (make-ref number)
;; - (make-tail number)
(define-struct pathseg () #f)
(define-struct (ref pathseg) (n) #f)
(define-struct (tail pathseg) (n) #f)
;; path:ref->splicing-tail : PathSeg -> ???
;; ????
(define (path:ref->splicing-tail path)
(unless (ref? path)
(raise-type-error 'path:ref->splicing-tail "ref path" path))
(make-tail (sub1 (ref-n path))))
;; path-get : syntax Path -> syntax
(define (path-get stx path)
(let loop ([stx stx] [path path])
(cond [(null? path) stx]
[(pair? path)
(loop (pathseg-get stx (car path)) (cdr path))]
[else
(error 'path-get "bad path: ~s" path)])))
;; pathseg-get : syntax PathSeg -> syntax
(define (pathseg-get stx path)
(cond [(ref? path) (pathseg-get/ref stx (ref-n path))]
[(tail? path) (pathseg-get/tail stx (tail-n path))]))
;; pathseg-get/ref : syntax number -> syntax
(define (pathseg-get/ref stx0 n0)
(let loop ([n n0] [stx stx0])
(unless (stx-pair? stx)
(error 'pathseg-get "ref path out of bounds for syntax: ~s, ~s"
n0
(syntax-object->datum stx0)))
(if (zero? n)
(stx-car stx)
(loop (sub1 n) (stx-cdr stx)))))
;; pathseg-get/tail : syntax number -> syntax
(define (pathseg-get/tail stx0 n0)
(let loop ([n n0] [stx stx0])
(unless (stx-pair? stx)
(error 'pathseg-get "tail path out of bounds for syntax: ~s, ~s" n0 stx0))
(if (zero? n)
(stx-cdr stx)
(loop (sub1 n) (stx-cdr stx)))))
;; path-replace : syntax Path syntax -> syntax
(define (path-replace stx path x)
(cond [(null? path) x]
[(pair? path)
(let ([pathseg0 (car path)])
(pathseg-replace stx
pathseg0
(path-replace (pathseg-get stx pathseg0)
(cdr path)
x)))]
[else
(error 'path-replace "bad path: ~s" path)]))
;; pathseg-replace : syntax PathSeg syntax -> syntax
(define (pathseg-replace stx pathseg x)
(cond [(ref? pathseg) (pathseg-replace/ref stx (ref-n pathseg) x)]
[(tail? pathseg) (pathseg-replace/tail stx (tail-n pathseg) x)]
[else (error 'pathseg-replace "bad path: ~s" pathseg)]))
;; pathseg-replace/ref : syntax number syntax -> syntax
(define (pathseg-replace/ref stx0 n0 x)
(let loop ([n n0] [stx stx0])
(unless (stx-pair? stx)
(error 'pathseg-replace "ref path out of bounds for syntax: ~s, ~s" n0 stx0))
(if (zero? n)
(stx-replcar stx x)
(stx-replcdr stx (loop (sub1 n) (stx-cdr stx))))))
;; pathseg-replace/tail : syntax number syntax -> syntax
(define (pathseg-replace/tail stx0 n0 x)
(let loop ([n n0] [stx stx0])
(unless (stx-pair? stx)
(error 'pathseg-replace "tail path out of bounds for syntax: ~s, ~s" n0 stx0))
(if (zero? n)
(stx-replcdr stx x)
(stx-replcdr stx (loop (sub1 n) (stx-cdr stx))))))
;; stx-replcar : syntax syntax -> syntax
(define (stx-replcar stx x)
(cond [(pair? stx)
(cons x (cdr stx))]
[(syntax? stx)
(datum->syntax-object stx (cons x (stx-cdr stx)))]
[else (raise-type-error 'stx-replcar "stx-pair" stx)]))
;; stx-replcdr : syntax syntax -> syntax
(define (stx-replcdr stx x)
(cond [(pair? stx)
(cons (car stx) x)]
[(and (syntax? stx) (pair? (syntax-e stx)))
(datum->syntax-object stx (cons (stx-car stx) x))]
[else (raise-type-error 'stx-replcdr "stx-pair" stx)]))
(define (sd x)
(syntax-object->datum (datum->syntax-object #f x)))
;;=======
;; find-subterm-paths : syntax syntax -> (list-of Path)
(define (find-subterm-paths subterm term)
(let outer-loop ([term term])
(cond [(eq? subterm term)
(list null)]
[(stx-pair? term)
;; Optimized for lists...
(let loop ([term term] [n 0])
(if (stx-pair? term)
(let* ([seg0 (make-ref n)])
(append (map (lambda (p) (cons seg0 p)) (outer-loop (stx-car term)))
(if (eq? subterm (stx-cdr term))
(list (list (make-tail n)))
(loop (stx-cdr term) (add1 n)))))
(let ([seg0 (make-tail n)])
(map (lambda (p) (cons seg0 p))
(outer-loop term)))))]
;; FIXME: more structured cases here: box, vector, ...
[else null])))
)

160
collects/macro-debugger/model/deriv-c.ss Normal file
View File

@ -0,0 +1,160 @@
(module deriv-c mzscheme
(provide (all-defined))
;; A Derivation is either
;; - a PRule
;; - (make-mrule syntax syntax Transformation Derivation)
;; - (make-lift-deriv syntax syntax Derivation syntax Derivation)
(define-struct deriv (e1 e2) #f)
(define-struct (mrule deriv) (transformation next) #f)
(define-struct (lift-deriv deriv) (first lift-stx second) #f)
;; A Transformation is
;; (make-transformation syntax syntax (listof identifier) syntax syntax (listof LocalAction))
;; - resolves is the list of identifiers resolved by the macro keyword
;; - me1 is the marked version of the input syntax
;; - me2 is the marked version of the output syntax
(define-struct transformation (e1 e2 resolves me1 me2 locals) #f)
;; A LocalAction is one of
;; - (make-local-expansion Syntax Syntax Syntax Syntax Derivation)
;; - (make-local-lift Syntax Identifier)
(define-struct local-expansion (e1 e2 me1 me2 deriv) #f)
(define-struct local-lift (expr id) #f)
(define-struct local-lift-end (decl) #f)
;; A PRule is one of ...
(define-struct (prule deriv) (resolves) #f)
;; Lexical or Mapped Variable
(define-struct (p:variable prule) () #f)
;; Definitions: one subterm each
(define-struct (p:define-syntaxes prule) (rhs) #f)
(define-struct (p:define-values prule) (rhs) #f)
;; Simple expressions
(define-struct (p:if prule) (full? test then else) #f)
(define-struct (p:wcm prule) (key mark body) #f)
(define-struct (p:set! prule) (id-resolves rhs) #f)
(define-struct (p:set!-macro prule) (deriv) #f)
;; Sequence-containing expressions
(define-struct (p:begin prule) (lderiv) #f)
(define-struct (p:begin0 prule) (first lderiv) #f)
(define-struct (p:#%app prule) (tagged-stx lderiv) #f)
;; Binding expressions
(define-struct (p:lambda prule) (renames body) #f)
(define-struct (p:case-lambda prule) (renames+bodies) #f)
(define-struct (p:let-values prule) (renames rhss body) #f)
(define-struct (p:let*-values prule) (inner) #f)
(define-struct (p:letrec-values prule) (renames rhss body) #f)
(define-struct (p:letrec-syntaxes+values prule) (srenames srhss vrenames vrhss body) #f)
;; Atomic primitives: no subterms
(define-struct (p::STOP prule) () #f)
(define-struct (p:#%datum p::STOP) (tagged-stx) #f)
(define-struct (p:#%top p::STOP) (tagged-stx) #f)
(define-struct (p:quote p::STOP) () #f)
(define-struct (p:quote-syntax p::STOP) () #f)
(define-struct (p:require p::STOP) () #f)
(define-struct (p:require-for-syntax p::STOP) () #f)
(define-struct (p:require-for-template p::STOP) () #f)
(define-struct (p:provide p::STOP) () #f)
;; for stop expander
(define-struct (p:stop p::STOP) () #f)
;; for early primitive errors
(define-struct (p:unknown p::STOP) () #f)
;; Module stuff.... hairy
(define-struct (p:module prule) (body) #f)
(define-struct (p:#%module-begin prule) (pass1 pass2) #f)
;; where pass1 is a ModPass1
;; and pass2 is a ModPass2
;; Artificial Rename
;; FIXME: Go back and add more info later, such as rename-identity
(define-struct (p:rename prule) (renames inner) #f)
;; Synthetic primitive
(define-struct (p:synth prule) (subterms) #f)
;; where subterms is list-of-Subterm
;; A Subterm is one of
;; - (make-s:subterm Path Derivation)
(define-struct s:subterm (path deriv) #f)
;; A ListDerivation is (make-lderiv Syntaxes Syntaxes (listof Derivation))
(define-struct lderiv (es1 es2 derivs) #f)
;; A BlockDerivation is (make-bderiv syntax-list syntax-list BlockPass1 Transition LDeriv)
;; where Transition = (union 'letrec 'list)
(define-struct bderiv (es1 es2 pass1 trans pass2) #f)
;; A BlockPass1 is list-of-BRule
;; A BRule is one of
;; - (make-b:defvals BlockRename Derivation/#f)
;; - (make-b:devstx BlockRename Derivation Derivation)
;; - (make-b:splice BlockRename Derivation Syntaxes)
;; - (make-b:expr BlockRename Derivation)
;; - (make-b:begin BlockRename Derivation List-of-BRule)
;; This last only used in macro-hiding
;; A BlockRename is (cons syntax syntax)
;; It always applies only to the current block element
(define-struct brule (renames))
(define-struct (b:defvals brule) (head) #f)
(define-struct (b:defstx brule) (deriv rhs) #f)
(define-struct (b:splice brule) (head tail) #f)
(define-struct (b:expr brule) (head) #f)
(define-struct (b:begin brule) (head inner) #f)
;; A ModPass1 is a list of ModRule1
;; A ModRule1 is one of
;; - (make-mod:prim Derivation ModPrim)
;; - (make-mod:splice Derivation tail)
;; - (make-mod:lift Derivation tail)
;; - (make-mod:begin Derivation (list-of ModRule1))
;; A ModPrim is a PRule in:
;; - (make-p:define-values syntax syntax () #f)
;; - (make-p:define-syntaxes syntax syntax () Derivation)
;; - (make-p:require syntax syntax ())
;; - (make-p:require-for-syntax syntax syntax ())
;; - (make-p:require-for-template syntax syntax ())
;; - (make-p:provide syntax syntax ())
;; - #f
;; A ModPass2 is a list of ModRule2
;; A ModRule2 is one of
;; - (make-mod:skip)
;; - (make-mod:cons Derivation)
;; - (make-mod:lift Derivation syntaxes)
(define-struct modrule ())
(define-struct (mod:cons modrule) (head) #f)
(define-struct (mod:prim modrule) (head prim) #f)
(define-struct (mod:skip modrule) () #f)
(define-struct (mod:splice modrule) (head tail) #f)
(define-struct (mod:lift modrule) (head tail) #f)
(define-struct (mod:lift-end modrule) (tail) #f)
(define-struct (mod:begin modrule) (head inner) #f)
;; Handling Syntax Errors
;; ----------------------
;; An interrupted node is (make-interrupted-wrap symbol node)
;; where node is one of Derivation, ListDerivation, BlockDerivation,
;; PRule, MRule, BRule, or ModRule
(define-struct interrupted-wrap (tag inner) #f)
;; An error-wrapped node is (make-error-wrap exception symbol node)
;; where node is one of PRule, MRule, BRule, or ModRule
(define-struct error-wrap (exn tag inner) #f)
)

470
collects/macro-debugger/model/deriv-parser.ss Normal file
View File

@ -0,0 +1,470 @@
(module deriv-parser mzscheme
(require "yacc-ext.ss"
"yacc-interrupted.ss"
"deriv.ss"
"deriv-tokens.ss")
(provide parse-derivation)
(define (deriv-error ok? name value start end)
(if ok?
(error 'derivation-parser "error on token #~a: <~s, ~s>" start name value)
(error 'derivation-parser "bad token #~a" start)))
;; PARSER
(define parse-derivation
(parser
(options (start Expansion)
(src-pos)
(tokens basic-tokens prim-tokens renames-tokens)
(end EOF)
(error deriv-error)
#;(debug "debug-parser.txt"))
;; Required (non-hygienically) by productions/I
(productions
#;(Error [(syntax-error) $1])
(NoError [() #f]))
;; tokens
(skipped-token-values visit resolve next next-group return
enter-macro macro-pre-transform macro-post-transform exit-macro
enter-prim exit-prim
enter-block block->list block->letrec splice
enter-list exit-list
enter-check exit-check
local-post exit-local
phase-up module-body
renames-lambda
renames-case-lambda
renames-let
renames-letrec-syntaxes
renames-block
IMPOSSIBLE)
;; Entry point
(productions
(Expansion
[(EE/Lifts) $1]
[(EE/Lifts/Interrupted) $1]))
(productions/I
;; Expansion of an expression
;; EE Answer = Derivation (I)
(EE
(#:no-wrap)
[(visit (? PrimStep 'prim) return)
$2]
[(visit (? TaggedPrimStep 'prim) return)
($2 $1)]
[((? EE/Macro))
$1])
(EE/Macro
[(visit (? MacroStep 'macro) (? EE 'next))
(make-mrule $1 (and (deriv? $3) (deriv-e2 $3)) $2 $3)])
;; Expand/Lifts
;; Expand/Lifts Answer = Derivation (I)
(EE/Lifts
(#:no-wrap)
[((? EE)) $1]
[((? EE/Lifts+)) $1])
(EE/Lifts+
[(EE lift-loop (? EE/Lifts))
(let ([initial (deriv-e1 $1)]
[final (and (deriv? $3) (deriv-e2 $3))])
(make-lift-deriv initial final $1 $2 $3))])
;; Evaluation
(Eval
[() #f])
;; Expansion of an expression to primitive form
;; CheckImmediateMacro Answer = Derivation (I)
(CheckImmediateMacro
(#:no-wrap)
[(enter-check (? CheckImmediateMacro/Inner) exit-check)
($2 $1 $3 (lambda (ce1 ce2) (make-p:stop ce1 ce2 null)))])
(CheckImmediateMacro/Inner
(#:args e1 e2 k)
[()
(k e1 e2)]
[(visit (? MacroStep 'macro) return (? CheckImmediateMacro/Inner 'next))
(let ([next ($4 $3 e2 k)])
(make-mrule $1 (and (deriv? next) (deriv-e2 next)) $2 next))])
;; Expansion of multiple expressions, next-separated
;; NextEEs Answer = (listof Derivation)
(NextEEs
(#:no-wrap)
(#:skipped null)
[() null]
[(next (? EE 'first) (? NextEEs 'rest)) (cons $2 $3)])
;; Keyword resolution
;; Resolves Answer = (listof identifier)
(Resolves [() null]
[(resolve Resolves) (cons $1 $2)])
;; Single macro step (may contain local-expand calls)
;; MacroStep Answer = Transformation (I,E)
(MacroStep
[(Resolves enter-macro
macro-pre-transform (? LocalActions 'locals) (! 'transform) macro-post-transform
exit-macro)
(make-transformation $2 $7 $1 $3 $6 $4)])
;; Local actions taken by macro
;; LocalAction Answer = (list-of LocalAction)
(LocalActions
(#:no-wrap)
(#:skipped null)
[() null]
[((? LocalAction) (? LocalActions)) (cons $1 $2)])
(LocalAction
[(enter-local local-pre (? EE) local-post exit-local)
(make-local-expansion $1 $5 $2 $4 $3)]
[(lift)
(make-local-lift (car $1) (cdr $1))]
[(lift-statement)
(make-local-lift-end $1)])
;; Multiple calls to local-expand
;; EEs Answer = (listof Derivation)
(EEs
(#:skipped null)
(#:no-wrap)
[() null]
[((? EE 'first) (? EEs 'rest)) (cons $1 $2)])
;; Primitive syntax step
;; PrimStep Answer = PRule
(PrimStep
(#:no-wrap)
[(Resolves NoError enter-prim (? Prim) exit-prim)
($4 $3 $5 $1)]
[(Resolves variable)
(make-p:variable (car $2) (cdr $2) $1)])
;; Tagged Primitive syntax
;; TaggedPrimStep Answer = syntax -> PRule
(TaggedPrimStep
(#:no-wrap)
(#:args orig-stx)
[(Resolves ! IMPOSSIBLE)
(make-p:unknown orig-stx #f $1)]
[(Resolves NoError enter-prim (? TaggedPrim) exit-prim)
($4 orig-stx $5 $1 $3)])
;; Primitive
;; Prim Answer = syntax syntax (listof identifier) -> PRule
(Prim
(#:args e1 e2 rs)
(#:no-wrap)
[((? PrimModule)) ($1 e1 e2 rs)]
[((? Prim#%ModuleBegin)) ($1 e1 e2 rs)]
[((? PrimDefineSyntaxes)) ($1 e1 e2 rs)]
[((? PrimDefineValues)) ($1 e1 e2 rs)]
[((? PrimIf)) ($1 e1 e2 rs)]
[((? PrimWCM)) ($1 e1 e2 rs)]
[((? PrimSet)) ($1 e1 e2 rs)]
[((? PrimBegin)) ($1 e1 e2 rs)]
[((? PrimBegin0)) ($1 e1 e2 rs)]
[((? PrimLambda)) ($1 e1 e2 rs)]
[((? PrimCaseLambda)) ($1 e1 e2 rs)]
[((? PrimLetValues)) ($1 e1 e2 rs)]
[((? PrimLet*Values)) ($1 e1 e2 rs)]
[((? PrimLetrecValues)) ($1 e1 e2 rs)]
[((? PrimLetrecSyntaxes+Values)) ($1 e1 e2 rs)]
[((? PrimSTOP)) ($1 e1 e2 rs)]
[((? PrimQuote)) ($1 e1 e2 rs)]
[((? PrimQuoteSyntax)) ($1 e1 e2 rs)]
[((? PrimRequire)) ($1 e1 e2 rs)]
[((? PrimRequireForSyntax)) ($1 e1 e2 rs)]
[((? PrimRequireForTemplate)) ($1 e1 e2 rs)]
[((? PrimProvide)) ($1 e1 e2 rs)])
;; Tagged Primitive
;; TaggedPrim Answer = syntax syntax (list-of identifier) syntax -> PRule
(TaggedPrim
(#:args e1 e2 rs tagged-stx)
(#:no-wrap)
[((? Prim#%App)) ($1 e1 e2 rs tagged-stx)]
[((? Prim#%Datum)) ($1 e1 e2 rs tagged-stx)]
[((? Prim#%Top)) ($1 e1 e2 rs tagged-stx)])
;; Modules
(PrimModule
(#:args e1 e2 rs)
[(prim-module ! (? EE 'body))
(make-p:module e1 e2 rs $3)]
;; One form after language ... macro that expands into #%module-begin
[(prim-module NoError next
enter-check (? CheckImmediateMacro/Inner) exit-check
(! 'module-begin) next (? EE))
(make-p:module e1 e2 rs
($5 $4
(and (deriv? $9) (deriv-e2 $9))
(lambda (ce1 ce2) $9)))])
(Prim#%ModuleBegin
(#:args e1 e2 rs)
[(prim-#%module-begin ! (? ModulePass1 'pass1) next-group (? ModulePass2 'pass2))
(make-p:#%module-begin e1 e2 rs $3 $5)])
(ModulePass1
(#:skipped null)
(#:no-wrap)
[() null]
[(next (? ModulePass1-Part) (? ModulePass1))
(cons $2 $3)]
[(lift-end-loop (? ModulePass1))
(cons (make-mod:lift-end $1) $2)])
(ModulePass1-Part
[((? EE) (? ModulePass1/Prim))
(make-mod:prim $1 $2)]
[(EE splice)
(make-mod:splice $1 $2)]
[(EE lift-loop)
(make-mod:lift $1 $2)])
(ModulePass1/Prim
[(enter-prim prim-define-values ! exit-prim)
(make-p:define-values $1 $4 null #f)]
[(enter-prim prim-define-syntaxes ! phase-up (? EE) exit-prim)
(make-p:define-syntaxes $1 $6 null $5)]
[(enter-prim prim-require ! exit-prim)
(make-p:require $1 $4 null)]
[(enter-prim prim-require-for-syntax ! exit-prim)
(make-p:require-for-syntax $1 $4 null)]
[(enter-prim prim-require-for-template ! exit-prim)
(make-p:require-for-template $1 $4 null)]
[(enter-prim prim-provide ! exit-prim)
(make-p:provide $1 $4 null)]
[()
#f])
(ModulePass2
(#:skipped null)
(#:no-wrap)
[() null]
[(next (? ModulePass2-Part) (? ModulePass2))
(cons $2 $3)]
[(lift-end-loop (? ModulePass2))
(cons (make-mod:lift-end $1) $2)])
(ModulePass2-Part
;; not normal; already handled
[()
(make-mod:skip)]
;; normal: expand completely
[((? EE))
(make-mod:cons $1)]
;; catch lifts
[(EE lift-loop)
(make-mod:lift $1 $2)])
;; Definitions
(PrimDefineSyntaxes
(#:args e1 e2 rs)
[(prim-define-syntaxes ! (? EE/Lifts))
(make-p:define-syntaxes e1 e2 rs $3)])
(PrimDefineValues
(#:args e1 e2 rs)
[(prim-define-values ! (? EE))
(make-p:define-values e1 e2 rs $3)])
;; Simple expressions
(PrimIf
(#:args e1 e2 rs)
[(prim-if ! (? EE 'test) next (? EE 'then) next (? EE 'else))
(make-p:if e1 e2 rs #t $3 $5 $7)]
[(prim-if NoError next-group (? EE 'test) next (? EE 'then))
(make-p:if e1 e2 rs #f $4 $6 #f)])
(PrimWCM
(#:args e1 e2 rs)
[(prim-wcm ! (? EE 'key) next (? EE 'mark) next (? EE 'body))
(make-p:wcm e1 e2 rs $3 $5 $7)])
;; Sequence-containing expressions
(PrimBegin
(#:args e1 e2 rs)
[(prim-begin ! (? EL))
(make-p:begin e1 e2 rs $3)])
(PrimBegin0
(#:args e1 e2 rs)
[(prim-begin0 ! next (? EE) next (? EL))
(make-p:begin0 e1 e2 rs $4 $6)])
(Prim#%App
(#:args e1 e2 rs tagged-stx)
[(prim-#%app !)
(make-p:#%app e1 e2 rs tagged-stx (make-lderiv null null null))]
[(prim-#%app NoError (? EL))
(make-p:#%app e1 e2 rs tagged-stx $3)])
;; Binding expressions
(PrimLambda
(#:args e1 e2 rs)
[(prim-lambda ! renames-lambda (? EB))
(make-p:lambda e1 e2 rs $3 $4)])
(PrimCaseLambda
(#:args e1 e2 rs)
[(prim-case-lambda ! (? NextCaseLambdaClauses))
(make-p:case-lambda e1 e2 rs $3)])
(NextCaseLambdaClauses
(#:skipped null)
[(next ! renames-case-lambda (? EB 'first) (? NextCaseLambdaClauses 'rest))
(cons (cons $3 $4) $5)]
[() null])
(PrimLetValues
(#:args e1 e2 rs)
[(prim-let-values ! renames-let (? NextEEs 'rhss) next-group (? EB 'body))
(make-p:let-values e1 e2 rs $3 $4 $6)])
(PrimLet*Values
(#:args e1 e2 rs)
;; let*-values with bindings is "macro-like"
[(prim-let*-values ! (? EE))
(make-p:let*-values e1 e2 rs $3)]
;; No bindings... model as "let"
[(prim-let*-values NoError renames-let (? NextEEs 'rhss) next-group (? EB 'body))
(make-p:let-values e1 e2 rs $3 $4 $6)])
(PrimLetrecValues
(#:args e1 e2 rs)
[(prim-letrec-values ! renames-let (? NextEEs 'rhss) next-group (? EB 'body))
(make-p:letrec-values e1 e2 rs $3 $4 $6)])
;; Might have to deal with let*-values
(PrimLetrecSyntaxes+Values
(#:args e1 e2 rs)
[(prim-letrec-syntaxes+values (! 'bad-syntax) renames-letrec-syntaxes
(? NextBindSyntaxess 'srhss) next-group (? EB 'body))
(make-p:letrec-syntaxes+values e1 e2 rs $3 $4 #f null $6)]
[(prim-letrec-syntaxes+values NoError renames-letrec-syntaxes
NextBindSyntaxess next-group
prim-letrec-values (! 'impossible?)
renames-let (? NextEEs 'vrhss) next-group (? EB 'body))
(make-p:letrec-syntaxes+values e1 e2 rs $3 $4 $8 $9 $11)])
;; Atomic expressions
(Prim#%Datum
(#:args e1 e2 rs tagged-stx)
[(prim-#%datum !) (make-p:#%datum e1 e2 rs tagged-stx)])
(Prim#%Top
(#:args e1 e2 rs tagged-stx)
[(prim-#%top !) (make-p:#%top e1 e2 rs tagged-stx)])
(PrimSTOP
(#:args e1 e2 rs)
[(prim-stop !) (make-p:stop e1 e2 rs)])
(PrimQuote
(#:args e1 e2 rs)
[(prim-quote !) (make-p:quote e1 e2 rs)])
(PrimQuoteSyntax
(#:args e1 e2 rs)
[(prim-quote-syntax !) (make-p:quote-syntax e1 e2 rs)])
(PrimRequire
(#:args e1 e2 rs)
[(prim-require !) (make-p:require e1 e2 rs)])
(PrimRequireForSyntax
(#:args e1 e2 rs)
[(prim-require-for-syntax !) (make-p:require-for-syntax e1 e2 rs)])
(PrimRequireForTemplate
(#:args e1 e2 rs)
[(prim-require-for-template !) (make-p:require-for-template e1 e2 rs)])
(PrimProvide
(#:args e1 e2 rs)
[(prim-provide !) (make-p:provide e1 e2 rs)])
(PrimSet
(#:args e1 e2 rs)
[(prim-set! ! Resolves next (? EE))
(make-p:set! e1 e2 rs $3 $5)]
[(prim-set! NoError (? MacroStep 'macro) (? EE 'continue))
(make-p:set!-macro e1 e2 rs (make-mrule e1 (and (deriv? $4) (deriv-e2 $4)) $3 $4))])
;; Blocks
;; EB Answer = BlockDerivation
(EB
[(enter-block (? BlockPass1 'pass1) block->list (? EL 'pass2))
(make-bderiv $1
(and (lderiv? $4) (lderiv-es2 $4))
$2
'list
$4)]
[(enter-block BlockPass1 block->letrec (? EL 'pass2))
(make-bderiv $1
(and (lderiv? $4) (lderiv-es2 $4))
$2
'letrec
$4)])
;; BlockPass1 Answer = (list-of BRule)
(BlockPass1
(#:no-wrap)
(#:skipped null)
[() null]
[((? BRule) (? BlockPass1))
(cons $1 $2)])
;; BRule Answer = BRule
(BRule
[(next ! IMPOSSIBLE)
#f]
[(next NoError renames-block (? CheckImmediateMacro 'check))
(make-b:expr $3 $4)]
[(next NoError renames-block CheckImmediateMacro prim-begin ! splice !)
(make-b:splice $3 $4 $7)]
[(next NoError renames-block CheckImmediateMacro prim-define-values !)
(make-b:defvals $3 $4)]
[(next NoError renames-block CheckImmediateMacro
prim-define-syntaxes (? BindSyntaxes 'bind))
(make-b:defstx $3 $4 $5)])
;; BindSyntaxes Answer = Derivation
(BindSyntaxes
[(phase-up (? EE/Lifts) Eval) $2])
;; NextBindSyntaxess Answer = (list-of Derivation)
(NextBindSyntaxess
(#:skipped null)
[() null]
[(next (? BindSyntaxes 'first) (? NextBindSyntaxess 'rest)) (cons $2 $3)])
;; Lists
;; EL Answer = ListDerivation
(EL
(#:skipped #f)
[(enter-list ! (? EL*) exit-list) (make-lderiv $1 $4 $3)])
;; EL* Answer = (listof Derivation)
(EL*
(#:no-wrap)
(#:skipped null)
[() null]
[(next (? EE 'first) (? EL* 'rest)) (cons $2 $3)])
)))
)

143
collects/macro-debugger/model/deriv-tokens.ss Normal file
View File

@ -0,0 +1,143 @@
(module deriv-tokens mzscheme
(require (lib "lex.ss" "parser-tools")
"deriv.ss")
(provide (all-defined))
(define-tokens basic-tokens
(visit ; syntax
resolve ; identifier
next ; .
next-group ; .
enter-macro ; syntax
macro-pre-transform ; syntax
macro-post-transform ; syntax
exit-macro ; syntax
enter-prim ; syntax
exit-prim ; syntax
return ; syntax
enter-block ; syntaxes
block->list ; syntaxes
block->letrec ; syntax(es?)
splice ; syntaxes
enter-list ; syntaxes
exit-list ; syntaxes
enter-check ; syntax
exit-check ; syntax
phase-up ; .
module-body ; (list-of (cons syntax boolean))
... ; .
EOF ; .
syntax-error ; exn
lift-loop ; syntax
lift-end-loop ; syntax
lift ; (cons syntax id)
lift-statement ; syntax
enter-local ; syntax
local-pre ; syntax
local-post ; syntax
exit-local ; syntax
IMPOSSIBLE ; useful for error-handling clauses that have no NoError counterpart
))
(define-tokens renames-tokens
(renames-lambda ; (cons syntax syntax)
renames-case-lambda ; (cons syntax syntax)
renames-let ; (cons (listof syntax) syntax)
renames-letrec-syntaxes ; (cons (listof syntax) (cons (listof syntax) syntax))
renames-block ; (cons syntax syntax) ... different, contains both pre+post
))
(define-tokens prim-tokens
(prim-module prim-#%module-begin
prim-define-syntaxes prim-define-values
prim-if prim-wcm prim-begin prim-begin0 prim-#%app prim-lambda
prim-case-lambda prim-let-values prim-let*-values prim-letrec-values
prim-letrec-syntaxes+values prim-#%datum prim-#%top prim-stop
prim-quote prim-quote-syntax prim-require prim-require-for-syntax
prim-require-for-template prim-provide
prim-set!
variable ; (cons identifier identifier)
))
;; ** Signals to tokens
(define signal-mapping
`((EOF . EOF)
(error . ,token-syntax-error)
(0 . ,token-visit)
(1 . ,token-resolve)
(2 . ,token-return)
(3 . ,token-next)
(4 . ,token-enter-list)
(5 . ,token-exit-list)
(6 . ,token-enter-prim)
(7 . ,token-exit-prim)
(8 . ,token-enter-macro)
(9 . ,token-exit-macro)
(10 . ,token-enter-block)
(11 . ,token-splice)
(12 . ,token-block->list)
(13 . ,token-next-group)
(14 . ,token-block->letrec)
#;(15 . renamer)
(16 . ,token-renames-let)
(17 . ,token-renames-lambda)
(18 . ,token-renames-case-lambda)
(19 . ,token-renames-letrec-syntaxes)
(20 . phase-up)
(21 . ,token-macro-pre-transform)
(22 . ,token-macro-post-transform)
(23 . ,token-module-body)
(24 . ,token-renames-block)
(100 . prim-stop)
(101 . prim-module)
(102 . prim-#%module-begin)
(103 . prim-define-syntaxes)
(104 . prim-define-values)
(105 . prim-if)
(106 . prim-wcm)
(107 . prim-begin)
(108 . prim-begin0)
(109 . prim-#%app)
(110 . prim-lambda)
(111 . prim-case-lambda)
(112 . prim-let-values)
(113 . prim-letrec-values)
(114 . prim-letrec-syntaxes+values)
(115 . prim-#%datum)
(116 . prim-#%top)
(117 . prim-quote)
(118 . prim-quote-syntax)
(119 . prim-require)
(120 . prim-require-for-syntax)
(121 . prim-require-for-template)
(122 . prim-provide)
(123 . prim-set!)
(124 . prim-let*-values)
(125 . ,token-variable)
(126 . ,token-enter-check)
(127 . ,token-exit-check)
(128 . ,token-lift-loop)
(129 . ,token-lift)
(130 . ,token-enter-local)
(131 . ,token-exit-local)
(132 . ,token-local-pre)
(133 . ,token-local-post)
(134 . ,token-lift-statement)
(135 . ,token-lift-end-loop)
))
(define (tokenize sig-n val pos)
(let ([p (assv sig-n signal-mapping)])
(if (pair? p)
(make-position-token
(cond [(procedure? (cdr p)) ((cdr p) val)]
[(symbol? (cdr p)) (cdr p)])
pos
pos)
(error 'tokenize "bad signal: ~s" sig-n))))
)

165
collects/macro-debugger/model/deriv-util.ss Normal file
View File

@ -0,0 +1,165 @@
(module deriv-util mzscheme
(require "deriv.ss"
(lib "plt-match.ss"))
(provide IntW
ErrW
AnyQ
IntQ
$$
$$I
$$E
Wrap
lift/wrap
rewrap
rewrap/nt
outer-rewrap
lift/deriv-e1
lift/deriv-e2
wrapped?)
;; IntW
;; Matches only interrupted wraps
(define-match-expander IntW
(syntax-rules ()
[(IntW S (var ...))
(struct interrupted-wrap (_ (struct S (var ...))))]
[(IntW S (var ...) tag)
(struct interrupted-wrap (tag (struct S (var ...))))]))
;; ErrW
;; Matches only error wraps
(define-match-expander ErrW
(syntax-rules ()
[(ErrW S (var ...))
(struct error-wrap (_ _ (struct S (var ...))))]
[(ErrW S (var ...) exn)
(struct error-wrap (exn _ (struct S (var ...))))]
[(ErrW S (var ...) tag exn)
(struct error-wrap (exn tag (struct S (var ...))))]))
;; AnyQ matcher
;; Matches unwrapped, interrupted wrapped, or error wrapped
(define-match-expander AnyQ
(syntax-rules ()
[(AnyQ S (var ...))
(or (struct S (var ...))
(struct interrupted-wrap (_ (struct S (var ...))))
(struct error-wrap (_ _ (struct S (var ...)))))]
[(AnyQ S (var ...) exni)
(or (and (struct S (var ...))
(app (lambda (_) #f) exni))
(and (struct interrupted-wrap (tag (struct S (var ...))))
(app (lambda (ew) (cons #f (interrupted-wrap-tag ew))) exni))
(and (struct error-wrap (exn tag (struct S (var ...))))
(app (lambda (ew) (cons (error-wrap-exn ew) (error-wrap-tag ew))) exni)))]))
;; IntQ
;; Matches interrupted wraps and unwrapped structs
(define-match-expander IntQ
(syntax-rules ()
[(IntQ S (var ...))
(or (struct S (var ...))
(struct interrupted-wrap (_ (struct S (var ...)))))]
[(IntQ S (var ...) tag)
(or (and (struct S (var ...))
(app (lambda (_) #f) tag))
(struct interrupted-wrap (tag (struct S (var ...)))))]))
;; $$ match form
;; ($$ struct-name (var ...) info)
;; If normal instance of struct-name, binds info to #f
;; If interrupted-wrapped, binds info to (cons #f symbol/#f)
;; If error-wrapped, binds info to (cons exn symbol/#f)
(define-match-expander $$
(lambda (stx)
(syntax-case stx ()
[($$ S (var ...) info)
#'(or (and (struct S (var ...))
(app (lambda (_) #f) info))
(and (struct interrupted-wrap (tag (struct S (var ...))))
(app (lambda (ew) (cons #f (interrupted-wrap-tag ew))) info))
(and (struct error-wrap (exn tag (struct S (var ...))))
(app (lambda (ew) (cons (error-wrap-exn ew) (error-wrap-tag ew)))
info)))]
[($$ S (var ...))
#'(struct S (var ...))])))
(define-match-expander $$I
(lambda (stx)
(syntax-case stx ()
[($$I S (var ...))
#'(or (struct interrupted-wrap (tag (struct S (var ...))))
(struct S (var ...)))]
[($$I S (var ...) tag)
#'(or (struct interrupted-wrap (tag (struct S (var ...))))
(and (app (lambda (_) #f) tag)
(struct S (var ...))))])))
(define-match-expander $$E
(lambda (stx)
(syntax-case stx ()
[($$E S (var ...))
#'(or (struct interrupted-wrap (_tag (struct S (var ...))))
(struct error-wrap (_exn _tag (struct S (var ...))))
(struct S (var ...)))])))
(define-match-expander Wrap
(syntax-rules ()
[(Wrap x)
(or (struct interrupted-wrap (_tag x))
(struct error-wrap (_exn _tag x))
x)]))
;; lift/wrap : ('a -> 'b) boolean -> Wrap('a) -> Wrap('b)
(define (lift/wrap f preserve-tag?)
(lambda (x)
(match x
[(struct interrupted-wrap (tag inner))
(make-interrupted-wrap (and preserve-tag? tag) (f inner))]
[(struct error-wrap (exn tag inner))
(make-error-wrap exn (and preserve-tag? tag) (f inner))]
[x
(f x)])))
;; rewrap : Wrap('a) 'b -> Wrap('b)
(define (rewrap x y)
(if (wrapped? y)
y
((lift/wrap (lambda (x) y) #t) x)))
;; rewrap/nt : Wrap('a) 'b -> Wrap('b)
(define (rewrap/nt x y)
(if (wrapped? y)
y
((lift/wrap (lambda (x) y) #f) x)))
(define (outer-rewrap x y)
(if (and (wrapped? x) (not (wrapped? y)))
(make-interrupted-wrap #f y)
y))
(define (lift/deriv-e1 x)
(match x
[(AnyQ deriv (e1 _)) e1]))
(define (lift/deriv-e2 x)
(match x
[(AnyQ deriv (_ e2)) e2]))
(define (wrapped? x)
(or (interrupted-wrap? x)
(error-wrap? x)))
; (define-match-expander $$E
; (lambda (stx)
; (syntax-case stx (@)
; [($$E S (var ...))
; #'($$ S (var ...) _exni)]
; [($$E S (var ...) @ tag)
; #'($$ S (var ...) (cons #f tag))]
; [($$E S (var ...) @ tag exn)
; #'($$ S (var ...) (cons exn tag))])))
)

311
collects/macro-debugger/model/deriv.ss Normal file
View File

@ -0,0 +1,311 @@
(module deriv mzscheme
(require (lib "contract.ss")
(lib "stx.ss" "syntax")
"deriv-c.ss")
;; NO CONTRACTS
; (provide (all-from "deriv-c.ss"))
;; CONTRACTS
(define (stx-list-like? x)
(or (syntax? x)
(null? x)
(and (pair? x) (syntax? (car x)) (stx-list-like? (cdr x)))))
(define (maybe c) (or/c c false/c))
(define node/c (or/c deriv? lderiv? bderiv? transformation? brule? modrule?))
(define errnode/c (or/c prule? transformation? lderiv? brule? modrule?))
(define tag/c (maybe symbol?))
(define syntax/f (maybe syntax?))
(define syntaxes/c stx-list-like?)
(define syntaxes/f (maybe syntaxes/c))
(define (anyw C)
(or/c (struct/c error-wrap exn? tag/c C)
(struct/c interrupted-wrap tag/c C)))
(define (anyq C)
(or/c C (anyw C)))
(define (intw C)
(struct/c interrupted-wrap tag/c C))
(define (intq C)
(or/c C (intw C)))
(define resolves/c (listof identifier?))
(provide/contract
(struct deriv
([e1 syntax?]
[e2 syntax/f]))
(struct (mrule deriv)
([e1 syntax?]
[e2 syntax/f]
[transformation (anyq transformation?)]
[next (maybe (anyq deriv?))]))
(struct (lift-deriv deriv)
([e1 syntax?]
[e2 syntax/f]
[first deriv?]
[lift-stx syntax?]
[second (anyq deriv?)]))
(struct transformation
([e1 syntax?]
[e2 syntax/f]
[resolves resolves/c]
[me1 syntax?]
[me2 syntax/f]
[locals (listof (or/c local-expansion? local-lift? local-lift-end?))]))
(struct (prule deriv)
([e1 syntax?]
[e2 syntax/f]
[resolves resolves/c]))
(struct lderiv
([es1 syntaxes/c]
[es2 syntaxes/f]
[derivs (listof (anyq deriv?))]))
(struct interrupted-wrap
([tag (or/c symbol? false/c)]
[inner node/c]))
(struct error-wrap
([exn exn?]
[tag (or/c symbol? false/c)]
[inner errnode/c])))
(provide ;(struct deriv (e1 e2))
;(struct mrule (transformation next))
;(struct lift-deriv (first lift-stx second))
;(struct transformation (e1 e2 resolves me1 me2 locals))
(struct local-expansion (e1 e2 me1 me2 deriv))
(struct local-lift (expr id))
(struct local-lift-end (decl))
;(struct prule (resolves))
(struct p:variable ())
(struct p:define-syntaxes (rhs))
(struct p:define-values (rhs))
(struct p:if (full? test then else))
(struct p:wcm (key mark body))
(struct p:set! (id-resolves rhs))
(struct p:set!-macro (deriv))
(struct p:begin (lderiv))
(struct p:begin0 (first lderiv))
(struct p:#%app (tagged-stx lderiv))
(struct p:lambda (renames body))
(struct p:case-lambda (renames+bodies))
(struct p:let-values (renames body))
(struct p:let*-values (inner))
(struct p:letrec-values (renames rhss body))
(struct p:letrec-syntaxes+values (srenames srhss vrenames vrhss body))
(struct p:module (body))
(struct p:#%module-begin (pass1 pass2))
(struct p::STOP ())
(struct p:#%datum (tagged-stx))
(struct p:#%top (tagged-stx))
(struct p:quote ())
(struct p:quote-syntax ())
(struct p:require ())
(struct p:require-for-syntax ())
(struct p:require-for-template ())
(struct p:provide ())
(struct p:stop ())
(struct p:unknown ())
(struct p:rename (renames inner))
(struct p:synth (subterms))
(struct s:subterm (path deriv))
;(struct lderiv (es1 es2 derivs))
(struct bderiv (es1 es2 pass1 trans pass2))
(struct brule (renames))
(struct b:defvals (head))
(struct b:defstx (deriv rhs))
(struct b:splice (head tail))
(struct b:expr (head))
(struct b:begin (head inner))
(struct modrule ())
(struct mod:cons (head))
(struct mod:prim (head prim))
(struct mod:skip ())
(struct mod:splice (head tail))
(struct mod:lift (head tail))
(struct mod:lift-end (tail))
(struct mod:begin (head inner))
;(struct interrupted-wrap (tag inner))
;(struct error-wrap (exn tag inner))
)
;; Well-formedness
;; Predicates on well-formed derivations
#;
(define (wf-ok-deriv? x)
(match x
[($ pderiv e1 e2 prule)
(and (syntax? e1)
(syntax? e2)
(wf-ok-prule? prule))]
[($ mderiv e1 e2 mrule next)
(and (syntax? e1)
(syntax? e2)
(wf-ok-mrule? mrule)
(wf-ok-deriv? next))]
[else #f]))
#;
(define (wf-ok-mrule? x)
(match x
[($ mrule e1 e2 rs me1 me2 locals)
(and (syntax? e1)
(syntax? e2)
(list? rs)
(andmap identifier? rs)
(syntax? me1)
(syntax? me2)
(list? locals)
(andmap wf-ok-deriv? locals))]
[else #f]))
#;
(define (wf-ok-basic-prule? x)
(match x
[($ prule e1 e2 rs)
(and (syntax? e1)
(syntax? e2)
(list? rs)
(andmap identifier? rs))]
[else #f]))
#;
(define (wf-ok-prule? x)
(and (wf-ok-basic-prule? x)
(match x
[($ p:variable _ _ _) #t]
[($ p:define-syntaxes _ _ _ rhs)
(wf-ok-deriv? rhs)]
[($ p:define-values _ _ _ rhs)
(wf-ok-deriv? rhs)]
[($ p:if _ _ _ test then else)
(and (wf-ok-deriv? test)
(wf-ok-deriv? then)
(wf-ok-deriv? else))]
[($ p:wcm _ _ _ key value body)
(and (wf-ok-deriv? key)
(wf-ok-deriv? value)
(wf-ok-deriv? body))]
[($ p:set! _ _ _ id-rs rhs)
(and (list? id-rs)
(andmap identifier? id-rs)
(wf-ok-deriv? rhs))]
[($ p:set!-macro _ _ _ deriv)
(wf-ok-deriv? deriv)]
[($ p:begin _ _ _ lderiv)
(wf-ok-lderiv? lderiv)]
[($ p:begin0 _ _ _ first lderiv)
(and (wf-ok-deriv? first)
(wf-ok-lderiv? lderiv))]
[($ p:#%app _ _ _ lderiv)
(wf-ok-lderiv? lderiv)]
[($ p:lambda _ _ _ renames body)
(and (pair? renames)
(syntax? (car renames))
(syntax? (cdr renames))
(wf-ok-bderiv? body))]
[($ p:case-lambda _ _ _ (renames+bodies ...))
(andmap (lambda (r+b)
(and (pair? r+b)
(pair? (car r+b))
(syntax? (caar r+b))
(syntax? (cdar r+b))
(wf-ok-bderiv? (cdr r+b))))
renames+bodies)]
[($ p:let-values _ _ _ (renames ...) (rhss ...) body)
(and (andmap (lambda (r)
(and (pair? r)
(syntax? (car r))
(syntax? (cdr r))))
renames)
(andmap wf-ok-deriv? rhss)
(= (length renames) (length rhss))
(wf-ok-bderiv? body))]
[($ p:letrec-values _ _ _ (renames ...) (rhss ...) body)
(and (andmap (lambda (r)
(and (pair? r)
(syntax? (car r))
(syntax? (cdr r))))
renames)
(andmap wf-ok-deriv? rhss)
(= (length renames) (length rhss))
(wf-ok-bderiv? body))]
[($ p:letrec-syntaxes+values _ _ _
(srenames ...) (srhss ...) (vrenames ...) (vrhss ...) body)
(and (andmap (lambda (r)
(and (pair? r) (syntax? (car r)) (syntax? (cdr r))))
srenames)
(andmap wf-ok-deriv? srhss)
(= (length srenames) (length srhss))
(andmap (lambda (r)
(and (pair? r) (syntax? (car r)) (syntax? (cdr r))))
vrenames)
(andmap wf-ok-deriv? vrhss)
(= (length vrenames) (length vrhss))
(wf-ok-bderiv? body))]
[($ p::STOP _ _ _) #t]
[else #f])))
#;
(define (wf-ok-lderiv? x)
(match x
[($ lderiv es1 es2 derivs)
(and (list? es1)
(andmap syntax? es1)
(list? es2)
(andmap syntax? es2)
(list? derivs)
(andmap wf-ok-lderiv? derivs))]
[else #f]))
#;
(define (wf-ok-bderiv? x)
(define (wf-ok-brule? x)
(match x
[($ brskip renames next)
(and (void renames)
(wf-ok-brule? next))]
[($ brcons renames head next)
(and (void renames)
(wf-ok-deriv? head)
(wf-ok-brule? next))]
[($ brdefstx renames deriv rhs next)
(and (void renames)
(wf-ok-deriv? deriv)
(wf-ok-deriv? rhs)
(wf-ok-brule? next))]
[($ brsplice tail next)
(and (list? tail)
(andmap syntax? tail)
(wf-ok-brule? next))]
[else #f]))
(match x
[($ bderiv es1 es2 pass1 trans pass2)
(and (wf-ok-brule? pass1)
(wf-ok-lderiv? pass2))]
[else #f]))
#;
(define (wf-exn-deriv? x)
#f)
)

81
collects/macro-debugger/model/hiding-policies.ss Normal file
View File

@ -0,0 +1,81 @@
(module hiding-policies mzscheme
(require (lib "plt-match.ss")
(lib "boundmap.ss" "syntax"))
(provide (all-defined))
(define-struct hiding-policy
(opaque-modules opaque-ids opaque-kernel transparent-ids))
(define (policy-hide-module p m)
(hash-table-put! (hiding-policy-opaque-modules p) m #t))
(define (policy-unhide-module p m)
(hash-table-remove! (hiding-policy-opaque-modules p) m))
(define (policy-hide-kernel p)
(set-hiding-policy-opaque-kernel! p #t))
(define (policy-unhide-kernel p)
(set-hiding-policy-opaque-kernel! p #f))
(define (policy-hide-id p id)
(policy-unshow-id p id)
(module-identifier-mapping-put! (hiding-policy-opaque-ids p) id #t))
(define (policy-unhide-id p id)
(module-identifier-mapping-put! (hiding-policy-opaque-ids p) id #f))
(define (policy-show-id p id)
(policy-unhide-id p id)
(module-identifier-mapping-put! (hiding-policy-transparent-ids p) id #t))
(define (policy-unshow-id p id)
(module-identifier-mapping-put! (hiding-policy-transparent-ids p) id #f))
(define (new-hiding-policy)
(make-hiding-policy (make-hash-table)
(make-module-identifier-mapping)
#f
(make-module-identifier-mapping)))
(define (new-standard-hiding-policy)
(let ([p (new-hiding-policy)])
(policy-hide-kernel p)
p))
;; ---
(define-syntax inline
(syntax-rules ()
[(inline ([name expr] ...) . body)
(let-syntax ([name
(lambda (x)
(syntax-case x ()
[xx (identifier? #'xx) #'expr]))] ...)
. body)]))
(define (/false) #f)
(define (policy-show-macro? policy id)
(match policy
[(struct hiding-policy (opaque-modules
opaque-identifiers
opaque-kernel
transparent-identifiers))
(let ([binding (identifier-binding id)])
(if (list? binding)
(let-values ([(srcmod srcname nommod nomname _) (apply values binding)])
(inline ([opaque-srcmod (hash-table-get opaque-modules srcmod /false)]
[opaque-nommod (hash-table-get opaque-modules nommod /false)]
;; FIXME
[in-kernel?
(and (symbol? srcmod)
(eq? #\# (string-ref (symbol->string srcmod) 0)))]
[not-opaque-id
(not (module-identifier-mapping-get opaque-identifiers id /false))]
[transparent-id
(module-identifier-mapping-get transparent-identifiers id /false)])
(or transparent-id
(and (not opaque-srcmod)
(not opaque-nommod)
(not (and in-kernel? opaque-kernel))
not-opaque-id))))
#f))]))
)

196
collects/macro-debugger/model/reductions-engine.ss Normal file
View File

@ -0,0 +1,196 @@
(module reductions-engine mzscheme
(require "deriv.ss"
"stx-util.ss")
(provide (all-defined))
;; A ReductionSequence is a (list-of Reduction)
;; A Reduction is one of
;; - (make-step Syntaxes Syntaxes Syntax Syntax BigContext)
;; - (make-misstep Syntax Syntax Exception)
(define-struct step (redex contractum e1 e2 note lctx) #f)
;(define-struct lift-step (expr id note lctxt) #t)
(define-struct misstep (redex e1 exn) #f)
;; -------------------------
;; A Context is (syntax -> syntax)
;; A BigContext is (list-of (cons Syntaxes Syntax))
;; local expansion contexts: pairs of foci, term
;; context: parameter of Context
(define context (make-parameter (lambda (x) x)))
;; big-context: parameter of BigContext
(define big-context (make-parameter null))
(define-syntax with-context
(syntax-rules ()
[(with-context f . body)
(let ([E (context)])
(parameterize ([context (lambda (x) (E (f x)))])
. body))]))
(define-syntax with-new-local-context
(syntax-rules ()
[(with-new-local-context e . body)
(parameterize ([big-context (cons (cons (list e) (E e)) (big-context))]
[context (lambda (x) x)])
. body)]))
;; E : syntax -> syntax
(define (E stx) ((context) stx))
;; -----------------------------------
;; CC
;; the context constructor
(define-syntax (CC stx)
(syntax-case stx ()
[(CC HOLE expr pattern)
#'(syntax-copier HOLE expr pattern)]))
;; R
;; the threaded reductions engine
(define-syntax R
(syntax-rules ()
[(R form pattern . clauses)
(R** #f _ [#:set-syntax form] [#:pattern pattern] . clauses)]))
(define-syntax (R** stx)
(syntax-case stx (! @ List Block =>)
[(R** form-var pattern)
#'null]
[(R** f p => k)
#'(k f)]
;; Change patterns
[(R** f p [#:pattern p2] . more)
#'(R** f p2 . more)]
;; Bind pattern variables
[(R** f p [#:bind pattern rhs] . more)
#'(with-syntax ([pattern rhs])
(R** f p . more))]
;; Change syntax
[(R** f p [#:set-syntax form] . more)
#'(let ([form-variable form])
(R** form-variable p . more))]
;; Change syntax with step
[(R** f p [#:walk form2 foci1 foci2 description] . more)
#'(let-values ([(form2-var foci1-var foci2-var description-var)
(with-syntax ([p f])
(values form2 foci1 foci2 description))])
(cons (walk/foci/E foci1-var foci2-var f form2-var description-var)
(R** form2-var p . more)))]
[(R** f p [#:walk form2 description] . more)
#'(let-values ([(form2-var description-var)
(with-syntax ([p f])
(values form2 description))])
(cons (walk f form2-var description-var)
(R** form2-var p . more)))]
;; Conditional
[(R** f p [#:if test consequent ...] . more)
#'(if (with-syntax ([p f]) test)
(R** f p consequent ... . more)
(R** f p . more))]
;; Error-point case
[(R** f p [! info] . more)
#'(R** f p [! info #f] . more)]
[(R** f p [! info key] . more)
#'(let ([continue (lambda () (R** f p . more))])
(cond [(and (pair? info) (car info))
;; error-wrap
;; If this is the key, then insert the misstep here and stop.
;; This stops processing *within* an error-wrapped prim.
(if (or (eq? key #f) (eq? key (cdr info)))
(list (make-misstep f (E f) (car info)))
(continue))]
[else
(continue)]))]
[(R** f p [Generator hole0 fill0] . more)
#'(let-values ([(reducer get-e1 get-e2) Generator])
(R** f p [reducer get-e1 get-e2 hole0 fill0] . more))]
; ;; Expression case
; [(R** f p [hole0 fill0] . more)
; #'(R** f p [reductions deriv-e1 deriv-e2 hole0 fill0] . more)]
; ;; List case
; [(R** f p [List hole0 fill0] . more)
; #'(R** f p [list-reductions lderiv-es1 lderiv-es2 hole0 fill0] . more)]
; ;; Block case
; [(R** f p [Block hole0 fill0] . more)
; #'(R** f p [block-reductions bderiv-es1 bderiv-es2 hole0 fill0] . more)]
;; Implementation for (hole ...) sequences
[(R** form-var pattern
[f0 get-e1 get-e2 (hole0 :::) fill0s] . more)
(module-identifier=? #'::: (quote-syntax ...))
#'(let ([ctx0 (CC (hole0 :::) form-var pattern)])
(let ([e1s (with-syntax ([pattern form-var]) (syntax->list #'(hole0 :::)))])
(let loop ([fills fill0s] [prefix null] [suffix e1s])
(cond
[(pair? fills)
(append
(with-context ctx0
(with-context (lambda (x) (revappend prefix (cons x (cdr suffix))))
(f0 (car fills))))
(cond [(interrupted-wrap? (car fills))
null]
[(error-wrap? (car fills))
null]
[else
(loop (cdr fills)
(cons (get-e2 (car fills)) prefix)
(cdr suffix))]))]
[(null? fills)
(let ([form-var (ctx0 (reverse prefix))])
(R** form-var pattern . more))]))))]
;; Implementation
[(R** form-var pattern
[f0 get-e1 get-e2 hole0 fill0] . more)
#'(let ([ctx0 (CC hole0 form-var pattern)])
(append (with-context ctx0
(f0 fill0))
;; If the last thing we ran through was interrupted,
;; then there's nothing left to do.
;; This stops processing *after* an error-wrapped deriv.
(cond [(interrupted-wrap? fill0) null]
[(error-wrap? fill0) null]
[else
(let ([form-var (ctx0 (get-e2 fill0))])
(R** form-var pattern . more))])))]))
;; -----------------------------------
;; walk : syntax(s) syntax(s) [string] -> Reduction
;; Lifts a local step into a term step.
(define walk
(case-lambda
[(e1 e2) (walk e1 e2 #f)]
[(e1 e2 note) (make-step e1 e2 (E e1) (E e2) note (big-context))]))
;; walk/foci/E : syntax(s) syntax(s) syntax syntax string -> Reduction
(define (walk/foci/E focus1 focus2 e1 e2 note)
(walk/foci focus1 focus2 (E e1) (E e2) note))
;; walk/foci : syntax(s) syntax(s) syntax syntax string -> Reduction
(define (walk/foci focus1 focus2 Ee1 Ee2 note)
(make-step focus1 focus2 Ee1 Ee2 note (big-context)))
;; stumble : syntax exception -> Reduction
(define (stumble stx exn)
(make-misstep stx (E stx) exn))
;; ------------------------------------
(define (revappend a b)
(cond [(pair? a) (revappend (cdr a) (cons (car a) b))]
[(null? a) b]))
)

523
collects/macro-debugger/model/reductions.ss Normal file
View File

@ -0,0 +1,523 @@
(module reductions mzscheme
(require (lib "plt-match.ss")
"stx-util.ss"
"deriv-util.ss"
"context.ss"
"deriv.ss"
"reductions-engine.ss")
(provide reductions
(struct step (redex contractum e1 e2 note lctx))
(struct misstep (redex e1 exn)))
;; Setup for reduction-engines
(define-syntax Expr
(syntax-id-rules ()
[Expr (values reductions deriv-e1 deriv-e2)]))
(define-syntax List
(syntax-id-rules ()
[List (values list-reductions lderiv-es1 lderiv-es2)]))
(define-syntax Block
(syntax-id-rules ()
[Block (values block-reductions bderiv-es1 bderiv-es2)]))
;; Reductions
;; reductions : Derivation -> ReductionSequence
(define (reductions d)
(match d
;; Primitives
[(struct p:variable (e1 e2 rs))
null]
[(IntQ p:module (e1 e2 rs body))
(with-syntax ([(?module name language . BODY) e1])
(let ([ctx (lambda (x) (d->so e1 `(,#'?module ,#'name ,#'language ,x)))]
[body-e1 (match body [($$ deriv (body-e1 _) _) body-e1])])
(cons (walk e1 (ctx body-e1) "Tag #%module-begin")
(with-context ctx
(reductions body)))))]
[(IntQ p:#%module-begin (e1 e2 rs pass1 pass2))
#;(R e1 (?module-begin . MBODY)
[! exni 'blah]
[ModulePass1 MBODY pass1]
=> (lambda (e1prime)
(R e1prime (?module-begin2 . MBODY2)
[ModulePass2 MBODY2 pass2])))
(with-syntax ([(?#%module-begin form ...) e1])
(let-values ([(reductions1 final-stxs1)
(with-context (lambda (x) (d->so e1 (cons #'?#%module-begin x)))
(mbrules-reductions pass1 (syntax->list #'(form ...)) #t))])
(let-values ([(reductions2 final-stxs2)
(with-context (lambda (x) (d->so e1 (cons #'?#%module-begin x)))
(mbrules-reductions pass2 final-stxs1 #f))])
(append reductions1 reductions2))))]
[(AnyQ p:define-syntaxes (e1 e2 rs rhs) exni)
(R e1 _
[! exni]
[#:pattern (?define-syntaxes formals RHS)]
[Expr RHS rhs])]
[(AnyQ p:define-values (e1 e2 rs rhs) exni)
(R e1 _
[! exni]
[#:pattern (?define-values formals RHS)]
[Expr RHS rhs])]
[(AnyQ p:if (e1 e2 rs full? test then else) exni)
(if full?
(R e1 _
[! exni]
[#:pattern (?if TEST THEN ELSE)]
[Expr TEST test]
[Expr THEN then]
[Expr ELSE else])
(R e1 _
[! exni]
[#:pattern (?if TEST THEN)]
[Expr TEST test]
[Expr THEN then]))]
[(AnyQ p:wcm (e1 e2 rs key mark body) exni)
(R e1 _
[! exni]
[#:pattern (?wcm KEY MARK BODY)]
[Expr KEY key]
[Expr MARK mark]
[Expr BODY body])]
[(AnyQ p:begin (e1 e2 rs lderiv) exni)
(R e1 _
[! exni]
[#:pattern (?begin . LDERIV)]
[List LDERIV lderiv])]
[(AnyQ p:begin0 (e1 e2 rs first lderiv) exni)
(R e1 _
[! exni]
[#:pattern (?begin0 FIRST . LDERIV)]
[Expr FIRST first]
[List LDERIV lderiv])]
[(AnyQ p:#%app (e1 e2 rs tagged-stx lderiv) exni)
(let ([tail
(R tagged-stx (?#%app . LDERIV)
[! exni]
[List LDERIV lderiv])])
(if (eq? tagged-stx e1)
tail
(cons (walk e1 tagged-stx "Tag application") tail)))]
[(AnyQ p:lambda (e1 e2 rs renames body) exni)
(R e1 _
[! exni]
[#:bind (?formals* . ?body*) renames]
[#:pattern (?lambda ?formals . ?body)]
[#:walk (syntax/skeleton e1 (?lambda ?formals* . ?body*))
#'?formals #'?formals*
"Rename formal parameters"]
[Block ?body body])
#;
(R e1 _1
[! exni]
=>
(lambda (stx)
(with-syntax ([(?lambda ?formals . ?body) stx]
[(?formals* . ?body*) renames])
(let ([mid (syntax/skeleton e1 (?lambda ?formals* . ?body*))])
(append
(if (stx-pair? #'?formals)
(list (walk/foci/E #'?formals #'?formals* e1 mid
"Rename formal parameters"))
null)
(R mid (LAMBDA FORMALS . BODY)
[Block BODY body]))))))
#;(with-syntax ([(?lambda ?formals . ?body) e1]
[(?formals* . ?body*) renames])
(let ([mid (syntax/skeleton e1 (?lambda ?formals* . ?body*))])
(append
(if (stx-pair? #'?formals)
(list (walk/foci/E #'?formals #'?formals* e1 mid
"Rename formal parameters"))
null)
(R mid (LAMBDA FORMALS . BODY)
[Block BODY body]))))]
[(struct p:case-lambda (e1 e2 rs renames+bodies))
#;
(R e1 _
[! exni]
[#:pattern (?case-lambda [?formals . ?body] ...)]
[#:bind [(?formals* . ?body*) ...] (map car renames+bodies)]
[#:walk (syntax/skeleton e1 (?case-lambda [?formals* . ?body*] ...))
(syntax->list #'(?formals ...))
(syntax->list #'(?formals* ...))
"Rename formal parameters"]
[Block (?body ...) (map cdr renames+bodies)])
(with-syntax ([(?case-lambda [?formals . ?body] ...) e1]
[((?formals* . ?body*) ...) (map car renames+bodies)])
(let ([mid (syntax/skeleton e1 (?case-lambda [?formals* . ?body*] ...))])
(cons (walk/foci/E (syntax->list #'(?formals ...))
(syntax->list #'(?formals* ...))
e1 mid "Rename formal parameters")
(R mid (CASE-LAMBDA [FORMALS . BODY] ...)
[Block (BODY ...) (map cdr renames+bodies)]))))]
[(AnyQ p:let-values (e1 e2 rs renames rhss body) exni)
(R e1 _
[! exni]
[#:pattern (?let-values ([?vars ?rhs] ...) . ?body)]
[#:bind (([?vars* ?rhs*] ...) . ?body*) renames]
[#:walk (syntax/skeleton e1 (?let-values ([?vars* ?rhs*] ...) . ?body*))
(syntax->list #'(?vars ...))
(syntax->list #'(?vars* ...))
"Rename bound variables"]
[Expr (?rhs ...) rhss]
[Block ?body body])
#;
(with-syntax ([(?let-values ([?vars ?rhs] ...) . ?body) e1]
[(([?vars* ?rhs*] ...) . ?body*) renames])
(let ([mid (syntax/skeleton e1 (?let-values ([?vars* ?rhs*] ...) . ?body*))])
(cons (walk/foci/E (syntax->list #'(?vars ...))
(syntax->list #'(?vars* ...))
e1 mid "Rename let-bound variables")
(R mid (LET-VALUES ([VARS RHS] ...) . BODY)
[Expr (RHS ...) rhss]
[Block BODY body]))))]
[(AnyQ p:letrec-values (e1 e2 rs renames rhss body) exni)
(R e1 _
[! exni]
[#:pattern (?letrec-values ([?vars ?rhs] ...) . ?body)]
[#:bind (([?vars* ?rhs*] ...) . ?body*) renames]
[#:walk (syntax/skeleton e1 (?letrec-values ([?vars* ?rhs*] ...) . ?body*))
(syntax->list #'(?vars ...))
(syntax->list #'(?vars* ...))
"Rename bound variables"]
[Expr (?rhs ...) rhss]
[Block ?body body])
#;
(with-syntax ([(?letrec-values ([?vars ?rhs] ...) . ?body) e1]
[(([?vars* ?rhs*] ...) . ?body*) renames])
(let ([mid (syntax/skeleton e1 (?letrec-values ([?vars* ?rhs*] ...) . ?body*))])
(cons (walk/foci/E (syntax->list #'(?vars ...))
(syntax->list #'(?vars* ...))
e1 mid "Rename letrec-bound variables")
(R mid (LETREC-VALUES ([VARS RHS] ...) . BODY)
[Expr (RHS ...) rhss]
[Block BODY body]))))]
[(AnyQ p:letrec-syntaxes+values (e1 e2 rs srenames srhss vrenames vrhss body) exni)
(R e1 _
[! exni]
[#:pattern (?lsv ([?svars ?srhs] ...) ([?vvars ?vrhs] ...) . ?body)]
[#:bind (([?svars* ?srhs*] ...) ([?vvars* ?vrhs] ...) . ?body*) srenames]
[#:walk (syntax/skeleton e1 (?lsv ([?svars* ?srhs*] ...) ([?vvars* ?vrhs*] ...) . ?body*))
(syntax->list #'(?svars ...))
(syntax->list #'(?svars* ...))
"Rename bound variables"]
[Expr (?srhs ...) srhss]
[#:bind (([?vvars** ?vrhs**] ...) . ?body**) vrenames]
[#:walk (syntax/skeleton e1 (?lsv ([?svars* ?srhs*] ...) ([?vars** ?vrhs**] ...) . ?body**))
(syntax->list #'(?vvars* ...))
(syntax->list #'(?vvars** ...))
"Rename bound variables"]
[Expr (?vrhs ...) vrhss]
[Block ?body body]
=> (lambda (mid)
(if (eq? mid e2)
null
(list (walk mid e2 "Remove syntax bindings")))))
#;
(with-syntax ([(?lsv ([?svars ?srhs] ...) ([?vvars ?vrhs] ...) . ?body) e1]
[(([?svars* ?srhs*] ...) ?vpart* . ?body*) srenames])
(with-syntax ([(([?vvars* ?vrhs*] ...) . ?body**)
(or vrenames #'(?vpart* . ?body*))])
(let ([mid (syntax/skeleton
e1
(?lsv ([?svars* ?srhs*] ...) ([?vvars* ?vrhs] ...) . ?body**))])
(cons
(walk/foci/E (syntax->list #'(?svars ... ?vvars ...))
(syntax->list #'(?svars* ... ?vvars* ...))
e1 mid "Rename local variables")
(R mid (LETREC-SYNTAXES+VALUES ([SVARS SRHS] ...) ([VVARS VRHS] ...) . BODY)
[Expr (SRHS ...) srhss]
[Expr (VRHS ...) vrhss]
[Block BODY body]
=> (lambda (mid)
(if (eq? mid e2)
null
(list (walk mid e2 "Finish letrec-syntaxes+values")))))))))]
;; The auto-tagged atomic primitives
[(AnyQ p:#%datum (e1 e2 rs tagged-stx) exni)
(append (if (eq? e1 tagged-stx)
null
(list (walk e1 tagged-stx "Tag datum")))
(if exni
(list (stumble tagged-stx (car exni)))
null))]
[(AnyQ p:#%top (e1 e2 rs tagged-stx) exni)
(append (if (eq? e1 tagged-stx)
null
(list (walk e1 tagged-stx "Tag top-level variable")))
(if exni
(list (stumble tagged-stx (car exni)))
null))]
;; The rest of the automatic primitives
[(AnyQ p::STOP (e1 e2 rs) exni)
(R e1 _
[! exni])]
[(AnyQ p:set!-macro (e1 e2 rs deriv) exni)
(R e1 _
[! exni]
=> (lambda (mid)
(reductions deriv)))]
[(AnyQ p:set! (e1 e2 rs id-rs rhs) exni)
(R e1 _
[! exni]
[#:pattern (SET! VAR RHS)]
[Expr RHS rhs])]
;; Synthetic primitives
;; These have their own subterm replacement mechanisms
[(and d (AnyQ p:synth (e1 e2 rs subterms)))
(let loop ([term e1] [subterms subterms])
(cond [(null? subterms)
(let ([exn (and (error-wrap? d) (error-wrap-exn d))])
(if exn
(list (stumble term exn))
null))]
[(pair? subterms)
(let* ([subterm0 (car subterms)]
[path0 (s:subterm-path subterm0)]
[deriv0 (s:subterm-deriv subterm0)])
(let ([ctx (lambda (x) (path-replace term path0 x))])
(append (with-context ctx
(reductions deriv0))
(loop (path-replace term path0 (deriv-e2 deriv0))
(cdr subterms)))))]))]
;; FIXME
[(IntQ p:rename (e1 e2 rs rename inner))
(reductions inner)]
;; Error
; [(struct error-wrap (exn tag (? prule? prule)))
; ;; Let's take the attitude that all primitive syntax errors
; ;; occur "at the beginning"
; (list (make-misstep (deriv-e1 prule) (E (deriv-e1 prule)) exn))]
;
; #;
; [($$ interrupted-wrap (tag prule))
; (reductions prule orig-stx)]
;; Macros
[(IntQ mrule (e1 e2 transformation next))
(append (reductions-transformation transformation)
(reductions next))]
;; Lifts
[(IntQ lift-deriv (e1 e2 first lifted-stx second))
(append (reductions first)
(list (walk (deriv-e2 first) lifted-stx "Capture lifts"))
(reductions second))]
;; Skipped
[#f null]))
;; reductions-transformation : Transformation -> ReductionSequence
(define (reductions-transformation tx)
(match tx
[(struct transformation (e1 e2 rs me1 me2 locals))
(append (reductions-locals e1 locals)
(list (walk e1 e2 "Macro transformation")))]
[(IntW transformation (e1 e2 rs me1 me2 locals) 'locals)
(reductions-locals e1 locals)]
[(ErrW transformation (e1 e2 rs me1 me2 locals) 'transform exn)
(append (reductions-locals e1 locals)
(list (stumble e1 exn)))]))
;; reductions-locals : syntax (list-of LocalAction) -> ReductionSequence
(define (reductions-locals stx locals)
(with-new-local-context stx
(apply append (map reductions-local locals))))
;; reductions-local : LocalAction -> ReductionSequence
(define (reductions-local local)
(match local
[(IntQ local-expansion (e1 e2 me1 me2 deriv))
(reductions deriv)]
[(struct local-lift (expr id))
(list (walk expr id "Macro lifted expression to top-level"))]
[(struct local-lift-end (decl))
(list (walk decl decl "Declaration lifted to end of module"))]))
;; list-reductions : ListDerivation -> ReductionSequence
(define (list-reductions ld)
(match ld
[(IntQ lderiv (es1 es2 derivs))
(let loop ([derivs derivs] [suffix es1])
(cond [(pair? derivs)
(append
(with-context (lambda (x) (cons x (stx-cdr suffix)))
(reductions (car derivs)))
(with-context (lambda (x) (cons (deriv-e2 (car derivs)) x))
(loop (cdr derivs) (stx-cdr suffix))))]
[(null? derivs)
null]))]
[(ErrW lderiv (es1 es2 derivs) _ exn)
(list (stumble es1 exn))]
[#f null]))
;; block-reductions : BlockDerivation -> ReductionSequence
(define (block-reductions bd)
(match bd
;; If interrupted in pass1, skip pass2
[(IntW bderiv (es1 es2 pass1 trans pass2) 'pass1)
(let-values ([(reductions stxs) (brules-reductions pass1 es1)])
reductions)]
;; Otherwise, do both
[(IntQ bderiv (es1 es2 pass1 trans pass2))
(let-values ([(reductions1 stxs1) (brules-reductions pass1 es1)])
(append reductions1
(if (eq? trans 'letrec)
(match pass2
[($$ lderiv (pass2-es1 _ _) _exni)
(list (walk stxs1 pass2-es1 "Transform block to letrec"))])
null)
(list-reductions pass2)))]
[#f null]))
;; brules-reductions : (list-of-BRule) syntax-list -> ReductionSequence syntax-list
(define (brules-reductions brules all-stxs)
(let loop ([brules brules] [suffix all-stxs] [prefix null] [rss null])
(match brules
[(cons (struct b:expr (renames head)) next)
(let ([estx (deriv-e2 head)])
(loop next (stx-cdr suffix) (cons estx prefix)
(cons (with-context (lambda (x)
(revappend prefix (cons x (stx-cdr suffix))))
(reductions head))
rss)))]
[(cons (IntW b:expr (renames head) tag) '())
(loop '() #f #f
(cons (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix))))
(reductions head))
rss))]
[(cons (struct b:defvals (renames head)) next)
(let ([head-rs
(with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix))))
(reductions head))])
(loop next (stx-cdr suffix) (cons (deriv-e2 head) prefix)
(cons head-rs rss)))]
[(cons ($$ b:defstx (renames head rhs) _exni) next)
(let* ([estx (deriv-e2 head)]
[estx2 (with-syntax ([(?ds ?vars ?rhs) estx]
[?rhs* (deriv-e2 rhs)])
;;FIXME
#'(?ds ?vars ?rhs*))])
(loop next (cdr suffix) (cons estx2 prefix)
(with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix))))
(cons (with-context (CC (?ds ?vars ?rhs) estx ?rhs)
(reductions rhs))
(cons (reductions head)
rss)))))]
[(cons (struct b:splice (renames head tail)) next)
(loop next tail prefix
(cons (list (walk/foci (deriv-e2 head)
(take-until tail (stx-cdr suffix))
(E (revappend prefix
(cons (deriv-e2 head) (stx-cdr suffix))))
(E (revappend prefix tail))
"Splice block-level begin"))
(cons (with-context (lambda (x)
(revappend prefix (cons x (stx-cdr suffix))))
(reductions head))
rss)))]
[(cons (struct b:begin (renames head derivs)) next)
;; FIXME
(error 'unimplemented)]
[(cons (struct error-wrap (exn tag _inner)) '())
(values (list (make-misstep suffix (E (revappend prefix suffix)) exn))
(revappend prefix suffix))]
['()
(values (apply append (reverse rss))
(revappend prefix suffix))])))
;; mbrules-reductions : MBRules (list-of syntax) -> ReductionSequence
;; The reprocess-on-lift? argument controls the behavior of a mod:lift event.
;; In Pass1, #t; in Pass2, #f.
(define (mbrules-reductions mbrules all-stxs reprocess-on-lift?)
;(printf "**** MB Reductions, pass ~s~n" (if reprocess-on-lift? 1 2))
(let* ([final-stxs #f]
[reductions
(let loop ([mbrules mbrules] [suffix all-stxs] [prefix null])
;(printf "** MB loop~n")
;(printf " rules: ~s~n" mbrules)
;(printf " suffix: ~s~n" suffix)
;(printf " prefix: ~s~n" prefix)
(match mbrules
[(cons ($$ mod:skip ()) next)
(loop next (stx-cdr suffix) (cons (stx-car suffix) prefix))]
[(cons ($$ mod:cons (head) _exni) next)
(append (with-context (lambda (x)
(revappend prefix (cons x (stx-cdr suffix))))
(append (reductions head)))
(let ([estx (and (deriv? head) (deriv-e2 head))])
(loop next (stx-cdr suffix) (cons estx prefix))))]
[(cons ($$ mod:prim (head prim) _exni) next)
(append (with-context (lambda (x)
(revappend prefix (cons x (stx-cdr suffix))))
(if (and prim (not (p:define-values? prim)))
(append (reductions head)
(reductions prim))
(reductions head)))
(let ([estx (and (deriv? head) (deriv-e2 head))])
(loop next (stx-cdr suffix) (cons estx prefix))))]
[(cons ($$ mod:splice (head stxs)) next)
;(printf "suffix is: ~s~n~n" suffix)
;(printf "stxs is: ~s~n" stxs)
(append
(with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix))))
(reductions head))
(let ([suffix-tail (stx-cdr suffix)]
[head-e2 (deriv-e2 head)])
(cons (walk/foci head-e2
(stx-take stxs
(- (stx-improper-length stxs)
(stx-improper-length suffix-tail)))
(E (revappend prefix (cons head-e2 suffix-tail)))
(E (revappend prefix stxs))
"Splice module-level begin")
(loop next stxs prefix))))]
[(cons ($$ mod:lift (head stxs)) next)
;(printf "suffix is: ~s~n~n" suffix)
;(printf "stxs is: ~s~n" stxs)
(append
(with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix))))
(reductions head))
(let ([suffix-tail (stx-cdr suffix)]
[head-e2 (deriv-e2 head)])
(let ([new-suffix (append stxs (cons head-e2 suffix-tail))])
(cons (walk/foci null
stxs
(E (revappend prefix (cons head-e2 suffix-tail)))
(E (revappend prefix new-suffix))
"Splice definitions from lifted expressions")
(loop next
new-suffix
prefix)))))]
[(cons ($$ mod:lift-end (tail)) next)
(append
(if (pair? tail)
(list (walk/foci null
tail
(E (revappend prefix suffix))
(E (revappend prefix tail))
"Splice lifted module declarations"))
null)
(loop next tail prefix))]
['()
(set! final-stxs (reverse prefix))
null]))])
(values reductions final-stxs)))
)

97
collects/macro-debugger/model/stx-util.ss Normal file
View File

@ -0,0 +1,97 @@
(module stx-util mzscheme
(require (lib "stx.ss" "syntax"))
(provide (all-defined)
(all-from (lib "stx.ss" "syntax")))
#;
(define-syntax (CC stx)
(syntax-case stx ()
[(CC HOLE expr pattern)
#'(lambda (in-the-hole)
(with-syntax ([pattern expr])
(with-syntax ([HOLE in-the-hole])
#'pattern)))]))
(define (d->so template datum)
(let ([template (and (syntax? template) #f)])
(datum->syntax-object template datum template template)))
(define-syntax (syntax-copier stx)
(syntax-case stx ()
[(syntax-copier hole expr pattern)
#'(let ([expr-var expr])
(lambda (in-the-hole)
(with-syntax ([pattern expr-var])
(with-syntax ([hole in-the-hole])
(syntax/restamp pattern #'pattern expr-var)))))]))
(define-syntax syntax/skeleton
(syntax-rules ()
[(syntax/skeleton old-expr pattern)
(syntax/restamp pattern #'pattern old-expr)]))
;; FIXME: Need to avoid turning syntax lists into syntax pairs
(define-syntax (syntax/restamp stx)
(syntax-case stx (...)
[(syntax/restamp (pa (... ...)) new-expr old-expr)
#`(let ([new-parts (stx->list new-expr)]
[old-parts (stx->list old-expr)])
(unless (= (length new-parts) (length old-parts))
(printf "** syntax/restamp~n~s~n" (quote-syntax #,stx))
(printf "pattern : ~s~n" (syntax-object->datum #'(pa (... ...))))
(printf "old parts: ~s~n" old-parts)
(printf "new parts: ~s~n" new-parts))
(d->so
old-expr
(map (lambda (new old) (syntax/restamp pa new old))
new-parts
old-parts)))]
#;[(syntax/restamp (pa ...) new-expr old-expr)
(with-syntax ([(na ...) (generate-temporaries #'(pa ...))]
[(oa ...) (generate-temporaries #'(pa ...))])
#'(with-syntax ([(na ...) new-expr]
[(oa ...) old-expr])
(d->so
old-expr
(list (syntax/restamp pa #'na #'oa) ...))))]
[(syntax/restamp (pa . pb) new-expr old-expr)
#'(let ([na (stx-car new-expr)]
[nb (stx-cdr new-expr)]
[oa (stx-car old-expr)]
[ob (stx-cdr old-expr)])
(d->so old-expr
(cons (syntax/restamp pa na oa)
(syntax/restamp pb nb ob))))]
[(syntax/restamp pvar new-expr old-expr)
#'new-expr]))
(define (iota n)
(let loop ([i 0])
(if (< i n)
(cons i (loop (add1 i)))
null)))
;; stx-take : syntax-list number -> (list-of syntax)
(define (stx-take items n)
(cond [(zero? n) null]
[else (cons (stx-car items) (stx-take (stx-cdr items) (sub1 n)))]))
(define *args* #f)
(define (take-until stxs tail)
(set! *args* (list stxs tail))
(let loop ([stxs stxs])
(if (eq? stxs tail)
null
(cons (stx-car stxs) (loop (stx-cdr stxs))))))
(define (stx-improper-length stx)
(if (stx-pair? stx)
(add1 (stx-improper-length (stx-cdr stx)))
0))
)

37
collects/macro-debugger/model/trace-raw.ss Normal file
View File

@ -0,0 +1,37 @@
(module trace-raw mzscheme
(require "../syntax-browser/syntax-browser.ss"
(lib "class.ss")
(lib "lex.ss" "parser-tools")
"deriv-tokens.ss"
"deriv-parser.ss")
(provide (all-defined))
(define current-expand-observe
(dynamic-require '#%expobs 'current-expand-observe))
(define (go-trace sexpr)
(define browser
(parameterize (#;(identifier=-choices
(list (cons "related by table"
(lambda (a b) (related-by-table table a b))))))
(make-syntax-browser)))
(define table #f)
(define pos 0)
(parameterize ((current-expand-observe
(lambda (sig val)
(define t (tokenize sig val pos))
(send browser add-text
(format "Signal: ~s: ~s~n"
pos
(token-name (position-token-token t))))
(send browser add-syntax
(datum->syntax-object #f val))
(set! pos (add1 pos)))))
(expand sexpr)))
(define (related-by-table table a b)
(or (eq? a b)
#;(and table '...)))
)

79
collects/macro-debugger/model/trace.ss Normal file
View File

@ -0,0 +1,79 @@
(module trace mzscheme
(require (lib "lex.ss" "parser-tools")
(lib "class.ss"))
(require "deriv.ss"
"deriv-parser.ss"
"deriv-tokens.ss"
"reductions.ss"
"hide.ss"
"hiding-policies.ss")
(provide trace-verbose?
trace
trace/result
trace+reductions
(all-from "reductions.ss"))
(define current-expand-observe
(dynamic-require '#%expobs 'current-expand-observe))
(define trace-verbose? (make-parameter #f))
;; trace : syntax -> Derivation
(define (trace stx)
(let-values ([(result tracer) (expand+tracer stx)])
(parse-derivation tracer)))
;; trace/result : syntax -> (values syntax/exn Derivation)
(define (trace/result stx)
(let-values ([(result tracer) (expand+tracer stx)])
(values result
(parse-derivation tracer))))
;; trace+reductions : syntax -> ReductionSequence
(define (trace+reductions stx)
(reductions (trace stx)))
;; expand+tracer : syntax/sexpr -> (values syntax/exn (-> event))
(define (expand+tracer sexpr)
(let* ([s (make-semaphore 1)]
[head (cons #f #f)]
[tail head]
[pos 0])
(define (add! x)
(semaphore-wait s)
(set-car! tail x)
(set-cdr! tail (cons #f #f))
(set! tail (cdr tail))
(semaphore-post s))
(define get
(let ([head head])
(lambda ()
(semaphore-wait s)
(let ([result (car head)])
(set! head (cdr head))
(semaphore-post s)
result))))
(parameterize ((current-expand-observe
(lambda (sig val)
(add! (cons sig val)))))
(let ([result
(with-handlers ([(lambda (exn) #t)
(lambda (exn)
(add! (cons 'error exn))
exn)])
(expand sexpr))])
(add! (cons 'EOF pos))
(values result
(lambda ()
(let* ([sig+val (get)]
[sig (car sig+val)]
[val (cdr sig+val)]
[t (tokenize sig val pos)])
(when (trace-verbose?)
(printf "~s: ~s~n" pos (token-name (position-token-token t))))
(set! pos (add1 pos))
t)))))))
)

44
collects/macro-debugger/model/yacc-ext.ss Normal file
View File

@ -0,0 +1,44 @@
(module yacc-ext mzscheme
(require (prefix yacc: (lib "yacc.ss" "parser-tools")))
(provide parser
options
productions)
(define-syntax options
(lambda (stx)
(raise-syntax-error #f "options keyword used out of context" stx)))
(define-syntax productions
(lambda (stx)
(raise-syntax-error #f "productions keyword used out of context" stx)))
(define-syntax (parser stx)
(syntax-case stx ()
[(parser form ...)
(let* ([stop-list (list #'begin #'options #'productions)]
[forms (syntax->list #'(form ...))]
[options+productions
(let loop ([forms forms] [opts null] [prods null])
(if (pair? forms)
(let ([eform0 (local-expand (car forms) 'expression stop-list)]
[forms (cdr forms)])
(syntax-case eform0 (begin options productions)
[(begin subform ...)
(loop (append (syntax->list #'(subform ...)) forms) opts prods)]
[(options subform ...)
(loop forms (append (syntax->list #'(subform ...)) opts) prods)]
[(productions subform ...)
(loop forms opts (append (syntax->list #'(subform ...)) prods))]
[else
(raise-syntax-error #f "bad parser subform" eform0)]))
(cons opts (reverse prods))))]
[opts (car options+productions)]
[prods (cdr options+productions)])
(with-syntax ([(opt ...) opts]
[(prod ...) prods])
#'(yacc:parser opt ... (grammar prod ...))))]))
)

219
collects/macro-debugger/model/yacc-interrupted.ss Normal file
View File

@ -0,0 +1,219 @@
(module yacc-interrupted mzscheme
(require "deriv.ss"
"yacc-ext.ss")
(provide ! ?
production/I
productions/I
skipped-token-values
%skipped
%action)
;; Grammar macros for "interrupted parses"
;; Uses interrupted-wrap and error-wrap from deriv.ss
(define-syntax !
(lambda (stx)
(raise-syntax-error #f "keyword ! used out of context" stx)))
(define-syntax ?
(lambda (stx)
(raise-syntax-error #f "keyword ? used out of context" stx)))
(define-syntax (productions/I stx)
(syntax-case stx ()
[(productions/I def ...)
#'(begin (production/I def) ...)]))
(define-for-syntax (partition-options/alternates forms)
(let loop ([forms forms] [options null] [alts null])
(if (pair? forms)
(syntax-case (car forms) ()
[(#:args . args)
(loop (cdr forms) (cons (cons #:args #'args) options) alts)]
[(#:skipped expr)
(loop (cdr forms) (cons (cons #:skipped #'expr) options) alts)]
[(#:no-interrupted)
(loop (cdr forms) (cons (cons #:no-interrupted #t) options) alts)]
[(#:no-wrap)
(loop (cdr forms) (cons (cons #:no-wrap #t) options) alts)]
[(#:no-wrap-error)
(loop (cdr forms) (cons (cons #:no-wrap-error #t) options) alts)]
[(kw . args)
(keyword? (syntax-e #'kw))
(raise-syntax-error #f "bad keyword" (car forms))]
[(pattern action)
(loop (cdr forms) options (cons (cons #'pattern #'action) alts))])
(values options (reverse alts)))))
(define-for-syntax (symbol+ . args)
(define (norm x)
(cond [(identifier? x) (norm (syntax-e x))]
[(string? x) x]
[(number? x) (number->string x)]
[(symbol? x) (symbol->string x)]))
(string->symbol (apply string-append (map norm args))))
(define-for-syntax (I symbol)
(syntax-local-introduce
(syntax-local-get-shadower (datum->syntax-object #f symbol))))
(define-for-syntax (elaborate-skipped-tail head tail action)
(define new-tail
(let loop ([parts tail])
(syntax-case parts (? !)
[() #'()]
[(! . parts-rest) (loop #'((! #f) . parts-rest))]
[((! expr) . parts-rest)
(with-syntax ([NoError (I 'NoError)]
[parts-rest (loop #'parts-rest)])
#'(NoError . parts-rest))]
[((? NT) . parts-rest)
(loop #'((? NT #f) . parts-rest))]
[((? NT expr) . parts-rest)
(loop #'(NT . parts-rest))]
[(part0 . parts-rest)
(identifier? #'part0)
(with-syntax ([part0/Skipped (I (symbol+ #'part0 '/Skipped))]
[parts-rest (loop #'parts-rest)])
#'(part0/Skipped . parts-rest))])))
(with-syntax ([head head]
[new-tail new-tail])
(cons #'(head . new-tail)
action)))
(define-for-syntax (elaborate-successful-alternate alt)
(define pattern (car alt))
(define action (cdr alt))
(cons (let loop ([parts pattern])
(syntax-case parts (? !)
[() #'()]
[(! . parts-rest)
(loop #'((! #f) . parts-rest))]
[((! expr) . parts-rest)
(with-syntax ([NoError (I 'NoError)]
[parts-rest (loop #'parts-rest)])
#'(NoError . parts-rest))]
[((? NT) . parts-rest)
(loop #'((? NT #f) . parts-rest))]
[((? NT expr) . parts-rest)
(with-syntax ([parts-rest (loop #'parts-rest)])
#'(NT . parts-rest))]
[(part0 . parts-rest)
(identifier? #'part0)
(with-syntax ([parts-rest (loop #'parts-rest)])
#'(part0 . parts-rest))]))
action))
(define-for-syntax (elaborate-interrupted-alternate alt wrap? wrap-error?)
(define pattern (car alt))
(define action (cdr alt))
(let loop ([parts pattern] [position 1])
(syntax-case parts (? !)
[()
;; Can't be interrupted
null]
[(! . parts-rest)
(loop #'((! #f) . parts-rest) position)]
[((! expr) . parts-rest)
(cons
;; Error occurs
(with-syntax ([Error (I 'syntax-error #;Error)]
[action action]
[position-argument (I (symbol+ '$ position))])
(elaborate-skipped-tail
#'Error
#'parts-rest
(if wrap-error?
#'(make-error-wrap position-argument expr action)
#'action)))
;; Error doesn't occur
(with-syntax ([NoError (I 'NoError)])
(loop #'(NoError . parts-rest) position)))]
[((? NT) . parts-rest)
(loop #'((? NT #f) . parts-rest) position)]
[((? NT expr) . parts-rest)
(cons
;; NT is interrupted
(with-syntax ([NT/I (I (symbol+ #'NT '/Interrupted))]
[action action])
(elaborate-skipped-tail
#'NT/I
#'parts-rest
(if wrap?
#'(make-interrupted-wrap expr action)
#'action)))
;; NT is not interrupted
(loop #'(NT . parts-rest) position))]
[(part0 . parts-rest)
(identifier? #'part0)
(map (lambda (clause) (cons #`(part0 . #,(car clause)) (cdr clause)))
(loop #'parts-rest (add1 position)))])))
(define-syntax (production/I stx)
(syntax-case stx ()
[(production/I (name form ...))
(let ()
(define-values (options alternates)
(partition-options/alternates (syntax->list #'(form ...))))
(define successful-alternates
(map elaborate-successful-alternate alternates))
(define interrupted-alternates
(apply append
(map (lambda (a)
(elaborate-interrupted-alternate a
(not (assq #:no-wrap options))
(not (assq #:no-wrap-error options))))
alternates)))
(with-syntax ([((success-pattern . success-action) ...)
successful-alternates]
[((interrupted-pattern . interrupted-action) ...)
interrupted-alternates]
[skip-spec (assq #:skipped options)]
[args-spec (assq #:args options)]
[name/Skipped (I (symbol+ #'name '/Skipped))]
[name/Interrupted (I (symbol+ #'name '/Interrupted))]
[%action ((syntax-local-certifier) #'%action)])
#`(begin
(productions
(name [success-pattern
(%action args-spec success-action)]
...)
(name/Skipped [() (%skipped args-spec skip-spec)]))
#,(if (and (not (assq #:no-interrupted options))
(pair? interrupted-alternates))
#'(productions
(name/Interrupted [interrupted-pattern
(%action args-spec interrupted-action)]
...))
#'(begin)))))]))
(define-syntax (skipped-token-values stx)
(syntax-case stx ()
[(skipped-token-values)
#'(begin)]
[(skipped-token-values name . more)
(identifier? #'name)
(with-syntax ([name/Skipped (I (symbol+ #'name '/Skipped))])
#'(begin (productions (name/Skipped [() #f]))
(skipped-token-values . more)))]
[(skipped-token-values (name value) . more)
(with-syntax ([name/Skipped (I (symbol+ #'name '/Skipped))])
#'(begin (productions (name/Skipped [() value]))
(skipped-token-values . more)))]))
(define-syntax (%skipped stx)
(syntax-case stx ()
[(%skipped args (#:skipped . expr))
#'(%action args expr)]
[(%skipped args #f)
#'(%action args #f)]))
(define-syntax (%action stx)
(syntax-case stx ()
[(elaborate-action (#:args . args) action)
#'(lambda args action)]
[(elaborate-action #f action)
#'action]))
)

7
collects/macro-debugger/syntax-browser.ss Normal file
View File

@ -0,0 +1,7 @@
(module syntax-browser mzscheme
(require "syntax-browser/syntax-browser.ss")
(provide browse-syntax
browse-syntaxes
syntax-snip))

69
collects/macro-debugger/syntax-browser/controller.ss Normal file
View File

@ -0,0 +1,69 @@
(module controller mzscheme
(require (lib "class.ss")
"interfaces.ss"
"partition.ss"
"properties.ss")
(provide syntax-controller%)
;; syntax-controller%
(define syntax-controller%
(class* object% (syntax-controller<%>
syntax-pp-snip-controller<%>
color-controller<%>)
(define colorers null)
(define selection-listeners null)
(define selected-syntax #f)
(init-field (properties-controller
(new independent-properties-controller% (controller this))))
;; syntax-controller<%> Methods
(define/public (select-syntax stx)
(set! selected-syntax stx)
(send properties-controller set-syntax stx)
(for-each (lambda (c) (send c select-syntax stx)) colorers)
(for-each (lambda (p) (p stx)) selection-listeners))
(define/public (get-selected-syntax)
selected-syntax)
(define/public (get-properties-controller) properties-controller)
(define/public (add-view-colorer c)
(set! colorers (cons c colorers))
(send c select-syntax selected-syntax))
(define/public (get-view-colorers) colorers)
(define/public (add-selection-listener p)
(set! selection-listeners (cons p selection-listeners)))
(define/public (on-update-identifier=? id=?)
(set! -secondary-partition
(and id=? (new partition% (relation id=?))))
(for-each (lambda (c) (send c refresh)) colorers))
(define/public (erase)
(set! colorers null))
;; syntax-pp-snip-controller<%> Methods
(define/public (on-select-syntax stx)
(select-syntax stx))
;; color-controller<%> Methods
(define -primary-partition (new-bound-partition))
(define -secondary-partition #f)
(define/public (get-primary-partition) -primary-partition)
(define/public (get-secondary-partition) -secondary-partition)
;; Initialization
(super-new)
))
)

34
collects/macro-debugger/syntax-browser/hrule-snip.ss Normal file
View File

@ -0,0 +1,34 @@
(module hrule-snip mzscheme
(require (lib "class.ss")
(lib "mred.ss" "mred"))
(provide hrule-snip%)
;; hrule-snip%
;; A snip for drawing horizontal separating lines.
(define hrule-snip%
(class snip%
(inherit get-admin)
(define/override (get-extent dc x y bw bh bdescent bspace blspace brspace)
(let-values [((h) (get-xheight dc))
((fw fh) (send dc get-size))]
(let ([ad-x (box 0)]
[ad-y (box 0)])
(send (get-admin) get-view-size ad-x ad-y)
#;(set-box?! bw fw)
(set-box?! bw (unbox ad-x))
(set-box?! bh h))))
(define/override (draw dc x y left top right bottom dx dy draw-caret)
(let* [(xh (get-xheight dc))
(ny (+ y (/ xh 2)))]
(send dc draw-line x ny right ny)))
(define/private (set-box?! b v)
(when (box? b) (set-box! b v)))
(define/private (get-xheight dc)
(or cached-xheight
(let-values [((w h descent extra) (send dc get-text-extent "x"))]
(set! cached-xheight h)
h)))
(define cached-xheight #f)
(super-new)))
)

123
collects/macro-debugger/syntax-browser/interfaces.ss Normal file
View File

@ -0,0 +1,123 @@
(module interfaces mzscheme
(require (lib "class.ss"))
(provide (all-defined))
;; syntax-controller<%>
;; A syntax-controller coordinates state shared by many different syntax views.
;; Syntax views can share:
;; - selection
;; - partitioning configuration
;; - property display
(define syntax-controller<%>
(interface ()
;; select-syntax : syntax -> void
select-syntax
;; get-selected-syntax : -> syntax/#f
get-selected-syntax
;; get-properties-controller : -> syntax-properties-controller<%>
get-properties-controller
;; add-view-colorer : syntax-colorer<%> -> void
add-view-colorer
;; get-view-colorers : -> (list-of syntax-colorer<%>)
get-view-colorers
;; add-selection-listener : syntax -> void
add-selection-listener
))
;; syntax-properties-controller<%>
(define syntax-properties-controller<%>
(interface ()
;; set-syntax : syntax -> void
set-syntax
;; show : boolean -> void
#;show
;; is-shown? : -> boolean
#;is-shown?))
;; syntax-configuration<%>
(define syntax-configuration<%>
(interface ()
;; get-primary-partition : -> partition<%>
get-primary-partition
;; get-secondary-partition : -> partition<%>
get-secondary-partition
;; update-identifier=? : ... -> void
update-identifier=?))
;; syntax-colorer<%>
(define syntax-colorer<%>
(interface ()
select-syntax
apply-styles))
;;----------
;; Convenience widget, specialized for displaying stx and not much else
(define syntax-browser<%>
(interface ()
add-syntax
add-text
add-separator
erase-all
select-syntax
get-text
))
(define partition<%>
(interface ()
;; get-partition : any -> number
get-partition
;; same-partition? : any any -> number
same-partition?
;; count : -> number
count))
;; Internal interfaces
(define syntax-pp-snip-controller<%>
(interface ()
on-select-syntax
))
(define color-controller<%>
(interface ()
get-primary-partition
get-secondary-partition
))
(define syntax-pp<%>
(interface ()
pretty-print-syntax
get-range
get-identifier-list
flat=>stx
stx=>flat))
(define typesetter<%>
(interface ()
get-output-port
get-current-position))
(define range<%>
(interface ()
get-start
set-start
get-ranges
add-range
all-ranges))
)

160
collects/macro-debugger/syntax-browser/partition.ss Normal file
View File

@ -0,0 +1,160 @@
(module partition mzscheme
(require (lib "class.ss")
(lib "boundmap.ss" "syntax")
(lib "stx.ss" "syntax")
"interfaces.ss")
(provide new-bound-partition
partition%
identifier=-choices)
(define (new-bound-partition)
#;(define p (new partition% (relation id:same-marks?)))
(define p (new bound-partition%))
(send p get-partition (datum->syntax-object #f 'no-marks))
p)
;; representative-symbol : symbol
;; Must be fresh---otherwise, using it could detect rename wraps
;; instead of only marks.
;; For example, in (lambda (representative) representative)
(define representative-symbol
(gensym 'representative))
;; unmarked-syntax : identifier
;; Has no marks---used to initialize bound partition so that
;; unmarked syntax always gets colored "black"
(define unmarked-syntax
(datum->syntax-object #f representative-symbol))
(define partition%
(class* object% (partition<%>)
(init relation)
(define related? relation)
(field (rep=>num (make-hash-table)))
(field (obj=>rep (make-hash-table 'weak)))
(field (reps null))
(field (next-num 0))
(define/public (get-partition obj)
(rep->partition (obj->rep obj)))
(define/public (same-partition? A B)
(= (get-partition A) (get-partition B)))
(define/private (obj->rep obj)
(hash-table-get obj=>rep obj (lambda () (obj->rep* obj))))
(define/public (count)
next-num)
(define/private (obj->rep* obj)
(let loop ([reps reps])
(cond [(null? reps)
(new-rep obj)]
[(related? obj (car reps))
(hash-table-put! obj=>rep obj (car reps))
(car reps)]
[else
(loop (cdr reps))])))
(define/private (new-rep rep)
(hash-table-put! rep=>num rep next-num)
(set! next-num (add1 next-num))
(set! reps (cons rep reps))
rep)
(define/private (rep->partition rep)
(hash-table-get rep=>num rep))
;; Nearly useless as it stands
(define/public (dump)
(hash-table-for-each
rep=>num
(lambda (k v)
(printf "~s => ~s~n" k v))))
(super-new)
))
;; bound-partition%
(define bound-partition%
(class* object% (partition<%>)
;; numbers : bound-identifier-mapping[identifier => number]
(define numbers (make-bound-identifier-mapping))
(define next-number 0)
(define/public (get-partition stx)
(let* ([r (representative stx)]
[n (bound-identifier-mapping-get numbers r (lambda _ #f))])
(or n
(begin0 next-number
(bound-identifier-mapping-put! numbers r next-number)
(set! next-number (add1 next-number))))))
(define/public (same-partition? a b)
(= (get-partition a) (get-partition b)))
(define/public (count)
next-number)
(define/private (representative stx)
(datum->syntax-object stx representative-symbol))
(super-new)))
;; Different identifier relations for highlighting.
(define (lift/rep id=?)
(lambda (A B)
(let ([ra (datum->syntax-object A representative-symbol)]
[rb (datum->syntax-object B representative-symbol)])
(id=? ra rb))))
(define (lift id=?)
(lambda (A B)
(and (identifier? A) (identifier? B) (id=? A B))))
;; id:same-marks? : syntax syntax -> boolean
(define id:same-marks?
(lift/rep bound-identifier=?))
;; id:X-module=? : identifier identifier -> boolean
;; If both module-imported, do they come from the same module?
;; If both top-bound, then same source.
(define (id:source-module=? a b)
(let ([ba (identifier-binding a)]
[bb (identifier-binding b)])
(cond [(or (eq? 'lexical ba) (eq? 'lexical bb))
(module-identifier=? a b)]
[(and (not ba) (not bb))
#t]
[(or (not ba) (not bb))
#f]
[else
(eq? (car ba) (car bb))])))
(define (id:nominal-module=? A B)
(let ([ba (identifier-binding A)]
[bb (identifier-binding B)])
(cond [(or (eq? 'lexical ba) (eq? 'lexical bb))
(module-identifier=? A B)]
[(or (not ba) (not bb))
(and (not ba) (not bb))]
[else (eq? (caddr ba) (caddr bb))])))
(define (symbolic-identifier=? A B)
(eq? (syntax-e A) (syntax-e B)))
(define identifier=-choices
(make-parameter
`(("<nothing>" . #f)
("bound-identifier=?" . ,bound-identifier=?)
("same marks" . ,id:same-marks?)
("module-identifier=?" . ,module-identifier=?)
("module-or-top-identifier=?" . ,module-or-top-identifier=?)
("symbolic-identifier=?" . ,symbolic-identifier=?)
("same source module" . ,id:source-module=?)
("same nominal module" . ,id:nominal-module=?))))
)

27
collects/macro-debugger/syntax-browser/prefs.ss Normal file
View File

@ -0,0 +1,27 @@
(module prefs mzscheme
(require (lib "framework.ss" "framework"))
(provide (all-defined))
(define current-syntax-font-size (make-parameter 16))
(define current-default-columns (make-parameter 40))
(define-syntax pref:get/set
(syntax-rules ()
[(_ get/set prop)
(define get/set
(case-lambda
[() (preferences:get 'prop)]
[(newval) (preferences:set 'prop newval)]))]))
(preferences:set-default 'SyntaxBrowser:Width 700 number?)
(preferences:set-default 'SyntaxBrowser:Height 600 number?)
(preferences:set-default 'SyntaxBrowser:PropertiesPanelPercentage 1/3 number?)
(preferences:set-default 'SyntaxBrowser:PropertiesPanelShown #t boolean?)
(pref:get/set pref:width SyntaxBrowser:Width)
(pref:get/set pref:height SyntaxBrowser:Height)
(pref:get/set pref:props-percentage SyntaxBrowser:PropertiesPanelPercentage)
(pref:get/set pref:props-shown? SyntaxBrowser:PropertiesPanelShown)
)

81
collects/macro-debugger/syntax-browser/pretty-helper.ss Normal file
View File

@ -0,0 +1,81 @@
(module pretty-helper mzscheme
(require (lib "class.ss")
"partition.ss")
(provide (all-defined))
;; Fixme: null object still confusable.
;; Problem: If stx1 and stx2 are two distinguishable syntax objects, it
;; still may be the case that (syntax-e stx1) and (syntax-e stx2) are
;; indistinguishable.
;; Solution: Rather than map stx to (syntax-e stx), in the cases where
;; (syntax-e stx) is confusable, map it to a different, unique, value.
;; - stx is identifier : map it to an uninterned symbol w/ same rep
;; (Symbols are useful: see pretty-print's style table)
;; - else : map it to a syntax-dummy object
(define-struct syntax-dummy (val))
;; syntax->datum/tables : stx [partition% num boolean]
;; -> (values s-expr hashtable hashtable)
;; When partition is not false, tracks the partititions that subterms belong to
;; When limit is a number, restarts processing with numbering? set to true
;; When numbering? is true, suffixes identifiers with partition numbers.
;;
;; Returns three values:
;; - an S-expression
;; - a hashtable mapping S-expressions to syntax objects
;; - a hashtable mapping syntax objects to S-expressions
;; Syntax objects which are eq? will map to same flat values
(define syntax->datum/tables
(case-lambda
[(stx) (table stx #f #f #f)]
[(stx partition limit numbering?) (table stx partition limit numbering?)]))
;; table : syntax partition%-or-#f num-or-#f -> (values s-expr hashtable hashtable)
(define (table stx partition limit numbering?)
(define (make-identifier-proxy id)
(let ([n (send partition get-partition id)])
(cond [(or (zero? n) (not numbering?))
(string->uninterned-symbol (symbol->string (syntax-e id)))]
[else
(string->uninterned-symbol
(format "~a:~a" (syntax-e id) n))])))
(let/ec escape
(let ([flat=>stx (make-hash-table)]
[stx=>flat (make-hash-table)])
(values (let loop ([obj stx])
(cond
[(hash-table-get stx=>flat obj (lambda _ #f))
=> (lambda (datum) datum)]
[(and partition (identifier? obj))
(let ([lp-datum (make-identifier-proxy obj)])
(when (and limit (> (send partition count) limit))
(call-with-values (lambda () (table stx partition #f #t))
escape))
(hash-table-put! flat=>stx lp-datum obj)
(hash-table-put! stx=>flat obj lp-datum)
lp-datum)]
[(syntax? obj)
(void (send partition get-partition obj))
(let ([lp-datum (loop (syntax-e obj))])
(hash-table-put! flat=>stx lp-datum obj)
(hash-table-put! stx=>flat obj lp-datum)
lp-datum)]
[(pair? obj)
(cons (loop (car obj))
(loop (cdr obj)))]
[(vector? obj)
(list->vector (map loop (vector->list obj)))]
[(symbol? obj)
#;(make-syntax-dummy obj)
(string->uninterned-symbol (symbol->string obj))]
[(number? obj)
(make-syntax-dummy obj)]
#;[(null? obj)
(make-syntax-dummy obj)]
[else obj]))
flat=>stx
stx=>flat))))
)

94
collects/macro-debugger/syntax-browser/pretty-printer.ss Normal file
View File

@ -0,0 +1,94 @@
(module pretty-printer mzscheme
(require (lib "list.ss")
(lib "class.ss")
(lib "pretty.ss")
(lib "mred.ss" "mred")
"pretty-range.ss"
"pretty-helper.ss"
"interfaces.ss"
"prefs.ss")
(provide syntax-pp%
(struct range (obj start end)))
;; syntax-pp%
;; Pretty printer for syntax objects.
(define syntax-pp%
(class* object% (syntax-pp<%>)
(init-field main-stx)
(init-field typesetter)
(init-field (primary-partition #f))
(init-field (columns (current-default-columns)))
(unless (syntax? main-stx)
(error 'syntax-snip% "got non-syntax object: ~s" main-stx))
(define datum #f)
(define ht:flat=>stx #f)
(define ht:stx=>flat #f)
(define identifier-list null)
(define -range #f)
(define/public (get-range) -range)
(define/public (get-identifier-list) identifier-list)
(define/public (flat=>stx obj)
(hash-table-get ht:flat=>stx obj))
(define/public (stx=>flat obj)
(hash-table-get ht:stx=>flat obj))
(define/public (pretty-print-syntax)
(define range (new ranges%))
(define (pp-pre-hook obj port)
(send range set-start obj (send typesetter get-current-position)))
(define (pp-post-hook obj port)
(let ([start (send range get-start obj)]
[end (send typesetter get-current-position)])
(when start
(send range add-range
(flat=>stx obj)
(cons start end)))))
(define (pp-size-hook obj display-like? port)
(cond [(is-a? obj editor-snip%)
columns]
[(syntax-dummy? obj)
(let ((ostring (open-output-string)))
((if display-like? display write) (syntax-dummy-val obj) ostring)
(string-length (get-output-string ostring)))]
[else #f]))
(define (pp-print-hook obj display-like? port)
(cond [(syntax-dummy? obj)
((if display-like? display write) (syntax-dummy-val obj) port)]
[(is-a? obj editor-snip%)
(write-special obj port)]
[else
(error 'pretty-print-hook "unexpected special value: ~e" obj)]))
(define (pp-extend-style-table)
(let* ([ids identifier-list]
[syms (map (lambda (x) (stx=>flat x)) ids)]
[like-syms (map syntax-e ids)])
(pretty-print-extend-style-table (pretty-print-current-style-table)
syms
like-syms)))
(parameterize
([pretty-print-pre-print-hook pp-pre-hook]
[pretty-print-post-print-hook pp-post-hook]
[pretty-print-size-hook pp-size-hook]
[pretty-print-print-hook pp-print-hook]
[pretty-print-columns columns]
[pretty-print-current-style-table (pp-extend-style-table)])
(pretty-print datum (send typesetter get-output-port))
(set! -range range)))
;; recompute-tables : -> void
(define/private (recompute-tables)
(set!-values (datum ht:flat=>stx ht:stx=>flat)
(syntax->datum/tables main-stx primary-partition 12 #f))
(set! identifier-list
(filter identifier? (hash-table-map ht:stx=>flat (lambda (k v) k)))))
;; Initialization
(recompute-tables)
(super-new)))
)

173
collects/macro-debugger/syntax-browser/properties.ss Normal file
View File

@ -0,0 +1,173 @@
(module properties mzscheme
(require "prefs.ss"
"interfaces.ss"
"partition.ss"
"util.ss"
(lib "class.ss")
(lib "mred.ss" "mred"))
(provide properties-view%
independent-properties-controller%)
;; independent-properties-controller%
(define independent-properties-controller%
(class* object% (syntax-properties-controller<%>)
(init-field controller)
;; Properties display
(define parent
(new frame% (label "Properties and Configuration") (height (pref:height))
(width (floor (* (pref:props-percentage) (pref:width))))))
(define choice (new choice% (label "identifer=?") (parent parent)
(choices (map car (identifier=-choices)))
(callback (lambda _ (on-update-identifier=?-choice)))))
(new message% (label " ") (parent parent))
(define pv (new properties-view% (parent parent)))
(define/private (show-properties)
(unless (send parent is-shown?)
(send parent show #t)))
(define/private (on-update-identifier=?-choice)
(let ([id=? (get-identifier=?)])
(send controller on-update-identifier=? id=?)))
(define/private (get-identifier=?)
(cond [(assoc (send choice get-string-selection)
(identifier=-choices))
=> cdr]
[else #f]))
(define/public (set-syntax stx)
(send pv set-syntax stx))
(define/public (show ?)
(send parent show ?))
(define/public (is-shown?)
(send parent is-shown?))
(super-new)))
;; properties-view%
(define properties-view%
(class* object% ()
(init parent)
(define selected-syntax #f)
(define tab-panel (new tab-panel%
(choices (list "Binding" "Source" "Properties"))
(parent parent)
(callback (lambda _ (refresh)))))
(define text (new text%))
(send text set-styles-sticky #f)
(define ecanvas (new editor-canvas% (editor text) (parent tab-panel)))
(define/public (set-syntax stx)
(set! selected-syntax stx)
(refresh))
(define/private (refresh)
(send* text
(lock #f)
(begin-edit-sequence)
(erase))
(when (syntax? selected-syntax)
(let ([s (send tab-panel get-item-label (send tab-panel get-selection))])
(cond [(equal? s "Binding")
(display-binding-info)]
[(equal? s "Source")
(display-source-info)]
[(equal? s "Properties")
(display-properties)])))
(send* text
(end-edit-sequence)
(lock #t)
(scroll-to-position 0)))
(define/private (display-binding-info)
(for-each (lambda (p) (display-binding-kv (car p) ((cdr p) selected-syntax)))
binding-properties))
(define/private (display-binding-kv k v)
(display (format "~a~n" k) key-sd)
(cond [(eq? v 'lexical)
(display "lexical\n" #f)]
[(eq? v #f)
(display "#f (top-level or unbound)\n" #f)]
[(list? v)
(display-subkv "source module" (mpi->string (list-ref v 0)))
(display-subkv "source id" (list-ref v 1))
(display-subkv "nom. module" (mpi->string (list-ref v 2)))
(display-subkv "nom. id" (list-ref v 3))
(if (list-ref v 4)
(display-subkv "phase" "via define-for-syntax"))]
[(void? v)
(display "Not applicable\n" n/a-sd)])
(display "\n" #f))
(define/private (display-subkv k v)
(display (format "~a: " k) sub-key-sd)
(display (format "~a~n" v) #f))
(define/private (display-source-info)
(for-each (lambda (p) (display-subkv (car p) ((cdr p) selected-syntax)))
source-properties))
(define/private (display-properties)
(let ([keys (syntax-property-symbol-keys selected-syntax)])
(if (null? keys)
(display "No properties available" n/a-sd)
(for-each (lambda (k) (display-kv k (syntax-property selected-syntax k)))
keys))))
(define/private (display-kv key value)
(display (format "~a~n" key) key-sd)
(display (format "~s~n~n" value) #f))
(define/private (display item sd)
(let ([p0 (send text last-position)])
(send text insert item)
(let ([p1 (send text last-position)])
(send text change-style sd p0 p1))))
(send text lock #t)
(super-new)))
;; lift/id : (identifier -> void) 'a -> void
(define (lift/id f)
(lambda (stx) (when (identifier? stx) (f stx))))
;; binding-properties : (listof (cons string (syntax -> any)))
(define binding-properties
(list (cons "identifier-binding"
(lift/id identifier-binding))
(cons "identifier-transformer-binding"
(lift/id identifier-transformer-binding))
(cons "identifier-template-binding"
(lift/id identifier-template-binding))))
;; source-properties : (listof (cons string (syntax -> any)))
(define source-properties
(list (cons "syntax-source" syntax-source)
(cons "syntax-source-module"
(lambda (stx) (mpi->string (syntax-source-module stx))))
(cons "syntax-line" syntax-line)
(cons "syntax-position" syntax-position)
(cons "syntax-span" syntax-span)
(cons "syntax-original?" syntax-original?)))
(define key-sd
(let ([sd (new style-delta%)])
(send sd set-delta-foreground "blue")
(send sd set-weight-on 'bold)
sd))
(define sub-key-sd
(let ([sd (new style-delta%)])
(send sd set-delta-foreground "blue")
sd))
(define n/a-sd
(let ([sd (new style-delta%)])
(send sd set-delta-foreground "gray")
sd))
)

154
collects/macro-debugger/syntax-browser/syntax-snip.ss Normal file
View File

@ -0,0 +1,154 @@
(module syntax-snip mzscheme
(require (lib "class.ss")
(lib "mred.ss" "mred")
"interfaces.ss"
"prefs.ss"
"properties.ss"
"typesetter.ss"
"widget.ss"
"partition.ss")
(provide syntax-snip%
super-syntax-snip%)
(define current-syntax-controller (make-parameter #f))
(define (the-syntax-controller)
(let ([controller (current-syntax-controller)])
(or controller
(let ([controller (new syntax-controller%)])
(current-syntax-controller controller)
controller))))
;; syntax-snip%
(define syntax-snip%
(class* editor-snip% ()
(init-field ((stx syntax)))
(init-field controller)
(define -outer (new text%))
(super-new (editor -outer))
;; Initialization
(send -outer begin-edit-sequence)
(initialize -outer)
(outer:insert "Syntax browser" style:bold)
(outer:insert " ")
(outer:insert "Clear" style:hyper
(lambda (x y z) (send controller select-syntax #f)))
(outer:insert " ")
(outer:insert "Properties" style:hyper
(lambda (x y z)
(send (send controller get-properties-controller)
show #t)))
(outer:insert "\n")
(new typesetter-for-text%
(syntax stx)
(controller controller)
(text -outer))
(send -outer lock #t)
(send -outer end-edit-sequence)
(send -outer hide-caret #t)
(define/public (initialize outer)
(void))
(define/private outer:insert
(case-lambda
[(obj)
(outer:insert obj style:normal)]
[(text style)
(outer:insert text style #f)]
[(text style clickback)
(let ([start (send -outer last-position)])
(send -outer insert text)
(let ([end (send -outer last-position)])
(send -outer change-style style start end #f)
(when clickback
(send -outer set-clickback start end clickback))))]))
;; snip% Methods
(define/override (copy)
(new syntax-snip% (controller controller) (syntax stx)))
))
(define subservient-syntax-snip%
(class syntax-snip%
(init-field f)
(define/override (initialize outer)
(f outer))
(super-new)))
(define style:normal (make-object style-delta% 'change-normal))
(define style:hyper
(let ([s (make-object style-delta% 'change-normal)])
(send s set-delta 'change-toggle-underline)
(send s set-delta-foreground "blue")
s))
(define style:bold
(let ([s (make-object style-delta% 'change-normal)])
(send s set-delta 'change-bold)
s))
(define (show-icon) (make-object image-snip% (build-path (collection-path "icons") "turn-up.png")))
(define (hide-icon) (make-object image-snip% (build-path (collection-path "icons") "turn-down.png")))
(define super-syntax-snip%
(class* editor-snip% ()
(init-field ((stx syntax)))
(init-field (controller (the-syntax-controller)))
(define -outer (new text%))
(super-new (editor -outer) (with-border? #f))
(define/private (hide-me)
(send* -outer
(lock #f)
(erase))
(outer:insert (show-icon) style:hyper (lambda _ (show-me)))
(outer:insert "#<syntax>")
(send -outer lock #t))
(define/private (show-me)
(send* -outer
(lock #f)
(erase))
(outer:insert (new subservient-syntax-snip%
(syntax stx)
(controller controller)
(f (lambda (t)
(let* ([start (send t last-position)]
[_ (send t insert (hide-icon))]
[end (send t last-position)])
(send t insert " ")
(send t change-style style:hyper start end #f)
(send t set-clickback start end (lambda _ (hide-me))))))))
(send* -outer
(lock #t)))
(define/private outer:insert
(case-lambda
[(obj)
(outer:insert obj style:normal)]
[(text style)
(outer:insert text style #f)]
[(text style clickback)
(let ([start (send -outer last-position)])
(send -outer insert text)
(let ([end (send -outer last-position)])
(send -outer change-style style start end #f)
(when clickback
(send -outer set-clickback start end clickback))))]))
(define/override (copy)
(new super-syntax-snip% (controller controller) (syntax stx)))
(hide-me)
(send -outer hide-caret #t)
(send -outer lock #t)
))
)

50
collects/macro-debugger/syntax-browser/util.ss Normal file
View File

@ -0,0 +1,50 @@
(module util mzscheme
(require (lib "class.ss"))
(provide with-unlock
mpi->string
mpi->list)
(define-syntax with-unlock
(syntax-rules ()
[(with-unlock text . body)
(let* ([t text]
[locked? (send t is-locked?)])
(send t lock #f)
(let () . body)
(send t lock locked?))]))
(define (mpi->string mpi)
(if (module-path-index? mpi)
(let ([mps (mpi->list mpi)])
(cond [(and (pair? mps) (pair? (cdr mps)))
(apply string-append
(format "~s" (car mps))
(map (lambda (x) (format " <= ~s" x)) (cdr mps)))]
[(and (pair? mps) (null? (cdr mps)))
(format "~s" (car mps))]
[(null? mps) "self"]))
(format "~s" mpi)))
(define (mpi->list mpi)
(if mpi
(let-values ([(path rel) (module-path-index-split mpi)])
(if (and (pair? path) (memq (car path) '(file lib planet)))
(cons path null)
(cons path (mpi->list rel))))
'()))
; ;; mpi->string : module-path-index -> string
; ;; Human-readable form of module-path-index
; (define (mpi->string x)
; (cond [(module-path-index? x)
; (let-values ([(path base) (module-path-index-split x)])
; (cond [(eq? path #f)
; "self module"]
; [(eq? base #f)
; (format "top-level => ~a" path)]
; [else
; (format "~a => ~a" (mpi->string base) path)]))]
; [else x]))
)

184
collects/macro-debugger/syntax-browser/widget.ss Normal file
View File

@ -0,0 +1,184 @@
(module widget mzscheme
(require "interfaces.ss"
"controller.ss"
"typesetter.ss"
"hrule-snip.ss"
"properties.ss"
"partition.ss"
"prefs.ss"
"util.ss"
(lib "list.ss")
(lib "class.ss")
(lib "framework.ss" "framework")
(lib "mred.ss" "mred"))
(provide syntax-controller%
syntax-widget%
syntax-browser-frame%)
;; syntax-widget%
;; A syntax-widget creates its own syntax-controller.
(define syntax-widget%
(class* object% (syntax-browser<%> syntax-properties-controller<%>)
(init parent)
(define -main-panel (new vertical-panel% (parent parent)))
(define -split-panel (new panel:horizontal-dragable% (parent -main-panel)))
(define -text (new text%))
(define -ecanvas (new editor-canvas% (parent -split-panel) (editor -text)))
(define -props-panel (new horizontal-panel% (parent -split-panel)))
(define props (new properties-view% (parent -props-panel)))
(define -saved-panel-percentages #f)
(define controller
(new syntax-controller%
(properties-controller this)))
#;(send -text hide-caret #t)
(send -text lock #t)
(send -split-panel set-percentages
(let ([pp (pref:props-percentage)]) (list (- 1 pp) pp)))
(toggle-props)
;; syntax-properties-controller<%> methods
(define/public (set-syntax stx)
(send props set-syntax stx))
(define/public (show ?)
(if ? (show-props) (hide-props)))
(define/public (is-shown?)
(send -props-panel is-shown?))
(define/public (toggle-props)
(if (send -props-panel is-shown?)
(hide-props)
(show-props)))
(define/public (hide-props)
(when (send -props-panel is-shown?)
(set! -saved-panel-percentages (send -split-panel get-percentages))
(send -split-panel delete-child -props-panel)
(send -props-panel show #f)))
(define/public (show-props)
(unless (send -props-panel is-shown?)
(send -split-panel add-child -props-panel)
(send -split-panel set-percentages -saved-panel-percentages)
(send -props-panel show #t)))
;;
(define/public (get-controller) controller)
;;
(define/public (get-main-panel) -main-panel)
(define/public (on-close)
(unless (= (cadr -saved-panel-percentages) (pref:props-percentage))
(pref:props-percentage (cadr -saved-panel-percentages))))
;; syntax-browser<%> Methods
(define/public (add-text text)
(with-unlock -text
(send -text insert text)))
(define/public add-syntax
(case-lambda
[(stx)
(internal-add-syntax stx null #f)]
[(stx hi-stxs hi-color)
(internal-add-syntax stx hi-stxs hi-color)]))
(define/public (add-separator)
(with-unlock -text
(send* -text
(insert (new hrule-snip%))
(insert "\n"))))
(define/public (erase-all)
(with-unlock -text (send -text erase))
(send controller erase))
(define/public (select-syntax stx)
(send controller select-syntax stx))
(define/public (get-text) -text)
(define/private (internal-add-syntax stx hi-stxs hi-color)
(with-unlock -text
(let ([current-position (send -text last-position)])
(let* ([new-ts (new typesetter-for-text%
(controller controller)
(syntax stx)
(text -text))]
[new-colorer (send new-ts get-colorer)])
(send* -text
(insert "\n")
(scroll-to-position current-position))
(unless (null? hi-stxs)
(send new-colorer highlight-syntaxes hi-stxs hi-color))))))
(super-new)))
;; syntax-widget/controls%
(define syntax-widget/controls%
(class* syntax-widget% ()
(inherit get-main-panel
get-controller
toggle-props)
(super-new)
(define -control-panel
(new horizontal-pane% (parent (get-main-panel)) (stretchable-height #f)))
;; Put the control panel up front
(send (get-main-panel) change-children
(lambda (children)
(cons -control-panel (remq -control-panel children))))
(define -identifier=-choices (identifier=-choices))
(define -choice
(new choice% (label "identifer=?") (parent -control-panel)
(choices (map car -identifier=-choices))
(callback (lambda _ (on-update-identifier=?-choice)))))
(new button%
(label "Clear")
(parent -control-panel)
(callback (lambda _ (send (get-controller) select-syntax #f))))
(new button%
(label "Properties")
(parent -control-panel)
(callback (lambda _ (toggle-props))))
(define/private (on-update-identifier=?-choice)
(let ([id=? (get-identifier=?)])
(send (get-controller) on-update-identifier=? id=?)))
(define/private (get-identifier=?)
(cond [(assoc (send -choice get-string-selection)
-identifier=-choices)
=> cdr]
[else #f]))))
;; syntax-browser-frame%
(define syntax-browser-frame%
(class* frame% ()
(super-new (label "Syntax Browser")
(width (pref:width))
(height (pref:height)))
(define widget (new syntax-widget/controls% (parent this)))
(define/public (get-widget) widget)
(define/augment (on-close)
(pref:width (send this get-width))
(pref:height (send this get-height))
(send widget on-close)
(preferences:save)
(inner (void) on-close))
))
)

87
collects/macro-debugger/view/cursor.ss Normal file
View File

@ -0,0 +1,87 @@
(module cursor mzscheme
(provide (all-defined))
;; Cursors
;; (define-struct cursor (v n))
;;
;; (define (cursor:new items)
;; (if (pair? items)
;; (make-cursor (list->vector items) 0)
;; (make-cursor #f #f)))
;;
;; (define (cursor:current c)
;; (when (cursor-n c)
;; (vector-ref (cursor-v c) (cursor-n c))))
;; (define (cursor:move-next c)
;; (when (cursor:can-move-next? c)
;; (set-cursor-n! c (add1 (cursor-n c)))))
;; (define (cursor:move-previous c)
;; (when (cursor:can-move-previous? c)
;; (set-cursor-n! c (sub1 (cursor-n c)))))
;; (define (cursor:move-to-start c)
;; (when (cursor-n c)
;; (set-cursor-n! c 0)))
;; (define (cursor:move-to-end c)
;; (when (cursor-n c)
;; (set-cursor-n! c (sub1 (vector-length (cursor-v c))))))
;;
;; (define (cursor:can-move-next? c)
;; (and (cursor-n c) (< (cursor-n c) (sub1 (vector-length (cursor-v c))))))
;;
;; (define (cursor:can-move-previous? c)
;; (and (cursor-n c) (> (cursor-n c) 0)))
(define-struct cursor (prefix suffixp))
(define (cursor-suffix c)
(if (promise? (cursor-suffixp c))
(force (cursor-suffixp c))
(cursor-suffixp c)))
(define set-cursor-suffix! set-cursor-suffixp!)
(define (cursor:new items)
(if (pair? items)
(make-cursor null items)
; A convenient lie
(make-cursor null (list #f))))
(define (cursor:current c)
(let ([suffix (cursor-suffix c)])
(car suffix)))
(define (cursor:move-to-start c)
(when (cursor:can-move-previous? c)
(cursor:move-previous c)
(cursor:move-to-start c)))
(define (cursor:move-to-end c)
(when (cursor:can-move-next? c)
(cursor:move-next c)
(cursor:move-to-end c)))
(define (cursor:move-previous c)
(when (pair? (cursor-prefix c))
(let ([old-prefix-cell (cursor-prefix c)])
(set-cursor-prefix! c (cdr old-prefix-cell))
(set-cdr! old-prefix-cell (cursor-suffix c))
(set-cursor-suffix! c old-prefix-cell))))
(define (cursor:move-next c)
(when (cursor:can-move-next? c)
(let ([old-suffix-cell (cursor-suffix c)])
(set-cursor-suffix! c (cdr old-suffix-cell))
(set-cdr! old-suffix-cell (cursor-prefix c))
(set-cursor-prefix! c old-suffix-cell))))
(define (cursor:can-move-next? c)
(pair? (cdr (cursor-suffix c))))
(define (cursor:can-move-previous? c)
(pair? (cursor-prefix c)))
)