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

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

@ -1,35 +1,35 @@
#lang scheme/base
(module context mzscheme (require syntax/stx)
(require (lib "stx.ss" "syntax")) (provide (struct-out ref)
(provide (struct ref (n)) (struct-out tail)
(struct tail (n))
path-get path-get
pathseg-get pathseg-get
path-replace path-replace
pathseg-replace pathseg-replace
find-subterm-paths) find-subterm-paths)
;; A Path is a (list-of PathSeg) ;; A Path is a (list-of PathSeg)
;; where the PathSegs are listed outermost to innermost ;; 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 ;; for example: (path-get #'((a b) (c d)) (list (make-ref 0) (make-ref 1))) = #'b, not #'c
;; A PathSeg is one of: ;; A PathSeg is one of:
;; - (make-ref number) ;; - (make-ref number)
;; - (make-tail number) ;; - (make-tail number)
(define-struct pathseg () #f) (define-struct pathseg () #:transparent)
(define-struct (ref pathseg) (n) #f) (define-struct (ref pathseg) (n) #:transparent)
(define-struct (tail pathseg) (n) #f) (define-struct (tail pathseg) (n) #:transparent)
;; path:ref->splicing-tail : PathSeg -> ??? ;; path:ref->splicing-tail : PathSeg -> ???
;; ???? ;; ????
(define (path:ref->splicing-tail path) (define (path:ref->splicing-tail path)
(unless (ref? path) (unless (ref? path)
(raise-type-error 'path:ref->splicing-tail "ref path" path)) (raise-type-error 'path:ref->splicing-tail "ref path" path))
(make-tail (sub1 (ref-n path)))) (make-tail (sub1 (ref-n path))))
;; path-get : syntax Path -> syntax ;; path-get : syntax Path -> syntax
(define (path-get stx path) (define (path-get stx path)
(let loop ([stx stx] [path path]) (let loop ([stx stx] [path path])
(cond [(null? path) stx] (cond [(null? path) stx]
[(pair? path) [(pair? path)
@ -37,24 +37,24 @@
[else [else
(error 'path-get "bad path: ~s" path)]))) (error 'path-get "bad path: ~s" path)])))
;; pathseg-get : syntax PathSeg -> syntax ;; pathseg-get : syntax PathSeg -> syntax
(define (pathseg-get stx path) (define (pathseg-get stx path)
(cond [(ref? path) (pathseg-get/ref stx (ref-n path))] (cond [(ref? path) (pathseg-get/ref stx (ref-n path))]
[(tail? path) (pathseg-get/tail stx (tail-n path))])) [(tail? path) (pathseg-get/tail stx (tail-n path))]))
;; pathseg-get/ref : syntax number -> syntax ;; pathseg-get/ref : syntax number -> syntax
(define (pathseg-get/ref stx0 n0) (define (pathseg-get/ref stx0 n0)
(let loop ([n n0] [stx stx0]) (let loop ([n n0] [stx stx0])
(unless (stx-pair? stx) (unless (stx-pair? stx)
(error 'pathseg-get "ref path out of bounds for syntax: ~s, ~s" (error 'pathseg-get "ref path out of bounds for syntax: ~s, ~s"
n0 n0
(syntax-object->datum stx0))) (syntax->datum stx0)))
(if (zero? n) (if (zero? n)
(stx-car stx) (stx-car stx)
(loop (sub1 n) (stx-cdr stx))))) (loop (sub1 n) (stx-cdr stx)))))
;; pathseg-get/tail : syntax number -> syntax ;; pathseg-get/tail : syntax number -> syntax
(define (pathseg-get/tail stx0 n0) (define (pathseg-get/tail stx0 n0)
(let loop ([n n0] [stx stx0]) (let loop ([n n0] [stx stx0])
(unless (stx-pair? stx) (unless (stx-pair? stx)
(error 'pathseg-get "tail path out of bounds for syntax: ~s, ~s" n0 stx0)) (error 'pathseg-get "tail path out of bounds for syntax: ~s, ~s" n0 stx0))
@ -62,8 +62,8 @@
(stx-cdr stx) (stx-cdr stx)
(loop (sub1 n) (stx-cdr stx))))) (loop (sub1 n) (stx-cdr stx)))))
;; path-replace : syntax Path syntax -> syntax ;; path-replace : syntax Path syntax -> syntax
(define (path-replace stx path x) (define (path-replace stx path x)
(cond [(null? path) x] (cond [(null? path) x]
[(pair? path) [(pair? path)
(let ([pathseg0 (car path)]) (let ([pathseg0 (car path)])
@ -75,14 +75,14 @@
[else [else
(error 'path-replace "bad path: ~s" path)])) (error 'path-replace "bad path: ~s" path)]))
;; pathseg-replace : syntax PathSeg syntax -> syntax ;; pathseg-replace : syntax PathSeg syntax -> syntax
(define (pathseg-replace stx pathseg x) (define (pathseg-replace stx pathseg x)
(cond [(ref? pathseg) (pathseg-replace/ref stx (ref-n pathseg) x)] (cond [(ref? pathseg) (pathseg-replace/ref stx (ref-n pathseg) x)]
[(tail? pathseg) (pathseg-replace/tail stx (tail-n pathseg) x)] [(tail? pathseg) (pathseg-replace/tail stx (tail-n pathseg) x)]
[else (error 'pathseg-replace "bad path: ~s" pathseg)])) [else (error 'pathseg-replace "bad path: ~s" pathseg)]))
;; pathseg-replace/ref : syntax number syntax -> syntax ;; pathseg-replace/ref : syntax number syntax -> syntax
(define (pathseg-replace/ref stx0 n0 x) (define (pathseg-replace/ref stx0 n0 x)
(let loop ([n n0] [stx stx0]) (let loop ([n n0] [stx stx0])
(unless (stx-pair? stx) (unless (stx-pair? stx)
(error 'pathseg-replace "ref path out of bounds for syntax: ~s, ~s" n0 stx0)) (error 'pathseg-replace "ref path out of bounds for syntax: ~s, ~s" n0 stx0))
@ -90,8 +90,8 @@
(stx-replcar stx x) (stx-replcar stx x)
(stx-replcdr stx (loop (sub1 n) (stx-cdr stx)))))) (stx-replcdr stx (loop (sub1 n) (stx-cdr stx))))))
;; pathseg-replace/tail : syntax number syntax -> syntax ;; pathseg-replace/tail : syntax number syntax -> syntax
(define (pathseg-replace/tail stx0 n0 x) (define (pathseg-replace/tail stx0 n0 x)
(let loop ([n n0] [stx stx0]) (let loop ([n n0] [stx stx0])
(unless (stx-pair? stx) (unless (stx-pair? stx)
(error 'pathseg-replace "tail path out of bounds for syntax: ~s, ~s" n0 stx0)) (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 x)
(stx-replcdr stx (loop (sub1 n) (stx-cdr stx)))))) (stx-replcdr stx (loop (sub1 n) (stx-cdr stx))))))
;; stx-replcar : syntax syntax -> syntax ;; stx-replcar : syntax syntax -> syntax
(define (stx-replcar stx x) (define (stx-replcar stx x)
(cond [(pair? stx) (cond [(pair? stx)
(cons x (cdr stx))] (cons x (cdr stx))]
[(syntax? 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)])) [else (raise-type-error 'stx-replcar "stx-pair" stx)]))
;; stx-replcdr : syntax syntax -> syntax ;; stx-replcdr : syntax syntax -> syntax
(define (stx-replcdr stx x) (define (stx-replcdr stx x)
(cond [(pair? stx) (cond [(pair? stx)
(cons (car stx) x)] (cons (car stx) x)]
[(and (syntax? stx) (pair? (syntax-e stx))) [(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)])) [else (raise-type-error 'stx-replcdr "stx-pair" stx)]))
(define (sd x) (define (sd x)
(syntax-object->datum (datum->syntax-object #f x))) (syntax->datum (datum->syntax #f x)))
;;======= ;;=======
;; find-subterm-paths : syntax syntax -> (list-of Path) ;; find-subterm-paths : syntax syntax -> (list-of Path)
(define (find-subterm-paths subterm term) (define (find-subterm-paths subterm term)
(let outer-loop ([term term]) (let outer-loop ([term term])
(cond [(eq? subterm term) (cond [(eq? subterm term)
(list null)] (list null)]
@ -139,4 +139,3 @@
(outer-loop term)))))] (outer-loop term)))))]
;; FIXME: more structured cases here: box, vector, ... ;; FIXME: more structured cases here: box, vector, ...
[else null]))) [else null])))
)

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

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

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

@ -1,187 +1,184 @@
(module deriv-c mzscheme #lang scheme/base
(provide (all-defined)) (provide (all-defined-out))
;; A Node(a) is: ;; A Node(a) is:
;; (make-node a ?a) ;; (make-node a ?a)
(define-struct node (z1 z2) #f) (define-struct node (z1 z2) #:transparent)
;; A TopDeriv is one of ;; A TopDeriv is one of
;; (make-lift-deriv <Node(Stx)> Deriv Stxs TopDeriv) ;; (make-lift-deriv <Node(Stx)> Deriv Stxs TopDeriv)
;; Deriv ;; Deriv
;; A Deriv is one of ;; A Deriv is one of
;; (make-mrule <Node(Stx)> Transformation Deriv) ;; (make-mrule <Node(Stx)> Transformation Deriv)
;; PrimDeriv ;; PrimDeriv
(define-struct (deriv node) () #f) (define-struct (deriv node) () #:transparent)
(define-struct (lift-deriv deriv) (first lift-stx second) #f) (define-struct (lift-deriv deriv) (first lift-stx second) #:transparent)
(define-struct (mrule deriv) (transformation next) #f) (define-struct (mrule deriv) (transformation next) #:transparent)
;; A DerivLL is one of ;; A DerivLL is one of
;; (make-lift/let-deriv <Node(Stx)> Deriv Stx Deriv) ;; (make-lift/let-deriv <Node(Stx)> Deriv Stx Deriv)
;; Deriv ;; Deriv
(define-struct (lift/let-deriv deriv) (first lift-stx second) #f) (define-struct (lift/let-deriv deriv) (first lift-stx second) #:transparent)
;; A Transformation is ;; A Transformation is
;; (make-transformation <Node(Stx)> Rs ?exn ?Stx (list-of LocalAction) ?exn ?Stx Number) ;; (make-transformation <Node(Stx)> Rs ?exn ?Stx (list-of LocalAction) ?exn ?Stx Number)
(define-struct (transformation node) (resolves ?1 me1 locals ?2 me2 seq) #f) (define-struct (transformation node) (resolves ?1 me1 locals ?2 me2 seq) #:transparent)
;; A LocalAction is one of ;; A LocalAction is one of
;; (make-local-expansion <Node(Stx)> Stx ?Stx Boolean Deriv) ;; (make-local-expansion <Node(Stx)> Stx ?Stx Boolean Deriv)
;; (make-local-expansion/expr <Node(Stx)> Stx ?Stx Boolean ?Opaque Deriv) ;; (make-local-expansion/expr <Node(Stx)> Stx ?Stx Boolean ?Opaque Deriv)
;; (make-local-lift Stx Identifier) ;; (make-local-lift Stx Identifier)
;; (make-local-lift-end Stx) ;; (make-local-lift-end Stx)
;; (make-local-bind BindSyntaxes) ;; (make-local-bind BindSyntaxes)
(define-struct (local-expansion node) (me1 me2 for-stx? inner) #f) (define-struct (local-expansion node) (me1 me2 for-stx? inner) #:transparent)
(define-struct (local-expansion/expr node) (me1 me2 for-stx? opaque inner) #f) (define-struct (local-expansion/expr node) (me1 me2 for-stx? opaque inner) #:transparent)
(define-struct local-lift (expr id) #f) (define-struct local-lift (expr id) #:transparent)
(define-struct local-lift-end (decl) #f) (define-struct local-lift-end (decl) #:transparent)
(define-struct local-bind (bindrhs) #f) (define-struct local-bind (bindrhs) #:transparent)
;; Base = << Node(Stx) Rs ?exn >> ;; Base = << Node(Stx) Rs ?exn >>
(define-struct (base deriv) (resolves ?1) #f) (define-struct (base deriv) (resolves ?1) #:transparent)
;; A PrimDeriv is one of ;; A PrimDeriv is one of
(define-struct (prule base) () #f) (define-struct (prule base) () #:transparent)
(define-struct (p:variable prule) () #f) (define-struct (p:variable prule) () #:transparent)
;; (make-p:module <Base> Boolean ?Deriv ?exn Deriv) ;; (make-p:module <Base> Boolean ?Deriv ?exn Deriv)
;; (make-p:#%module-begin <Base> ModulePass1 ModulePass2 ?exn) ;; (make-p:#%module-begin <Base> ModulePass1 ModulePass2 ?exn)
(define-struct (p:module prule) (one-body-form? mb ?2 body) #f) (define-struct (p:module prule) (one-body-form? mb ?2 body) #:transparent)
(define-struct (p:#%module-begin prule) (pass1 pass2 ?2) #f) (define-struct (p:#%module-begin prule) (pass1 pass2 ?2) #:transparent)
;; (make-p:define-syntaxes <Base> DerivLL) ;; (make-p:define-syntaxes <Base> DerivLL)
;; (make-p:define-values <Base> Deriv) ;; (make-p:define-values <Base> Deriv)
(define-struct (p:define-syntaxes prule) (rhs ?2) #f) (define-struct (p:define-syntaxes prule) (rhs ?2) #:transparent)
(define-struct (p:define-values prule) (rhs) #f) (define-struct (p:define-values prule) (rhs) #:transparent)
;; (make-p:#%expression <Base> Deriv) ;; (make-p:#%expression <Base> Deriv)
;; (make-p:if <Base> Boolean Deriv Deriv Deriv) ;; (make-p:if <Base> Boolean Deriv Deriv Deriv)
;; (make-p:wcm <Base> Deriv Deriv Deriv) ;; (make-p:wcm <Base> Deriv Deriv Deriv)
;; (make-p:set! <Base> Rs Deriv) ;; (make-p:set! <Base> Rs Deriv)
;; (make-p:set!-macro <Base> Rs Deriv) ;; (make-p:set!-macro <Base> Rs Deriv)
(define-struct (p:#%expression prule) (inner) #f) (define-struct (p:#%expression prule) (inner) #:transparent)
(define-struct (p:if prule) (full? test then else) #f) (define-struct (p:if prule) (full? test then else) #:transparent)
(define-struct (p:wcm prule) (key mark body) #f) (define-struct (p:wcm prule) (key mark body) #:transparent)
(define-struct (p:set! prule) (id-resolves rhs) #f) (define-struct (p:set! prule) (id-resolves rhs) #:transparent)
(define-struct (p:set!-macro prule) (deriv) #f) (define-struct (p:set!-macro prule) (deriv) #:transparent)
;; (make-p:#%app <Base> Stx LDeriv) ;; (make-p:#%app <Base> Stx LDeriv)
;; (make-p:begin <Base> LDeriv) ;; (make-p:begin <Base> LDeriv)
;; (make-p:begin0 <Base> Deriv LDeriv) ;; (make-p:begin0 <Base> Deriv LDeriv)
(define-struct (p:#%app prule) (tagged-stx lderiv) #f) (define-struct (p:#%app prule) (tagged-stx lderiv) #:transparent)
(define-struct (p:begin prule) (lderiv) #f) (define-struct (p:begin prule) (lderiv) #:transparent)
(define-struct (p:begin0 prule) (first lderiv) #f) (define-struct (p:begin0 prule) (first lderiv) #:transparent)
;; (make-p:lambda <Base> LambdaRenames BDeriv) ;; (make-p:lambda <Base> LambdaRenames BDeriv)
;; (make-p:case-lambda <Base> (list-of CaseLambdaClause)) ;; (make-p:case-lambda <Base> (list-of CaseLambdaClause))
;; (make-p:let-values <Base> LetRenames (list-of Deriv) BDeriv) ;; (make-p:let-values <Base> LetRenames (list-of Deriv) BDeriv)
;; (make-p:letrec-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) ;; (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:lambda prule) (renames body) #:transparent)
(define-struct (p:case-lambda prule) (renames+bodies) #f) (define-struct (p:case-lambda prule) (renames+bodies) #:transparent)
(define-struct (p:let-values prule) (renames rhss body) #f) (define-struct (p:let-values prule) (renames rhss body) #:transparent)
(define-struct (p:letrec-values prule) (renames rhss body) #f) (define-struct (p:letrec-values prule) (renames rhss body) #:transparent)
(define-struct (p:letrec-syntaxes+values prule) (srenames sbindrhss vrenames vrhss body) #f) (define-struct (p:letrec-syntaxes+values prule) (srenames sbindrhss vrenames vrhss body) #:transparent)
;; (make-p:stop <Base>) ;; (make-p:stop <Base>)
;; (make-p:unknown <Base>) ;; (make-p:unknown <Base>)
;; (make-p:#%top <Base> Stx) ;; (make-p:#%top <Base> Stx)
;; (make-p:#%datum <Base> Stx) ;; (make-p:#%datum <Base> Stx)
;; (make-p:quote <Base>) ;; (make-p:quote <Base>)
;; (make-p:quote-syntax <Base>) ;; (make-p:quote-syntax <Base>)
;; (make-p:require <Base>) ;; (make-p:require <Base>)
;; (make-p:require-for-syntax <Base>) ;; (make-p:require-for-syntax <Base>)
;; (make-p:require-for-template <Base>) ;; (make-p:require-for-template <Base>)
;; (make-p:provide <Base>) ;; (make-p:provide <Base>)
(define-struct (p::STOP prule) () #f) (define-struct (p::STOP prule) () #:transparent)
(define-struct (p:stop p::STOP) () #f) (define-struct (p:stop p::STOP) () #:transparent)
(define-struct (p:unknown p::STOP) () #f) (define-struct (p:unknown p::STOP) () #:transparent)
(define-struct (p:#%top p::STOP) (tagged-stx) #f) (define-struct (p:#%top p::STOP) (tagged-stx) #:transparent)
(define-struct (p:#%datum p::STOP) (tagged-stx) #f) (define-struct (p:#%datum p::STOP) (tagged-stx) #:transparent)
(define-struct (p:quote p::STOP) () #f) (define-struct (p:quote p::STOP) () #:transparent)
(define-struct (p:quote-syntax p::STOP) () #f) (define-struct (p:quote-syntax p::STOP) () #:transparent)
(define-struct (p:require p::STOP) () #f) (define-struct (p:require p::STOP) () #:transparent)
(define-struct (p:require-for-syntax p::STOP) () #f) (define-struct (p:require-for-syntax p::STOP) () #:transparent)
(define-struct (p:require-for-template p::STOP) () #f) (define-struct (p:require-for-template p::STOP) () #:transparent)
(define-struct (p:provide p::STOP) () #f) (define-struct (p:provide p::STOP) () #:transparent)
;;+ (make-p:rename <Base> Renames Deriv) ;;+ (make-p:rename <Base> Renames Deriv)
;;+ (make-p:synth <Base> (list-of SynthItem) ?exn) ;;+ (make-p:synth <Base> (list-of SynthItem) ?exn)
(define-struct (p:rename prule) (renames inner) #f) (define-struct (p:rename prule) (renames inner) #:transparent)
(define-struct (p:synth prule) (subterms ?2) #f) (define-struct (p:synth prule) (subterms ?2) #:transparent)
;; A LDeriv is ;; A LDeriv is
;; (make-lderiv <Node(Stxs)> ?exn (list-of Deriv)) ;; (make-lderiv <Node(Stxs)> ?exn (list-of Deriv))
(define-struct (lderiv node) (?1 derivs) #f) (define-struct (lderiv node) (?1 derivs) #:transparent)
;; A BDeriv is ;; A BDeriv is
;; (make-bderiv <Node(Stxs)> (list-of BRule) (U 'list 'letrec) LDeriv) ;; (make-bderiv <Node(Stxs)> (list-of BRule) (U 'list 'letrec) LDeriv)
(define-struct (bderiv node) (pass1 trans pass2) #f) (define-struct (bderiv node) (pass1 trans pass2) #:transparent)
;; A BRule is one of ;; A BRule is one of
;; (make-b:error exn) ;; (make-b:error exn)
;; (make-b:expr BlockRenames Deriv) ;; (make-b:expr BlockRenames Deriv)
;; (make-b:splice BlockRenames Deriv ?exn Stxs ?exn) ;; (make-b:splice BlockRenames Deriv ?exn Stxs ?exn)
;; (make-b:defvals BlockRenames Deriv ?exn) ;; (make-b:defvals BlockRenames Deriv ?exn)
;; (make-b:defstx BlockRenames Deriv ?exn BindSyntaxes) ;; (make-b:defstx BlockRenames Deriv ?exn BindSyntaxes)
;;i (make-b:begin BlockRenames Deriv (list-of Deriv)) ;;i (make-b:begin BlockRenames Deriv (list-of Deriv))
(define-struct b:error (?1) #f) (define-struct b:error (?1) #:transparent)
(define-struct brule (renames) #f) (define-struct brule (renames) #:transparent)
(define-struct (b:expr brule) (head) #f) (define-struct (b:expr brule) (head) #:transparent)
(define-struct (b:splice brule) (head ?1 tail ?2) #f) (define-struct (b:splice brule) (head ?1 tail ?2) #:transparent)
(define-struct (b:defvals brule) (head ?1) #f) (define-struct (b:defvals brule) (head ?1) #:transparent)
(define-struct (b:defstx brule) (head ?1 bindrhs) #f) (define-struct (b:defstx brule) (head ?1 bindrhs) #:transparent)
;;(define-struct (b:begin brule) (head inner) #f) ;;(define-struct (b:begin brule) (head inner) #:transparent)
;; A BindSyntaxes is ;; A BindSyntaxes is
;; (make-bind-syntaxes DerivLL ?exn) ;; (make-bind-syntaxes DerivLL ?exn)
(define-struct bind-syntaxes (rhs ?1) #f) (define-struct bind-syntaxes (rhs ?1) #:transparent)
;; A CaseLambdaClause is ;; A CaseLambdaClause is
;; (make-clc ?exn CaseLambdaRename BDeriv) ;; (make-clc ?exn CaseLambdaRename BDeriv)
(define-struct clc (?1 renames body) #f) (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 ModPass1 is (list-of ModRule1)
;; A ModPass2 is (list-of ModRule2) ;; A ModPass2 is (list-of ModRule2)
;; A ModRule1 is one of ;; A ModRule1 is one of
;; (make-mod:prim Deriv ModPrim) ;; (make-mod:prim Deriv ModPrim)
;; (make-mod:splice Deriv ?exn Stxs) ;; (make-mod:splice Deriv ?exn Stxs)
;; (make-mod:lift Deriv Stxs) ;; (make-mod:lift Deriv Stxs)
;; (make-mod:lift-end Stxs) ;; (make-mod:lift-end Stxs)
;; A ModRule2 is one of ;; A ModRule2 is one of
;; (make-mod:skip) ;; (make-mod:skip)
;; (make-mod:cons Deriv) ;; (make-mod:cons Deriv)
;; (make-mod:lift Deriv Stxs) ;; (make-mod:lift Deriv Stxs)
(define-struct modrule () #f) (define-struct modrule () #:transparent)
(define-struct (mod:cons modrule) (head) #f) (define-struct (mod:cons modrule) (head) #:transparent)
(define-struct (mod:prim modrule) (head prim) #f) (define-struct (mod:prim modrule) (head prim) #:transparent)
(define-struct (mod:skip modrule) () #f) (define-struct (mod:skip modrule) () #:transparent)
(define-struct (mod:splice modrule) (head ?1 tail) #f) (define-struct (mod:splice modrule) (head ?1 tail) #:transparent)
(define-struct (mod:lift modrule) (head tail) #f) (define-struct (mod:lift modrule) (head tail) #:transparent)
(define-struct (mod:lift-end modrule) (tail) #f) (define-struct (mod:lift-end modrule) (tail) #:transparent)
;; A ModPrim is a PRule in: ;; A ModPrim is a PRule in:
;; (make-p:define-values <Base> #f) ;; (make-p:define-values <Base> #:transparent)
;; (make-p:define-syntaxes <Base> Deriv) ;; (make-p:define-syntaxes <Base> Deriv)
;; (make-p:require <Base>) ;; (make-p:require <Base>)
;; (make-p:require-for-syntax <Base>) ;; (make-p:require-for-syntax <Base>)
;; (make-p:require-for-template <Base>) ;; (make-p:require-for-template <Base>)
;; (make-p:provide <Base>) ;; (make-p:provide <Base>)
;; #f ;; #f
;; A SynthItem is one of ;; A SynthItem is one of
;; - (make-s:subterm Path Deriv) ;; - (make-s:subterm Path Deriv)
;; - (make-s:rename Path Stx Stx) ;; - (make-s:rename Path Stx Stx)
(define-struct subitem () #f) (define-struct subitem () #:transparent)
(define-struct (s:subterm subitem) (path deriv) #f) (define-struct (s:subterm subitem) (path deriv) #:transparent)
(define-struct (s:rename subitem) (path before after) #f) (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 #lang scheme/base
(require "yacc-ext.ss" (require (for-syntax scheme/base)
"yacc-ext.ss"
"yacc-interrupted.ss" "yacc-interrupted.ss"
"deriv.ss" "deriv.ss"
"deriv-util.ss" "deriv-util.ss"
"deriv-tokens.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? (if ok?
(error 'derivation-parser (error 'derivation-parser
"error on token #~a: <~s, ~s>" "error on token #~a: <~s, ~s>"
start name value) start name value)
(error 'derivation-parser "bad token #~a" start))) (error 'derivation-parser "bad token #~a" start)))
;; PARSER ;; PARSER
(define (parse-derivation x) (define (parse-derivation x)
(parameterize ((current-sequence-number 0)) (parameterize ((current-sequence-number 0))
(parse-derivation* x))) (parse-derivation* x)))
(define current-sequence-number (make-parameter #f)) (define current-sequence-number (make-parameter #f))
(define (new-sequence-number) (define (new-sequence-number)
(let ([seq (current-sequence-number)]) (let ([seq (current-sequence-number)])
(current-sequence-number (add1 seq)) (current-sequence-number (add1 seq))
seq)) seq))
(define-struct (exn:eval exn) (deriv)) (define-struct (exn:eval exn) (deriv))
(define empty-cms (define empty-cms
(call-with-continuation-prompt (lambda () (current-continuation-marks)))) (call-with-continuation-prompt (lambda () (current-continuation-marks))))
(define (create-eval-exn deriv) (define (create-eval-exn deriv)
(make-exn:eval "exception during evaluation" (make-exn:eval "exception during evaluation"
empty-cms empty-cms
deriv)) 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 () (syntax-case stx ()
[(productions/I def ...) [(productions/I def ...)
#'(begin (production/I def) ...)])) #'(begin (production/I def) ...)]))
(define parse-derivation* (define parse-derivation*
(parser (parser
(options (start Expansion) (options (start Expansion)
(src-pos) (src-pos)
@ -576,5 +577,3 @@
[(next (? EE) (? EL*)) (cons $2 $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 #lang scheme/base
(require (lib "lex.ss" "parser-tools") (require parser-tools/lex
"deriv.ss") "deriv.ss")
(provide (all-defined)) (provide (all-defined-out))
(define-tokens basic-tokens (define-tokens basic-tokens
(start ; . (start ; .
visit ; syntax visit ; syntax
resolve ; identifier resolve ; identifier
@ -49,7 +49,7 @@
IMPOSSIBLE ; useful for error-handling clauses that have no NoError counterpart 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-lambda ; (cons syntax syntax)
renames-case-lambda ; (cons syntax syntax) renames-case-lambda ; (cons syntax syntax)
renames-let ; (cons (listof syntax) syntax) renames-let ; (cons (listof syntax) syntax)
@ -57,8 +57,8 @@
renames-block ; (cons syntax syntax) ... different, contains both pre+post renames-block ; (cons syntax syntax) ... different, contains both pre+post
)) ))
;; Empty tokens ;; Empty tokens
(define-tokens prim-tokens (define-tokens prim-tokens
(prim-module prim-#%module-begin (prim-module prim-#%module-begin
prim-define-syntaxes prim-define-values prim-define-syntaxes prim-define-values
prim-if prim-wcm prim-begin prim-begin0 prim-#%app prim-lambda prim-if prim-wcm prim-begin prim-begin0 prim-#%app prim-lambda
@ -70,9 +70,9 @@
prim-expression prim-expression
)) ))
;; ** Signals to tokens ;; ** Signals to tokens
(define signal-mapping (define signal-mapping
`((EOF . EOF) `((EOF . EOF)
(error . ,token-syntax-error) (error . ,token-syntax-error)
(0 . ,token-visit) (0 . ,token-visit)
@ -144,7 +144,7 @@
(141 . ,token-start) (141 . ,token-start)
)) ))
(define (tokenize sig-n val pos) (define (tokenize sig-n val pos)
(let ([p (assv sig-n signal-mapping)]) (let ([p (assv sig-n signal-mapping)])
(if (pair? p) (if (pair? p)
(make-position-token (make-position-token
@ -154,7 +154,5 @@
pos) pos)
(error 'tokenize "bad signal: ~s" sig-n)))) (error 'tokenize "bad signal: ~s" sig-n))))
(define (signal->symbol sig-n) (define (signal->symbol sig-n)
(cdr (assv sig-n signal-mapping))) (cdr (assv sig-n signal-mapping)))
)

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

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

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

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

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

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

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

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

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

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

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

@ -1,40 +1,40 @@
(module steps mzscheme #lang scheme/base
(require "deriv.ss" (require "deriv.ss"
"deriv-util.ss" "deriv-util.ss"
"deriv-find.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 Context is a list of Frames
;; A Frame is either: ;; A Frame is either:
;; - (syntax -> syntax) ;; - (syntax -> syntax)
;; - (make-renames syntax syntax) ;; - (make-renames syntax syntax)
;; - 'phase-up ;; - 'phase-up
(define-struct renames (old new)) (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 BigContext is (list-of BigFrame)
;; A BigFrame is (make-bigframe Derivation Context Syntaxes Syntax) ;; A BigFrame is (make-bigframe Derivation Context Syntaxes Syntax)
(define-struct bigframe (deriv ctx foci e)) (define-struct bigframe (deriv ctx foci e))
;; A Reduction is one of ;; A Reduction is one of
;; - (make-step ... Syntaxes Syntaxes Syntax Syntax) ;; - (make-step ... Syntaxes Syntaxes Syntax Syntax)
;; - (make-mono ... Syntaxes Syntax) ;; - (make-mono ... Syntaxes Syntax)
;; - (make-misstep ... Syntax Syntax Exception) ;; - (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 (step protostep) (foci1 foci2 e1 e2) #:transparent)
(define-struct (mono protostep) (foci1 e1) #f) (define-struct (mono protostep) (foci1 e1) #:transparent)
(define-struct (misstep protostep) (foci1 e1 exn) #f) (define-struct (misstep protostep) (foci1 e1 exn) #:transparent)
;; context-fill : Context Syntax -> Syntax ;; context-fill : Context Syntax -> Syntax
(define (context-fill ctx stx) (define (context-fill ctx stx)
(let loop ([ctx ctx] [stx stx]) (let loop ([ctx ctx] [stx stx])
(if (null? ctx) (if (null? ctx)
stx stx
@ -43,8 +43,8 @@
(loop (cdr ctx) (frame0 stx)) (loop (cdr ctx) (frame0 stx))
(loop (cdr ctx) stx)))))) (loop (cdr ctx) stx))))))
;; context-env : Context -> (list-of identifier) ;; context-env : Context -> (list-of identifier)
(define (context-env ctx) (define (context-env ctx)
(let loop ([ctx ctx] [env null]) (let loop ([ctx ctx] [env null])
(if (null? ctx) (if (null? ctx)
env env
@ -55,23 +55,23 @@
env)) env))
(loop (cdr ctx) env)))))) (loop (cdr ctx) env))))))
(define (step-term1 s) (define (step-term1 s)
(context-fill (protostep-ctx s) (step-e1 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))) (context-fill (protostep-ctx s) (step-e2 s)))
(define (mono-term1 s) (define (mono-term1 s)
(context-fill (protostep-ctx s) (mono-e1 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))) (context-fill (protostep-ctx s) (misstep-e1 s)))
(define (bigframe-term bf) (define (bigframe-term bf)
(context-fill (bigframe-ctx bf) (bigframe-e 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") '((macro . "Macro transformation")
(rename-lambda . "Rename formal parameters") (rename-lambda . "Rename formal parameters")
@ -98,12 +98,12 @@
(error . "Error"))) (error . "Error")))
(define (step-type->string x) (define (step-type->string x)
(cond [(assq x step-type-meanings) => cdr] (cond [(assq x step-type-meanings) => cdr]
[(string? x) x] [(string? x) x]
[else (error 'step-type->string "not a step type: ~s" x)])) [else (error 'step-type->string "not a step type: ~s" x)]))
(define (rename-step? x) (define (rename-step? x)
(memq (protostep-type x) (memq (protostep-type x)
'(rename-lambda '(rename-lambda
rename-case-lambda rename-case-lambda
@ -111,6 +111,5 @@
rename-letrec-values rename-letrec-values
rename-lsv))) rename-lsv)))
(define (rewrite-step? x) (define (rewrite-step? x)
(and (step? x) (not (rename-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 #lang scheme/base
(require (lib "stx.ss" "syntax")) (require (for-syntax scheme/base)
syntax/stx)
(provide (all-defined) (provide (all-defined-out)
(all-from (lib "stx.ss" "syntax"))) (all-from-out syntax/stx))
(define (d->so template datum) (define (d->so template datum)
(if (syntax? template) (if (syntax? template)
(datum->syntax-object template datum template template) (datum->syntax template datum template template)
datum)) datum))
(define-syntax (syntax-copier stx) (define-syntax (syntax-copier stx)
(syntax-case stx () (syntax-case stx ()
[(syntax-copier hole expr pattern) [(syntax-copier hole expr pattern)
#'(let ([expr-var expr]) #'(let ([expr-var expr])
@ -19,14 +20,14 @@
(with-syntax ([hole in-the-hole]) (with-syntax ([hole in-the-hole])
(syntax/restamp pattern #'pattern expr-var)))))])) (syntax/restamp pattern #'pattern expr-var)))))]))
(define-syntax syntax/skeleton (define-syntax syntax/skeleton
(syntax-rules () (syntax-rules ()
[(syntax/skeleton old-expr pattern) [(syntax/skeleton old-expr pattern)
(syntax/restamp pattern #'pattern old-expr)])) (syntax/restamp pattern #'pattern old-expr)]))
;; FIXME: Need to avoid turning syntax lists into syntax pairs ;; FIXME: Need to avoid turning syntax lists into syntax pairs
(define-syntax (syntax/restamp stx) (define-syntax (syntax/restamp stx)
(syntax-case stx (...) (syntax-case stx (...)
[(syntax/restamp (pa (... ...)) new-expr old-expr) [(syntax/restamp (pa (... ...)) new-expr old-expr)
#`(let ([new-parts (stx->list new-expr)] #`(let ([new-parts (stx->list new-expr)]
@ -34,9 +35,9 @@
;; FIXME ;; FIXME
(unless (= (length new-parts) (length old-parts)) (unless (= (length new-parts) (length old-parts))
(printf "** syntax/restamp~n~s~n" (quote-syntax #,stx)) (printf "** syntax/restamp~n~s~n" (quote-syntax #,stx))
(printf "pattern : ~s~n" (syntax-object->datum #'(pa (... ...)))) (printf "pattern : ~s~n" (syntax->datum #'(pa (... ...))))
(printf "old parts: ~s~n" (map syntax-object->datum old-parts)) (printf "old parts: ~s~n" (map syntax->datum old-parts))
(printf "new parts: ~s~n" (map syntax-object->datum new-parts))) (printf "new parts: ~s~n" (map syntax->datum new-parts)))
(d->so (d->so
old-expr old-expr
(map (lambda (new old) (syntax/restamp pa new old)) (map (lambda (new old) (syntax/restamp pa new old))
@ -47,7 +48,7 @@
#'(begin #'(begin
(unless (and (stx-pair? new-expr) (stx-pair? old-expr)) (unless (and (stx-pair? new-expr) (stx-pair? old-expr))
(printf "** syntax/restamp~n~s~n" (quote-syntax #,stx)) (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 "old parts: ~s~n" old-expr)
(printf "new parts: ~s~n" new-expr)) (printf "new parts: ~s~n" new-expr))
(let ([na (stx-car new-expr)] (let ([na (stx-car new-expr)]
@ -60,32 +61,32 @@
[(syntax/restamp pvar new-expr old-expr) [(syntax/restamp pvar new-expr old-expr)
#'new-expr])) #'new-expr]))
(define (iota n) (define (iota n)
(let loop ([i 0]) (let loop ([i 0])
(if (< i n) (if (< i n)
(cons i (loop (add1 i))) (cons i (loop (add1 i)))
null))) null)))
;; stx-take : syntax-list number -> (list-of syntax) ;; stx-take : syntax-list number -> (list-of syntax)
(define (stx-take items n) (define (stx-take items n)
(cond [(zero? n) null] (cond [(zero? n) null]
[else (cons (stx-car items) (stx-take (stx-cdr items) (sub1 n)))])) [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) (unless (number? n)
(raise-type-error 'take-if-possible "number" n)) (raise-type-error 'take-if-possible "number" n))
(if (and (pair? items) (positive? n)) (if (and (pair? items) (positive? n))
(cons (car items) (take-if-possible (cdr items) (sub1 n))) (cons (car items) (take-if-possible (cdr items) (sub1 n)))
null)) null))
;; stx-improper-length : syntax -> number ;; stx-improper-length : syntax -> number
(define (stx-improper-length stx) (define (stx-improper-length stx)
(let loop ([stx stx] [n 0]) (let loop ([stx stx] [n 0])
(if (stx-pair? stx) (if (stx-pair? stx)
(loop (stx-cdr stx) (add1 n)) (loop (stx-cdr stx) (add1 n))
n))) n)))
(define (stx->list* stx) (define (stx->list* stx)
(cond [(pair? stx) (cond [(pair? stx)
(cons (car stx) (stx->list* (cdr stx)))] (cons (car stx) (stx->list* (cdr stx)))]
[(null? stx) [(null? stx)
@ -96,5 +97,3 @@
(cons (car x) (stx->list* (cdr x))) (cons (car x) (stx->list* (cdr x)))
(list stx)))] (list stx)))]
[else null])) [else null]))
)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

@ -1,38 +1,38 @@
(module frame mzscheme #lang scheme/base
(require (lib "class.ss") (require scheme/class
(lib "mred.ss" "mred") scheme/gui
(lib "framework.ss" "framework") framework/framework
(lib "list.ss") scheme/list
"partition.ss" "partition.ss"
"prefs.ss" "prefs.ss"
"widget.ss") "widget.ss")
(provide browse-syntax (provide browse-syntax
browse-syntaxes browse-syntaxes
make-syntax-browser make-syntax-browser
syntax-browser-frame% syntax-browser-frame%
syntax-widget/controls%) syntax-widget/controls%)
;; browse-syntax : syntax -> void ;; browse-syntax : syntax -> void
(define (browse-syntax stx) (define (browse-syntax stx)
(browse-syntaxes (list stx))) (browse-syntaxes (list stx)))
;; browse-syntaxes : (list-of syntax) -> void ;; browse-syntaxes : (list-of syntax) -> void
(define (browse-syntaxes stxs) (define (browse-syntaxes stxs)
(let ((w (make-syntax-browser))) (let ((w (make-syntax-browser)))
(for-each (lambda (stx) (for-each (lambda (stx)
(send w add-syntax stx) (send w add-syntax stx)
(send w add-separator)) (send w add-separator))
stxs))) stxs)))
;; make-syntax-browser : -> syntax-browser<%> ;; make-syntax-browser : -> syntax-browser<%>
(define (make-syntax-browser) (define (make-syntax-browser)
(let* ([view (new syntax-browser-frame%)]) (let* ([view (new syntax-browser-frame%)])
(send view show #t) (send view show #t)
(send view get-widget))) (send view get-widget)))
;; syntax-browser-frame% ;; syntax-browser-frame%
(define syntax-browser-frame% (define syntax-browser-frame%
(class* frame% () (class* frame% ()
(init-field [config (new syntax-prefs%)]) (init-field [config (new syntax-prefs%)])
(super-new (label "Syntax Browser") (super-new (label "Syntax Browser")
@ -50,8 +50,8 @@
(inner (void) on-close)) (inner (void) on-close))
)) ))
;; syntax-widget/controls% ;; syntax-widget/controls%
(define syntax-widget/controls% (define syntax-widget/controls%
(class* widget% () (class* widget% ()
(inherit get-main-panel (inherit get-main-panel
get-controller get-controller
@ -92,5 +92,3 @@
(send -choice set-selection (send -choice set-selection
(or (send -choice find-string (car name+func)) 0)))) (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 #lang scheme/base
(require (lib "class.ss")
(lib "mred.ss" "mred"))
(provide hrule-snip%)
;; hrule-snip% (require scheme/class
;; A snip for drawing horizontal separating lines. scheme/gui)
(define hrule-snip% (provide hrule-snip%)
;; hrule-snip%
;; A snip for drawing horizontal separating lines.
(define hrule-snip%
(class snip% (class snip%
(inherit get-admin) (inherit get-admin)
(define/override (get-extent dc x y bw bh bdescent bspace blspace brspace) (define/override (get-extent dc x y bw bh bdescent bspace blspace brspace)
@ -42,16 +43,15 @@
(set-snipclass snip-class))) (set-snipclass snip-class)))
(define hrule-snipclass% (define hrule-snipclass%
(class snip-class% (class snip-class%
(define/override (read stream) (define/override (read stream)
(let ([str (send stream get-bytes)]) (let ([str (send stream get-bytes)])
(new hrule-snip%))) (new hrule-snip%)))
(super-new))) (super-new)))
(define snip-class (new hrule-snipclass%)) (define snip-class (new hrule-snipclass%))
(send snip-class set-version 1) (send snip-class set-version 1)
(send snip-class set-classname (send snip-class set-classname
(format "~s" '(lib "hrule-snip.ss" "macro-debugger" "syntax-browser"))) (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 #lang scheme/base
(require (lib "class.ss")) (require scheme/class)
(provide (all-defined)) (provide (all-defined-out))
;; displays-manager<%> ;; displays-manager<%>
(define displays-manager<%> (define displays-manager<%>
(interface () (interface ()
;; add-syntax-display : display<%> -> void ;; add-syntax-display : display<%> -> void
add-syntax-display add-syntax-display
@ -12,8 +12,8 @@
;; remove-all-syntax-displays : -> void ;; remove-all-syntax-displays : -> void
remove-all-syntax-displays)) remove-all-syntax-displays))
;; selection-manager<%> ;; selection-manager<%>
(define selection-manager<%> (define selection-manager<%>
(interface () (interface ()
;; selected-syntax : syntax/#f ;; selected-syntax : syntax/#f
set-selected-syntax set-selected-syntax
@ -21,15 +21,15 @@
listen-selected-syntax listen-selected-syntax
)) ))
;; mark-manager<%> ;; mark-manager<%>
;; Manages marks, mappings from marks to colors ;; Manages marks, mappings from marks to colors
(define mark-manager<%> (define mark-manager<%>
(interface () (interface ()
;; get-primary-partition : -> partition ;; get-primary-partition : -> partition
get-primary-partition)) get-primary-partition))
;; secondary-partition<%> ;; secondary-partition<%>
(define secondary-partition<%> (define secondary-partition<%>
(interface (displays-manager<%>) (interface (displays-manager<%>)
;; get-secondary-partition : -> partition<%> ;; get-secondary-partition : -> partition<%>
get-secondary-partition get-secondary-partition
@ -49,15 +49,15 @@
;; listen-identifier=? : ((cons string procedure) -> void) -> void ;; listen-identifier=? : ((cons string procedure) -> void) -> void
listen-identifier=?)) listen-identifier=?))
;; controller<%> ;; controller<%>
(define controller<%> (define controller<%>
(interface (displays-manager<%> (interface (displays-manager<%>
selection-manager<%> selection-manager<%>
mark-manager<%> mark-manager<%>
secondary-partition<%>))) secondary-partition<%>)))
;; host<%> ;; host<%>
(define host<%> (define host<%>
(interface () (interface ()
;; get-controller : -> controller<%> ;; get-controller : -> controller<%>
get-controller get-controller
@ -67,8 +67,8 @@
)) ))
;; display<%> ;; display<%>
(define display<%> (define display<%>
(interface () (interface ()
;; refresh : -> void ;; refresh : -> void
refresh refresh
@ -85,8 +85,8 @@
;; get-range : -> range<%> ;; get-range : -> range<%>
get-range)) get-range))
;; range<%> ;; range<%>
(define range<%> (define range<%>
(interface () (interface ()
;; get-ranges : datum -> (list-of (cons number number)) ;; get-ranges : datum -> (list-of (cons number number))
get-ranges get-ranges
@ -98,20 +98,20 @@
;; get-identifier-list : (list-of identifier) ;; get-identifier-list : (list-of identifier)
get-identifier-list)) get-identifier-list))
;; A Range is (make-range datum number number) ;; A Range is (make-range datum number number)
(define-struct range (obj start end)) (define-struct range (obj start end))
;; syntax-prefs<%> ;; syntax-prefs<%>
(define syntax-prefs<%> (define syntax-prefs<%>
(interface () (interface ()
pref:width pref:width
pref:height pref:height
pref:props-percentage pref:props-percentage
pref:props-shown?)) pref:props-shown?))
;; widget-hooks<%> ;; widget-hooks<%>
(define widget-hooks<%> (define widget-hooks<%>
(interface () (interface ()
;; setup-keymap : -> void ;; setup-keymap : -> void
setup-keymap setup-keymap
@ -120,8 +120,8 @@
shutdown shutdown
)) ))
;; keymap-hooks<%> ;; keymap-hooks<%>
(define keymap-hooks<%> (define keymap-hooks<%>
(interface () (interface ()
;; make-context-menu : -> context-menu<%> ;; make-context-menu : -> context-menu<%>
make-context-menu make-context-menu
@ -129,8 +129,8 @@
;; get-context-menu% : -> class ;; get-context-menu% : -> class
get-context-menu%)) get-context-menu%))
;; context-menu-hooks<%> ;; context-menu-hooks<%>
(define context-menu-hooks<%> (define context-menu-hooks<%>
(interface () (interface ()
add-edit-items add-edit-items
after-edit-items after-edit-items
@ -140,10 +140,10 @@
after-partition-items)) after-partition-items))
;;---------- ;;----------
;; Convenience widget, specialized for displaying stx and not much else ;; Convenience widget, specialized for displaying stx and not much else
(define syntax-browser<%> (define syntax-browser<%>
(interface () (interface ()
add-syntax add-syntax
add-text add-text
@ -153,7 +153,7 @@
get-text get-text
)) ))
(define partition<%> (define partition<%>
(interface () (interface ()
;; get-partition : any -> number ;; get-partition : any -> number
get-partition get-partition
@ -163,5 +163,3 @@
;; count : -> number ;; count : -> number
count)) count))
)

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

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

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

@ -1,30 +1,30 @@
(module partition mzscheme #lang scheme/base
(require (lib "class.ss") (require scheme/class
(lib "boundmap.ss" "syntax") syntax/boundmap
(lib "stx.ss" "syntax") syntax/stx
"interfaces.ss") "interfaces.ss")
(provide new-bound-partition (provide new-bound-partition
partition% partition%
identifier=-choices) identifier=-choices)
(define (new-bound-partition) (define (new-bound-partition)
(new bound-partition%)) (new bound-partition%))
;; representative-symbol : symbol ;; representative-symbol : symbol
;; Must be fresh---otherwise, using it could detect rename wraps ;; Must be fresh---otherwise, using it could detect rename wraps
;; instead of only marks. ;; instead of only marks.
;; For example, in (lambda (representative) representative) ;; For example, in (lambda (representative) representative)
(define representative-symbol (define representative-symbol
(gensym 'representative)) (gensym 'representative))
;; unmarked-syntax : identifier ;; unmarked-syntax : identifier
;; Has no marks---used to initialize bound partition so that ;; Has no marks---used to initialize bound partition so that
;; unmarked syntax always gets colored "black" ;; unmarked syntax always gets colored "black"
(define unmarked-syntax (define unmarked-syntax
(datum->syntax-object #f representative-symbol)) (datum->syntax #f representative-symbol))
(define partition% (define partition%
(class* object% (partition<%>) (class* object% (partition<%>)
(init relation) (init relation)
@ -76,8 +76,8 @@
(super-new) (super-new)
)) ))
;; bound-partition% ;; bound-partition%
(define bound-partition% (define bound-partition%
(class* object% (partition<%>) (class* object% (partition<%>)
;; numbers : bound-identifier-mapping[identifier => number] ;; numbers : bound-identifier-mapping[identifier => number]
(define numbers (make-bound-identifier-mapping)) (define numbers (make-bound-identifier-mapping))
@ -89,7 +89,7 @@
(or n (or n
(begin0 next-number (begin0 next-number
(bound-identifier-mapping-put! numbers r 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)))))) (set! next-number (add1 next-number))))))
(define/public (same-partition? a b) (define/public (same-partition? a b)
@ -99,61 +99,59 @@
next-number) next-number)
(define/private (representative stx) (define/private (representative stx)
(datum->syntax-object stx representative-symbol)) (datum->syntax stx representative-symbol))
(get-partition unmarked-syntax) (get-partition unmarked-syntax)
(super-new))) (super-new)))
;; Different identifier relations for highlighting. ;; Different identifier relations for highlighting.
(define (lift/rep id=?) (define (lift/rep id=?)
(lambda (A B) (lambda (A B)
(let ([ra (datum->syntax-object A representative-symbol)] (let ([ra (datum->syntax A representative-symbol)]
[rb (datum->syntax-object B representative-symbol)]) [rb (datum->syntax B representative-symbol)])
(id=? ra rb)))) (id=? ra rb))))
(define (lift id=?) (define (lift id=?)
(lambda (A B) (lambda (A B)
(and (identifier? A) (identifier? B) (id=? A B)))) (and (identifier? A) (identifier? B) (id=? A B))))
;; id:same-marks? : syntax syntax -> boolean ;; id:same-marks? : syntax syntax -> boolean
(define id:same-marks? (define id:same-marks?
(lift/rep bound-identifier=?)) (lift/rep bound-identifier=?))
;; id:X-module=? : identifier identifier -> boolean ;; id:X-module=? : identifier identifier -> boolean
;; If both module-imported, do they come from the same module? ;; If both module-imported, do they come from the same module?
;; If both top-bound, then same source. ;; If both top-bound, then same source.
(define (id:source-module=? a b) (define (id:source-module=? a b)
(let ([ba (identifier-binding a)] (let ([ba (identifier-binding a)]
[bb (identifier-binding b)]) [bb (identifier-binding b)])
(cond [(or (eq? 'lexical ba) (eq? 'lexical bb)) (cond [(or (eq? 'lexical ba) (eq? 'lexical bb))
(module-identifier=? a b)] (free-identifier=? a b)]
[(and (not ba) (not bb)) [(and (not ba) (not bb))
#t] #t]
[(or (not ba) (not bb)) [(or (not ba) (not bb))
#f] #f]
[else [else
(eq? (car ba) (car bb))]))) (eq? (car ba) (car bb))])))
(define (id:nominal-module=? A B) (define (id:nominal-module=? A B)
(let ([ba (identifier-binding A)] (let ([ba (identifier-binding A)]
[bb (identifier-binding B)]) [bb (identifier-binding B)])
(cond [(or (eq? 'lexical ba) (eq? 'lexical bb)) (cond [(or (eq? 'lexical ba) (eq? 'lexical bb))
(module-identifier=? A B)] (free-identifier=? A B)]
[(or (not ba) (not bb)) [(or (not ba) (not bb))
(and (not ba) (not bb))] (and (not ba) (not bb))]
[else (eq? (caddr ba) (caddr bb))]))) [else (eq? (caddr ba) (caddr bb))])))
(define (symbolic-identifier=? A B) (define (symbolic-identifier=? A B)
(eq? (syntax-e A) (syntax-e B))) (eq? (syntax-e A) (syntax-e B)))
(define identifier=-choices (define identifier=-choices
(make-parameter (make-parameter
`(("<nothing>" . #f) `(("<nothing>" . #f)
("bound-identifier=?" . ,bound-identifier=?) ("bound-identifier=?" . ,bound-identifier=?)
("module-identifier=?" . ,module-identifier=?) ("free-identifier=?" . ,free-identifier=?)
("module-or-top-identifier=?" . ,module-or-top-identifier=?) ("module-or-top-identifier=?" . ,module-or-top-identifier=?)
("symbolic-identifier=?" . ,symbolic-identifier=?) ("symbolic-identifier=?" . ,symbolic-identifier=?)
("same source module" . ,id:source-module=?) ("same source module" . ,id:source-module=?)
("same nominal module" . ,id:nominal-module=?)))) ("same nominal module" . ,id:nominal-module=?))))
)

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

@ -1,32 +1,31 @@
(module prefs mzscheme #lang scheme/base
(require (lib "class.ss") (require scheme/class
(lib "framework.ss" "framework") framework/framework
"interfaces.ss" "interfaces.ss"
"../util/misc.ss") "../util/misc.ss")
(provide syntax-prefs% (provide syntax-prefs%
syntax-prefs-mixin syntax-prefs-mixin
pref:tabify) pref:tabify)
(preferences:set-default 'SyntaxBrowser:Width 700 number?) (preferences:set-default 'SyntaxBrowser:Width 700 number?)
(preferences:set-default 'SyntaxBrowser:Height 600 number?) (preferences:set-default 'SyntaxBrowser:Height 600 number?)
(preferences:set-default 'SyntaxBrowser:PropertiesPanelPercentage 1/3 number?) (preferences:set-default 'SyntaxBrowser:PropertiesPanelPercentage 1/3 number?)
(preferences:set-default 'SyntaxBrowser:PropertiesPanelShown #t boolean?) (preferences:set-default 'SyntaxBrowser:PropertiesPanelShown #t boolean?)
(pref:get/set pref:width SyntaxBrowser:Width) (pref:get/set pref:width SyntaxBrowser:Width)
(pref:get/set pref:height SyntaxBrowser:Height) (pref:get/set pref:height SyntaxBrowser:Height)
(pref:get/set pref:props-percentage SyntaxBrowser:PropertiesPanelPercentage) (pref:get/set pref:props-percentage SyntaxBrowser:PropertiesPanelPercentage)
(pref:get/set pref:props-shown? SyntaxBrowser:PropertiesPanelShown) (pref:get/set pref:props-shown? SyntaxBrowser:PropertiesPanelShown)
(pref:get/set pref:tabify framework:tabify) (pref:get/set pref:tabify framework:tabify)
(define syntax-prefs-mixin (define syntax-prefs-mixin
(closure-mixin (syntax-prefs<%>) (closure-mixin (syntax-prefs<%>)
(pref:width pref:width) (pref:width pref:width)
(pref:height pref:height) (pref:height pref:height)
(pref:props-percentage pref:props-percentage) (pref:props-percentage pref:props-percentage)
(pref:props-shown? pref:props-shown?))) (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 #lang scheme/base
(require (lib "class.ss") (require scheme/class
(lib "stx.ss" "syntax") syntax/stx
"partition.ss") "partition.ss")
(provide (all-defined)) (provide (all-defined-out))
;; Problem: If stx1 and stx2 are two distinguishable syntax objects, it ;; 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 ;; still may be the case that (syntax-e stx1) and (syntax-e stx2) are
;; indistinguishable. ;; indistinguishable.
;; Solution: Rather than map stx to (syntax-e stx), in the cases where ;; 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. ;; (syntax-e stx) is confusable, map it to a different, unique, value.
;; - stx is identifier : map it to an uninterned symbol w/ same rep ;; - stx is identifier : map it to an uninterned symbol w/ same rep
;; (Symbols are useful: see pretty-print's style table) ;; (Symbols are useful: see pretty-print's style table)
;; - else : map it to a syntax-dummy object ;; - else : map it to a syntax-dummy object
;; NOTE: Nulls are only wrapped when *not* list-terminators. ;; NOTE: Nulls are only wrapped when *not* list-terminators.
;; If they were always wrapped, the pretty-printer would screw up ;; If they were always wrapped, the pretty-printer would screw up
;; list printing (I think). ;; list printing (I think).
(define-struct syntax-dummy (val)) (define-struct syntax-dummy (val))
;; A SuffixOption is one of ;; A SuffixOption is one of
;; - 'never -- never ;; - 'never -- never
;; - 'always -- suffix > 0 ;; - 'always -- suffix > 0
;; - 'over-limit -- suffix > limit ;; - 'over-limit -- suffix > limit
;; - 'all-if-over-limit -- suffix > 0 if any over limit ;; - 'all-if-over-limit -- suffix > 0 if any over limit
;; syntax->datum/tables : stx [partition% num SuffixOption] ;; syntax->datum/tables : stx [partition% num SuffixOption]
;; -> (values s-expr hashtable hashtable) ;; -> (values s-expr hashtable hashtable)
;; When partition is not false, tracks the partititions that subterms belong to ;; When partition is not false, tracks the partititions that subterms belong to
;; When limit is a number, restarts processing with numbering? set to true ;; When limit is a number, restarts processing with numbering? set to true
;; ;;
;; Returns three values: ;; Returns three values:
;; - an S-expression ;; - an S-expression
;; - a hashtable mapping S-expressions to syntax objects ;; - a hashtable mapping S-expressions to syntax objects
;; - a hashtable mapping syntax objects to S-expressions ;; - a hashtable mapping syntax objects to S-expressions
;; Syntax objects which are eq? will map to same flat values ;; Syntax objects which are eq? will map to same flat values
(define syntax->datum/tables (define syntax->datum/tables
(case-lambda (case-lambda
[(stx) (table stx #f #f 'never)] [(stx) (table stx #f #f 'never)]
[(stx partition limit suffixopt) (table stx partition limit suffixopt)])) [(stx partition limit suffixopt) (table stx partition limit suffixopt)]))
;; table : syntax maybe-partition% maybe-num SuffixOption -> (values s-expr hashtable hashtable) ;; table : syntax maybe-partition% maybe-num SuffixOption -> (values s-expr hashtable hashtable)
(define (table stx partition limit suffixopt) (define (table stx partition limit suffixopt)
(define (make-identifier-proxy id) (define (make-identifier-proxy id)
(case suffixopt (case suffixopt
((never) (unintern (syntax-e id))) ((never) (unintern (syntax-e id)))
@ -118,15 +118,15 @@
flat=>stx flat=>stx
stx=>flat)))) stx=>flat))))
;; check+convert-special-expression : syntax -> #f/syntaxish ;; check+convert-special-expression : syntax -> #f/syntaxish
(define (check+convert-special-expression stx) (define (check+convert-special-expression stx)
(define stx-list (stx->list stx)) (define stx-list (stx->list stx))
(and stx-list (= 2 (length stx-list)) (and stx-list (= 2 (length stx-list))
(let ([kw (car stx-list)] (let ([kw (car stx-list)]
[expr (cadr stx-list)]) [expr (cadr stx-list)])
(and (identifier? kw) (and (identifier? kw)
(memq (syntax-e kw) special-expression-keywords) (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))) (andmap (lambda (f) (equal? (f stx) (f kw)))
(list syntax-source (list syntax-source
syntax-line syntax-line
@ -137,14 +137,12 @@
(cons (syntax-e kw) (cons (syntax-e kw)
(list expr)))))) (list expr))))))
(define special-expression-keywords (define special-expression-keywords
'(quote quasiquote unquote unquote-splicing syntax)) '(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))) (string->uninterned-symbol (symbol->string sym)))
(define (suffix sym n) (define (suffix sym n)
(string->uninterned-symbol (format "~a:~a" 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 ;; FIXME: Need to disable printing of structs with custom-write property
(module pretty-printer mzscheme #lang scheme/base
(require (lib "list.ss") (require scheme/list
(lib "class.ss") scheme/class
(lib "pretty.ss") scheme/pretty
(lib "mred.ss" "mred") scheme/gui
"pretty-helper.ss" "pretty-helper.ss"
"interfaces.ss" "interfaces.ss"
"params.ss" "params.ss"
"prefs.ss") "prefs.ss")
(provide pretty-print-syntax) (provide pretty-print-syntax)
;; pretty-print-syntax : syntax port partition -> range% ;; pretty-print-syntax : syntax port partition -> range%
(define (pretty-print-syntax stx port primary-partition) (define (pretty-print-syntax stx port primary-partition)
(define range-builder (new range-builder%)) (define range-builder (new range-builder%))
(define-values (datum ht:flat=>stx ht:stx=>flat) (define-values (datum ht:flat=>stx ht:stx=>flat)
(syntax->datum/tables stx primary-partition (syntax->datum/tables stx primary-partition
@ -67,7 +67,7 @@
(range-builder range-builder) (range-builder range-builder)
(identifier-list identifier-list)))) (identifier-list identifier-list))))
(define (pp-print-hook obj display-like? port) (define (pp-print-hook obj display-like? port)
(cond [(syntax-dummy? obj) (cond [(syntax-dummy? obj)
((if display-like? display write) (syntax-dummy-val obj) port)] ((if display-like? display write) (syntax-dummy-val obj) port)]
[(is-a? obj editor-snip%) [(is-a? obj editor-snip%)
@ -75,7 +75,7 @@
[else [else
(error 'pretty-print-hook "unexpected special value: ~e" obj)])) (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%) (cond [(is-a? obj editor-snip%)
(pretty-print-columns)] (pretty-print-columns)]
[(syntax-dummy? obj) [(syntax-dummy? obj)
@ -84,7 +84,7 @@
(string-length (get-output-string ostring)))] (string-length (get-output-string ostring)))]
[else #f])) [else #f]))
(define (pp-better-style-table) (define (pp-better-style-table)
(let* ([pref (pref:tabify)] (let* ([pref (pref:tabify)]
[table (car pref)] [table (car pref)]
[begin-rx (cadr pref)] [begin-rx (cadr pref)]
@ -96,19 +96,19 @@
(map car style-list) (map car style-list)
(map cdr style-list))))) (map cdr style-list)))))
(define (basic-style-list) (define (basic-style-list)
(pretty-print-extend-style-table (pretty-print-extend-style-table
(pretty-print-current-style-table) (pretty-print-current-style-table)
(map car basic-styles) (map car basic-styles)
(map cdr basic-styles))) (map cdr basic-styles)))
(define basic-styles (define basic-styles
'((define-values . define) '((define-values . define)
(define-syntaxes . define-syntax))) (define-syntaxes . define-syntax)))
(define-local-member-name range:get-ranges) (define-local-member-name range:get-ranges)
;; range-builder% ;; range-builder%
(define range-builder% (define range-builder%
(class object% (class object%
(define starts (make-hash-table)) (define starts (make-hash-table))
(define ranges (make-hash-table)) (define ranges (make-hash-table))
@ -129,8 +129,8 @@
(super-new))) (super-new)))
;; range% ;; range%
(define range% (define range%
(class* object% (range<%>) (class* object% (range<%>)
(init range-builder) (init range-builder)
(init-field identifier-list) (init-field identifier-list)
@ -158,4 +158,3 @@
(>= (- (range-end x) (range-start x)) (>= (- (range-end x) (range-start x))
(- (range-end y) (range-start y)))))))) (- (range-end y) (range-start y))))))))
)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

@ -1,20 +1,20 @@
(module stepper mzscheme #lang scheme/base
(require (lib "class.ss") (require scheme/class
(lib "unit.ss") scheme/unit
(lib "list.ss") scheme/list
(lib "plt-match.ss") scheme/match
(lib "mred.ss" "mred") scheme/gui
(lib "framework.ss" "framework") framework/framework
(lib "boundmap.ss" "syntax") syntax/boundmap
"interfaces.ss" "interfaces.ss"
"prefs.ss" "prefs.ss"
"extensions.ss" "extensions.ss"
"warning.ss" "warning.ss"
"hiding-panel.ss" "hiding-panel.ss"
"term-record.ss" "term-record.ss"
(prefix s: "../syntax-browser/widget.ss") (prefix-in s: "../syntax-browser/widget.ss")
(prefix s: "../syntax-browser/params.ss") (prefix-in s: "../syntax-browser/params.ss")
"../model/deriv.ss" "../model/deriv.ss"
"../model/deriv-util.ss" "../model/deriv-util.ss"
"../model/deriv-find.ss" "../model/deriv-find.ss"
@ -23,14 +23,14 @@
"../model/hide.ss" "../model/hide.ss"
"../model/steps.ss" "../model/steps.ss"
"cursor.ss" "cursor.ss"
"util.ss") "../util/notify.ss")
(provide macro-stepper-widget% (provide macro-stepper-widget%
macro-stepper-widget/process-mixin) macro-stepper-widget/process-mixin)
;; Macro Stepper ;; Macro Stepper
;; macro-stepper-widget% ;; macro-stepper-widget%
(define macro-stepper-widget% (define macro-stepper-widget%
(class* object% () (class* object% ()
(init-field parent) (init-field parent)
(init-field config) (init-field config)
@ -379,7 +379,7 @@
(refresh/move) (refresh/move)
)) ))
(define (macro-stepper-widget/process-mixin %) (define (macro-stepper-widget/process-mixin %)
(class % (class %
(super-new) (super-new)
(define/override (get-preprocess-deriv) (define/override (get-preprocess-deriv)
@ -427,7 +427,6 @@
[else #f]))) [else #f])))
(define/public (top-interaction-kw? x) (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 #lang scheme/base
(require (lib "class.ss") (require scheme/class
(lib "unit.ss") scheme/unit
(lib "list.ss") scheme/list
(lib "plt-match.ss") scheme/match
(lib "mred.ss" "mred") scheme/gui
(lib "framework.ss" "framework") framework/framework
(lib "boundmap.ss" "syntax") syntax/boundmap
"interfaces.ss" "interfaces.ss"
"prefs.ss" "prefs.ss"
"extensions.ss" "extensions.ss"
"warning.ss" "warning.ss"
"hiding-panel.ss" "hiding-panel.ss"
(prefix s: "../syntax-browser/widget.ss") (prefix-in s: "../syntax-browser/widget.ss")
(prefix s: "../syntax-browser/params.ss") (prefix-in s: "../syntax-browser/params.ss")
"../model/deriv.ss" "../model/deriv.ss"
"../model/deriv-util.ss" "../model/deriv-util.ss"
"../model/deriv-find.ss" "../model/deriv-find.ss"
@ -24,21 +24,21 @@
"../model/steps.ss" "../model/steps.ss"
"debug-format.ss" "debug-format.ss"
"cursor.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 (prestep protostep) (foci1 e1))
(define-struct (poststep protostep) (foci2 e2)) (define-struct (poststep protostep) (foci2 e2))
(define (prestep-term1 s) (context-fill (protostep-ctx s) (prestep-e1 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))) (define (poststep-term2 s) (context-fill (protostep-ctx s) (poststep-e2 s)))
;; TermRecords ;; TermRecords
(define term-record% (define term-record%
(class object% (class object%
(init-field stepper) (init-field stepper)
(init-field [events #f]) (init-field [events #f])
@ -389,15 +389,15 @@
(define/public (add-syntax stx binders definites) (define/public (add-syntax stx binders definites)
(send sbview add-syntax stx (send sbview add-syntax stx
#:alpha-table binders '#:alpha-table binders
#:definites definites)) '#:definites definites))
(define/private (add-final stx error binders definites) (define/private (add-final stx error binders definites)
(when stx (when stx
(send sbview add-text "Expansion finished\n") (send sbview add-text "Expansion finished\n")
(send sbview add-syntax stx (send sbview add-syntax stx
#:alpha-table binders '#:alpha-table binders
#:definites (or definites null))) '#:definites (or definites null)))
(when error (when error
(add-error error))) (add-error error)))
@ -484,8 +484,8 @@
(send sbview add-text "\n") (send sbview add-text "\n")
(when (exn:fail:syntax? (misstep-exn step)) (when (exn:fail:syntax? (misstep-exn step))
(for-each (lambda (e) (send sbview add-syntax e (for-each (lambda (e) (send sbview add-syntax e
#:alpha-table binders '#:alpha-table binders
#:definites (protostep-definites step))) '#:definites (protostep-definites step)))
(exn:fail:syntax-exprs (misstep-exn step)))) (exn:fail:syntax-exprs (misstep-exn step))))
(show-lctx step binders)) (show-lctx step binders))
@ -493,12 +493,12 @@
;; insert-syntax/color : syntax syntaxes identifiers syntaxes string -> void ;; insert-syntax/color : syntax syntaxes identifiers syntaxes string -> void
(define/private (insert-syntax/color stx foci binders definites frontier hi-color) (define/private (insert-syntax/color stx foci binders definites frontier hi-color)
(send sbview add-syntax stx (send sbview add-syntax stx
#:definites definites '#:definites definites
#:alpha-table binders '#:alpha-table binders
#:hi-color hi-color '#:hi-color hi-color
#:hi-stxs (if (send config get-highlight-foci?) foci null) '#:hi-stxs (if (send config get-highlight-foci?) foci null)
#:hi2-color "WhiteSmoke" '#:hi2-color "WhiteSmoke"
#:hi2-stxs (if (send config get-highlight-frontier?) frontier null))) '#:hi2-stxs (if (send config get-highlight-frontier?) frontier null)))
;; insert-syntax/redex : syntax syntaxes identifiers syntaxes -> void ;; insert-syntax/redex : syntax syntaxes identifiers syntaxes -> void
(define/private (insert-syntax/redex stx foci binders definites frontier) (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 #lang scheme/base
(require (lib "class.ss") (require scheme/class
(lib "pretty.ss") scheme/pretty
(lib "mred.ss" "mred") scheme/gui
(lib "framework.ss" "framework") framework/framework
"interfaces.ss" "interfaces.ss"
"frame.ss" "frame.ss"
"prefs.ss" "prefs.ss"
"../model/trace.ss") "../model/trace.ss")
(provide (all-defined)) (provide (all-defined-out))
(define macro-stepper-frame% (define macro-stepper-frame%
(macro-stepper-frame-mixin (macro-stepper-frame-mixin
(frame:standard-menus-mixin (frame:standard-menus-mixin
(frame:basic-mixin frame%)))) (frame:basic-mixin frame%))))
;; Main entry points ;; Main entry points
(define (make-macro-stepper) (define (make-macro-stepper)
(let ([f (new macro-stepper-frame% (let ([f (new macro-stepper-frame%
(config (new macro-stepper-config/prefs%)))]) (config (new macro-stepper-config/prefs%)))])
(send f show #t) (send f show #t)
(send f get-widget))) (send f get-widget)))
(define (go stx) (define (go stx)
(let ([stepper (make-macro-stepper)]) (let ([stepper (make-macro-stepper)])
(send stepper add-deriv (trace stx)) (send stepper add-deriv (trace stx))
stepper)) stepper))
(define (go/deriv deriv) (define (go/deriv deriv)
(let* ([f (new macro-stepper-frame%)] (let* ([f (new macro-stepper-frame%)]
[w (send f get-widget)]) [w (send f get-widget)])
(send w add-deriv deriv) (send w add-deriv deriv)
(send f show #t) (send f show #t)
w)) w))
(define (go/trace events) (define (go/trace events)
(let* ([w (make-macro-stepper)]) (let* ([w (make-macro-stepper)])
(send w add-trace events) (send w add-trace events)
w)) w))
)