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

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

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

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

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

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

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

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

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

File diff suppressed because it is too large Load Diff

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

@ -1,160 +1,158 @@
(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
next ; . next ; .
next-group ; . next-group ; .
enter-macro ; syntax enter-macro ; syntax
macro-pre-transform ; syntax macro-pre-transform ; syntax
macro-post-transform ; syntax macro-post-transform ; syntax
exit-macro ; syntax exit-macro ; syntax
enter-prim ; syntax enter-prim ; syntax
exit-prim ; syntax exit-prim ; syntax
return ; syntax return ; syntax
enter-block ; syntaxes enter-block ; syntaxes
block->list ; syntaxes block->list ; syntaxes
block->letrec ; syntax(es?) block->letrec ; syntax(es?)
splice ; syntaxes splice ; syntaxes
enter-list ; syntaxes enter-list ; syntaxes
exit-list ; syntaxes exit-list ; syntaxes
enter-check ; syntax enter-check ; syntax
exit-check ; syntax exit-check ; syntax
phase-up ; . phase-up ; .
module-body ; (list-of (cons syntax boolean)) module-body ; (list-of (cons syntax boolean))
... ; . ... ; .
EOF ; . EOF ; .
syntax-error ; exn syntax-error ; exn
lift-loop ; syntax lift-loop ; syntax
lift/let-loop ; syntax lift/let-loop ; syntax
module-lift-loop ; syntaxes module-lift-loop ; syntaxes
module-lift-end-loop ; syntaxes module-lift-end-loop ; syntaxes
lift ; (cons syntax id) lift ; (cons syntax id)
lift-statement ; syntax lift-statement ; syntax
enter-local ; syntax enter-local ; syntax
local-pre ; syntax local-pre ; syntax
local-post ; syntax local-post ; syntax
exit-local ; syntax exit-local ; syntax
enter-local/expr ; syntax enter-local/expr ; syntax
exit-local/expr ; (cons syntax expanded-expression) exit-local/expr ; (cons syntax expanded-expression)
variable ; (cons identifier identifier) variable ; (cons identifier identifier)
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)
renames-letrec-syntaxes ; (cons (listof syntax) (cons (listof syntax) syntax)) renames-letrec-syntaxes ; (cons (listof syntax) (cons (listof syntax) syntax))
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
prim-case-lambda prim-let-values prim-let*-values prim-letrec-values prim-case-lambda prim-let-values prim-let*-values prim-letrec-values
prim-letrec-syntaxes+values prim-#%datum prim-#%top prim-stop prim-letrec-syntaxes+values prim-#%datum prim-#%top prim-stop
prim-quote prim-quote-syntax prim-require prim-require-for-syntax prim-quote prim-quote-syntax prim-require prim-require-for-syntax
prim-require-for-template prim-provide prim-require-for-template prim-provide
prim-set! prim-set!
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)
(1 . ,token-resolve) (1 . ,token-resolve)
(2 . ,token-return) (2 . ,token-return)
(3 . ,token-next) (3 . ,token-next)
(4 . ,token-enter-list) (4 . ,token-enter-list)
(5 . ,token-exit-list) (5 . ,token-exit-list)
(6 . ,token-enter-prim) (6 . ,token-enter-prim)
(7 . ,token-exit-prim) (7 . ,token-exit-prim)
(8 . ,token-enter-macro) (8 . ,token-enter-macro)
(9 . ,token-exit-macro) (9 . ,token-exit-macro)
(10 . ,token-enter-block) (10 . ,token-enter-block)
(11 . ,token-splice) (11 . ,token-splice)
(12 . ,token-block->list) (12 . ,token-block->list)
(13 . ,token-next-group) (13 . ,token-next-group)
(14 . ,token-block->letrec) (14 . ,token-block->letrec)
(16 . ,token-renames-let) (16 . ,token-renames-let)
(17 . ,token-renames-lambda) (17 . ,token-renames-lambda)
(18 . ,token-renames-case-lambda) (18 . ,token-renames-case-lambda)
(19 . ,token-renames-letrec-syntaxes) (19 . ,token-renames-letrec-syntaxes)
(20 . phase-up) (20 . phase-up)
(21 . ,token-macro-pre-transform) (21 . ,token-macro-pre-transform)
(22 . ,token-macro-post-transform) (22 . ,token-macro-post-transform)
(23 . ,token-module-body) (23 . ,token-module-body)
(24 . ,token-renames-block) (24 . ,token-renames-block)
(100 . prim-stop) (100 . prim-stop)
(101 . prim-module) (101 . prim-module)
(102 . prim-#%module-begin) (102 . prim-#%module-begin)
(103 . prim-define-syntaxes) (103 . prim-define-syntaxes)
(104 . prim-define-values) (104 . prim-define-values)
(105 . prim-if) (105 . prim-if)
(106 . prim-wcm) (106 . prim-wcm)
(107 . prim-begin) (107 . prim-begin)
(108 . prim-begin0) (108 . prim-begin0)
(109 . prim-#%app) (109 . prim-#%app)
(110 . prim-lambda) (110 . prim-lambda)
(111 . prim-case-lambda) (111 . prim-case-lambda)
(112 . prim-let-values) (112 . prim-let-values)
(113 . prim-letrec-values) (113 . prim-letrec-values)
(114 . prim-letrec-syntaxes+values) (114 . prim-letrec-syntaxes+values)
(115 . prim-#%datum) (115 . prim-#%datum)
(116 . prim-#%top) (116 . prim-#%top)
(117 . prim-quote) (117 . prim-quote)
(118 . prim-quote-syntax) (118 . prim-quote-syntax)
(119 . prim-require) (119 . prim-require)
(120 . prim-require-for-syntax) (120 . prim-require-for-syntax)
(121 . prim-require-for-template) (121 . prim-require-for-template)
(122 . prim-provide) (122 . prim-provide)
(123 . prim-set!) (123 . prim-set!)
(124 . prim-let*-values) (124 . prim-let*-values)
(125 . ,token-variable) (125 . ,token-variable)
(126 . ,token-enter-check) (126 . ,token-enter-check)
(127 . ,token-exit-check) (127 . ,token-exit-check)
(128 . ,token-lift-loop) (128 . ,token-lift-loop)
(129 . ,token-lift) (129 . ,token-lift)
(130 . ,token-enter-local) (130 . ,token-enter-local)
(131 . ,token-exit-local) (131 . ,token-exit-local)
(132 . ,token-local-pre) (132 . ,token-local-pre)
(133 . ,token-local-post) (133 . ,token-local-post)
(134 . ,token-lift-statement) (134 . ,token-lift-statement)
(135 . ,token-module-lift-end-loop) (135 . ,token-module-lift-end-loop)
(136 . ,token-lift/let-loop) (136 . ,token-lift/let-loop)
(137 . ,token-module-lift-loop) (137 . ,token-module-lift-loop)
(138 . prim-expression) (138 . prim-expression)
(139 . ,token-enter-local/expr) (139 . ,token-enter-local/expr)
(140 . ,token-exit-local/expr) (140 . ,token-exit-local/expr)
(141 . ,token-start) (141 . ,token-start)
)) ))
(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
(cond [(procedure? (cdr p)) ((cdr p) val)] (cond [(procedure? (cdr p)) ((cdr p) val)]
[(symbol? (cdr p)) (cdr p)]) [(symbol? (cdr p)) (cdr p)])
pos pos
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)))
)

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

@ -1,100 +1,100 @@
(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
ok-node? ok-node?
interrupted-node? interrupted-node?
wderiv-e1 wderiv-e1
wderiv-e2 wderiv-e2
wlderiv-es1 wlderiv-es1
wlderiv-es2 wlderiv-es2
wbderiv-es1 wbderiv-es1
wbderiv-es2 wbderiv-es2
wderivlist-es2) wderivlist-es2)
;; Wrap matcher
;; Matches unwrapped, interrupted wrapped, or error wrapped
(define-match-expander Wrap
(lambda (stx)
(syntax-case stx ()
[(Wrap S (var ...))
(syntax/loc stx (struct S (var ...)))])))
;; ---- ;; Wrap matcher
;; Matches unwrapped, interrupted wrapped, or error wrapped
(define (check sym pred type x) (define-match-expander Wrap
(unless (pred x) (lambda (stx)
(raise-type-error sym type x)))
(define (ok-node? x)
(check 'ok-node? node? "node" x)
(and (node-z1 x) #t))
(define (interrupted-node? x)
(check 'interrupted-node? node? "node" x)
(not (node-z2 x)))
(define (wderiv-e1 x)
(check 'wderiv-e1 deriv? "deriv" x)
(node-z1 x))
(define (wderiv-e2 x)
(check 'wderiv-e2 deriv? "deriv" x)
(node-z2 x))
(define (wlderiv-es1 x)
(check 'wlderiv-es1 lderiv? "lderiv" x)
(node-z1 x))
(define (wlderiv-es2 x)
(check 'wlderiv-es2 lderiv? "lderiv" x)
(node-z2 x))
(define (wbderiv-es1 x)
(check 'wbderiv-es1 bderiv? "bderiv" x)
(node-z1 x))
(define (wbderiv-es2 x)
(check 'wbderiv-es2 bderiv? "bderiv" x))
;; wderivlist-es2 : (list-of WDeriv) -> (list-of Stx)/#f
(define (wderivlist-es2 xs)
(let ([es2 (map wderiv-e2 xs)])
(and (andmap syntax? es2) es2)))
;; ----
(define-syntax (make stx)
(syntax-case stx () (syntax-case stx ()
[(make S expr ...) [(Wrap S (var ...))
(unless (identifier? #'S) (syntax/loc stx (struct S (var ...)))])))
(raise-syntax-error #f "not an identifier" stx #'S))
(let () ;; ----
(define (no-info) (raise-syntax-error #f "not a struct" stx #'S))
(define info (define (check sym pred type x)
(extract-struct-info (unless (pred x)
(syntax-local-value #'S no-info))) (raise-type-error sym type x)))
(define constructor (list-ref info 1))
(define accessors (list-ref info 3)) (define (ok-node? x)
(unless (identifier? #'constructor) (check 'ok-node? node? "node" x)
(raise-syntax-error #f "constructor not available for struct" stx #'S)) (and (node-z1 x) #t))
(unless (andmap identifier? accessors) (define (interrupted-node? x)
(raise-syntax-error #f "incomplete info for struct type" stx #'S)) (check 'interrupted-node? node? "node" x)
(let ([num-slots (length accessors)] (not (node-z2 x)))
[num-provided (length (syntax->list #'(expr ...)))])
(unless (= num-provided num-slots)
(raise-syntax-error (define (wderiv-e1 x)
#f (check 'wderiv-e1 deriv? "deriv" x)
(format "wrong number of arguments for struct ~s (expected ~s)" (node-z1 x))
(syntax-e #'S) (define (wderiv-e2 x)
num-slots) (check 'wderiv-e2 deriv? "deriv" x)
stx))) (node-z2 x))
(with-syntax ([constructor constructor])
#'(constructor expr ...)))])) (define (wlderiv-es1 x)
) (check 'wlderiv-es1 lderiv? "lderiv" x)
(node-z1 x))
(define (wlderiv-es2 x)
(check 'wlderiv-es2 lderiv? "lderiv" x)
(node-z2 x))
(define (wbderiv-es1 x)
(check 'wbderiv-es1 bderiv? "bderiv" x)
(node-z1 x))
(define (wbderiv-es2 x)
(check 'wbderiv-es2 bderiv? "bderiv" x))
;; wderivlist-es2 : (list-of WDeriv) -> (list-of Stx)/#f
(define (wderivlist-es2 xs)
(let ([es2 (map wderiv-e2 xs)])
(and (andmap syntax? es2) es2)))
;; ----
(define-syntax (make stx)
(syntax-case stx ()
[(make S expr ...)
(unless (identifier? #'S)
(raise-syntax-error #f "not an identifier" stx #'S))
(let ()
(define (no-info) (raise-syntax-error #f "not a struct" stx #'S))
(define info
(extract-struct-info
(syntax-local-value #'S no-info)))
(define constructor (list-ref info 1))
(define accessors (list-ref info 3))
(unless (identifier? #'constructor)
(raise-syntax-error #f "constructor not available for struct" stx #'S))
(unless (andmap identifier? accessors)
(raise-syntax-error #f "incomplete info for struct type" stx #'S))
(let ([num-slots (length accessors)]
[num-provided (length (syntax->list #'(expr ...)))])
(unless (= num-provided num-slots)
(raise-syntax-error
#f
(format "wrong number of arguments for struct ~s (expected ~s)"
(syntax-e #'S)
num-slots)
stx)))
(with-syntax ([constructor constructor])
#'(constructor expr ...)))]))

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

@ -1,370 +1,368 @@
(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 (stx? x) (define (?? c) (or/c c false/c))
(or (syntax? x)
(and (pair? x) (stx? (car x)) (stx? (cdr x)))
(null? x)))
(define (stx-list-like? x)
(let ([x (stx->list x)])
(and x (andmap syntax? x))))
(define syntax/f (?? syntax?)) (define (stx? x)
(define syntaxes/c stx-list-like?) (or (syntax? x)
(define syntaxes/f (?? syntaxes/c)) (and (pair? x) (stx? (car x)) (stx? (cdr x)))
(define resolves/c (listof identifier?)) (null? x)))
(define localaction/c (define (stx-list-like? x)
(or/c local-expansion? local-expansion/expr? local-lift? (let ([x (stx->list x)])
local-lift-end? local-bind?)) (and x (andmap syntax? x))))
(provide/contract
(struct node
([z1 any/c]
[z2 any/c]))
(struct (deriv node)
([z1 syntax?]
[z2 syntax/f]))
(struct (lift-deriv deriv)
([z1 syntax?]
[z2 syntax/f]
[first deriv?]
[lift-stx syntax?]
[second deriv?]))
(struct (mrule deriv)
([z1 syntax?]
[z2 syntax/f]
[transformation transformation?]
[next (?? deriv?)]))
(struct (lift/let-deriv deriv)
([z1 syntax?]
[z2 syntax/f]
[first deriv?]
[lift-stx syntax?]
[second deriv?]))
(struct (transformation node)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[me1 (?? syntax?)]
[locals (?? (listof localaction/c))]
[?2 (?? exn?)]
[me2 (?? syntax?)]
[seq number?]))
(struct (local-expansion node)
([z1 syntax?]
[z2 syntax/f]
[me1 syntax?]
[me2 syntax/f]
[for-stx? boolean?]
[inner deriv?]))
(struct (local-expansion/expr node)
([z1 syntax?]
[z2 syntax/f]
[me1 syntax?]
[me2 syntax/f]
[for-stx? boolean?]
[opaque any/c]
[inner deriv?]))
(struct local-lift
([expr syntax?]
[id identifier?]))
(struct local-lift-end
([decl syntax?]))
(struct local-bind
([bindrhs bind-syntaxes?]))
(struct (base deriv)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]))
(struct (prule base)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]))
(struct (p:variable prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]))
(struct (p:module prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[one-body-form? boolean?]
[mb (?? deriv?)]
[?2 (?? exn?)]
[body (?? deriv?)]))
(struct (p:#%module-begin prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[pass1 (?? (listof modrule?))]
[pass2 (?? (listof modrule?))]
[?2 (?? exn?)]))
(struct (p:define-syntaxes prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[rhs (?? deriv?)]
[?2 (?? exn?)]))
(struct (p:define-values prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[rhs (?? deriv?)]))
(struct (p:#%expression prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[inner (?? deriv?)]))
(struct (p:if prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[full? boolean?]
[test (?? deriv?)]
[then (?? deriv?)]
[else (?? deriv?)]))
(struct (p:wcm prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[key (?? deriv?)]
[mark (?? deriv?)]
[body (?? deriv?)]))
(struct (p:set! prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[id-resolves (?? resolves/c)]
[rhs (?? deriv?)]))
(struct (p:set!-macro prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[deriv (?? deriv?)]))
(struct (p:#%app prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[tagged-stx syntax/f]
[lderiv (?? lderiv?)]))
(struct (p:begin prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[lderiv (?? lderiv?)]))
(struct (p:begin0 prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[first (?? deriv?)]
[lderiv (?? lderiv?)]))
(struct (p:lambda prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[renames any/c] ;; fixme
[body (?? bderiv?)]))
(struct (p:case-lambda prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[renames+bodies (listof clc?)]))
(struct (p:let-values prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[renames any/c] ;; fixme
[rhss (?? (listof deriv?))]
[body (?? bderiv?)]))
(struct (p:letrec-values prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[renames any/c] ;; fixme
[rhss (?? (listof deriv?))]
[body (?? bderiv?)]))
(struct (p:letrec-syntaxes+values prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[srenames any/c] ;; fixme
[sbindrhss (?? (listof bind-syntaxes?))]
[vrenames any/c] ;; fixme
[vrhss (?? (listof deriv?))]
[body (?? bderiv?)]))
(struct (p::STOP prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]))
(struct (p:stop p::STOP)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]))
(struct (p:unknown p::STOP)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]))
(struct (p:#%top p::STOP)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[tagged-stx syntax/f]))
(struct (p:#%datum p::STOP)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[tagged-stx syntax/f]))
(struct (p:quote p::STOP)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]))
(struct (p:quote-syntax p::STOP)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]))
(struct (p:require p::STOP)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]))
(struct (p:require-for-syntax p::STOP)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]))
(struct (p:require-for-template p::STOP)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]))
(struct (p:provide p::STOP)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]))
(struct (p:rename prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[renames any/c]
[inner (?? deriv?)]))
(struct (p:synth prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[subterms (?? (listof subitem?))]
[?2 (?? exn?)]))
(struct (lderiv node) (define syntax/f (?? syntax?))
([z1 stx?] (define syntaxes/c stx-list-like?)
[z2 syntaxes/f] (define syntaxes/f (?? syntaxes/c))
[?1 (?? exn?)] (define resolves/c (listof identifier?))
[derivs (?? (listof deriv?))]))
(struct (bderiv node)
([z1 stx?]
[z2 syntaxes/f]
[pass1 (?? (listof (or/c b:error? brule?)))]
[trans (symbols 'list 'letrec)]
[pass2 (?? lderiv?)]))
(struct b:error (define localaction/c
([?1 exn?])) (or/c local-expansion? local-expansion/expr? local-lift?
(struct brule local-lift-end? local-bind?))
([renames any/c]))
(struct (b:expr brule)
([renames any/c]
[head deriv?]))
(struct (b:splice brule)
([renames any/c]
[head deriv?]
[?1 (?? exn?)]
[tail (?? stx?)]
[?2 (?? exn?)]))
(struct (b:defvals brule)
([renames any/c]
[head deriv?]
[?1 (?? exn?)]))
(struct (b:defstx brule)
([renames any/c]
[head deriv?]
[?1 (?? exn?)]
[bindrhs (?? bind-syntaxes?)]))
(struct bind-syntaxes (provide/contract
([rhs deriv?] (struct node
[?1 (?? exn?)])) ([z1 any/c]
[z2 any/c]))
(struct (deriv node)
([z1 syntax?]
[z2 syntax/f]))
(struct (lift-deriv deriv)
([z1 syntax?]
[z2 syntax/f]
[first deriv?]
[lift-stx syntax?]
[second deriv?]))
(struct (mrule deriv)
([z1 syntax?]
[z2 syntax/f]
[transformation transformation?]
[next (?? deriv?)]))
(struct (lift/let-deriv deriv)
([z1 syntax?]
[z2 syntax/f]
[first deriv?]
[lift-stx syntax?]
[second deriv?]))
(struct (transformation node)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[me1 (?? syntax?)]
[locals (?? (listof localaction/c))]
[?2 (?? exn?)]
[me2 (?? syntax?)]
[seq number?]))
(struct (local-expansion node)
([z1 syntax?]
[z2 syntax/f]
[me1 syntax?]
[me2 syntax/f]
[for-stx? boolean?]
[inner deriv?]))
(struct (local-expansion/expr node)
([z1 syntax?]
[z2 syntax/f]
[me1 syntax?]
[me2 syntax/f]
[for-stx? boolean?]
[opaque any/c]
[inner deriv?]))
(struct local-lift
([expr syntax?]
[id identifier?]))
(struct local-lift-end
([decl syntax?]))
(struct local-bind
([bindrhs bind-syntaxes?]))
(struct (base deriv)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]))
(struct (prule base)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]))
(struct (p:variable prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]))
(struct (p:module prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[one-body-form? boolean?]
[mb (?? deriv?)]
[?2 (?? exn?)]
[body (?? deriv?)]))
(struct (p:#%module-begin prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[pass1 (?? (listof modrule?))]
[pass2 (?? (listof modrule?))]
[?2 (?? exn?)]))
(struct (p:define-syntaxes prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[rhs (?? deriv?)]
[?2 (?? exn?)]))
(struct (p:define-values prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[rhs (?? deriv?)]))
(struct (p:#%expression prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[inner (?? deriv?)]))
(struct (p:if prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[full? boolean?]
[test (?? deriv?)]
[then (?? deriv?)]
[else (?? deriv?)]))
(struct (p:wcm prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[key (?? deriv?)]
[mark (?? deriv?)]
[body (?? deriv?)]))
(struct (p:set! prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[id-resolves (?? resolves/c)]
[rhs (?? deriv?)]))
(struct (p:set!-macro prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[deriv (?? deriv?)]))
(struct (p:#%app prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[tagged-stx syntax/f]
[lderiv (?? lderiv?)]))
(struct (p:begin prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[lderiv (?? lderiv?)]))
(struct (p:begin0 prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[first (?? deriv?)]
[lderiv (?? lderiv?)]))
(struct (p:lambda prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[renames any/c] ;; fixme
[body (?? bderiv?)]))
(struct (p:case-lambda prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[renames+bodies (listof clc?)]))
(struct (p:let-values prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[renames any/c] ;; fixme
[rhss (?? (listof deriv?))]
[body (?? bderiv?)]))
(struct (p:letrec-values prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[renames any/c] ;; fixme
[rhss (?? (listof deriv?))]
[body (?? bderiv?)]))
(struct (p:letrec-syntaxes+values prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[srenames any/c] ;; fixme
[sbindrhss (?? (listof bind-syntaxes?))]
[vrenames any/c] ;; fixme
[vrhss (?? (listof deriv?))]
[body (?? bderiv?)]))
(struct (p::STOP prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]))
(struct (p:stop p::STOP)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]))
(struct (p:unknown p::STOP)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]))
(struct (p:#%top p::STOP)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[tagged-stx syntax/f]))
(struct (p:#%datum p::STOP)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[tagged-stx syntax/f]))
(struct (p:quote p::STOP)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]))
(struct (p:quote-syntax p::STOP)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]))
(struct (p:require p::STOP)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]))
(struct (p:require-for-syntax p::STOP)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]))
(struct (p:require-for-template p::STOP)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]))
(struct (p:provide p::STOP)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]))
(struct (p:rename prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[renames any/c]
[inner (?? deriv?)]))
(struct (p:synth prule)
([z1 syntax?]
[z2 syntax/f]
[resolves resolves/c]
[?1 (?? exn?)]
[subterms (?? (listof subitem?))]
[?2 (?? exn?)]))
(struct clc (struct (lderiv node)
([?1 (?? exn?)] ([z1 stx?]
[renames any/c] [z2 syntaxes/f]
[body (?? bderiv?)])) [?1 (?? exn?)]
[derivs (?? (listof deriv?))]))
(struct (bderiv node)
([z1 stx?]
[z2 syntaxes/f]
[pass1 (?? (listof (or/c b:error? brule?)))]
[trans (symbols 'list 'letrec)]
[pass2 (?? lderiv?)]))
(struct modrule ()) (struct b:error
(struct (mod:cons modrule) ([?1 exn?]))
([head deriv?])) (struct brule
(struct (mod:prim modrule) ([renames any/c]))
([head deriv?] (struct (b:expr brule)
[prim (?? deriv?)])) ([renames any/c]
(struct (mod:skip modrule) ()) [head deriv?]))
(struct (mod:splice modrule) (struct (b:splice brule)
([head deriv?] ([renames any/c]
[?1 (?? exn?)] [head deriv?]
[tail (?? stx?)])) [?1 (?? exn?)]
(struct (mod:lift modrule) [tail (?? stx?)]
([head deriv?] [?2 (?? exn?)]))
[tail syntaxes/c])) (struct (b:defvals brule)
(struct (mod:lift-end modrule) ([renames any/c]
([tail syntaxes/c])) [head deriv?]
[?1 (?? exn?)]))
(struct (b:defstx brule)
([renames any/c]
[head deriv?]
[?1 (?? exn?)]
[bindrhs (?? bind-syntaxes?)]))
(struct subitem ()) (struct bind-syntaxes
(struct (s:subterm subitem) ([rhs deriv?]
([path any/c] [?1 (?? exn?)]))
[deriv deriv?]))
(struct (s:rename subitem) (struct clc
([path any/c] ([?1 (?? exn?)]
[before syntax?] [renames any/c]
[after syntax?])) [body (?? bderiv?)]))
))
(struct modrule ())
(struct (mod:cons modrule)
([head deriv?]))
(struct (mod:prim modrule)
([head deriv?]
[prim (?? deriv?)]))
(struct (mod:skip modrule) ())
(struct (mod:splice modrule)
([head deriv?]
[?1 (?? exn?)]
[tail (?? stx?)]))
(struct (mod:lift modrule)
([head deriv?]
[tail syntaxes/c]))
(struct (mod:lift-end modrule)
([tail syntaxes/c]))
(struct subitem ())
(struct (s:subterm subitem)
([path any/c]
[deriv deriv?]))
(struct (s:rename subitem)
([path any/c]
[before syntax?]
[after syntax?])))
|#

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

@ -1,100 +1,101 @@
(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)
(let ([p (new-hiding-policy)])
(policy-hide-kernel p)
(policy-hide-libs p)
p))
;; --- (define (new-standard-hiding-policy)
(let ([p (new-hiding-policy)])
(define-syntax inline (policy-hide-kernel p)
(syntax-rules () (policy-hide-libs p)
[(inline ([name expr] ...) . body) p))
(let-syntax ([name
(lambda (x)
(syntax-case x ()
[xx (identifier? #'xx) #'expr]))] ...)
. body)]))
(define (/false) #f) ;; ---
(define (policy-show-macro? policy id) (define-syntax inline
(match policy (syntax-rules ()
[(struct hiding-policy (opaque-modules [(inline ([name expr] ...) . body)
opaque-identifiers (let-syntax ([name
opaque-kernel (lambda (x)
opaque-libs (syntax-case x ()
transparent-identifiers)) [xx (identifier? #'xx) #'expr]))] ...)
(inline ([not-opaque-id . body)]))
(not (module-identifier-mapping-get opaque-identifiers id /false))]
[transparent-id
(module-identifier-mapping-get transparent-identifiers id /false)])
(let ([binding (identifier-binding id)])
(if (list? binding)
(let-values ([(srcmod srcname nommod nomname _) (apply values binding)])
(inline ([opaque-srcmod (hash-table-get opaque-modules srcmod /false)]
[opaque-nommod (hash-table-get opaque-modules nommod /false)]
;; FIXME
[in-kernel?
(and (symbol? srcmod)
(eq? #\# (string-ref (symbol->string srcmod) 0)))]
[in-lib-module?
(lib-module? srcmod)])
(or transparent-id
(and (not opaque-srcmod)
(not opaque-nommod)
(not (and in-kernel? opaque-kernel))
(not (and in-lib-module? opaque-libs))
not-opaque-id))))
(or transparent-id
not-opaque-id))))]))
(define (lib-module? mpi) (define (/false) #f)
(and (module-path-index? mpi)
(let-values ([(path rel) (module-path-index-split mpi)]) (define (policy-show-macro? policy id)
(cond [(pair? path) (memq (car path) '(lib planet))] (match policy
[(string? path) (lib-module? rel)] [(struct hiding-policy (opaque-modules
[else #f])))) opaque-identifiers
) opaque-kernel
opaque-libs
transparent-identifiers))
(inline ([not-opaque-id
(not (module-identifier-mapping-get opaque-identifiers id /false))]
[transparent-id
(module-identifier-mapping-get transparent-identifiers id /false)])
(let ([binding (identifier-binding id)])
(if (list? binding)
(let-values ([(srcmod srcname nommod nomname _) (apply values binding)])
(inline ([opaque-srcmod (hash-table-get opaque-modules srcmod /false)]
[opaque-nommod (hash-table-get opaque-modules nommod /false)]
;; FIXME
[in-kernel?
(and (symbol? srcmod)
(eq? #\# (string-ref (symbol->string srcmod) 0)))]
[in-lib-module?
(lib-module? srcmod)])
(or transparent-id
(and (not opaque-srcmod)
(not opaque-nommod)
(not (and in-kernel? opaque-kernel))
(not (and in-lib-module? opaque-libs))
not-opaque-id))))
(or transparent-id
not-opaque-id))))]))
(define (lib-module? mpi)
(and (module-path-index? mpi)
(let-values ([(path rel) (module-path-index-split mpi)])
(cond [(pair? path) (memq (car path) '(lib planet))]
[(string? path) (lib-module? rel)]
[else #f]))))

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

@ -1,444 +1,445 @@
#lang scheme/base
(require (for-syntax scheme/base)
scheme/list
scheme/contract
"deriv.ss"
"stx-util.ss"
"steps.ss")
(provide (all-from-out "steps.ss")
context
big-context
current-derivation
current-definites
learn-definites
current-frontier
add-frontier
blaze-frontier
rename-frontier
with-context
with-derivation
with-new-local-context
RSunit
RSzero
RSbind
RSadd
RSseq
RSforeach
RS-steps
CC
R
revappend
walk
walk/foci
walk/mono
stumble
stumble/E)
;; FIXME: Steps are pairs of Configurations ;; FIXME: Steps are pairs of Configurations
;; Configurations contain contexts, definites, etc. ;; Configurations contain contexts, definites, etc.
(module reductions-engine mzscheme ;; context: parameter of Context
(require (lib "list.ss") (define context (make-parameter null))
"deriv.ss"
"stx-util.ss"
"steps.ss")
(require (lib "contract.ss"))
(provide (all-from "steps.ss"))
(provide context ;; big-context: parameter of BigContext
big-context (define big-context (make-parameter null))
current-derivation
current-definites
learn-definites
current-frontier
add-frontier
blaze-frontier
rename-frontier
with-context
with-derivation
with-new-local-context
RSunit ;; current-derivation : parameter of Derivation
RSzero (define current-derivation (make-parameter #f))
RSbind
RSadd
RSseq
RSforeach
RS-steps
CC
R
revappend)
(provide walk
walk/foci
walk/mono
stumble
stumble/E)
;; context: parameter of Context ;; current-definites : parameter of (list-of identifier)
(define context (make-parameter null)) (define current-definites (make-parameter null))
;; big-context: parameter of BigContext ;; current-frontier : parameter of (list-of syntax)
(define big-context (make-parameter null)) (define current-frontier (make-parameter null))
;; current-derivation : parameter of Derivation (define-syntax with-context
(define current-derivation (make-parameter #f)) (syntax-rules ()
[(with-context f . body)
(let ([c (context)])
(parameterize ([context (cons f c)])
(let () . body)))]))
;; current-definites : parameter of (list-of identifier) (define-syntax with-derivation
(define current-definites (make-parameter null)) (syntax-rules ()
[(with-derivation d . body)
(parameterize ((current-derivation d)) . body)]))
;; current-frontier : parameter of (list-of syntax) (define-syntax with-new-local-context
(define current-frontier (make-parameter null)) (syntax-rules ()
[(with-new-local-context e . body)
(parameterize ([big-context
(cons (make-bigframe (current-derivation) (context) (list e) e)
(big-context))]
[context null])
. body)]))
(define-syntax with-context (define (learn-definites ids)
(syntax-rules () (current-definites
[(with-context f . body) (append ids (current-definites))))
(let ([c (context)])
(parameterize ([context (cons f c)])
(let () . body)))]))
(define-syntax with-derivation (define (get-frontier) (or (current-frontier) null))
(syntax-rules ()
[(with-derivation d . body)
(parameterize ((current-derivation d)) . body)]))
(define-syntax with-new-local-context
(syntax-rules ()
[(with-new-local-context e . body)
(parameterize ([big-context
(cons (make-bigframe (current-derivation) (context) (list e) e)
(big-context))]
[context null])
. body)]))
(define (learn-definites ids) (define (add-frontier stxs)
(current-definites (current-frontier
(append ids (current-definites)))) (let ([frontier0 (current-frontier)])
(and frontier0 (append stxs frontier0)))))
(define (get-frontier) (or (current-frontier) null)) (define (blaze-frontier stx)
(current-frontier
(define (add-frontier stxs) (let ([frontier0 (current-frontier)])
(current-frontier (and frontier0
(let ([frontier0 (current-frontier)]) (remq stx frontier0)))))
(and frontier0 (append stxs frontier0)))))
(define (blaze-frontier stx)
(current-frontier
(let ([frontier0 (current-frontier)])
(and 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
(syntax-rules ()
[(->RS/c domain-c ...)
(-> domain-c ...
(values (listof protostep?) any/c (or/c exn? false/c)))]))
(define/contract RSzero
(->RS/c)
(lambda () (values null #f #f)))
(define/contract RSunit
(->RS/c any/c)
(lambda (v)
(values null v #f)))
(define/contract RSbind
(->RS/c (->RS/c) (->RS/c any/c))
(lambda (a f)
(let-values ([(rseq1 final1 exn1) (a)])
(if (not exn1)
(let-values ([(rseq2 final2 exn2) (f final1)])
(values (append rseq1 rseq2) final2 exn2))
(values rseq1 final1 exn1)))))
(define/contract RSseq (define-syntax ->RS/c
(->RS/c (->RS/c) (->RS/c)) (syntax-rules ()
(lambda (a b) [(->RS/c domain-c ...)
(RSbind a (lambda (_) (b))))) (-> domain-c ...
(values (listof protostep?) any/c (or/c exn? false/c)))]))
(define/contract RSforeach (define/contract RSzero
(->RS/c (->RS/c any/c) (listof any/c)) (->RS/c)
(lambda (f xs) (lambda () (values null #f #f)))
(let loop ([xs xs])
(if (pair? xs)
(RSseq (lambda () (f (car xs)))
(lambda () (loop (cdr xs))))
(RSunit (void))))))
(define/contract RSadd
(->RS/c (listof protostep?) (->RS/c))
(lambda (steps a)
(let-values ([(rseq1 final1 exn1) (a)])
(values (append steps rseq1) final1 exn1))))
(define-syntax RS-steps (define/contract RSunit
(syntax-rules () (->RS/c any/c)
[(RS-steps expr) (lambda (v)
(let-values ([(rseq final exn) expr]) (values null v #f)))
rseq)]))
;; CC
;; the context constructor
(define-syntax (CC stx)
(syntax-case stx ()
[(CC HOLE expr pattern)
#'(syntax-copier HOLE expr pattern)]))
;; (R stx R-clause ...) (define/contract RSbind
;; An R-clause is one of (->RS/c (->RS/c) (->RS/c any/c))
;; [! expr] (lambda (a f)
;; [#:pattern pattern] (let-values ([(rseq1 final1 exn1) (a)])
;; [#:bind pattern stx-expr] (if (not exn1)
;; [#:let-values (var ...) expr] (let-values ([(rseq2 final2 exn2) (f final1)])
;; [#:set-syntax stx-expr] (values (append rseq1 rseq2) final2 exn2))
;; [#:walk term2 foci1 foci2 description] (values rseq1 final1 exn1)))))
;; [#:walk term2 description]
;; [#:rename form2 foci1 foci2 description]
;; [#:rename/no-step pattern stx stx]
;; [#:reductions expr]
;; [#:learn ids]
;; [#:frontier stxs]
;; [#:when test R-clause ...]
;; [#:if/np test R-clause ...]
;; [generator hole fill]
;; R
;; the threaded reductions engine
;; (R form . clauses) : (values (list-of Step) ?stx ?exn) (define/contract RSseq
(->RS/c (->RS/c) (->RS/c))
(lambda (a b)
(RSbind a (lambda (_) (b)))))
(define-syntax R (define/contract RSforeach
(syntax-rules () (->RS/c (->RS/c any/c) (listof any/c))
[(R form . clauses) (lambda (f xs)
(R** #f _ [#:set-syntax form] . clauses)])) (let loop ([xs xs])
(if (pair? xs)
(define-syntax R** (RSseq (lambda () (f (car xs)))
(syntax-rules (! =>) (lambda () (loop (cdr xs))))
;; Base: done (RSunit (void))))))
[(R** form-var pattern)
(RSunit form-var)] (define/contract RSadd
(->RS/c (listof protostep?) (->RS/c))
;; Base: explicit continuation (lambda (steps a)
[(R** f p => k) (let-values ([(rseq1 final1 exn1) (a)])
(k f)] (values (append steps rseq1) final1 exn1))))
;; Error-point case (define-syntax RS-steps
[(R** f p [! maybe-exn] . more) (syntax-rules ()
(let ([x maybe-exn]) [(RS-steps expr)
(unless (or (not x) (exn? x)) (let-values ([(rseq final exn) expr])
(raise-type-error 'R "exception" x)) rseq)]))
(if x
(values (list (stumble f x)) #f x) ;; CC
(R** f p . more)))] ;; the context constructor
(define-syntax (CC stx)
;; Change patterns (syntax-case stx ()
[(R** f p [#:pattern p2] . more) [(CC HOLE expr pattern)
(R** f p2 . more)] #'(syntax-copier HOLE expr pattern)]))
;; Bind pattern variables ;; (R stx R-clause ...)
[(R** f p [#:bind pattern rhs] . more) ;; An R-clause is one of
(with-syntax ([pattern (with-syntax ([p f]) rhs)]) ;; [! expr]
(R** f p . more))] ;; [#:pattern pattern]
;; [#:bind pattern stx-expr]
;; Bind variables ;; [#:let-values (var ...) expr]
[(R** f p [#:let-values (var ...) rhs] . more) ;; [#:set-syntax stx-expr]
(let-values ([(var ...) (with-syntax ([p f]) rhs)]) ;; [#:walk term2 foci1 foci2 description]
(R** f p . more))] ;; [#:walk term2 description]
;; [#:rename form2 foci1 foci2 description]
;; Change syntax ;; [#:rename/no-step pattern stx stx]
[(R** f p [#:set-syntax form] . more) ;; [#:reductions expr]
(let ([form-variable form]) ;; [#:learn ids]
(R** form-variable p . more))] ;; [#:frontier stxs]
;; [#:when test R-clause ...]
;; Change syntax and Step (explicit foci) ;; [#:if/np test R-clause ...]
[(R** f p [#:walk form2 foci1 foci2 description] . more) ;; [generator hole fill]
(let-values ([(form2-var foci1-var foci2-var description-var)
(with-syntax ([p f]) ;; R
(values form2 foci1 foci2 description))]) ;; the threaded reductions engine
(RSadd (list (walk/foci foci1-var foci2-var f form2-var description-var))
(lambda () (R** form2-var p . more))))] ;; (R form . clauses) : (values (list-of Step) ?stx ?exn)
;; Change syntax and Step (infer foci) (define-syntax R
[(R** f p [#:walk form2 description] . more) (syntax-rules ()
(let-values ([(form2-var description-var) [(R form . clauses)
(with-syntax ([p f]) (R** #f _ [#:set-syntax form] . clauses)]))
(values form2 description))])
(RSadd (list (walk f form2-var description-var)) (define-syntax R**
(lambda () (R** form2-var p . more))))] (syntax-rules (! =>)
;; Base: done
;; Change syntax with rename [(R** form-var pattern)
[(R** f p [#:rename form2 foci1 foci2 description] . more) (RSunit form-var)]
(let-values ([(form2-var foci1-var foci2-var description-var)
(with-syntax ([p f]) ;; Base: explicit continuation
(values form2 foci1 foci2 description))]) [(R** f p => k)
(rename-frontier f form2-var) (k f)]
(with-context (make-renames foci1-var foci2-var)
(RSadd (list (walk/foci foci1-var foci2-var ;; Error-point case
f form2-var [(R** f p [! maybe-exn] . more)
description-var)) (let ([x maybe-exn])
(lambda () (R** form2-var p . more)))))] (unless (or (not x) (exn? x))
(raise-type-error 'R "exception" x))
;; Change syntax with rename (but no step) (if x
[(R** f p [#:rename/no-step pvar from to] . more) (values (list (stumble f x)) #f x)
(let-values ([(from-var to-var) (R** f p . more)))]
(with-syntax ([p f]) (values from to))])
(let ([f2 (with-syntax ([p f]) ;; Change patterns
(with-syntax ([pvar to]) [(R** f p [#:pattern p2] . more)
(syntax p)))]) (R** f p2 . more)]
(rename-frontier from-var to-var)
(with-context (make-renames from-var to-var) ;; Bind pattern variables
(R** f2 p . more))))] [(R** f p [#:bind pattern rhs] . more)
(with-syntax ([pattern (with-syntax ([p f]) rhs)])
;; Add in arbitrary other steps (R** f p . more))]
[(R** f p [#:reductions steps] . more)
(RSseq (lambda () steps) ;; Bind variables
(lambda () (R** f p . more)))] [(R** f p [#:let-values (var ...) rhs] . more)
(let-values ([(var ...) (with-syntax ([p f]) rhs)])
;; Add to definites (R** f p . more))]
[(R** f p [#:learn ids] . more)
(begin (learn-definites (with-syntax ([p f]) ids)) ;; Change syntax
(R** f p . more))] [(R** f p [#:set-syntax form] . more)
(let ([form-variable form])
;; Add to frontier (R** form-variable p . more))]
[(R** f p [#:frontier stxs] . more)
(begin (add-frontier (with-syntax ([p f]) stxs)) ;; Change syntax and Step (explicit foci)
(R** f p . more))] [(R** f p [#:walk form2 foci1 foci2 description] . more)
(let-values ([(form2-var foci1-var foci2-var description-var)
;; Conditional (pattern changes lost afterwards ...) (with-syntax ([p f])
[(R** f p [#:if/np test [consequent ...] [alternate ...]] . more) (values form2 foci1 foci2 description))])
(let ([continue (lambda (f2) (R** f2 p . more))]) (RSadd (list (walk/foci foci1-var foci2-var f form2-var description-var))
(if (with-syntax ([p f]) test) (lambda () (R** form2-var p . more))))]
(R** f p consequent ... => continue)
(R** f p alternate ... => continue)))] ;; Change syntax and Step (infer foci)
[(R** f p [#:walk form2 description] . more)
;; Conditional (pattern changes lost afterwards ...) (let-values ([(form2-var description-var)
[(R** f p [#:when/np test consequent ...] . more) (with-syntax ([p f])
(let ([continue (lambda (f2) (R** f2 p . more))]) (values form2 description))])
(if (with-syntax ([p f]) test) (RSadd (list (walk f form2-var description-var))
(R** f p consequent ... => continue) (lambda () (R** form2-var p . more))))]
(continue f)))]
;; Change syntax with rename
;; Conditional [(R** f p [#:rename form2 foci1 foci2 description] . more)
[(R** f p [#:when test consequent ...] . more) (let-values ([(form2-var foci1-var foci2-var description-var)
(with-syntax ([p f])
(values form2 foci1 foci2 description))])
(rename-frontier f form2-var)
(with-context (make-renames foci1-var foci2-var)
(RSadd (list (walk/foci foci1-var foci2-var
f form2-var
description-var))
(lambda () (R** form2-var p . more)))))]
;; Change syntax with rename (but no step)
[(R** f p [#:rename/no-step pvar from to] . more)
(let-values ([(from-var to-var)
(with-syntax ([p f]) (values from to))])
(let ([f2 (with-syntax ([p f])
(with-syntax ([pvar to])
(syntax p)))])
(rename-frontier from-var to-var)
(with-context (make-renames from-var to-var)
(R** f2 p . more))))]
;; Add in arbitrary other steps
[(R** f p [#:reductions steps] . more)
(RSseq (lambda () steps)
(lambda () (R** f p . more)))]
;; Add to definites
[(R** f p [#:learn ids] . more)
(begin (learn-definites (with-syntax ([p f]) ids))
(R** f p . more))]
;; Add to frontier
[(R** f p [#:frontier stxs] . more)
(begin (add-frontier (with-syntax ([p f]) stxs))
(R** f p . more))]
;; Conditional (pattern changes lost afterwards ...)
[(R** f p [#:if/np test [consequent ...] [alternate ...]] . more)
(let ([continue (lambda (f2) (R** f2 p . more))])
(if (with-syntax ([p f]) test) (if (with-syntax ([p f]) test)
(R** f p consequent ... . more) (R** f p consequent ... => continue)
(R** f p . more))] (R** f p alternate ... => continue)))]
;; Subterm handling ;; Conditional (pattern changes lost afterwards ...)
[(R** f p [generator hole fill] . more) [(R** f p [#:when/np test consequent ...] . more)
(let ([k (lambda (f2) (R** f2 p . more))]) (let ([continue (lambda (f2) (R** f2 p . more))])
(Run f p generator hole fill k))])) (if (with-syntax ([p f]) test)
(R** f p consequent ... => continue)
(continue f)))]
;; Conditional
[(R** f p [#:when test consequent ...] . more)
(if (with-syntax ([p f]) test)
(R** f p consequent ... . more)
(R** f p . more))]
;; Subterm handling
[(R** f p [generator hole fill] . more)
(let ([k (lambda (f2) (R** f2 p . more))])
(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)
(syntax-case stx ()
;; Implementation of subterm handling for (hole ...) sequences
[(Run* f form-var pattern (hole :::) fills k)
(and (identifier? #':::)
(module-identifier=? #'::: (quote-syntax ...)))
#'(let ([ctx (CC (hole :::) form-var pattern)])
(let ([e1s (with-syntax ([pattern form-var]) (syntax->list #'(hole :::)))])
(run-multiple f ctx fills e1s k)))]
;; Implementation of subterm handling
[(Run* f form-var pattern hole fill k)
#'(let ([ctx (CC hole form-var pattern)])
(run-one f ctx fill k))]))
;; run-multiple : (a -> RS(b)) ((list-of b) -> c) (list-of a) (list-of b) (c -> RS(d))
;; -> RS(d)
;; For example: a = Deriv; b = c = d = Syntax
(define (run-multiple f ctx fills suffix k)
(let loop ([fills fills] [prefix null] [suffix suffix])
(cond
[(pair? fills)
(RSbind (lambda ()
(with-context ctx
(with-context (lambda (x) (revappend prefix (cons x (cdr suffix))))
(f (car fills)))))
(lambda (final)
(loop (cdr fills)
(cons final prefix)
(cdr suffix))))]
[(null? fills)
(let ([form (ctx (reverse prefix))])
(k form))])))
;; run-one : (a -> RS(b)) (b -> c) (c -> RS(d)) -> RS(d)
(define (run-one f ctx fill k)
(RSbind (lambda () (with-context ctx (f fill)))
(lambda (final)
(k (ctx final)))))
;; Rename mapping
(define (rename-frontier from to) (define-syntax (Run* stx)
(current-frontier (syntax-case stx ()
(with-handlers ([exn:fail? (lambda _ #f)]) ;; Implementation of subterm handling for (hole ...) sequences
(apply append [(Run* f form-var pattern (hole :::) fills k)
(map (make-rename-mapping from to) (and (identifier? #':::)
(current-frontier)))))) (free-identifier=? #'::: (quote-syntax ...)))
#'(let ([ctx (CC (hole :::) form-var pattern)])
(define (make-rename-mapping from0 to0) (let ([e1s (with-syntax ([pattern form-var]) (syntax->list #'(hole :::)))])
(define table (make-hash-table)) (run-multiple f ctx fills e1s k)))]
(let loop ([from from0] [to to0]) ;; Implementation of subterm handling
(cond [(syntax? from) [(Run* f form-var pattern hole fill k)
(hash-table-put! table from (flatten-syntaxes to)) #'(let ([ctx (CC hole form-var pattern)])
(loop (syntax-e from) to)] (run-one f ctx fill k))]))
[(syntax? to)
(loop from (syntax-e to))]
[(pair? from)
#;(unless (pair? to)
(fprintf (current-error-port)
"from:\n~s\n\n" (syntax-object->datum from0))
(fprintf (current-error-port)
"to:\n~s\n\n" (syntax-object->datum to0))
(error 'frontier-renaming))
(loop (car from) (car to))
(loop (cdr from) (cdr to))]
[(vector? from)
(loop (vector->list from) (vector->list to))]
[(box? from)
(loop (unbox from) (unbox to))]
[else (void)]))
(lambda (stx)
(let ([replacement (hash-table-get table stx #f)])
(if replacement
(begin #;(printf " replacing ~s with ~s~n" stx replacement)
replacement)
(begin #;(printf " not replacing ~s~n" stx)
(list stx))))))
(define (flatten-syntaxes x) ;; run-multiple : (a -> RS(b)) ((list-of b) -> c) (list-of a) (list-of b) (c -> RS(d))
(cond [(syntax? x) ;; -> RS(d)
(list x)] ;; For example: a = Deriv; b = c = d = Syntax
[(pair? x) (define (run-multiple f ctx fills suffix k)
(append (flatten-syntaxes (car x)) (let loop ([fills fills] [prefix null] [suffix suffix])
(flatten-syntaxes (cdr x)))] (cond
[(vector? x) [(pair? fills)
(flatten-syntaxes (vector->list x))] (RSbind (lambda ()
[(box? x) (with-context ctx
(flatten-syntaxes (unbox x))] (with-context (lambda (x) (revappend prefix (cons x (cdr suffix))))
[else null])) (f (car fills)))))
(lambda (final)
(loop (cdr fills)
(cons final prefix)
(cdr suffix))))]
[(null? fills)
(let ([form (ctx (reverse prefix))])
(k form))])))
;; ----------------------------------- ;; run-one : (a -> RS(b)) (b -> c) (c -> RS(d)) -> RS(d)
(define (run-one f ctx fill k)
(RSbind (lambda () (with-context ctx (f fill)))
(lambda (final)
(k (ctx final)))))
;; walk : syntax(es) syntax(es) StepType -> Reduction ;; Rename mapping
;; Lifts a local step into a term step.
(define (walk e1 e2 type)
(make-step (current-derivation) (big-context) type (context)
(current-definites) (get-frontier)
(foci e1) (foci e2) e1 e2))
;; walk/foci : syntaxes syntaxes syntax syntax StepType -> Reduction
(define (walk/foci foci1 foci2 Ee1 Ee2 type)
(make-step (current-derivation) (big-context) type (context)
(current-definites) (get-frontier)
(foci foci1) (foci foci2) Ee1 Ee2))
;; walk/mono : syntax StepType -> Reduction (define (rename-frontier from to)
(define (walk/mono e1 type) (current-frontier
(make-mono (current-derivation) (big-context) type (context) (with-handlers ([exn:fail? (lambda _ #f)])
(current-definites) (get-frontier) (apply append
(foci e1) e1)) (map (make-rename-mapping from to)
(current-frontier))))))
;; stumble : syntax exception -> Reduction
(define (stumble stx exn)
(make-misstep (current-derivation) (big-context) 'error (context)
(current-definites) (get-frontier)
(foci stx) stx exn))
;; stumble/E : syntax(s) syntax exn -> Reduction
(define (stumble/E focus Ee1 exn)
(make-misstep (current-derivation) (big-context) 'error (context)
(current-definites) (get-frontier)
(foci focus) Ee1 exn))
;; ------------------------------------
(define (revappend a b)
(cond [(pair? a) (revappend (cdr a) (cons (car a) b))]
[(null? a) b]))
(define (foci x) (define (make-rename-mapping from0 to0)
(if (list? x) (define table (make-hash-table))
x (let loop ([from from0] [to to0])
(list x))) (cond [(syntax? from)
) (hash-table-put! table from (flatten-syntaxes to))
(loop (syntax-e from) to)]
[(syntax? to)
(loop from (syntax-e to))]
[(pair? from)
#;(unless (pair? to)
(fprintf (current-error-port)
"from:\n~s\n\n" (syntax->datum from0))
(fprintf (current-error-port)
"to:\n~s\n\n" (syntax->datum to0))
(error 'frontier-renaming))
(loop (car from) (car to))
(loop (cdr from) (cdr to))]
[(vector? from)
(loop (vector->list from) (vector->list to))]
[(box? from)
(loop (unbox from) (unbox to))]
[else (void)]))
(lambda (stx)
(let ([replacement (hash-table-get table stx #f)])
(if replacement
(begin #;(printf " replacing ~s with ~s~n" stx replacement)
replacement)
(begin #;(printf " not replacing ~s~n" stx)
(list stx))))))
(define (flatten-syntaxes x)
(cond [(syntax? x)
(list x)]
[(pair? x)
(append (flatten-syntaxes (car x))
(flatten-syntaxes (cdr x)))]
[(vector? x)
(flatten-syntaxes (vector->list x))]
[(box? x)
(flatten-syntaxes (unbox x))]
[else null]))
;; -----------------------------------
;; walk : syntax(es) syntax(es) StepType -> Reduction
;; Lifts a local step into a term step.
(define (walk e1 e2 type)
(make-step (current-derivation) (big-context) type (context)
(current-definites) (get-frontier)
(foci e1) (foci e2) e1 e2))
;; walk/foci : syntaxes syntaxes syntax syntax StepType -> Reduction
(define (walk/foci foci1 foci2 Ee1 Ee2 type)
(make-step (current-derivation) (big-context) type (context)
(current-definites) (get-frontier)
(foci foci1) (foci foci2) Ee1 Ee2))
;; walk/mono : syntax StepType -> Reduction
(define (walk/mono e1 type)
(make-mono (current-derivation) (big-context) type (context)
(current-definites) (get-frontier)
(foci e1) e1))
;; stumble : syntax exception -> Reduction
(define (stumble stx exn)
(make-misstep (current-derivation) (big-context) 'error (context)
(current-definites) (get-frontier)
(foci stx) stx exn))
;; stumble/E : syntax(s) syntax exn -> Reduction
(define (stumble/E focus Ee1 exn)
(make-misstep (current-derivation) (big-context) 'error (context)
(current-definites) (get-frontier)
(foci focus) Ee1 exn))
;; ------------------------------------
(define (revappend a b)
(cond [(pair? a) (revappend (cdr a) (cons (car a) b))]
[(null? a) b]))
(define (foci x)
(if (list? x)
x
(list x)))

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

File diff suppressed because it is too large Load Diff

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

@ -1,116 +1,115 @@
(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
(let ([frame0 (car ctx)]) (let ([frame0 (car ctx)])
(if (procedure? frame0) (if (procedure? frame0)
(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
(let ([frame0 (car ctx)]) (let ([frame0 (car ctx)])
(if (renames? frame0) (if (renames? frame0)
(loop (cdr ctx) (loop (cdr ctx)
(append (flatten-identifiers (renames-new frame0)) (append (flatten-identifiers (renames-new frame0))
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")
(rename-case-lambda . "Rename formal parameters") (rename-case-lambda . "Rename formal parameters")
(rename-let-values . "Rename bound variables") (rename-let-values . "Rename bound variables")
(rename-letrec-values . "Rename bound variables") (rename-letrec-values . "Rename bound variables")
(rename-lsv . "Rename bound variables") (rename-lsv . "Rename bound variables")
(lsv-remove-syntax . "Remove syntax bindings") (lsv-remove-syntax . "Remove syntax bindings")
(resolve-variable . "Resolve variable (remove extra marks)") (resolve-variable . "Resolve variable (remove extra marks)")
(tag-module-begin . "Tag #%module-begin") (tag-module-begin . "Tag #%module-begin")
(tag-app . "Tag application") (tag-app . "Tag application")
(tag-datum . "Tag datum") (tag-datum . "Tag datum")
(tag-top . "Tag top-level variable") (tag-top . "Tag top-level variable")
(capture-lifts . "Capture lifts") (capture-lifts . "Capture lifts")
(local-lift . "Macro lifted expression to top-level") (local-lift . "Macro lifted expression to top-level")
(module-lift . "Macro lifted declaration to end of module") (module-lift . "Macro lifted declaration to end of module")
(block->letrec . "Transform block to letrec") (block->letrec . "Transform block to letrec")
(splice-block . "Splice block-level begin") (splice-block . "Splice block-level begin")
(splice-module . "Splice module-level begin") (splice-module . "Splice module-level begin")
(splice-lifts . "Splice definitions from lifted expressions") (splice-lifts . "Splice definitions from lifted expressions")
(splice-module-lifts . "Splice lifted module declarations") (splice-module-lifts . "Splice lifted module declarations")
(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
rename-let-values rename-let-values
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))))
)

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

@ -1,100 +1,99 @@
(module stx-util mzscheme #lang scheme/base
(require (lib "stx.ss" "syntax")) (require (for-syntax scheme/base)
syntax/stx)
(provide (all-defined)
(all-from (lib "stx.ss" "syntax")))
(define (d->so template datum)
(if (syntax? template)
(datum->syntax-object template datum template template)
datum))
(define-syntax (syntax-copier stx)
(syntax-case stx ()
[(syntax-copier hole expr pattern)
#'(let ([expr-var expr])
(lambda (in-the-hole)
(with-syntax ([pattern expr-var])
(with-syntax ([hole in-the-hole])
(syntax/restamp pattern #'pattern expr-var)))))]))
(define-syntax syntax/skeleton
(syntax-rules ()
[(syntax/skeleton old-expr pattern)
(syntax/restamp pattern #'pattern old-expr)]))
;; FIXME: Need to avoid turning syntax lists into syntax pairs
(define-syntax (syntax/restamp stx)
(syntax-case stx (...)
[(syntax/restamp (pa (... ...)) new-expr old-expr)
#`(let ([new-parts (stx->list new-expr)]
[old-parts (stx->list old-expr)])
;; FIXME
(unless (= (length new-parts) (length old-parts))
(printf "** syntax/restamp~n~s~n" (quote-syntax #,stx))
(printf "pattern : ~s~n" (syntax-object->datum #'(pa (... ...))))
(printf "old parts: ~s~n" (map syntax-object->datum old-parts))
(printf "new parts: ~s~n" (map syntax-object->datum new-parts)))
(d->so
old-expr
(map (lambda (new old) (syntax/restamp pa new old))
new-parts
old-parts)))]
[(syntax/restamp (pa . pb) new-expr old-expr)
;; FIXME
#'(begin
(unless (and (stx-pair? new-expr) (stx-pair? old-expr))
(printf "** syntax/restamp~n~s~n" (quote-syntax #,stx))
(printf "pattern : ~s~n" (syntax-object->datum (quote-syntax (pa . pb))))
(printf "old parts: ~s~n" old-expr)
(printf "new parts: ~s~n" new-expr))
(let ([na (stx-car new-expr)]
[nb (stx-cdr new-expr)]
[oa (stx-car old-expr)]
[ob (stx-cdr old-expr)])
(d->so old-expr
(cons (syntax/restamp pa na oa)
(syntax/restamp pb nb ob)))))]
[(syntax/restamp pvar new-expr old-expr)
#'new-expr]))
(define (iota n) (provide (all-defined-out)
(let loop ([i 0]) (all-from-out syntax/stx))
(if (< i n)
(cons i (loop (add1 i)))
null)))
;; stx-take : syntax-list number -> (list-of syntax) (define (d->so template datum)
(define (stx-take items n) (if (syntax? template)
(cond [(zero? n) null] (datum->syntax template datum template template)
[else (cons (stx-car items) (stx-take (stx-cdr items) (sub1 n)))])) datum))
(define (take-if-possible items n) (define-syntax (syntax-copier stx)
(unless (number? n) (syntax-case stx ()
(raise-type-error 'take-if-possible "number" n)) [(syntax-copier hole expr pattern)
(if (and (pair? items) (positive? n)) #'(let ([expr-var expr])
(cons (car items) (take-if-possible (cdr items) (sub1 n))) (lambda (in-the-hole)
null)) (with-syntax ([pattern expr-var])
(with-syntax ([hole in-the-hole])
(syntax/restamp pattern #'pattern expr-var)))))]))
;; stx-improper-length : syntax -> number (define-syntax syntax/skeleton
(define (stx-improper-length stx) (syntax-rules ()
(let loop ([stx stx] [n 0]) [(syntax/skeleton old-expr pattern)
(if (stx-pair? stx) (syntax/restamp pattern #'pattern old-expr)]))
(loop (stx-cdr stx) (add1 n))
n)))
(define (stx->list* stx)
(cond [(pair? stx)
(cons (car stx) (stx->list* (cdr stx)))]
[(null? stx)
null]
[(syntax? stx)
(let ([x (syntax-e stx)])
(if (pair? x)
(cons (car x) (stx->list* (cdr x)))
(list stx)))]
[else null]))
) ;; FIXME: Need to avoid turning syntax lists into syntax pairs
(define-syntax (syntax/restamp stx)
(syntax-case stx (...)
[(syntax/restamp (pa (... ...)) new-expr old-expr)
#`(let ([new-parts (stx->list new-expr)]
[old-parts (stx->list old-expr)])
;; FIXME
(unless (= (length new-parts) (length old-parts))
(printf "** syntax/restamp~n~s~n" (quote-syntax #,stx))
(printf "pattern : ~s~n" (syntax->datum #'(pa (... ...))))
(printf "old parts: ~s~n" (map syntax->datum old-parts))
(printf "new parts: ~s~n" (map syntax->datum new-parts)))
(d->so
old-expr
(map (lambda (new old) (syntax/restamp pa new old))
new-parts
old-parts)))]
[(syntax/restamp (pa . pb) new-expr old-expr)
;; FIXME
#'(begin
(unless (and (stx-pair? new-expr) (stx-pair? old-expr))
(printf "** syntax/restamp~n~s~n" (quote-syntax #,stx))
(printf "pattern : ~s~n" (syntax->datum (quote-syntax (pa . pb))))
(printf "old parts: ~s~n" old-expr)
(printf "new parts: ~s~n" new-expr))
(let ([na (stx-car new-expr)]
[nb (stx-cdr new-expr)]
[oa (stx-car old-expr)]
[ob (stx-cdr old-expr)])
(d->so old-expr
(cons (syntax/restamp pa na oa)
(syntax/restamp pb nb ob)))))]
[(syntax/restamp pvar new-expr old-expr)
#'new-expr]))
(define (iota n)
(let loop ([i 0])
(if (< i n)
(cons i (loop (add1 i)))
null)))
;; stx-take : syntax-list number -> (list-of syntax)
(define (stx-take items n)
(cond [(zero? n) null]
[else (cons (stx-car items) (stx-take (stx-cdr items) (sub1 n)))]))
(define (take-if-possible items n)
(unless (number? n)
(raise-type-error 'take-if-possible "number" n))
(if (and (pair? items) (positive? n))
(cons (car items) (take-if-possible (cdr items) (sub1 n)))
null))
;; stx-improper-length : syntax -> number
(define (stx-improper-length stx)
(let loop ([stx stx] [n 0])
(if (stx-pair? stx)
(loop (stx-cdr stx) (add1 n))
n)))
(define (stx->list* stx)
(cond [(pair? stx)
(cons (car stx) (stx->list* (cdr stx)))]
[(null? stx)
null]
[(syntax? stx)
(let ([x (syntax-e stx)])
(if (pair? x)
(cons (car x) (stx->list* (cdr x)))
(list stx)))]
[else null]))

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

@ -1,37 +1,36 @@
(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") "../syntax-browser.ss")
(provide (all-defined)) (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 events null)
(define pos 0)
(define browser (make-syntax-browser))
(define (show sig+val)
(define sig (car sig+val))
(define val (cdr sig+val))
(define t (tokenize sig val pos))
(send browser add-text
(format "Signal: ~s: ~s~n"
pos
(token-name (position-token-token t))))
(when val
(send browser add-syntax
(datum->syntax #f val)))
(set! pos (add1 pos)))
(parameterize ((current-expand-observe
(lambda (sig val)
(define t (tokenize sig val pos))
(set! events (cons (cons sig val) events))
#;(show (cons sig val)))))
(expand sexpr)
(for-each show (reverse events))))
(define (go-trace sexpr)
(define events null)
(define pos 0)
(define browser (make-syntax-browser))
(define (show sig+val)
(define sig (car sig+val))
(define val (cdr sig+val))
(define t (tokenize sig val pos))
(send browser add-text
(format "Signal: ~s: ~s~n"
pos
(token-name (position-token-token t))))
(when val
(send browser add-syntax
(datum->syntax-object #f val)))
(set! pos (add1 pos)))
(parameterize ((current-expand-observe
(lambda (sig val)
(define t (tokenize sig val pos))
(set! events (cons (cons sig val) events))
#;(show (cons sig val)))))
(expand sexpr)
(for-each show (reverse events))))
)

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

@ -1,73 +1,73 @@
(module trace mzscheme #lang scheme/base
(require (lib "lex.ss" "parser-tools")) (require scheme/promise
(require "deriv.ss" parser-tools/lex
"deriv-parser.ss" "deriv.ss"
"deriv-tokens.ss") "deriv-parser.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))
(set! events (cdr events)) (set! events (cdr events))
(let* ([sig (car sig+val)] (let* ([sig (car sig+val)]
[val (cdr sig+val)] [val (cdr sig+val)]
[t (tokenize sig val pos)]) [t (tokenize sig val pos)])
(when (trace-verbose?) (when (trace-verbose?)
(printf "~s: ~s~n" pos (printf "~s: ~s~n" pos
(token-name (position-token-token t)))) (token-name (position-token-token t))))
(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)))
(parameterize ((current-expand-observe (parameterize ((current-expand-observe
(let ([c 0]) (let ([c 0])
(lambda (sig val) (lambda (sig val)
(set! c (add1 c)) (set! c (add1 c))
(add! (cons sig val)))))) (add! (cons sig val))))))
(let ([result (let ([result
(with-handlers ([(lambda (exn) #t) (with-handlers ([(lambda (exn) #t)
(lambda (exn) (lambda (exn)
(add! (cons 'error exn)) (add! (cons 'error exn))
exn)]) exn)])
(expander sexpr))]) (expander sexpr))])
(add! (cons 'EOF #f)) (add! (cons 'EOF #f))
(values result (values result
(reverse events)))))) (reverse events))))))
)

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

@ -1,50 +1,49 @@
(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
(lambda (stx)
(raise-syntax-error #f "options keyword used out of context" stx)))
(define-syntax productions
(lambda (stx)
(raise-syntax-error #f "productions keyword used out of context" stx)))
(define-syntax definitions (define-syntax options
(lambda (stx) (lambda (stx)
(raise-syntax-error #f "definitions keyword used out of context" stx))) (raise-syntax-error #f "options keyword used out of context" stx)))
(define-syntax (parser stx) (define-syntax productions
(syntax-case stx () (lambda (stx)
[(parser form ...) (raise-syntax-error #f "productions keyword used out of context" stx)))
(let ([stop-list (list #'begin #'options #'productions #'definitions)]
[forms (syntax->list #'(form ...))]) (define-syntax definitions
(define-values (opts prods defs) (lambda (stx)
(let loop ([forms forms] [opts null] [prods null] [defs null]) (raise-syntax-error #f "definitions keyword used out of context" stx)))
(if (pair? forms)
(let ([eform0 (local-expand (car forms) 'expression stop-list)] (define-syntax (parser stx)
[forms (cdr forms)]) (syntax-case stx ()
(syntax-case eform0 (begin options productions definitions) [(parser form ...)
[(begin subform ...) (let ([stop-list (list #'begin #'options #'productions #'definitions)]
(loop (append (syntax->list #'(subform ...)) forms) opts prods defs)] [forms (syntax->list #'(form ...))])
[(options subform ...) (define-values (opts prods defs)
(loop forms (append (syntax->list #'(subform ...)) opts) prods defs)] (let loop ([forms forms] [opts null] [prods null] [defs null])
[(productions subform ...) (if (pair? forms)
(loop forms opts (append (syntax->list #'(subform ...)) prods) defs)] (let ([eform0 (local-expand (car forms) 'expression stop-list)]
[(definitions subform ...) [forms (cdr forms)])
(loop forms opts prods (append (syntax->list #'(subform ...)) defs))] (syntax-case eform0 (begin options productions definitions)
[else [(begin subform ...)
(raise-syntax-error #f "bad parser subform" eform0)])) (loop (append (syntax->list #'(subform ...)) forms) opts prods defs)]
(values opts prods defs)))) [(options subform ...)
(with-syntax ([(opt ...) opts] (loop forms (append (syntax->list #'(subform ...)) opts) prods defs)]
[(prod ...) prods] [(productions subform ...)
[(def ...) defs]) (loop forms opts (append (syntax->list #'(subform ...)) prods) defs)]
#'(let () [(definitions subform ...)
def ... (loop forms opts prods (append (syntax->list #'(subform ...)) defs))]
(#%expression (yacc:parser opt ... (grammar prod ...))))))])) [else
) (raise-syntax-error #f "bad parser subform" eform0)]))
(values opts prods defs))))
(with-syntax ([(opt ...) opts]
[(prod ...) prods]
[(def ...) defs])
#'(let ()
def ...
(#%expression (yacc:parser opt ... (grammar prod ...))))))]))

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

@ -1,302 +1,302 @@
(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")
define-production-splitter (provide ! ? !!
skipped-token-values define-production-splitter
%skipped skipped-token-values
%action) %skipped
%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))]
[(pattern action) [(pattern action)
(loop (cdr forms) options (cons (cons #'pattern #'action) alts))] (loop (cdr forms) options (cons (cons #'pattern #'action) alts))]
[other [other
(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]
[(number? x) (number->string x)] [(number? x) (number->string x)]
[(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 (? ! !!)
[()
(values (reverse rtail) (reverse arguments))]
[(! . parts-rest)
(loop #'parts-rest position rtail (cons #'#f arguments))]
[(!! . parts-rest)
(raise-syntax-error 'split
"cannot have !! after potential error"
#'!!)]
[((? NT) . parts-rest)
(loop #'(NT . parts-rest) position rtail arguments)]
[(NT . parts-rest)
(identifier? #'NT)
(loop #'parts-rest
(add1 position)
(cons (skipped-name #'NT) rtail)
(cons ($name position) arguments))])))
(define arguments (append (reverse args) new-arguments))
(cons #`(#,head . #,new-tail)
(mk-action arguments)))
(define-for-syntax ((make-elaborate-successful-alternate wrap? okW) alt)
(define pattern (car alt))
(define action-function (cdr alt))
(define-values (new-patterns arguments)
(let loop ([parts pattern] [rpattern null] [position 1] [args null])
(syntax-case parts (? ! !!)
[() (values (list (reverse rpattern)) (reverse args))]
[(! . parts-rest)
(loop #'parts-rest rpattern position (cons #'#f args))]
[(!!)
(values null null)]
[((? NT) . parts-rest)
(loop (cons #'NT #'parts-rest) rpattern position args)]
[(NT . parts-rest)
(identifier? #'NT)
(loop #'parts-rest (cons #'NT rpattern)
(add1 position) (cons ($name position) args))])))
(map (lambda (new-pattern)
(cons (datum->syntax-object #f new-pattern pattern)
#`(#,action-function #,(if wrap? okW #'values) #,@arguments)))
new-patterns))
(define-for-syntax ((make-elaborate-interrupted-alternate wrap? intW) alt)
(define pattern (car alt))
(define action-function (cdr alt))
(define (int-action args)
(let ([wrapf (if wrap? #`(lambda (x) (#,intW x)) #'values)])
#`(#,action-function #,wrapf #,@args)))
(let loop ([parts pattern] [position 1] [args null])
(syntax-case parts (? ! !!) (syntax-case parts (? ! !!)
[() [()
;; Can't be interrupted (values (reverse rtail) (reverse arguments))]
null]
[(! . parts-rest) [(! . parts-rest)
(cons (loop #'parts-rest position rtail (cons #'#f arguments))]
;; Error occurs [(!! . parts-rest)
(elaborate-skipped-tail (I 'syntax-error) (raise-syntax-error 'split
#'parts-rest "cannot have !! after potential error"
(add1 position) #'!!)]
(cons ($name position) args)
int-action)
;; Error doesn't occur
(loop #'parts-rest position (cons #'#f args)))]
[(!!)
(cons
(elaborate-skipped-tail (I 'syntax-error)
#'()
(add1 position)
(cons ($name position) args)
int-action)
null)]
[((? NT) . parts-rest) [((? NT) . parts-rest)
(cons (loop #'(NT . parts-rest) position rtail arguments)]
;; NT is interrupted [(NT . parts-rest)
(elaborate-skipped-tail (I (symbol+ #'NT '/Interrupted)) (identifier? #'NT)
#'parts-rest (loop #'parts-rest
(add1 position) (add1 position)
(cons ($name position) args) (cons (skipped-name #'NT) rtail)
int-action) (cons ($name position) arguments))])))
;; NT is not interrupted (define arguments (append (reverse args) new-arguments))
(loop #'(NT . parts-rest) position args))] (cons #`(#,head . #,new-tail)
[(part0 . parts-rest) (mk-action arguments)))
(identifier? #'part0)
(map (lambda (clause) (cons #`(part0 . #,(car clause)) (cdr clause)))
(loop #'parts-rest (add1 position) (cons ($name position) args)))])))
(define-for-syntax (generate-action-name nt pos) (define-for-syntax ((make-elaborate-successful-alternate wrap? okW) alt)
(syntax-local-get-shadower (define pattern (car alt))
(datum->syntax-object #f (symbol+ 'action-for- nt '/ pos)))) (define action-function (cdr alt))
(define-values (new-patterns arguments)
(define-for-syntax ((make-rewrite-alt+def nt args-spec) alt pos) (let loop ([parts pattern] [rpattern null] [position 1] [args null])
(define pattern (car alt)) (syntax-case parts (? ! !!)
(define action (cdr alt)) [() (values (list (reverse rpattern)) (reverse args))]
(define-values (var-indexes non-var-indexes) [(! . parts-rest)
(let loop ([pattern pattern] [n 1] [vars null] [nonvars null]) (loop #'parts-rest rpattern position (cons #'#f args))]
(syntax-case pattern () [(!!)
[(first . more) (values null null)]
(syntax-case #'first (! ? !!) [((? NT) . parts-rest)
[! (loop (cons #'NT #'parts-rest) rpattern position args)]
(loop #'more (add1 n) (cons n vars) nonvars)] [(NT . parts-rest)
[(! . _) (identifier? #'NT)
(loop #'parts-rest (cons #'NT rpattern)
(add1 position) (cons ($name position) args))])))
(map (lambda (new-pattern)
(cons (datum->syntax #f new-pattern pattern)
#`(#,action-function #,(if wrap? okW #'values) #,@arguments)))
new-patterns))
(define-for-syntax ((make-elaborate-interrupted-alternate wrap? intW) alt)
(define pattern (car alt))
(define action-function (cdr alt))
(define (int-action args)
(let ([wrapf (if wrap? #`(lambda (x) (#,intW x)) #'values)])
#`(#,action-function #,wrapf #,@args)))
(let loop ([parts pattern] [position 1] [args null])
(syntax-case parts (? ! !!)
[()
;; Can't be interrupted
null]
[(! . parts-rest)
(cons
;; Error occurs
(elaborate-skipped-tail (I 'syntax-error)
#'parts-rest
(add1 position)
(cons ($name position) args)
int-action)
;; Error doesn't occur
(loop #'parts-rest position (cons #'#f args)))]
[(!!)
(cons
(elaborate-skipped-tail (I 'syntax-error)
#'()
(add1 position)
(cons ($name position) args)
int-action)
null)]
[((? NT) . parts-rest)
(cons
;; NT is interrupted
(elaborate-skipped-tail (I (symbol+ #'NT '/Interrupted))
#'parts-rest
(add1 position)
(cons ($name position) args)
int-action)
;; NT is not interrupted
(loop #'(NT . parts-rest) position args))]
[(part0 . parts-rest)
(identifier? #'part0)
(map (lambda (clause) (cons #`(part0 . #,(car clause)) (cdr clause)))
(loop #'parts-rest (add1 position) (cons ($name position) args)))])))
(define-for-syntax (generate-action-name nt pos)
(syntax-local-get-shadower
(datum->syntax #f (symbol+ 'action-for- nt '/ pos))))
(define-for-syntax ((make-rewrite-alt+def nt args-spec) alt pos)
(define pattern (car alt))
(define action (cdr alt))
(define-values (var-indexes non-var-indexes)
(let loop ([pattern pattern] [n 1] [vars null] [nonvars null])
(syntax-case pattern ()
[(first . more)
(syntax-case #'first (! ? !!)
[!
(loop #'more (add1 n) (cons n vars) nonvars)]
[(! . _)
(raise-syntax-error 'split
"misuse of ! grammar form"
pattern #'first)]
[!!
(when (pair? (syntax-e #'more))
(raise-syntax-error 'split (raise-syntax-error 'split
"misuse of ! grammar form" "nothing may follow !!"
pattern #'first)] pattern))
[!! (loop #'more (add1 n) (cons n vars) nonvars)]
(when (pair? (syntax-e #'more)) [(!! . _)
(raise-syntax-error 'split (raise-syntax-error 'split
"nothing may follow !!" "misuse of !! grammar form"
pattern)) pattern #'first)]
(loop #'more (add1 n) (cons n vars) nonvars)] [(? NT)
[(!! . _) (identifier? #'NT)
(raise-syntax-error 'split (loop #'more (add1 n) (cons n vars) nonvars)]
"misuse of !! grammar form" [(? . _)
pattern #'first)] (raise-syntax-error 'split
[(? NT) "misuse of ? grammar form"
(identifier? #'NT) pattern #'first)]
(loop #'more (add1 n) (cons n vars) nonvars)] [NT
[(? . _) (identifier? #'NT)
(raise-syntax-error 'split (loop #'more (add1 n) (cons n vars) nonvars)]
"misuse of ? grammar form" [other
pattern #'first)] (raise-syntax-error 'rewrite-pattern
[NT "invalid grammar pattern"
(identifier? #'NT) pattern #'first)])]
(loop #'more (add1 n) (cons n vars) nonvars)] [()
[other (values (reverse vars) (reverse nonvars))])))
(raise-syntax-error 'rewrite-pattern (define variables (map $name var-indexes))
"invalid grammar pattern" (define non-var-names (map $name non-var-indexes))
pattern #'first)])] (define action-function (generate-action-name nt pos))
[() (cons (cons pattern action-function)
(values (reverse vars) (reverse nonvars))]))) (with-syntax ([(var ...) variables]
(define variables (map $name var-indexes)) [(nonvar ...) non-var-names]
(define non-var-names (map $name non-var-indexes)) [action-function action-function]
(define action-function (generate-action-name nt pos)) [action action])
(cons (cons pattern action-function) #`(define (action-function wrap var ...)
(with-syntax ([(var ...) variables] (let-syntax ([nonvar invalid-$name-use] ...)
[(nonvar ...) non-var-names] #,(if args-spec
[action-function action-function] #`(lambda #,args-spec (wrap action))
[action action]) #`(wrap action)))))))
#`(define (action-function wrap var ...)
(let-syntax ([nonvar invalid-$name-use] ...)
#,(if args-spec
#`(lambda #,args-spec (wrap action))
#`(wrap action)))))))
(define-for-syntax (invalid-$name-use stx) (define-for-syntax (invalid-$name-use stx)
(raise-syntax-error #f "no value for positional variable" stx)) (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)))
(define alternates (map car alternates+definitions)) (define alternates (map car alternates+definitions))
(define action-definitions (map cdr alternates+definitions)) (define action-definitions (map cdr alternates+definitions))
(define elaborate-successful-alternate (define elaborate-successful-alternate
(make-elaborate-successful-alternate wrap? okW)) (make-elaborate-successful-alternate wrap? okW))
(define elaborate-interrupted-alternate (define elaborate-interrupted-alternate
(make-elaborate-interrupted-alternate wrap? intW)) (make-elaborate-interrupted-alternate wrap? intW))
(define successful-alternates (define successful-alternates
(apply append (map elaborate-successful-alternate alternates))) (apply append (map elaborate-successful-alternate alternates)))
(define interrupted-alternates (define interrupted-alternates
(apply append (map elaborate-interrupted-alternate alternates))) (apply append (map elaborate-interrupted-alternate alternates)))
(with-syntax ([((success-pattern . success-action) ...) (with-syntax ([((success-pattern . success-action) ...)
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)])
#`(begin #`(begin
(definitions #,@action-definitions) (definitions #,@action-definitions)
(productions (productions
(name [success-pattern success-action] ...) (name [success-pattern success-action] ...)
#,(if (pair? interrupted-alternates) #,(if (pair? interrupted-alternates)
#'(name/Interrupted [interrupted-pattern interrupted-action] #'(name/Interrupted [interrupted-pattern interrupted-action]
...) ...)
#'(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)]
[(skipped-token-values name . more) [(skipped-token-values name . more)
(identifier? #'name) (identifier? #'name)
(with-syntax ([name/Skipped (I (symbol+ #'name '/Skipped))]) (with-syntax ([name/Skipped (I (symbol+ #'name '/Skipped))])
#'(begin (productions (name/Skipped [() #f])) #'(begin (productions (name/Skipped [() #f]))
(skipped-token-values . more)))] (skipped-token-values . more)))]
[(skipped-token-values (name value) . more) [(skipped-token-values (name value) . more)
(with-syntax ([name/Skipped (I (symbol+ #'name '/Skipped))]) (with-syntax ([name/Skipped (I (symbol+ #'name '/Skipped))])
#'(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]))
)

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

@ -1,140 +1,139 @@
(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"
"model/hide.ss" "model/hide.ss"
"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
[(stx) (internal-stepper stx #f)]
[(stx show) (internal-stepper stx (->show-function show))]))
;; internal procedures
(define (internal-stepper stx show?)
(define steps (get-steps stx show?))
(define used-steps null)
(define partition (new-bound-partition))
(define dispatch
(case-lambda (case-lambda
[(stx) (internal-stepper stx #f)] [() (dispatch 'next)]
[(stx show) (internal-stepper stx (->show-function show))])) [(sym)
(case sym
;; internal procedures ((next)
(if (pair? steps)
(begin (show-step (car steps) partition)
(set! used-steps (cons (car steps) used-steps))
(set! steps (cdr steps)))
#f))
((prev)
(if (pair? used-steps)
(begin (show-step (car used-steps) partition)
(set! steps (cons (car used-steps) steps))
(set! used-steps (cdr used-steps)))
#f))
((all)
(when (pair? steps)
(dispatch 'next)
(dispatch 'all))))]))
dispatch)
(define (internal-stepper stx show?) (define (get-steps stx show?)
(define steps (get-steps stx show?)) (define deriv (trace stx))
(define used-steps null) (define hderiv
(define partition (new-bound-partition)) (if show? (hide/policy deriv show?) deriv))
(define dispatch (define (ok? x)
(case-lambda (or (rewrite-step? x) (misstep? x)))
[() (dispatch 'next)] (filter ok? (reductions hderiv)))
[(sym)
(case sym
((next)
(if (pair? steps)
(begin (show-step (car steps) partition)
(set! used-steps (cons (car steps) used-steps))
(set! steps (cdr steps)))
#f))
((prev)
(if (pair? used-steps)
(begin (show-step (car used-steps) partition)
(set! steps (cons (car used-steps) steps))
(set! used-steps (cdr used-steps)))
#f))
((all)
(when (pair? steps)
(dispatch 'next)
(dispatch 'all))))]))
dispatch)
(define (get-steps stx show?)
(define deriv (trace stx))
(define hderiv
(if show? (hide/policy deriv show?) deriv))
(define (ok? x)
(or (rewrite-step? x) (misstep? x)))
(filter ok? (reductions hderiv)))
(define (show-step step partition)
(cond [(step? step)
(display (step-type->string (protostep-type step)))
(newline)
(show-term (step-term1 step) partition)
(display " ==>")
(newline)
(show-term (step-term2 step) partition)
(newline)]
[(misstep? step)
(display (exn-message (misstep-exn step)))
(newline)
(show-term (misstep-term1 step) partition)]))
(define (show-term stx partition)
(define-values (datum flat=>stx stx=>flat)
(table stx partition 0 'always))
(define identifier-list
(filter identifier? (hash-table-map stx=>flat (lambda (k v) k))))
(define (pp-size-hook obj display-like? port)
(cond [(syntax-dummy? obj)
(let ((ostring (open-output-string)))
((if display-like? display write)
(syntax-dummy-val obj)
ostring)
(string-length (get-output-string ostring)))]
[else #f]))
(define (pp-print-hook obj display-like? port)
(cond [(syntax-dummy? obj)
((if display-like? display write) (syntax-dummy-val obj) port)]
[else
(error 'pretty-print-hook "unexpected special value: ~e" obj)]))
(define (pp-extend-style-table)
(let* ([ids identifier-list]
[syms (map (lambda (x) (hash-table-get stx=>flat x)) ids)]
[like-syms (map syntax-e ids)])
(pretty-print-extend-style-table (pp-better-style-table)
syms
like-syms)))
(define (pp-better-style-table)
(pretty-print-extend-style-table (pretty-print-current-style-table)
(map car extended-style-list)
(map cdr extended-style-list)))
(parameterize
([pretty-print-size-hook pp-size-hook]
[pretty-print-print-hook pp-print-hook]
[pretty-print-current-style-table (pp-extend-style-table)]
;; Printing parameters (mzscheme manual 7.9.1.4)
[print-unreadable #t]
[print-graph #f]
[print-struct #f]
[print-box #t]
[print-vector-length #t]
[print-hash-table #f]
[print-honu #f])
(pretty-print datum)))
(define (->show-function show)
(cond [(procedure? show)
show]
[(list? show)
(lambda (id)
(ormap (lambda (x) (module-identifier=? x id))
show))]
[(hiding-policy? show)
(lambda (x) (policy-show-macro? show x))]
[(eq? show #f)
#f]
[else
(error 'expand/trace-text
"expected procedure or list of identifiers for macros to show; got: ~e"
show)]))
(define extended-style-list (define (show-step step partition)
'((define-values . define) (cond [(step? step)
(define-syntaxes . define-syntax))) (display (step-type->string (protostep-type step)))
) (newline)
(show-term (step-term1 step) partition)
(display " ==>")
(newline)
(show-term (step-term2 step) partition)
(newline)]
[(misstep? step)
(display (exn-message (misstep-exn step)))
(newline)
(show-term (misstep-term1 step) partition)]))
(define (show-term stx partition)
(define-values (datum flat=>stx stx=>flat)
(table stx partition 0 'always))
(define identifier-list
(filter identifier? (hash-table-map stx=>flat (lambda (k v) k))))
(define (pp-size-hook obj display-like? port)
(cond [(syntax-dummy? obj)
(let ((ostring (open-output-string)))
((if display-like? display write)
(syntax-dummy-val obj)
ostring)
(string-length (get-output-string ostring)))]
[else #f]))
(define (pp-print-hook obj display-like? port)
(cond [(syntax-dummy? obj)
((if display-like? display write) (syntax-dummy-val obj) port)]
[else
(error 'pretty-print-hook "unexpected special value: ~e" obj)]))
(define (pp-extend-style-table)
(let* ([ids identifier-list]
[syms (map (lambda (x) (hash-table-get stx=>flat x)) ids)]
[like-syms (map syntax-e ids)])
(pretty-print-extend-style-table (pp-better-style-table)
syms
like-syms)))
(define (pp-better-style-table)
(pretty-print-extend-style-table (pretty-print-current-style-table)
(map car extended-style-list)
(map cdr extended-style-list)))
(parameterize
([pretty-print-size-hook pp-size-hook]
[pretty-print-print-hook pp-print-hook]
[pretty-print-current-style-table (pp-extend-style-table)]
;; Printing parameters (mzscheme manual 7.9.1.4)
[print-unreadable #t]
[print-graph #f]
[print-struct #f]
[print-box #t]
[print-vector-length #t]
[print-hash-table #f]
[print-honu #f])
(pretty-print datum)))
(define (->show-function show)
(cond [(procedure? show)
show]
[(list? show)
(lambda (id)
(ormap (lambda (x) (free-identifier=? x id))
show))]
[(hiding-policy? show)
(lambda (x) (policy-show-macro? show x))]
[(eq? show #f)
#f]
[else
(error 'expand/trace-text
"expected procedure or list of identifiers for macros to show; got: ~e"
show)]))
(define extended-style-list
'((define-values . define)
(define-syntaxes . define-syntax)))

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

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

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

@ -1,76 +1,75 @@
(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])
;; add-syntax-display : display<%> -> void ;; add-syntax-display : display<%> -> void
(define/public (add-syntax-display c) (define/public (add-syntax-display c)
(set! displays (cons c displays))) (set! displays (cons c displays)))
;; remove-all-syntax-displays : -> void ;; remove-all-syntax-displays : -> void
(define/public (remove-all-syntax-displays) (define/public (remove-all-syntax-displays)
(set! displays null)) (set! displays null))
(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)))
(super-new) (super-new)
(listen-selected-syntax (listen-selected-syntax
(lambda (new-value) (lambda (new-value)
(for-each (lambda (display) (send display refresh)) (for-each (lambda (display) (send display refresh))
displays))))) displays)))))
;; mark-manager-mixin
(define mark-manager-mixin
(mixin () (mark-manager<%>)
(init-field [primary-partition (new-bound-partition)])
(super-new)
;; get-primary-partition : -> partition ;; mark-manager-mixin
(define/public-final (get-primary-partition) (define mark-manager-mixin
primary-partition) (mixin () (mark-manager<%>)
(init-field [primary-partition (new-bound-partition)])
(super-new)
;; reset-primary-partition : -> void ;; get-primary-partition : -> partition
(define/public-final (reset-primary-partition) (define/public-final (get-primary-partition)
(set! primary-partition (new-bound-partition))))) primary-partition)
;; secondary-partition-mixin ;; reset-primary-partition : -> void
(define secondary-partition-mixin (define/public-final (reset-primary-partition)
(mixin (displays-manager<%>) (secondary-partition<%>) (set! primary-partition (new-bound-partition)))))
(inherit-field displays)
(field/notify identifier=? (new notify-box% (value #f)))
(field/notify secondary-partition (new notify-box% (value #f)))
(listen-identifier=? ;; secondary-partition-mixin
(lambda (name+proc) (define secondary-partition-mixin
(set-secondary-partition (mixin (displays-manager<%>) (secondary-partition<%>)
(and name+proc (inherit-field displays)
(new partition% (relation (cdr name+proc))))))) (field/notify identifier=? (new notify-box% (value #f)))
(listen-secondary-partition (field/notify secondary-partition (new notify-box% (value #f)))
(lambda (p)
(for-each (lambda (d) (send d refresh))
displays)))
(super-new)))
(define controller% (listen-identifier=?
(class (secondary-partition-mixin (lambda (name+proc)
(selection-manager-mixin (set-secondary-partition
(mark-manager-mixin (and name+proc
(displays-manager-mixin (new partition% (relation (cdr name+proc)))))))
object%)))) (listen-secondary-partition
(super-new))) (lambda (p)
) (for-each (lambda (d) (send d refresh))
displays)))
(super-new)))
(define controller%
(class (secondary-partition-mixin
(selection-manager-mixin
(mark-manager-mixin
(displays-manager-mixin
object%))))
(super-new)))

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

@ -1,251 +1,250 @@
(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)
(init-field controller) (init-field controller)
(define start-anchor (new anchor-snip%)) (define start-anchor (new anchor-snip%))
(define end-anchor (new anchor-snip%)) (define end-anchor (new anchor-snip%))
(define range #f) (define range #f)
(define extra-styles (make-hash-table)) (define extra-styles (make-hash-table))
;; render-syntax : syntax -> void ;; render-syntax : syntax -> void
(define/public (render-syntax stx) (define/public (render-syntax stx)
(with-unlock text (with-unlock text
(send text delete (get-start-position) (get-end-position)) (send text delete (get-start-position) (get-end-position))
(set! range (set! range
(print-syntax stx text controller (print-syntax stx text controller
(lambda () (get-start-position)) (lambda () (get-start-position))
(lambda () (get-end-position)))) (lambda () (get-end-position))))
(apply-primary-partition-styles)) (apply-primary-partition-styles))
(refresh)) (refresh))
;; refresh : -> void ;; refresh : -> void
;; Clears all highlighting and reapplies all non-foreground styles. ;; Clears all highlighting and reapplies all non-foreground styles.
(define/public (refresh) (define/public (refresh)
(with-unlock text (with-unlock text
(send* text (send* text
(begin-edit-sequence) (begin-edit-sequence)
(change-style unhighlight-d (get-start-position) (get-end-position))) (change-style unhighlight-d (get-start-position) (get-end-position)))
(apply-extra-styles) (apply-extra-styles)
(let ([selected-syntax (send controller get-selected-syntax)]) (let ([selected-syntax (send controller get-selected-syntax)])
(apply-secondary-partition-styles selected-syntax) (apply-secondary-partition-styles selected-syntax)
(apply-selection-styles selected-syntax)) (apply-selection-styles selected-syntax))
(send* text (send* text
(end-edit-sequence)))) (end-edit-sequence))))
;; cached-start-position : number ;; cached-start-position : number
(define cached-start-position #f) (define cached-start-position #f)
;; get-start-position : -> number ;; get-start-position : -> number
(define/public-final (get-start-position) (define/public-final (get-start-position)
(unless cached-start-position (unless cached-start-position
(set! cached-start-position (send text get-snip-position start-anchor))) (set! cached-start-position (send text get-snip-position start-anchor)))
cached-start-position) cached-start-position)
;; get-end-position : -> number ;; get-end-position : -> number
(define/public-final (get-end-position) (define/public-final (get-end-position)
(send text get-snip-position end-anchor)) (send text get-snip-position end-anchor))
;; relative->text-position : number -> number ;; relative->text-position : number -> number
;; FIXME: might be slow to find start every time! ;; FIXME: might be slow to find start every time!
(define/public-final (relative->text-position pos) (define/public-final (relative->text-position pos)
(+ pos (get-start-position))) (+ pos (get-start-position)))
;; Styling ;; Styling
;; get-range : -> range<%> ;; get-range : -> range<%>
(define/public (get-range) range) (define/public (get-range) range)
;; highlight-syntaxes : (list-of syntax) string -> void ;; highlight-syntaxes : (list-of syntax) string -> void
(define/public (highlight-syntaxes stxs hi-color) (define/public (highlight-syntaxes stxs hi-color)
(let ([style-delta (highlight-style-delta hi-color #f)]) (let ([style-delta (highlight-style-delta hi-color #f)])
(for-each (lambda (stx) (hash-table-put! extra-styles stx style-delta)) (for-each (lambda (stx) (hash-table-put! extra-styles stx style-delta))
stxs)) stxs))
(refresh)) (refresh))
;; apply-extra-styles : -> void ;; apply-extra-styles : -> void
;; Applies externally-added styles (such as highlighting) ;; Applies externally-added styles (such as highlighting)
(define/private (apply-extra-styles) (define/private (apply-extra-styles)
(hash-table-for-each (hash-table-for-each
extra-styles extra-styles
(lambda (hi-stx style-delta) (lambda (hi-stx style-delta)
(let ([rs (send range get-ranges hi-stx)]) (let ([rs (send range get-ranges hi-stx)])
(for-each (lambda (r) (restyle-range r style-delta)) rs))))) (for-each (lambda (r) (restyle-range r style-delta)) rs)))))
;; apply-secondary-partition-styles : selected-syntax -> void ;; apply-secondary-partition-styles : selected-syntax -> void
;; If the selected syntax is an identifier, then styles all identifiers ;; If the selected syntax is an identifier, then styles all identifiers
;; in the same partition in blue. ;; in the same partition in blue.
(define/private (apply-secondary-partition-styles selected-syntax) (define/private (apply-secondary-partition-styles selected-syntax)
(when (identifier? selected-syntax) (when (identifier? selected-syntax)
(let ([partition (send controller get-secondary-partition)]) (let ([partition (send controller get-secondary-partition)])
(when partition (when partition
(for-each (lambda (id) (for-each (lambda (id)
(when (send partition same-partition? selected-syntax id) (when (send partition same-partition? selected-syntax id)
(draw-secondary-connection id))) (draw-secondary-connection id)))
(send range get-identifier-list)))))) (send range get-identifier-list))))))
;; apply-selection-styles : syntax -> void ;; apply-selection-styles : syntax -> void
;; Styles subterms eq to the selected syntax ;; Styles subterms eq to the selected syntax
(define/private (apply-selection-styles selected-syntax) (define/private (apply-selection-styles selected-syntax)
(let ([rs (send range get-ranges selected-syntax)]) (let ([rs (send range get-ranges selected-syntax)])
(for-each (lambda (r) (restyle-range r select-highlight-d)) rs))) (for-each (lambda (r) (restyle-range r select-highlight-d)) rs)))
;; draw-secondary-connection : syntax -> void ;; draw-secondary-connection : syntax -> void
(define/private (draw-secondary-connection stx2) (define/private (draw-secondary-connection stx2)
(let ([rs (send range get-ranges stx2)]) (let ([rs (send range get-ranges stx2)])
(for-each (lambda (r) (restyle-range r select-sub-highlight-d)) rs))) (for-each (lambda (r) (restyle-range r select-sub-highlight-d)) rs)))
;; restyle-range : (cons num num) style-delta% -> void ;; restyle-range : (cons num num) style-delta% -> void
(define/private (restyle-range r style) (define/private (restyle-range r style)
(send text change-style style (send text change-style style
(relative->text-position (car r)) (relative->text-position (car r))
(relative->text-position (cdr r)))) (relative->text-position (cdr r))))
;; Primary styles ;; Primary styles
;; apply-primary-partition-styles : -> void ;; apply-primary-partition-styles : -> void
;; Changes the foreground color according to the primary partition. ;; Changes the foreground color according to the primary partition.
;; Only called once, when the syntax is first drawn. ;; Only called once, when the syntax is first drawn.
(define/private (apply-primary-partition-styles) (define/private (apply-primary-partition-styles)
(define (color-style color) (define (color-style color)
(let ([delta (new style-delta%)]) (let ([delta (new style-delta%)])
(send delta set-delta-foreground color) (send delta set-delta-foreground color)
delta)) delta))
(define color-styles (list->vector (map color-style (current-colors)))) (define color-styles (list->vector (map color-style (current-colors))))
(define overflow-style (color-style "darkgray")) (define overflow-style (color-style "darkgray"))
(define color-partition (send controller get-primary-partition)) (define color-partition (send controller get-primary-partition))
(define offset (get-start-position)) (define offset (get-start-position))
(for-each (for-each
(lambda (range) (lambda (range)
(let ([stx (range-obj range)] (let ([stx (range-obj range)]
[start (range-start range)] [start (range-start range)]
[end (range-end range)]) [end (range-end range)])
(send text change-style (send text change-style
(primary-style stx color-partition color-styles overflow-style) (primary-style stx color-partition color-styles overflow-style)
(+ offset start) (+ offset start)
(+ offset end)))) (+ offset end))))
(send range all-ranges))) (send range all-ranges)))
;; primary-style : syntax partition (vector-of style-delta%) style-delta% ;; primary-style : syntax partition (vector-of style-delta%) style-delta%
;; -> style-delta% ;; -> style-delta%
(define/private (primary-style stx partition color-vector overflow) (define/private (primary-style stx partition color-vector overflow)
(let ([n (send partition get-partition stx)]) (let ([n (send partition get-partition stx)])
(cond [(< n (vector-length color-vector)) (cond [(< n (vector-length color-vector))
(vector-ref color-vector n)] (vector-ref color-vector n)]
[else [else
overflow]))) overflow])))
;; Initialize ;; Initialize
(super-new) (super-new)
(send text insert start-anchor) (send text insert start-anchor)
(send text insert end-anchor) (send text insert end-anchor)
(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))
(define output-port (open-output-string)) (define output-port (open-output-string))
(port-count-lines! output-port) (port-count-lines! output-port)
(let ([range (pretty-print-syntax stx output-port primary-partition)]) (let ([range (pretty-print-syntax stx output-port primary-partition)])
(write-string (get-output-string output-port) real-output-port) (write-string (get-output-string output-port) real-output-port)
(let ([end (get-end-position)]) (let ([end (get-end-position)])
;; Pretty printer always inserts final newline; we remove it here. ;; Pretty printer always inserts final newline; we remove it here.
(send text delete (sub1 end) end)) (send text delete (sub1 end) end))
;; Set font to standard ;; Set font to standard
(send text change-style (send text change-style
(code-style text) (code-style text)
(get-start-position) (get-start-position)
(get-end-position)) (get-end-position))
(let ([offset (get-start-position)]) (let ([offset (get-start-position)])
(fixup-parentheses text range offset) (fixup-parentheses text range offset)
(for-each (for-each
(lambda (range) (lambda (range)
(let* ([stx (range-obj range)] (let* ([stx (range-obj range)]
[start (range-start range)] [start (range-start range)]
[end (range-end range)]) [end (range-end range)])
(send text set-clickback (+ offset start) (+ offset end) (send text set-clickback (+ offset start) (+ offset end)
(lambda (_1 _2 _3) (lambda (_1 _2 _3)
(send controller set-selected-syntax stx))))) (send controller set-selected-syntax stx)))))
(send range all-ranges)) (send range all-ranges))
range))) 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))]
[end (+ offset (range-end r))]) [end (+ offset (range-end r))])
(when (and (syntax? stx) (pair? (syntax-e stx))) (when (and (syntax? stx) (pair? (syntax-e stx)))
(case (syntax-property stx 'paren-shape) (case (syntax-property stx 'paren-shape)
((#\[) ((#\[)
(replace start #\[) (replace start #\[)
(replace (sub1 end) #\])) (replace (sub1 end) #\]))
((#\{) ((#\{)
(replace start #\{) (replace start #\{)
(replace (sub1 end) #\})))))) (replace (sub1 end) #\}))))))
(define (replace pos char) (define (replace pos char)
(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)])
(if font-size (if font-size
(send style-list find-or-create-style (send style-list find-or-create-style
style style
(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))
(unless em? (send sd set-underlined-off #t) (unless em? (send sd set-underlined-off #t)
(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))
)

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

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

@ -1,96 +1,94 @@
(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")
(width (send config pref:width)) (width (send config pref:width))
(height (send config pref:height))) (height (send config pref:height)))
(define widget (define widget
(new syntax-widget/controls% (new syntax-widget/controls%
(parent this) (parent this)
(config config))) (config config)))
(define/public (get-widget) widget) (define/public (get-widget) widget)
(define/augment (on-close) (define/augment (on-close)
(send config pref:width (send this get-width)) (send config pref:width (send this get-width))
(send config pref:height (send this get-height)) (send config pref:height (send this get-height))
(send widget shutdown) (send widget shutdown)
(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
toggle-props) toggle-props)
(super-new) (super-new)
(inherit-field config) (inherit-field config)
(define -control-panel (define -control-panel
(new horizontal-pane% (new horizontal-pane%
(parent (get-main-panel)) (parent (get-main-panel))
(stretchable-height #f))) (stretchable-height #f)))
;; Put the control panel up front ;; Put the control panel up front
(send (get-main-panel) change-children (send (get-main-panel) change-children
(lambda (children) (lambda (children)
(cons -control-panel (remq -control-panel children)))) (cons -control-panel (remq -control-panel children))))
(define -identifier=-choices (identifier=-choices)) (define -identifier=-choices (identifier=-choices))
(define -choice (define -choice
(new choice% (label "identifer=?") (parent -control-panel) (new choice% (label "identifer=?") (parent -control-panel)
(choices (map car -identifier=-choices)) (choices (map car -identifier=-choices))
(callback (callback
(lambda (c e) (lambda (c e)
(send (get-controller) set-identifier=? (send (get-controller) set-identifier=?
(assoc (send c get-string-selection) (assoc (send c get-string-selection)
-identifier=-choices)))))) -identifier=-choices))))))
(new button% (new button%
(label "Clear") (label "Clear")
(parent -control-panel) (parent -control-panel)
(callback (lambda _ (send (get-controller) select-syntax #f)))) (callback (lambda _ (send (get-controller) select-syntax #f))))
(new button% (new button%
(label "Properties") (label "Properties")
(parent -control-panel) (parent -control-panel)
(callback (lambda _ (toggle-props)))) (callback (lambda _ (toggle-props))))
(send (get-controller) listen-identifier=? (send (get-controller) listen-identifier=?
(lambda (name+func) (lambda (name+func)
(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))))
)) ))
)

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

@ -1,57 +1,57 @@
(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%)
(class snip%
(inherit get-admin)
(define/override (get-extent dc x y bw bh bdescent bspace blspace brspace)
(let-values [((h) (get-xheight dc))
((fw fh) (send dc get-size))]
(let ([ad-x (box 0)]
[ad-y (box 0)])
(send (get-admin) get-view-size ad-x ad-y)
#;(set-box?! bw fw)
(set-box?! bw (max 0 (- (unbox ad-x) (get-xheight dc))))
(set-box?! bh h))))
(define/override (draw dc x y left top right bottom dx dy draw-caret)
(let* [(xh (get-xheight dc))
(ny (+ y (/ xh 2)))]
(send dc draw-line x ny right ny)))
(define/private (set-box?! b v)
(when (box? b) (set-box! b v)))
(define/private (get-xheight dc)
(or cached-xheight
(let-values [((w h descent extra) (send dc get-text-extent "x"))]
(set! cached-xheight h)
h)))
(define cached-xheight #f)
;; Snip methods ;; hrule-snip%
(define/override (copy) ;; A snip for drawing horizontal separating lines.
(new hrule-snip%)) (define hrule-snip%
(define/override (write stream) (class snip%
(void)) (inherit get-admin)
(inherit set-snipclass) (define/override (get-extent dc x y bw bh bdescent bspace blspace brspace)
(super-new) (let-values [((h) (get-xheight dc))
((fw fh) (send dc get-size))]
(let ([ad-x (box 0)]
[ad-y (box 0)])
(send (get-admin) get-view-size ad-x ad-y)
#;(set-box?! bw fw)
(set-box?! bw (max 0 (- (unbox ad-x) (get-xheight dc))))
(set-box?! bh h))))
(define/override (draw dc x y left top right bottom dx dy draw-caret)
(let* [(xh (get-xheight dc))
(ny (+ y (/ xh 2)))]
(send dc draw-line x ny right ny)))
(define/private (set-box?! b v)
(when (box? b) (set-box! b v)))
(define/private (get-xheight dc)
(or cached-xheight
(let-values [((w h descent extra) (send dc get-text-extent "x"))]
(set! cached-xheight h)
h)))
(define cached-xheight #f)
(set-snipclass snip-class))) ;; Snip methods
(define/override (copy)
(new hrule-snip%))
(define/override (write stream)
(void))
(inherit set-snipclass)
(super-new)
(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)
)

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

@ -1,167 +1,165 @@
(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
;; 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
get-selected-syntax get-selected-syntax
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
;; set-secondary-partition : partition<%> -> void ;; set-secondary-partition : partition<%> -> void
set-secondary-partition set-secondary-partition
;; listen-secondary-partition : (partition<%> -> void) -> void ;; listen-secondary-partition : (partition<%> -> void) -> void
listen-secondary-partition listen-secondary-partition
;; get-identifier=? : -> (cons string procedure) ;; get-identifier=? : -> (cons string procedure)
get-identifier=? get-identifier=?
;; set-identifier=? : (cons string procedure) -> void ;; set-identifier=? : (cons string procedure) -> void
set-identifier=? set-identifier=?
;; 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
;; add-keymap : text snip ;; add-keymap : text snip
add-keymap add-keymap
)) ))
;; display<%> ;; display<%>
(define display<%> (define display<%>
(interface () (interface ()
;; refresh : -> void ;; refresh : -> void
refresh refresh
;; highlight-syntaxes : (list-of syntax) color -> void ;; highlight-syntaxes : (list-of syntax) color -> void
highlight-syntaxes highlight-syntaxes
;; get-start-position : -> number ;; get-start-position : -> number
get-start-position get-start-position
;; get-end-position : -> number ;; get-end-position : -> number
get-end-position get-end-position
;; 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
;; all-ranges : (list-of Range) ;; all-ranges : (list-of Range)
;; Sorted outermost-first ;; Sorted outermost-first
all-ranges all-ranges
;; 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
;; shutdown : -> void ;; shutdown : -> void
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
;; 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
add-selection-items add-selection-items
after-selection-items after-selection-items
add-partition-items add-partition-items
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
add-separator add-separator
erase-all erase-all
select-syntax select-syntax
get-text get-text
)) ))
(define partition<%> (define partition<%>
(interface () (interface ()
;; get-partition : any -> number ;; get-partition : any -> number
get-partition get-partition
;; same-partition? : any any -> number ;; same-partition? : any any -> number
same-partition? same-partition?
;; count : -> number ;; count : -> number
count)) count))
)

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

@ -1,152 +1,150 @@
(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)
(inherit add-function (inherit add-function
map-function map-function
chain-to-keymap) chain-to-keymap)
(super-new) (super-new)
(define/public (get-context-menu%) (define/public (get-context-menu%)
context-menu%) context-menu%)
(define/public (make-context-menu) (define/public (make-context-menu)
(new (get-context-menu%) (controller controller) (keymap this))) (new (get-context-menu%) (controller controller) (keymap this)))
;; Key mappings ;; Key mappings
(map-function "rightbutton" "popup-context-window") (map-function "rightbutton" "popup-context-window")
;; Functionality ;; Functionality
(add-function "popup-context-window" (add-function "popup-context-window"
(lambda (editor event) (lambda (editor event)
(do-popup-context-window editor event))) (do-popup-context-window editor event)))
(add-function "copy-text" (add-function "copy-text"
(lambda (_ event) (lambda (_ event)
(define stx (send controller get-selected-syntax)) (define stx (send controller get-selected-syntax))
(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))))
(add-function "clear-syntax-selection" (add-function "clear-syntax-selection"
(lambda (i e) (lambda (i e)
(send controller set-selected-syntax #f))) (send controller set-selected-syntax #f)))
(add-function "show-syntax-properties" (add-function "show-syntax-properties"
(lambda (i e) (lambda (i e)
(error 'show-syntax-properties "not provided by this keymap"))) (error 'show-syntax-properties "not provided by this keymap")))
;; Attach to editor ;; Attach to editor
(chain-to-keymap (send editor get-keymap) #t) (chain-to-keymap (send editor get-keymap) #t)
(send editor set-keymap this) (send editor set-keymap this)
(define/public (get-controller) controller) (define/public (get-controller) controller)
(define/private (do-popup-context-window editor event) (define/private (do-popup-context-window editor event)
(define-values (x y) (define-values (x y)
(send editor dc-location-to-editor-location (send editor dc-location-to-editor-location
(send event get-x) (send event get-x)
(send event get-y))) (send event get-y)))
(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)
(super-new) (super-new)
(field [copy-menu #f] (field [copy-menu #f]
[clear-menu #f] [clear-menu #f]
[props-menu #f]) [props-menu #f])
(define/public (add-edit-items) (define/public (add-edit-items)
(set! copy-menu (set! copy-menu
(new menu-item% (label "Copy") (parent this) (new menu-item% (label "Copy") (parent this)
(callback (lambda (i e) (callback (lambda (i e)
(send keymap call-function "copy-text" i e))))) (send keymap call-function "copy-text" i e)))))
(void)) (void))
(define/public (after-edit-items) (define/public (after-edit-items)
(void)) (void))
(define/public (add-selection-items) (define/public (add-selection-items)
(set! clear-menu (set! clear-menu
(new menu-item% (new menu-item%
(label "Clear selection") (label "Clear selection")
(parent this) (parent this)
(callback (callback
(lambda (i e) (lambda (i e)
(send keymap call-function "clear-syntax-selection" i e))))) (send keymap call-function "clear-syntax-selection" i e)))))
(set! props-menu (set! props-menu
(new menu-item% (new menu-item%
(label "Show syntax properties") (label "Show syntax properties")
(parent this) (parent this)
(callback (callback
(lambda (i e) (lambda (i e)
(send keymap call-function "show-syntax-properties" i e))))) (send keymap call-function "show-syntax-properties" i e)))))
(void)) (void))
(define/public (after-selection-items) (define/public (after-selection-items)
(void)) (void))
(define/public (add-partition-items) (define/public (add-partition-items)
(let ([secondary (new menu% (label "identifier=?") (parent this))]) (let ([secondary (new menu% (label "identifier=?") (parent this))])
(for-each (for-each
(lambda (name func) (lambda (name func)
(let ([this-choice (let ([this-choice
(new checkable-menu-item% (new checkable-menu-item%
(label name) (label name)
(parent secondary) (parent secondary)
(callback (callback
(lambda (i e) (lambda (i e)
(send controller set-identifier=? (send controller set-identifier=?
(cons name func)))))]) (cons name func)))))])
(send controller listen-identifier=? (send controller listen-identifier=?
(lambda (name+proc) (lambda (name+proc)
(send this-choice check (eq? name (car name+proc))))))) (send this-choice check (eq? name (car name+proc)))))))
(map car (identifier=-choices)) (map car (identifier=-choices))
(map cdr (identifier=-choices)))) (map cdr (identifier=-choices))))
(void)) (void))
(define/public (after-partition-items) (define/public (after-partition-items)
(void)) (void))
(define/public (add-separator) (define/public (add-separator)
(new separator-menu-item% (parent this))) (new separator-menu-item% (parent this)))
(define/override (on-demand) (define/override (on-demand)
(define stx (send controller get-selected-syntax)) (define stx (send controller get-selected-syntax))
(send copy-menu enable (and stx #t)) (send copy-menu enable (and stx #t))
(send clear-menu enable (and stx #t)) (send clear-menu enable (and stx #t))
(super on-demand)) (super on-demand))
;; Initialization ;; Initialization
(add-edit-items) (add-edit-items)
(after-edit-items) (after-edit-items)
(add-separator) (add-separator)
(add-selection-items) (add-selection-items)
(after-selection-items) (after-selection-items)
(add-separator) (add-separator)
(add-partition-items) (add-partition-items)
(after-partition-items) (after-partition-items)
)) ))
)

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

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

49
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%))
)

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

@ -1,150 +1,148 @@
(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)))
((always) ((always)
(let ([n (send partition get-partition id)]) (let ([n (send partition get-partition id)])
(if (zero? n) (unintern (syntax-e id)) (suffix (syntax-e id) n)))) (if (zero? n) (unintern (syntax-e id)) (suffix (syntax-e id) n))))
((over-limit) ((over-limit)
(let ([n (send partition get-partition id)]) (let ([n (send partition get-partition id)])
(if (<= n limit) (if (<= n limit)
(unintern (syntax-e id)) (unintern (syntax-e id))
(suffix (syntax-e id) n)))))) (suffix (syntax-e id) n))))))
(let/ec escape (let/ec escape
(let ([flat=>stx (make-hash-table)] (let ([flat=>stx (make-hash-table)]
[stx=>flat (make-hash-table)]) [stx=>flat (make-hash-table)])
(define (loop obj) (define (loop obj)
(cond [(hash-table-get stx=>flat obj (lambda _ #f)) (cond [(hash-table-get stx=>flat obj (lambda _ #f))
=> (lambda (datum) datum)] => (lambda (datum) datum)]
[(and partition (identifier? obj)) [(and partition (identifier? obj))
(when (and (eq? suffixopt 'all-if-over-limit) (when (and (eq? suffixopt 'all-if-over-limit)
(> (send partition count) limit)) (> (send partition count) limit))
(call-with-values (lambda () (table stx partition #f 'always)) (call-with-values (lambda () (table stx partition #f 'always))
escape)) escape))
(let ([lp-datum (make-identifier-proxy obj)]) (let ([lp-datum (make-identifier-proxy obj)])
(hash-table-put! flat=>stx lp-datum obj) (hash-table-put! flat=>stx lp-datum obj)
(hash-table-put! stx=>flat obj lp-datum) (hash-table-put! stx=>flat obj lp-datum)
lp-datum)] lp-datum)]
[(and (syntax? obj) (check+convert-special-expression obj)) [(and (syntax? obj) (check+convert-special-expression obj))
=> (lambda (newobj) => (lambda (newobj)
(when partition (send partition get-partition obj)) (when partition (send partition get-partition obj))
(let* ([inner (cadr newobj)] (let* ([inner (cadr newobj)]
[lp-inner-datum (loop inner)] [lp-inner-datum (loop inner)]
[lp-datum (list (car newobj) lp-inner-datum)]) [lp-datum (list (car newobj) lp-inner-datum)])
(hash-table-put! flat=>stx lp-inner-datum inner) (hash-table-put! flat=>stx lp-inner-datum inner)
(hash-table-put! stx=>flat inner lp-inner-datum) (hash-table-put! stx=>flat inner lp-inner-datum)
(hash-table-put! flat=>stx lp-datum obj) (hash-table-put! flat=>stx lp-datum obj)
(hash-table-put! stx=>flat obj lp-datum) (hash-table-put! stx=>flat obj lp-datum)
lp-datum))] lp-datum))]
[(syntax? obj) [(syntax? obj)
(when partition (send partition get-partition obj)) (when partition (send partition get-partition obj))
(let ([lp-datum (loop (syntax-e obj))]) (let ([lp-datum (loop (syntax-e obj))])
(hash-table-put! flat=>stx lp-datum obj) (hash-table-put! flat=>stx lp-datum obj)
(hash-table-put! stx=>flat obj lp-datum) (hash-table-put! stx=>flat obj lp-datum)
lp-datum)] lp-datum)]
[(pair? obj) [(pair? obj)
(pairloop obj)] (pairloop obj)]
[(symbol? obj) [(symbol? obj)
(unintern obj)] (unintern obj)]
[(null? obj) [(null? obj)
(make-syntax-dummy obj)] (make-syntax-dummy obj)]
[(boolean? obj) [(boolean? obj)
(make-syntax-dummy obj)] (make-syntax-dummy obj)]
[(number? obj) [(number? obj)
(make-syntax-dummy obj)] (make-syntax-dummy obj)]
[(keyword? obj) [(keyword? obj)
(make-syntax-dummy obj)] (make-syntax-dummy obj)]
[(vector? obj) [(vector? obj)
(list->vector (map loop (vector->list obj)))] (list->vector (map loop (vector->list obj)))]
[(box? obj) [(box? obj)
(box (loop (unbox obj)))] (box (loop (unbox obj)))]
[else obj])) [else obj]))
(define (pairloop obj) (define (pairloop obj)
(cond [(pair? obj) (cond [(pair? obj)
(cons (loop (car obj)) (cons (loop (car obj))
(pairloop (cdr obj)))] (pairloop (cdr obj)))]
[(null? obj) [(null? obj)
null] null]
[(and (syntax? obj) (null? (syntax-e obj))) [(and (syntax? obj) (null? (syntax-e obj)))
null] null]
[else (loop obj)])) [else (loop obj)]))
(values (loop stx) (values (loop stx)
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
syntax-column syntax-column
syntax-position syntax-position
syntax-original? syntax-original?
syntax-source-module)) syntax-source-module))
(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)))
)

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

@ -1,161 +1,160 @@
;; 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
(length (current-colors)) (length (current-colors))
(current-suffix-option))) (current-suffix-option)))
(define identifier-list (define identifier-list
(filter identifier? (hash-table-map ht:stx=>flat (lambda (k v) k)))) (filter identifier? (hash-table-map ht:stx=>flat (lambda (k v) k))))
(define (flat=>stx obj) (define (flat=>stx obj)
(hash-table-get ht:flat=>stx obj #f)) (hash-table-get ht:flat=>stx obj #f))
(define (stx=>flat stx) (define (stx=>flat stx)
(hash-table-get ht:stx=>flat stx)) (hash-table-get ht:stx=>flat stx))
(define (current-position) (define (current-position)
(let-values ([(line column position) (port-next-location port)]) (let-values ([(line column position) (port-next-location port)])
(sub1 position))) (sub1 position)))
(define (pp-pre-hook obj port) (define (pp-pre-hook obj port)
(send range-builder set-start obj (current-position))) (send range-builder set-start obj (current-position)))
(define (pp-post-hook obj port) (define (pp-post-hook obj port)
(let ([start (send range-builder get-start obj)] (let ([start (send range-builder get-start obj)]
[end (current-position)] [end (current-position)]
[stx (flat=>stx obj)]) [stx (flat=>stx obj)])
(when (and start stx) (when (and start stx)
(send range-builder add-range stx (cons start end))))) (send range-builder add-range stx (cons start end)))))
(define (pp-extend-style-table identifier-list) (define (pp-extend-style-table identifier-list)
(let* ([syms (map (lambda (x) (stx=>flat x)) identifier-list)] (let* ([syms (map (lambda (x) (stx=>flat x)) identifier-list)]
[like-syms (map syntax-e identifier-list)]) [like-syms (map syntax-e identifier-list)])
(pretty-print-extend-style-table (pp-better-style-table) (pretty-print-extend-style-table (pp-better-style-table)
syms syms
like-syms))) like-syms)))
(unless (syntax? stx) (unless (syntax? stx)
(raise-type-error 'pretty-print-syntax "syntax" stx)) (raise-type-error 'pretty-print-syntax "syntax" stx))
(parameterize (parameterize
([pretty-print-pre-print-hook pp-pre-hook] ([pretty-print-pre-print-hook pp-pre-hook]
[pretty-print-post-print-hook pp-post-hook] [pretty-print-post-print-hook pp-post-hook]
[pretty-print-size-hook pp-size-hook] [pretty-print-size-hook pp-size-hook]
[pretty-print-print-hook pp-print-hook] [pretty-print-print-hook pp-print-hook]
[pretty-print-current-style-table (pp-extend-style-table identifier-list)] [pretty-print-current-style-table (pp-extend-style-table identifier-list)]
[pretty-print-columns (current-default-columns)] [pretty-print-columns (current-default-columns)]
;; Printing parameters (mzscheme manual 7.9.1.4) ;; Printing parameters (mzscheme manual 7.9.1.4)
[print-unreadable #t] [print-unreadable #t]
[print-graph #f] [print-graph #f]
[print-struct #f] [print-struct #f]
[print-box #t] [print-box #t]
[print-vector-length #t] [print-vector-length #t]
[print-hash-table #f] [print-hash-table #f]
[print-honu #f]) [print-honu #f])
(pretty-print datum port) (pretty-print datum port)
(new range% (new range%
(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%)
(write-special obj port)] (write-special obj port)]
[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)
(let ((ostring (open-output-string))) (let ((ostring (open-output-string)))
((if display-like? display write) (syntax-dummy-val obj) ostring) ((if display-like? display write) (syntax-dummy-val obj) ostring)
(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)]
[define-rx (caddr pref)] [define-rx (caddr pref)]
[lambda-rx (cadddr pref)]) [lambda-rx (cadddr pref)])
(let ([style-list (hash-table-map table cons)]) (let ([style-list (hash-table-map table cons)])
(pretty-print-extend-style-table (pretty-print-extend-style-table
(basic-style-list) (basic-style-list)
(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))
(define/public (set-start obj n) (define/public (set-start obj n)
(hash-table-put! starts obj n)) (hash-table-put! starts obj n))
(define/public (get-start obj) (define/public (get-start obj)
(hash-table-get starts obj (lambda _ #f))) (hash-table-get starts obj (lambda _ #f)))
(define/public (add-range obj range) (define/public (add-range obj range)
(hash-table-put! ranges obj (cons range (get-ranges obj)))) (hash-table-put! ranges obj (cons range (get-ranges obj))))
(define (get-ranges obj) (define (get-ranges obj)
(hash-table-get ranges obj (lambda () null))) (hash-table-get ranges obj (lambda () null)))
(define/public (range:get-ranges) ranges) (define/public (range:get-ranges) ranges)
(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)
(super-new) (super-new)
(define ranges (hash-table-copy (send range-builder range:get-ranges))) (define ranges (hash-table-copy (send range-builder range:get-ranges)))
(define/public (get-ranges obj) (define/public (get-ranges obj)
(hash-table-get ranges obj (lambda _ null))) (hash-table-get ranges obj (lambda _ null)))
(define/public (all-ranges) (define/public (all-ranges)
sorted-ranges) sorted-ranges)
(define/public (get-identifier-list) (define/public (get-identifier-list)
identifier-list) identifier-list)
(define sorted-ranges (define sorted-ranges
(sort (sort
(apply append (apply append
(hash-table-map (hash-table-map
ranges ranges
(lambda (k vs) (lambda (k vs)
(map (lambda (v) (make-range k (car v) (cdr v))) vs)))) (map (lambda (v) (make-range k (car v) (cdr v))) vs))))
(lambda (x y) (lambda (x y)
(>= (- (range-end x) (range-start x)) (>= (- (range-end x) (range-start x))
(- (range-end y) (range-start y)))))))) (- (range-end y) (range-start y))))))))
)

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

@ -1,314 +1,311 @@
(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")) properties-snip%)
(provide properties-view%
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)
;; selected-syntax : syntax ;; selected-syntax : syntax
(field (selected-syntax #f)) (field (selected-syntax #f))
;; mode : maybe symbol in '(term stxobj) ;; mode : maybe symbol in '(term stxobj)
(define mode 'term) (define mode 'term)
;; text : text% ;; text : text%
(field (text (new text%))) (field (text (new text%)))
(field (pdisplayer (new properties-displayer% (text text)))) (field (pdisplayer (new properties-displayer% (text text))))
(send controller listen-selected-syntax (send controller listen-selected-syntax
(lambda (stx) (lambda (stx)
(set! selected-syntax stx) (set! selected-syntax stx)
(refresh))) (refresh)))
(super-new) (super-new)
;; get-mode : -> symbol ;; get-mode : -> symbol
(define/public (get-mode) mode) (define/public (get-mode) mode)
;; set-mode : symbol -> void ;; set-mode : symbol -> void
(define/public (set-mode m) (define/public (set-mode m)
(set! mode m) (set! mode m)
(refresh)) (refresh))
;; refresh : -> void ;; refresh : -> void
(define/public (refresh) (define/public (refresh)
(send* text (send* text
(lock #f) (lock #f)
(begin-edit-sequence) (begin-edit-sequence)
(erase)) (erase))
(if (syntax? selected-syntax) (if (syntax? selected-syntax)
(refresh/mode mode) (refresh/mode mode)
(refresh/mode #f)) (refresh/mode #f))
(send* text (send* text
(end-edit-sequence) (end-edit-sequence)
(lock #t) (lock #t)
(scroll-to-position 0))) (scroll-to-position 0)))
;; refresh/mode : symbol -> void ;; refresh/mode : symbol -> void
(define/public (refresh/mode mode) (define/public (refresh/mode mode)
(case mode (case mode
((term) (send pdisplayer display-meaning-info selected-syntax)) ((term) (send pdisplayer display-meaning-info selected-syntax))
((stxobj) (send pdisplayer display-stxobj-info selected-syntax)) ((stxobj) (send pdisplayer display-stxobj-info selected-syntax))
((#f) (send pdisplayer display-null-info)) ((#f) (send pdisplayer display-null-info))
(else (error 'properties-view-base:refresh (else (error 'properties-view-base:refresh
"internal error: no such mode: ~s" mode)))) "internal error: no such mode: ~s" mode))))
(send text set-styles-sticky #f) (send text set-styles-sticky #f)
#;(send text hide-caret #t) #;(send text hide-caret #t)
(send text lock #t) (send text lock #t)
(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)
(inherit set-mode) (inherit set-mode)
(define/private outer:insert (define/private outer:insert
(case-lambda (case-lambda
[(obj) [(obj)
(outer:insert obj style:normal)] (outer:insert obj style:normal)]
[(text style) [(text style)
(outer:insert text style #f)] (outer:insert text style #f)]
[(text style clickback) [(text style clickback)
(let ([start (send outer-text last-position)]) (let ([start (send outer-text last-position)])
(send outer-text insert text) (send outer-text insert text)
(let ([end (send outer-text last-position)]) (let ([end (send outer-text last-position)])
(send outer-text change-style style start end #f) (send outer-text change-style style start end #f)
(when clickback (when clickback
(send outer-text set-clickback start end clickback))))])) (send outer-text set-clickback start end clickback))))]))
(define outer-text (new text%)) (define outer-text (new text%))
(super-new (editor outer-text)) (super-new (editor outer-text))
(outer:insert "Term" style:hyper (lambda _ (set-mode 'term))) (outer:insert "Term" style:hyper (lambda _ (set-mode 'term)))
(outer:insert " ") (outer:insert " ")
(outer:insert "Syntax Object" style:hyper (lambda _ (set-mode 'stxobj))) (outer:insert "Syntax Object" style:hyper (lambda _ (set-mode 'stxobj)))
(outer:insert "\n") (outer:insert "\n")
(outer:insert (new editor-snip% (editor text))) (outer:insert (new editor-snip% (editor text)))
(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)
(inherit-field pdisplayer) (inherit-field pdisplayer)
(inherit set-mode) (inherit set-mode)
;; get-tab-choices : (listof (cons string thunk)) ;; get-tab-choices : (listof (cons string thunk))
;; Override to add or remove panels ;; Override to add or remove panels
(define/public (get-tab-choices) (define/public (get-tab-choices)
(list (cons "Term" 'term) (list (cons "Term" 'term)
(cons "Syntax Object" 'stxobj))) (cons "Syntax Object" 'stxobj)))
(super-new) (super-new)
(define tab-choices (get-tab-choices)) (define tab-choices (get-tab-choices))
(define tab-panel (define tab-panel
(new tab-panel% (new tab-panel%
(choices (map car tab-choices)) (choices (map car tab-choices))
(parent parent) (parent parent)
(callback (callback
(lambda (tp e) (lambda (tp e)
(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)
;; display-null-info : -> void ;; display-null-info : -> void
(define/public (display-null-info) (define/public (display-null-info)
(display "No syntax selected\n" n/a-sd)) (display "No syntax selected\n" n/a-sd))
;; display-meaning-info : syntax -> void ;; display-meaning-info : syntax -> void
(define/public (display-meaning-info stx) (define/public (display-meaning-info stx)
(when (and (identifier? stx) (when (and (identifier? stx)
(uninterned? (syntax-e stx))) (uninterned? (syntax-e stx)))
(display "Uninterned symbol!\n\n" key-sd)) (display "Uninterned symbol!\n\n" key-sd))
(display-binding-info stx) (display-binding-info stx)
(display-indirect-binding-info stx)) (display-indirect-binding-info stx))
;; display-binding-info : syntax -> void ;; display-binding-info : syntax -> void
(define/private (display-binding-info stx) (define/private (display-binding-info stx)
(display "Apparent identifier binding\n" key-sd) (display "Apparent identifier binding\n" key-sd)
(display-bindings stx)) (display-bindings stx))
;; display-indirect-binding-info : syntax -> void ;; display-indirect-binding-info : syntax -> void
(define/private (display-indirect-binding-info stx) (define/private (display-indirect-binding-info stx)
(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)
(unless (identifier? stx) (unless (identifier? stx)
(display "Not applicable\n\n" n/a-sd)) (display "Not applicable\n\n" n/a-sd))
(when (identifier? stx) (when (identifier? stx)
(if (eq? (identifier-binding stx) 'lexical) (if (eq? (identifier-binding stx) 'lexical)
(display "lexical (all phases)\n" #f) (display "lexical (all phases)\n" #f)
(for-each (lambda (p) (display-binding-kvs (car p) ((cdr p) stx))) (for-each (lambda (p) (display-binding-kvs (car p) ((cdr p) stx)))
binding-properties)) binding-properties))
(display "\n" #f))) (display "\n" #f)))
;; display-binding-kvs : string bindinginfo -> void ;; display-binding-kvs : string bindinginfo -> void
(define/private (display-binding-kvs k v) (define/private (display-binding-kvs k v)
(display k sub-key-sd) (display k sub-key-sd)
(display "\n" #f) (display "\n" #f)
(cond [(eq? v #f) (cond [(eq? v #f)
(display " top-level or unbound\n" #f)] (display " top-level or unbound\n" #f)]
[(list? v) [(list? v)
(display-subkv " defined in" (mpi->string (list-ref v 0))) (display-subkv " defined in" (mpi->string (list-ref v 0)))
(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
(define/public (display-stxobj-info stx) (define/public (display-stxobj-info stx)
(display-source-info stx) (display-source-info stx)
(display-extra-source-info stx) (display-extra-source-info stx)
(display-symbol-property-info stx)) (display-symbol-property-info stx))
;; display-source-info : syntax -> void ;; display-source-info : syntax -> void
(define/private (display-source-info stx) (define/private (display-source-info stx)
(define s-source (syntax-source stx)) (define s-source (syntax-source stx))
(define s-line (syntax-line stx)) (define s-line (syntax-line stx))
(define s-column (syntax-column stx)) (define s-column (syntax-column stx))
(define s-position (syntax-position stx)) (define s-position (syntax-position stx))
(define s-span0 (syntax-span stx)) (define s-span0 (syntax-span stx))
(define s-span (if (zero? s-span0) #f s-span0)) (define s-span (if (zero? s-span0) #f s-span0))
(display "Source location\n" key-sd) (display "Source location\n" key-sd)
(if (or s-source s-line s-column s-position s-span) (if (or s-source s-line s-column s-position s-span)
(begin (begin
(display-subkv "source" (prettify-source s-source)) (display-subkv "source" (prettify-source s-source))
(display-subkv "line" s-line) (display-subkv "line" s-line)
(display-subkv "column" s-column) (display-subkv "column" s-column)
(display-subkv "position" s-position) (display-subkv "position" s-position)
(display-subkv "span" s-span0)) (display-subkv "span" s-span0))
(display "No source location available\n" n/a-sd)) (display "No source location available\n" n/a-sd))
(display "\n" #f)) (display "\n" #f))
;; display-extra-source-info : syntax -> void ;; display-extra-source-info : syntax -> void
(define/private (display-extra-source-info stx) (define/private (display-extra-source-info stx)
(display "Built-in properties\n" key-sd) (display "Built-in properties\n" key-sd)
(display-subkv "source module" (display-subkv "source module"
(let ([mod (syntax-source-module stx)]) (let ([mod (syntax-source-module stx)])
(and mod (mpi->string mod)))) (and mod (mpi->string mod))))
(display-subkv "original?" (syntax-original? stx)) (display-subkv "original?" (syntax-original? stx))
(display "\n" #f)) (display "\n" #f))
;; display-symbol-property-info : syntax -> void ;; display-symbol-property-info : syntax -> void
(define/private (display-symbol-property-info stx) (define/private (display-symbol-property-info stx)
(let ([keys (syntax-property-symbol-keys stx)]) (let ([keys (syntax-property-symbol-keys stx)])
(display "Additional properties\n" key-sd) (display "Additional properties\n" key-sd)
(when (null? keys) (when (null? keys)
(display "No additional properties available.\n" n/a-sd)) (display "No additional properties available.\n" n/a-sd))
(when (pair? keys) (when (pair? keys)
(for-each (lambda (k) (display-subkv/value k (syntax-property stx k))) (for-each (lambda (k) (display-subkv/value k (syntax-property stx k)))
keys)))) keys))))
;; display-kv : any any -> void ;; display-kv : any any -> void
(define/private (display-kv key value) (define/private (display-kv key value)
(display (format "~a~n" key) key-sd) (display (format "~a~n" key) key-sd)
(display (format "~s~n~n" value) #f)) (display (format "~s~n~n" value) #f))
;; display-subkv : any any -> void ;; display-subkv : any any -> void
(define/public (display-subkv k v) (define/public (display-subkv k v)
(display (format "~a: " k) sub-key-sd) (display (format "~a: " k) sub-key-sd)
(display (format "~a~n" v) #f)) (display (format "~a~n" v) #f))
(define/public (display-subkv/value k v) (define/public (display-subkv/value k v)
(display-subkv k v) (display-subkv k v)
#; #;
(begin (begin
(display (format "~a:~n" k) sub-key-sd) (display (format "~a:~n" k) sub-key-sd)
(let* ([value-text (new text:standard-style-list% (auto-wrap #t))] (let* ([value-text (new text:standard-style-list% (auto-wrap #t))]
[value-snip (new editor-snip% (editor value-text))] [value-snip (new editor-snip% (editor value-text))]
[value-port (make-text-port value-text)]) [value-port (make-text-port value-text)])
(set-interactive-write-handler value-port) (set-interactive-write-handler value-port)
(set-interactive-print-handler value-port) (set-interactive-print-handler value-port)
(set-interactive-display-handler value-port) (set-interactive-display-handler value-port)
(write v value-port) (write v value-port)
(send value-text lock #t) (send value-text lock #t)
(send text insert value-snip) (send text insert value-snip)
(send text insert "\n") (send text insert "\n")
#;(send ecanvas add-wide-snip value-snip)))) #;(send ecanvas add-wide-snip value-snip))))
;; display : string style-delta -> void ;; display : string style-delta -> void
(define/private (display item sd) (define/private (display item sd)
(let ([p0 (send text last-position)]) (let ([p0 (send text last-position)])
(send text insert item) (send text insert item)
(let ([p1 (send text last-position)]) (let ([p1 (send text last-position)])
(send text change-style sd p0 p1)))) (send text change-style sd p0 p1))))
(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\")"
(lift/id identifier-transformer-binding)) (lift/id identifier-transformer-binding))
(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
(let ([sd (new style-delta%)])
(define key-sd (send sd set-delta-foreground "blue")
(let ([sd (new style-delta%)]) (send sd set-weight-on 'bold)
(send sd set-delta-foreground "blue") sd))
(send sd set-weight-on 'bold)
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
(let ([sd (new style-delta%)])
(send sd set-delta-foreground "gray")
sd))
(define style:normal (make-object style-delta% 'change-normal)) (define n/a-sd
(let ([sd (new style-delta%)])
(send sd set-delta-foreground "gray")
sd))
(define style:hyper (define style:normal (make-object style-delta% 'change-normal))
(let ([s (make-object style-delta% 'change-normal)])
(send s set-delta 'change-toggle-underline) (define style:hyper
(send s set-delta-foreground "blue") (let ([s (make-object style-delta% 'change-normal)])
s)) (send s set-delta 'change-toggle-underline)
) (send s set-delta-foreground "blue")
s))

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

@ -1,324 +1,323 @@
(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<%>
text:hover-mixin text:hover-mixin
text:hover-identifier-mixin text:hover-identifier-mixin
text:mouse-drawings-mixin text:mouse-drawings-mixin
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)]
[old-mode (send dc get-text-mode)]) [old-mode (send dc get-text-mode)])
(begin0 (thunk) (begin0 (thunk)
(send dc set-font old-font) (send dc set-font old-font)
(send dc set-text-foreground old-color) (send dc set-text-foreground old-color)
(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)
(define/override (on-default-event ev) (define/override (on-default-event ev)
(define gx (send ev get-x)) (define gx (send ev get-x))
(define gy (send ev get-y)) (define gy (send ev get-y))
(define-values (x y) (dc-location-to-editor-location gx gy)) (define-values (x y) (dc-location-to-editor-location gx gy))
(define pos (find-position x y)) (define pos (find-position x y))
(super on-default-event ev) (super on-default-event ev)
(case (send ev get-event-type) (case (send ev get-event-type)
((enter motion leave) ((enter motion leave)
(update-hover-position pos)))) (update-hover-position pos))))
(define/public (update-hover-position pos) (define/public (update-hover-position pos)
(void)) (void))
(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)))
(define idlocs null) (define idlocs null)
(define/public (add-identifier-location start end id) (define/public (add-identifier-location start end id)
(set! idlocs (cons (make-idloc start end id) idlocs))) (set! idlocs (cons (make-idloc start end id) idlocs)))
(define/public (delete-all-identifier-locations) (define/public (delete-all-identifier-locations)
(set! idlocs null) (set! idlocs null)
(set-hovered-identifier #f)) (set-hovered-identifier #f))
(define/override (update-hover-position pos) (define/override (update-hover-position pos)
(super update-hover-position pos) (super update-hover-position pos)
(let search ([idlocs idlocs]) (let search ([idlocs idlocs])
(cond [(null? idlocs) (set-hovered-identifier #f)] (cond [(null? idlocs) (set-hovered-identifier #f)]
[(and (<= (idloc-start (car idlocs)) pos) [(and (<= (idloc-start (car idlocs)) pos)
(< pos (idloc-end (car idlocs)))) (< pos (idloc-end (car idlocs))))
(set-hovered-identifier (idloc-id (car idlocs)))] (set-hovered-identifier (idloc-id (car idlocs)))]
[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
invalidate-bitmap-cache) invalidate-bitmap-cache)
;; list of Drawings ;; list of Drawings
(field [drawings-list null]) (field [drawings-list null])
(define/public add-mouse-drawing (define/public add-mouse-drawing
(case-lambda (case-lambda
[(start end draw) [(start end draw)
(add-mouse-drawing start end draw (box #f))] (add-mouse-drawing start end draw (box #f))]
[(start end draw tack-box) [(start end draw tack-box)
(set! drawings-list (set! drawings-list
(cons (make-drawing start end draw #f tack-box) (cons (make-drawing start end draw #f tack-box)
drawings-list))])) drawings-list))]))
(define/public (delete-all-drawings) (define/public (delete-all-drawings)
(set! drawings-list null)) (set! drawings-list null))
(define/public-final (for-each-drawing f) (define/public-final (for-each-drawing f)
(for-each f drawings-list)) (for-each f drawings-list))
(define/override (on-paint before? dc left top right bottom dx dy draw-caret) (define/override (on-paint before? dc left top right bottom dx dy draw-caret)
(super on-paint before? dc left top right bottom dx dy draw-caret) (super on-paint before? dc left top right bottom dx dy draw-caret)
(unless before? (unless before?
(for-each-drawing
(lambda (d)
(when (or (drawing-visible? d) (unbox (drawing-tacked? d)))
((drawing-draw d) this dc left top right bottom dx dy))))))
(define/override (update-hover-position pos)
(super update-hover-position pos)
(let ([changed? (update-visible-drawings pos)])
(when changed? (invalidate-bitmap-cache 0.0 0.0 +inf.0 +inf.0))))
(define/private (update-visible-drawings pos)
(let ([changed? #f])
(for-each-drawing
(lambda (d)
(let ([vis? (<= (drawing-start d) pos (drawing-end d))])
(unless (eqv? vis? (drawing-visible? d))
(set-drawing-visible?! d vis?)
(set! changed? #t)))))
changed?))
(super-new)))
(define text:tacking-mixin
(mixin (text:basic<%> text:mouse-drawings<%>) ()
(inherit get-canvas
for-each-drawing)
(inherit-field drawings-list)
(super-new)
(define/override (on-event ev)
(case (send ev get-event-type)
((right-down)
(if (ormap (lambda (d) (drawing-visible? d)) drawings-list)
(send (get-canvas) popup-menu
(make-tack/untack-menu)
(send ev get-x)
(send ev get-y))
(super on-event ev)))
(else
(super on-event ev))))
(define/private (make-tack/untack-menu)
(define menu (new popup-menu%))
(new menu-item% (label "Tack")
(parent menu)
(callback
(lambda _ (tack))))
(new menu-item% (label "Untack")
(parent menu)
(callback
(lambda _ (untack))))
menu)
(define/private (tack)
(for-each-drawing (for-each-drawing
(lambda (d) (lambda (d)
(when (drawing-visible? d) (when (or (drawing-visible? d) (unbox (drawing-tacked? d)))
(set-box! (drawing-tacked? d) #t))))) ((drawing-draw d) this dc left top right bottom dx dy))))))
(define/private (untack)
(define/override (update-hover-position pos)
(super update-hover-position pos)
(let ([changed? (update-visible-drawings pos)])
(when changed? (invalidate-bitmap-cache 0.0 0.0 +inf.0 +inf.0))))
(define/private (update-visible-drawings pos)
(let ([changed? #f])
(for-each-drawing (for-each-drawing
(lambda (d) (lambda (d)
(when (drawing-visible? d) (let ([vis? (<= (drawing-start d) pos (drawing-end d))])
(set-box! (drawing-tacked? d) #f))))))) (unless (eqv? vis? (drawing-visible? d))
(set-drawing-visible?! d vis?)
(set! changed? #t)))))
changed?))
(define text:arrows-mixin (super-new)))
(mixin (text:mouse-drawings<%>) (text:arrows<%>)
(inherit position-location
add-mouse-drawing
find-wordbreak)
(define/public (add-arrow from1 from2 to1 to2 color) (define text:tacking-mixin
(internal-add-arrow from1 from2 to1 to2 color #f)) (mixin (text:basic<%> text:mouse-drawings<%>) ()
(inherit get-canvas
for-each-drawing)
(inherit-field drawings-list)
(super-new)
(define/public (add-question-arrow from1 from2 to1 to2 color) (define/override (on-event ev)
(internal-add-arrow from1 from2 to1 to2 color #t)) (case (send ev get-event-type)
((right-down)
(if (ormap (lambda (d) (drawing-visible? d)) drawings-list)
(send (get-canvas) popup-menu
(make-tack/untack-menu)
(send ev get-x)
(send ev get-y))
(super on-event ev)))
(else
(super on-event ev))))
(define/public (add-billboard pos1 pos2 str color-name) (define/private (make-tack/untack-menu)
(define color (send the-color-database find-color color-name)) (define menu (new popup-menu%))
(new menu-item% (label "Tack")
(parent menu)
(callback
(lambda _ (tack))))
(new menu-item% (label "Untack")
(parent menu)
(callback
(lambda _ (untack))))
menu)
(define/private (tack)
(for-each-drawing
(lambda (d)
(when (drawing-visible? d)
(set-box! (drawing-tacked? d) #t)))))
(define/private (untack)
(for-each-drawing
(lambda (d)
(when (drawing-visible? d)
(set-box! (drawing-tacked? d) #f)))))))
(define text:arrows-mixin
(mixin (text:mouse-drawings<%>) (text:arrows<%>)
(inherit position-location
add-mouse-drawing
find-wordbreak)
(define/public (add-arrow from1 from2 to1 to2 color)
(internal-add-arrow from1 from2 to1 to2 color #f))
(define/public (add-question-arrow from1 from2 to1 to2 color)
(internal-add-arrow from1 from2 to1 to2 color #t))
(define/public (add-billboard pos1 pos2 str color-name)
(define color (send the-color-database find-color color-name))
(let ([draw
(lambda (text dc left top right bottom dx dy)
(let-values ([(x y) (range->mean-loc pos1 pos1)]
[(fw fh _d _v) (send dc get-text-extent "y")])
(with-saved-pen&brush dc
(with-saved-text-config dc
(send* dc
(set-pen color 1 'solid)
(set-brush billboard-brush)
(set-text-mode 'solid)
(set-font (billboard-font dc))
(set-text-foreground color))
(let-values ([(w h d v) (send dc get-text-extent str)]
[(adj-y) fh]
[(mini) _d])
(send* dc
(draw-rounded-rectangle
(+ x dx)
(+ y dy adj-y)
(+ w mini mini)
(+ h mini mini))
(draw-text str (+ x dx mini) (+ y dy mini adj-y))))))))])
(add-mouse-drawing pos1 pos2 draw)))
(define/private (internal-add-arrow from1 from2 to1 to2 color-name question?)
(define color (send the-color-database find-color color-name))
(define tack-box (box #f))
(unless (and (= from1 to1) (= from2 to2))
(let ([draw (let ([draw
(lambda (text dc left top right bottom dx dy) (lambda (text dc left top right bottom dx dy)
(let-values ([(x y) (range->mean-loc pos1 pos1)] (let-values ([(startx starty) (range->mean-loc from1 from2)]
[(fw fh _d _v) (send dc get-text-extent "y")]) [(endx endy) (range->mean-loc to1 to2)]
[(fw fh _d _v) (send dc get-text-extent "x")])
(with-saved-pen&brush dc (with-saved-pen&brush dc
(with-saved-text-config dc (with-saved-text-config dc
(send* dc (send dc set-pen color 1 'solid)
(set-pen color 1 'solid) (send dc set-brush
(set-brush billboard-brush) (if (unbox tack-box)
(set-text-mode 'solid) (tacked-arrow-brush color)
(set-font (billboard-font dc)) arrow-brush))
(set-text-foreground color)) (draw-arrow dc startx
(let-values ([(w h d v) (send dc get-text-extent str)] (+ starty (/ fh 2))
[(adj-y) fh] endx
[(mini) _d]) (+ endy (/ fh 2))
(send* dc dx dy)
(draw-rounded-rectangle (send dc set-text-mode 'transparent)
(+ x dx) (when question?
(+ y dy adj-y) (send dc set-font (?-font dc))
(+ w mini mini) (send dc set-text-foreground color)
(+ h mini mini)) (send dc draw-text "?"
(draw-text str (+ x dx mini) (+ y dy mini adj-y))))))))]) (+ endx dx fw)
(add-mouse-drawing pos1 pos2 draw))) (- endy dy fh)))))))])
(add-mouse-drawing from1 from2 draw tack-box)
(add-mouse-drawing to1 to2 draw tack-box))))
(define/private (internal-add-arrow from1 from2 to1 to2 color-name question?) (define/private (position->location p)
(define color (send the-color-database find-color color-name)) (define xbox (box 0.0))
(define tack-box (box #f)) (define ybox (box 0.0))
(unless (and (= from1 to1) (= from2 to2)) (position-location p xbox ybox)
(let ([draw (values (unbox xbox) (unbox ybox)))
(lambda (text dc left top right bottom dx dy)
(let-values ([(startx starty) (range->mean-loc from1 from2)]
[(endx endy) (range->mean-loc to1 to2)]
[(fw fh _d _v) (send dc get-text-extent "x")])
(with-saved-pen&brush dc
(with-saved-text-config dc
(send dc set-pen color 1 'solid)
(send dc set-brush
(if (unbox tack-box)
(tacked-arrow-brush color)
arrow-brush))
(draw-arrow dc startx
(+ starty (/ fh 2))
endx
(+ endy (/ fh 2))
dx dy)
(send dc set-text-mode 'transparent)
(when question?
(send dc set-font (?-font dc))
(send dc set-text-foreground color)
(send dc draw-text "?"
(+ endx dx fw)
(- endy dy fh)))))))])
(add-mouse-drawing from1 from2 draw tack-box)
(add-mouse-drawing to1 to2 draw tack-box))))
(define/private (position->location p) (define/private (?-font dc)
(define xbox (box 0.0)) (let ([size (send (send dc get-font) get-point-size)])
(define ybox (box 0.0)) (send the-font-list find-or-create-font size 'default 'normal 'bold)))
(position-location p xbox ybox)
(values (unbox xbox) (unbox ybox)))
(define/private (?-font dc) (define/private (billboard-font dc)
(let ([size (send (send dc get-font) get-point-size)]) (let ([size (send (send dc get-font) get-point-size)])
(send the-font-list find-or-create-font size 'default 'normal 'bold))) (send the-font-list find-or-create-font size 'default 'normal)))
(define/private (billboard-font dc) (define/private (range->mean-loc pos1 pos2)
(let ([size (send (send dc get-font) get-point-size)]) (let*-values ([(loc1x loc1y) (position->location pos1)]
(send the-font-list find-or-create-font size 'default 'normal))) [(loc2x loc2y) (position->location pos2)]
[(locx) (mean loc1x loc2x)]
[(locy) (mean loc1y loc2y)])
(values locx locy)))
(define/private (range->mean-loc pos1 pos2) (super-new)))
(let*-values ([(loc1x loc1y) (position->location pos1)]
[(loc2x loc2y) (position->location pos2)]
[(locx) (mean loc1x loc2x)]
[(locy) (mean loc1y loc2y)])
(values locx locy)))
(super-new))) (define text:mouse-drawings%
(text:mouse-drawings-mixin
(text:hover-mixin
text:standard-style-list%)))
(define text:mouse-drawings% (define text:arrows%
(text:mouse-drawings-mixin (text:arrows-mixin
(text:hover-mixin (text:tacking-mixin
text:standard-style-list%))) text:mouse-drawings%)))
(define text:arrows%
(text:arrows-mixin
(text:tacking-mixin
text:mouse-drawings%)))
)

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

@ -1,60 +1,59 @@
(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]
[locked? (send t is-locked?)]) [locked? (send t is-locked?)])
(send t lock #f) (send t lock #f)
(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?)
(send text insert (send text insert
(bytes->string/utf-8 s #f start end) (bytes->string/utf-8 s #f start end)
(end-position)) (end-position))
(- end start)) (- end start))
void void
(lambda (special buffer? enable-break?) (lambda (special buffer? enable-break?)
(send text insert special (end-position)) (send text insert special (end-position))
#t))) #t)))
;; mpi->string : module-path-index -> string ;; 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)))
(apply string-append (apply string-append
(format "~s" (car mps)) (format "~s" (car mps))
(map (lambda (x) (format " <= ~s" x)) (cdr mps)))] (map (lambda (x) (format " <= ~s" x)) (cdr mps)))]
[(and (pair? mps) (null? (cdr mps))) [(and (pair? mps) (null? (cdr mps)))
(format "~s" (car mps))] (format "~s" (car mps))]
[(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)))
(cons path null)] (cons path null)]
[path [path
(cons path (mpi->list rel))] (cons path (mpi->list rel))]
[else '()]))] [else '()]))]
[(not mpi) [(not mpi)
'()] '()]
[else (list mpi)])) [else (list mpi)]))
)

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

@ -1,258 +1,257 @@
(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"
"display.ss" "display.ss"
"keymap.ss" "keymap.ss"
"hrule-snip.ss" "hrule-snip.ss"
"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)
(define controller (new controller%)) (define controller (new controller%))
(define -main-panel (define -main-panel
(new vertical-panel% (parent parent))) (new vertical-panel% (parent parent)))
(define -split-panel (define -split-panel
(new panel:horizontal-dragable% (parent -main-panel))) (new panel:horizontal-dragable% (parent -main-panel)))
(define -text (new browser-text%)) (define -text (new browser-text%))
(define -ecanvas (define -ecanvas
(new editor-canvas% (parent -split-panel) (editor -text))) (new editor-canvas% (parent -split-panel) (editor -text)))
(define -props-panel (new horizontal-panel% (parent -split-panel))) (define -props-panel (new horizontal-panel% (parent -split-panel)))
(define props (define props
(new properties-view% (new properties-view%
(parent -props-panel) (parent -props-panel)
(controller controller))) (controller controller)))
(define props-percentage (send config pref:props-percentage)) (define props-percentage (send config pref:props-percentage))
(define/public (setup-keymap) (define/public (setup-keymap)
(new widget-keymap% (new widget-keymap%
(editor -text) (editor -text)
(widget this))) (widget this)))
(send -text set-styles-sticky #f) (send -text set-styles-sticky #f)
(send -text lock #t) (send -text lock #t)
(send -split-panel set-percentages (send -split-panel set-percentages
(list (- 1 props-percentage) props-percentage)) (list (- 1 props-percentage) props-percentage))
;; syntax-properties-controller<%> methods ;; syntax-properties-controller<%> methods
(define/public (props-shown?) (define/public (props-shown?)
(send -props-panel is-shown?)) (send -props-panel is-shown?))
(define/public (toggle-props) (define/public (toggle-props)
(show-props (not (send -props-panel is-shown?)))) (show-props (not (send -props-panel is-shown?))))
(define/public (show-props show?) (define/public (show-props show?)
(if show? (if show?
(unless (send -props-panel is-shown?) (unless (send -props-panel is-shown?)
(send -split-panel add-child -props-panel) (send -split-panel add-child -props-panel)
(send -split-panel set-percentages (send -split-panel set-percentages
(list (- 1 props-percentage) props-percentage)) (list (- 1 props-percentage) props-percentage))
(send -props-panel show #t)) (send -props-panel show #t))
(when (send -props-panel is-shown?) (when (send -props-panel is-shown?)
(set! props-percentage (set! props-percentage
(cadr (send -split-panel get-percentages))) (cadr (send -split-panel get-percentages)))
(send -split-panel delete-child -props-panel) (send -split-panel delete-child -props-panel)
(send -props-panel show #f)))) (send -props-panel show #f))))
;; ;;
(define/public (get-controller) controller) (define/public (get-controller) controller)
;; ;;
(define/public (get-main-panel) -main-panel) (define/public (get-main-panel) -main-panel)
(define/public (shutdown) (define/public (shutdown)
(unless (= props-percentage (send config pref:props-percentage)) (unless (= props-percentage (send config pref:props-percentage))
(send config pref:props-percentage props-percentage))) (send config pref:props-percentage props-percentage)))
;; syntax-browser<%> Methods ;; syntax-browser<%> Methods
(define/public (add-text text) (define/public (add-text text)
(with-unlock -text (with-unlock -text
(send -text insert text))) (send -text insert text)))
(define/public (add-error-text text) (define/public (add-error-text text)
(with-unlock -text (with-unlock -text
(let ([a (send -text last-position)]) (let ([a (send -text last-position)])
(send -text insert text) (send -text insert text)
(let ([b (send -text last-position)]) (let ([b (send -text last-position)])
(send -text change-style error-text-style a b))))) (send -text change-style error-text-style a b)))))
(define/public (add-clickback text handler) (define/public (add-clickback text handler)
(with-unlock -text (with-unlock -text
(let ([a (send -text last-position)]) (let ([a (send -text last-position)])
(send -text insert text) (send -text insert text)
(let ([b (send -text last-position)]) (let ([b (send -text last-position)])
(send -text set-clickback a b handler) (send -text set-clickback a b handler)
(send -text change-style clickback-style a b))))) (send -text change-style clickback-style a b)))))
(define/public add-syntax (define/public add-syntax
(lambda/kw (stx #:key [hi-stxs null] hi-color alpha-table [definites null] (lambda/kw (stx #:key [hi-stxs null] hi-color alpha-table [definites null]
hi2-color [hi2-stxs null]) hi2-color [hi2-stxs null])
(define (get-binder id) (define (get-binder id)
(module-identifier-mapping-get alpha-table id (lambda () #f))) (module-identifier-mapping-get alpha-table id (lambda () #f)))
(when (and (pair? hi-stxs) (not hi-color)) (when (and (pair? hi-stxs) (not hi-color))
(error 'syntax-widget%::add-syntax "no highlight color specified")) (error 'syntax-widget%::add-syntax "no highlight color specified"))
(let ([display (internal-add-syntax stx)] (let ([display (internal-add-syntax stx)]
[definite-table (make-hash-table)]) [definite-table (make-hash-table)])
(when (and hi2-color (pair? hi2-stxs)) (when (and hi2-color (pair? hi2-stxs))
(send display highlight-syntaxes hi2-stxs hi2-color)) (send display highlight-syntaxes hi2-stxs hi2-color))
(when (and hi-color (pair? hi-stxs)) (when (and hi-color (pair? hi-stxs))
(send display highlight-syntaxes hi-stxs hi-color)) (send display highlight-syntaxes hi-stxs hi-color))
(for-each (lambda (x) (hash-table-put! definite-table x #t)) definites) (for-each (lambda (x) (hash-table-put! definite-table x #t)) definites)
(when alpha-table (when alpha-table
(let ([range (send display get-range)] (let ([range (send display get-range)]
[start (send display get-start-position)]) [start (send display get-start-position)])
(define (adjust n) (+ start n)) (define (adjust n) (+ start n))
(for-each (for-each
(lambda (id) (lambda (id)
#; ;; DISABLED #; ;; DISABLED
(match (identifier-binding id) (match (identifier-binding id)
[(list src-mod src-name nom-mod nom-name _) [(list src-mod src-name nom-mod nom-name _)
(for-each (lambda (id-r) (for-each (lambda (id-r)
(send -text add-billboard (send -text add-billboard
(adjust (car id-r)) (adjust (car id-r))
(adjust (cdr id-r)) (adjust (cdr id-r))
(string-append "from " (string-append "from "
(mpi->string src-mod)) (mpi->string src-mod))
(if (hash-table-get definite-table id #f)
"blue"
"purple")))
(send range get-ranges id))]
[_ (void)])
(let ([binder (get-binder id)])
(when binder
(for-each
(lambda (binder-r)
(for-each (lambda (id-r)
(if (hash-table-get definite-table id #f) (if (hash-table-get definite-table id #f)
(send -text add-arrow "blue"
(adjust (car binder-r)) "purple")))
(adjust (cdr binder-r)) (send range get-ranges id))]
(adjust (car id-r)) [_ (void)])
(adjust (cdr id-r))
"blue")
(send -text add-question-arrow
(adjust (car binder-r))
(adjust (cdr binder-r))
(adjust (car id-r))
(adjust (cdr id-r))
"purple")))
(send range get-ranges id)))
(send range get-ranges binder)))))
(send range get-identifier-list))))
display)))
(define/public (add-separator) (let ([binder (get-binder id)])
(with-unlock -text (when binder
(send* -text (for-each
(insert (new hrule-snip%)) (lambda (binder-r)
(insert "\n")))) (for-each (lambda (id-r)
(if (hash-table-get definite-table id #f)
(send -text add-arrow
(adjust (car binder-r))
(adjust (cdr binder-r))
(adjust (car id-r))
(adjust (cdr id-r))
"blue")
(send -text add-question-arrow
(adjust (car binder-r))
(adjust (cdr binder-r))
(adjust (car id-r))
(adjust (cdr id-r))
"purple")))
(send range get-ranges id)))
(send range get-ranges binder)))))
(send range get-identifier-list))))
display)))
(define/public (erase-all) (define/public (add-separator)
(with-unlock -text (with-unlock -text
(send -text erase) (send* -text
(send -text delete-all-drawings)) (insert (new hrule-snip%))
(send controller remove-all-syntax-displays)) (insert "\n"))))
(define/public (get-text) -text) (define/public (erase-all)
(with-unlock -text
(send -text erase)
(send -text delete-all-drawings))
(send controller remove-all-syntax-displays))
;; internal-add-syntax : syntax -> display (define/public (get-text) -text)
(define/private (internal-add-syntax stx)
(with-unlock -text
(parameterize ((current-default-columns (calculate-columns)))
(let ([display (print-syntax-to-editor stx -text controller)])
(send* -text
(insert "\n")
;(scroll-to-position current-position)
)
display))))
(define/private (calculate-columns) ;; internal-add-syntax : syntax -> display
(define style (code-style -text)) (define/private (internal-add-syntax stx)
(define char-width (send style get-text-width (send -ecanvas get-dc))) (with-unlock -text
(define-values (canvas-w canvas-h) (send -ecanvas get-client-size)) (parameterize ((current-default-columns (calculate-columns)))
(sub1 (inexact->exact (floor (/ canvas-w char-width))))) (let ([display (print-syntax-to-editor stx -text controller)])
(send* -text
(insert "\n")
;(scroll-to-position current-position)
)
display))))
;; Initialize (define/private (calculate-columns)
(super-new) (define style (code-style -text))
(setup-keymap))) (define char-width (send style get-text-width (send -ecanvas get-dc)))
(define-values (canvas-w canvas-h) (send -ecanvas get-client-size))
(sub1 (inexact->exact (floor (/ canvas-w char-width)))))
(define clickback-style ;; Initialize
(let ([sd (new style-delta%)]) (super-new)
(send sd set-delta 'change-toggle-underline) (setup-keymap)))
(send sd set-delta-foreground "blue")
sd))
(define error-text-style (define clickback-style
(let ([sd (new style-delta%)]) (let ([sd (new style-delta%)])
(send sd set-delta 'change-italic) (send sd set-delta 'change-toggle-underline)
(send sd set-delta-foreground "red") (send sd set-delta-foreground "blue")
sd)) sd))
;; Specialized classes for widget (define error-text-style
(let ([sd (new style-delta%)])
(send sd set-delta 'change-italic)
(send sd set-delta-foreground "red")
sd))
(define widget-keymap% ;; Specialized classes for widget
(class syntax-keymap%
(init-field widget)
(super-new (controller (send widget get-controller)))
(inherit add-function)
(inherit-field controller)
(define/override (get-context-menu%) (define widget-keymap%
widget-context-menu%) (class syntax-keymap%
(init-field widget)
(super-new (controller (send widget get-controller)))
(inherit add-function)
(inherit-field controller)
(add-function "show-syntax-properties" (define/override (get-context-menu%)
(lambda (i e) widget-context-menu%)
(send widget toggle-props)))
(define/public (get-widget) widget))) (add-function "show-syntax-properties"
(lambda (i e)
(send widget toggle-props)))
(define widget-context-menu% (define/public (get-widget) widget)))
(class context-menu%
(inherit-field keymap)
(inherit-field props-menu)
(define/override (on-demand) (define widget-context-menu%
(send props-menu set-label (class context-menu%
(if (send (send keymap get-widget) props-shown?) (inherit-field keymap)
"Hide syntax properties" (inherit-field props-menu)
"Show syntax properties"))
(super on-demand))
(super-new)))
(define browser-text% (define/override (on-demand)
(class (text:arrows-mixin (send props-menu set-label
(text:tacking-mixin (if (send (send keymap get-widget) props-shown?)
(text:mouse-drawings-mixin "Hide syntax properties"
(text:hover-mixin "Show syntax properties"))
(text:hide-caret/selection-mixin (super on-demand))
(editor:standard-style-list-mixin text:basic%)))))) (super-new)))
(inherit set-autowrap-bitmap)
(define/override (default-style-name) "Basic") (define browser-text%
(super-new (auto-wrap #t)) (class (text:arrows-mixin
(set-autowrap-bitmap #f))) (text:tacking-mixin
) (text:mouse-drawings-mixin
(text:hover-mixin
(text:hide-caret/selection-mixin
(editor:standard-style-list-mixin text:basic%))))))
(inherit set-autowrap-bitmap)
(define/override (default-style-name) "Basic")
(super-new (auto-wrap #t))
(set-autowrap-bitmap #f)))

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

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

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

@ -1,55 +1,53 @@
(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)
(with-output-to-file file
(lambda ()
(write `(list ,@(map (lambda (e) (serialize-datum e)) events)))
(newline)
(write (exn-message exn))
(newline)
(write (map serialize-context-frame
(continuation-mark-set->context
(exn-continuation-marks exn)))))
'replace))
(define (write-debug-file file exn events) (define (serialize-datum d)
(with-output-to-file file (cond [(number? d) `(quote ,d)]
[(boolean? d) `(quote ,d)]
[(symbol? d) `(quote ,d)]
[(string? d) `(quote ,d)]
[(pair? d) `(cons ,(serialize-datum (car d)) ,(serialize-datum (cdr d)))]
[(null? d) '()]
[(exn? d) `(make-exn ,(exn-message d) (current-continuation-marks))]
[(syntax? d) `(datum->syntax #f ',(syntax->datum d))]
#;[(syntax? d) `(eval (quote ,(compile `(,#'quote-syntax ,d))))]
[else (error 'serialize-datum "got ~s" d)]))
(define (serialize-context-frame frame)
(cons (car frame)
(if (cdr frame)
(serialize-srcloc (cdr frame))
null)))
(define (serialize-srcloc s)
(list (let ([src (srcloc-source s)])
(cond [(path? src) (path->string src)]
[(string? src) src]
[else '?]))
(srcloc-line s)
(srcloc-column s)))
(define (load-debug-file file)
(parameterize ((read-accept-compiled #t))
(with-input-from-file file
(lambda () (lambda ()
(write `(list ,@(map (lambda (e) (serialize-datum e)) events))) (let* ([events-expr (read)]
(newline) [exnmsg (read)]
(write (exn-message exn)) [ctx (read)])
(newline) (let ([events (eval events-expr)])
(write (map serialize-context-frame (values events exnmsg ctx)))))))
(continuation-mark-set->context
(exn-continuation-marks exn)))))
'replace))
(define (serialize-datum d)
(cond [(number? d) `(quote ,d)]
[(boolean? d) `(quote ,d)]
[(symbol? d) `(quote ,d)]
[(string? d) `(quote ,d)]
[(pair? d) `(cons ,(serialize-datum (car d)) ,(serialize-datum (cdr d)))]
[(null? d) '()]
[(exn? d) `(make-exn ,(exn-message d) (current-continuation-marks))]
[(syntax? d) `(datum->syntax-object #f ',(syntax-object->datum d))]
#;[(syntax? d) `(eval (quote ,(compile `(,#'quote-syntax ,d))))]
[else (error 'serialize-datum "got ~s" d)]))
(define (serialize-context-frame frame)
(cons (car frame)
(if (cdr frame)
(serialize-srcloc (cdr frame))
null)))
(define (serialize-srcloc s)
(list (let ([src (srcloc-source s)])
(cond [(path? src) (path->string src)]
[(string? src) src]
[else '?]))
(srcloc-line s)
(srcloc-column s)))
(define (load-debug-file file)
(parameterize ((read-accept-compiled #t))
(with-input-from-file file
(lambda ()
(let* ([events-expr (read)]
[exnmsg (read)]
[ctx (read)])
(let ([events (eval events-expr)])
(values events exnmsg ctx)))))))
)

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

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

@ -1,112 +1,111 @@
(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)
(inherit add-function) (inherit add-function)
(super-new) (super-new)
(define/override (get-context-menu%) (define/override (get-context-menu%)
stepper-context-menu%) stepper-context-menu%)
(define/public (get-hiding-panel) (define/public (get-hiding-panel)
(send macro-stepper get-macro-hiding-prefs)) (send macro-stepper get-macro-hiding-prefs))
(add-function "hiding:show-macro" (add-function "hiding:show-macro"
(lambda (i e) (lambda (i e)
(send* (get-hiding-panel) (send* (get-hiding-panel)
(add-show-identifier) (add-show-identifier)
(refresh)))) (refresh))))
(add-function "hiding:hide-macro" (add-function "hiding:hide-macro"
(lambda (i e) (lambda (i e)
(send* (get-hiding-panel) (send* (get-hiding-panel)
(add-hide-identifier) (add-hide-identifier)
(refresh)))))) (refresh))))))
(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)
(field [show-macro #f] (field [show-macro #f]
[hide-macro #f]) [hide-macro #f])
(define/override (after-selection-items) (define/override (after-selection-items)
(super after-selection-items) (super after-selection-items)
(add-separator) (add-separator)
(set! show-macro (set! show-macro
(new menu-item% (label "Show this macro") (parent this) (new menu-item% (label "Show this macro") (parent this)
(callback (lambda (i e) (callback (lambda (i e)
(send keymap call-function "hiding:show-macro" i e))))) (send keymap call-function "hiding:show-macro" i e)))))
(set! hide-macro (set! hide-macro
(new menu-item% (label "Hide this macro") (parent this) (new menu-item% (label "Hide this macro") (parent this)
(callback (lambda (i e) (callback (lambda (i e)
(send keymap call-function "hiding:hide-macro" i e))))) (send keymap call-function "hiding:hide-macro" i e)))))
(void)) (void))
(define/override (on-demand) (define/override (on-demand)
(define hiding-panel (send keymap get-hiding-panel)) (define hiding-panel (send keymap get-hiding-panel))
(define controller (send keymap get-controller)) (define controller (send keymap get-controller))
(define stx (send controller get-selected-syntax)) (define stx (send controller get-selected-syntax))
(define id? (identifier? stx)) (define id? (identifier? stx))
(send show-macro enable id?) (send show-macro enable id?)
(send hide-macro enable id?) (send hide-macro enable id?)
(super on-demand)) (super on-demand))
(super-new))) (super-new)))
(define stepper-syntax-widget%
(class s:widget%
(init-field macro-stepper)
(inherit get-text)
(define/override (setup-keymap) (define stepper-syntax-widget%
(new stepper-keymap% (class s:widget%
(editor (get-text)) (init-field macro-stepper)
(widget this) (inherit get-text)
(macro-stepper macro-stepper)))
(define/override (show-props show?) (define/override (setup-keymap)
(super show-props show?) (new stepper-keymap%
(send macro-stepper update/preserve-view)) (editor (get-text))
(widget this)
(macro-stepper macro-stepper)))
(super-new (define/override (show-props show?)
(config (new config-adapter% (super show-props show?)
(config (send macro-stepper get-config))))))) (send macro-stepper update/preserve-view))
(define config-adapter% (super-new
(class object% (config (new config-adapter%
(init-field config) (config (send macro-stepper get-config)))))))
(define/public pref:props-percentage
(case-lambda [() (send config get-props-percentage)] (define config-adapter%
[(v) (send config set-props-percentage v)])) (class object%
(super-new))) (init-field config)
) (define/public pref:props-percentage
(case-lambda [() (send config get-props-percentage)]
[(v) (send config set-props-percentage v)]))
(super-new)))

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

@ -1,236 +1,234 @@
(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))
(define obsoleted? #f) (define obsoleted? #f)
(inherit get-area-container (inherit get-area-container
set-label set-label
get-menu% get-menu%
get-menu-item% get-menu-item%
get-menu-bar get-menu-bar
get-file-menu get-file-menu
get-edit-menu get-edit-menu
get-help-menu) get-help-menu)
(super-new (label (make-label)) (super-new (label (make-label))
(width (send config get-width)) (width (send config get-width))
(height (send config get-height))) (height (send config get-height)))
(define/private (make-label) (define/private (make-label)
(if filename (if filename
(string-append (path->string (string-append (path->string
(file-name-from-path filename)) (file-name-from-path filename))
(if obsoleted? " (old)" "") (if obsoleted? " (old)" "")
" - Macro stepper") " - Macro stepper")
"Macro stepper")) "Macro stepper"))
(define/override (on-size w h) (define/override (on-size w h)
(send config set-width w) (send config set-width w)
(send config set-height h) (send config set-height h)
(send widget update/preserve-view)) (send widget update/preserve-view))
(override/return-false file-menu:create-new? (override/return-false file-menu:create-new?
file-menu:create-open? file-menu:create-open?
file-menu:create-open-recent? file-menu:create-open-recent?
file-menu:create-revert? file-menu:create-revert?
file-menu:create-save? file-menu:create-save?
file-menu:create-save-as? file-menu:create-save-as?
;file-menu:create-print? ;file-menu:create-print?
edit-menu:create-undo? edit-menu:create-undo?
edit-menu:create-redo? edit-menu:create-redo?
;edit-menu:create-cut? ;edit-menu:create-cut?
;edit-menu:create-paste? ;edit-menu:create-paste?
edit-menu:create-clear? edit-menu:create-clear?
;edit-menu:create-find? ;edit-menu:create-find?
;edit-menu:create-find-again? ;edit-menu:create-find-again?
edit-menu:create-replace-and-find-again?) edit-menu:create-replace-and-find-again?)
(define file-menu (get-file-menu)) (define file-menu (get-file-menu))
(define edit-menu (get-edit-menu)) (define edit-menu (get-edit-menu))
(define stepper-menu (define stepper-menu
(new (get-menu%) (parent (get-menu-bar)) (label "Stepper"))) (new (get-menu%) (parent (get-menu-bar)) (label "Stepper")))
(define help-menu (get-help-menu)) (define help-menu (get-help-menu))
(define warning-panel (define warning-panel
(new horizontal-panel% (new horizontal-panel%
(parent (get-area-container)) (parent (get-area-container))
(stretchable-height #f) (stretchable-height #f)
(style '(deleted)))) (style '(deleted))))
(define/public (get-macro-stepper-widget%) (define/public (get-macro-stepper-widget%)
macro-stepper-widget%) macro-stepper-widget%)
(define widget (define widget
(new (get-macro-stepper-widget%) (new (get-macro-stepper-widget%)
(parent (get-area-container)) (parent (get-area-container))
(config config))) (config config)))
(define/public (get-widget) widget) (define/public (get-widget) widget)
(define/public (add-obsoleted-warning) (define/public (add-obsoleted-warning)
(unless obsoleted? (unless obsoleted?
(set! obsoleted? #t) (set! obsoleted? #t)
(new warning-canvas% (new warning-canvas%
(warning (warning
(string-append (string-append
"Warning: This macro stepper session is obsolete. " "Warning: This macro stepper session is obsolete. "
"The program may have changed.")) "The program may have changed."))
(parent warning-panel)) (parent warning-panel))
(set-label (make-label)) (set-label (make-label))
(send (get-area-container) change-children (send (get-area-container) change-children
(lambda (children) (lambda (children)
(cons warning-panel (cons warning-panel
(remq warning-panel children)))))) (remq warning-panel children))))))
;; Set up menus ;; Set up menus
(menu-option/notify-box stepper-menu (menu-option/notify-box stepper-menu
"Show syntax properties" "Show syntax properties"
(get-field show-syntax-properties? config)) (get-field show-syntax-properties? config))
;; FIXME: rewrite with notify-box ;; FIXME: rewrite with notify-box
(let ([id-menu (let ([id-menu
(new (get-menu%) (new (get-menu%)
(label "Identifier=?") (label "Identifier=?")
(parent stepper-menu))]) (parent stepper-menu))])
(for-each (lambda (p) (for-each (lambda (p)
(let ([this-choice (let ([this-choice
(new checkable-menu-item% (new checkable-menu-item%
(label (car p)) (label (car p))
(parent id-menu) (parent id-menu)
(callback (callback
(lambda _ (lambda _
(send (send widget get-controller) (send (send widget get-controller)
set-identifier=? p))))]) set-identifier=? p))))])
(send (send widget get-controller) (send (send widget get-controller)
listen-identifier=? listen-identifier=?
(lambda (name+func) (lambda (name+func)
(send this-choice check (send this-choice check
(eq? (car name+func) (car p))))))) (eq? (car name+func) (car p)))))))
(sb:identifier=-choices))) (sb:identifier=-choices)))
(let ([identifier=? (send config get-identifier=?)]) (let ([identifier=? (send config get-identifier=?)])
(when identifier=? (when identifier=?
(let ([p (assoc identifier=? (sb:identifier=-choices))]) (let ([p (assoc identifier=? (sb:identifier=-choices))])
(send (send widget get-controller) set-identifier=? p)))) (send (send widget get-controller) set-identifier=? p))))
(new (get-menu-item%) (new (get-menu-item%)
(label "Clear selection") (label "Clear selection")
(parent stepper-menu) (parent stepper-menu)
(callback
(lambda _ (send (send widget get-controller) select-syntax #f))))
(new separator-menu-item% (parent stepper-menu))
(menu-option/notify-box stepper-menu
"Show macro hiding panel"
(get-field show-hiding-panel? config))
#;
(new (get-menu-item%)
(label "Show in new frame")
(parent stepper-menu)
(callback (lambda _ (send widget show-in-new-frame))))
(new (get-menu-item%)
(label "Remove selected term")
(parent stepper-menu)
(callback (lambda _ (send widget remove-current-term))))
(new (get-menu-item%)
(label "Reset mark numbering")
(parent stepper-menu)
(callback (lambda _ (send widget reset-primary-partition))))
(let ([extras-menu
(new (get-menu%)
(label "Extra options")
(parent stepper-menu))])
(new checkable-menu-item%
(label "Always suffix marked identifiers")
(parent extras-menu)
(callback (callback
(lambda _ (send (send widget get-controller) select-syntax #f)))) (lambda (i e)
(new separator-menu-item% (parent stepper-menu)) (sb:current-suffix-option
(if (send i is-checked?)
'always
'over-limit))
(send widget update/preserve-view))))
(menu-option/notify-box extras-menu
"Highlight redex/contractum"
(get-field highlight-foci? config))
(menu-option/notify-box extras-menu
"Highlight frontier"
(get-field highlight-frontier? config))
(menu-option/notify-box extras-menu
"Include renaming steps"
(get-field show-rename-steps? config))
(menu-option/notify-box extras-menu
"One term at a time"
(get-field one-by-one? config))
(menu-option/notify-box extras-menu
"Suppress warnings"
(get-field suppress-warnings? config))
(menu-option/notify-box extras-menu
"Extra navigation"
(get-field extra-navigation? config))
(menu-option/notify-box extras-menu
"Force block->letrec transformation"
(get-field force-letrec-transformation? config))
(menu-option/notify-box extras-menu
"(Debug) Catch internal errors?"
(get-field debug-catch-errors? config)))
(menu-option/notify-box stepper-menu (frame:reorder-menus this)))
"Show macro hiding panel"
(get-field show-hiding-panel? config))
#;
(new (get-menu-item%)
(label "Show in new frame")
(parent stepper-menu)
(callback (lambda _ (send widget show-in-new-frame))))
(new (get-menu-item%)
(label "Remove selected term")
(parent stepper-menu)
(callback (lambda _ (send widget remove-current-term))))
(new (get-menu-item%)
(label "Reset mark numbering")
(parent stepper-menu)
(callback (lambda _ (send widget reset-primary-partition))))
(let ([extras-menu
(new (get-menu%)
(label "Extra options")
(parent stepper-menu))])
(new checkable-menu-item%
(label "Always suffix marked identifiers")
(parent extras-menu)
(callback
(lambda (i e)
(sb:current-suffix-option
(if (send i is-checked?)
'always
'over-limit))
(send widget update/preserve-view))))
(menu-option/notify-box extras-menu
"Highlight redex/contractum"
(get-field highlight-foci? config))
(menu-option/notify-box extras-menu
"Highlight frontier"
(get-field highlight-frontier? config))
(menu-option/notify-box extras-menu
"Include renaming steps"
(get-field show-rename-steps? config))
(menu-option/notify-box extras-menu
"One term at a time"
(get-field one-by-one? config))
(menu-option/notify-box extras-menu
"Suppress warnings"
(get-field suppress-warnings? config))
(menu-option/notify-box extras-menu
"Extra navigation"
(get-field extra-navigation? config))
(menu-option/notify-box extras-menu
"Force block->letrec transformation"
(get-field force-letrec-transformation? config))
(menu-option/notify-box extras-menu
"(Debug) Catch internal errors?"
(get-field debug-catch-errors? config)))
(frame:reorder-menus this))) ;; Stolen from stepper
;; Stolen from stepper (define warning-color "yellow")
(define warning-font normal-control-font)
(define warning-color "yellow") (define warning-canvas%
(define warning-font normal-control-font) (class canvas%
(init-field warning)
(define warning-canvas% (inherit get-dc get-client-size)
(class canvas% (define/override (on-paint)
(init-field warning) (let ([dc (get-dc)])
(inherit get-dc get-client-size) (send dc set-font warning-font)
(define/override (on-paint) (let-values ([(cw ch) (get-client-size)]
(let ([dc (get-dc)]) [(tw th dont-care dont-care2) (send dc get-text-extent warning)])
(send dc set-font warning-font) (send dc set-pen (send the-pen-list find-or-create-pen warning-color 1 'solid))
(let-values ([(cw ch) (get-client-size)] (send dc set-brush (send the-brush-list find-or-create-brush warning-color 'solid))
[(tw th dont-care dont-care2) (send dc get-text-extent warning)]) (send dc draw-rectangle 0 0 cw ch)
(send dc set-pen (send the-pen-list find-or-create-pen warning-color 1 'solid)) (send dc draw-text
(send dc set-brush (send the-brush-list find-or-create-brush warning-color 'solid)) warning
(send dc draw-rectangle 0 0 cw ch) (- (/ cw 2) (/ tw 2))
(send dc draw-text (- (/ ch 2) (/ th 2))))))
warning (super-new)
(- (/ cw 2) (/ tw 2)) (inherit min-width min-height stretchable-height)
(- (/ ch 2) (/ th 2)))))) (let-values ([(tw th dc dc2) (send (get-dc) get-text-extent warning warning-font)])
(super-new) (min-width (+ 2 (inexact->exact (ceiling tw))))
(inherit min-width min-height stretchable-height) (min-height (+ 2 (inexact->exact (ceiling th)))))
(let-values ([(tw th dc dc2) (send (get-dc) get-text-extent warning warning-font)]) (stretchable-height #f)))
(min-width (+ 2 (inexact->exact (ceiling tw))))
(min-height (+ 2 (inexact->exact (ceiling th)))))
(stretchable-height #f)))
)

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

@ -1,320 +1,319 @@
(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?
specialized-policies) specialized-policies)
(lambda (id) (lambda (id)
(define now (phase)) (define now (phase))
(define binding (define binding
(cond [(= now 0) (identifier-binding id)] (cond [(= now 0) (identifier-binding id)]
[(= now 1) (identifier-transformer-binding id)] [(= now 1) (identifier-transformer-binding id)]
[else #f])) [else #f]))
(define-values (def-mod def-name nom-mod nom-name) (define-values (def-mod def-name nom-mod nom-name)
(if (pair? binding) (if (pair? binding)
(values (car binding) (values (car binding)
(cadr binding) (cadr binding)
(caddr binding) (caddr binding)
(cadddr binding)) (cadddr binding))
(values #f #f #f #f))) (values #f #f #f #f)))
(let/ec return (let/ec return
(let loop ([policies specialized-policies]) (let loop ([policies specialized-policies])
(when (pair? policies) (when (pair? policies)
((car policies) id binding return) ((car policies) id binding return)
(loop (cdr policies)))) (loop (cdr policies))))
(cond [(and hide-mzscheme? def-mod (scheme-module? def-mod)) (cond [(and hide-mzscheme? def-mod (scheme-module? def-mod))
#f] #f]
[(and hide-libs? def-mod (lib-module? def-mod)) [(and hide-libs? def-mod (lib-module? def-mod))
#f] #f]
[(and hide-contracts? def-name [(and hide-contracts? def-name
(regexp-match #rx"^provide/contract-id-" (regexp-match #rx"^provide/contract-id-"
(symbol->string def-name))) (symbol->string def-name)))
#f] #f]
[(and hide-transformers? (positive? now)) [(and hide-transformers? (positive? now))
#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)
(init-field config) (init-field config)
(define/public (get-policy) (define/public (get-policy)
(let ([mode (get-mode)]) (let ([mode (get-mode)])
(cond [(not (macro-hiding-enabled?)) #f] (cond [(not (macro-hiding-enabled?)) #f]
[(equal? mode mode:standard) standard-policy] [(equal? mode mode:standard) standard-policy]
[(equal? mode mode:custom) (get-custom-policy)]))) [(equal? mode mode:custom) (get-custom-policy)])))
(define/private (get-custom-policy) (define/private (get-custom-policy)
(let ([hide-mzscheme? (send box:hide-mzscheme get-value)] (let ([hide-mzscheme? (send box:hide-mzscheme get-value)]
[hide-libs? (send box:hide-libs get-value)] [hide-libs? (send box:hide-libs get-value)]
[hide-contracts? (send box:hide-contracts get-value)] [hide-contracts? (send box:hide-contracts get-value)]
[hide-transformers? (send box:hide-phase1 get-value)] [hide-transformers? (send box:hide-phase1 get-value)]
[specialized-policies (get-specialized-policies)]) [specialized-policies (get-specialized-policies)])
(make-policy hide-mzscheme? (make-policy hide-mzscheme?
hide-libs? hide-libs?
hide-contracts? hide-contracts?
hide-transformers? hide-transformers?
specialized-policies))) specialized-policies)))
(define super-panel (define super-panel
(new vertical-panel% (new vertical-panel%
(parent parent) (parent parent)
(stretchable-height #f))) (stretchable-height #f)))
(define top-line-panel (define top-line-panel
(new horizontal-panel% (new horizontal-panel%
(parent super-panel) (parent super-panel)
(alignment '(left center)) (alignment '(left center))
(stretchable-height #f))) (stretchable-height #f)))
(define customize-panel (define customize-panel
(new horizontal-panel% (new horizontal-panel%
(parent super-panel) (parent super-panel)
(stretchable-height #f) (stretchable-height #f)
(alignment '(left top)) (alignment '(left top))
(style '(deleted)))) (style '(deleted))))
(define left-pane (define left-pane
(new vertical-pane% (new vertical-pane%
(parent customize-panel) (parent customize-panel)
(stretchable-width #f) (stretchable-width #f)
(alignment '(left top)))) (alignment '(left top))))
(define right-pane (define right-pane
(new vertical-pane% (new vertical-pane%
(parent customize-panel))) (parent customize-panel)))
(define mode-selector (define mode-selector
(choice/notify-box (choice/notify-box
top-line-panel top-line-panel
"Macro hiding: " "Macro hiding: "
(list mode:disable mode:standard mode:custom) (list mode:disable mode:standard mode:custom)
(get-field macro-hiding-mode config))) (get-field macro-hiding-mode config)))
(define top-line-inner-panel (define top-line-inner-panel
(new horizontal-panel% (new horizontal-panel%
(parent top-line-panel) (parent top-line-panel)
(alignment '(right center)) (alignment '(right center))
(style '(deleted)))) (style '(deleted))))
(define/private (get-mode) (define/private (get-mode)
(send config get-macro-hiding-mode)) (send config get-macro-hiding-mode))
(define/private (macro-hiding-enabled?) (define/private (macro-hiding-enabled?)
(let ([mode (get-mode)]) (let ([mode (get-mode)])
(or (equal? mode mode:standard) (or (equal? mode mode:standard)
(and (equal? mode mode:custom) (and (equal? mode mode:custom)
(send box:hiding get-value))))) (send box:hiding get-value)))))
(define/private (ensure-custom-mode) (define/private (ensure-custom-mode)
(unless (equal? (get-mode) mode:custom) (unless (equal? (get-mode) mode:custom)
(send config set-macro-hiding-mode mode:custom))) (send config set-macro-hiding-mode mode:custom)))
(define/private (update-visibility) (define/private (update-visibility)
(let ([customizing (equal? (get-mode) mode:custom)]) (let ([customizing (equal? (get-mode) mode:custom)])
(send top-line-panel change-children (send top-line-panel change-children
(lambda (children) (lambda (children)
(append (remq top-line-inner-panel children) (append (remq top-line-inner-panel children)
(if customizing (list top-line-inner-panel) null)))) (if customizing (list top-line-inner-panel) null))))
(send super-panel change-children (send super-panel change-children
(lambda (children) (lambda (children)
(append (remq customize-panel children) (append (remq customize-panel children)
(if (and customizing (send box:edit get-value)) (if (and customizing (send box:edit get-value))
(list customize-panel) (list customize-panel)
null)))))) null))))))
(send config listen-macro-hiding-mode (send config listen-macro-hiding-mode
(lambda (value) (lambda (value)
(update-visibility) (update-visibility)
(force-refresh))) (force-refresh)))
(define box:hiding (define box:hiding
(new check-box% (new check-box%
(label "Enable macro hiding") (label "Enable macro hiding")
(value #t) (value #t)
(parent top-line-inner-panel) (parent top-line-inner-panel)
(callback (lambda (c e) (force-refresh))))) (callback (lambda (c e) (force-refresh)))))
(define box:edit (define box:edit
(new check-box% (new check-box%
(label "Show policy editor") (label "Show policy editor")
(parent top-line-inner-panel) (parent top-line-inner-panel)
(value #t) (value #t)
(callback (lambda (c e) (update-visibility))))) (callback (lambda (c e) (update-visibility)))))
(define box:hide-mzscheme (define box:hide-mzscheme
(new check-box% (new check-box%
(label "Hide mzscheme syntax") (label "Hide mzscheme syntax")
(parent left-pane) (parent left-pane)
(value #t) (value #t)
(callback (lambda (c e) (refresh))))) (callback (lambda (c e) (refresh)))))
(define box:hide-libs (define box:hide-libs
(new check-box% (new check-box%
(label "Hide library syntax") (label "Hide library syntax")
(parent left-pane) (parent left-pane)
(value #t) (value #t)
(callback (lambda (c e) (refresh))))) (callback (lambda (c e) (refresh)))))
(define box:hide-contracts (define box:hide-contracts
(new check-box% (new check-box%
(label "Hide contracts (heuristic)") (label "Hide contracts (heuristic)")
(parent left-pane) (parent left-pane)
(value #t) (value #t)
(callback (lambda (c e) (refresh))))) (callback (lambda (c e) (refresh)))))
(define box:hide-phase1 (define box:hide-phase1
(new check-box% (new check-box%
(label "Hide phase>0") (label "Hide phase>0")
(parent left-pane) (parent left-pane)
(value #t) (value #t)
(callback (lambda (c e) (refresh))))) (callback (lambda (c e) (refresh)))))
(define look-ctl (define look-ctl
(new list-box% (parent right-pane) (label "") (new list-box% (parent right-pane) (label "")
(choices null) (style '(extended)) (choices null) (style '(extended))
(callback (callback
(lambda (c e) (lambda (c e)
(send delete-ctl enable (pair? (send c get-selections))))))) (send delete-ctl enable (pair? (send c get-selections)))))))
(define look-button-pane (define look-button-pane
(new horizontal-pane% (parent right-pane) (stretchable-width #f))) (new horizontal-pane% (parent right-pane) (stretchable-width #f)))
(define delete-ctl (define delete-ctl
(new button% (parent look-button-pane) (label "Delete rule") (enabled #f) (new button% (parent look-button-pane) (label "Delete rule") (enabled #f)
(callback (lambda _ (delete-selected) (refresh))))) (callback (lambda _ (delete-selected) (refresh)))))
(define add-hide-id-button (define add-hide-id-button
(new button% (parent look-button-pane) (label "Hide macro") (enabled #f) (new button% (parent look-button-pane) (label "Hide macro") (enabled #f)
(callback (lambda _ (add-hide-identifier) (refresh))))) (callback (lambda _ (add-hide-identifier) (refresh)))))
(define add-show-id-button (define add-show-id-button
(new button% (parent look-button-pane) (label "Show macro") (enabled #f) (new button% (parent look-button-pane) (label "Show macro") (enabled #f)
(callback (lambda _ (add-show-identifier) (refresh))))) (callback (lambda _ (add-show-identifier) (refresh)))))
#;(new grow-box-spacer-pane% (parent right-pane)) #;(new grow-box-spacer-pane% (parent right-pane))
;; Methods ;; Methods
(define stx #f) (define stx #f)
(define stx-name #f) (define stx-name #f)
;; refresh : -> void ;; refresh : -> void
(define/public (refresh) (define/public (refresh)
(when (macro-hiding-enabled?) (when (macro-hiding-enabled?)
(send stepper refresh/resynth))) (send stepper refresh/resynth)))
;; force-refresh : -> void ;; force-refresh : -> void
(define/private (force-refresh) (define/private (force-refresh)
(send stepper refresh/resynth)) (send stepper refresh/resynth))
;; set-syntax : syntax/#f -> void ;; set-syntax : syntax/#f -> void
(define/public (set-syntax lstx) (define/public (set-syntax lstx)
(set! stx (and (identifier? lstx) lstx)) (set! stx (and (identifier? lstx) lstx))
(when (identifier? stx) (when (identifier? stx)
(let ([binding (identifier-binding stx)]) (let ([binding (identifier-binding stx)])
(if (pair? binding) (if (pair? binding)
(set! stx-name (cadr binding)) (set! stx-name (cadr binding))
(set! stx-name (syntax-e stx))))) (set! stx-name (syntax-e stx)))))
(send add-show-id-button enable (identifier? lstx)) (send add-show-id-button enable (identifier? lstx))
(send add-hide-id-button enable (identifier? lstx))) (send add-hide-id-button enable (identifier? lstx)))
(define identifier-policies null) (define identifier-policies null)
(define/private (get-specialized-policies) (define/private (get-specialized-policies)
(map (lambda (policy) (map (lambda (policy)
(define key (mcar policy)) (define key (mcar policy))
(define show? (mcdr policy)) (define show? (mcdr policy))
(cond [(pair? key) (cond [(pair? key)
(lambda (id binding return) (lambda (id binding return)
(when (and (pair? binding) (when (and (pair? binding)
(equal? key (get-id-key/binding id binding))) (equal? key (get-id-key/binding id binding)))
(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))
(define/public (add-hide-identifier) (define/public (add-hide-identifier)
(add-identifier-policy #f) (add-identifier-policy #f)
(ensure-custom-mode)) (ensure-custom-mode))
(define/public (add-show-identifier) (define/public (add-show-identifier)
(add-identifier-policy #t) (add-identifier-policy #t)
(ensure-custom-mode)) (ensure-custom-mode))
(define/private (add-identifier-policy show?) (define/private (add-identifier-policy show?)
(when (identifier? stx) (when (identifier? stx)
(let ([key (get-id-key stx)]) (let ([key (get-id-key stx)])
(let loop ([i 0] [policies identifier-policies]) (let loop ([i 0] [policies identifier-policies])
(cond [(null? policies) (cond [(null? policies)
(set! identifier-policies (set! identifier-policies
(cons (mcons key show?) identifier-policies)) (cons (mcons key show?) identifier-policies))
(send look-ctl append "") (send look-ctl append "")
(update-list-view i key show?)] (update-list-view i key show?)]
[(key=? key (mcar (car policies))) [(key=? key (mcar (car policies)))
(set-mcdr! (car policies) show?) (set-mcdr! (car policies) show?)
(update-list-view i key show?)] (update-list-view i key show?)]
[else (loop (add1 i) (cdr policies))]))))) [else (loop (add1 i) (cdr policies))])))))
(define/private (update-list-view index key show?) (define/private (update-list-view index key show?)
(send look-ctl set-data index key) (send look-ctl set-data index key)
(send look-ctl set-string (send look-ctl set-string
index index
(string-append (if show? "show " "hide ") (string-append (if show? "show " "hide ")
(key->text key)))) (key->text key))))
(define/private (delete-selected) (define/private (delete-selected)
(define to-delete (sort (send look-ctl get-selections) <)) (define to-delete (sort (send look-ctl get-selections) <))
(set! identifier-policies (set! identifier-policies
(let loop ([i 0] [policies identifier-policies] [to-delete to-delete]) (let loop ([i 0] [policies identifier-policies] [to-delete to-delete])
(cond [(null? to-delete) policies] (cond [(null? to-delete) policies]
[(= i (car to-delete)) [(= i (car to-delete))
(loop (add1 i) (cdr policies) (cdr to-delete))] (loop (add1 i) (cdr policies) (cdr to-delete))]
[else [else
(cons (car policies) (cons (car policies)
(loop (add1 i) (cdr policies) to-delete))]))) (loop (add1 i) (cdr policies) to-delete))])))
(for-each (lambda (n) (send look-ctl delete n)) (reverse to-delete))) (for-each (lambda (n) (send look-ctl delete n)) (reverse to-delete)))
(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)])
(format "'~s' from ~a" (format "'~s' from ~a"
name name
(mpi->string mod)))] (mpi->string mod)))]
[else (symbol->string (syntax-e key))])) [else (symbol->string (syntax-e key))]))
)

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

@ -1,48 +1,46 @@
(module interfaces mzscheme #lang scheme/base
(require (lib "unit.ss")) (require scheme/unit)
(provide (all-defined)) (provide (all-defined-out))
;; Signatures
(define-signature view^ ;; Signatures
(macro-stepper-frame%
macro-stepper-widget%
make-macro-stepper
go
go/deriv))
(define-signature view-base^ (define-signature view^
(base-frame%)) (macro-stepper-frame%
macro-stepper-widget%
make-macro-stepper
go
go/deriv))
(define-signature prefs^ (define-signature view-base^
(pref:width (base-frame%))
pref:height
pref:props-percentage
pref:macro-hiding-mode
pref:show-syntax-properties?
pref:show-hiding-panel?
pref:identifier=?
pref:show-rename-steps?
pref:highlight-foci?
pref:highlight-frontier?
pref:suppress-warnings?
pref:one-by-one?
pref:extra-navigation?
pref:debug-catch-errors?
pref:force-letrec-transformation?
))
;; macro-stepper-config% (define-signature prefs^
;; all fields are notify-box% objects (pref:width
;; width pref:height
;; height pref:props-percentage
;; macro-hiding? pref:macro-hiding-mode
;; hide-primitives? pref:show-syntax-properties?
;; hide-libs? pref:show-hiding-panel?
;; show-syntax-properties? pref:identifier=?
;; show-hiding-panel? pref:show-rename-steps?
;; show-rename-steps? pref:highlight-foci?
;; highlight-foci? pref:highlight-frontier?
pref:suppress-warnings?
pref:one-by-one?
pref:extra-navigation?
pref:debug-catch-errors?
pref:force-letrec-transformation?
))
) ;; macro-stepper-config%
;; all fields are notify-box% objects
;; width
;; height
;; macro-hiding?
;; hide-primitives?
;; hide-libs?
;; show-syntax-properties?
;; show-hiding-panel?
;; show-rename-steps?
;; highlight-foci?

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

@ -1,100 +1,98 @@
(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)
(notify-methods macro-hiding-mode) (notify-methods macro-hiding-mode)
(notify-methods props-percentage) (notify-methods props-percentage)
(notify-methods show-syntax-properties?) (notify-methods show-syntax-properties?)
(notify-methods show-hiding-panel?) (notify-methods show-hiding-panel?)
(notify-methods identifier=?) (notify-methods identifier=?)
(notify-methods highlight-foci?) (notify-methods highlight-foci?)
(notify-methods highlight-frontier?) (notify-methods highlight-frontier?)
(notify-methods show-rename-steps?) (notify-methods show-rename-steps?)
(notify-methods suppress-warnings?) (notify-methods suppress-warnings?)
(notify-methods one-by-one?) (notify-methods one-by-one?)
(notify-methods extra-navigation?) (notify-methods extra-navigation?)
(notify-methods debug-catch-errors?) (notify-methods debug-catch-errors?)
(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)
(connect-to-pref macro-hiding-mode pref:macro-hiding-mode) (connect-to-pref macro-hiding-mode pref:macro-hiding-mode)
(connect-to-pref props-percentage pref:props-percentage) (connect-to-pref props-percentage pref:props-percentage)
(connect-to-pref show-syntax-properties? pref:show-syntax-properties?) (connect-to-pref show-syntax-properties? pref:show-syntax-properties?)
(connect-to-pref show-hiding-panel? pref:show-hiding-panel?) (connect-to-pref show-hiding-panel? pref:show-hiding-panel?)
(connect-to-pref identifier=? pref:identifier=?) (connect-to-pref identifier=? pref:identifier=?)
(connect-to-pref highlight-foci? pref:highlight-foci?) (connect-to-pref highlight-foci? pref:highlight-foci?)
(connect-to-pref highlight-frontier? pref:highlight-frontier?) (connect-to-pref highlight-frontier? pref:highlight-frontier?)
(connect-to-pref show-rename-steps? pref:show-rename-steps?) (connect-to-pref show-rename-steps? pref:show-rename-steps?)
(connect-to-pref suppress-warnings? pref:suppress-warnings?) (connect-to-pref suppress-warnings? pref:suppress-warnings?)
(connect-to-pref one-by-one? pref:one-by-one?) (connect-to-pref one-by-one? pref:one-by-one?)
(connect-to-pref extra-navigation? pref:extra-navigation?) (connect-to-pref extra-navigation? pref:extra-navigation?)
(connect-to-pref debug-catch-errors? pref:debug-catch-errors?) (connect-to-pref debug-catch-errors? pref:debug-catch-errors?)
(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)
(connect-to-pref/readonly macro-hiding-mode pref:macro-hiding-mode) (connect-to-pref/readonly macro-hiding-mode pref:macro-hiding-mode)
(connect-to-pref/readonly props-percentage pref:props-percentage) (connect-to-pref/readonly props-percentage pref:props-percentage)
(connect-to-pref/readonly show-syntax-properties? pref:show-syntax-properties?) (connect-to-pref/readonly show-syntax-properties? pref:show-syntax-properties?)
(connect-to-pref/readonly show-hiding-panel? pref:show-hiding-panel?) (connect-to-pref/readonly show-hiding-panel? pref:show-hiding-panel?)
(connect-to-pref/readonly identifier=? pref:identifier=?) (connect-to-pref/readonly identifier=? pref:identifier=?)
(connect-to-pref/readonly highlight-foci? pref:highlight-foci?) (connect-to-pref/readonly highlight-foci? pref:highlight-foci?)
(connect-to-pref/readonly highlight-frontier? pref:highlight-frontier?) (connect-to-pref/readonly highlight-frontier? pref:highlight-frontier?)
(connect-to-pref/readonly show-rename-steps? pref:show-rename-steps?) (connect-to-pref/readonly show-rename-steps? pref:show-rename-steps?)
(connect-to-pref/readonly suppress-warnings? pref:suppress-warnings?) (connect-to-pref/readonly suppress-warnings? pref:suppress-warnings?)
(connect-to-pref/readonly one-by-one? pref:one-by-one?) (connect-to-pref/readonly one-by-one? pref:one-by-one?)
(connect-to-pref/readonly extra-navigation? pref:extra-navigation?) (connect-to-pref/readonly extra-navigation? pref:extra-navigation?)
(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)))
)

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

@ -1,433 +1,432 @@
(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"
"../model/trace.ss" "../model/trace.ss"
"../model/reductions.ss" "../model/reductions.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-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)
;; Terms ;; Terms
;; all-terms : (list-of TermRecord) ;; all-terms : (list-of TermRecord)
;; (Reversed) ;; (Reversed)
(define all-terms null) (define all-terms null)
;; terms : (Cursor-of TermRecord) ;; terms : (Cursor-of TermRecord)
;; Contains visible terms of all-terms ;; Contains visible terms of all-terms
(define terms (cursor:new null)) (define terms (cursor:new null))
;; focused-term : -> TermRecord or #f ;; focused-term : -> TermRecord or #f
(define (focused-term) (define (focused-term)
(cursor:next terms)) (cursor:next terms))
;; add-deriv : Deriv -> void ;; add-deriv : Deriv -> void
(define/public (add-deriv d) (define/public (add-deriv d)
(let ([trec (new term-record% (stepper this) (raw-deriv d))]) (let ([trec (new term-record% (stepper this) (raw-deriv d))])
(add trec))) (add trec)))
;; add-trace : (list-of event) -> void ;; add-trace : (list-of event) -> void
(define/public (add-trace events) (define/public (add-trace events)
(let ([trec (new term-record% (stepper this) (events events))]) (let ([trec (new term-record% (stepper this) (events events))])
(add trec))) (add trec)))
;; add : TermRecord -> void ;; add : TermRecord -> void
(define/public (add trec) (define/public (add trec)
(set! all-terms (cons trec all-terms)) (set! all-terms (cons trec all-terms))
(let ([display-new-term? (cursor:at-end? terms)] (let ([display-new-term? (cursor:at-end? terms)]
[invisible? (send trec get-deriv-hidden?)]) [invisible? (send trec get-deriv-hidden?)])
(unless invisible? (unless invisible?
(cursor:add-to-end! terms (list trec)) (cursor:add-to-end! terms (list trec))
(trim-navigator) (trim-navigator)
(if display-new-term? (if display-new-term?
(refresh) (refresh)
(update))))) (update)))))
;; remove-current-term : -> void ;; remove-current-term : -> void
(define/public (remove-current-term) (define/public (remove-current-term)
(cursor:remove-current! terms) (cursor:remove-current! terms)
(trim-navigator) (trim-navigator)
(refresh)) (refresh))
(define/public (get-config) config) (define/public (get-config) config)
(define/public (get-controller) sbc) (define/public (get-controller) sbc)
(define/public (get-view) sbview) (define/public (get-view) sbview)
(define/public (get-warnings-area) warnings-area) (define/public (get-warnings-area) warnings-area)
(define/public (get-macro-hiding-prefs) macro-hiding-prefs) (define/public (get-macro-hiding-prefs) macro-hiding-prefs)
(define/public (reset-primary-partition) (define/public (reset-primary-partition)
(send sbc reset-primary-partition) (send sbc reset-primary-partition)
(update/preserve-view)) (update/preserve-view))
(define area (new vertical-panel% (parent parent))) (define area (new vertical-panel% (parent parent)))
(define supernavigator (define supernavigator
(new horizontal-panel% (new horizontal-panel%
(parent area) (parent area)
(stretchable-height #f) (stretchable-height #f)
(alignment '(center center)))) (alignment '(center center))))
(define navigator (define navigator
(new horizontal-panel% (new horizontal-panel%
(parent supernavigator) (parent supernavigator)
(stretchable-width #f) (stretchable-width #f)
(stretchable-height #f) (stretchable-height #f)
(alignment '(left center)))) (alignment '(left center))))
(define extra-navigator (define extra-navigator
(new horizontal-panel% (new horizontal-panel%
(parent supernavigator) (parent supernavigator)
(stretchable-width #f) (stretchable-width #f)
(stretchable-height #f) (stretchable-height #f)
(alignment '(left center)) (alignment '(left center))
(style '(deleted)))) (style '(deleted))))
(define warnings-area (new stepper-warnings% (parent area)))
(define sbview (new stepper-syntax-widget%
(parent area)
(macro-stepper this)))
(define sbc (send sbview get-controller))
(define control-pane
(new vertical-panel% (parent area) (stretchable-height #f)))
(define macro-hiding-prefs
(new macro-hiding-prefs-widget%
(parent control-pane)
(stepper this)
(config config)))
(send config listen-show-syntax-properties?
(lambda (show?) (send sbview show-props show?)))
(send config listen-show-hiding-panel?
(lambda (show?) (show-macro-hiding-prefs show?)))
(send sbc listen-selected-syntax
(lambda (stx) (send macro-hiding-prefs set-syntax stx)))
(send config listen-highlight-foci?
(lambda (_) (update/preserve-view)))
(send config listen-highlight-frontier?
(lambda (_) (update/preserve-view)))
(send config listen-show-rename-steps?
(lambda (_) (refresh/re-reduce)))
(send config listen-one-by-one?
(lambda (_) (refresh/re-reduce)))
(send config listen-force-letrec-transformation?
(lambda (_) (refresh/resynth)))
(send config listen-extra-navigation?
(lambda (show?) (show-extra-navigation show?)))
(define nav:up
(new button% (label "Previous term") (parent navigator)
(callback (lambda (b e) (navigate-up)))))
(define nav:start
(new button% (label "<-- Start") (parent navigator)
(callback (lambda (b e) (navigate-to-start)))))
(define nav:previous
(new button% (label "<- Step") (parent navigator)
(callback (lambda (b e) (navigate-previous)))))
(define nav:next
(new button% (label "Step ->") (parent navigator)
(callback (lambda (b e) (navigate-next)))))
(define nav:end
(new button% (label "End -->") (parent navigator)
(callback (lambda (b e) (navigate-to-end)))))
(define nav:down
(new button% (label "Next term") (parent navigator)
(callback (lambda (b e) (navigate-down)))))
(define/private (trim-navigator)
(if (> (length (cursor->list terms)) 1)
(send navigator change-children
(lambda _
(list nav:up
nav:start
nav:previous
nav:next
nav:end
nav:down)))
(send navigator change-children
(lambda _
(list nav:start
nav:previous
nav:next
nav:end)))))
(define/public (show-macro-hiding-prefs show?)
(send area change-children
(lambda (children)
(if show?
(append (remq control-pane children) (list control-pane))
(remq control-pane children)))))
(define/private (show-extra-navigation show?)
(send supernavigator change-children
(lambda (children)
(if show?
(list navigator extra-navigator)
(list navigator)))))
;; Navigation
(define/public-final (at-start?)
(send (focused-term) at-start?))
(define/public-final (at-end?)
(send (focused-term) at-end?))
(define/public-final (navigate-to-start)
(send (focused-term) navigate-to-start)
(update/save-position))
(define/public-final (navigate-to-end)
(send (focused-term) navigate-to-end)
(update/save-position))
(define/public-final (navigate-previous)
(send (focused-term) navigate-previous)
(update/save-position))
(define/public-final (navigate-next)
(send (focused-term) navigate-next)
(update/save-position))
(define/public-final (navigate-up)
(when (focused-term)
(send (focused-term) on-lose-focus))
(cursor:move-prev terms)
(refresh/move))
(define/public-final (navigate-down)
(when (focused-term)
(send (focused-term) on-lose-focus))
(cursor:move-next terms)
(refresh/move))
;; Update
;; update/save-position : -> void
(define/private (update/save-position)
(update/preserve-lines-view))
;; update/preserve-lines-view : -> void
(define/public (update/preserve-lines-view)
(define text (send sbview get-text))
(define start-box (box 0))
(define end-box (box 0))
(send text get-visible-line-range start-box end-box)
(update)
(send text scroll-to-position
(send text line-start-position (unbox start-box))
#f
(send text line-start-position (unbox end-box))
'start))
;; update/preserve-view : -> void
(define/public (update/preserve-view)
(define text (send sbview get-text))
(define start-box (box 0))
(define end-box (box 0))
(send text get-visible-position-range start-box end-box)
(update)
(send text scroll-to-position (unbox start-box) #f (unbox end-box) 'start))
;; update : -> void
;; Updates the terms in the syntax browser to the current step
(define/private (update)
(define text (send sbview get-text))
(define position-of-interest 0)
(define multiple-terms? (> (length (cursor->list terms)) 1))
(send text begin-edit-sequence)
(send sbview erase-all)
(define warnings-area (new stepper-warnings% (parent area))) (update:show-prefix)
(when multiple-terms? (send sbview add-separator))
(define sbview (new stepper-syntax-widget% (set! position-of-interest (send text last-position))
(parent area) (update:show-current-step)
(macro-stepper this))) (when multiple-terms? (send sbview add-separator))
(define sbc (send sbview get-controller)) (update:show-suffix)
(define control-pane (send text end-edit-sequence)
(new vertical-panel% (parent area) (stretchable-height #f))) (send text scroll-to-position
(define macro-hiding-prefs position-of-interest
(new macro-hiding-prefs-widget% #f
(parent control-pane) (send text last-position)
(stepper this) 'start)
(config config))) (enable/disable-buttons))
(send config listen-show-syntax-properties? ;; update:show-prefix : -> void
(lambda (show?) (send sbview show-props show?))) (define/private (update:show-prefix)
(send config listen-show-hiding-panel? ;; Show the final terms from the cached synth'd derivs
(lambda (show?) (show-macro-hiding-prefs show?))) (for-each (lambda (trec) (send trec display-final-term))
(send sbc listen-selected-syntax (cursor:prefix->list terms)))
(lambda (stx) (send macro-hiding-prefs set-syntax stx)))
(send config listen-highlight-foci?
(lambda (_) (update/preserve-view)))
(send config listen-highlight-frontier?
(lambda (_) (update/preserve-view)))
(send config listen-show-rename-steps?
(lambda (_) (refresh/re-reduce)))
(send config listen-one-by-one?
(lambda (_) (refresh/re-reduce)))
(send config listen-force-letrec-transformation?
(lambda (_) (refresh/resynth)))
(send config listen-extra-navigation?
(lambda (show?) (show-extra-navigation show?)))
(define nav:up ;; update:show-current-step : -> void
(new button% (label "Previous term") (parent navigator) (define/private (update:show-current-step)
(callback (lambda (b e) (navigate-up))))) (when (focused-term)
(define nav:start (send (focused-term) display-step)))
(new button% (label "<-- Start") (parent navigator)
(callback (lambda (b e) (navigate-to-start)))))
(define nav:previous
(new button% (label "<- Step") (parent navigator)
(callback (lambda (b e) (navigate-previous)))))
(define nav:next
(new button% (label "Step ->") (parent navigator)
(callback (lambda (b e) (navigate-next)))))
(define nav:end
(new button% (label "End -->") (parent navigator)
(callback (lambda (b e) (navigate-to-end)))))
(define nav:down
(new button% (label "Next term") (parent navigator)
(callback (lambda (b e) (navigate-down)))))
(define/private (trim-navigator) ;; update:show-suffix : -> void
(if (> (length (cursor->list terms)) 1) (define/private (update:show-suffix)
(send navigator change-children (let ([suffix0 (cursor:suffix->list terms)])
(lambda _ (when (pair? suffix0)
(list nav:up (for-each (lambda (trec)
nav:start (send trec display-initial-term))
nav:previous (cdr suffix0)))))
nav:next
nav:end
nav:down)))
(send navigator change-children
(lambda _
(list nav:start
nav:previous
nav:next
nav:end)))))
(define/public (show-macro-hiding-prefs show?) ;; enable/disable-buttons : -> void
(send area change-children (define/private (enable/disable-buttons)
(lambda (children) (define term (focused-term))
(if show? (send nav:start enable (and term (send term has-prev?)))
(append (remq control-pane children) (list control-pane)) (send nav:previous enable (and term (send term has-prev?)))
(remq control-pane children))))) (send nav:next enable (and term (send term has-next?)))
(send nav:end enable (and term (send term has-next?)))
(send nav:up enable (cursor:has-prev? terms))
(send nav:down enable (cursor:has-next? terms)))
(define/private (show-extra-navigation show?) ;; --
(send supernavigator change-children
(lambda (children)
(if show?
(list navigator extra-navigator)
(list navigator)))))
;; Navigation ;; refresh/resynth : -> void
;; Macro hiding policy has changed; invalidate cached parts of trec
(define/public (refresh/resynth)
(for-each (lambda (trec) (send trec invalidate-synth!))
(cursor->list terms))
(refresh))
(define/public-final (at-start?) ;; refresh/re-reduce : -> void
(send (focused-term) at-start?)) ;; Reduction config has changed; invalidate cached parts of trec
(define/public-final (at-end?) (define/private (refresh/re-reduce)
(send (focused-term) at-end?)) (for-each (lambda (trec) (send trec invalidate-steps!))
(cursor->list terms))
(refresh))
(define/public-final (navigate-to-start) ;; refresh/move : -> void
(send (focused-term) navigate-to-start) ;; Moving between terms; clear the saved position
(update/save-position)) (define/private (refresh/move)
(define/public-final (navigate-to-end) (refresh))
(send (focused-term) navigate-to-end)
(update/save-position))
(define/public-final (navigate-previous)
(send (focused-term) navigate-previous)
(update/save-position))
(define/public-final (navigate-next)
(send (focused-term) navigate-next)
(update/save-position))
(define/public-final (navigate-up) ;; refresh : -> void
(when (focused-term) (define/public (refresh)
(send (focused-term) on-lose-focus)) (send warnings-area clear)
(cursor:move-prev terms) (when (focused-term)
(refresh/move)) (send (focused-term) on-get-focus))
(define/public-final (navigate-down) (update))
(when (focused-term)
(send (focused-term) on-lose-focus))
(cursor:move-next terms)
(refresh/move))
;; Update ;; delayed-recache-errors : (list-of (cons exn string))
(define delayed-recache-errors null)
;; update/save-position : -> void ;; handle-recache-error : exception string -> void
(define/private (update/save-position) (define/private (handle-recache-error exn part)
(update/preserve-lines-view)) (if (send config get-debug-catch-errors?)
(begin
(set! delayed-recache-errors
(cons (cons exn part) delayed-recache-errors))
(queue-callback
(lambda ()
(when (pair? delayed-recache-errors)
(message-box
"Error"
(string-append
"Internal errors in macro stepper:\n"
(if (memq 'macro-hiding (map cdr delayed-recache-errors))
(string-append
"Macro hiding failed on one or more terms. "
"The macro stepper is showing the terms "
"with macro hiding disabled.\n")
"")
(if (memq 'reductions (map cdr delayed-recache-errors))
(string-append
"The macro stepper failed to compute the reduction sequence "
"for one or more terms.\n")
"")))
(set! delayed-recache-errors null)))))
(raise exn)))
;; update/preserve-lines-view : -> void (define/private (foci x) (if (list? x) x (list x)))
(define/public (update/preserve-lines-view)
(define text (send sbview get-text))
(define start-box (box 0))
(define end-box (box 0))
(send text get-visible-line-range start-box end-box)
(update)
(send text scroll-to-position
(send text line-start-position (unbox start-box))
#f
(send text line-start-position (unbox end-box))
'start))
;; update/preserve-view : -> void
(define/public (update/preserve-view)
(define text (send sbview get-text))
(define start-box (box 0))
(define end-box (box 0))
(send text get-visible-position-range start-box end-box)
(update)
(send text scroll-to-position (unbox start-box) #f (unbox end-box) 'start))
;; update : -> void ;; Hiding policy
;; Updates the terms in the syntax browser to the current step
(define/private (update) (define/public (get-show-macro?)
(define text (send sbview get-text)) (send macro-hiding-prefs get-policy))
(define position-of-interest 0)
(define multiple-terms? (> (length (cursor->list terms)) 1))
(send text begin-edit-sequence)
(send sbview erase-all)
(update:show-prefix)
(when multiple-terms? (send sbview add-separator))
(set! position-of-interest (send text last-position))
(update:show-current-step)
(when multiple-terms? (send sbview add-separator))
(update:show-suffix)
(send text end-edit-sequence)
(send text scroll-to-position
position-of-interest
#f
(send text last-position)
'start)
(enable/disable-buttons))
;; update:show-prefix : -> void ;; Derivation pre-processing
(define/private (update:show-prefix)
;; Show the final terms from the cached synth'd derivs
(for-each (lambda (trec) (send trec display-final-term))
(cursor:prefix->list terms)))
;; update:show-current-step : -> void (define/public (get-preprocess-deriv) (lambda (d) d))
(define/private (update:show-current-step)
(when (focused-term)
(send (focused-term) display-step)))
;; update:show-suffix : -> void ;; Initialization
(define/private (update:show-suffix)
(let ([suffix0 (cursor:suffix->list terms)])
(when (pair? suffix0)
(for-each (lambda (trec)
(send trec display-initial-term))
(cdr suffix0)))))
;; enable/disable-buttons : -> void (super-new)
(define/private (enable/disable-buttons) (send sbview show-props (send config get-show-syntax-properties?))
(define term (focused-term)) (show-macro-hiding-prefs (send config get-show-hiding-panel?))
(send nav:start enable (and term (send term has-prev?))) (show-extra-navigation (send config get-extra-navigation?))
(send nav:previous enable (and term (send term has-prev?))) (refresh/move)
(send nav:next enable (and term (send term has-next?))) ))
(send nav:end enable (and term (send term has-next?)))
(send nav:up enable (cursor:has-prev? terms))
(send nav:down enable (cursor:has-next? terms)))
;; -- (define (macro-stepper-widget/process-mixin %)
(class %
(super-new)
(define/override (get-preprocess-deriv)
(lambda (d) (get-original-part d)))
;; refresh/resynth : -> void ;; get-original-part : Deriv -> Deriv/#f
;; Macro hiding policy has changed; invalidate cached parts of trec ;; Strip off mzscheme's #%top-interaction
(define/public (refresh/resynth) ;; Careful: the #%top-interaction node may be inside of a lift-deriv
(for-each (lambda (trec) (send trec invalidate-synth!)) (define/private (get-original-part deriv)
(cursor->list terms)) (let ([deriv* (adjust-deriv/lift deriv)])
(refresh)) deriv*))
;; adjust-deriv/lift : Derivation -> (list-of Derivation)
(define/private (adjust-deriv/lift deriv)
(match deriv
[(Wrap lift-deriv (e1 e2 first lifted-stx second))
(let ([first (adjust-deriv/top first)])
(and first
(let ([e1 (wderiv-e1 first)])
(make-lift-deriv e1 e2 first lifted-stx second))))]
[else (adjust-deriv/top deriv)]))
;; refresh/re-reduce : -> void ;; adjust-deriv/top : Derivation -> Derivation
;; Reduction config has changed; invalidate cached parts of trec (define/private (adjust-deriv/top deriv)
(define/private (refresh/re-reduce) (if (syntax-source (wderiv-e1 deriv))
(for-each (lambda (trec) (send trec invalidate-steps!)) deriv
(cursor->list terms)) ;; It's not original...
(refresh)) ;; Strip out mzscheme's top-interactions
;; Keep anything that is a non-mzscheme top-interaction
;; Drop everything else (not original program)
(match deriv
[(Wrap mrule (e1 e2 tx next))
(match tx
[(Wrap transformation (e1 e2 rs ?1 me1 locals ?2 me2 seq))
(cond [(ormap (lambda (x) (top-interaction-kw? x))
rs)
;; Just mzscheme's top-interaction; strip it out
(adjust-deriv/top next)]
[(equal? (map syntax-e rs) '(#%top-interaction))
;; A *different* top interaction; keep it
deriv]
[else
;; Not original and not tagged with top-interaction
#f])])]
[else #f])))
;; refresh/move : -> void (define/public (top-interaction-kw? x)
;; Moving between terms; clear the saved position (free-identifier=? x #'#%top-interaction))
(define/private (refresh/move)
(refresh))
;; refresh : -> void ))
(define/public (refresh)
(send warnings-area clear)
(when (focused-term)
(send (focused-term) on-get-focus))
(update))
;; delayed-recache-errors : (list-of (cons exn string))
(define delayed-recache-errors null)
;; handle-recache-error : exception string -> void
(define/private (handle-recache-error exn part)
(if (send config get-debug-catch-errors?)
(begin
(set! delayed-recache-errors
(cons (cons exn part) delayed-recache-errors))
(queue-callback
(lambda ()
(when (pair? delayed-recache-errors)
(message-box
"Error"
(string-append
"Internal errors in macro stepper:\n"
(if (memq 'macro-hiding (map cdr delayed-recache-errors))
(string-append
"Macro hiding failed on one or more terms. "
"The macro stepper is showing the terms "
"with macro hiding disabled.\n")
"")
(if (memq 'reductions (map cdr delayed-recache-errors))
(string-append
"The macro stepper failed to compute the reduction sequence "
"for one or more terms.\n")
"")))
(set! delayed-recache-errors null)))))
(raise exn)))
(define/private (foci x) (if (list? x) x (list x)))
;; Hiding policy
(define/public (get-show-macro?)
(send macro-hiding-prefs get-policy))
;; Derivation pre-processing
(define/public (get-preprocess-deriv) (lambda (d) d))
;; Initialization
(super-new)
(send sbview show-props (send config get-show-syntax-properties?))
(show-macro-hiding-prefs (send config get-show-hiding-panel?))
(show-extra-navigation (send config get-extra-navigation?))
(refresh/move)
))
(define (macro-stepper-widget/process-mixin %)
(class %
(super-new)
(define/override (get-preprocess-deriv)
(lambda (d) (get-original-part d)))
;; get-original-part : Deriv -> Deriv/#f
;; Strip off mzscheme's #%top-interaction
;; Careful: the #%top-interaction node may be inside of a lift-deriv
(define/private (get-original-part deriv)
(let ([deriv* (adjust-deriv/lift deriv)])
deriv*))
;; adjust-deriv/lift : Derivation -> (list-of Derivation)
(define/private (adjust-deriv/lift deriv)
(match deriv
[(Wrap lift-deriv (e1 e2 first lifted-stx second))
(let ([first (adjust-deriv/top first)])
(and first
(let ([e1 (wderiv-e1 first)])
(make-lift-deriv e1 e2 first lifted-stx second))))]
[else (adjust-deriv/top deriv)]))
;; adjust-deriv/top : Derivation -> Derivation
(define/private (adjust-deriv/top deriv)
(if (syntax-source (wderiv-e1 deriv))
deriv
;; It's not original...
;; Strip out mzscheme's top-interactions
;; Keep anything that is a non-mzscheme top-interaction
;; Drop everything else (not original program)
(match deriv
[(Wrap mrule (e1 e2 tx next))
(match tx
[(Wrap transformation (e1 e2 rs ?1 me1 locals ?2 me2 seq))
(cond [(ormap (lambda (x) (top-interaction-kw? x))
rs)
;; Just mzscheme's top-interaction; strip it out
(adjust-deriv/top next)]
[(equal? (map syntax-e rs) '(#%top-interaction))
;; A *different* top interaction; keep it
deriv]
[else
;; Not original and not tagged with top-interaction
#f])])]
[else #f])))
(define/public (top-interaction-kw? x)
(module-identifier=? x #'#%top-interaction))
))
)

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

File diff suppressed because it is too large Load Diff

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