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

changed macro-debugger to use v4 syntax (mostly)

Browse Source 
svn: r8544

original commit: 13a3c31ad5f63115427cfd34df285c0e981a8107
This commit is contained in:
Ryan Culpepper 2008-02-05 21:56:49 +00:00
parent e56b4cdb71
commit dae9aa6eee
46 changed files with 7062 additions and 7118 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,27 +1,24 @@
(module expand mzscheme
(require "model/trace.ss"
#lang scheme/base
(require "model/trace.ss"
"model/hide.ss")
(provide expand-only
(provide expand-only
expand/hide)
(define (expand-only stx show-list)
(define (expand-only stx show-list)
(define (show? id)
(ormap (lambda (x) (module-identifier=? id x))
(ormap (lambda (x) (free-identifier=? id x))
show-list))
(expand/hiding stx show?))
(define (expand/hide stx hide-list)
(define (expand/hide stx hide-list)
(define (show? id)
(andmap (lambda (x) (not (module-identifier=? id x)))
(andmap (lambda (x) (not (free-identifier=? id x)))
hide-list))
(expand/hiding stx show?))
(define (expand/hiding stx show?)
(define (expand/hiding stx show?)
(let-values ([(result deriv) (trace/result stx)])
(when (exn? result)
(raise result))
(let-values ([(_d estx) (hide/policy deriv show?)])
estx)))
)

89
collects/macro-debugger/model/context.ss
View File

@ -1,35 +1,35 @@
#lang scheme/base
(module context mzscheme
(require (lib "stx.ss" "syntax"))
(provide (struct ref (n))
(struct tail (n))
(require syntax/stx)
(provide (struct-out ref)
(struct-out tail)
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 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)
;; 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)
(define-struct pathseg () #:transparent)
(define-struct (ref pathseg) (n) #:transparent)
(define-struct (tail pathseg) (n) #:transparent)
;; path:ref->splicing-tail : PathSeg -> ???
;; ????
(define (path:ref->splicing-tail path)
;; 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)
;; path-get : syntax Path -> syntax
(define (path-get stx path)
(let loop ([stx stx] [path path])
(cond [(null? path) stx]
[(pair? path)
@ -37,24 +37,24 @@
[else
(error 'path-get "bad path: ~s" path)])))
;; pathseg-get : syntax PathSeg -> syntax
(define (pathseg-get stx 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)
;; 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)))
(syntax->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)
;; 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))
@ -62,8 +62,8 @@
(stx-cdr stx)
(loop (sub1 n) (stx-cdr stx)))))
;; path-replace : syntax Path syntax -> syntax
(define (path-replace stx path x)
;; path-replace : syntax Path syntax -> syntax
(define (path-replace stx path x)
(cond [(null? path) x]
[(pair? path)
(let ([pathseg0 (car path)])
@ -75,14 +75,14 @@
[else
(error 'path-replace "bad path: ~s" path)]))
;; pathseg-replace : syntax PathSeg syntax -> syntax
(define (pathseg-replace stx pathseg x)
;; 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)
;; 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))
@ -90,8 +90,8 @@
(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)
;; 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))
@ -99,29 +99,29 @@
(stx-replcdr stx x)
(stx-replcdr stx (loop (sub1 n) (stx-cdr stx))))))
;; stx-replcar : syntax syntax -> syntax
(define (stx-replcar stx x)
;; 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 (cdr (syntax-e stx))) stx stx)]
(datum->syntax stx (cons x (cdr (syntax-e stx))) stx stx)]
[else (raise-type-error 'stx-replcar "stx-pair" stx)]))
;; stx-replcdr : syntax syntax -> syntax
(define (stx-replcdr stx x)
;; 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 (car (syntax-e stx)) x) stx stx)]
(datum->syntax stx (cons (car (syntax-e stx)) x) stx stx)]
[else (raise-type-error 'stx-replcdr "stx-pair" stx)]))
(define (sd x)
(syntax-object->datum (datum->syntax-object #f x)))
(define (sd x)
(syntax->datum (datum->syntax #f x)))
;;=======
;;=======
;; find-subterm-paths : syntax syntax -> (list-of Path)
(define (find-subterm-paths subterm term)
;; 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)]
@ -139,4 +139,3 @@
(outer-loop term)))))]
;; FIXME: more structured cases here: box, vector, ...
[else null])))
)

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

@ -1,7 +1,8 @@
(module debug mzscheme
(require (lib "plt-match.ss"))
(require "trace.ss"
#lang scheme/base
(require scheme/match
"trace.ss"
"reductions.ss"
"deriv-util.ss"
"deriv-find.ss"
@ -10,13 +11,12 @@
"deriv.ss"
"steps.ss")
(provide (all-from "trace.ss")
(all-from "reductions.ss")
(all-from "deriv.ss")
(all-from "deriv-util.ss")
(all-from "deriv-find.ss")
(all-from "hiding-policies.ss")
(all-from "hide.ss")
(all-from "steps.ss")
(all-from (lib "plt-match.ss")))
)
(provide (all-from-out "trace.ss")
(all-from-out "reductions.ss")
(all-from-out "deriv.ss")
(all-from-out "deriv-util.ss")
(all-from-out "deriv-find.ss")
(all-from-out "hiding-policies.ss")
(all-from-out "hide.ss")
(all-from-out "steps.ss")
(all-from-out scheme/match))

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

@ -1,187 +1,184 @@
(module deriv-c mzscheme
(provide (all-defined))
#lang scheme/base
(provide (all-defined-out))
;; A Node(a) is:
;; (make-node a ?a)
(define-struct node (z1 z2) #f)
;; A Node(a) is:
;; (make-node a ?a)
(define-struct node (z1 z2) #:transparent)
;; A TopDeriv is one of
;; (make-lift-deriv <Node(Stx)> Deriv Stxs TopDeriv)
;; Deriv
;; A TopDeriv is one of
;; (make-lift-deriv <Node(Stx)> Deriv Stxs TopDeriv)
;; Deriv
;; A Deriv is one of
;; (make-mrule <Node(Stx)> Transformation Deriv)
;; PrimDeriv
(define-struct (deriv node) () #f)
(define-struct (lift-deriv deriv) (first lift-stx second) #f)
(define-struct (mrule deriv) (transformation next) #f)
;; A Deriv is one of
;; (make-mrule <Node(Stx)> Transformation Deriv)
;; PrimDeriv
(define-struct (deriv node) () #:transparent)
(define-struct (lift-deriv deriv) (first lift-stx second) #:transparent)
(define-struct (mrule deriv) (transformation next) #:transparent)
;; A DerivLL is one of
;; (make-lift/let-deriv <Node(Stx)> Deriv Stx Deriv)
;; Deriv
(define-struct (lift/let-deriv deriv) (first lift-stx second) #f)
;; A DerivLL is one of
;; (make-lift/let-deriv <Node(Stx)> Deriv Stx Deriv)
;; Deriv
(define-struct (lift/let-deriv deriv) (first lift-stx second) #:transparent)
;; A Transformation is
;; (make-transformation <Node(Stx)> Rs ?exn ?Stx (list-of LocalAction) ?exn ?Stx Number)
(define-struct (transformation node) (resolves ?1 me1 locals ?2 me2 seq) #f)
;; A Transformation is
;; (make-transformation <Node(Stx)> Rs ?exn ?Stx (list-of LocalAction) ?exn ?Stx Number)
(define-struct (transformation node) (resolves ?1 me1 locals ?2 me2 seq) #:transparent)
;; A LocalAction is one of
;; (make-local-expansion <Node(Stx)> Stx ?Stx Boolean Deriv)
;; (make-local-expansion/expr <Node(Stx)> Stx ?Stx Boolean ?Opaque Deriv)
;; (make-local-lift Stx Identifier)
;; (make-local-lift-end Stx)
;; (make-local-bind BindSyntaxes)
(define-struct (local-expansion node) (me1 me2 for-stx? inner) #f)
(define-struct (local-expansion/expr node) (me1 me2 for-stx? opaque inner) #f)
(define-struct local-lift (expr id) #f)
(define-struct local-lift-end (decl) #f)
(define-struct local-bind (bindrhs) #f)
;; A LocalAction is one of
;; (make-local-expansion <Node(Stx)> Stx ?Stx Boolean Deriv)
;; (make-local-expansion/expr <Node(Stx)> Stx ?Stx Boolean ?Opaque Deriv)
;; (make-local-lift Stx Identifier)
;; (make-local-lift-end Stx)
;; (make-local-bind BindSyntaxes)
(define-struct (local-expansion node) (me1 me2 for-stx? inner) #:transparent)
(define-struct (local-expansion/expr node) (me1 me2 for-stx? opaque inner) #:transparent)
(define-struct local-lift (expr id) #:transparent)
(define-struct local-lift-end (decl) #:transparent)
(define-struct local-bind (bindrhs) #:transparent)
;; Base = << Node(Stx) Rs ?exn >>
(define-struct (base deriv) (resolves ?1) #f)
;; Base = << Node(Stx) Rs ?exn >>
(define-struct (base deriv) (resolves ?1) #:transparent)
;; A PrimDeriv is one of
(define-struct (prule base) () #f)
(define-struct (p:variable prule) () #f)
;; A PrimDeriv is one of
(define-struct (prule base) () #:transparent)
(define-struct (p:variable prule) () #:transparent)
;; (make-p:module <Base> Boolean ?Deriv ?exn Deriv)
;; (make-p:#%module-begin <Base> ModulePass1 ModulePass2 ?exn)
(define-struct (p:module prule) (one-body-form? mb ?2 body) #f)
(define-struct (p:#%module-begin prule) (pass1 pass2 ?2) #f)
;; (make-p:module <Base> Boolean ?Deriv ?exn Deriv)
;; (make-p:#%module-begin <Base> ModulePass1 ModulePass2 ?exn)
(define-struct (p:module prule) (one-body-form? mb ?2 body) #:transparent)
(define-struct (p:#%module-begin prule) (pass1 pass2 ?2) #:transparent)
;; (make-p:define-syntaxes <Base> DerivLL)
;; (make-p:define-values <Base> Deriv)
(define-struct (p:define-syntaxes prule) (rhs ?2) #f)
(define-struct (p:define-values prule) (rhs) #f)
;; (make-p:define-syntaxes <Base> DerivLL)
;; (make-p:define-values <Base> Deriv)
(define-struct (p:define-syntaxes prule) (rhs ?2) #:transparent)
(define-struct (p:define-values prule) (rhs) #:transparent)
;; (make-p:#%expression <Base> Deriv)
;; (make-p:if <Base> Boolean Deriv Deriv Deriv)
;; (make-p:wcm <Base> Deriv Deriv Deriv)
;; (make-p:set! <Base> Rs Deriv)
;; (make-p:set!-macro <Base> Rs Deriv)
(define-struct (p:#%expression prule) (inner) #f)
(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)
;; (make-p:#%expression <Base> Deriv)
;; (make-p:if <Base> Boolean Deriv Deriv Deriv)
;; (make-p:wcm <Base> Deriv Deriv Deriv)
;; (make-p:set! <Base> Rs Deriv)
;; (make-p:set!-macro <Base> Rs Deriv)
(define-struct (p:#%expression prule) (inner) #:transparent)
(define-struct (p:if prule) (full? test then else) #:transparent)
(define-struct (p:wcm prule) (key mark body) #:transparent)
(define-struct (p:set! prule) (id-resolves rhs) #:transparent)
(define-struct (p:set!-macro prule) (deriv) #:transparent)
;; (make-p:#%app <Base> Stx LDeriv)
;; (make-p:begin <Base> LDeriv)
;; (make-p:begin0 <Base> Deriv LDeriv)
(define-struct (p:#%app prule) (tagged-stx lderiv) #f)
(define-struct (p:begin prule) (lderiv) #f)
(define-struct (p:begin0 prule) (first lderiv) #f)
;; (make-p:#%app <Base> Stx LDeriv)
;; (make-p:begin <Base> LDeriv)
;; (make-p:begin0 <Base> Deriv LDeriv)
(define-struct (p:#%app prule) (tagged-stx lderiv) #:transparent)
(define-struct (p:begin prule) (lderiv) #:transparent)
(define-struct (p:begin0 prule) (first lderiv) #:transparent)
;; (make-p:lambda <Base> LambdaRenames BDeriv)
;; (make-p:case-lambda <Base> (list-of CaseLambdaClause))
;; (make-p:let-values <Base> LetRenames (list-of Deriv) BDeriv)
;; (make-p:letrec-values <Base> LetRenames (list-of Deriv) BDeriv)
;; (make-p:letrec-syntaxes+values <Base> LSVRenames (list-of BindSyntaxes) (list-of Deriv) BDeriv)
(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:letrec-values prule) (renames rhss body) #f)
(define-struct (p:letrec-syntaxes+values prule) (srenames sbindrhss vrenames vrhss body) #f)
;; (make-p:lambda <Base> LambdaRenames BDeriv)
;; (make-p:case-lambda <Base> (list-of CaseLambdaClause))
;; (make-p:let-values <Base> LetRenames (list-of Deriv) BDeriv)
;; (make-p:letrec-values <Base> LetRenames (list-of Deriv) BDeriv)
;; (make-p:letrec-syntaxes+values <Base> LSVRenames (list-of BindSyntaxes) (list-of Deriv) BDeriv)
(define-struct (p:lambda prule) (renames body) #:transparent)
(define-struct (p:case-lambda prule) (renames+bodies) #:transparent)
(define-struct (p:let-values prule) (renames rhss body) #:transparent)
(define-struct (p:letrec-values prule) (renames rhss body) #:transparent)
(define-struct (p:letrec-syntaxes+values prule) (srenames sbindrhss vrenames vrhss body) #:transparent)
;; (make-p:stop <Base>)
;; (make-p:unknown <Base>)
;; (make-p:#%top <Base> Stx)
;; (make-p:#%datum <Base> Stx)
;; (make-p:quote <Base>)
;; (make-p:quote-syntax <Base>)
;; (make-p:require <Base>)
;; (make-p:require-for-syntax <Base>)
;; (make-p:require-for-template <Base>)
;; (make-p:provide <Base>)
(define-struct (p::STOP prule) () #f)
(define-struct (p:stop p::STOP) () #f)
(define-struct (p:unknown p::STOP) () #f)
(define-struct (p:#%top p::STOP) (tagged-stx) #f)
(define-struct (p:#%datum 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)
;; (make-p:stop <Base>)
;; (make-p:unknown <Base>)
;; (make-p:#%top <Base> Stx)
;; (make-p:#%datum <Base> Stx)
;; (make-p:quote <Base>)
;; (make-p:quote-syntax <Base>)
;; (make-p:require <Base>)
;; (make-p:require-for-syntax <Base>)
;; (make-p:require-for-template <Base>)
;; (make-p:provide <Base>)
(define-struct (p::STOP prule) () #:transparent)
(define-struct (p:stop p::STOP) () #:transparent)
(define-struct (p:unknown p::STOP) () #:transparent)
(define-struct (p:#%top p::STOP) (tagged-stx) #:transparent)
(define-struct (p:#%datum p::STOP) (tagged-stx) #:transparent)
(define-struct (p:quote p::STOP) () #:transparent)
(define-struct (p:quote-syntax p::STOP) () #:transparent)
(define-struct (p:require p::STOP) () #:transparent)
(define-struct (p:require-for-syntax p::STOP) () #:transparent)
(define-struct (p:require-for-template p::STOP) () #:transparent)
(define-struct (p:provide p::STOP) () #:transparent)
;;+ (make-p:rename <Base> Renames Deriv)
;;+ (make-p:synth <Base> (list-of SynthItem) ?exn)
(define-struct (p:rename prule) (renames inner) #f)
(define-struct (p:synth prule) (subterms ?2) #f)
;;+ (make-p:rename <Base> Renames Deriv)
;;+ (make-p:synth <Base> (list-of SynthItem) ?exn)
(define-struct (p:rename prule) (renames inner) #:transparent)
(define-struct (p:synth prule) (subterms ?2) #:transparent)
;; A LDeriv is
;; (make-lderiv <Node(Stxs)> ?exn (list-of Deriv))
(define-struct (lderiv node) (?1 derivs) #f)
;; A LDeriv is
;; (make-lderiv <Node(Stxs)> ?exn (list-of Deriv))
(define-struct (lderiv node) (?1 derivs) #:transparent)
;; A BDeriv is
;; (make-bderiv <Node(Stxs)> (list-of BRule) (U 'list 'letrec) LDeriv)
(define-struct (bderiv node) (pass1 trans pass2) #f)
;; A BDeriv is
;; (make-bderiv <Node(Stxs)> (list-of BRule) (U 'list 'letrec) LDeriv)
(define-struct (bderiv node) (pass1 trans pass2) #:transparent)
;; A BRule is one of
;; (make-b:error exn)
;; (make-b:expr BlockRenames Deriv)
;; (make-b:splice BlockRenames Deriv ?exn Stxs ?exn)
;; (make-b:defvals BlockRenames Deriv ?exn)
;; (make-b:defstx BlockRenames Deriv ?exn BindSyntaxes)
;;i (make-b:begin BlockRenames Deriv (list-of Deriv))
(define-struct b:error (?1) #f)
(define-struct brule (renames) #f)
(define-struct (b:expr brule) (head) #f)
(define-struct (b:splice brule) (head ?1 tail ?2) #f)
(define-struct (b:defvals brule) (head ?1) #f)
(define-struct (b:defstx brule) (head ?1 bindrhs) #f)
;;(define-struct (b:begin brule) (head inner) #f)
;; A BRule is one of
;; (make-b:error exn)
;; (make-b:expr BlockRenames Deriv)
;; (make-b:splice BlockRenames Deriv ?exn Stxs ?exn)
;; (make-b:defvals BlockRenames Deriv ?exn)
;; (make-b:defstx BlockRenames Deriv ?exn BindSyntaxes)
;;i (make-b:begin BlockRenames Deriv (list-of Deriv))
(define-struct b:error (?1) #:transparent)
(define-struct brule (renames) #:transparent)
(define-struct (b:expr brule) (head) #:transparent)
(define-struct (b:splice brule) (head ?1 tail ?2) #:transparent)
(define-struct (b:defvals brule) (head ?1) #:transparent)
(define-struct (b:defstx brule) (head ?1 bindrhs) #:transparent)
;;(define-struct (b:begin brule) (head inner) #:transparent)
;; A BindSyntaxes is
;; (make-bind-syntaxes DerivLL ?exn)
(define-struct bind-syntaxes (rhs ?1) #f)
;; A BindSyntaxes is
;; (make-bind-syntaxes DerivLL ?exn)
(define-struct bind-syntaxes (rhs ?1) #:transparent)
;; A CaseLambdaClause is
;; (make-clc ?exn CaseLambdaRename BDeriv)
(define-struct clc (?1 renames body) #f)
;; A CaseLambdaClause is
;; (make-clc ?exn CaseLambdaRename BDeriv)
(define-struct clc (?1 renames body) #:transparent)
;; A BlockRename is (cons Stx Stx)
;; A BlockRename is (cons Stx Stx)
;; A ModPass1 is (list-of ModRule1)
;; A ModPass2 is (list-of ModRule2)
;; A ModPass1 is (list-of ModRule1)
;; A ModPass2 is (list-of ModRule2)
;; A ModRule1 is one of
;; (make-mod:prim Deriv ModPrim)
;; (make-mod:splice Deriv ?exn Stxs)
;; (make-mod:lift Deriv Stxs)
;; (make-mod:lift-end Stxs)
;; A ModRule2 is one of
;; (make-mod:skip)
;; (make-mod:cons Deriv)
;; (make-mod:lift Deriv Stxs)
(define-struct modrule () #f)
(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 ?1 tail) #f)
(define-struct (mod:lift modrule) (head tail) #f)
(define-struct (mod:lift-end modrule) (tail) #f)
;; A ModRule1 is one of
;; (make-mod:prim Deriv ModPrim)
;; (make-mod:splice Deriv ?exn Stxs)
;; (make-mod:lift Deriv Stxs)
;; (make-mod:lift-end Stxs)
;; A ModRule2 is one of
;; (make-mod:skip)
;; (make-mod:cons Deriv)
;; (make-mod:lift Deriv Stxs)
(define-struct modrule () #:transparent)
(define-struct (mod:cons modrule) (head) #:transparent)
(define-struct (mod:prim modrule) (head prim) #:transparent)
(define-struct (mod:skip modrule) () #:transparent)
(define-struct (mod:splice modrule) (head ?1 tail) #:transparent)
(define-struct (mod:lift modrule) (head tail) #:transparent)
(define-struct (mod:lift-end modrule) (tail) #:transparent)
;; A ModPrim is a PRule in:
;; (make-p:define-values <Base> #f)
;; (make-p:define-syntaxes <Base> Deriv)
;; (make-p:require <Base>)
;; (make-p:require-for-syntax <Base>)
;; (make-p:require-for-template <Base>)
;; (make-p:provide <Base>)
;; #f
;; A ModPrim is a PRule in:
;; (make-p:define-values <Base> #:transparent)
;; (make-p:define-syntaxes <Base> Deriv)
;; (make-p:require <Base>)
;; (make-p:require-for-syntax <Base>)
;; (make-p:require-for-template <Base>)
;; (make-p:provide <Base>)
;; #f
;; A SynthItem is one of
;; - (make-s:subterm Path Deriv)
;; - (make-s:rename Path Stx Stx)
(define-struct subitem () #f)
(define-struct (s:subterm subitem) (path deriv) #f)
(define-struct (s:rename subitem) (path before after) #f)
)
;; A SynthItem is one of
;; - (make-s:subterm Path Deriv)
;; - (make-s:rename Path Stx Stx)
(define-struct subitem () #:transparent)
(define-struct (s:subterm subitem) (path deriv) #:transparent)
(define-struct (s:rename subitem) (path before after) #:transparent)

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

@ -1,47 +1,48 @@
(module deriv-parser mzscheme
(require "yacc-ext.ss"
#lang scheme/base
(require (for-syntax scheme/base)
"yacc-ext.ss"
"yacc-interrupted.ss"
"deriv.ss"
"deriv-util.ss"
"deriv-tokens.ss")
(provide parse-derivation)
(provide parse-derivation)
(define (deriv-error ok? name value start end)
(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
;; PARSER
(define (parse-derivation x)
(define (parse-derivation x)
(parameterize ((current-sequence-number 0))
(parse-derivation* x)))
(define current-sequence-number (make-parameter #f))
(define (new-sequence-number)
(define current-sequence-number (make-parameter #f))
(define (new-sequence-number)
(let ([seq (current-sequence-number)])
(current-sequence-number (add1 seq))
seq))
(define-struct (exn:eval exn) (deriv))
(define empty-cms
(define-struct (exn:eval exn) (deriv))
(define empty-cms
(call-with-continuation-prompt (lambda () (current-continuation-marks))))
(define (create-eval-exn deriv)
(define (create-eval-exn deriv)
(make-exn:eval "exception during evaluation"
empty-cms
deriv))
(define-production-splitter production/I values values)
(define-production-splitter production/I values values)
(define-syntax (productions/I stx)
(define-syntax (productions/I stx)
(syntax-case stx ()
[(productions/I def ...)
#'(begin (production/I def) ...)]))
(define parse-derivation*
(define parse-derivation*
(parser
(options (start Expansion)
(src-pos)
@ -576,5 +577,3 @@
[(next (? EE) (? EL*)) (cons $2 $3)])
)))
)

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

@ -1,10 +1,10 @@
(module deriv-tokens mzscheme
(require (lib "lex.ss" "parser-tools")
#lang scheme/base
(require parser-tools/lex
"deriv.ss")
(provide (all-defined))
(provide (all-defined-out))
(define-tokens basic-tokens
(define-tokens basic-tokens
(start ; .
visit ; syntax
resolve ; identifier
@ -49,7 +49,7 @@
IMPOSSIBLE ; useful for error-handling clauses that have no NoError counterpart
))
(define-tokens renames-tokens
(define-tokens renames-tokens
(renames-lambda ; (cons syntax syntax)
renames-case-lambda ; (cons syntax syntax)
renames-let ; (cons (listof syntax) syntax)
@ -57,8 +57,8 @@
renames-block ; (cons syntax syntax) ... different, contains both pre+post
))
;; Empty tokens
(define-tokens prim-tokens
;; Empty tokens
(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
@ -70,9 +70,9 @@
prim-expression
))
;; ** Signals to tokens
;; ** Signals to tokens
(define signal-mapping
(define signal-mapping
`((EOF . EOF)
(error . ,token-syntax-error)
(0 . ,token-visit)
@ -144,7 +144,7 @@
(141 . ,token-start)
))
(define (tokenize sig-n val pos)
(define (tokenize sig-n val pos)
(let ([p (assv sig-n signal-mapping)])
(if (pair? p)
(make-position-token
@ -154,7 +154,5 @@
pos)
(error 'tokenize "bad signal: ~s" sig-n))))
(define (signal->symbol sig-n)
(define (signal->symbol sig-n)
(cdr (assv sig-n signal-mapping)))
)

48
collects/macro-debugger/model/deriv-util.ss
View File

@ -1,11 +1,12 @@
(module deriv-util mzscheme
(require "deriv.ss"
(lib "list.ss")
(lib "plt-match.ss"))
(require-for-syntax (lib "scheme/private/struct-info.ss"))
#lang scheme/base
(require (for-syntax scheme/base)
(for-syntax scheme/private/struct-info)
scheme/list
scheme/match
"deriv.ss")
(provide make
(provide make
Wrap
@ -21,56 +22,56 @@
wderivlist-es2)
;; Wrap matcher
;; Matches unwrapped, interrupted wrapped, or error wrapped
(define-match-expander Wrap
;; Wrap matcher
;; Matches unwrapped, interrupted wrapped, or error wrapped
(define-match-expander Wrap
(lambda (stx)
(syntax-case stx ()
[(Wrap S (var ...))
(syntax/loc stx (struct S (var ...)))])))
;; ----
;; ----
(define (check sym pred type x)
(define (check sym pred type x)
(unless (pred x)
(raise-type-error sym type x)))
(define (ok-node? x)
(define (ok-node? x)
(check 'ok-node? node? "node" x)
(and (node-z1 x) #t))
(define (interrupted-node? x)
(define (interrupted-node? x)
(check 'interrupted-node? node? "node" x)
(not (node-z2 x)))
(define (wderiv-e1 x)
(define (wderiv-e1 x)
(check 'wderiv-e1 deriv? "deriv" x)
(node-z1 x))
(define (wderiv-e2 x)
(define (wderiv-e2 x)
(check 'wderiv-e2 deriv? "deriv" x)
(node-z2 x))
(define (wlderiv-es1 x)
(define (wlderiv-es1 x)
(check 'wlderiv-es1 lderiv? "lderiv" x)
(node-z1 x))
(define (wlderiv-es2 x)
(define (wlderiv-es2 x)
(check 'wlderiv-es2 lderiv? "lderiv" x)
(node-z2 x))
(define (wbderiv-es1 x)
(define (wbderiv-es1 x)
(check 'wbderiv-es1 bderiv? "bderiv" x)
(node-z1 x))
(define (wbderiv-es2 x)
(define (wbderiv-es2 x)
(check 'wbderiv-es2 bderiv? "bderiv" x))
;; wderivlist-es2 : (list-of WDeriv) -> (list-of Stx)/#f
(define (wderivlist-es2 xs)
;; wderivlist-es2 : (list-of WDeriv) -> (list-of Stx)/#f
(define (wderivlist-es2 xs)
(let ([es2 (map wderiv-e2 xs)])
(and (andmap syntax? es2) es2)))
;; ----
;; ----
(define-syntax (make stx)
(define-syntax (make stx)
(syntax-case stx ()
[(make S expr ...)
(unless (identifier? #'S)
@ -97,4 +98,3 @@
stx)))
(with-syntax ([constructor constructor])
#'(constructor expr ...)))]))
)

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

@ -1,36 +1,34 @@
(module deriv mzscheme
(require (lib "contract.ss")
(lib "stx.ss" "syntax")
#lang scheme/base
(require scheme/contract
syntax/stx
"deriv-c.ss")
;; NO CONTRACTS
(provide (all-from-out "deriv-c.ss"))
#;(provide (all-from "deriv-c.ss"))
#|
;; CONTRACTS
(define (?? c) (or/c c false/c))
(define (?? c) (or/c c false/c))
(define (stx? x)
(define (stx? x)
(or (syntax? x)
(and (pair? x) (stx? (car x)) (stx? (cdr x)))
(null? x)))
(define (stx-list-like? x)
(define (stx-list-like? x)
(let ([x (stx->list x)])
(and x (andmap syntax? x))))
(define syntax/f (?? syntax?))
(define syntaxes/c stx-list-like?)
(define syntaxes/f (?? syntaxes/c))
(define resolves/c (listof identifier?))
(define syntax/f (?? syntax?))
(define syntaxes/c stx-list-like?)
(define syntaxes/f (?? syntaxes/c))
(define resolves/c (listof identifier?))
(define localaction/c
(define localaction/c
(or/c local-expansion? local-expansion/expr? local-lift?
local-lift-end? local-bind?))
(provide/contract
(provide/contract
(struct node
([z1 any/c]
[z2 any/c]))
@ -366,5 +364,5 @@
(struct (s:rename subitem)
([path any/c]
[before syntax?]
[after syntax?]))
))
[after syntax?])))
|#

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

@ -1,55 +1,57 @@
(module hiding-policies mzscheme
(require (lib "plt-match.ss")
(lib "boundmap.ss" "syntax"))
(provide (all-defined))
#lang scheme/base
(require (for-syntax scheme/base)
scheme/match
syntax/boundmap)
(provide (all-defined-out))
(define-struct hiding-policy
(opaque-modules opaque-ids opaque-kernel opaque-libs transparent-ids))
(define-struct hiding-policy
(opaque-modules opaque-ids opaque-kernel opaque-libs transparent-ids)
#:mutable)
(define (policy-hide-module p m)
(define (policy-hide-module p m)
(hash-table-put! (hiding-policy-opaque-modules p) m #t))
(define (policy-unhide-module p m)
(define (policy-unhide-module p m)
(hash-table-remove! (hiding-policy-opaque-modules p) m))
(define (policy-hide-kernel p)
(define (policy-hide-kernel p)
(set-hiding-policy-opaque-kernel! p #t))
(define (policy-unhide-kernel p)
(define (policy-unhide-kernel p)
(set-hiding-policy-opaque-kernel! p #f))
(define (policy-hide-libs p)
(define (policy-hide-libs p)
(set-hiding-policy-opaque-libs! p #t))
(define (policy-unhide-libs p)
(define (policy-unhide-libs p)
(set-hiding-policy-opaque-libs! p #f))
(define (policy-hide-id p id)
(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)
(define (policy-unhide-id p id)
(module-identifier-mapping-put! (hiding-policy-opaque-ids p) id #f))
(define (policy-show-id p id)
(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)
(define (policy-unshow-id p id)
(module-identifier-mapping-put! (hiding-policy-transparent-ids p) id #f))
(define (new-hiding-policy)
(define (new-hiding-policy)
(make-hiding-policy (make-hash-table)
(make-module-identifier-mapping)
#f
#f
(make-module-identifier-mapping)))
(define (new-standard-hiding-policy)
(define (new-standard-hiding-policy)
(let ([p (new-hiding-policy)])
(policy-hide-kernel p)
(policy-hide-libs p)
p))
;; ---
;; ---
(define-syntax inline
(define-syntax inline
(syntax-rules ()
[(inline ([name expr] ...) . body)
(let-syntax ([name
@ -58,9 +60,9 @@
[xx (identifier? #'xx) #'expr]))] ...)
. body)]))
(define (/false) #f)
(define (/false) #f)
(define (policy-show-macro? policy id)
(define (policy-show-macro? policy id)
(match policy
[(struct hiding-policy (opaque-modules
opaque-identifiers
@ -91,10 +93,9 @@
(or transparent-id
not-opaque-id))))]))
(define (lib-module? mpi)
(define (lib-module? mpi)
(and (module-path-index? mpi)
(let-values ([(path rel) (module-path-index-split mpi)])
(cond [(pair? path) (memq (car path) '(lib planet))]
[(string? path) (lib-module? rel)]
[else #f]))))
)

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

@ -1,16 +1,14 @@
;; FIXME: Steps are pairs of Configurations
;; Configurations contain contexts, definites, etc.
#lang scheme/base
(module reductions-engine mzscheme
(require (lib "list.ss")
(require (for-syntax scheme/base)
scheme/list
scheme/contract
"deriv.ss"
"stx-util.ss"
"steps.ss")
(require (lib "contract.ss"))
(provide (all-from "steps.ss"))
(provide context
(provide (all-from-out "steps.ss")
context
big-context
current-derivation
current-definites
@ -33,41 +31,45 @@
CC
R
revappend)
(provide walk
revappend
walk
walk/foci
walk/mono
stumble
stumble/E)
;; context: parameter of Context
(define context (make-parameter null))
;; FIXME: Steps are pairs of Configurations
;; Configurations contain contexts, definites, etc.
;; big-context: parameter of BigContext
(define big-context (make-parameter null))
;; context: parameter of Context
(define context (make-parameter null))
;; current-derivation : parameter of Derivation
(define current-derivation (make-parameter #f))
;; big-context: parameter of BigContext
(define big-context (make-parameter null))
;; current-definites : parameter of (list-of identifier)
(define current-definites (make-parameter null))
;; current-derivation : parameter of Derivation
(define current-derivation (make-parameter #f))
;; current-frontier : parameter of (list-of syntax)
(define current-frontier (make-parameter null))
;; current-definites : parameter of (list-of identifier)
(define current-definites (make-parameter null))
(define-syntax with-context
;; current-frontier : parameter of (list-of syntax)
(define current-frontier (make-parameter null))
(define-syntax with-context
(syntax-rules ()
[(with-context f . body)
(let ([c (context)])
(parameterize ([context (cons f c)])
(let () . body)))]))
(define-syntax with-derivation
(define-syntax with-derivation
(syntax-rules ()
[(with-derivation d . body)
(parameterize ((current-derivation d)) . body)]))
(define-syntax with-new-local-context
(define-syntax with-new-local-context
(syntax-rules ()
[(with-new-local-context e . body)
(parameterize ([big-context
@ -76,45 +78,45 @@
[context null])
. body)]))
(define (learn-definites ids)
(define (learn-definites ids)
(current-definites
(append ids (current-definites))))
(define (get-frontier) (or (current-frontier) null))
(define (get-frontier) (or (current-frontier) null))
(define (add-frontier stxs)
(define (add-frontier stxs)
(current-frontier
(let ([frontier0 (current-frontier)])
(and frontier0 (append stxs frontier0)))))
(define (blaze-frontier stx)
(define (blaze-frontier stx)
(current-frontier
(let ([frontier0 (current-frontier)])
(and frontier0
(remq stx frontier0)))))
;; -----------------------------------
;; -----------------------------------
;; RS: The "reductions monad"
;; (RS a) = (values ReductionSequence ?a ?exn)
;; Not a proper monad, because of 'values'
;; RS: The "reductions monad"
;; (RS a) = (values ReductionSequence ?a ?exn)
;; Not a proper monad, because of 'values'
(define-syntax ->RS/c
(define-syntax ->RS/c
(syntax-rules ()
[(->RS/c domain-c ...)
(-> domain-c ...
(values (listof protostep?) any/c (or/c exn? false/c)))]))
(define/contract RSzero
(define/contract RSzero
(->RS/c)
(lambda () (values null #f #f)))
(define/contract RSunit
(define/contract RSunit
(->RS/c any/c)
(lambda (v)
(values null v #f)))
(define/contract RSbind
(define/contract RSbind
(->RS/c (->RS/c) (->RS/c any/c))
(lambda (a f)
(let-values ([(rseq1 final1 exn1) (a)])
@ -123,12 +125,12 @@
(values (append rseq1 rseq2) final2 exn2))
(values rseq1 final1 exn1)))))
(define/contract RSseq
(define/contract RSseq
(->RS/c (->RS/c) (->RS/c))
(lambda (a b)
(RSbind a (lambda (_) (b)))))
(define/contract RSforeach
(define/contract RSforeach
(->RS/c (->RS/c any/c) (listof any/c))
(lambda (f xs)
(let loop ([xs xs])
@ -137,54 +139,54 @@
(lambda () (loop (cdr xs))))
(RSunit (void))))))
(define/contract RSadd
(define/contract RSadd
(->RS/c (listof protostep?) (->RS/c))
(lambda (steps a)
(let-values ([(rseq1 final1 exn1) (a)])
(values (append steps rseq1) final1 exn1))))
(define-syntax RS-steps
(define-syntax RS-steps
(syntax-rules ()
[(RS-steps expr)
(let-values ([(rseq final exn) expr])
rseq)]))
;; CC
;; the context constructor
(define-syntax (CC stx)
;; CC
;; the context constructor
(define-syntax (CC stx)
(syntax-case stx ()
[(CC HOLE expr pattern)
#'(syntax-copier HOLE expr pattern)]))
;; (R stx R-clause ...)
;; An R-clause is one of
;; [! expr]
;; [#:pattern pattern]
;; [#:bind pattern stx-expr]
;; [#:let-values (var ...) expr]
;; [#:set-syntax stx-expr]
;; [#:walk term2 foci1 foci2 description]
;; [#:walk term2 description]
;; [#:rename form2 foci1 foci2 description]
;; [#:rename/no-step pattern stx stx]
;; [#:reductions expr]
;; [#:learn ids]
;; [#:frontier stxs]
;; [#:when test R-clause ...]
;; [#:if/np test R-clause ...]
;; [generator hole fill]
;; (R stx R-clause ...)
;; An R-clause is one of
;; [! expr]
;; [#:pattern pattern]
;; [#:bind pattern stx-expr]
;; [#:let-values (var ...) expr]
;; [#:set-syntax stx-expr]
;; [#:walk term2 foci1 foci2 description]
;; [#:walk term2 description]
;; [#:rename form2 foci1 foci2 description]
;; [#:rename/no-step pattern stx stx]
;; [#:reductions expr]
;; [#:learn ids]
;; [#:frontier stxs]
;; [#:when test R-clause ...]
;; [#:if/np test R-clause ...]
;; [generator hole fill]
;; R
;; the threaded reductions engine
;; R
;; the threaded reductions engine
;; (R form . clauses) : (values (list-of Step) ?stx ?exn)
;; (R form . clauses) : (values (list-of Step) ?stx ?exn)
(define-syntax R
(define-syntax R
(syntax-rules ()
[(R form . clauses)
(R** #f _ [#:set-syntax form] . clauses)]))
(define-syntax R**
(define-syntax R**
(syntax-rules (! =>)
;; Base: done
[(R** form-var pattern)
@ -302,18 +304,18 @@
(Run f p generator hole fill k))]))
(define-syntax Run
(define-syntax Run
(syntax-rules ()
[(Run f p generator hole fill k)
(let ([reducer (with-syntax ([p f]) (generator))])
(Run* reducer f p hole fill k))]))
(define-syntax (Run* stx)
(define-syntax (Run* stx)
(syntax-case stx ()
;; Implementation of subterm handling for (hole ...) sequences
[(Run* f form-var pattern (hole :::) fills k)
(and (identifier? #':::)
(module-identifier=? #'::: (quote-syntax ...)))
(free-identifier=? #'::: (quote-syntax ...)))
#'(let ([ctx (CC (hole :::) form-var pattern)])
(let ([e1s (with-syntax ([pattern form-var]) (syntax->list #'(hole :::)))])
(run-multiple f ctx fills e1s k)))]
@ -322,10 +324,10 @@
#'(let ([ctx (CC hole form-var pattern)])
(run-one f ctx fill k))]))
;; run-multiple : (a -> RS(b)) ((list-of b) -> c) (list-of a) (list-of b) (c -> RS(d))
;; -> RS(d)
;; For example: a = Deriv; b = c = d = Syntax
(define (run-multiple f ctx fills suffix k)
;; run-multiple : (a -> RS(b)) ((list-of b) -> c) (list-of a) (list-of b) (c -> RS(d))
;; -> RS(d)
;; For example: a = Deriv; b = c = d = Syntax
(define (run-multiple f ctx fills suffix k)
(let loop ([fills fills] [prefix null] [suffix suffix])
(cond
[(pair? fills)
@ -341,22 +343,22 @@
(let ([form (ctx (reverse prefix))])
(k form))])))
;; run-one : (a -> RS(b)) (b -> c) (c -> RS(d)) -> RS(d)
(define (run-one f ctx fill k)
;; run-one : (a -> RS(b)) (b -> c) (c -> RS(d)) -> RS(d)
(define (run-one f ctx fill k)
(RSbind (lambda () (with-context ctx (f fill)))
(lambda (final)
(k (ctx final)))))
;; Rename mapping
;; Rename mapping
(define (rename-frontier from to)
(define (rename-frontier from to)
(current-frontier
(with-handlers ([exn:fail? (lambda _ #f)])
(apply append
(map (make-rename-mapping from to)
(current-frontier))))))
(define (make-rename-mapping from0 to0)
(define (make-rename-mapping from0 to0)
(define table (make-hash-table))
(let loop ([from from0] [to to0])
(cond [(syntax? from)
@ -367,9 +369,9 @@
[(pair? from)
#;(unless (pair? to)
(fprintf (current-error-port)
"from:\n~s\n\n" (syntax-object->datum from0))
"from:\n~s\n\n" (syntax->datum from0))
(fprintf (current-error-port)
"to:\n~s\n\n" (syntax-object->datum to0))
"to:\n~s\n\n" (syntax->datum to0))
(error 'frontier-renaming))
(loop (car from) (car to))
(loop (cdr from) (cdr to))]
@ -386,7 +388,7 @@
(begin #;(printf " not replacing ~s~n" stx)
(list stx))))))
(define (flatten-syntaxes x)
(define (flatten-syntaxes x)
(cond [(syntax? x)
(list x)]
[(pair? x)
@ -398,47 +400,46 @@
(flatten-syntaxes (unbox x))]
[else null]))
;; -----------------------------------
;; -----------------------------------
;; walk : syntax(es) syntax(es) StepType -> Reduction
;; Lifts a local step into a term step.
(define (walk e1 e2 type)
;; walk : syntax(es) syntax(es) StepType -> Reduction
;; Lifts a local step into a term step.
(define (walk e1 e2 type)
(make-step (current-derivation) (big-context) type (context)
(current-definites) (get-frontier)
(foci e1) (foci e2) e1 e2))
;; walk/foci : syntaxes syntaxes syntax syntax StepType -> Reduction
(define (walk/foci foci1 foci2 Ee1 Ee2 type)
;; walk/foci : syntaxes syntaxes syntax syntax StepType -> Reduction
(define (walk/foci foci1 foci2 Ee1 Ee2 type)
(make-step (current-derivation) (big-context) type (context)
(current-definites) (get-frontier)
(foci foci1) (foci foci2) Ee1 Ee2))
;; walk/mono : syntax StepType -> Reduction
(define (walk/mono e1 type)
;; walk/mono : syntax StepType -> Reduction
(define (walk/mono e1 type)
(make-mono (current-derivation) (big-context) type (context)
(current-definites) (get-frontier)
(foci e1) e1))
;; stumble : syntax exception -> Reduction
(define (stumble stx exn)
;; stumble : syntax exception -> Reduction
(define (stumble stx exn)
(make-misstep (current-derivation) (big-context) 'error (context)
(current-definites) (get-frontier)
(foci stx) stx exn))
;; stumble/E : syntax(s) syntax exn -> Reduction
(define (stumble/E focus Ee1 exn)
;; stumble/E : syntax(s) syntax exn -> Reduction
(define (stumble/E focus Ee1 exn)
(make-misstep (current-derivation) (big-context) 'error (context)
(current-definites) (get-frontier)
(foci focus) Ee1 exn))
;; ------------------------------------
;; ------------------------------------
(define (revappend a b)
(define (revappend a b)
(cond [(pair? a) (revappend (cdr a) (cons (car a) b))]
[(null? a) b]))
(define (foci x)
(define (foci x)
(if (list? x)
x
(list x)))
)

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

@ -1,61 +1,61 @@
(module reductions mzscheme
(require (lib "plt-match.ss")
#lang scheme/base
(require scheme/match
"stx-util.ss"
"deriv-util.ss"
"context.ss"
"deriv.ss"
"reductions-engine.ss")
(provide reductions
(provide reductions
reductions+)
;; Setup for reduction-engines
;; Setup for reduction-engines
(define (Expr) reductions*)
(define (List) list-reductions)
(define (Block) block-reductions)
(define (Transformation)
(define (Expr) reductions*)
(define (List) list-reductions)
(define (Block) block-reductions)
(define (Transformation)
transformation-reductions)
(define (BindSyntaxes)
(define (BindSyntaxes)
bind-syntaxes-reductions)
(define ((CaseLambdaClauses e1))
(define ((CaseLambdaClauses e1))
(mk-case-lambda-clauses-reductions e1))
(define ((SynthItems e1))
(define ((SynthItems e1))
(mk-synth-items-reductions e1))
(define ((BRules es1))
(define ((BRules es1))
(mk-brules-reductions es1))
(define ((ModulePass es1))
(define ((ModulePass es1))
(mk-mbrules-reductions es1))
;; Syntax
;; Syntax
(define-syntax match/with-derivation
(define-syntax match/with-derivation
(syntax-rules ()
[(match/with-derivation d . clauses)
(let ([dvar d])
(with-derivation dvar
(match dvar . clauses)))]))
;; Reductions
;; Reductions
;; reductions : WDeriv -> ReductionSequence
(define (reductions d)
;; reductions : WDeriv -> ReductionSequence
(define (reductions d)
(parameterize ((current-definites null)
(current-frontier null))
(when d (add-frontier (list (wderiv-e1 d))))
(RS-steps (reductions* d))))
;; reductions+ : WDeriv -> (list-of step) (list-of identifier) ?stx ?exn
(define (reductions+ d)
;; reductions+ : WDeriv -> (list-of step) (list-of identifier) ?stx ?exn
(define (reductions+ d)
(parameterize ((current-definites null)
(current-frontier null))
(when d (add-frontier (list (wderiv-e1 d))))
(let-values ([(rs stx exn) (reductions* d)])
(values rs (current-definites) stx exn))))
;; reductions* : WDeriv -> RS(stx)
(define (reductions* d)
;; reductions* : WDeriv -> RS(stx)
(define (reductions* d)
(match d
[(Wrap deriv (e1 e2))
(blaze-frontier e1)]
@ -340,9 +340,9 @@
;; Skipped
[#f (RSzero)]))
;; mk-case-lambda-clauses-reductions : stxs ->
;; (list-of (W (list ?exn rename (W BDeriv)))) -> (RS stxs)
(define ((mk-case-lambda-clauses-reductions es1) clauses)
;; mk-case-lambda-clauses-reductions : stxs ->
;; (list-of (W (list ?exn rename (W BDeriv)))) -> (RS stxs)
(define ((mk-case-lambda-clauses-reductions es1) clauses)
(blaze-frontier es1)
(match clauses
['()
@ -360,8 +360,8 @@
[(CaseLambdaClauses (cdr es1))
?rest rest])]))
;; mk-synth-items-reductions : syntax -> (list-of SynthItem) -> (RS syntax)
(define ((mk-synth-items-reductions e1) subterms)
;; mk-synth-items-reductions : syntax -> (list-of SynthItem) -> (RS syntax)
(define ((mk-synth-items-reductions e1) subterms)
(let loop ([term e1] [subterms subterms])
(cond [(null? subterms)
(RSunit e1)]
@ -386,8 +386,8 @@
(s:rename-after subterm0))
(cdr subterms)))])))
;; transformation-reductions : Transformation -> (RS Stx)
(define (transformation-reductions tx)
;; transformation-reductions : Transformation -> (RS Stx)
(define (transformation-reductions tx)
(match tx
[(Wrap transformation (e1 e2 rs ?1 me1 locals ?2 me2 seq))
(R e1
@ -401,13 +401,13 @@
(list e2)
'macro])]))
;; reductions-locals : syntax (list-of LocalAction) -> (RS void)
(define (reductions-locals stx locals)
;; reductions-locals : syntax (list-of LocalAction) -> (RS void)
(define (reductions-locals stx locals)
(with-new-local-context stx
(RSforeach reductions-local locals)))
;; reductions-local : LocalAction -> (RS void)
(define (reductions-local local)
;; reductions-local : LocalAction -> (RS void)
(define (reductions-local local)
(match/with-derivation local
[(struct local-expansion (e1 e2 me1 me2 for-stx? deriv))
(reductions* deriv)]
@ -424,8 +424,8 @@
[(struct local-bind (bindrhs))
(bind-syntaxes-reductions bindrhs)]))
;; list-reductions : ListDerivation -> (RS Stxs)
(define (list-reductions ld)
;; list-reductions : ListDerivation -> (RS Stxs)
(define (list-reductions ld)
(match/with-derivation ld
[(Wrap lderiv (es1 es2 ?1 derivs))
(R es1
@ -434,8 +434,8 @@
[Expr (?form ...) derivs])]
[#f (RSunit null)]))
;; block-reductions : BlockDerivation -> (RS Stxs)
(define (block-reductions bd)
;; block-reductions : BlockDerivation -> (RS Stxs)
(define (block-reductions bd)
(match/with-derivation bd
[(Wrap bderiv (es1 es2 pass1 trans pass2))
(R es1
@ -448,8 +448,8 @@
[List ?form pass2])]
[#f (RSunit null)]))
;; mk-brules-reductions : stxs -> (list-of BRule) -> (RS Stxs)
(define ((mk-brules-reductions es1) brules)
;; mk-brules-reductions : stxs -> (list-of BRule) -> (RS Stxs)
(define ((mk-brules-reductions es1) brules)
(match brules
['()
(RSunit null)]
@ -500,8 +500,8 @@
(R es1
[! exn])]))
;; bind-syntaxes-reductions : BindSyntaxes -> (RS stx)
(define (bind-syntaxes-reductions bindrhs)
;; bind-syntaxes-reductions : BindSyntaxes -> (RS stx)
(define (bind-syntaxes-reductions bindrhs)
(match bindrhs
[(Wrap bind-syntaxes (rhs ?1))
(R (wderiv-e1 rhs)
@ -509,8 +509,8 @@
[Expr ?form rhs]
[! ?1])]))
;; mk-mbrules-reductions : stx -> (list-of MBRule) -> (RS stxs)
(define ((mk-mbrules-reductions es1) mbrules)
;; mk-mbrules-reductions : stx -> (list-of MBRule) -> (RS stxs)
(define ((mk-mbrules-reductions es1) mbrules)
(match mbrules
['()
(RSunit null)]
@ -560,5 +560,3 @@
stxs
'splice-module-lifts]]
[(ModulePass #'?forms) ?forms rest])]))
)

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

@ -1,40 +1,40 @@
(module steps mzscheme
(require "deriv.ss"
#lang scheme/base
(require "deriv.ss"
"deriv-util.ss"
"deriv-find.ss")
(provide (all-defined))
(provide (all-defined-out))
;; A ReductionSequence is a (list-of Reduction)
;; A ReductionSequence is a (list-of Reduction)
;; A ProtoStep is (make-protostep Derivation BigContext StepType Context Definites)
;; A ProtoStep is (make-protostep Derivation BigContext StepType Context Definites)
;; A Context is a list of Frames
;; A Frame is either:
;; - (syntax -> syntax)
;; - (make-renames syntax syntax)
;; - 'phase-up
(define-struct renames (old new))
;; A Context is a list of Frames
;; A Frame is either:
;; - (syntax -> syntax)
;; - (make-renames syntax syntax)
;; - 'phase-up
(define-struct renames (old new))
;; A Definite is a (list-of identifier)
;; A Definite is a (list-of identifier)
;; A BigContext is (list-of BigFrame)
;; A BigFrame is (make-bigframe Derivation Context Syntaxes Syntax)
(define-struct bigframe (deriv ctx foci e))
;; A BigContext is (list-of BigFrame)
;; A BigFrame is (make-bigframe Derivation Context Syntaxes Syntax)
(define-struct bigframe (deriv ctx foci e))
;; A Reduction is one of
;; - (make-step ... Syntaxes Syntaxes Syntax Syntax)
;; - (make-mono ... Syntaxes Syntax)
;; - (make-misstep ... Syntax Syntax Exception)
;; A Reduction is one of
;; - (make-step ... Syntaxes Syntaxes Syntax Syntax)
;; - (make-mono ... Syntaxes Syntax)
;; - (make-misstep ... Syntax Syntax Exception)
(define-struct protostep (deriv lctx type ctx definites frontier) #f)
(define-struct protostep (deriv lctx type ctx definites frontier) #:transparent)
(define-struct (step protostep) (foci1 foci2 e1 e2) #f)
(define-struct (mono protostep) (foci1 e1) #f)
(define-struct (misstep protostep) (foci1 e1 exn) #f)
(define-struct (step protostep) (foci1 foci2 e1 e2) #:transparent)
(define-struct (mono protostep) (foci1 e1) #:transparent)
(define-struct (misstep protostep) (foci1 e1 exn) #:transparent)
;; context-fill : Context Syntax -> Syntax
(define (context-fill ctx stx)
;; context-fill : Context Syntax -> Syntax
(define (context-fill ctx stx)
(let loop ([ctx ctx] [stx stx])
(if (null? ctx)
stx
@ -43,8 +43,8 @@
(loop (cdr ctx) (frame0 stx))
(loop (cdr ctx) stx))))))
;; context-env : Context -> (list-of identifier)
(define (context-env ctx)
;; context-env : Context -> (list-of identifier)
(define (context-env ctx)
(let loop ([ctx ctx] [env null])
(if (null? ctx)
env
@ -55,23 +55,23 @@
env))
(loop (cdr ctx) env))))))
(define (step-term1 s)
(define (step-term1 s)
(context-fill (protostep-ctx s) (step-e1 s)))
(define (step-term2 s)
(define (step-term2 s)
(context-fill (protostep-ctx s) (step-e2 s)))
(define (mono-term1 s)
(define (mono-term1 s)
(context-fill (protostep-ctx s) (mono-e1 s)))
(define (misstep-term1 s)
(define (misstep-term1 s)
(context-fill (protostep-ctx s) (misstep-e1 s)))
(define (bigframe-term bf)
(define (bigframe-term bf)
(context-fill (bigframe-ctx bf) (bigframe-e bf)))
;; A StepType is a simple in the following alist.
;; A StepType is a simple in the following alist.
(define step-type-meanings
(define step-type-meanings
'((macro . "Macro transformation")
(rename-lambda . "Rename formal parameters")
@ -98,12 +98,12 @@
(error . "Error")))
(define (step-type->string x)
(define (step-type->string x)
(cond [(assq x step-type-meanings) => cdr]
[(string? x) x]
[else (error 'step-type->string "not a step type: ~s" x)]))
(define (rename-step? x)
(define (rename-step? x)
(memq (protostep-type x)
'(rename-lambda
rename-case-lambda
@ -111,6 +111,5 @@
rename-letrec-values
rename-lsv)))
(define (rewrite-step? x)
(define (rewrite-step? x)
(and (step? x) (not (rename-step? x))))
)

45
collects/macro-debugger/model/stx-util.ss
View File

@ -1,16 +1,17 @@
(module stx-util mzscheme
(require (lib "stx.ss" "syntax"))
#lang scheme/base
(require (for-syntax scheme/base)
syntax/stx)
(provide (all-defined)
(all-from (lib "stx.ss" "syntax")))
(provide (all-defined-out)
(all-from-out syntax/stx))
(define (d->so template datum)
(define (d->so template datum)
(if (syntax? template)
(datum->syntax-object template datum template template)
(datum->syntax template datum template template)
datum))
(define-syntax (syntax-copier stx)
(define-syntax (syntax-copier stx)
(syntax-case stx ()
[(syntax-copier hole expr pattern)
#'(let ([expr-var expr])
@ -19,14 +20,14 @@
(with-syntax ([hole in-the-hole])
(syntax/restamp pattern #'pattern expr-var)))))]))
(define-syntax syntax/skeleton
(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)
;; 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)]
@ -34,9 +35,9 @@
;; FIXME
(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" (map syntax-object->datum old-parts))
(printf "new parts: ~s~n" (map syntax-object->datum new-parts)))
(printf "pattern : ~s~n" (syntax->datum #'(pa (... ...))))
(printf "old parts: ~s~n" (map syntax->datum old-parts))
(printf "new parts: ~s~n" (map syntax->datum new-parts)))
(d->so
old-expr
(map (lambda (new old) (syntax/restamp pa new old))
@ -47,7 +48,7 @@
#'(begin
(unless (and (stx-pair? new-expr) (stx-pair? old-expr))
(printf "** syntax/restamp~n~s~n" (quote-syntax #,stx))
(printf "pattern : ~s~n" (syntax-object->datum (quote-syntax (pa . pb))))
(printf "pattern : ~s~n" (syntax->datum (quote-syntax (pa . pb))))
(printf "old parts: ~s~n" old-expr)
(printf "new parts: ~s~n" new-expr))
(let ([na (stx-car new-expr)]
@ -60,32 +61,32 @@
[(syntax/restamp pvar new-expr old-expr)
#'new-expr]))
(define (iota n)
(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)
;; 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 (take-if-possible items n)
(define (take-if-possible items n)
(unless (number? n)
(raise-type-error 'take-if-possible "number" n))
(if (and (pair? items) (positive? n))
(cons (car items) (take-if-possible (cdr items) (sub1 n)))
null))
;; stx-improper-length : syntax -> number
(define (stx-improper-length stx)
;; stx-improper-length : syntax -> number
(define (stx-improper-length stx)
(let loop ([stx stx] [n 0])
(if (stx-pair? stx)
(loop (stx-cdr stx) (add1 n))
n)))
(define (stx->list* stx)
(define (stx->list* stx)
(cond [(pair? stx)
(cons (car stx) (stx->list* (cdr stx)))]
[(null? stx)
@ -96,5 +97,3 @@
(cons (car x) (stx->list* (cdr x)))
(list stx)))]
[else null]))
)

19
collects/macro-debugger/model/trace-raw.ss
View File

@ -1,16 +1,16 @@
(module trace-raw mzscheme
(require "../syntax-browser.ss"
(lib "class.ss")
(lib "lex.ss" "parser-tools")
#lang scheme/base
(require scheme/class
parser-tools/lex
"deriv-tokens.ss"
"deriv-parser.ss")
(provide (all-defined))
"deriv-parser.ss"
"../syntax-browser.ss")
(provide (all-defined-out))
(define current-expand-observe
(define current-expand-observe
(dynamic-require ''#%expobs 'current-expand-observe))
(define (go-trace sexpr)
(define (go-trace sexpr)
(define events null)
(define pos 0)
(define browser (make-syntax-browser))
@ -24,7 +24,7 @@
(token-name (position-token-token t))))
(when val
(send browser add-syntax
(datum->syntax-object #f val)))
(datum->syntax #f val)))
(set! pos (add1 pos)))
(parameterize ((current-expand-observe
(lambda (sig val)
@ -34,4 +34,3 @@
(expand sexpr)
(for-each show (reverse events))))
)

34
collects/macro-debugger/model/trace.ss
View File

@ -1,43 +1,44 @@
(module trace mzscheme
(require (lib "lex.ss" "parser-tools"))
(require "deriv.ss"
#lang scheme/base
(require scheme/promise
parser-tools/lex
"deriv.ss"
"deriv-parser.ss"
"deriv-tokens.ss")
(provide trace
(provide trace
trace*
trace/result
trace-verbose?
events->token-generator
current-expand-observe)
(define current-expand-observe
(define current-expand-observe
(dynamic-require ''#%expobs 'current-expand-observe))
(define trace-verbose? (make-parameter #f))
(define trace-verbose? (make-parameter #f))
;; trace : stx -> Deriv
(define (trace stx)
;; trace : stx -> Deriv
(define (trace stx)
(let-values ([(result events derivp) (trace* stx expand)])
(force derivp)))
;; trace/result : stx -> stx/exn Deriv
(define (trace/result stx)
;; trace/result : stx -> stx/exn Deriv
(define (trace/result stx)
(let-values ([(result events derivp) (trace* stx expand)])
(values result
(force derivp))))
;; trace* : stx (stx -> stx) -> stx/exn (list-of event) (promise-of Deriv)
(define (trace* stx expander)
;; trace* : stx (stx -> stx) -> stx/exn (list-of event) (promise-of Deriv)
(define (trace* stx expander)
(let-values ([(result events) (expand/events stx expander)])
(values result
events
(delay (parse-derivation
(events->token-generator events))))))
;; events->token-generator : (list-of event) -> (-> token)
(define (events->token-generator events)
;; events->token-generator : (list-of event) -> (-> token)
(define (events->token-generator events)
(let ([pos 0])
(lambda ()
(define sig+val (car events))
@ -51,8 +52,8 @@
(set! pos (add1 pos))
t))))
;; expand/events : stx (stx -> stx) -> stx/exn (list-of event)
(define (expand/events sexpr expander)
;; expand/events : stx (stx -> stx) -> stx/exn (list-of event)
(define (expand/events sexpr expander)
(let ([events null])
(define (add! x)
(set! events (cons x events)))
@ -70,4 +71,3 @@
(add! (cons 'EOF #f))
(values result
(reverse events))))))
)

17
collects/macro-debugger/model/yacc-ext.ss
View File

@ -1,25 +1,25 @@
(module yacc-ext mzscheme
(require (prefix yacc: (lib "yacc.ss" "parser-tools")))
(provide parser
#lang scheme/base
(require (prefix-in yacc: parser-tools/yacc)
(for-syntax scheme/base))
(provide parser
options
productions
definitions)
(define-syntax options
(define-syntax options
(lambda (stx)
(raise-syntax-error #f "options keyword used out of context" stx)))
(define-syntax productions
(define-syntax productions
(lambda (stx)
(raise-syntax-error #f "productions keyword used out of context" stx)))
(define-syntax definitions
(define-syntax definitions
(lambda (stx)
(raise-syntax-error #f "definitions keyword used out of context" stx)))
(define-syntax (parser stx)
(define-syntax (parser stx)
(syntax-case stx ()
[(parser form ...)
(let ([stop-list (list #'begin #'options #'productions #'definitions)]
@ -47,4 +47,3 @@
#'(let ()
def ...
(#%expression (yacc:parser opt ... (grammar prod ...))))))]))
)

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

@ -1,45 +1,46 @@
(module yacc-interrupted mzscheme
(require-for-syntax (lib "etc.ss"))
(require "yacc-ext.ss")
(provide ! ? !!
#lang scheme/base
(require (for-syntax scheme/base)
(for-syntax mzlib/etc)
"yacc-ext.ss")
(provide ! ? !!
define-production-splitter
skipped-token-values
%skipped
%action)
;; Grammar macros for "interrupted parses"
;; Grammar macros for "interrupted parses"
(define-syntax !
(define-syntax !
(lambda (stx)
(raise-syntax-error #f "keyword ! used out of context" stx)))
(define-syntax !!
(define-syntax !!
(lambda (stx)
(raise-syntax-error #f "keyword !! used out of context" stx)))
(define-syntax ?
(define-syntax ?
(lambda (stx)
(raise-syntax-error #f "keyword ? used out of context" stx)))
(define-syntax define-production-splitter
(define-syntax define-production-splitter
(syntax-rules ()
[(define-production-splitter name ok intW)
(define-syntax name
(make-production-splitter #'ok #'intW))]))
(define-for-syntax (partition-options/alternates forms)
(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)]
(loop (cdr forms) (cons (cons '#:args #'args) options) alts)]
[(#:skipped expr)
(loop (cdr forms) (cons (cons #:skipped #'expr) options) alts)]
(loop (cdr forms) (cons (cons '#:skipped #'expr) options) alts)]
[(#:wrap)
(loop (cdr forms) (cons (cons #:wrap #t) options) alts)]
(loop (cdr forms) (cons (cons '#:wrap #t) options) alts)]
[(#:no-wrap)
(loop (cdr forms) (cons (cons #:no-wrap #t) options) alts)]
(loop (cdr forms) (cons (cons '#:no-wrap #t) options) alts)]
[(kw . args)
(keyword? (syntax-e #'kw))
(raise-syntax-error 'split "bad keyword" (car forms))]
@ -49,7 +50,7 @@
(raise-syntax-error 'split "bad grammar option or alternate" #'other)])
(values options (reverse alts)))))
(define-for-syntax (symbol+ . args)
(define-for-syntax (symbol+ . args)
(define (norm x)
(cond [(identifier? x) (norm (syntax-e x))]
[(string? x) x]
@ -57,20 +58,20 @@
[(symbol? x) (symbol->string x)]))
(string->symbol (apply string-append (map norm args))))
(define-for-syntax (I symbol)
(define-for-syntax (I symbol)
(syntax-local-introduce
(syntax-local-get-shadower (datum->syntax-object #f symbol))))
(syntax-local-get-shadower (datum->syntax #f symbol))))
(define-for-syntax ($name n)
(define-for-syntax ($name n)
(I (symbol+ '$ n)))
(define-for-syntax (interrupted-name s)
(define-for-syntax (interrupted-name s)
(I (symbol+ s '/Interrupted)))
(define-for-syntax (skipped-name s)
(define-for-syntax (skipped-name s)
(I (symbol+ s '/Skipped)))
(define-for-syntax (elaborate-skipped-tail head tail position args mk-action)
(define-for-syntax (elaborate-skipped-tail head tail position args mk-action)
(define-values (new-tail new-arguments)
(let loop ([parts tail] [position position] [rtail null] [arguments null])
(syntax-case parts (? ! !!)
@ -94,7 +95,7 @@
(cons #`(#,head . #,new-tail)
(mk-action arguments)))
(define-for-syntax ((make-elaborate-successful-alternate wrap? okW) alt)
(define-for-syntax ((make-elaborate-successful-alternate wrap? okW) alt)
(define pattern (car alt))
(define action-function (cdr alt))
(define-values (new-patterns arguments)
@ -112,11 +113,11 @@
(loop #'parts-rest (cons #'NT rpattern)
(add1 position) (cons ($name position) args))])))
(map (lambda (new-pattern)
(cons (datum->syntax-object #f new-pattern pattern)
(cons (datum->syntax #f new-pattern pattern)
#`(#,action-function #,(if wrap? okW #'values) #,@arguments)))
new-patterns))
(define-for-syntax ((make-elaborate-interrupted-alternate wrap? intW) alt)
(define-for-syntax ((make-elaborate-interrupted-alternate wrap? intW) alt)
(define pattern (car alt))
(define action-function (cdr alt))
(define (int-action args)
@ -160,11 +161,11 @@
(map (lambda (clause) (cons #`(part0 . #,(car clause)) (cdr clause)))
(loop #'parts-rest (add1 position) (cons ($name position) args)))])))
(define-for-syntax (generate-action-name nt pos)
(define-for-syntax (generate-action-name nt pos)
(syntax-local-get-shadower
(datum->syntax-object #f (symbol+ 'action-for- nt '/ pos))))
(datum->syntax #f (symbol+ 'action-for- nt '/ pos))))
(define-for-syntax ((make-rewrite-alt+def nt args-spec) alt pos)
(define-for-syntax ((make-rewrite-alt+def nt args-spec) alt pos)
(define pattern (car alt))
(define action (cdr alt))
(define-values (var-indexes non-var-indexes)
@ -218,28 +219,28 @@
#`(lambda #,args-spec (wrap action))
#`(wrap action)))))))
(define-for-syntax (invalid-$name-use stx)
(define-for-syntax (invalid-$name-use stx)
(raise-syntax-error #f "no value for positional variable" stx))
;; An alternate is (cons pattern action-expr)
;; An alternate* is (cons pattern action-function-name)
;; An alternate is (cons pattern action-expr)
;; An alternate* is (cons pattern action-function-name)
(define-for-syntax ((make-production-splitter okW intW) stx)
(define-for-syntax ((make-production-splitter okW intW) stx)
(syntax-case stx ()
[(_ (name form ...))
(let ()
(define-values (options alternates0)
(partition-options/alternates (syntax->list #'(form ...))))
(define wrap?
(let ([wrap? (assq #:wrap options)]
[no-wrap? (assq #:no-wrap options)])
(let ([wrap? (assq '#:wrap options)]
[no-wrap? (assq '#:no-wrap options)])
(unless (and (or wrap? no-wrap?) (not (and wrap? no-wrap?)))
(raise-syntax-error 'split
"must specify exactly one of #:wrap, #:no-wrap"
stx))
(and wrap? #t)))
(define args-spec
(let ([p (assq #:args options)]) (and p (cdr p))))
(let ([p (assq '#:args options)]) (and p (cdr p))))
(define rewrite-alt+def (make-rewrite-alt+def #'name args-spec))
(define alternates+definitions
(map rewrite-alt+def alternates0 (build-list (length alternates0) add1)))
@ -257,8 +258,8 @@
successful-alternates]
[((interrupted-pattern . interrupted-action) ...)
interrupted-alternates]
[skip-spec (assq #:skipped options)]
[args-spec (assq #:args options)]
[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)])
@ -272,7 +273,7 @@
#'(name/Interrupted [(IMPOSSIBLE) #f]))
(name/Skipped [() (%skipped args-spec skip-spec)])))))]))
(define-syntax (skipped-token-values stx)
(define-syntax (skipped-token-values stx)
(syntax-case stx ()
[(skipped-token-values)
#'(begin)]
@ -286,17 +287,16 @@
#'(begin (productions (name/Skipped [() value]))
(skipped-token-values . more)))]))
(define-syntax (%skipped stx)
(define-syntax (%skipped stx)
(syntax-case stx ()
[(%skipped args (#:skipped . expr))
#'(%action args expr)]
[(%skipped args #f)
#'(%action args #f)]))
(define-syntax (%action stx)
(define-syntax (%action stx)
(syntax-case stx ()
[(%action (#:args . args) action)
#'(lambda args action)]
[(%action #f action)
#'action]))
)

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

@ -1,7 +1,7 @@
(module stepper-text mzscheme
(require (lib "list.ss")
(lib "pretty.ss")
#lang scheme/base
(require scheme/list
scheme/pretty
"model/trace.ss"
"model/reductions.ss"
"model/steps.ss"
@ -9,24 +9,24 @@
"model/hiding-policies.ss"
"syntax-browser/partition.ss"
"syntax-browser/pretty-helper.ss")
(provide expand/step-text
(provide expand/step-text
stepper-text)
(define expand/step-text
(define expand/step-text
(case-lambda
[(stx) (expand/step-text stx #f)]
[(stx show)
(define s (stepper-text stx (->show-function show)))
(s 'all)]))
(define stepper-text
(define stepper-text
(case-lambda
[(stx) (internal-stepper stx #f)]
[(stx show) (internal-stepper stx (->show-function show))]))
;; internal procedures
;; internal procedures
(define (internal-stepper stx show?)
(define (internal-stepper stx show?)
(define steps (get-steps stx show?))
(define used-steps null)
(define partition (new-bound-partition))
@ -53,7 +53,7 @@
(dispatch 'all))))]))
dispatch)
(define (get-steps stx show?)
(define (get-steps stx show?)
(define deriv (trace stx))
(define hderiv
(if show? (hide/policy deriv show?) deriv))
@ -61,7 +61,7 @@
(or (rewrite-step? x) (misstep? x)))
(filter ok? (reductions hderiv)))
(define (show-step step partition)
(define (show-step step partition)
(cond [(step? step)
(display (step-type->string (protostep-type step)))
(newline)
@ -75,7 +75,7 @@
(newline)
(show-term (misstep-term1 step) partition)]))
(define (show-term stx partition)
(define (show-term stx partition)
(define-values (datum flat=>stx stx=>flat)
(table stx partition 0 'always))
(define identifier-list
@ -118,12 +118,12 @@
[print-honu #f])
(pretty-print datum)))
(define (->show-function show)
(define (->show-function show)
(cond [(procedure? show)
show]
[(list? show)
(lambda (id)
(ormap (lambda (x) (module-identifier=? x id))
(ormap (lambda (x) (free-identifier=? x id))
show))]
[(hiding-policy? show)
(lambda (x) (policy-show-macro? show x))]
@ -134,7 +134,6 @@
"expected procedure or list of identifiers for macros to show; got: ~e"
show)]))
(define extended-style-list
(define extended-style-list
'((define-values . define)
(define-syntaxes . define-syntax)))
)

9
collects/macro-debugger/stepper.ss
View File

@ -1,8 +1,7 @@
(module stepper mzscheme
(require "view/view.ss")
(provide expand/step)
#lang scheme/base
(require "view/view.ss")
(provide expand/step)
(define (expand/step stx)
(define (expand/step stx)
(go stx))
)

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

@ -1,7 +1,6 @@
(module syntax-browser mzscheme
(require "syntax-browser/frame.ss")
(provide browse-syntax
#lang scheme/base
(require "syntax-browser/frame.ss")
(provide browse-syntax
browse-syntaxes
make-syntax-browser)
)

25
collects/macro-debugger/syntax-browser/controller.ss
View File

@ -1,13 +1,13 @@
(module controller mzscheme
(require (lib "class.ss")
#lang scheme/base
(require scheme/class
"interfaces.ss"
"partition.ss"
"../util/notify.ss")
(provide controller%)
(provide controller%)
;; displays-manager-mixin
(define displays-manager-mixin
;; displays-manager-mixin
(define displays-manager-mixin
(mixin () (displays-manager<%>)
;; displays : (list-of display<%>)
(field [displays null])
@ -22,8 +22,8 @@
(super-new)))
;; selection-manager-mixin
(define selection-manager-mixin
;; selection-manager-mixin
(define selection-manager-mixin
(mixin (displays-manager<%>) (selection-manager<%>)
(inherit-field displays)
(field/notify selected-syntax (new notify-box% (value #f)))
@ -34,8 +34,8 @@
(for-each (lambda (display) (send display refresh))
displays)))))
;; mark-manager-mixin
(define mark-manager-mixin
;; mark-manager-mixin
(define mark-manager-mixin
(mixin () (mark-manager<%>)
(init-field [primary-partition (new-bound-partition)])
(super-new)
@ -48,8 +48,8 @@
(define/public-final (reset-primary-partition)
(set! primary-partition (new-bound-partition)))))
;; secondary-partition-mixin
(define secondary-partition-mixin
;; secondary-partition-mixin
(define secondary-partition-mixin
(mixin (displays-manager<%>) (secondary-partition<%>)
(inherit-field displays)
(field/notify identifier=? (new notify-box% (value #f)))
@ -66,11 +66,10 @@
displays)))
(super-new)))
(define controller%
(define controller%
(class (secondary-partition-mixin
(selection-manager-mixin
(mark-manager-mixin
(displays-manager-mixin
object%))))
(super-new)))
)

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

@ -1,23 +1,23 @@
(module display mzscheme
(require (lib "class.ss")
(lib "mred.ss" "mred")
(lib "plt-match.ss")
#lang scheme/base
(require scheme/class
scheme/gui
scheme/match
"params.ss"
"pretty-printer.ss"
"interfaces.ss"
"util.ss")
(provide print-syntax-to-editor
(provide print-syntax-to-editor
code-style)
;; print-syntax-to-editor : syntax text controller<%> -> display<%>
(define (print-syntax-to-editor stx text controller)
;; print-syntax-to-editor : syntax text controller<%> -> display<%>
(define (print-syntax-to-editor stx text controller)
(new display% (syntax stx) (text text) (controller controller)))
;; FIXME: assumes text never moves
;; FIXME: assumes text never moves
;; display%
(define display%
;; display%
(define display%
(class* object% (display<%>)
(init ((stx syntax)))
(init-field text)
@ -162,9 +162,9 @@
(render-syntax stx)
(send controller add-syntax-display this)))
;; print-syntax : syntax controller (-> number) (-> number)
;; -> range%
(define (print-syntax stx text controller
;; print-syntax : syntax controller (-> number) (-> number)
;; -> range%
(define (print-syntax stx text controller
get-start-position get-end-position)
(define primary-partition (send controller get-primary-partition))
(define real-output-port (make-text-port text get-end-position))
@ -194,8 +194,8 @@
(send range all-ranges))
range)))
;; fixup-parentheses : text range -> void
(define (fixup-parentheses text range offset)
;; fixup-parentheses : text range -> void
(define (fixup-parentheses text range offset)
(define (fixup r)
(let ([stx (range-obj r)]
[start (+ offset (range-start r))]
@ -212,8 +212,8 @@
(send text insert char pos (add1 pos)))
(for-each fixup (send range all-ranges)))
;; code-style : text<%> -> style<%>
(define (code-style text)
;; code-style : text<%> -> style<%>
(define (code-style text)
(let* ([style-list (send text get-style-list)]
[style (send style-list find-named-style "Standard")]
[font-size (current-syntax-font-size)])
@ -223,16 +223,16 @@
(make-object style-delta% 'change-size font-size))
style)))
;; anchor-snip%
(define anchor-snip%
;; anchor-snip%
(define anchor-snip%
(class snip%
(define/override (copy)
(make-object string-snip% ""))
(super-instantiate ())))
;; Styles
;; Styles
(define (highlight-style-delta color em?)
(define (highlight-style-delta color em?)
(let ([sd (new style-delta%)])
(unless em? (send sd set-delta-background color))
(when em? (send sd set-weight-on 'bold))
@ -240,12 +240,11 @@
(send sd set-weight-off 'bold))
sd))
(define selection-color "yellow")
(define subselection-color "yellow")
(define selection-color "yellow")
(define subselection-color "yellow")
(define select-highlight-d (highlight-style-delta selection-color #t))
(define select-sub-highlight-d (highlight-style-delta subselection-color #f))
(define select-highlight-d (highlight-style-delta selection-color #t))
(define select-sub-highlight-d (highlight-style-delta subselection-color #f))
(define unhighlight-d (highlight-style-delta "white" #f))
(define unhighlight-d (highlight-style-delta "white" #f))
)

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

@ -1,13 +1,13 @@
(module embed mzscheme
(require "interfaces.ss"
#lang scheme/base
(require "interfaces.ss"
"widget.ss"
"keymap.ss"
"params.ss"
"partition.ss")
(provide (all-from "interfaces.ss")
(all-from "widget.ss")
(all-from "keymap.ss")
(all-from "params.ss")
identifier=-choices))
(provide (all-from-out "interfaces.ss")
(all-from-out "widget.ss")
(all-from-out "keymap.ss")
(all-from-out "params.ss")
identifier=-choices)

34
collects/macro-debugger/syntax-browser/frame.ss
View File

@ -1,38 +1,38 @@
(module frame mzscheme
(require (lib "class.ss")
(lib "mred.ss" "mred")
(lib "framework.ss" "framework")
(lib "list.ss")
#lang scheme/base
(require scheme/class
scheme/gui
framework/framework
scheme/list
"partition.ss"
"prefs.ss"
"widget.ss")
(provide browse-syntax
(provide browse-syntax
browse-syntaxes
make-syntax-browser
syntax-browser-frame%
syntax-widget/controls%)
;; browse-syntax : syntax -> void
(define (browse-syntax stx)
;; browse-syntax : syntax -> void
(define (browse-syntax stx)
(browse-syntaxes (list stx)))
;; browse-syntaxes : (list-of syntax) -> void
(define (browse-syntaxes stxs)
;; browse-syntaxes : (list-of syntax) -> void
(define (browse-syntaxes stxs)
(let ((w (make-syntax-browser)))
(for-each (lambda (stx)
(send w add-syntax stx)
(send w add-separator))
stxs)))
;; make-syntax-browser : -> syntax-browser<%>
(define (make-syntax-browser)
;; make-syntax-browser : -> syntax-browser<%>
(define (make-syntax-browser)
(let* ([view (new syntax-browser-frame%)])
(send view show #t)
(send view get-widget)))
;; syntax-browser-frame%
(define syntax-browser-frame%
;; syntax-browser-frame%
(define syntax-browser-frame%
(class* frame% ()
(init-field [config (new syntax-prefs%)])
(super-new (label "Syntax Browser")
@ -50,8 +50,8 @@
(inner (void) on-close))
))
;; syntax-widget/controls%
(define syntax-widget/controls%
;; syntax-widget/controls%
(define syntax-widget/controls%
(class* widget% ()
(inherit get-main-panel
get-controller
@ -92,5 +92,3 @@
(send -choice set-selection
(or (send -choice find-string (car name+func)) 0))))
))
)

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

@ -1,12 +1,13 @@
(module hrule-snip mzscheme
(require (lib "class.ss")
(lib "mred.ss" "mred"))
(provide hrule-snip%)
#lang scheme/base
;; hrule-snip%
;; A snip for drawing horizontal separating lines.
(define hrule-snip%
(require scheme/class
scheme/gui)
(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)
@ -42,16 +43,15 @@
(set-snipclass snip-class)))
(define hrule-snipclass%
(define hrule-snipclass%
(class snip-class%
(define/override (read stream)
(let ([str (send stream get-bytes)])
(new hrule-snip%)))
(super-new)))
(define snip-class (new hrule-snipclass%))
(send snip-class set-version 1)
(send snip-class set-classname
(define snip-class (new hrule-snipclass%))
(send snip-class set-version 1)
(send snip-class set-classname
(format "~s" '(lib "hrule-snip.ss" "macro-debugger" "syntax-browser")))
(send (get-the-snip-class-list) add snip-class)
)
(send (get-the-snip-class-list) add snip-class)

70
collects/macro-debugger/syntax-browser/interfaces.ss
View File

@ -1,10 +1,10 @@
(module interfaces mzscheme
(require (lib "class.ss"))
(provide (all-defined))
#lang scheme/base
(require scheme/class)
(provide (all-defined-out))
;; displays-manager<%>
(define displays-manager<%>
;; displays-manager<%>
(define displays-manager<%>
(interface ()
;; add-syntax-display : display<%> -> void
add-syntax-display
@ -12,8 +12,8 @@
;; remove-all-syntax-displays : -> void
remove-all-syntax-displays))
;; selection-manager<%>
(define selection-manager<%>
;; selection-manager<%>
(define selection-manager<%>
(interface ()
;; selected-syntax : syntax/#f
set-selected-syntax
@ -21,15 +21,15 @@
listen-selected-syntax
))
;; mark-manager<%>
;; Manages marks, mappings from marks to colors
(define mark-manager<%>
;; mark-manager<%>
;; Manages marks, mappings from marks to colors
(define mark-manager<%>
(interface ()
;; get-primary-partition : -> partition
get-primary-partition))
;; secondary-partition<%>
(define secondary-partition<%>
;; secondary-partition<%>
(define secondary-partition<%>
(interface (displays-manager<%>)
;; get-secondary-partition : -> partition<%>
get-secondary-partition
@ -49,15 +49,15 @@
;; listen-identifier=? : ((cons string procedure) -> void) -> void
listen-identifier=?))
;; controller<%>
(define controller<%>
;; controller<%>
(define controller<%>
(interface (displays-manager<%>
selection-manager<%>
mark-manager<%>
secondary-partition<%>)))
;; host<%>
(define host<%>
;; host<%>
(define host<%>
(interface ()
;; get-controller : -> controller<%>
get-controller
@ -67,8 +67,8 @@
))
;; display<%>
(define display<%>
;; display<%>
(define display<%>
(interface ()
;; refresh : -> void
refresh
@ -85,8 +85,8 @@
;; get-range : -> range<%>
get-range))
;; range<%>
(define range<%>
;; range<%>
(define range<%>
(interface ()
;; get-ranges : datum -> (list-of (cons number number))
get-ranges
@ -98,20 +98,20 @@
;; get-identifier-list : (list-of identifier)
get-identifier-list))
;; A Range is (make-range datum number number)
(define-struct range (obj start end))
;; A Range is (make-range datum number number)
(define-struct range (obj start end))
;; syntax-prefs<%>
(define syntax-prefs<%>
;; syntax-prefs<%>
(define syntax-prefs<%>
(interface ()
pref:width
pref:height
pref:props-percentage
pref:props-shown?))
;; widget-hooks<%>
(define widget-hooks<%>
;; widget-hooks<%>
(define widget-hooks<%>
(interface ()
;; setup-keymap : -> void
setup-keymap
@ -120,8 +120,8 @@
shutdown
))
;; keymap-hooks<%>
(define keymap-hooks<%>
;; keymap-hooks<%>
(define keymap-hooks<%>
(interface ()
;; make-context-menu : -> context-menu<%>
make-context-menu
@ -129,8 +129,8 @@
;; get-context-menu% : -> class
get-context-menu%))
;; context-menu-hooks<%>
(define context-menu-hooks<%>
;; context-menu-hooks<%>
(define context-menu-hooks<%>
(interface ()
add-edit-items
after-edit-items
@ -140,10 +140,10 @@
after-partition-items))
;;----------
;;----------
;; Convenience widget, specialized for displaying stx and not much else
(define syntax-browser<%>
;; Convenience widget, specialized for displaying stx and not much else
(define syntax-browser<%>
(interface ()
add-syntax
add-text
@ -153,7 +153,7 @@
get-text
))
(define partition<%>
(define partition<%>
(interface ()
;; get-partition : any -> number
get-partition
@ -163,5 +163,3 @@
;; count : -> number
count))
)

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

@ -1,13 +1,13 @@
(module keymap mzscheme
(require (lib "class.ss")
(lib "mred.ss" "mred")
#lang scheme/base
(require scheme/class
scheme/gui
"interfaces.ss"
"partition.ss")
(provide syntax-keymap%
(provide syntax-keymap%
context-menu%)
(define syntax-keymap%
(define syntax-keymap%
(class keymap%
(init editor)
(init-field controller)
@ -38,7 +38,7 @@
(define stx (send controller get-selected-syntax))
(send the-clipboard set-clipboard-string
(if stx
(format "~s" (syntax-object->datum stx))
(format "~s" (syntax->datum stx))
"")
(send event get-time-stamp))))
@ -65,7 +65,7 @@
(define admin (send editor get-admin))
(send admin popup-menu (make-context-menu) x y))))
(define context-menu%
(define context-menu%
(class popup-menu%
(init-field keymap)
(init-field controller)
@ -148,5 +148,3 @@
(add-partition-items)
(after-partition-items)
))
)

78
collects/macro-debugger/syntax-browser/partition.ss
View File

@ -1,30 +1,30 @@
(module partition mzscheme
(require (lib "class.ss")
(lib "boundmap.ss" "syntax")
(lib "stx.ss" "syntax")
#lang scheme/base
(require scheme/class
syntax/boundmap
syntax/stx
"interfaces.ss")
(provide new-bound-partition
(provide new-bound-partition
partition%
identifier=-choices)
(define (new-bound-partition)
(define (new-bound-partition)
(new bound-partition%))
;; 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
;; 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))
;; unmarked-syntax : identifier
;; Has no marks---used to initialize bound partition so that
;; unmarked syntax always gets colored "black"
(define unmarked-syntax
(datum->syntax #f representative-symbol))
(define partition%
(define partition%
(class* object% (partition<%>)
(init relation)
@ -76,8 +76,8 @@
(super-new)
))
;; bound-partition%
(define bound-partition%
;; bound-partition%
(define bound-partition%
(class* object% (partition<%>)
;; numbers : bound-identifier-mapping[identifier => number]
(define numbers (make-bound-identifier-mapping))
@ -89,7 +89,7 @@
(or n
(begin0 next-number
(bound-identifier-mapping-put! numbers r next-number)
#;(printf "primary partition new stx:~n~s~n~s~n" stx (syntax-object->datum stx))
#;(printf "primary partition new stx:~n~s~n~s~n" stx (syntax->datum stx))
(set! next-number (add1 next-number))))))
(define/public (same-partition? a b)
@ -99,61 +99,59 @@
next-number)
(define/private (representative stx)
(datum->syntax-object stx representative-symbol))
(datum->syntax stx representative-symbol))
(get-partition unmarked-syntax)
(super-new)))
;; Different identifier relations for highlighting.
;; Different identifier relations for highlighting.
(define (lift/rep id=?)
(define (lift/rep id=?)
(lambda (A B)
(let ([ra (datum->syntax-object A representative-symbol)]
[rb (datum->syntax-object B representative-symbol)])
(let ([ra (datum->syntax A representative-symbol)]
[rb (datum->syntax B representative-symbol)])
(id=? ra rb))))
(define (lift id=?)
(define (lift id=?)
(lambda (A B)
(and (identifier? A) (identifier? B) (id=? A B))))
;; id:same-marks? : syntax syntax -> boolean
(define id:same-marks?
;; 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)
;; 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)]
(free-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)
(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)]
(free-identifier=? A B)]
[(or (not ba) (not bb))
(and (not ba) (not bb))]
[else (eq? (caddr ba) (caddr bb))])))
(define (symbolic-identifier=? A B)
(define (symbolic-identifier=? A B)
(eq? (syntax-e A) (syntax-e B)))
(define identifier=-choices
(define identifier=-choices
(make-parameter
`(("<nothing>" . #f)
("bound-identifier=?" . ,bound-identifier=?)
("module-identifier=?" . ,module-identifier=?)
("free-identifier=?" . ,free-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=?))))
)

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

@ -1,32 +1,31 @@
(module prefs mzscheme
(require (lib "class.ss")
(lib "framework.ss" "framework")
#lang scheme/base
(require scheme/class
framework/framework
"interfaces.ss"
"../util/misc.ss")
(provide syntax-prefs%
(provide syntax-prefs%
syntax-prefs-mixin
pref:tabify)
(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?)
(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)
(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)
(pref:get/set pref:tabify framework:tabify)
(pref:get/set pref:tabify framework:tabify)
(define syntax-prefs-mixin
(define syntax-prefs-mixin
(closure-mixin (syntax-prefs<%>)
(pref:width pref:width)
(pref:height pref:height)
(pref:props-percentage pref:props-percentage)
(pref:props-shown? pref:props-shown?)))
(define syntax-prefs% (syntax-prefs-mixin object%))
)
(define syntax-prefs% (syntax-prefs-mixin object%))

84
collects/macro-debugger/syntax-browser/pretty-helper.ss
View File

@ -1,49 +1,49 @@
(module pretty-helper mzscheme
(require (lib "class.ss")
(lib "stx.ss" "syntax")
#lang scheme/base
(require scheme/class
syntax/stx
"partition.ss")
(provide (all-defined))
(provide (all-defined-out))
;; 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.
;; 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
;; 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
;; NOTE: Nulls are only wrapped when *not* list-terminators.
;; If they were always wrapped, the pretty-printer would screw up
;; list printing (I think).
;; NOTE: Nulls are only wrapped when *not* list-terminators.
;; If they were always wrapped, the pretty-printer would screw up
;; list printing (I think).
(define-struct syntax-dummy (val))
(define-struct syntax-dummy (val))
;; A SuffixOption is one of
;; - 'never -- never
;; - 'always -- suffix > 0
;; - 'over-limit -- suffix > limit
;; - 'all-if-over-limit -- suffix > 0 if any over limit
;; A SuffixOption is one of
;; - 'never -- never
;; - 'always -- suffix > 0
;; - 'over-limit -- suffix > limit
;; - 'all-if-over-limit -- suffix > 0 if any over limit
;; syntax->datum/tables : stx [partition% num SuffixOption]
;; -> (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
;;
;; 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
;; syntax->datum/tables : stx [partition% num SuffixOption]
;; -> (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
;;
;; 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 'never)]
[(stx partition limit suffixopt) (table stx partition limit suffixopt)]))
;; table : syntax maybe-partition% maybe-num SuffixOption -> (values s-expr hashtable hashtable)
(define (table stx partition limit suffixopt)
;; table : syntax maybe-partition% maybe-num SuffixOption -> (values s-expr hashtable hashtable)
(define (table stx partition limit suffixopt)
(define (make-identifier-proxy id)
(case suffixopt
((never) (unintern (syntax-e id)))
@ -118,15 +118,15 @@
flat=>stx
stx=>flat))))
;; check+convert-special-expression : syntax -> #f/syntaxish
(define (check+convert-special-expression stx)
;; check+convert-special-expression : syntax -> #f/syntaxish
(define (check+convert-special-expression stx)
(define stx-list (stx->list stx))
(and stx-list (= 2 (length stx-list))
(let ([kw (car stx-list)]
[expr (cadr stx-list)])
(and (identifier? kw)
(memq (syntax-e kw) special-expression-keywords)
(bound-identifier=? kw (datum->syntax-object stx (syntax-e kw)))
(bound-identifier=? kw (datum->syntax stx (syntax-e kw)))
(andmap (lambda (f) (equal? (f stx) (f kw)))
(list syntax-source
syntax-line
@ -137,14 +137,12 @@
(cons (syntax-e kw)
(list expr))))))
(define special-expression-keywords
(define special-expression-keywords
'(quote quasiquote unquote unquote-splicing syntax))
;; FIXME: quasisyntax unsyntax unsyntax-splicing
;; FIXME: quasisyntax unsyntax unsyntax-splicing
(define (unintern sym)
(define (unintern sym)
(string->uninterned-symbol (symbol->string sym)))
(define (suffix sym n)
(define (suffix sym n)
(string->uninterned-symbol (format "~a:~a" sym n)))
)

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

@ -1,20 +1,20 @@
;; FIXME: Need to disable printing of structs with custom-write property
(module pretty-printer mzscheme
(require (lib "list.ss")
(lib "class.ss")
(lib "pretty.ss")
(lib "mred.ss" "mred")
#lang scheme/base
(require scheme/list
scheme/class
scheme/pretty
scheme/gui
"pretty-helper.ss"
"interfaces.ss"
"params.ss"
"prefs.ss")
(provide pretty-print-syntax)
(provide pretty-print-syntax)
;; pretty-print-syntax : syntax port partition -> range%
(define (pretty-print-syntax stx port primary-partition)
;; pretty-print-syntax : syntax port partition -> range%
(define (pretty-print-syntax stx port primary-partition)
(define range-builder (new range-builder%))
(define-values (datum ht:flat=>stx ht:stx=>flat)
(syntax->datum/tables stx primary-partition
@ -67,7 +67,7 @@
(range-builder range-builder)
(identifier-list identifier-list))))
(define (pp-print-hook obj display-like? port)
(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%)
@ -75,7 +75,7 @@
[else
(error 'pretty-print-hook "unexpected special value: ~e" obj)]))
(define (pp-size-hook obj display-like? port)
(define (pp-size-hook obj display-like? port)
(cond [(is-a? obj editor-snip%)
(pretty-print-columns)]
[(syntax-dummy? obj)
@ -84,7 +84,7 @@
(string-length (get-output-string ostring)))]
[else #f]))
(define (pp-better-style-table)
(define (pp-better-style-table)
(let* ([pref (pref:tabify)]
[table (car pref)]
[begin-rx (cadr pref)]
@ -96,19 +96,19 @@
(map car style-list)
(map cdr style-list)))))
(define (basic-style-list)
(define (basic-style-list)
(pretty-print-extend-style-table
(pretty-print-current-style-table)
(map car basic-styles)
(map cdr basic-styles)))
(define basic-styles
(define basic-styles
'((define-values . define)
(define-syntaxes . define-syntax)))
(define-local-member-name range:get-ranges)
(define-local-member-name range:get-ranges)
;; range-builder%
(define range-builder%
;; range-builder%
(define range-builder%
(class object%
(define starts (make-hash-table))
(define ranges (make-hash-table))
@ -129,8 +129,8 @@
(super-new)))
;; range%
(define range%
;; range%
(define range%
(class* object% (range<%>)
(init range-builder)
(init-field identifier-list)
@ -158,4 +158,3 @@
(>= (- (range-end x) (range-start x))
(- (range-end y) (range-start y))))))))
)

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

@ -1,16 +1,14 @@
(module properties mzscheme
(require "interfaces.ss"
"util.ss"
(lib "class.ss")
(lib "mred.ss" "mred")
#;(lib "framework.ss" "framework")
#;(lib "interactive-value-port.ss" "mrlib"))
(provide properties-view%
#lang scheme/base
(require scheme/class
scheme/gui
"interfaces.ss"
"util.ss")
(provide properties-view%
properties-snip%)
;; properties-view-base-mixin
(define properties-view-base-mixin
;; properties-view-base-mixin
(define properties-view-base-mixin
(mixin () ()
;; controller : controller<%>
(init-field controller)
@ -68,8 +66,8 @@
(refresh)))
;; properties-snip%
(define properties-snip%
;; properties-snip%
(define properties-snip%
(class (properties-view-base-mixin editor-snip%)
(inherit-field text)
(inherit-field pdisplayer)
@ -99,8 +97,8 @@
(send outer-text hide-caret #t)
(send outer-text lock #t)))
;; properties-view%
(define properties-view%
;; properties-view%
(define properties-view%
(class* (properties-view-base-mixin object%) ()
(init parent)
(inherit-field text)
@ -124,8 +122,8 @@
(set-mode (cdr (list-ref tab-choices (send tp get-selection))))))))
(define ecanvas (new editor-canvas% (editor text) (parent tab-panel)))))
;; properties-displayer%
(define properties-displayer%
;; properties-displayer%
(define properties-displayer%
(class* object% ()
(init-field text)
@ -151,13 +149,13 @@
(cond
[(identifier? stx)
(display "Binding if used for #%top\n" key-sd)
(display-bindings (datum->syntax-object stx '#%top))]
(display-bindings (datum->syntax stx '#%top))]
[(and (syntax? stx) (pair? (syntax-e stx)))
(display "Binding if used for #%app\n" key-sd)
(display-bindings (datum->syntax-object stx '#%app))]
(display-bindings (datum->syntax stx '#%app))]
[else
(display "Binding if used for #%datum\n" key-sd)
(display-bindings (datum->syntax-object stx '#%datum))]))
(display-bindings (datum->syntax stx '#%datum))]))
;; display-bindings : syntax -> void
(define/private (display-bindings stx)
@ -181,7 +179,7 @@
(display-subkv " as" (list-ref v 1))
(display-subkv " imported from" (mpi->string (list-ref v 2)))
(display-subkv " as" (list-ref v 3))
(if (list-ref v 4)
(when (list-ref v 4)
(display " via define-for-syntax" sub-key-sd))]))
;; display-stxobj-info : syntax -> void
@ -265,12 +263,12 @@
(super-new)))
;; lift/id : (identifier -> void) 'a -> void
(define (lift/id f)
;; 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
;; binding-properties : (listof (cons string (syntax -> any)))
(define binding-properties
(list (cons "in the standard phase"
(lift/id identifier-binding))
(cons "in the transformer phase (\"for-syntax\")"
@ -278,37 +276,36 @@
(cons "in the template phase (\"for-template\")"
(lift/id identifier-template-binding))))
(define (uninterned? s)
(define (uninterned? s)
(not (eq? s (string->symbol (symbol->string s)))))
(define (prettify-source s)
(define (prettify-source s)
(cond [(is-a? s editor<%>)
'editor]
[else s]))
;; Styles
;; Styles
(define key-sd
(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
(define sub-key-sd
(let ([sd (new style-delta%)])
(send sd set-delta-foreground "blue")
sd))
(define n/a-sd
(define n/a-sd
(let ([sd (new style-delta%)])
(send sd set-delta-foreground "gray")
sd))
(define style:normal (make-object style-delta% 'change-normal))
(define style:normal (make-object style-delta% 'change-normal))
(define style:hyper
(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))
)

61
collects/macro-debugger/syntax-browser/text.ss
View File

@ -1,13 +1,13 @@
(module text mzscheme
(require (lib "list.ss")
(lib "class.ss")
(lib "mred.ss" "mred")
(lib "arrow.ss" "drscheme")
(lib "framework.ss" "framework")
#lang scheme/base
(require scheme/list
scheme/class
scheme/gui
drscheme/arrow
framework/framework
"../util/notify.ss")
(provide text:hover<%>
(provide text:hover<%>
text:hover-identifier<%>
text:mouse-drawings<%>
text:arrows<%>
@ -18,42 +18,42 @@
text:tacking-mixin
text:arrows-mixin)
(define arrow-brush
(define arrow-brush
(send the-brush-list find-or-create-brush "white" 'solid))
(define (tacked-arrow-brush color)
(define (tacked-arrow-brush color)
(send the-brush-list find-or-create-brush color 'solid))
(define billboard-brush
(define billboard-brush
(send the-brush-list find-or-create-brush "white" 'solid))
(define white (send the-color-database find-color "white"))
(define white (send the-color-database find-color "white"))
;; A Drawing is (make-drawing number number (??? -> void) boolean boolean)
(define-struct drawing (start end draw visible? tacked?) #f)
;; A Drawing is (make-drawing number number (??? -> void) boolean boolean)
(define-struct drawing (start end draw visible? tacked?) #:mutable)
(define-struct idloc (start end id) #f)
(define-struct idloc (start end id))
(define (mean x y)
(define (mean x y)
(/ (+ x y) 2))
(define-syntax with-saved-pen&brush
(define-syntax with-saved-pen&brush
(syntax-rules ()
[(with-saved-pen&brush dc . body)
(save-pen&brush dc (lambda () . body))]))
(define (save-pen&brush dc thunk)
(define (save-pen&brush dc thunk)
(let ([old-pen (send dc get-pen)]
[old-brush (send dc get-brush)])
(begin0 (thunk)
(send dc set-pen old-pen)
(send dc set-brush old-brush))))
(define-syntax with-saved-text-config
(define-syntax with-saved-text-config
(syntax-rules ()
[(with-saved-text-config dc . body)
(save-text-config dc (lambda () . body))]))
(define (save-text-config dc thunk)
(define (save-text-config dc thunk)
(let ([old-font (send dc get-font)]
[old-color (send dc get-text-foreground)]
[old-background (send dc get-text-background)]
@ -64,29 +64,29 @@
(send dc set-text-background old-background)
(send dc set-text-mode old-mode))))
(define text:hover<%>
(define text:hover<%>
(interface (text:basic<%>)
update-hover-position))
(define text:hover-identifier<%>
(define text:hover-identifier<%>
(interface ()
get-hovered-identifier
set-hovered-identifier
listen-hovered-identifier))
(define text:mouse-drawings<%>
(define text:mouse-drawings<%>
(interface (text:basic<%>)
add-mouse-drawing
for-each-drawing
delete-all-drawings))
(define text:arrows<%>
(define text:arrows<%>
(interface (text:mouse-drawings<%>)
add-arrow
add-question-arrow
add-billboard))
(define text:hover-mixin
(define text:hover-mixin
(mixin (text:basic<%>) (text:hover<%>)
(inherit dc-location-to-editor-location
find-position)
@ -106,7 +106,7 @@
(super-new)))
(define text:hover-identifier-mixin
(define text:hover-identifier-mixin
(mixin (text:hover<%>) (text:hover-identifier<%>)
(field/notify hovered-identifier (new notify-box% (value #f)))
@ -129,7 +129,7 @@
[else (search (cdr idlocs))])))
(super-new)))
(define text:mouse-drawings-mixin
(define text:mouse-drawings-mixin
(mixin (text:hover<%>) (text:mouse-drawings<%>)
(inherit dc-location-to-editor-location
find-position
@ -178,7 +178,7 @@
(super-new)))
(define text:tacking-mixin
(define text:tacking-mixin
(mixin (text:basic<%> text:mouse-drawings<%>) ()
(inherit get-canvas
for-each-drawing)
@ -220,7 +220,7 @@
(when (drawing-visible? d)
(set-box! (drawing-tacked? d) #f)))))))
(define text:arrows-mixin
(define text:arrows-mixin
(mixin (text:mouse-drawings<%>) (text:arrows<%>)
(inherit position-location
add-mouse-drawing
@ -312,13 +312,12 @@
(super-new)))
(define text:mouse-drawings%
(define text:mouse-drawings%
(text:mouse-drawings-mixin
(text:hover-mixin
text:standard-style-list%)))
(define text:arrows%
(define text:arrows%
(text:arrows-mixin
(text:tacking-mixin
text:mouse-drawings%)))
)

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

@ -1,14 +1,14 @@
(module util mzscheme
(require (lib "class.ss"))
(provide with-unlock
#lang scheme/base
(require scheme/class)
(provide with-unlock
make-text-port
mpi->string
mpi->list)
;; with-unlock SYNTAX (expression)
;; (with-unlock text-expression . body)
(define-syntax with-unlock
;; with-unlock SYNTAX (expression)
;; (with-unlock text-expression . body)
(define-syntax with-unlock
(syntax-rules ()
[(with-unlock text . body)
(let* ([t text]
@ -17,9 +17,9 @@
(begin0 (let () . body)
(send t lock locked?)))]))
;; make-text-port : text (-> number) -> port
;; builds a port from a text object.
(define (make-text-port text end-position)
;; make-text-port : text (-> number) -> port
;; builds a port from a text object.
(define (make-text-port text end-position)
(make-output-port #f
always-evt
(lambda (s start end flush? enable-break?)
@ -32,8 +32,8 @@
(send text insert special (end-position))
#t)))
;; mpi->string : module-path-index -> string
(define (mpi->string mpi)
;; mpi->string : module-path-index -> string
(define (mpi->string mpi)
(if (module-path-index? mpi)
(let ([mps (mpi->list mpi)])
(cond [(and (pair? mps) (pair? (cdr mps)))
@ -45,8 +45,8 @@
[(null? mps) "this module"]))
(format "~s" mpi)))
;; mpi->list : module-path-index -> (list-of module-spec)
(define (mpi->list mpi)
;; mpi->list : module-path-index -> (list-of module-spec)
(define (mpi->list mpi)
(cond [(module-path-index? mpi)
(let-values ([(path rel) (module-path-index-split mpi)])
(cond [(and (pair? path) (memq (car path) '(file lib planet)))
@ -57,4 +57,3 @@
[(not mpi)
'()]
[else (list mpi)]))
)

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

@ -1,12 +1,12 @@
(module widget mzscheme
(require (lib "class.ss")
(lib "mred.ss" "mred")
(lib "framework.ss" "framework")
(lib "list.ss")
(lib "plt-match.ss")
(lib "kw.ss")
(lib "boundmap.ss" "syntax")
#lang mzscheme
(require scheme/class
mred/mred
framework/framework
scheme/list
scheme/match
mzlib/kw
syntax/boundmap
"interfaces.ss"
"params.ss"
"controller.ss"
@ -16,13 +16,13 @@
"properties.ss"
"text.ss"
"util.ss")
(provide widget%
(provide widget%
widget-keymap%
widget-context-menu%)
;; widget%
;; A syntax widget creates its own syntax-controller.
(define widget%
;; widget%
;; A syntax widget creates its own syntax-controller.
(define widget%
(class* object% (widget-hooks<%>)
(init parent)
(init-field config)
@ -201,21 +201,21 @@
(super-new)
(setup-keymap)))
(define clickback-style
(define clickback-style
(let ([sd (new style-delta%)])
(send sd set-delta 'change-toggle-underline)
(send sd set-delta-foreground "blue")
sd))
(define error-text-style
(define error-text-style
(let ([sd (new style-delta%)])
(send sd set-delta 'change-italic)
(send sd set-delta-foreground "red")
sd))
;; Specialized classes for widget
;; Specialized classes for widget
(define widget-keymap%
(define widget-keymap%
(class syntax-keymap%
(init-field widget)
(super-new (controller (send widget get-controller)))
@ -231,7 +231,7 @@
(define/public (get-widget) widget)))
(define widget-context-menu%
(define widget-context-menu%
(class context-menu%
(inherit-field keymap)
(inherit-field props-menu)
@ -244,7 +244,7 @@
(super on-demand))
(super-new)))
(define browser-text%
(define browser-text%
(class (text:arrows-mixin
(text:tacking-mixin
(text:mouse-drawings-mixin
@ -255,4 +255,3 @@
(define/override (default-style-name) "Basic")
(super-new (auto-wrap #t))
(set-autowrap-bitmap #f)))
)

59
collects/macro-debugger/view/cursor.ss
View File

@ -1,6 +1,7 @@
(module cursor mzscheme
(provide cursor?
#lang scheme/base
(require scheme/promise)
(provide cursor?
cursor:new
cursor:add-to-end!
cursor:remove-current!
@ -24,109 +25,107 @@
cursor:prefix->list
cursor:suffix->list)
(define-syntax stream-cons
(define-syntax stream-cons
(syntax-rules ()
[(stream-cons x y)
(delay (cons x y))]))
(define (stream-car x)
(define (stream-car x)
(if (promise? x)
(car (force x))
(car x)))
(define (stream-cdr x)
(define (stream-cdr x)
(if (promise? x)
(cdr (force x))
(cdr x)))
(define (stream-null? x)
(define (stream-null? x)
(or (null? x)
(and (promise? x) (null? (force x)))))
(define (stream-append x y)
(define (stream-append x y)
(if (stream-null? x)
y
(stream-cons (stream-car x)
(stream-append (stream-cdr x) y))))
(define (stream->list s)
(define (stream->list s)
(if (stream-null? s)
null
(cons (stream-car s) (stream->list (stream-cdr s)))))
;; Cursors
;; Cursors
;; A (Cursor-of 'a) is (make-cursor (list-of 'a) (Stream-of 'a))
(define-struct cursor (prefix suffixp))
;; A (Cursor-of 'a) is (make-cursor (list-of 'a) (Stream-of 'a))
(define-struct cursor (prefix suffixp) #:mutable)
(define (cursor:new items)
(define (cursor:new items)
(make-cursor null items))
(define (cursor:add-to-end! c items)
(define (cursor:add-to-end! c items)
(let ([suffix (cursor-suffixp c)])
(set-cursor-suffixp! c (stream-append suffix items))))
(define (cursor:remove-current! c)
(define (cursor:remove-current! c)
(when (cursor:has-next? c)
(set-cursor-suffixp! c (stream-cdr (cursor-suffixp c)))))
(define (cursor:next c)
(define (cursor:next c)
(let ([suffix (cursor-suffixp c)])
(if (stream-null? suffix)
#f
(stream-car suffix))))
(define (cursor:prev c)
(define (cursor:prev c)
(let ([prefix (cursor-prefix c)])
(if (pair? prefix)
(car prefix)
#f)))
(define (cursor:move-prev c)
(define (cursor:move-prev c)
(when (pair? (cursor-prefix c))
(let ([old-prefix (cursor-prefix c)])
(set-cursor-prefix! c (cdr old-prefix))
(set-cursor-suffixp! c (cons (car old-prefix) (cursor-suffixp c))))))
(define (cursor:move-next c)
(define (cursor:move-next c)
(when (cursor:has-next? c)
(let* ([old-suffixp (cursor-suffixp c)])
(set-cursor-prefix! c (cons (stream-car old-suffixp)
(cursor-prefix c)))
(set-cursor-suffixp! c (stream-cdr old-suffixp)))))
(define (cursor:at-start? c)
(define (cursor:at-start? c)
(null? (cursor-prefix c)))
(define (cursor:at-end? c)
(define (cursor:at-end? c)
(stream-null? (cursor-suffixp c)))
(define (cursor:has-next? c)
(define (cursor:has-next? c)
(not (cursor:at-end? c)))
(define (cursor:has-prev? c)
(define (cursor:has-prev? c)
(not (cursor:at-start? c)))
(define (cursor:move-to-start c)
(define (cursor:move-to-start c)
(when (cursor:has-prev? c)
(cursor:move-prev c)
(cursor:move-to-start c)))
(define (cursor:move-to-end c)
(define (cursor:move-to-end c)
(when (cursor:has-next? c)
(cursor:move-next c)
(cursor:move-to-end c)))
(define (cursor:skip-to c i)
(define (cursor:skip-to c i)
(unless (or (eq? (cursor:next c) i) (cursor:at-end? c))
(cursor:move-next c)
(cursor:skip-to c i)))
(define (cursor->list c)
(define (cursor->list c)
(append (cursor:prefix->list c)
(cursor:suffix->list c)))
(define (cursor:prefix->list c)
(define (cursor:prefix->list c)
(reverse (cursor-prefix c)))
(define (cursor:suffix->list c)
(define (cursor:suffix->list c)
(stream->list (cursor-suffixp c)))
)

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

@ -1,11 +1,10 @@
(module debug-format mzscheme
(require (lib "pretty.ss"))
(provide write-debug-file
#lang scheme/base
(require scheme/pretty)
(provide write-debug-file
load-debug-file)
(define (write-debug-file file exn events)
(define (write-debug-file file exn events)
(with-output-to-file file
(lambda ()
(write `(list ,@(map (lambda (e) (serialize-datum e)) events)))
@ -17,7 +16,7 @@
(exn-continuation-marks exn)))))
'replace))
(define (serialize-datum d)
(define (serialize-datum d)
(cond [(number? d) `(quote ,d)]
[(boolean? d) `(quote ,d)]
[(symbol? d) `(quote ,d)]
@ -25,17 +24,17 @@
[(pair? d) `(cons ,(serialize-datum (car d)) ,(serialize-datum (cdr d)))]
[(null? d) '()]
[(exn? d) `(make-exn ,(exn-message d) (current-continuation-marks))]
[(syntax? d) `(datum->syntax-object #f ',(syntax-object->datum d))]
[(syntax? d) `(datum->syntax #f ',(syntax->datum d))]
#;[(syntax? d) `(eval (quote ,(compile `(,#'quote-syntax ,d))))]
[else (error 'serialize-datum "got ~s" d)]))
(define (serialize-context-frame frame)
(define (serialize-context-frame frame)
(cons (car frame)
(if (cdr frame)
(serialize-srcloc (cdr frame))
null)))
(define (serialize-srcloc s)
(define (serialize-srcloc s)
(list (let ([src (srcloc-source s)])
(cond [(path? src) (path->string src)]
[(string? src) src]
@ -43,7 +42,7 @@
(srcloc-line s)
(srcloc-column s)))
(define (load-debug-file file)
(define (load-debug-file file)
(parameterize ((read-accept-compiled #t))
(with-input-from-file file
(lambda ()
@ -52,4 +51,3 @@
[ctx (read)])
(let ([events (eval events-expr)])
(values events exnmsg ctx)))))))
)

17
collects/macro-debugger/view/debug.ss
View File

@ -1,35 +1,34 @@
(module debug mzscheme
(require (lib "pretty.ss")
(lib "class.ss")
#lang scheme/base
(require scheme/pretty
scheme/class
"debug-format.ss"
"prefs.ss"
"view.ss")
(provide debug-file)
(provide debug-file)
(define (widget-mixin %)
(define (widget-mixin %)
(class %
(define/override (top-interaction-kw? x)
(eq? (syntax-e x) '#%top-interaction))
(super-new)))
(define stepper-frame%
(define stepper-frame%
(class macro-stepper-frame%
(define/override (get-macro-stepper-widget%)
(widget-mixin (super get-macro-stepper-widget%)))
(super-new)))
(define (make-stepper)
(define (make-stepper)
(let ([f (new macro-stepper-frame%
(config (new macro-stepper-config/prefs%)))])
(send f show #t)
(send f get-widget)))
(define (debug-file file)
(define (debug-file file)
(let-values ([(events msg ctx) (load-debug-file file)])
(pretty-print msg)
(pretty-print ctx)
(let* ([w (make-stepper)])
(send w add-trace events)
w)))
)

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

@ -1,31 +1,31 @@
(module extensions mzscheme
(require (lib "class.ss")
(lib "unit.ss")
(lib "list.ss")
(lib "plt-match.ss")
(lib "mred.ss" "mred")
(lib "framework.ss" "framework")
(lib "boundmap.ss" "syntax")
#lang scheme/base
(require scheme/class
scheme/unit
scheme/list
scheme/match
scheme/gui
framework/framework
syntax/boundmap
"interfaces.ss"
"prefs.ss"
"warning.ss"
"hiding-panel.ss"
(prefix s: "../syntax-browser/widget.ss")
(prefix-in s: "../syntax-browser/widget.ss")
"../model/deriv.ss"
"../model/deriv-util.ss"
"../model/trace.ss"
"../model/hide.ss"
"../model/steps.ss"
"cursor.ss"
"util.ss")
(provide stepper-keymap%
"../util/notify.ss")
(provide stepper-keymap%
stepper-context-menu%
stepper-syntax-widget%)
;; Extensions
;; Extensions
(define stepper-keymap%
(define stepper-keymap%
(class s:widget-keymap%
(init-field macro-stepper)
(inherit-field controller)
@ -51,7 +51,7 @@
(add-hide-identifier)
(refresh))))))
(define stepper-context-menu%
(define stepper-context-menu%
(class s:widget-context-menu%
(inherit-field keymap)
(inherit add-separator)
@ -83,7 +83,7 @@
(super-new)))
(define stepper-syntax-widget%
(define stepper-syntax-widget%
(class s:widget%
(init-field macro-stepper)
(inherit get-text)
@ -102,11 +102,10 @@
(config (new config-adapter%
(config (send macro-stepper get-config)))))))
(define config-adapter%
(define config-adapter%
(class object%
(init-field config)
(define/public pref:props-percentage
(case-lambda [() (send config get-props-percentage)]
[(v) (send config set-props-percentage v)]))
(super-new)))
)

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

@ -1,30 +1,30 @@
(module frame mzscheme
(require (lib "class.ss")
(lib "unit.ss")
(lib "list.ss")
(lib "file.ss")
(lib "plt-match.ss")
(lib "mred.ss" "mred")
(lib "framework.ss" "framework")
(lib "boundmap.ss" "syntax")
#lang scheme/base
(require scheme/class
scheme/unit
scheme/list
scheme/file
scheme/match
scheme/gui
framework/framework
syntax/boundmap
"interfaces.ss"
"stepper.ss"
"prefs.ss"
"warning.ss"
"hiding-panel.ss"
(prefix sb: "../syntax-browser/embed.ss")
(prefix sb: "../syntax-browser/params.ss")
(prefix-in sb: "../syntax-browser/embed.ss")
(prefix-in sb: "../syntax-browser/params.ss")
"../model/deriv.ss"
"../model/deriv-util.ss"
"../model/trace.ss"
"../model/hide.ss"
"../model/steps.ss"
"cursor.ss"
"util.ss")
(provide macro-stepper-frame-mixin)
"../util/notify.ss")
(provide macro-stepper-frame-mixin)
(define (macro-stepper-frame-mixin base-frame%)
(define (macro-stepper-frame-mixin base-frame%)
(class base-frame%
(init-field config)
(init-field (filename #f))
@ -205,12 +205,12 @@
(frame:reorder-menus this)))
;; Stolen from stepper
;; Stolen from stepper
(define warning-color "yellow")
(define warning-font normal-control-font)
(define warning-color "yellow")
(define warning-font normal-control-font)
(define warning-canvas%
(define warning-canvas%
(class canvas%
(init-field warning)
(inherit get-dc get-client-size)
@ -232,5 +232,3 @@
(min-width (+ 2 (inexact->exact (ceiling tw))))
(min-height (+ 2 (inexact->exact (ceiling th)))))
(stretchable-height #f)))
)

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

@ -1,20 +1,20 @@
(module hiding-panel mzscheme
(require (lib "class.ss")
(lib "mred.ss" "mred")
(lib "list.ss")
(lib "boundmap.ss" "syntax")
"util.ss"
#lang scheme/base
(require scheme/class
scheme/gui
scheme/list
syntax/boundmap
"../model/synth-engine.ss"
"../syntax-browser/util.ss"
"../util/notify.ss"
"../util/hiding.ss")
(provide macro-hiding-prefs-widget%)
(provide macro-hiding-prefs-widget%)
(define mode:disable "Disable")
(define mode:standard "Standard")
(define mode:custom "Custom ...")
(define mode:disable "Disable")
(define mode:standard "Standard")
(define mode:custom "Custom ...")
(define (make-policy hide-mzscheme?
(define (make-policy hide-mzscheme?
hide-libs?
hide-contracts?
hide-transformers?
@ -49,11 +49,11 @@
#f]
[else #t]))))
(define standard-policy
(define standard-policy
(make-policy #t #t #t #t null))
;; macro-hiding-prefs-widget%
(define macro-hiding-prefs-widget%
;; macro-hiding-prefs-widget%
(define macro-hiding-prefs-widget%
(class object%
(init parent)
(init-field stepper)
@ -241,7 +241,7 @@
(return show?)))]
[else
(lambda (id binding return)
(when (module-identifier=? id key)
(when (free-identifier=? id key)
(return show?)))]))
identifier-policies))
@ -289,26 +289,26 @@
(super-new)
(update-visibility)))
(define (get-id-key id)
(define (get-id-key id)
id
#; ;; FIXME
(let ([binding (identifier-binding id)])
(get-id-key/binding id binding)))
(define (get-id-key/binding id binding)
(define (get-id-key/binding id binding)
(cond [(pair? binding)
(list (car binding) (cadr binding))]
[else id]))
(define (key=? key1 key2)
(define (key=? key1 key2)
(cond [(and (identifier? key1) (identifier? key2))
(module-identifier=? key1 key2)]
(free-identifier=? key1 key2)]
[(and (pair? key1) (pair? key2))
(and (equal? (car key1) (car key2))
(equal? (cadr key1) (cadr key2)))]
[else #f]))
(define (key->text key)
(define (key->text key)
(cond [(pair? key)
(let ([name (cadddr key)]
[mod (caddr key)])
@ -317,4 +317,3 @@
(mpi->string mod)))]
[else (symbol->string (syntax-e key))]))
)

38
collects/macro-debugger/view/interfaces.ss
View File

@ -1,21 +1,21 @@
(module interfaces mzscheme
(require (lib "unit.ss"))
(provide (all-defined))
#lang scheme/base
(require scheme/unit)
(provide (all-defined-out))
;; Signatures
;; Signatures
(define-signature view^
(define-signature view^
(macro-stepper-frame%
macro-stepper-widget%
make-macro-stepper
go
go/deriv))
(define-signature view-base^
(define-signature view-base^
(base-frame%))
(define-signature prefs^
(define-signature prefs^
(pref:width
pref:height
pref:props-percentage
@ -33,16 +33,14 @@
pref:force-letrec-transformation?
))
;; macro-stepper-config%
;; all fields are notify-box% objects
;; width
;; height
;; macro-hiding?
;; hide-primitives?
;; hide-libs?
;; show-syntax-properties?
;; show-hiding-panel?
;; show-rename-steps?
;; highlight-foci?
)
;; macro-stepper-config%
;; all fields are notify-box% objects
;; width
;; height
;; macro-hiding?
;; hide-primitives?
;; hide-libs?
;; show-syntax-properties?
;; show-hiding-panel?
;; show-rename-steps?
;; highlight-foci?

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

@ -1,46 +1,46 @@
(module prefs mzscheme
(require (lib "class.ss")
(lib "framework.ss" "framework")
#lang scheme/base
(require scheme/class
framework/framework
"../util/notify.ss"
"../util/misc.ss")
(provide macro-stepper-config-base%
(provide macro-stepper-config-base%
macro-stepper-config/prefs%
macro-stepper-config/prefs/readonly%)
(preferences:set-default 'MacroStepper:Frame:Width 700 number?)
(preferences:set-default 'MacroStepper:Frame:Height 600 number?)
(preferences:set-default 'MacroStepper:PropertiesPanelPercentage 1/3 number?)
(preferences:set-default 'MacroStepper:MacroHidingMode "Standard" string?)
(preferences:set-default 'MacroStepper:ShowSyntaxProperties? #f boolean?)
(preferences:set-default 'MacroStepper:ShowHidingPanel? #t boolean?)
(preferences:set-default 'MacroStepper:IdentifierComparison "bound-identifier=?" string?)
(preferences:set-default 'MacroStepper:HighlightFoci? #t boolean?)
(preferences:set-default 'MacroStepper:HighlightFrontier? #t boolean?)
(preferences:set-default 'MacroStepper:ShowRenameSteps? #f boolean?)
(preferences:set-default 'MacroStepper:SuppressWarnings? #f boolean?)
(preferences:set-default 'MacroStepper:OneByOne? #f boolean?)
(preferences:set-default 'MacroStepper:ExtraNavigation? #f boolean?)
(preferences:set-default 'MacroStepper:DebugCatchErrors? #t boolean?)
(preferences:set-default 'MacroStepper:ForceLetrecTransformation? #f boolean?)
(preferences:set-default 'MacroStepper:Frame:Width 700 number?)
(preferences:set-default 'MacroStepper:Frame:Height 600 number?)
(preferences:set-default 'MacroStepper:PropertiesPanelPercentage 1/3 number?)
(preferences:set-default 'MacroStepper:MacroHidingMode "Standard" string?)
(preferences:set-default 'MacroStepper:ShowSyntaxProperties? #f boolean?)
(preferences:set-default 'MacroStepper:ShowHidingPanel? #t boolean?)
(preferences:set-default 'MacroStepper:IdentifierComparison "bound-identifier=?" string?)
(preferences:set-default 'MacroStepper:HighlightFoci? #t boolean?)
(preferences:set-default 'MacroStepper:HighlightFrontier? #t boolean?)
(preferences:set-default 'MacroStepper:ShowRenameSteps? #f boolean?)
(preferences:set-default 'MacroStepper:SuppressWarnings? #f boolean?)
(preferences:set-default 'MacroStepper:OneByOne? #f boolean?)
(preferences:set-default 'MacroStepper:ExtraNavigation? #f boolean?)
(preferences:set-default 'MacroStepper:DebugCatchErrors? #t boolean?)
(preferences:set-default 'MacroStepper:ForceLetrecTransformation? #f boolean?)
(pref:get/set pref:width MacroStepper:Frame:Width)
(pref:get/set pref:height MacroStepper:Frame:Height)
(pref:get/set pref:props-percentage MacroStepper:PropertiesPanelPercentage)
(pref:get/set pref:macro-hiding-mode MacroStepper:MacroHidingMode)
(pref:get/set pref:show-syntax-properties? MacroStepper:ShowSyntaxProperties?)
(pref:get/set pref:show-hiding-panel? MacroStepper:ShowHidingPanel?)
(pref:get/set pref:identifier=? MacroStepper:IdentifierComparison)
(pref:get/set pref:highlight-foci? MacroStepper:HighlightFoci?)
(pref:get/set pref:highlight-frontier? MacroStepper:HighlightFrontier?)
(pref:get/set pref:show-rename-steps? MacroStepper:ShowRenameSteps?)
(pref:get/set pref:suppress-warnings? MacroStepper:SuppressWarnings?)
(pref:get/set pref:one-by-one? MacroStepper:OneByOne?)
(pref:get/set pref:extra-navigation? MacroStepper:ExtraNavigation?)
(pref:get/set pref:debug-catch-errors? MacroStepper:DebugCatchErrors?)
(pref:get/set pref:force-letrec-transformation? MacroStepper:ForceLetrecTransformation?)
(pref:get/set pref:width MacroStepper:Frame:Width)
(pref:get/set pref:height MacroStepper:Frame:Height)
(pref:get/set pref:props-percentage MacroStepper:PropertiesPanelPercentage)
(pref:get/set pref:macro-hiding-mode MacroStepper:MacroHidingMode)
(pref:get/set pref:show-syntax-properties? MacroStepper:ShowSyntaxProperties?)
(pref:get/set pref:show-hiding-panel? MacroStepper:ShowHidingPanel?)
(pref:get/set pref:identifier=? MacroStepper:IdentifierComparison)
(pref:get/set pref:highlight-foci? MacroStepper:HighlightFoci?)
(pref:get/set pref:highlight-frontier? MacroStepper:HighlightFrontier?)
(pref:get/set pref:show-rename-steps? MacroStepper:ShowRenameSteps?)
(pref:get/set pref:suppress-warnings? MacroStepper:SuppressWarnings?)
(pref:get/set pref:one-by-one? MacroStepper:OneByOne?)
(pref:get/set pref:extra-navigation? MacroStepper:ExtraNavigation?)
(pref:get/set pref:debug-catch-errors? MacroStepper:DebugCatchErrors?)
(pref:get/set pref:force-letrec-transformation? MacroStepper:ForceLetrecTransformation?)
(define macro-stepper-config-base%
(define macro-stepper-config-base%
(class object%
(notify-methods width)
(notify-methods height)
@ -59,7 +59,7 @@
(notify-methods force-letrec-transformation?)
(super-new)))
(define macro-stepper-config/prefs%
(define macro-stepper-config/prefs%
(class macro-stepper-config-base%
(connect-to-pref width pref:width)
(connect-to-pref height pref:height)
@ -78,7 +78,7 @@
(connect-to-pref force-letrec-transformation? pref:force-letrec-transformation?)
(super-new)))
(define macro-stepper-config/prefs/readonly%
(define macro-stepper-config/prefs/readonly%
(class macro-stepper-config-base%
(connect-to-pref/readonly width pref:width)
(connect-to-pref/readonly height pref:height)
@ -96,5 +96,3 @@
(connect-to-pref/readonly debug-catch-errors? pref:debug-catch-errors?)
(connect-to-pref/readonly force-letrec-transformation? pref:force-letrec-transformation?)
(super-new)))
)

35
collects/macro-debugger/view/stepper.ss
View File

@ -1,20 +1,20 @@
(module stepper mzscheme
(require (lib "class.ss")
(lib "unit.ss")
(lib "list.ss")
(lib "plt-match.ss")
(lib "mred.ss" "mred")
(lib "framework.ss" "framework")
(lib "boundmap.ss" "syntax")
#lang scheme/base
(require scheme/class
scheme/unit
scheme/list
scheme/match
scheme/gui
framework/framework
syntax/boundmap
"interfaces.ss"
"prefs.ss"
"extensions.ss"
"warning.ss"
"hiding-panel.ss"
"term-record.ss"
(prefix s: "../syntax-browser/widget.ss")
(prefix s: "../syntax-browser/params.ss")
(prefix-in s: "../syntax-browser/widget.ss")
(prefix-in s: "../syntax-browser/params.ss")
"../model/deriv.ss"
"../model/deriv-util.ss"
"../model/deriv-find.ss"
@ -23,14 +23,14 @@
"../model/hide.ss"
"../model/steps.ss"
"cursor.ss"
"util.ss")
(provide macro-stepper-widget%
"../util/notify.ss")
(provide macro-stepper-widget%
macro-stepper-widget/process-mixin)
;; Macro Stepper
;; Macro Stepper
;; macro-stepper-widget%
(define macro-stepper-widget%
;; macro-stepper-widget%
(define macro-stepper-widget%
(class* object% ()
(init-field parent)
(init-field config)
@ -379,7 +379,7 @@
(refresh/move)
))
(define (macro-stepper-widget/process-mixin %)
(define (macro-stepper-widget/process-mixin %)
(class %
(super-new)
(define/override (get-preprocess-deriv)
@ -427,7 +427,6 @@
[else #f])))
(define/public (top-interaction-kw? x)
(module-identifier=? x #'#%top-interaction))
(free-identifier=? x #'#%top-interaction))
))
)

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

@ -1,19 +1,19 @@
(module term-record mzscheme
(require (lib "class.ss")
(lib "unit.ss")
(lib "list.ss")
(lib "plt-match.ss")
(lib "mred.ss" "mred")
(lib "framework.ss" "framework")
(lib "boundmap.ss" "syntax")
#lang scheme/base
(require scheme/class
scheme/unit
scheme/list
scheme/match
scheme/gui
framework/framework
syntax/boundmap
"interfaces.ss"
"prefs.ss"
"extensions.ss"
"warning.ss"
"hiding-panel.ss"
(prefix s: "../syntax-browser/widget.ss")
(prefix s: "../syntax-browser/params.ss")
(prefix-in s: "../syntax-browser/widget.ss")
(prefix-in s: "../syntax-browser/params.ss")
"../model/deriv.ss"
"../model/deriv-util.ss"
"../model/deriv-find.ss"
@ -24,21 +24,21 @@
"../model/steps.ss"
"debug-format.ss"
"cursor.ss"
"util.ss")
"../util/notify.ss")
(provide term-record%)
(provide term-record%)
;; Struct for one-by-one stepping
;; Struct for one-by-one stepping
(define-struct (prestep protostep) (foci1 e1))
(define-struct (poststep protostep) (foci2 e2))
(define-struct (prestep protostep) (foci1 e1))
(define-struct (poststep protostep) (foci2 e2))
(define (prestep-term1 s) (context-fill (protostep-ctx s) (prestep-e1 s)))
(define (poststep-term2 s) (context-fill (protostep-ctx s) (poststep-e2 s)))
(define (prestep-term1 s) (context-fill (protostep-ctx s) (prestep-e1 s)))
(define (poststep-term2 s) (context-fill (protostep-ctx s) (poststep-e2 s)))
;; TermRecords
;; TermRecords
(define term-record%
(define term-record%
(class object%
(init-field stepper)
(init-field [events #f])
@ -389,15 +389,15 @@
(define/public (add-syntax stx binders definites)
(send sbview add-syntax stx
#:alpha-table binders
#:definites definites))
'#:alpha-table binders
'#:definites definites))
(define/private (add-final stx error binders definites)
(when stx
(send sbview add-text "Expansion finished\n")
(send sbview add-syntax stx
#:alpha-table binders
#:definites (or definites null)))
'#:alpha-table binders
'#:definites (or definites null)))
(when error
(add-error error)))
@ -484,8 +484,8 @@
(send sbview add-text "\n")
(when (exn:fail:syntax? (misstep-exn step))
(for-each (lambda (e) (send sbview add-syntax e
#:alpha-table binders
#:definites (protostep-definites step)))
'#:alpha-table binders
'#:definites (protostep-definites step)))
(exn:fail:syntax-exprs (misstep-exn step))))
(show-lctx step binders))
@ -493,12 +493,12 @@
;; insert-syntax/color : syntax syntaxes identifiers syntaxes string -> void
(define/private (insert-syntax/color stx foci binders definites frontier hi-color)
(send sbview add-syntax stx
#:definites definites
#:alpha-table binders
#:hi-color hi-color
#:hi-stxs (if (send config get-highlight-foci?) foci null)
#:hi2-color "WhiteSmoke"
#:hi2-stxs (if (send config get-highlight-frontier?) frontier null)))
'#:definites definites
'#:alpha-table binders
'#:hi-color hi-color
'#:hi-stxs (if (send config get-highlight-foci?) foci null)
'#:hi2-color "WhiteSmoke"
'#:hi2-stxs (if (send config get-highlight-frontier?) frontier null)))
;; insert-syntax/redex : syntax syntaxes identifiers syntaxes -> void
(define/private (insert-syntax/redex stx foci binders definites frontier)
@ -538,5 +538,3 @@
))
)

26
collects/macro-debugger/view/view.ss
View File

@ -1,43 +1,41 @@
(module view mzscheme
(require (lib "class.ss")
(lib "pretty.ss")
(lib "mred.ss" "mred")
(lib "framework.ss" "framework")
#lang scheme/base
(require scheme/class
scheme/pretty
scheme/gui
framework/framework
"interfaces.ss"
"frame.ss"
"prefs.ss"
"../model/trace.ss")
(provide (all-defined))
(provide (all-defined-out))
(define macro-stepper-frame%
(define macro-stepper-frame%
(macro-stepper-frame-mixin
(frame:standard-menus-mixin
(frame:basic-mixin frame%))))
;; Main entry points
;; Main entry points
(define (make-macro-stepper)
(define (make-macro-stepper)
(let ([f (new macro-stepper-frame%
(config (new macro-stepper-config/prefs%)))])
(send f show #t)
(send f get-widget)))
(define (go stx)
(define (go stx)
(let ([stepper (make-macro-stepper)])
(send stepper add-deriv (trace stx))
stepper))
(define (go/deriv deriv)
(define (go/deriv deriv)
(let* ([f (new macro-stepper-frame%)]
[w (send f get-widget)])
(send w add-deriv deriv)
(send f show #t)
w))
(define (go/trace events)
(define (go/trace events)
(let* ([w (make-macro-stepper)])
(send w add-trace events)
w))
)