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

macro-stepper: smooth rounded rectangles

Browse Source 
Closes PR 11489

original commit: af7f60f3b518e1a021daae9ff99ef160681320f4
This commit is contained in:
Ryan Culpepper 2010-12-15 11:58:56 -07:00
commit e6d3233f0c
48 changed files with 1831 additions and 756 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

340
collects/macro-debugger/analysis/check-requires.rkt Normal file
View File

@ -0,0 +1,340 @@
#lang racket/base
(require racket/contract
racket/match
racket/dict
unstable/struct
syntax/modresolve
syntax/stx
syntax/id-table
macro-debugger/model/deriv
"private/reftable.rkt"
"private/nom-use-alg.rkt"
"private/util.rkt")
(provide/contract
[check-requires (-> module-path? list?)]
[add-disappeared-uses? (parameter/c boolean?)]
[mpi->key (-> module-path-index? any/c)])
#|
The purpose of this script is to estimate a module's useless requires.
Usage:
(check-requires <module-name>)
Examples:
(check-requires 'typed-scheme)
(check-requires 'unstable/markparam)
(check-requires 'macro-debugger/syntax-browser/widget)
The procedure prints one line per (non-label) require in the following
format:
KEEP <module> at <phase> <optional-comment>
- The require must be kept because bindings defined within it are used.
- The optional comment indicates if the require must be kept
- only because its bindings are re-exported
- only because the whitelist DB says so
BYPASS <module> at <phase>
- The require is used, but only for bindings that could be more directly
obtained via another module. For example, 'racket' can be bypassed in favor
of some subset of 'racket/base', 'racket/contract', etc.
DROP <module> at <phase>
- The require appears to be unused. Unless it must be kept for side
effects or for bindings of a very unusual macro, it can be dropped
entirely.
Notes:
BYPASS recommendations should often be disregarded, because the
required module is expressly intended as an aggregation module and the
only way to bypass it would be to require private modules
directly. See TODO for plans to improve BYPASS recommendations.
Ignore recommendations to DROP or BYPASS modules with side
effects. Read the section below (How it works) and also see the docs
for 'module-db' for whitelisting side-effectful modules.
The script is not intelligent about the language, which causes
certain spurious recommendations to appear frequently. For example,
DROP scheme/mzscheme at 1
means that the module's language is mzscheme, which automatically
inserts (require-for-syntax scheme/mzscheme). It's infeasible to
remove it except by rewriting the module in scheme/base or
racket/base.
========
How it works
Determining whether a require is actually useless is impossible: a
module may be required for compile-time side effect only, and there's
no way to monitor that.
Here are some approximations that are feasible to calculate:
NOM-USES = A require R is "used" by a module M if, during the
compilation of M, a reference is resolved to a binding exported by R.
DEF-USES = A require R is "used" by a module M if, during the
compilation of M, a reference is resolved to a binding defined in R.
The limitations:
- misses side-effects
- misses identifiers recognized via 'free-identifier=?'
(But those should be recorded as 'disappeared-use anyway.)
|#
;; ========
(define add-disappeared-uses? (make-parameter #t))
;; ========
;; phase : (parameterof nat)
(define phase (make-parameter 0))
;; ========
;; analyze : *Deriv* RefTable -> void
;; *Deriv* = Deriv | LDeriv | BRule | ModRule | ... (anything from deriv.rkt)
(define (analyze deriv refs)
(define (recur . args)
(let check ([arg args])
(cond [(syntax? arg) (error 'whoops "arg = ~s" arg)]
[(list? arg) (for-each check arg)]
[else (void)]))
(for ([arg (in-list args)])
(if (list? arg)
(apply recur arg)
(analyze arg refs))))
(define (add! ids)
(reftable-add-all! refs (phase) ids))
;; (printf "analyze ~.s\n" deriv)
;; Handle common base (ie, resolves) part of derivs, if applicable
(match deriv
[(base z1 z2 resolves ?1)
(add! resolves)
(when (and (syntax? z2) (add-disappeared-uses?))
(let ([uses (syntax-property z2 'disappeared-use)])
(add! (let loop ([x uses] [onto null])
(cond [(identifier? x) (cons x onto)]
[(pair? x) (loop (car x) (loop (cdr x) onto))]
[else onto])))))]
[_
(void)])
;; Handle individual variants
(match deriv
[(lift-deriv z1 z2 first lift-stx second)
(recur first second)]
[(tagrule z1 z2 tagged-stx next)
(recur next)]
[(lift/let-deriv z1 z2 first lift-stx second)
(recur first second)]
[(mrule z1 z2 rs ?1 me1 locals me2 ?2 etx next)
(recur locals next)]
[(local-exn exn)
(void)]
[(local-expansion z1 z2 for-stx? me1 inner lifted me2 opaque)
(parameterize ((phase (+ (phase) (if for-stx? 1 0))))
(recur inner))]
[(local-lift expr ids)
(void)]
[(local-lift-end decl)
(void)]
[(local-lift-require req expr mexpr)
(void)]
[(local-lift-provide prov)
(void)]
[(local-bind names ?1 renames bindrhs)
(recur bindrhs)]
[(local-value name ?1 resolves bound?)
(when (and bound? resolves)
(add! (cons name resolves)))]
[(track-origin before after)
(void)]
[(local-remark contents)
(void)]
[(p:variable z1 z2 rs ?1)
(void)]
[(p:module z1 z2 rs ?1 locals tag rename check tag2 ?3 body shift)
(recur locals check body)]
[(p:#%module-begin z1 z2 rs ?1 me pass1 pass2 ?2)
(recur pass1 pass2)]
[(p:define-syntaxes z1 z2 rs ?1 rhs locals)
(parameterize ((phase (+ (phase) 1)))
(recur rhs locals))]
[(p:define-values z1 z2 rs ?1 rhs)
(recur rhs)]
[(p:#%expression z1 z2 rs ?1 inner untag)
(recur inner)]
[(p:if z1 z2 rs ?1 test then else)
(recur test then else)]
[(p:wcm z1 z2 rs ?1 key mark body)
(recur key mark body)]
[(p:set! _ _ _ _ id-resolves ?2 rhs)
(add! id-resolves)
(recur rhs)]
[(p:set!-macro _ _ _ _ deriv)
(recur deriv)]
[(p:#%app _ _ _ _ lderiv)
(recur lderiv)]
[(p:begin _ _ _ _ lderiv)
(recur lderiv)]
[(p:begin0 _ _ _ _ first lderiv)
(recur first lderiv)]
[(p:lambda _ _ _ _ renames body)
(recur body)]
[(p:case-lambda _ _ _ _ renames+bodies)
(recur renames+bodies)]
[(p:let-values _ _ _ _ renames rhss body)
(recur rhss body)]
[(p:letrec-values _ _ _ _ renames rhss body)
(recur rhss body)]
[(p:letrec-syntaxes+values _ _ _ _ srenames sbindrhss vrenames vrhss body tag)
(recur sbindrhss vrhss body)]
[(p:provide _ _ _ _ inners ?2)
(recur inners)]
[(p:require _ _ _ _ locals)
(recur locals)]
[(p:#%stratified-body _ _ _ _ bderiv)
(recur bderiv)]
[(p:stop _ _ _ _) (void)]
[(p:unknown _ _ _ _) (void)]
[(p:#%top _ _ _ _)
(void)]
[(p:#%datum _ _ _ _) (void)]
[(p:quote _ _ _ _) (void)]
[(p:quote-syntax z1 z2 _ _)
(when z2 (analyze/quote-syntax z2 refs))]
[(p:#%variable-reference _ _ _ _)
;; FIXME
(void)]
[(lderiv _ _ ?1 derivs)
(recur derivs)]
[(bderiv _ _ pass1 trans pass2)
(recur pass1 pass2)]
[(b:error ?1)
(void)]
[(b:expr _ head)
(recur head)]
[(b:splice _ head ?1 tail ?2)
(recur head)]
[(b:defvals _ head ?1 rename ?2)
(recur head)]
[(b:defstx _ head ?1 rename ?2 bindrhs)
(recur head bindrhs)]
[(bind-syntaxes rhs locals)
(parameterize ((phase (+ 1 (phase))))
(recur rhs locals))]
[(clc ?1 renames body)
(recur body)]
[(mod:prim head rename prim)
(recur head prim)]
[(mod:splice head rename ?1 tail)
(recur head)]
[(mod:lift head renames tail)
(recur head)]
[(mod:lift-end tail)
(void)]
[(mod:cons head)
(recur head)]
[(mod:skip)
(void)]
[(ecte _ _ locals first second locals2)
(recur locals first second locals2)]
[#f
(void)]))
;; analyze/quote-syntax : stx RefTable -> void
;; Current approach: estimate that an identifier in a syntax template
;; may be used at (sub1 (phase)) or (phase).
;; FIXME: Allow for more conservative choices, too.
;; FIXME: #%top, #%app, #%datum, etc?
;; FIXME: Track tentative (in quote-syntax) references separately?
(define (analyze/quote-syntax qs-stx refs)
(let ([phases (list (phase) (sub1 (phase)))]
[stx (syntax-case qs-stx ()
[(_quote-syntax x) #'x])])
(define (add! id)
(for ([phase (in-list phases)])
(reftable-add! refs phase id)))
(let loop ([stx stx])
(let ([d (if (syntax? stx) (syntax-e stx) stx)])
(cond [(identifier? stx) (add! stx)]
[(pair? d)
(loop (car d))
(loop (cdr d))]
[(vector? d)
(map loop (vector->list d))]
[(prefab-struct-key d)
(map loop (struct->list d))]
[(box? d)
(loop (unbox d))]
[else
(void)])))))
;; ========
#|
A recommendation is one of
(list 'keep module-path-index phase string/#f)
(list 'bypass module-path-index phase)
(list 'drop module-path-index phase)
|#
;; check-requires : module-path -> (listof recommendation)
(define (check-requires mod-path)
(let-values ([(compiled deriv) (get-module-code/trace mod-path)])
(let ([refs (new-reftable)])
(analyze deriv refs)
(nom-use-alg refs compiled))))
#|
TODO
====
Elaborate on BYPASS recommendations by finding the necessary modules
further up the require chain to require directly.
- don't recommend private modules, though... heuristic
Let user provide database of modules that should never be dropped, eg
because they have side effects.
- wouldn't it be awesome if this db could be a datalog program?
- start simpler, though
Verbose mode should show identifiers used by a module (for KEEP).
For example, if only one used, good candidate to split out, if possible.
Ambitious mode could analyze module and recommend ways to split module
into independent submodules.
More options for quote-syntax handling & explain current heuristic better.
Handle for-label.
|#

27
collects/macro-debugger/analysis/private/moduledb.rkt Normal file
View File

@ -0,0 +1,27 @@
#lang racket/base
(require syntax/modresolve)
(provide module-db)
;; A ModuleDB = hash[path/symbol => (U 'no-drop 'no-bypass)]
;; 'no-drop = must not be dropped or bypassed because of, eg, side effects
;; 'no-bypass = don't bypass in favor of private component modules
;; but if the module is unused, can drop it
;; (FIXME: replace with component module calculation and checking)
(define (make-module-db mod+config-list)
(for/hash ([mod+config (in-list mod+config-list)])
(values (resolve-module-path (car mod+config) #f) (cadr mod+config))))
;; module-db : ModuleDB
(define module-db
(make-module-db
'([racket/base no-bypass]
[racket/contract/base no-bypass]
[racket/gui no-bypass]
[racket/match no-bypass]
['#%builtin no-drop]
[typed-scheme/private/base-env no-drop]
[typed-scheme/private/base-special-env no-drop]
[typed-scheme/private/base-env-numeric no-drop]
[typed-scheme/private/base-env-indexing no-drop])))

109
collects/macro-debugger/analysis/private/nom-use-alg.rkt Normal file
View File

@ -0,0 +1,109 @@
#lang racket/base
(require racket/dict
racket/match
"reftable.rkt"
"moduledb.rkt"
"util.rkt")
(provide nom-use-alg)
;; sMPI = S-expr form of mpi (see mpi->key)
;; Using MPIs doesn't work. I conjecture that the final module shift means that
;; all during-expansion MPIs are different from all compiled-expr MPIs.
;; A UsedTable = hash[(list int sMPI) => list]
;; calculate-used-approximations : RefTable -> (values UsedTable UsedTable)
(define (calculate-used-approximations refs)
(let ([NOM-USES (make-hash)]
[DEF-USES (make-hash)])
(for* ([(use-phase id-table) (in-hash refs)]
[id (in-dict-keys id-table)])
;; Only look at identifiers written in module being examined.
;; (Otherwise, nom-mod & nom-phase aren't enough info (???)
(when (here-mpi? (syntax-source-module id)) ;; REDUNDANT
(let ([b (identifier-binding id use-phase)])
(match b
[(list def-mod def-sym nom-mod nom-sym
def-phase nom-imp-phase nom-exp-phase)
;; use-phase = def-phase + required-phase
;; thus required-phase = use-phase - def-phase
(let* ([required-phase (- use-phase def-phase)]
[key (list required-phase (mpi->key def-mod))])
(hash-set! DEF-USES key
(cons id (hash-ref DEF-USES key null))))
;; use-phase = nom-imp-phase + nom-exp-phase ?????
;; We just care about nom-imp-phase, since importing into *here*
#|
;; FIXME: This check goes wrong on defined-for-syntax ids
(unless (equal? use-phase (+ nom-imp-phase nom-exp-phase))
(error 'calculate
"internal error: phases wrong in ~s @ ~s, binding = ~s"
id use-phase b))
|#
(let ([key (list nom-imp-phase (mpi->key nom-mod))])
(hash-set! NOM-USES key
(cons id (hash-ref NOM-USES key null))))]
[_
(void)]))))
(values NOM-USES DEF-USES)))
;; ========
;; get-requires : compiled-module-expr -> (listof (list int MPI))
(define (get-requires compiled)
(let ([phase+mods-list (module-compiled-imports compiled)])
(for*/list ([phase+mods (in-list phase+mods-list)]
#:when (car phase+mods) ;; Skip for-label requires
[mod (cdr phase+mods)])
(list (car phase+mods) mod))))
;; add-provides! : compiled-module-expr UsedTable UsedTable -> void
(define (add-provides! compiled NOM-USES DEF-USES)
(define (add! mpi phase)
(let ([key (list phase (mpi->key mpi))])
(hash-set! NOM-USES key (cons 'export (hash-ref NOM-USES key null)))
(hash-set! DEF-USES key (cons 'export (hash-ref DEF-USES key null)))))
(let-values ([(vprov sprov) (module-compiled-exports compiled)])
(for* ([phase+exps (in-list (append vprov sprov))]
#:when (car phase+exps) ;; Skip for-label provides
[name+srcs (in-list (cdr phase+exps))]
[src (in-list (cadr name+srcs))])
(let ([name (car name+srcs)])
(match src
[(? module-path-index?)
(add! src 0)]
[(list imp-mod imp-phase-shift imp-name imp-phase-???)
(add! imp-mod imp-phase-shift)])))))
;; ========
;; report : UseTable UseTable (listof (list int mpi)) -> (listof recommendation)
(define (report NOM-USES DEF-USES phase+mod-list)
(for/list ([phase+mod (in-list phase+mod-list)])
(let* ([key (list (car phase+mod) (mpi->key (cadr phase+mod)))]
[db-config
(hash-ref module-db
(resolved-module-path-name
(module-path-index-resolve (cadr phase+mod)))
#f)]
[nom-ids (hash-ref NOM-USES key null)]
[def-ids (hash-ref DEF-USES key null)]
[phase (car phase+mod)]
[mod (cadr phase+mod)]
[name (format "~s at ~s" (mpi->key mod) phase)])
(cond [(and (pair? nom-ids) (pair? def-ids))
(list 'keep mod phase (if (ormap identifier? nom-ids) #f "for exports"))]
[(pair? nom-ids)
(if (memq db-config '(no-bypass no-drop))
(list 'keep mod phase "db says no-bypass")
(list 'bypass mod phase))]
[else
(if (memq db-config '(no-drop))
(list 'keep mod phase "db says no-drop")
(list 'drop mod phase))]))))
;; nom-use-alg : RefTable compiled -> (listof recommendation)
(define (nom-use-alg refs compiled)
(let-values ([(NOM-USES DEF-USES) (calculate-used-approximations refs)])
(add-provides! compiled NOM-USES DEF-USES)
(report NOM-USES DEF-USES (get-requires compiled))))

59
collects/macro-debugger/analysis/private/refine-alg.rkt Normal file
View File

@ -0,0 +1,59 @@
#lang racket/base
;; intern Def, Use?
;; A Def is (def sym resolved-module-path int)
(struct def (sym mod phase) #:prefab)
;; A Use is (use Def int)
;; the offset is (ref-phase - def-phase)
(struct use (def offset) #:prefab)
;; A resolved is path or symbol.
;; An import is (import resolved int)
(struct import (resolved offset))
;; ========
;; uses : hash[Use => #t]
;; reqs : hash[import => mpi]
;; keeps : hash[import => mpi]
#|
(define (refine uses reqs keeps)
(unless (= (hash-count uses) 0)
(direct-def-uses uses reqs keeps)
(recur-on-imports uses reqs keeps)))
|#
(define (hash-choose h)
(let ([i (hash-iterate-first h)])
(and i (hash-iterate-value h i))))
#|
Algorithm for refining bypass modules
loop: set of references (id, phase), set of requires (mod, phase)
for every reference DEFINED* in a require R
mark that require R NEEDED and remove from set
eliminate every reference provided by R
(including re-provides)
now every reference left is re-provided by some remaining require
recur on imports of requires
DEFINED* : really, defined in this module OR imported from a "private" module.
|#
;; ====================
#|
Another algorithm
Put all requires in priority queue, with max-depth-to-kernel
priority...
|#

73
collects/macro-debugger/analysis/private/util.rkt Normal file
View File

@ -0,0 +1,73 @@
#lang racket/base
(require syntax/modcode
syntax/modresolve
macro-debugger/model/trace)
(provide get-module-code/trace
here-mpi?
mpi->key
mpi->list)
;; get-module-derivation : module-path -> (values compiled Deriv)
(define (get-module-code/trace path)
(get-module-code (resolve-module-path path #f)
#:choose (lambda _ 'src)
#:compile (lambda (stx)
(let-values ([(stx deriv) (trace/result stx expand)])
(values (compile stx) deriv)))))
;; here-mpi? : any -> boolean
(define (here-mpi? x)
(and (module-path-index? x)
(let-values ([(rel base) (module-path-index-split x)])
(and (eq? rel #f) (eq? base #f)))))
(define (mpi->key x)
(let ([l (mpi->list x)])
(if (and (pair? l) (null? (cdr l)))
(car l)
l)))
(define (mpi->list x)
(cond [(module-path-index? x)
(let-values ([(rel base) (module-path-index-split x)])
(if rel
(cons rel (mpi->list base))
null))]
[(eq? x #f)
null]
[else
(list x)]))
;; --------
(provide get-module-imports
get-module-exports
get-module-var-exports
get-module-stx-exports)
(struct modinfo (imports var-exports stx-exports) #:prefab)
;; cache : hash[path/symbol => modinfo]
(define cache (make-hash))
(define (get-module-info/no-cache resolved)
(let ([compiled (get-module-code resolved)])
(let-values ([(imports) (module-compiled-imports compiled)]
[(var-exports stx-exports) (module-compiled-exports compiled)])
(modinfo imports var-exports stx-exports))))
(define (get-module-info path)
(let ([resolved (resolve-module-path path #f)])
(hash-ref! cache resolved (lambda () (get-module-info/no-cache resolved)))))
(define (get-module-imports path)
(modinfo-imports (get-module-info path)))
(define (get-module-var-exports path)
(modinfo-var-exports (get-module-info path)))
(define (get-module-stx-exports path)
(modinfo-stx-exports (get-module-info path)))
(define (get-module-exports path)
(let ([info (get-module-info path)])
(values (modinfo-var-exports info) (modinfo-stx-exports info))))

31
collects/macro-debugger/macro-debugger.scrbl
View File

@ -28,29 +28,24 @@ syntax browser uses colors and a properties panel to show the term's
syntax properties, such as lexical binding information and source syntax properties, such as lexical binding information and source
location. location.
@section{Macro stepper} @section{Macro stepper}
@defmodule[macro-debugger/stepper] @defmodule[macro-debugger/stepper]
@defproc[(expand/step [stx any/c]) @defproc[(expand/step [stx any/c])
(is-a/c macro-stepper<%>)]{ void?]{
Expands the syntax (or S-expression) and opens a macro stepper frame Expands the syntax (or S-expression) and opens a macro stepper frame
for stepping through the expansion. for stepping through the expansion.
} }
@definterface[macro-stepper<%> ()]{ @defproc[(expand-module/step [mod module-path?])
void?]{
@defmethod[(at-start?) boolean?] Expands the source file named by @racket[mod], which must contains a
@defmethod[(at-end?) boolean?] single module declaration, and opens a macro stepper frame for
@defmethod[(navigate-to-start) void?] stepping through the expansion.
@defmethod[(navigate-to-end) void?]
@defmethod[(navigate-previous) void?]
@defmethod[(navigate-next) void?]
@defmethod[(at-top?) boolean?]
@defmethod[(at-bottom?) boolean?]
@defmethod[(navigate-up) void?]
@defmethod[(navigate-down) void?]
} }
@section{Macro expansion tools} @section{Macro expansion tools}
@ -139,7 +134,6 @@ transformer returns. Unmarking is suppressed if @scheme[unmark?] is
] ]
(Run the fragment above in the macro stepper.) (Run the fragment above in the macro stepper.)
} }
@defproc[(emit-local-step [before syntax?] [after syntax?] @defproc[(emit-local-step [before syntax?] [after syntax?]
@ -151,9 +145,9 @@ Emits an event that simulates a local expansion step from
The @scheme[id] argument acts as the step's ``macro'' for the purposes The @scheme[id] argument acts as the step's ``macro'' for the purposes
of macro hiding. of macro hiding.
} }
@section{Macro stepper text interface} @section{Macro stepper text interface}
@defmodule[macro-debugger/stepper-text] @defmodule[macro-debugger/stepper-text]
@ -188,6 +182,7 @@ of macro hiding.
@scheme['all] to print out all remaining steps. @scheme['all] to print out all remaining steps.
} }
@section{Syntax browser} @section{Syntax browser}
@defmodule[macro-debugger/syntax-browser] @defmodule[macro-debugger/syntax-browser]
@ -208,14 +203,6 @@ of macro hiding.
objects. objects.
} }
@;{
@defproc[(syntax-snip [stx syntax?])
(is-a/c snip%)]{
Like @scheme[browse-syntax], but creates a snip that can be
displayed in an editor.
}
}
@section{Using the macro stepper} @section{Using the macro stepper}

2
collects/macro-debugger/model/deriv-c.rkt
View File

@ -39,6 +39,8 @@
(define-struct local-lift-require (req expr mexpr) #:transparent) (define-struct local-lift-require (req expr mexpr) #:transparent)
(define-struct local-lift-provide (prov) #:transparent) (define-struct local-lift-provide (prov) #:transparent)
(define-struct local-bind (names ?1 renames bindrhs) #:transparent) (define-struct local-bind (names ?1 renames bindrhs) #:transparent)
(define-struct local-value (name ?1 resolves bound?) #:transparent)
(define-struct track-origin (before after) #:transparent)
(define-struct local-remark (contents) #:transparent) (define-struct local-remark (contents) #:transparent)
;; contents : (listof (U string syntax)) ;; contents : (listof (U string syntax))

5
collects/macro-debugger/model/deriv-parser.rkt
View File

@ -43,6 +43,7 @@
enter-check exit-check enter-check exit-check
local-post exit-local exit-local/expr local-post exit-local exit-local/expr
local-bind enter-bind exit-bind local-bind enter-bind exit-bind
local-value-result
phase-up module-body phase-up module-body
renames-lambda renames-lambda
renames-case-lambda renames-case-lambda
@ -201,6 +202,10 @@
(make local-bind $1 $2 $3 #f)] (make local-bind $1 $2 $3 #f)]
[(local-bind rename-list (? BindSyntaxes)) [(local-bind rename-list (? BindSyntaxes))
(make local-bind $1 #f $2 $3)] (make local-bind $1 #f $2 $3)]
[(track-origin)
(make track-origin (car $1) (cdr $1))]
[(local-value ! Resolves local-value-result)
(make local-value $1 $2 $3 $4)]
[(local-remark) [(local-remark)
(make local-remark $1)] (make local-remark $1)]
[(local-artificial-step) [(local-artificial-step)

10
collects/macro-debugger/model/deriv-tokens.rkt
View File

@ -61,6 +61,10 @@
local-remark ; (listof (U string syntax)) local-remark ; (listof (U string syntax))
local-artificial-step ; (list syntax syntax syntax syntax) local-artificial-step ; (list syntax syntax syntax syntax)
track-origin ; (cons stx stx)
local-value ; identifier
local-value-result ; boolean
)) ))
(define-tokens renames-tokens (define-tokens renames-tokens
@ -175,8 +179,10 @@
(149 prim-varref) (149 prim-varref)
(150 lift-require ,token-lift-require) (150 lift-require ,token-lift-require)
(151 lift-provide ,token-lift-provide) (151 lift-provide ,token-lift-provide)
(155 prim-#%stratified-body) (152 track-origin ,token-track-origin)
)) (153 local-value ,token-local-value)
(154 local-value-result ,token-local-value-result)
(155 prim-#%stratified-body)))
(define (signal->symbol sig) (define (signal->symbol sig)
(if (symbol? sig) (if (symbol? sig)

2
collects/macro-debugger/model/deriv-util.rkt
View File

@ -1,7 +1,5 @@
#lang racket/base #lang racket/base
(require (for-syntax racket/base) (require (for-syntax racket/base)
(for-syntax racket/private/struct-info)
racket/list
racket/match racket/match
unstable/struct unstable/struct
"deriv.rkt") "deriv.rkt")

4
collects/macro-debugger/model/deriv.rkt
View File

@ -1,5 +1,3 @@
#lang racket/base #lang racket/base
(require racket/contract (require "deriv-c.rkt")
syntax/stx
"deriv-c.rkt")
(provide (all-from-out "deriv-c.rkt")) (provide (all-from-out "deriv-c.rkt"))

3
collects/macro-debugger/model/hiding-policies.rkt
View File

@ -1,6 +1,5 @@
#lang racket/base #lang racket/base
(require (for-syntax racket/base) (require racket/match
racket/match
"reductions-config.rkt" "reductions-config.rkt"
"../util/mpi.rkt") "../util/mpi.rkt")
(provide policy->predicate) (provide policy->predicate)

28
collects/macro-debugger/model/reductions-config.rkt
View File

@ -1,9 +1,8 @@
#lang racket/base #lang racket/base
(require (for-syntax racket/base) (require (for-syntax racket/base)
racket/list
racket/contract racket/contract
racket/match racket/match
"deriv.rkt" "../util/eomap.rkt"
"deriv-util.rkt" "deriv-util.rkt"
"stx-util.rkt" "stx-util.rkt"
"context.rkt" "context.rkt"
@ -35,8 +34,8 @@
[big-context (parameter/c big-context/c)] [big-context (parameter/c big-context/c)]
[marking-table (parameter/c (or/c hash? false/c))] [marking-table (parameter/c (or/c hash? false/c))]
[current-binders (parameter/c (listof identifier?))] [current-binders (parameter/c (listof identifier?))]
[current-definites (parameter/c (listof identifier?))] [current-definites (parameter/c eomap?)] ;; eomap[identifier => phase-level]
[current-binders (parameter/c (listof identifier?))] [current-binders (parameter/c hash?)] ;; hash[identifier => phase-level]
[current-frontier (parameter/c (listof syntax?))] [current-frontier (parameter/c (listof syntax?))]
[sequence-number (parameter/c (or/c false/c exact-nonnegative-integer?))] [sequence-number (parameter/c (or/c false/c exact-nonnegative-integer?))]
[phase (parameter/c exact-nonnegative-integer?)] [phase (parameter/c exact-nonnegative-integer?)]
@ -82,11 +81,11 @@
;; marking-table ;; marking-table
(define marking-table (make-parameter #f)) (define marking-table (make-parameter #f))
;; current-binders : parameterof (listof identifier) ;; current-binders : parameter of hash[identifier => phase-level]
(define current-binders (make-parameter null)) (define current-binders (make-parameter #f))
;; current-definites : parameter of (list-of identifier) ;; current-definites : parameter of eomap[identifier => phase-level]
(define current-definites (make-parameter null)) (define current-definites (make-parameter #f))
;; current-frontier : parameter of (list-of syntax) ;; current-frontier : parameter of (list-of syntax)
(define current-frontier (make-parameter null)) (define current-frontier (make-parameter null))
@ -151,11 +150,12 @@
(define (learn-definites ids) (define (learn-definites ids)
(current-definites (current-definites
(append ids (current-definites)))) (eomap-set* (current-definites) ids (phase))))
(define (learn-binders ids) (define (learn-binders ids)
(current-binders (current-binders
(append ids (current-binders)))) (for/fold ([binders (current-binders)]) ([id (in-list ids)])
(hash-set binders id (phase)))))
(define (get-frontier) (or (current-frontier) null)) (define (get-frontier) (or (current-frontier) null))
@ -249,9 +249,9 @@
(lambda (stx #:allow-nonstx? [allow-nonstx? #f] #:default [default #f]) (lambda (stx #:allow-nonstx? [allow-nonstx? #f] #:default [default #f])
(let ([replacement (hash-ref table stx #f)]) (let ([replacement (hash-ref table stx #f)])
(if replacement (if replacement
(begin #;(printf " replacing ~s with ~s~n" stx replacement) (begin #;(printf " replacing ~s with ~s\n" stx replacement)
replacement) replacement)
(begin #;(printf " not replacing ~s~n" stx) (begin #;(printf " not replacing ~s\n" stx)
default))))) default)))))
(define (make-renames-table from0 to0) (define (make-renames-table from0 to0)
@ -286,11 +286,11 @@
;; Only bad effect should be missed subterms (usually at phase1). ;; Only bad effect should be missed subterms (usually at phase1).
(STRICT-CHECKS (STRICT-CHECKS
(fprintf (current-error-port) (fprintf (current-error-port)
"from:\n~e\n\nto:\n~e\n\n" "from:\n~.s\n\nto:\n~.s\n\n"
(stx->datum from) (stx->datum from)
(stx->datum to)) (stx->datum to))
(fprintf (current-error-port) (fprintf (current-error-port)
"original from:\n~e\n\noriginal to:\n~e\n\n" "original from:\n~.s\n\noriginal to:\n~.s\n\n"
(stx->datum from0) (stx->datum from0)
(stx->datum to0)) (stx->datum to0))
(error 'add-to-renames-table)) (error 'add-to-renames-table))

66
collects/macro-debugger/model/reductions-engine.rkt
View File

@ -1,9 +1,8 @@
#lang racket/base #lang racket/base
(require (for-syntax racket/base (require (for-syntax racket/base
syntax/parse) syntax/parse
racket/list syntax/parse/experimental/contract)
racket/contract racket/contract
"deriv.rkt"
"deriv-util.rkt" "deriv-util.rkt"
"stx-util.rkt" "stx-util.rkt"
"context.rkt" "context.rkt"
@ -149,7 +148,7 @@
(current-state-with v (with-syntax1 ([p f]) fs)))] (current-state-with v (with-syntax1 ([p f]) fs)))]
[type-var type]) [type-var type])
(DEBUG (DEBUG
(printf "visibility = ~s\n" (visibility)) (printf "visibility = ~s\n" (if (visibility) 'VISIBLE 'HIDDEN))
(printf "step: s1 = ~s\n" s) (printf "step: s1 = ~s\n" s)
(printf "step: s2 = ~s\n\n" s2)) (printf "step: s2 = ~s\n\n" s2))
(let ([ws2 (let ([ws2
@ -289,9 +288,9 @@
[(R** f v p s ws [#:print-state msg] . more) [(R** f v p s ws [#:print-state msg] . more)
#'(begin (printf "** ~s\n" msg) #'(begin (printf "** ~s\n" msg)
(printf "f = ~e\n" (stx->datum f)) (printf "f = ~.s\n" (stx->datum f))
(printf "v = ~e\n" (stx->datum v)) (printf "v = ~.s\n" (stx->datum v))
(printf "s = ~e\n" (stx->datum s)) (printf "s = ~.s\n" (stx->datum s))
(R** f v p s ws . more))] (R** f v p s ws . more))]
;; ** Multi-pass reductions ** ;; ** Multi-pass reductions **
@ -323,7 +322,7 @@
(visibility-off (not previous-pass-hides?) (visibility-off (not previous-pass-hides?)
v v
(lambda () (lambda ()
(print-viable-subterms v) (when #f (print-viable-subterms v))
(R** f v p s ws clause ... => k)) (R** f v p s ws clause ... => k))
#t))] #t))]
@ -365,10 +364,10 @@
[fills fills-e]) [fills fills-e])
(DEBUG (DEBUG
(printf "Run (multi, vis=~s)\n" (visibility)) (printf "Run (multi, vis=~s)\n" (visibility))
(printf " f: ~e\n" (stx->datum f)) (printf " f: ~.s\n" (stx->datum f))
(printf " v: ~e\n" (stx->datum v)) (printf " v: ~.s\n" (stx->datum v))
(printf " p: ~e\n" 'p) (printf " p: ~.s\n" 'p)
(printf " hole: ~e\n" '(hole :::)) (printf " hole: ~.s\n" '(hole :::))
(print-viable-subterms v)) (print-viable-subterms v))
(if (visibility) (if (visibility)
(let ([vctx (CC (hole :::) v p)] (let ([vctx (CC (hole :::) v p)]
@ -381,10 +380,10 @@
[fctx (CC hole f p)]) [fctx (CC hole f p)])
(DEBUG (DEBUG
(printf "Run (single, vis=~s)\n" (visibility)) (printf "Run (single, vis=~s)\n" (visibility))
(printf " f: ~e\n" (stx->datum f)) (printf " f: ~.s\n" (stx->datum f))
(printf " v: ~e\n" (stx->datum v)) (printf " v: ~.s\n" (stx->datum v))
(printf " p: ~e\n" 'p) (printf " p: ~.s\n" 'p)
(printf " hole: ~e\n" 'hole) (printf " hole: ~.s\n" 'hole)
(print-viable-subterms v)) (print-viable-subterms v))
(if (visibility) (if (visibility)
(let ([vctx (CC hole v p)] (let ([vctx (CC hole v p)]
@ -396,8 +395,8 @@
(define (run-one reducer init-e fctx vsub vctx fill s ws k) (define (run-one reducer init-e fctx vsub vctx fill s ws k)
(DEBUG (DEBUG
(printf "run-one\n") (printf "run-one\n")
(printf " fctx: ~e\n" (stx->datum (fctx #'HOLE))) (printf " fctx: ~.s\n" (stx->datum (fctx #'HOLE)))
(printf " vctx: ~e\n" (stx->datum (vctx #'HOLE)))) (printf " vctx: ~.s\n" (stx->datum (vctx #'HOLE))))
(RSbind (with-context vctx (RSbind (with-context vctx
((reducer fill) init-e vsub s ws)) ((reducer fill) init-e vsub s ws))
(lambda (f2 v2 s2 ws2) (k (fctx f2) (vctx v2) s2 ws2)))) (lambda (f2 v2 s2 ws2) (k (fctx f2) (vctx v2) s2 ws2))))
@ -406,12 +405,12 @@
(define (run-multiple/visible reducer init-e1s fctx vsubs vctx fills s ws k) (define (run-multiple/visible reducer init-e1s fctx vsubs vctx fills s ws k)
(DEBUG (DEBUG
(printf "run-multiple/visible\n") (printf "run-multiple/visible\n")
(printf " fctx: ~e\n" (stx->datum (fctx (for/list ([dummy init-e1s]) #'HOLE)))) (printf " fctx: ~.s\n" (stx->datum (fctx (for/list ([dummy init-e1s]) #'HOLE))))
(printf " vctx: ~e\n" (stx->datum (vctx (for/list ([dummy init-e1s]) #'HOLE)))) (printf " vctx: ~.s\n" (stx->datum (vctx (for/list ([dummy init-e1s]) #'HOLE))))
(unless (= (length fills) (length init-e1s)) (unless (= (length fills) (length init-e1s))
(printf " fills(~s): ~e\n" (length fills) fills) (printf " fills(~s): ~.s\n" (length fills) fills)
(printf " init-e1s: ~s\n" (stx->datum init-e1s)) (printf " init-e1s: ~.s\n" (stx->datum init-e1s))
(printf " vsubs: ~s\n" (stx->datum vsubs)))) (printf " vsubs: ~.s\n" (stx->datum vsubs))))
(let loop ([fills fills] [prefix null] [vprefix null] [suffix init-e1s] [vsuffix vsubs] [s s] [ws ws]) (let loop ([fills fills] [prefix null] [vprefix null] [suffix init-e1s] [vsuffix vsubs] [s s] [ws ws])
(cond (cond
[(pair? fills) [(pair? fills)
@ -432,10 +431,10 @@
(define (run-multiple/nonvisible reducer init-e1s fctx v fills s ws k) (define (run-multiple/nonvisible reducer init-e1s fctx v fills s ws k)
(DEBUG (DEBUG
(printf "run-multiple/nonvisible\n") (printf "run-multiple/nonvisible\n")
(printf " fctx: ~e\n" (stx->datum (fctx (for/list ([dummy init-e1s]) #'HOLE))))) (printf " fctx: ~.s\n" (stx->datum (fctx (for/list ([dummy init-e1s]) #'HOLE)))))
(let loop ([fills fills] [prefix null] [suffix init-e1s] [v v] [s s] [ws ws]) (let loop ([fills fills] [prefix null] [suffix init-e1s] [v v] [s s] [ws ws])
(DEBUG (DEBUG
(printf " v: ~e\n" (stx->datum (datum->syntax #f v)))) (printf " v: ~.s\n" (stx->datum (datum->syntax #f v))))
(cond (cond
[(pair? fills) [(pair? fills)
(RSbind ((reducer (car fills)) (car suffix) v s ws) (RSbind ((reducer (car fills)) (car suffix) v s ws)
@ -468,7 +467,7 @@
(cond [(and (not new-visible?) (or (visibility) reset-subterms?)) (cond [(and (not new-visible?) (or (visibility) reset-subterms?))
(begin (begin
(DEBUG (DEBUG
(printf "hide => seek: ~e\n" (stx->datum stx))) (printf "hide => seek: ~.s\n" (stx->datum stx)))
(current-pass-hides? #t) (current-pass-hides? #t)
(let* ([subterms (gather-proper-subterms stx)] (let* ([subterms (gather-proper-subterms stx)]
[marking (marking-table)] [marking (marking-table)]
@ -494,13 +493,16 @@
(define (seek-point stx vstx k) (define (seek-point stx vstx k)
(if (visibility) (if (visibility)
(k vstx) (k vstx)
(begin
(DEBUG (printf "Seek point\n")
(print-viable-subterms stx))
(let ([paths (table-get (subterms-table) stx)]) (let ([paths (table-get (subterms-table) stx)])
(cond [(null? paths) (cond [(null? paths)
(DEBUG (printf "seek-point: failed on ~e\n" (stx->datum stx))) (DEBUG (printf "seek-point: failed on ~.s\n" (stx->datum stx)))
(k vstx)] (k vstx)]
[(null? (cdr paths)) [(null? (cdr paths))
(let ([path (car paths)]) (let ([path (car paths)])
(DEBUG (printf "seek => hide: ~e\n" (stx->datum stx))) (DEBUG (printf "seek => hide: ~.s\n" (stx->datum stx)))
(let ([ctx (lambda (x) (path-replace vstx path x))]) (let ([ctx (lambda (x) (path-replace vstx path x))])
(RScase (parameterize ((visibility #t) (RScase (parameterize ((visibility #t)
(subterms-table #f) (subterms-table #f)
@ -513,7 +515,7 @@
(lambda (ws exn) (lambda (ws exn)
(RSfail ws exn)))))] (RSfail ws exn)))))]
[else [else
(raise (make nonlinearity stx paths))])))) (raise (make nonlinearity stx paths))])))))
(provide print-viable-subterms) (provide print-viable-subterms)
(define (print-viable-subterms stx) (define (print-viable-subterms stx)
@ -538,16 +540,16 @@
[same-form? (equal? actual-datum expected-datum)]) [same-form? (equal? actual-datum expected-datum)])
(if same-form? (if same-form?
(fprintf (current-error-port) (fprintf (current-error-port)
"same form but wrong wrappings:\n~e\nwrongness:\n~e\n" "same form but wrong wrappings:\n~.s\nwrongness:\n~.s\n"
actual-datum actual-datum
(wrongness actual expected)) (wrongness actual expected))
(fprintf (current-error-port) (fprintf (current-error-port)
"got:\n~s\n\nexpected:\n~e\n" "got:\n~.s\n\nexpected:\n~.s\n"
actual-datum actual-datum
expected-datum)) expected-datum))
(for ([d derivs]) (for ([d derivs])
(fprintf (current-error-port) (fprintf (current-error-port)
"\n~e\n" d)) "\n~.s\n" d))
(error function (error function
(if same-form? (if same-form?
"wrong starting point (wraps)!" "wrong starting point (wraps)!"

23
collects/macro-debugger/model/reductions.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base #lang racket/base
(require racket/match (require racket/match
"../util/eomap.rkt"
"stx-util.rkt" "stx-util.rkt"
"deriv-util.rkt" "deriv-util.rkt"
"deriv.rkt" "deriv.rkt"
@ -15,10 +16,13 @@
(let-values ([(steps binders definites estx exn) (reductions+ d)]) (let-values ([(steps binders definites estx exn) (reductions+ d)])
steps)) steps))
;; reductions+ : WDeriv -> (list-of step) (list-of identifier) ?stx ?exn ;; Binders = hasheq[identifier => phase-level]
;; Definites = eomap[identifier => phase-level]
;; reductions+ : WDeriv -> (list-of step) Binders Definites ?stx ?exn
(define (reductions+ d) (define (reductions+ d)
(parameterize ((current-definites null) (parameterize ((current-definites (empty-eomap))
(current-binders null) (current-binders #hasheq())
(current-frontier null) (current-frontier null)
(hides-flags (list (box #f))) (hides-flags (list (box #f)))
(sequence-number 0)) (sequence-number 0))
@ -454,6 +458,19 @@
;; FIXME: use renames ;; FIXME: use renames
[#:binders names] [#:binders names]
[#:when bindrhs => (BindSyntaxes bindrhs)]]] [#:when bindrhs => (BindSyntaxes bindrhs)]]]
[(struct track-origin (before after))
(R)
#|
;; Do nothing for now... need to account for marks also.
[R [#:set-syntax before]
[#:pattern ?form]
[#:rename ?form after 'track-origin]]
|#]
[(struct local-value (name ?1 resolves bound?))
[R [! ?1]
;; [#:learn (list name)]
;; Add remark step?
]]
[(struct local-remark (contents)) [(struct local-remark (contents))
(R [#:reductions (list (walk/talk 'remark contents))])])) (R [#:reductions (list (walk/talk 'remark contents))])]))

6
collects/macro-debugger/model/steps.rkt
View File

@ -1,6 +1,4 @@
#lang racket/base #lang racket/base
(require "deriv.rkt"
"deriv-util.rkt")
(provide (struct-out protostep) (provide (struct-out protostep)
(struct-out step) (struct-out step)
(struct-out misstep) (struct-out misstep)
@ -92,6 +90,7 @@
(splice-module-lifts . "Splice lifted module declarations") (splice-module-lifts . "Splice lifted module declarations")
(remark . "Macro made a remark") (remark . "Macro made a remark")
(track-origin . "Macro called syntax-track-origin")
(error . "Error"))) (error . "Error")))
@ -111,7 +110,8 @@
rename-case-lambda rename-case-lambda
rename-let-values rename-let-values
rename-letrec-values rename-letrec-values
rename-lsv))) rename-lsv
track-origin)))
(define (rewrite-step? x) (define (rewrite-step? x)
(and (step? x) (not (rename-step? x)))) (and (step? x) (not (rename-step? x))))

16
collects/macro-debugger/model/stx-util.rkt
View File

@ -36,10 +36,10 @@
[old-parts (stx->list old-expr)]) [old-parts (stx->list old-expr)])
;; FIXME ;; FIXME
(unless (= (length new-parts) (length old-parts)) (unless (= (length new-parts) (length old-parts))
(printf "** syntax/restamp~n~s~n" (quote-syntax #,stx)) (printf "** syntax/restamp\n~s\n" (quote-syntax #,stx))
(printf "pattern : ~s~n" (syntax->datum #'(pa (... ...)))) (printf "pattern : ~s\n" (syntax->datum #'(pa (... ...))))
(printf "old parts: ~s~n" (map syntax->datum old-parts)) (printf "old parts: ~s\n" (map syntax->datum old-parts))
(printf "new parts: ~s~n" (map syntax->datum new-parts))) (printf "new parts: ~s\n" (map syntax->datum new-parts)))
(d->so (d->so
old-expr old-expr
(map (lambda (new old) (syntax/restamp pa new old)) (map (lambda (new old) (syntax/restamp pa new old))
@ -49,10 +49,10 @@
;; FIXME ;; FIXME
#'(begin #'(begin
(unless (and (stx-pair? new-expr) (stx-pair? old-expr)) (unless (and (stx-pair? new-expr) (stx-pair? old-expr))
(printf "** syntax/restamp~n~s~n" (quote-syntax #,stx)) (printf "** syntax/restamp\n~s\n" (quote-syntax #,stx))
(printf "pattern : ~s~n" (syntax->datum (quote-syntax (pa . pb)))) (printf "pattern : ~s\n" (syntax->datum (quote-syntax (pa . pb))))
(printf "old parts: ~s~n" old-expr) (printf "old parts: ~s\n" old-expr)
(printf "new parts: ~s~n" new-expr)) (printf "new parts: ~s\n" new-expr))
(let ([na (stx-car new-expr)] (let ([na (stx-car new-expr)]
[nb (stx-cdr new-expr)] [nb (stx-cdr new-expr)]
[oa (stx-car old-expr)] [oa (stx-car old-expr)]

3
collects/macro-debugger/model/trace-raw.rkt
View File

@ -2,7 +2,6 @@
(require racket/class (require racket/class
parser-tools/lex parser-tools/lex
"deriv-tokens.rkt" "deriv-tokens.rkt"
"deriv-parser.rkt"
"../syntax-browser.rkt") "../syntax-browser.rkt")
(provide (all-defined-out)) (provide (all-defined-out))
@ -18,7 +17,7 @@
(define val (cdr sig+val)) (define val (cdr sig+val))
(define t (tokenize sig val pos)) (define t (tokenize sig val pos))
(send browser add-text (send browser add-text
(format "Signal: ~s: ~s~n" (format "Signal: ~s: ~s\n"
pos pos
(token-name (position-token-token t)))) (token-name (position-token-token t))))
(when val (when val

19
collects/macro-debugger/model/trace.rkt
View File

@ -1,12 +1,15 @@
#lang racket/base #lang racket/base
(require racket/promise (require racket/promise
syntax/modcode
syntax/modresolve
parser-tools/lex parser-tools/lex
"deriv.rkt"
"deriv-parser.rkt" "deriv-parser.rkt"
"deriv-tokens.rkt") "deriv-tokens.rkt")
(provide trace (provide trace
trace* trace*
trace-module
trace*-module
trace/result trace/result
trace-verbose? trace-verbose?
events->token-generator events->token-generator
@ -26,6 +29,11 @@
(let-values ([(result events derivp) (trace* stx expander)]) (let-values ([(result events derivp) (trace* stx expander)])
(force derivp))) (force derivp)))
;; trace-module : module-path -> Deriv
(define (trace-module module-path)
(let-values ([(result events derivp) (trace*-module module-path)])
(force derivp)))
;; trace/result : stx -> stx/exn Deriv ;; trace/result : stx -> stx/exn Deriv
(define (trace/result stx [expander expand/compile-time-evals]) (define (trace/result stx [expander expand/compile-time-evals])
(let-values ([(result events derivp) (trace* stx expander)]) (let-values ([(result events derivp) (trace* stx expander)])
@ -40,6 +48,13 @@
(delay (parse-derivation (delay (parse-derivation
(events->token-generator events)))))) (events->token-generator events))))))
;; trace*-module : module-path -> stx/exn (listof event) (promiseof Deriv)
(define (trace*-module module-path)
(get-module-code (resolve-module-path module-path #f)
#:choose (lambda _ 'src)
#:compile (lambda (stx)
(trace* stx expand))))
;; 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 1]) (let ([pos 1])
@ -50,7 +65,7 @@
[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))))

3
collects/macro-debugger/stepper-text.rkt
View File

@ -1,6 +1,5 @@
#lang racket/base #lang racket/base
(require racket/list (require racket/pretty
racket/pretty
"model/trace.rkt" "model/trace.rkt"
"model/reductions.rkt" "model/reductions.rkt"
"model/reductions-config.rkt" "model/reductions-config.rkt"

25
collects/macro-debugger/stepper.rkt
View File

@ -1,6 +1,25 @@
#lang racket/base #lang racket/base
(require "view/view.rkt") (require racket/class
(provide expand/step) racket/contract
unstable/class-iop
"model/trace.rkt"
"view/interfaces.rkt"
"view/view.rkt")
(define (create-stepper deriv)
(define director (new macro-stepper-director%))
(define stepper (send/i director director<%> new-stepper))
(send/i director director<%> add-deriv deriv)
(void))
(define (expand/step stx) (define (expand/step stx)
(go stx)) (create-stepper (trace stx)))
(define (expand-module/step module-path)
(create-stepper (trace-module module-path)))
(provide/contract
[expand/step
(-> syntax? void?)]
[expand-module/step
(-> module-path? void?)])

227
collects/macro-debugger/syntax-browser/display.rkt
View File

@ -1,8 +1,10 @@
#lang racket/base #lang racket/base
(require racket/class (require racket/class
racket/gui racket/gui/base
racket/list racket/list
racket/block racket/pretty
racket/promise
data/interval-map
framework framework
unstable/class-iop unstable/class-iop
"pretty-printer.rkt" "pretty-printer.rkt"
@ -12,20 +14,28 @@
(provide print-syntax-to-editor (provide print-syntax-to-editor
code-style) code-style)
(define TIME-PRINTING? #f) (define-syntax-rule (uninterruptible e ...)
;; (coarsely) prevent breaks within editor operations
(parameterize-break #f (begin e ...))
#|
(parameterize-break #f
(let ([ta (now)])
(begin0 (begin e ...)
(let ([tb (now)])
(eprintf "****\n")
(pretty-write '(begin e ...) (current-error-port))
(eprintf " -- ~s ms\n\n" (- tb ta))))))
|#)
(define-syntax-rule (now) (define (now) (current-inexact-milliseconds))
(if TIME-PRINTING?
(current-inexact-milliseconds)
0))
;; FIXME: assumes text never moves ;; FIXME: assumes text never moves
;; print-syntax-to-editor : syntax text controller<%> config number number ;; print-syntax-to-editor : syntax text controller<%> config number number
;; -> display<%> ;; -> display<%>
;; Note: must call display<%>::refresh to finish styling.
(define (print-syntax-to-editor stx text controller config columns (define (print-syntax-to-editor stx text controller config columns
[insertion-point (send text last-position)]) [insertion-point (send text last-position)])
(block
(define output-port (open-output-string/count-lines)) (define output-port (open-output-string/count-lines))
(define range (define range
(pretty-print-syntax stx output-port (pretty-print-syntax stx output-port
@ -37,21 +47,19 @@
(define output-string (get-output-string output-port)) (define output-string (get-output-string output-port))
(define output-length (sub1 (string-length output-string))) ;; skip final newline (define output-length (sub1 (string-length output-string))) ;; skip final newline
(fixup-parentheses output-string range) (fixup-parentheses output-string range)
(send text begin-edit-sequence #f) (with-unlock text
(send text insert output-length output-string insertion-point) (uninterruptible
(define display (send text insert output-length output-string insertion-point))
(new display% (new display%
(text text) (text text)
(controller controller) (controller controller)
(config config) (config config)
(range range) (range range)
(start-position insertion-point) (start-position insertion-point)
(end-position (+ insertion-point output-length)))) (end-position (+ insertion-point output-length)))))
(send display initialize)
(send text end-edit-sequence)
display))
;; display% ;; display%
;; Note: must call refresh method to finish styling.
(define display% (define display%
(class* object% (display<%>) (class* object% (display<%>)
(init-field/i [controller controller<%>] (init-field/i [controller controller<%>]
@ -64,57 +72,69 @@
(define base-style (define base-style
(code-style text (send/i config config<%> get-syntax-font-size))) (code-style text (send/i config config<%> get-syntax-font-size)))
;; on-next-refresh : (listof (cons stx style-delta))
;; Styles to be applied on next refresh only. (eg, underline)
(define on-next-refresh null)
;; extra-styles : hash[stx => (listof style-delta)]
;; Styles to be re-applied on every refresh.
(define extra-styles (make-hasheq)) (define extra-styles (make-hasheq))
;; to-undo-styles : (listof (cons nat nat))
;; Ranges to unbold or unhighlight when selection changes.
;; FIXME: ought to be managed by text:region-data (to auto-update ranges)
;; until then, positions are relative
(define to-undo-styles null)
;; initialize : -> void ;; initialize : -> void
(define/public (initialize) (define/private (initialize)
(send text change-style base-style start-position end-position #f) (uninterruptible
(apply-primary-partition-styles) (send text change-style base-style start-position end-position #f))
(add-clickbacks) (uninterruptible (apply-primary-partition-styles))
(refresh)) (uninterruptible (add-clickbacks)))
;; add-clickbacks : -> void ;; add-clickbacks : -> void
(define/private (add-clickbacks) (define/private (add-clickbacks)
(define (the-clickback editor start end) (define mapping (send text get-region-mapping 'syntax))
(send/i controller selection-manager<%> set-selected-syntax (define lazy-interval-map-init
(clickback->stx (delay
(- start start-position) (- end start-position)))) (uninterruptible
(for ([range (send/i range range<%> all-ranges)]) (for ([range (send/i range range<%> all-ranges)])
(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 (+ start-position start) (+ start-position end) (interval-map-set! mapping (+ start-position start) (+ start-position end) stx))))))
the-clickback)))) (define (the-callback position)
(force lazy-interval-map-init)
;; clickback->stx : num num -> syntax (send/i controller selection-manager<%> set-selected-syntax
;; FIXME: use vectors for treerange-subs and do binary search to narrow? (interval-map-ref mapping position #f)))
(define/private (clickback->stx start end) (send text set-clickregion start-position end-position the-callback))
(let ([treeranges (send/i range range<%> get-treeranges)])
(let loop* ([treeranges treeranges])
(for/or ([tr treeranges])
(cond [(and (= (treerange-start tr) start)
(= (treerange-end tr) end))
(treerange-obj tr)]
[(and (<= (treerange-start tr) start)
(<= end (treerange-end tr)))
(loop* (treerange-subs tr))]
[else #f])))))
;; 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 (uninterruptible
(begin-edit-sequence #f) (let ([undo-select/highlight-d (get-undo-select/highlight-d)])
(change-style (unhighlight-d) start-position end-position)) (for ([r (in-list to-undo-styles)])
(apply-extra-styles) (send text change-style undo-select/highlight-d
(relative->text-position (car r))
(relative->text-position (cdr r)))))
(set! to-undo-styles null))
(uninterruptible
(for ([stx+delta (in-list on-next-refresh)])
(for ([r (in-list (send/i range range<%> get-ranges (car stx+delta)))])
(restyle-range r (cdr stx+delta) #f)))
(set! on-next-refresh null))
(uninterruptible
(apply-extra-styles))
(let ([selected-syntax (let ([selected-syntax
(send/i controller selection-manager<%> (send/i controller selection-manager<%>
get-selected-syntax)]) get-selected-syntax)])
(apply-secondary-relation-styles selected-syntax) (uninterruptible
(apply-selection-styles selected-syntax)) (apply-secondary-relation-styles selected-syntax))
(send* text (uninterruptible
(end-edit-sequence)))) (apply-selection-styles selected-syntax)))))
;; get-range : -> range<%> ;; get-range : -> range<%>
(define/public (get-range) range) (define/public (get-range) range)
@ -127,22 +147,16 @@
;; 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 ([delta (highlight-style-delta hi-color)])
(for ([stx stxs]) (for ([stx (in-list stxs)])
(add-extra-styles stx (list style-delta)))) (hash-set! extra-styles stx
(refresh)) (cons delta (hash-ref extra-styles stx null))))))
;; underline-syntaxes : (listof syntax) -> void ;; underline-syntaxes : (listof syntax) -> void
(define/public (underline-syntaxes stxs) (define/public (underline-syntaxes stxs)
(for ([stx stxs]) (for ([stx (in-list stxs)])
(add-extra-styles stx (list underline-style-delta))) (set! on-next-refresh
(refresh)) (cons (cons stx underline-d) on-next-refresh))))
;; add-extra-styles : syntax (listof style) -> void
(define/public (add-extra-styles stx styles)
(hash-set! extra-styles stx
(append (hash-ref extra-styles stx null)
styles)))
;; Primary styles ;; Primary styles
;; (Done once on initialization, never repeated) ;; (Done once on initialization, never repeated)
@ -194,10 +208,16 @@
;; 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)
(for ([(stx style-deltas) extra-styles]) (for ([(stx deltas) (in-hash extra-styles)])
(for ([r (send/i range range<%> get-ranges stx)]) (for ([r (in-list (send/i range range<%> get-ranges stx))])
(for ([style-delta style-deltas]) (for ([delta (in-list deltas)])
(restyle-range r style-delta))))) (restyle-range r delta #t)))))
;; apply-selection-styles : syntax -> void
;; Styles subterms eq to the selected syntax
(define/private (apply-selection-styles selected-syntax)
(for ([r (in-list (send/i range range<%> get-ranges selected-syntax))])
(restyle-range r select-d #t)))
;; apply-secondary-relation-styles : selected-syntax -> void ;; apply-secondary-relation-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
@ -207,25 +227,17 @@
(let* ([name+relation (let* ([name+relation
(send/i controller secondary-relation<%> (send/i controller secondary-relation<%>
get-identifier=?)] get-identifier=?)]
[relation (and name+relation (cdr name+relation))]) [relation (and name+relation (cdr name+relation))]
[secondary-highlight-d (get-secondary-highlight-d)])
(when relation (when relation
(for ([id (send/i range range<%> get-identifier-list)]) (for ([id (in-list (send/i range range<%> get-identifier-list))])
(when (relation selected-syntax id) (when (relation selected-syntax id)
(draw-secondary-connection id))))))) (for ([r (in-list (send/i range range<%> get-ranges id))])
(restyle-range r secondary-highlight-d #t))))))))
;; apply-selection-styles : syntax -> void ;; restyle-range : (cons num num) style-delta% boolean -> void
;; Styles subterms eq to the selected syntax (define/private (restyle-range r style need-undo?)
(define/private (apply-selection-styles selected-syntax) (when need-undo? (set! to-undo-styles (cons r to-undo-styles)))
(for ([r (send/i range range<%> get-ranges selected-syntax)])
(restyle-range r (select-highlight-d))))
;; draw-secondary-connection : syntax -> void
(define/private (draw-secondary-connection stx2)
(for ([r (send/i range range<%> get-ranges stx2)])
(restyle-range r (select-sub-highlight-d))))
;; restyle-range : (cons num num) style-delta% -> void
(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))))
@ -236,7 +248,8 @@
;; Initialize ;; Initialize
(super-new) (super-new)
(send/i controller controller<%> add-syntax-display this))) (send/i controller controller<%> add-syntax-display this)
(initialize)))
;; fixup-parentheses : string range -> void ;; fixup-parentheses : string range -> void
(define (fixup-parentheses string range) (define (fixup-parentheses string range)
@ -358,34 +371,38 @@
;; Styles ;; Styles
(define (highlight-style-delta raw-color em? (define select-d
#:translate-color? [translate-color? #t]) (make-object style-delta% 'change-weight 'bold))
(let* ([sd (new style-delta%)])
(unless em? (define underline-d
(send sd set-delta-background (make-object style-delta% 'change-underline #t))
(if translate-color? (translate-color raw-color) raw-color)))
(when em? (send sd set-weight-on 'bold)) (define (highlight-style-delta raw-color #:translate-color? [translate-color? #t])
(unless em? (let ([sd (new style-delta%)]
;; (send sd set-underlined-off #t) [color (if translate-color? (translate-color raw-color) raw-color)])
(send sd set-weight-off 'bold)) (send sd set-delta-background color)
sd)) sd))
(define underline-style-delta (define (mk-2-constant-style bow-color [wob-color (translate-color bow-color)])
(let ([sd (new style-delta%)]) (let ([wob-version (highlight-style-delta wob-color #:translate-color? #f)]
(send sd set-underlined-on #t) [bow-version (highlight-style-delta bow-color #:translate-color? #f)])
sd))
(define (mk-2-constant-style bow-color em? [wob-color (translate-color bow-color)])
(let ([wob-version (highlight-style-delta wob-color em? #:translate-color? #f)]
[bow-version (highlight-style-delta bow-color em? #:translate-color? #f)])
(λ () (λ ()
(if (pref:invert-colors?) (if (pref:invert-colors?)
wob-version wob-version
bow-version)))) bow-version))))
(define select-highlight-d (define get-secondary-highlight-d
(mk-2-constant-style "yellow" #t "darkgoldenrod")) (mk-2-constant-style "yellow" "darkgoldenrod"))
(define select-sub-highlight-d
(mk-2-constant-style "yellow" #f "darkgoldenrod"))
(define unhighlight-d (mk-2-constant-style "white" #f #|"black"|#)) #|
(define undo-select-d
(make-object style-delta% 'change-weight 'normal))
(define get-undo-highlight-d
(mk-2-constant-style "white" "black"))
|#
(define (get-undo-select/highlight-d)
(let ([sd (make-object style-delta% 'change-weight 'normal)]
[bg (if (pref:invert-colors?) "black" "white")])
(send sd set-delta-background bg)
sd))

3
collects/macro-debugger/syntax-browser/frame.rkt
View File

@ -1,8 +1,7 @@
#lang racket/base #lang racket/base
(require racket/class (require racket/class
racket/gui racket/gui/base
racket/list racket/list
framework
unstable/class-iop unstable/class-iop
"interfaces.rkt" "interfaces.rkt"
"partition.rkt" "partition.rkt"

2
collects/macro-debugger/syntax-browser/hrule-snip.rkt
View File

@ -1,6 +1,6 @@
#lang racket/base #lang racket/base
(require racket/class (require racket/class
racket/gui) racket/gui/base)
(provide hrule-snip%) (provide hrule-snip%)
;; hrule-snip% ;; hrule-snip%

25
collects/macro-debugger/syntax-browser/image.rkt
View File

@ -1,11 +1,12 @@
#lang racket/base #lang racket/base
(require racket/contract (require racket/contract
racket/class racket/class
racket/gui racket/gui/base
framework framework
"prefs.rkt" "prefs.rkt"
"controller.rkt" "controller.rkt"
"display.rkt") "display.rkt"
"text.rkt")
#| #|
@ -36,12 +37,10 @@ TODO: tacked arrows
;; print-syntax-columns : (parameter-of (U number 'infinity)) ;; print-syntax-columns : (parameter-of (U number 'infinity))
(define print-syntax-columns (make-parameter 40)) (define print-syntax-columns (make-parameter 40))
(define standard-text% (text:foreground-color-mixin (editor:standard-style-list-mixin text:basic%)))
;; print-syntax-to-png : syntax path -> void ;; print-syntax-to-png : syntax path -> void
(define (print-syntax-to-png stx file (define (print-syntax-to-png stx file
#:columns [columns (print-syntax-columns)]) #:columns [columns (print-syntax-columns)])
(let ([bmp (print-syntax-to-bitmap stx columns)]) (let ([bmp (print-syntax-to-bitmap stx #:columns columns)])
(send bmp save-file file 'png)) (send bmp save-file file 'png))
(void)) (void))
@ -49,8 +48,8 @@ TODO: tacked arrows
(define (print-syntax-to-bitmap stx (define (print-syntax-to-bitmap stx
#:columns [columns (print-syntax-columns)]) #:columns [columns (print-syntax-columns)])
(define t (prepare-editor stx columns)) (define t (prepare-editor stx columns))
(define f (new frame% [label "dummy"])) (define admin (new dummy-admin%))
(define ec (new editor-canvas% (editor t) (parent f))) (send t set-admin admin)
(define dc (new bitmap-dc% (bitmap (make-object bitmap% 1 1)))) (define dc (new bitmap-dc% (bitmap (make-object bitmap% 1 1))))
(define char-width (define char-width
(let* ([sl (send t get-style-list)] (let* ([sl (send t get-style-list)]
@ -87,10 +86,20 @@ TODO: tacked arrows
(send t print #f #f 'postscript #f #f #t))) (send t print #f #f 'postscript #f #f #t)))
(define (prepare-editor stx columns) (define (prepare-editor stx columns)
(define t (new standard-text%)) (define t (new browser-text%))
(define sl (send t get-style-list)) (define sl (send t get-style-list))
(send t change-style (send sl find-named-style (editor:get-default-color-style-name))) (send t change-style (send sl find-named-style (editor:get-default-color-style-name)))
(print-syntax-to-editor stx t (print-syntax-to-editor stx t
(new controller%) (new syntax-prefs/readonly%) (new controller%) (new syntax-prefs/readonly%)
columns (send t last-position)) columns (send t last-position))
t) t)
;; dummy editor-admin
(define dummy-admin%
(class editor-admin%
(define the-dc (new bitmap-dc% (bitmap (make-object bitmap% 1 1))))
(define/override (get-dc [x #f] [y #f])
(when x (set-box! x 0.0))
(when y (set-box! y 0.0))
the-dc)
(super-new)))

7
collects/macro-debugger/syntax-browser/keymap.rkt
View File

@ -1,10 +1,9 @@
#lang racket/base #lang racket/base
(require racket/class (require racket/class
racket/gui racket/gui/base
racket/pretty racket/pretty
unstable/gui/notify unstable/gui/notify
"interfaces.rkt" "interfaces.rkt")
"partition.rkt")
(provide syntax-keymap%) (provide syntax-keymap%)
(define keymap/popup% (define keymap/popup%
@ -119,7 +118,7 @@
(demand-callback (demand-callback
(lambda (i) (lambda (i)
(let ([stx (selected-syntax)]) (let ([stx (selected-syntax)])
(when stx (when (identifier? stx)
(send i set-label (send i set-label
(format "Format ~s ~a" (syntax-e stx) (cadr sym+desc))))))) (format "Format ~s ~a" (syntax-e stx) (cadr sym+desc)))))))
(callback (callback

1
collects/macro-debugger/syntax-browser/partition.rkt
View File

@ -1,6 +1,5 @@
#lang racket/base #lang racket/base
(require racket/class (require racket/class
syntax/stx
"interfaces.rkt" "interfaces.rkt"
"../util/stxobj.rkt") "../util/stxobj.rkt")
(provide new-bound-partition (provide new-bound-partition

5
collects/macro-debugger/syntax-browser/prefs.rkt
View File

@ -15,11 +15,13 @@
(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?)
(preferences:set-default 'SyntaxBrowser:DrawArrows? #t boolean?)
(define pref:width (pref:get/set 'SyntaxBrowser:Width)) (define pref:width (pref:get/set 'SyntaxBrowser:Width))
(define pref:height (pref:get/set 'SyntaxBrowser:Height)) (define pref:height (pref:get/set 'SyntaxBrowser:Height))
(define pref:props-percentage (pref:get/set 'SyntaxBrowser:PropertiesPanelPercentage)) (define pref:props-percentage (pref:get/set 'SyntaxBrowser:PropertiesPanelPercentage))
(define pref:props-shown? (pref:get/set 'SyntaxBrowser:PropertiesPanelShown)) (define pref:props-shown? (pref:get/set 'SyntaxBrowser:PropertiesPanelShown))
(define pref:draw-arrows? (pref:get/set 'SyntaxBrowser:DrawArrows?))
(define pref:invert-colors? (pref:get/set 'framework:white-on-black?)) (define pref:invert-colors? (pref:get/set 'framework:white-on-black?))
@ -68,7 +70,8 @@
(width pref:width) (width pref:width)
(height pref:height) (height pref:height)
(props-percentage pref:props-percentage) (props-percentage pref:props-percentage)
(props-shown? pref:props-shown?)) (props-shown? pref:props-shown?)
(draw-arrows? pref:draw-arrows?))
(super-new))) (super-new)))

3
collects/macro-debugger/syntax-browser/pretty-helper.rkt
View File

@ -1,6 +1,5 @@
#lang racket/base #lang racket/base
(require racket/class (require racket/pretty
racket/pretty
unstable/class-iop unstable/class-iop
syntax/stx syntax/stx
unstable/struct unstable/struct

7
collects/macro-debugger/syntax-browser/pretty-printer.rkt
View File

@ -2,7 +2,8 @@
(require racket/list (require racket/list
racket/class racket/class
racket/pretty racket/pretty
racket/gui racket/gui/base
racket/promise
"pretty-helper.rkt" "pretty-helper.rkt"
"interfaces.rkt") "interfaces.rkt")
(provide pretty-print-syntax) (provide pretty-print-syntax)
@ -86,7 +87,9 @@
(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-for-syntax . define)
(define-values-for-syntax . define))
#| #|
;; Messes up formatting too much :( ;; Messes up formatting too much :(
(let* ([pref (pref:tabify)] (let* ([pref (pref:tabify)]

23
collects/macro-debugger/syntax-browser/properties.rkt
View File

@ -1,6 +1,6 @@
#lang racket/base #lang racket/base
(require racket/class (require racket/class
racket/gui racket/gui/base
framework framework
unstable/class-iop unstable/class-iop
"interfaces.rkt" "interfaces.rkt"
@ -59,17 +59,12 @@
;; refresh : -> void ;; refresh : -> void
(define/public (refresh) (define/public (refresh)
(send* text (with-unlock text
(lock #f) (send text erase)
(begin-edit-sequence #f)
(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 scroll-to-position 0))
(end-edit-sequence)
(lock #t)
(scroll-to-position 0)))
;; refresh/mode : symbol -> void ;; refresh/mode : symbol -> void
(define/public (refresh/mode mode) (define/public (refresh/mode mode)
@ -255,19 +250,19 @@
;; 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)])

14
collects/macro-debugger/syntax-browser/snip-decorated.rkt
View File

@ -1,12 +1,13 @@
#lang racket/base #lang racket/base
(require racket/class (require racket/class
racket/gui racket/gui/base
(only-in mzlib/string read-from-string) (only-in mzlib/string read-from-string)
unstable/class-iop unstable/class-iop
"interfaces.rkt" "interfaces.rkt"
"controller.rkt" "controller.rkt"
"properties.rkt" "properties.rkt"
"prefs.rkt" "prefs.rkt"
"util.rkt"
(except-in "snip.rkt" (except-in "snip.rkt"
snip-class)) snip-class))
@ -47,10 +48,8 @@
(define open? #f) (define open? #f)
(define/public (refresh-contents) (define/public (refresh-contents)
(send* -outer (with-unlock -outer
(begin-edit-sequence) (send -outer erase)
(lock #f)
(erase))
(do-style (if open? open-style closed-style)) (do-style (if open? open-style closed-style))
(outer:insert (if open? (hide-icon) (show-icon)) (outer:insert (if open? (hide-icon) (show-icon))
style:hyper style:hyper
@ -63,10 +62,7 @@
(refresh-contents)))) (refresh-contents))))
(for-each (lambda (s) (outer:insert s)) (for-each (lambda (s) (outer:insert s))
(if open? (open-contents) (closed-contents))) (if open? (open-contents) (closed-contents)))
(send* -outer (send -outer change-style top-aligned 0 (send -outer last-position))))
(change-style top-aligned 0 (send -outer last-position))
(lock #t)
(end-edit-sequence)))
(define/private (do-style style) (define/private (do-style style)
(show-border (memq 'border style)) (show-border (memq 'border style))

12
collects/macro-debugger/syntax-browser/snip.rkt
View File

@ -1,13 +1,13 @@
#lang racket/base #lang racket/base
(require racket/class (require racket/class
racket/gui racket/gui/base
racket/match racket/match
(only-in mzlib/string read-from-string) (only-in mzlib/string read-from-string)
framework framework
"interfaces.rkt"
"display.rkt" "display.rkt"
"controller.rkt" "controller.rkt"
"keymap.rkt" "keymap.rkt"
"util.rkt"
"prefs.rkt") "prefs.rkt")
(provide syntax-snip% (provide syntax-snip%
@ -35,12 +35,10 @@
;;(set-margin 2 2 2 2) ;;(set-margin 2 2 2 2)
(set-inset 0 0 0 0) (set-inset 0 0 0 0)
(send text begin-edit-sequence)
(send text change-style (make-object style-delta% 'change-alignment 'top))
(define display (define display
(print-syntax-to-editor stx text controller config columns)) (with-unlock text
(send text lock #t) (send text change-style (make-object style-delta% 'change-alignment 'top))
(send text end-edit-sequence) (print-syntax-to-editor stx text controller config columns)))
(send text hide-caret #t) (send text hide-caret #t)
(setup-keymap text) (setup-keymap text)

252
collects/macro-debugger/syntax-browser/text.rkt
View File

@ -1,11 +1,11 @@
#lang racket/base #lang racket/base
(require racket/list (require racket/list
racket/class racket/class
racket/gui racket/gui/base
data/interval-map
drracket/arrow drracket/arrow
framework/framework framework/framework
unstable/interval-map data/interval-map
unstable/gui/notify
"interfaces.rkt") "interfaces.rkt")
(provide text:hover<%> (provide text:hover<%>
@ -15,7 +15,12 @@
text:hover-mixin text:hover-mixin
text:hover-drawings-mixin text:hover-drawings-mixin
text:tacking-mixin text:tacking-mixin
text:arrows-mixin) text:arrows-mixin
text:region-data-mixin
text:clickregion-mixin
browser-text%)
(define arrow-cursor (make-object cursor% 'arrow))
(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))
@ -27,14 +32,15 @@
(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) (box boolean)) ;; A Drawing is (make-drawing (??? -> void) (box boolean))
(define-struct drawing (start end draw tacked?)) (define-struct drawing (draw tacked?))
(define-struct idloc (start end id)) (define-struct idloc (start end id))
(define (mean x y) (define (mean x y)
(/ (+ x y) 2)) (/ (+ x y) 2))
;; save+restore pen, brush, also smoothing
(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)
@ -42,10 +48,13 @@
(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)]
[old-smoothing (send dc get-smoothing)])
(begin0 (thunk) (begin0 (thunk)
(send dc set-pen old-pen) (send* dc
(send dc set-brush old-brush)))) (set-pen old-pen)
(set-brush old-brush)
(set-smoothing old-smoothing)))))
(define-syntax with-saved-text-config (define-syntax with-saved-text-config
(syntax-rules () (syntax-rules ()
@ -58,10 +67,17 @@
[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
(send dc set-text-foreground old-color) (set-font old-font)
(send dc set-text-background old-background) (set-text-foreground old-color)
(send dc set-text-mode old-mode)))) (set-text-background old-background)
(set-text-mode old-mode)))))
;; Interfaces
(define text:region-data<%>
(interface (text:basic<%>)
get-region-mapping))
(define text:hover<%> (define text:hover<%>
(interface (text:basic<%>) (interface (text:basic<%>)
@ -70,29 +86,51 @@
(define text:hover-drawings<%> (define text:hover-drawings<%>
(interface (text:basic<%>) (interface (text:basic<%>)
add-hover-drawing add-hover-drawing
get-position-drawings get-position-drawings))
delete-all-drawings))
(define text:arrows<%> (define text:arrows<%>
(interface (text:hover-drawings<%>) (interface (text:hover-drawings<%>)
add-arrow add-arrow
add-question-arrow
add-billboard)) add-billboard))
;; Mixins
(define text:region-data-mixin
(mixin (text:basic<%>) (text:region-data<%>)
(define table (make-hasheq))
(define/public (get-region-mapping key)
(hash-ref! table key (lambda () (make-interval-map))))
(define/augment (after-delete start len)
(for ([im (in-hash-values table)])
(interval-map-contract! im start (+ start len)))
(inner (void) after-delete start len))
(define/augment (after-insert start len)
(for ([im (in-hash-values table)])
(interval-map-expand! im start (+ start len)))
(inner (void) after-insert start len))
(super-new)))
(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 gy (send ev get-y))
(define-values (x y) (dc-location-to-editor-location gx gy))
(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)))) (define-values (x y)
(let ([gx (send ev get-x)]
[gy (send ev get-y)])
(dc-location-to-editor-location gx gy)))
(define on-it? (box #f))
(define pos (find-position x y #f on-it?))
(update-hover-position (and (unbox on-it?) pos)))))
(define/public (update-hover-position pos) (define/public (update-hover-position pos)
(void)) (void))
@ -100,13 +138,15 @@
(super-new))) (super-new)))
(define text:hover-drawings-mixin (define text:hover-drawings-mixin
(mixin (text:hover<%>) (text:hover-drawings<%>) (mixin (text:hover<%> text:region-data<%>) (text:hover-drawings<%>)
(inherit dc-location-to-editor-location (inherit dc-location-to-editor-location
find-position find-position
invalidate-bitmap-cache) invalidate-bitmap-cache
get-region-mapping)
(super-new)
;; interval-map of Drawings ;; interval-map of Drawings
(define drawings-list (make-numeric-interval-map)) (define drawings-list (get-region-mapping 'hover-drawings))
(field [hover-position #f]) (field [hover-position #f])
@ -118,15 +158,12 @@
(invalidate-bitmap-cache 0.0 0.0 +inf.0 +inf.0))) (invalidate-bitmap-cache 0.0 0.0 +inf.0 +inf.0)))
(define/public (add-hover-drawing start end draw [tack-box (box #f)]) (define/public (add-hover-drawing start end draw [tack-box (box #f)])
(let ([drawing (make-drawing start end draw tack-box)]) (let ([drawing (make-drawing draw tack-box)])
(interval-map-cons*! drawings-list (interval-map-cons*! drawings-list
start (add1 end) start (add1 end)
drawing drawing
null))) null)))
(define/public (delete-all-drawings)
(interval-map-remove! drawings-list -inf.0 +inf.0))
(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?
@ -139,9 +176,7 @@
(define/private (same-drawings? old-pos pos) (define/private (same-drawings? old-pos pos)
;; relies on order drawings added & list-of-eq?-struct equality ;; relies on order drawings added & list-of-eq?-struct equality
(equal? (get-position-drawings old-pos) (equal? (get-position-drawings old-pos)
(get-position-drawings pos))) (get-position-drawings pos)))))
(super-new)))
(define text:tacking-mixin (define text:tacking-mixin
(mixin (text:basic<%> text:hover-drawings<%>) () (mixin (text:basic<%> text:hover-drawings<%>) ()
@ -153,17 +188,26 @@
(define tacked-table (make-hasheq)) (define tacked-table (make-hasheq))
(define/override (on-event ev) (define/override (on-local-event ev)
(case (send ev get-event-type) (case (send ev get-event-type)
((right-down) ((right-down)
(if (pair? (get-position-drawings hover-position)) (if (pair? (get-position-drawings hover-position))
(send (get-canvas) popup-menu (send (get-canvas) popup-menu
(make-tack/untack-menu) (make-tack/untack-menu (get-position-drawings hover-position))
(send ev get-x) (send ev get-x)
(send ev get-y)) (send ev get-y))
(super on-event ev))) (super on-local-event ev)))
(else (else
(super on-event ev)))) (super on-local-event ev))))
;; Clear tacked-table on any modification.
;; FIXME: possible to be more precise? (but not needed for macro stepper)
(define/augment (after-delete start len)
(set! tacked-table (make-hasheq))
(inner (void) after-delete start len))
(define/augment (after-insert start len)
(set! tacked-table (make-hasheq))
(inner (void) after-insert start len))
(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)
@ -171,26 +215,32 @@
(for ([draw (in-hash-keys tacked-table)]) (for ([draw (in-hash-keys tacked-table)])
(draw this dc left top right bottom dx dy)))) (draw this dc left top right bottom dx dy))))
(define/private (make-tack/untack-menu) (define/private (make-tack/untack-menu drawings)
(define menu (new popup-menu%)) (define menu (new popup-menu%))
(define keymap (get-keymap)) (define keymap (get-keymap))
(define tack-item
(new menu-item% (label "Tack") (new menu-item% (label "Tack")
(parent menu) (parent menu)
(callback (lambda _ (tack)))) (callback (lambda _ (tack drawings)))))
(define untack-item
(new menu-item% (label "Untack") (new menu-item% (label "Untack")
(parent menu) (parent menu)
(callback (lambda _ (untack)))) (callback (lambda _ (untack drawings)))))
(send tack-item enable
(for/or ([d (in-list drawings)]) (not (unbox (drawing-tacked? d)))))
(send untack-item enable
(for/or ([d (in-list drawings)]) (unbox (drawing-tacked? d))))
(when (is-a? keymap keymap/popup<%>) (when (is-a? keymap keymap/popup<%>)
(new separator-menu-item% (parent menu)) (new separator-menu-item% (parent menu))
(send keymap add-context-menu-items menu)) (send keymap add-context-menu-items menu))
menu) menu)
(define/private (tack) (define/private (tack drawings)
(for ([d (get-position-drawings hover-position)]) (for ([d (in-list drawings)])
(hash-set! tacked-table (drawing-draw d) #t) (hash-set! tacked-table (drawing-draw d) #t)
(set-box! (drawing-tacked? d) #t))) (set-box! (drawing-tacked? d) #t)))
(define/private (untack) (define/private (untack drawings)
(for ([d (get-position-drawings hover-position)]) (for ([d (in-list drawings)])
(hash-remove! tacked-table (drawing-draw d)) (hash-remove! tacked-table (drawing-draw d))
(set-box! (drawing-tacked? d) #f))))) (set-box! (drawing-tacked? d) #f)))))
@ -200,12 +250,6 @@
add-hover-drawing add-hover-drawing
find-wordbreak) 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/public (add-billboard pos1 pos2 str color-name)
(define color (send the-color-database find-color color-name)) (define color (send the-color-database find-color color-name))
(let ([draw (let ([draw
@ -224,6 +268,7 @@
[(adj-y) fh] [(adj-y) fh]
[(mini) _d]) [(mini) _d])
(send* dc (send* dc
(set-smoothing 'smoothed)
(draw-rounded-rectangle (draw-rounded-rectangle
(+ x dx) (+ x dx)
(+ y dy adj-y) (+ y dy adj-y)
@ -232,7 +277,7 @@
(draw-text str (+ x dx mini) (+ y dy mini adj-y))))))))]) (draw-text str (+ x dx mini) (+ y dy mini adj-y))))))))])
(add-hover-drawing pos1 pos2 draw))) (add-hover-drawing pos1 pos2 draw)))
(define/private (internal-add-arrow from1 from2 to1 to2 color-name question?) (define/public (add-arrow from1 from2 to1 to2 color-name label where)
(define color (send the-color-database find-color color-name)) (define color (send the-color-database find-color color-name))
(define tack-box (box #f)) (define tack-box (box #f))
(unless (and (= from1 to1) (= from2 to2)) (unless (and (= from1 to1) (= from2 to2))
@ -240,7 +285,8 @@
(lambda (text dc left top right bottom dx dy) (lambda (text dc left top right bottom dx dy)
(let-values ([(startx starty) (range->mean-loc from1 from2)] (let-values ([(startx starty) (range->mean-loc from1 from2)]
[(endx endy) (range->mean-loc to1 to2)] [(endx endy) (range->mean-loc to1 to2)]
[(fw fh _d _v) (send dc get-text-extent "x")]) [(fw fh _d _v) (send dc get-text-extent "x")]
[(lw lh ld _V) (send dc get-text-extent (or label "x"))])
(with-saved-pen&brush dc (with-saved-pen&brush dc
(with-saved-text-config dc (with-saved-text-config dc
(send dc set-pen color 1 'solid) (send dc set-pen color 1 'solid)
@ -253,13 +299,17 @@
endx endx
(+ endy (/ fh 2)) (+ endy (/ fh 2))
dx dy) dx dy)
(send dc set-text-mode 'transparent) (when label
(when question? (let* ([lx (+ endx dx fw)]
(send dc set-font (?-font dc)) [ly (- (+ endy dy) fh)])
(send dc set-text-foreground color) (send* dc
(send dc draw-text "?" (set-brush billboard-brush)
(+ endx dx fw) (set-font (billboard-font dc))
(- (+ endy dy) fh)))))))]) (set-text-foreground color)
(set-smoothing 'smoothed)
(draw-rounded-rectangle (- lx ld) (- ly ld)
(+ lw ld ld) (+ lh ld ld))
(draw-text label lx ly))))))))])
(add-hover-drawing from1 from2 draw tack-box) (add-hover-drawing from1 from2 draw tack-box)
(add-hover-drawing to1 to2 draw tack-box)))) (add-hover-drawing to1 to2 draw tack-box))))
@ -286,15 +336,65 @@
(super-new))) (super-new)))
(define text:hover-drawings% #|
(text:hover-drawings-mixin text:clickregion-mixin
(text:hover-mixin
text:standard-style-list%)))
(define text:arrows% Like clickbacks, but:
(text:arrows-mixin - use interval-map to avoid linear search
(text:tacking-mixin (major problem w/ macro stepper and large expansions!)
text:hover-drawings%))) - callback takes position of click, not (start, end)
- different rules for removal
- TODO: extend to double-click
|#
(define text:clickregion-mixin
(mixin (text:region-data<%>) ()
(inherit get-admin
get-region-mapping
dc-location-to-editor-location
find-position)
(super-new)
(define clickbacks (get-region-mapping 'clickregion))
(define tracking #f)
(define/public (set-clickregion start end callback)
(if callback
(interval-map-set! clickbacks start end callback)
(interval-map-remove! clickbacks start end)))
(define/private (get-event-position ev)
(define-values (x y)
(let ([gx (send ev get-x)]
[gy (send ev get-y)])
(dc-location-to-editor-location gx gy)))
(define on-it? (box #f))
(define pos (find-position x y #f on-it?))
(and (unbox on-it?) pos))
(define/override (on-default-event ev)
(define admin (get-admin))
(when admin
(define pos (get-event-position ev))
(case (send ev get-event-type)
((left-down)
(set! tracking (and pos (interval-map-ref clickbacks pos #f)))
(send admin update-cursor))
((left-up)
(when tracking
(let ([cb (and pos (interval-map-ref clickbacks pos #f))]
[tracking* tracking])
(set! tracking #f)
(when (eq? tracking* cb)
(cb pos)))
(send admin update-cursor)))))
(super on-default-event ev))
(define/override (adjust-cursor ev)
(define pos (get-event-position ev))
(define cb (and pos (interval-map-ref clickbacks pos #f)))
(if cb
arrow-cursor
(super adjust-cursor ev)))))
#| #|
@ -327,3 +427,25 @@
[else (search (cdr idlocs))]))) [else (search (cdr idlocs))])))
(super-new))) (super-new)))
|# |#
(define browser-text%
(let ([browser-text-default-style-name "widget.rkt::browser-text% basic"])
(class (text:clickregion-mixin
(text:arrows-mixin
(text:tacking-mixin
(text:hover-drawings-mixin
(text:hover-mixin
(text:region-data-mixin
(text:hide-caret/selection-mixin
(text:foreground-color-mixin
(editor:standard-style-list-mixin text:basic%)))))))))
(inherit set-autowrap-bitmap get-style-list)
(define/override (default-style-name) browser-text-default-style-name)
(super-new (auto-wrap #t))
(let* ([sl (get-style-list)]
[standard (send sl find-named-style (editor:get-default-color-style-name))]
[browser-basic (send sl find-or-create-style standard
(make-object style-delta% 'change-family 'default))])
(send sl new-named-style browser-text-default-style-name browser-basic))
(set-autowrap-bitmap #f))))

13
collects/macro-debugger/syntax-browser/util.rkt
View File

@ -10,13 +10,16 @@
[(with-unlock text . body) [(with-unlock text . body)
(let* ([t text] (let* ([t text]
[locked? (send t is-locked?)]) [locked? (send t is-locked?)])
(dynamic-wind
(lambda ()
(send* t (send* t
(lock #f) (begin-edit-sequence #f)
(begin-edit-sequence #f)) (lock #f)))
(begin0 (let () . body) (lambda () . body)
(lambda ()
(send* t (send* t
(end-edit-sequence) (lock locked?)
(lock locked?))))])) (end-edit-sequence)))))]))
;; 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.

152
collects/macro-debugger/syntax-browser/widget.rkt
View File

@ -1,6 +1,6 @@
#lang racket/base #lang racket/base
(require racket/class (require racket/class
racket/gui racket/gui/base
racket/list racket/list
racket/match racket/match
framework framework
@ -14,6 +14,7 @@
"properties.rkt" "properties.rkt"
"text.rkt" "text.rkt"
"util.rkt" "util.rkt"
"../util/eomap.rkt"
"../util/mpi.rkt") "../util/mpi.rkt")
(provide widget%) (provide widget%)
@ -106,19 +107,24 @@
(send -text change-style clickback-style a b))))) (send -text change-style clickback-style a b)))))
(define/public (add-syntax stx (define/public (add-syntax stx
#:binders [binders null] #:binders [binders #f]
#:shift-table [shift-table #f] #:shift-table [shift-table #f]
#:definites [definites null] #:definites [definites #f]
#:hi-colors [hi-colors null] #:hi-colors [hi-colors null]
#:hi-stxss [hi-stxss null] #:hi-stxss [hi-stxss null]
#:substitutions [substitutions null]) #:substitutions [substitutions null])
(let ([display (internal-add-syntax stx)] (define (get-shifted id) (hash-ref shift-table id null))
[definite-table (make-hasheq)])
(let ([range (send/i display display<%> get-range)]
[offset (send/i display display<%> get-start-position)])
(for ([subst substitutions])
(for ([r (send/i range range<%> get-ranges (car subst))])
(with-unlock -text (with-unlock -text
(define display
(print-syntax-to-editor stx -text controller config
(calculate-columns)
(send -text last-position)))
(send -text insert "\n")
(define range (send/i display display<%> get-range))
(define offset (send/i display display<%> get-start-position))
(for ([subst (in-list substitutions)])
(for ([r (in-list (send/i range range<%> get-ranges (car subst)))])
(send -text insert (cdr subst) (send -text insert (cdr subst)
(+ offset (car r)) (+ offset (car r))
(+ offset (cdr r)) (+ offset (cdr r))
@ -126,67 +132,76 @@
(send -text change-style (send -text change-style
(code-style -text (send/i config config<%> get-syntax-font-size)) (code-style -text (send/i config config<%> get-syntax-font-size))
(+ offset (car r)) (+ offset (car r))
(+ offset (cdr r))))))) (+ offset (cdr r))
(for ([hi-stxs hi-stxss] [hi-color hi-colors]) #f)))
;; Apply highlighting
(for ([hi-stxs (in-list hi-stxss)] [hi-color (in-list hi-colors)])
(send/i display display<%> highlight-syntaxes hi-stxs hi-color)) (send/i display display<%> highlight-syntaxes hi-stxs hi-color))
(for ([definite definites]) ;; Underline binders (and shifted binders)
(hash-set! definite-table definite #t) (send/i display display<%> underline-syntaxes
(when shift-table (let ([binder-list (hash-map binders (lambda (k v) k))])
(for ([shifted-definite (hash-ref shift-table definite null)]) (append (apply append (map get-shifted binder-list))
(hash-set! definite-table shifted-definite #t)))) binder-list)))
(let ([binder-table (make-free-id-table)]) (send display refresh)
(define range (send/i display display<%> get-range))
(define start (send/i display display<%> get-start-position)) ;; Make arrows (& billboards, when enabled)
(define (get-binders id) (when (send config get-draw-arrows?)
(let ([binder (free-id-table-ref binder-table id #f)]) (define (definite-phase id)
(and definites
(or (eomap-ref definites id #f)
(for/or ([shifted (in-list (hash-ref shift-table id null))])
(eomap-ref definites shifted #f)))))
(define phase-binder-table (make-hash))
(define (get-binder-table phase)
(hash-ref! phase-binder-table phase (lambda () (make-free-id-table #:phase phase))))
(for ([(binder phase) (in-hash binders)])
(free-id-table-set! (get-binder-table phase) binder binder))
(define (get-binders id phase)
(define (for-one-table table id)
(let ([binder (free-id-table-ref table id #f)])
(cond [(not binder) null] (cond [(not binder) null]
[shift-table (cons binder (get-shifted binder))] [shift-table (cons binder (get-shifted binder))]
[else (list binder)]))) [else (list binder)])))
(define (get-shifted id) (cond [phase (for-one-table (get-binder-table phase) id)]
(hash-ref shift-table id null)) [else
;; Populate table (apply append
(for ([binder binders]) (for/list ([table (in-hash-values phase-binder-table)])
(free-id-table-set! binder-table binder binder)) (for-one-table table id)))]))
;; Underline binders (and shifted binders)
(send/i display display<%> underline-syntaxes (for ([id (in-list (send/i range range<%> get-identifier-list))])
(append (apply append (map get-shifted binders)) (define phase (definite-phase id))
binders))
;; Make arrows (& billboards, when enabled)
(for ([id (send/i range range<%> get-identifier-list)])
(define definite? (hash-ref definite-table id #f))
(when #f ;; DISABLED (when #f ;; DISABLED
(add-binding-billboard start range id definite?)) (add-binding-billboard offset range id phase))
(for ([binder (get-binders id)]) (for ([binder (in-list (get-binders id phase))])
(for ([binder-r (send/i range range<%> get-ranges binder)]) (for ([binder-r (in-list (send/i range range<%> get-ranges binder))])
(for ([id-r (send/i range range<%> get-ranges id)]) (for ([id-r (in-list (send/i range range<%> get-ranges id))])
(add-binding-arrow start binder-r id-r definite?)))))) (add-binding-arrow offset binder-r id-r phase))))))
(void))) (void)))
(define/private (add-binding-arrow start binder-r id-r definite?) (define/private (add-binding-arrow start binder-r id-r phase)
(if definite? ;; phase = #f means not definite binding (ie, "?" arrow)
(send -text add-arrow (send -text add-arrow
(+ start (car binder-r)) (+ start (car binder-r))
(+ start (cdr binder-r)) (+ start (cdr binder-r))
(+ start (car id-r)) (+ start (car id-r))
(+ start (cdr id-r)) (+ start (cdr id-r))
"blue") (if phase "blue" "purple")
(send -text add-question-arrow (cond [(equal? phase 0) #f]
(+ start (car binder-r)) [phase (format "phase ~s" phase)]
(+ start (cdr binder-r)) [else "?"])
(+ start (car id-r)) (if phase 'end 'start)))
(+ start (cdr id-r))
"purple")))
(define/private (add-binding-billboard start range id definite?) (define/private (add-binding-billboard start range id definite?)
(match (identifier-binding id) (match (identifier-binding id)
[(list-rest src-mod src-name nom-mod nom-name _) [(list-rest src-mod src-name nom-mod nom-name _)
(for-each (lambda (id-r) (for ([id-r (in-list (send/i range range<%> get-ranges id))])
(send -text add-billboard (send -text add-billboard
(+ start (car id-r)) (+ start (car id-r))
(+ start (cdr id-r)) (+ start (cdr id-r))
(string-append "from " (mpi->string src-mod)) (string-append "from " (mpi->string src-mod))
(if definite? "blue" "purple"))) (if definite? "blue" "purple")))]
(send/i range range<%> get-ranges id))]
[_ (void)])) [_ (void)]))
(define/public (add-separator) (define/public (add-separator)
@ -197,25 +212,11 @@
(define/public (erase-all) (define/public (erase-all)
(with-unlock -text (with-unlock -text
(send -text erase) (send -text erase))
(send -text delete-all-drawings))
(send/i controller displays-manager<%> remove-all-syntax-displays)) (send/i controller displays-manager<%> remove-all-syntax-displays))
(define/public (get-text) -text) (define/public (get-text) -text)
;; internal-add-syntax : syntax -> display
(define/private (internal-add-syntax stx)
(with-unlock -text
(let ([display
(print-syntax-to-editor stx -text controller config
(calculate-columns)
(send -text last-position))])
(send* -text
(insert "\n")
;;(scroll-to-position current-position)
)
display)))
(define/private (calculate-columns) (define/private (calculate-columns)
(define style (code-style -text (send/i config config<%> get-syntax-font-size))) (define style (code-style -text (send/i config config<%> get-syntax-font-size)))
(define char-width (send style get-text-width (send -ecanvas get-dc))) (define char-width (send style get-text-width (send -ecanvas get-dc)))
@ -246,24 +247,3 @@
(send sd set-delta 'change-italic) (send sd set-delta 'change-italic)
(send sd set-delta-foreground "red") (send sd set-delta-foreground "red")
sd)) sd))
;; Specialized classes for widget
(define browser-text%
(let ([browser-text-default-style-name "widget.rkt::browser-text% basic"])
(class (text:arrows-mixin
(text:tacking-mixin
(text:hover-drawings-mixin
(text:hover-mixin
(text:hide-caret/selection-mixin
(text:foreground-color-mixin
(editor:standard-style-list-mixin text:basic%)))))))
(inherit set-autowrap-bitmap get-style-list)
(define/override (default-style-name) browser-text-default-style-name)
(super-new (auto-wrap #t))
(let* ([sl (get-style-list)]
[standard (send sl find-named-style (editor:get-default-color-style-name))]
[browser-basic (send sl find-or-create-style standard
(make-object style-delta% 'change-family 'default))])
(send sl new-named-style browser-text-default-style-name browser-basic))
(set-autowrap-bitmap #f))))

140
collects/macro-debugger/util/eomap.rkt Normal file
View File

@ -0,0 +1,140 @@
#lang racket/base
(require racket/contract
racket/dict
racket/match)
#|
eomap = "extend-only" mapping
Used to represent persistent mappings that are typically extended only once,
where both lookup and extend must be fast, but no other operations are needed.
Like association list (sharing, fast extend), but lookup is fast too.
Like immutable hash (fast lookup), but extend (hopefully) involves less allocation.
----
An eomap[K,V] is (eomap store[K,V] timestamp (box timestamp)).
A store[K,V] is mutable-dict[K, (listof (cons timestamp V))].
A timestamp is either
- nat
- (cons nat (cons symbol timestamp))
Timestamps are arranged into Branches. The main Branch goes 1, 2, 3 ....
A box stores the latest timestamp in a Branch.
If another eomap is branched off of 2, that Branch is tagged (g0 . 2) and
its successor for 2 is (1 g0 . 2).
Timestamps and branches are compared using eqv?.
Comparison:
t1 < nat2 if
- t1 = nat1 < nat2
t1 < (nat2 sym2 . bt2) if
- t1 = (nat1 sym2 . bt2) ;; same branch
and nat1 < nat2
- t1 < bt2, or ;; less than branch point
====
The data structure works best, of course, when a mapping is extended only once,
so we can stick to simple numbered timestamps.
An alternative is to make eomaps enforce the extend-once property; so
instead of branching a second extension just errors.
TODO: check if macro stepper strictly follows extend-once discipline.
|#
(struct eomap (store ts latest))
(define (empty-eomap [store (make-hasheq)])
(eomap store 1 (box 1)))
(define (eomap-bump eom)
(match eom
[(eomap store ts latest)
(let-values ([(ts* latest*) (successor ts latest)])
(eomap store ts* latest*))]))
(define (eomap-add eom to-add)
(let ([eom* (eomap-bump eom)])
(match eom*
[(eomap store ts latest)
(for ([(key value) (in-dict to-add)])
(dict-set! store key
(cons (cons ts value) (dict-ref store key null))))])
eom*))
(define (eomap-set* eom keys value)
(let ([eom* (eomap-bump eom)])
(match eom*
[(eomap store ts latest)
(for ([key (in-list keys)])
(dict-set! store key
(cons (cons ts value) (dict-ref store key null))))])
eom*))
(define (eomap-ref eom key [default not-given])
(match eom
[(eomap store ts _latest)
(let loop ([ts+value-list (dict-ref store key null)])
(cond [(pair? ts+value-list)
(let ([entry-ts (car (car ts+value-list))]
[entry-value (cdr (car ts+value-list))])
(cond [(t<=? entry-ts ts)
entry-value]
[else (loop (cdr ts+value-list))]))]
[else
(cond [(eq? default not-given)
(error 'eomap-ref "key not found: ~e" key)]
[(procedure? default) (default)]
[else default])]))]))
(define not-given (gensym 'not-given))
;; Timestamps
(define (successor ts latest)
(define (tadd1 ts)
(cond [(pair? ts) (cons (add1 (car ts)) (cdr ts))]
[else (add1 ts)]))
(cond [(eqv? ts (unbox latest))
(let ([ts+1 (tadd1 ts)])
(set-box! latest ts+1)
(values ts+1 latest))]
[else
(let* ([tag (cons (gensym) ts)]
[next (cons 1 tag)])
(values next (box next)))]))
(define (t<=? x y)
(or (eqv? x y) (t<? x y)))
(define (t<? x y)
(match y
[(cons yn ytag)
(match x
[(cons xn (? (lambda (v) (eqv? v ytag))))
(< xn yn)]
[x
(t<? x (cdr ytag))])]
[yn
(and (number? x)
(< x yn))]))
;; ----
(provide/contract
[eomap?
(-> any/c boolean?)]
[empty-eomap
(->* () (dict?) eomap?)]
[eomap-add
(-> eomap? dict? eomap?)]
[eomap-set*
(-> eomap? list? any/c eomap?)]
[eomap-ref
(->* (eomap? any/c) (any/c) any)])

1
collects/macro-debugger/view/debug.rkt
View File

@ -4,7 +4,6 @@
unstable/class-iop unstable/class-iop
"interfaces.rkt" "interfaces.rkt"
"debug-format.rkt" "debug-format.rkt"
"prefs.rkt"
"view.rkt") "view.rkt")
(provide debug-file) (provide debug-file)

18
collects/macro-debugger/view/extensions.rkt
View File

@ -3,21 +3,11 @@
racket/unit racket/unit
racket/list racket/list
racket/match racket/match
racket/gui racket/gui/base
framework
unstable/class-iop unstable/class-iop
"interfaces.rkt" "interfaces.rkt"
"prefs.rkt"
"hiding-panel.rkt"
(prefix-in s: "../syntax-browser/widget.rkt") (prefix-in s: "../syntax-browser/widget.rkt")
(prefix-in s: "../syntax-browser/keymap.rkt") (prefix-in s: "../syntax-browser/keymap.rkt"))
(prefix-in s: "../syntax-browser/interfaces.rkt")
"../model/deriv.rkt"
"../model/deriv-util.rkt"
"../model/trace.rkt"
"../model/steps.rkt"
"cursor.rkt"
unstable/gui/notify)
(provide stepper-keymap% (provide stepper-keymap%
stepper-syntax-widget%) stepper-syntax-widget%)
@ -29,6 +19,7 @@
(inherit-field config (inherit-field config
controller) controller)
(inherit add-function (inherit add-function
map-function
call-function) call-function)
(define show-macro #f) (define show-macro #f)
@ -39,6 +30,9 @@
(define/public (get-hiding-panel) (define/public (get-hiding-panel)
(send/i macro-stepper widget<%> get-macro-hiding-prefs)) (send/i macro-stepper widget<%> get-macro-hiding-prefs))
(map-function ":s" "hiding:show-macro")
(map-function ":h" "hiding:hide-macro")
(add-function "hiding:show-macro" (add-function "hiding:show-macro"
(lambda (i e) (lambda (i e)
(send*/i (get-hiding-panel) hiding-prefs<%> (send*/i (get-hiding-panel) hiding-prefs<%>

31
collects/macro-debugger/view/frame.rkt
View File

@ -3,21 +3,15 @@
racket/unit racket/unit
racket/list racket/list
racket/file racket/file
racket/path
racket/match racket/match
racket/gui racket/gui/base
framework framework
unstable/class-iop unstable/class-iop
"interfaces.rkt" "interfaces.rkt"
"stepper.rkt" "stepper.rkt"
"prefs.rkt"
"hiding-panel.rkt"
(prefix-in sb: "../syntax-browser/embed.rkt") (prefix-in sb: "../syntax-browser/embed.rkt")
(prefix-in sb: "../syntax-browser/interfaces.rkt") (prefix-in sb: "../syntax-browser/interfaces.rkt")
"../model/deriv.rkt"
"../model/deriv-util.rkt"
"../model/trace.rkt"
"../model/steps.rkt"
"cursor.rkt"
unstable/gui/notify) unstable/gui/notify)
(provide macro-stepper-frame-mixin) (provide macro-stepper-frame-mixin)
@ -64,7 +58,8 @@
(send/i config config<%> set-width w) (send/i config config<%> set-width w)
(send/i config config<%> set-height h) (send/i config config<%> set-height h)
(unless (and (= w0 w) (= h0 h)) (unless (and (= w0 w) (= h0 h))
(send/i widget widget<%> update/preserve-view)) (when (send/i config config<%> get-refresh-on-resize?)
(send/i widget widget<%> update/preserve-view)))
(set!-values (w0 h0) (values w h))) (set!-values (w0 h0) (values w h)))
(define warning-panel (define warning-panel
@ -198,26 +193,26 @@
(menu-option/notify-box extras-menu (menu-option/notify-box extras-menu
"Highlight redex/contractum" "Highlight redex/contractum"
(get-field highlight-foci? config)) (get-field highlight-foci? config))
#|
(menu-option/notify-box extras-menu (menu-option/notify-box extras-menu
"Highlight frontier" "Highlight frontier"
(get-field highlight-frontier? config)) (get-field highlight-frontier? config))
|#
(menu-option/notify-box extras-menu (menu-option/notify-box extras-menu
"Include renaming steps" "Include renaming steps"
(get-field show-rename-steps? config)) (get-field show-rename-steps? config))
(menu-option/notify-box extras-menu (menu-option/notify-box extras-menu
"One term at a time" "One term at a time"
(get-field one-by-one? config)) (get-field one-by-one? config))
(menu-option/notify-box extras-menu
"Refresh on resize"
(get-field refresh-on-resize? config))
(menu-option/notify-box extras-menu
"Draw binding arrows"
(get-field draw-arrows? config))
(menu-option/notify-box extras-menu (menu-option/notify-box extras-menu
"Extra navigation" "Extra navigation"
(get-field extra-navigation? config)) (get-field extra-navigation? config)))
#|
(menu-option/notify-box extras-menu
"Suppress warnings"
(get-field suppress-warnings? config))
(menu-option/notify-box extras-menu
"(Debug) Catch internal errors?"
(get-field debug-catch-errors? config))
|#)
;; fixup-menu : menu -> void ;; fixup-menu : menu -> void
;; Delete separators at beginning/end and duplicates in middle ;; Delete separators at beginning/end and duplicates in middle

105
collects/macro-debugger/view/gui-util.rkt Normal file
View File

@ -0,0 +1,105 @@
#lang racket/base
(require racket/class
racket/gui/base)
(provide status-area%)
(define FADE-DELAY 1000)
(define NAP-TIME 0.01)
(define status-area%
(class* object% (#| status-area<%> |#)
(init parent
stop-callback)
(define lock (make-semaphore 1))
(define-syntax-rule (with-lock . body)
(dynamic-wind (lambda () (yield lock))
(lambda () . body)
(lambda () (semaphore-post lock))))
(define timer (new timer% (notify-callback (lambda () (fade-out)))))
(define pane
(new horizontal-pane%
(parent parent)
(stretchable-height #f)))
(define message
(new message%
(parent pane)
(label "")
(auto-resize #t)
(stretchable-width #t)
(style '(deleted))))
(define stop-button
(new button%
(parent pane)
(label "Stop")
(enabled #f)
(callback stop-callback)
(style '(deleted))))
(define visible? #t)
(define/public (set-visible new-visible?)
(with-lock
(set! visible? new-visible?)
(show (memq state '(shown fade)))))
#|
Three states:
- 'none = no message displayed
- 'shown = message displayed
- 'fade = message displayed, waiting to erase
Timer is only started during 'fade state.
|#
(define state 'none)
(define/private (show ?)
(send pane change-children
(lambda _
(if (and ? visible?)
(list message stop-button)
null))))
(define/public (set-status msg)
(with-lock
(cond [msg
(case state
((none)
(send message set-label msg)
(send message enable #t)
(show #t)
(set! state 'shown))
((shown)
(send message set-label msg))
((fade)
(send timer stop) ;; but (update) may already be waiting
(send message set-label msg)
(send message enable #t)
(set! state 'shown)))]
[(not msg)
(case state
((shown)
(send timer start FADE-DELAY #t)
(send message enable #f)
(set! state 'fade)))])))
(define/private (fade-out)
(with-lock (fade-out*)))
(define/private (fade-out*)
(case state
((fade)
(show #f)
(send message set-label "")
(set! state 'none))
(else
;; timer not stopped in time; do nothing
(void))))
(define/public (enable-stop ?)
(send stop-button enable ?))
(super-new)))

3
collects/macro-debugger/view/hiding-panel.rkt
View File

@ -1,7 +1,8 @@
#lang racket/base #lang racket/base
(require racket/class (require racket/class
racket/gui racket/gui/base
racket/list racket/list
racket/match
unstable/class-iop unstable/class-iop
"interfaces.rkt" "interfaces.rkt"
"../model/hiding-policies.rkt" "../model/hiding-policies.rkt"

4
collects/macro-debugger/view/interfaces.rkt
View File

@ -4,7 +4,9 @@
(provide (all-defined-out)) (provide (all-defined-out))
(define-interface config<%> (sb:config<%>) (define-interface config<%> (sb:config<%>)
((sb:methods:notify macro-hiding-mode ((sb:methods:notify draw-arrows?
refresh-on-resize?
macro-hiding-mode
show-hiding-panel? show-hiding-panel?
identifier=? identifier=?
highlight-foci? highlight-foci?

11
collects/macro-debugger/view/prefs.rkt
View File

@ -14,6 +14,8 @@
(preferences:set-default 'MacroStepper:Frame:Height 600 number?) (preferences:set-default 'MacroStepper:Frame:Height 600 number?)
(preferences:set-default 'MacroStepper:PropertiesShown? #f boolean?) (preferences:set-default 'MacroStepper:PropertiesShown? #f boolean?)
(preferences:set-default 'MacroStepper:PropertiesPanelPercentage 1/3 number?) (preferences:set-default 'MacroStepper:PropertiesPanelPercentage 1/3 number?)
(preferences:set-default 'MacroStepper:DrawArrows? #t boolean?)
(preferences:set-default 'MacroStepper:MacroHidingMode "Standard" string?) (preferences:set-default 'MacroStepper:MacroHidingMode "Standard" string?)
(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?)
@ -27,11 +29,14 @@
(preferences:set-default 'MacroStepper:SplitContext? #f boolean?) (preferences:set-default 'MacroStepper:SplitContext? #f boolean?)
(preferences:set-default 'MacroStepper:MacroStepLimit 40000 (preferences:set-default 'MacroStepper:MacroStepLimit 40000
(lambda (x) (or (eq? x #f) (exact-positive-integer? x)))) (lambda (x) (or (eq? x #f) (exact-positive-integer? x))))
(preferences:set-default 'MacroStepper:RefreshOnResize? #t boolean?)
(define pref:width (pref:get/set 'MacroStepper:Frame:Width)) (define pref:width (pref:get/set 'MacroStepper:Frame:Width))
(define pref:height (pref:get/set 'MacroStepper:Frame:Height)) (define pref:height (pref:get/set 'MacroStepper:Frame:Height))
(define pref:props-shown? (pref:get/set 'MacroStepper:PropertiesShown?)) (define pref:props-shown? (pref:get/set 'MacroStepper:PropertiesShown?))
(define pref:props-percentage (pref:get/set 'MacroStepper:PropertiesPanelPercentage)) (define pref:props-percentage (pref:get/set 'MacroStepper:PropertiesPanelPercentage))
(define pref:draw-arrows? (pref:get/set 'MacroStepper:DrawArrows?))
(define pref:macro-hiding-mode (pref:get/set 'MacroStepper:MacroHidingMode)) (define pref:macro-hiding-mode (pref:get/set 'MacroStepper:MacroHidingMode))
(define pref:show-hiding-panel? (pref:get/set 'MacroStepper:ShowHidingPanel?)) (define pref:show-hiding-panel? (pref:get/set 'MacroStepper:ShowHidingPanel?))
(define pref:identifier=? (pref:get/set 'MacroStepper:IdentifierComparison)) (define pref:identifier=? (pref:get/set 'MacroStepper:IdentifierComparison))
@ -44,7 +49,7 @@
(define pref:debug-catch-errors? (pref:get/set 'MacroStepper:DebugCatchErrors?)) (define pref:debug-catch-errors? (pref:get/set 'MacroStepper:DebugCatchErrors?))
(define pref:split-context? (pref:get/set 'MacroStepper:SplitContext?)) (define pref:split-context? (pref:get/set 'MacroStepper:SplitContext?))
(define pref:macro-step-limit (pref:get/set 'MacroStepper:MacroStepLimit)) (define pref:macro-step-limit (pref:get/set 'MacroStepper:MacroStepLimit))
(define pref:refresh-on-resize? (pref:get/set 'MacroStepper:RefreshOnResize?))
(define macro-stepper-config-base% (define macro-stepper-config-base%
(class* prefs-base% (config<%>) (class* prefs-base% (config<%>)
@ -58,6 +63,7 @@
(height pref:height) (height pref:height)
(props-percentage pref:props-percentage) (props-percentage pref:props-percentage)
(props-shown? pref:props-shown?) (props-shown? pref:props-shown?)
(draw-arrows? pref:draw-arrows?)
(macro-hiding-mode pref:macro-hiding-mode) (macro-hiding-mode pref:macro-hiding-mode)
(show-hiding-panel? pref:show-hiding-panel?) (show-hiding-panel? pref:show-hiding-panel?)
(identifier=? pref:identifier=?) (identifier=? pref:identifier=?)
@ -68,7 +74,8 @@
(one-by-one? pref:one-by-one?) (one-by-one? pref:one-by-one?)
(extra-navigation? pref:extra-navigation?) (extra-navigation? pref:extra-navigation?)
(debug-catch-errors? pref:debug-catch-errors?) (debug-catch-errors? pref:debug-catch-errors?)
(split-context? pref:split-context?)) (split-context? pref:split-context?)
(refresh-on-resize? pref:refresh-on-resize?))
(super-new))) (super-new)))
(define macro-stepper-config/prefs% (define macro-stepper-config/prefs%

40
collects/macro-debugger/view/step-display.rkt
View File

@ -3,23 +3,11 @@
racket/unit racket/unit
racket/list racket/list
racket/match racket/match
racket/gui racket/gui/base
framework
unstable/class-iop unstable/class-iop
"interfaces.rkt" "interfaces.rkt"
"prefs.rkt"
"extensions.rkt"
"hiding-panel.rkt"
"../model/deriv.rkt"
"../model/deriv-util.rkt"
"../model/deriv-parser.rkt"
"../model/trace.rkt"
"../model/reductions-config.rkt"
"../model/reductions.rkt"
"../model/steps.rkt" "../model/steps.rkt"
unstable/gui/notify
(prefix-in sb: "../syntax-browser/interfaces.rkt") (prefix-in sb: "../syntax-browser/interfaces.rkt")
"cursor.rkt"
"debug-format.rkt") "debug-format.rkt")
#; #;
@ -43,9 +31,13 @@
(define/public (add-internal-error part exn stx events) (define/public (add-internal-error part exn stx events)
(send/i sbview sb:syntax-browser<%> add-text (send/i sbview sb:syntax-browser<%> add-text
(string-append
(if (exn:break? exn)
"Macro stepper was interrupted"
"Macro stepper error")
(if part (if part
(format "Macro stepper error (~a)" part) (format " (~a)" part)
"Macro stepper error")) "")))
(when (exn? exn) (when (exn? exn)
(send/i sbview sb:syntax-browser<%> add-text " ") (send/i sbview sb:syntax-browser<%> add-text " ")
(send/i sbview sb:syntax-browser<%> add-clickback "[details]" (send/i sbview sb:syntax-browser<%> add-clickback "[details]"
@ -56,7 +48,9 @@
(when stx (send/i sbview sb:syntax-browser<%> add-syntax stx))) (when stx (send/i sbview sb:syntax-browser<%> add-syntax stx)))
(define/private (show-internal-error-details exn events) (define/private (show-internal-error-details exn events)
(case (message-box/custom "Macro stepper internal error" (case (message-box/custom (if (exn:break? exn)
"Macro stepper was interrupted"
"Macro stepper internal error")
(format "Internal error:\n~a" (exn-message exn)) (format "Internal error:\n~a" (exn-message exn))
"Show error" "Show error"
"Dump debugging file" "Dump debugging file"
@ -90,8 +84,8 @@
(show-poststep step shift-table)])) (show-poststep step shift-table)]))
(define/public (add-syntax stx (define/public (add-syntax stx
#:binders [binders null] #:binders [binders #f]
#:definites [definites null] #:definites [definites #f]
#:shift-table [shift-table #f]) #:shift-table [shift-table #f])
(send/i sbview sb:syntax-browser<%> add-syntax stx (send/i sbview sb:syntax-browser<%> add-syntax stx
#:binders binders #:binders binders
@ -221,8 +215,8 @@
(when (exn:fail:syntax? (misstep-exn step)) (when (exn:fail:syntax? (misstep-exn step))
(for ([e (exn:fail:syntax-exprs (misstep-exn step))]) (for ([e (exn:fail:syntax-exprs (misstep-exn step))])
(send/i sbview sb:syntax-browser<%> add-syntax e (send/i sbview sb:syntax-browser<%> add-syntax e
#:binders (or (state-binders state) null) #:binders (state-binders state)
#:definites (or (state-uses state) null) #:definites (state-uses state)
#:shift-table shift-table))) #:shift-table shift-table)))
(show-lctx step shift-table)) (show-lctx step shift-table))
@ -236,8 +230,8 @@
[(syntax? content) [(syntax? content)
(send*/i sbview sb:syntax-browser<%> (send*/i sbview sb:syntax-browser<%>
(add-syntax content (add-syntax content
#:binders (or (state-binders state) null) #:binders (state-binders state)
#:definites (or (state-uses state) null) #:definites (state-uses state)
#:shift-table shift-table) #:shift-table shift-table)
(add-text "\n"))])) (add-text "\n"))]))
(show-lctx step shift-table)) (show-lctx step shift-table))
@ -248,7 +242,7 @@
(define highlight-foci? (send/i config config<%> get-highlight-foci?)) (define highlight-foci? (send/i config config<%> get-highlight-foci?))
(define highlight-frontier? (send/i config config<%> get-highlight-frontier?)) (define highlight-frontier? (send/i config config<%> get-highlight-frontier?))
(send/i sbview sb:syntax-browser<%> add-syntax stx (send/i sbview sb:syntax-browser<%> add-syntax stx
#:definites (or definites null) #:definites definites
#:binders binders #:binders binders
#:shift-table shift-table #:shift-table shift-table
#:hi-colors (list hi-color #:hi-colors (list hi-color

216
collects/macro-debugger/view/stepper.rkt
View File

@ -3,11 +3,10 @@
racket/unit racket/unit
racket/list racket/list
racket/match racket/match
racket/gui racket/gui/base
framework racket/pretty
unstable/class-iop unstable/class-iop
"interfaces.rkt" "interfaces.rkt"
"prefs.rkt"
"extensions.rkt" "extensions.rkt"
"hiding-panel.rkt" "hiding-panel.rkt"
"term-record.rkt" "term-record.rkt"
@ -15,10 +14,9 @@
(prefix-in sb: "../syntax-browser/interfaces.rkt") (prefix-in sb: "../syntax-browser/interfaces.rkt")
"../model/deriv.rkt" "../model/deriv.rkt"
"../model/deriv-util.rkt" "../model/deriv-util.rkt"
"../model/trace.rkt"
"../model/reductions.rkt"
"../model/steps.rkt"
"cursor.rkt" "cursor.rkt"
"gui-util.rkt"
"../syntax-browser/util.rkt"
unstable/gui/notify unstable/gui/notify
(only-in mzscheme [#%top-interaction mz-top-interaction])) (only-in mzscheme [#%top-interaction mz-top-interaction]))
(provide macro-stepper-widget% (provide macro-stepper-widget%
@ -33,6 +31,13 @@
(init-field config) (init-field config)
(init-field/i (director director<%>)) (init-field/i (director director<%>))
(define frame (send parent get-top-level-window))
(define eventspace (send frame get-eventspace))
(define-syntax-rule (with-eventspace . body)
(parameterize ((current-eventspace eventspace))
(queue-callback (lambda () . body))))
;; Terms ;; Terms
;; all-terms : (list-of TermRecord) ;; all-terms : (list-of TermRecord)
@ -61,7 +66,8 @@
(add trec))) (add trec)))
;; add : TermRecord -> void ;; add : TermRecord -> void
(define/public (add trec) (define/private (add trec)
(with-eventspace
(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/i trec term-record<%> get-deriv-hidden?)]) [invisible? (send/i trec term-record<%> get-deriv-hidden?)])
@ -70,7 +76,7 @@
(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)
@ -103,7 +109,11 @@
(send/i sbc sb:controller<%> reset-primary-partition) (send/i sbc sb:controller<%> reset-primary-partition)
(update/preserve-view)) (update/preserve-view))
(define area (new vertical-panel% (parent parent))) (define superarea (new vertical-pane% (parent parent)))
(define area
(new vertical-panel%
(parent superarea)
(enabled #f)))
(define supernavigator (define supernavigator
(new horizontal-panel% (new horizontal-panel%
(parent area) (parent area)
@ -135,12 +145,18 @@
(send/i sbview sb:syntax-browser<%> get-controller)) (send/i sbview sb:syntax-browser<%> get-controller))
(define control-pane (define control-pane
(new vertical-panel% (parent area) (stretchable-height #f))) (new vertical-panel% (parent area) (stretchable-height #f)))
(define/i macro-hiding-prefs hiding-prefs<%> (define/i macro-hiding-prefs hiding-prefs<%>
(new macro-hiding-prefs-widget% (new macro-hiding-prefs-widget%
(parent control-pane) (parent control-pane)
(stepper this) (stepper this)
(config config))) (config config)))
(define status-area
(new status-area%
(parent superarea)
(stop-callback (lambda _ (stop-processing)))))
(send/i sbc sb:controller<%> (send/i sbc sb:controller<%>
listen-selected-syntax listen-selected-syntax
(lambda (stx) (send/i macro-hiding-prefs hiding-prefs<%> set-syntax stx))) (lambda (stx) (send/i macro-hiding-prefs hiding-prefs<%> set-syntax stx)))
@ -243,28 +259,25 @@
(list navigator extra-navigator) (list navigator extra-navigator)
(list navigator))))) (list navigator)))))
(define/public (change-status msg)
(send status-area set-status msg))
;; Navigation ;; Navigation
#|
(define/public-final (at-start?)
(send/i (focused-term) term-record<%> at-start?))
(define/public-final (at-end?)
(send/i (focused-term) term-record<%> at-end?))
|#
(define/public-final (navigate-to-start) (define/public-final (navigate-to-start)
(send/i (focused-term) term-record<%> navigate-to-start) (send/i (focused-term) term-record<%> navigate-to-start)
(update/save-position)) (update/preserve-lines-view))
(define/public-final (navigate-to-end) (define/public-final (navigate-to-end)
(send/i (focused-term) term-record<%> navigate-to-end) (send/i (focused-term) term-record<%> navigate-to-end)
(update/save-position)) (update/preserve-lines-view))
(define/public-final (navigate-previous) (define/public-final (navigate-previous)
(send/i (focused-term) term-record<%> navigate-previous) (send/i (focused-term) term-record<%> navigate-previous)
(update/save-position)) (update/preserve-lines-view))
(define/public-final (navigate-next) (define/public-final (navigate-next)
(send/i (focused-term) term-record<%> navigate-next) (send/i (focused-term) term-record<%> navigate-next)
(update/save-position)) (update/preserve-lines-view))
(define/public-final (navigate-to n) (define/public-final (navigate-to n)
(send/i (focused-term) term-record<%> navigate-to n) (send/i (focused-term) term-record<%> navigate-to n)
(update/save-position)) (update/preserve-lines-view))
(define/public-final (navigate-up) (define/public-final (navigate-up)
(when (focused-term) (when (focused-term)
@ -277,108 +290,159 @@
(cursor:move-next terms) (cursor:move-next terms)
(refresh/move)) (refresh/move))
;; Update ;; enable/disable-buttons : -> void
(define/private (enable/disable-buttons [? #t])
(define term (and ? (focused-term)))
;; (message-box "alert" (format "enable/disable: ~s" ?))
(send area enable ?)
(send (send frame get-menu-bar) enable ?)
(send nav:start enable (and ? term (send/i term term-record<%> has-prev?)))
(send nav:previous enable (and ? term (send/i term term-record<%> has-prev?)))
(send nav:next enable (and ? term (send/i term term-record<%> has-next?)))
(send nav:end enable (and ? term (send/i term term-record<%> has-next?)))
(send nav:text enable (and ? term #t))
(send nav:up enable (and ? (cursor:has-prev? terms)))
(send nav:down enable (and ? (cursor:has-next? terms)))
(send status-area enable-stop (not ?)))
;; update/save-position : -> void ;; Async update & refresh
(define/private (update/save-position)
(update/preserve-lines-view)) (define update-thread #f)
(define ASYNC-DELAY 500) ;; milliseconds
(define/private (call-with-update-thread thunk)
(send status-area set-visible #f)
(let* ([lock (make-semaphore 1)] ;; mutex for status variable
[status #f] ;; mutable: one of #f, 'done, 'async
[thd
(parameterize-break #f
(thread (lambda ()
(with-handlers ([exn:break?
(lambda (e)
(change-status "Interrupted")
(void))])
(parameterize-break #t
(thunk)
(change-status #f)))
(semaphore-wait lock)
(case status
((async)
(set! update-thread #f)
(with-eventspace
(enable/disable-buttons #t)))
(else
(set! status 'done)))
(semaphore-post lock))))])
(sync thd (alarm-evt (+ (current-inexact-milliseconds) ASYNC-DELAY)))
(semaphore-wait lock)
(case status
((done)
;; Thread finished; enable/disable skipped, so do it now to update.
(enable/disable-buttons #t))
(else
(set! update-thread thd)
(send status-area set-visible #t)
(enable/disable-buttons #f)
(set! status 'async)))
(semaphore-post lock)))
(define-syntax-rule (with-update-thread . body)
(call-with-update-thread (lambda () . body)))
(define/private (stop-processing)
(let ([t update-thread])
(when t (break-thread t))))
;; Update
;; update/preserve-lines-view : -> void ;; update/preserve-lines-view : -> void
(define/public (update/preserve-lines-view) (define/public (update/preserve-lines-view)
(with-update-thread
(define text (send/i sbview sb:syntax-browser<%> get-text)) (define text (send/i sbview sb:syntax-browser<%> get-text))
(define start-box (box 0)) (define start-box (box 0))
(define end-box (box 0)) (define end-box (box 0))
(send text get-visible-line-range start-box end-box) (send text get-visible-line-range start-box end-box)
(update) (update*)
(send text scroll-to-position (send text scroll-to-position
(send text line-start-position (unbox start-box)) (send text line-start-position (unbox start-box))
#f #f
(send text line-start-position (unbox end-box)) (send text line-start-position (unbox end-box))
'start)) 'start)))
;; update/preserve-view : -> void ;; update/preserve-view : -> void
(define/public (update/preserve-view) (define/public (update/preserve-view)
(with-update-thread
(define text (send/i sbview sb:syntax-browser<%> get-text)) (define text (send/i sbview sb:syntax-browser<%> get-text))
(define start-box (box 0)) (define start-box (box 0))
(define end-box (box 0)) (define end-box (box 0))
(send text get-visible-position-range start-box end-box) (send text get-visible-position-range start-box end-box)
(update) (update*)
(send text scroll-to-position (unbox start-box) #f (unbox end-box) 'start)) (send text scroll-to-position (unbox start-box) #f (unbox end-box) 'start)))
;; update : -> void ;; update : -> void
;; Updates the terms in the syntax browser to the current step ;; Updates the terms in the syntax browser to the current step
(define/private (update) (define/private (update)
(with-update-thread
(update*)))
(define/private (update*)
;; update:show-prefix : -> void
(define (update:show-prefix)
;; Show the final terms from the cached synth'd derivs
(for ([trec (in-list (cursor:prefix->list terms))])
(send/i trec term-record<%> display-final-term)))
;; update:show-current-step : -> void
(define (update:show-current-step)
(when (focused-term)
(send/i (focused-term) term-record<%> display-step)))
;; update:show-suffix : -> void
(define (update:show-suffix)
(let ([suffix0 (cursor:suffix->list terms)])
(when (pair? suffix0)
(for ([trec (in-list (cdr suffix0))])
(send/i trec term-record<%> display-initial-term)))))
;; update-nav-index : -> void
(define (update-nav-index)
(define term (focused-term))
(set-current-step-index
(and term (send/i term term-record<%> get-step-index))))
(define text (send/i sbview sb:syntax-browser<%> get-text)) (define text (send/i sbview sb:syntax-browser<%> get-text))
(define position-of-interest 0) (define position-of-interest 0)
(define multiple-terms? (> (length (cursor->list terms)) 1)) (define multiple-terms? (> (length (cursor->list terms)) 1))
(send text begin-edit-sequence #f)
(send/i sbview sb:syntax-browser<%> erase-all)
(with-unlock text
(send/i sbview sb:syntax-browser<%> erase-all)
(update:show-prefix) (update:show-prefix)
(when multiple-terms? (send/i sbview sb:syntax-browser<%> add-separator)) (when multiple-terms? (send/i sbview sb:syntax-browser<%> add-separator))
(set! position-of-interest (send text last-position)) (set! position-of-interest (send text last-position))
(update:show-current-step) (update:show-current-step)
(when multiple-terms? (send/i sbview sb:syntax-browser<%> add-separator)) (when multiple-terms? (send/i sbview sb:syntax-browser<%> add-separator))
(update:show-suffix) (update:show-suffix))
(send text end-edit-sequence)
(send text scroll-to-position (send text scroll-to-position
position-of-interest position-of-interest
#f #f
(send text last-position) (send text last-position)
'start) 'start)
(update-nav-index) (update-nav-index)
(enable/disable-buttons)) (change-status #f))
;; update:show-prefix : -> void
(define/private (update:show-prefix)
;; Show the final terms from the cached synth'd derivs
(for-each (lambda (trec) (send/i trec term-record<%> display-final-term))
(cursor:prefix->list terms)))
;; update:show-current-step : -> void
(define/private (update:show-current-step)
(when (focused-term)
(send/i (focused-term) term-record<%> display-step)))
;; update:show-suffix : -> void
(define/private (update:show-suffix)
(let ([suffix0 (cursor:suffix->list terms)])
(when (pair? suffix0)
(for-each (lambda (trec)
(send/i trec term-record<%> display-initial-term))
(cdr suffix0)))))
;; update-nav-index : -> void
(define/private (update-nav-index)
(define term (focused-term))
(set-current-step-index
(and term (send/i term term-record<%> get-step-index))))
;; enable/disable-buttons : -> void
(define/private (enable/disable-buttons)
(define term (focused-term))
(send nav:start enable (and term (send/i term term-record<%> has-prev?)))
(send nav:previous enable (and term (send/i term term-record<%> has-prev?)))
(send nav:next enable (and term (send/i term term-record<%> has-next?)))
(send nav:end enable (and term (send/i term term-record<%> has-next?)))
(send nav:text enable (and term #t))
(send nav:up enable (cursor:has-prev? terms))
(send nav:down enable (cursor:has-next? terms)))
;; -- ;; --
;; refresh/resynth : -> void ;; refresh/resynth : -> void
;; Macro hiding policy has changed; invalidate cached parts of trec ;; Macro hiding policy has changed; invalidate cached parts of trec
(define/public (refresh/resynth) (define/public (refresh/resynth)
(for-each (lambda (trec) (send/i trec term-record<%> invalidate-synth!)) (for ([trec (in-list (cursor->list terms))])
(cursor->list terms)) (send/i trec term-record<%> invalidate-synth!))
(refresh)) (refresh))
;; refresh/re-reduce : -> void ;; refresh/re-reduce : -> void
;; Reduction config has changed; invalidate cached parts of trec ;; Reduction config has changed; invalidate cached parts of trec
(define/private (refresh/re-reduce) (define/private (refresh/re-reduce)
(for-each (lambda (trec) (send/i trec term-record<%> invalidate-steps!)) (for ([trec (in-list (cursor->list terms))])
(cursor->list terms)) (send/i trec term-record<%> invalidate-steps!))
(refresh)) (refresh))
;; refresh/move : -> void ;; refresh/move : -> void
@ -388,6 +452,7 @@
;; refresh : -> void ;; refresh : -> void
(define/public (refresh) (define/public (refresh)
(with-update-thread
(when (focused-term) (when (focused-term)
(send/i (focused-term) term-record<%> on-get-focus)) (send/i (focused-term) term-record<%> on-get-focus))
(send nav:step-count set-label "") (send nav:step-count set-label "")
@ -397,9 +462,7 @@
(when step-count (when step-count
;; +1 for end of expansion "step" ;; +1 for end of expansion "step"
(send nav:step-count set-label (format "of ~s" (add1 step-count))))))) (send nav:step-count set-label (format "of ~s" (add1 step-count)))))))
(update)) (update*)))
(define/private (foci x) (if (list? x) x (list x)))
;; Hiding policy ;; Hiding policy
@ -415,7 +478,6 @@
(super-new) (super-new)
(show-macro-hiding-panel (send/i config config<%> get-show-hiding-panel?)) (show-macro-hiding-panel (send/i config config<%> get-show-hiding-panel?))
(show-extra-navigation (send/i config config<%> get-extra-navigation?)) (show-extra-navigation (send/i config config<%> get-extra-navigation?))
(refresh/move)
)) ))
(define (macro-stepper-widget/process-mixin %) (define (macro-stepper-widget/process-mixin %)

37
collects/macro-debugger/view/term-record.rkt
View File

@ -3,15 +3,11 @@
racket/unit racket/unit
racket/list racket/list
racket/match racket/match
racket/gui racket/gui/base
framework
syntax/stx syntax/stx
unstable/find unstable/find
unstable/class-iop unstable/class-iop
"interfaces.rkt" "interfaces.rkt"
"prefs.rkt"
"extensions.rkt"
"hiding-panel.rkt"
"step-display.rkt" "step-display.rkt"
"../model/deriv.rkt" "../model/deriv.rkt"
"../model/deriv-util.rkt" "../model/deriv-util.rkt"
@ -20,9 +16,7 @@
"../model/reductions-config.rkt" "../model/reductions-config.rkt"
"../model/reductions.rkt" "../model/reductions.rkt"
"../model/steps.rkt" "../model/steps.rkt"
unstable/gui/notify "cursor.rkt")
"cursor.rkt"
"debug-format.rkt")
(provide term-record%) (provide term-record%)
@ -61,6 +55,12 @@
(define steps-position #f) (define steps-position #f)
(define/private (status msg)
(send stepper change-status msg))
(define-syntax-rule (with-status msg . body)
(begin (send stepper change-status msg)
(begin0 (let () . body))))
(super-new) (super-new)
(define-syntax define-guarded-getters (define-syntax define-guarded-getters
@ -120,22 +120,24 @@
(with-handlers ([(lambda (e) #t) (with-handlers ([(lambda (e) #t)
(lambda (e) (lambda (e)
(set! raw-deriv-oops e))]) (set! raw-deriv-oops e))])
(with-status "Parsing expansion derivation"
(set! raw-deriv (set! raw-deriv
(parse-derivation (parse-derivation
(events->token-generator events)))))) (events->token-generator events)))))))
;; recache-deriv! : -> void ;; recache-deriv! : -> void
(define/private (recache-deriv!) (define/private (recache-deriv!)
(unless (or deriv deriv-hidden?) (unless (or deriv deriv-hidden?)
(recache-raw-deriv!) (recache-raw-deriv!)
(when raw-deriv (when raw-deriv
(with-status "Processing expansion derivation"
(let ([process (send/i stepper widget<%> get-preprocess-deriv)]) (let ([process (send/i stepper widget<%> get-preprocess-deriv)])
(let ([d (process raw-deriv)]) (let ([d (process raw-deriv)])
(when (not d) (when (not d)
(set! deriv-hidden? #t)) (set! deriv-hidden? #t))
(when d (when d
(set! deriv d) (set! deriv d)
(set! shift-table (compute-shift-table d)))))))) (set! shift-table (compute-shift-table d)))))))))
;; recache-synth! : -> void ;; recache-synth! : -> void
(define/private (recache-synth!) (define/private (recache-synth!)
@ -146,6 +148,7 @@
(unless (or raw-steps raw-steps-oops) (unless (or raw-steps raw-steps-oops)
(recache-synth!) (recache-synth!)
(when deriv (when deriv
(with-status "Computing reduction steps"
(let ([show-macro? (or (send/i stepper widget<%> get-show-macro?) (let ([show-macro? (or (send/i stepper widget<%> get-show-macro?)
(lambda (id) #t))]) (lambda (id) #t))])
(with-handlers ([(lambda (e) #t) (with-handlers ([(lambda (e) #t)
@ -158,13 +161,14 @@
(set! raw-steps-estx estx*) (set! raw-steps-estx estx*)
(set! raw-steps-exn error*) (set! raw-steps-exn error*)
(set! raw-steps-binders binders*) (set! raw-steps-binders binders*)
(set! raw-steps-definites definites*))))))) (set! raw-steps-definites definites*))))))))
;; recache-steps! : -> void ;; recache-steps! : -> void
(define/private (recache-steps!) (define/private (recache-steps!)
(unless (or steps) (unless (or steps)
(recache-raw-steps!) (recache-raw-steps!)
(when raw-steps (when raw-steps
(with-status "Processing reduction steps"
(set! steps (set! steps
(and raw-steps (and raw-steps
(let* ([filtered-steps (let* ([filtered-steps
@ -177,7 +181,7 @@
(reduce:one-by-one filtered-steps) (reduce:one-by-one filtered-steps)
filtered-steps)]) filtered-steps)])
(cursor:new processed-steps)))) (cursor:new processed-steps))))
(restore-position)))) (restore-position)))))
;; reduce:one-by-one : (list-of step) -> (list-of step) ;; reduce:one-by-one : (list-of step) -> (list-of step)
(define/private (reduce:one-by-one rs) (define/private (reduce:one-by-one rs)
@ -274,15 +278,17 @@
;; display-initial-term : -> void ;; display-initial-term : -> void
(define/public (display-initial-term) (define/public (display-initial-term)
(with-status "Rendering term"
(cond [raw-deriv-oops (cond [raw-deriv-oops
(send/i displayer step-display<%> add-internal-error (send/i displayer step-display<%> add-internal-error
"derivation" raw-deriv-oops #f events)] "derivation" raw-deriv-oops #f events)]
[else [else
(send/i displayer step-display<%> add-syntax (wderiv-e1 deriv))])) (send/i displayer step-display<%> add-syntax (wderiv-e1 deriv))])))
;; display-final-term : -> void ;; display-final-term : -> void
(define/public (display-final-term) (define/public (display-final-term)
(recache-steps!) (recache-steps!)
(with-status "Rendering term"
(cond [(syntax? raw-steps-estx) (cond [(syntax? raw-steps-estx)
(send/i displayer step-display<%> add-syntax raw-steps-estx (send/i displayer step-display<%> add-syntax raw-steps-estx
#:binders raw-steps-binders #:binders raw-steps-binders
@ -290,11 +296,12 @@
#:definites raw-steps-definites)] #:definites raw-steps-definites)]
[(exn? raw-steps-exn) [(exn? raw-steps-exn)
(send/i displayer step-display<%> add-error raw-steps-exn)] (send/i displayer step-display<%> add-error raw-steps-exn)]
[else (display-oops #f)])) [else (display-oops #f)])))
;; display-step : -> void ;; display-step : -> void
(define/public (display-step) (define/public (display-step)
(recache-steps!) (recache-steps!)
(with-status "Rendering step"
(cond [steps (cond [steps
(let ([step (cursor:next steps)]) (let ([step (cursor:next steps)])
(if step (if step
@ -304,7 +311,7 @@
#:binders raw-steps-binders #:binders raw-steps-binders
#:shift-table shift-table #:shift-table shift-table
#:definites raw-steps-definites)))] #:definites raw-steps-definites)))]
[else (display-oops #t)])) [else (display-oops #t)])))
;; display-oops : boolean -> void ;; display-oops : boolean -> void
(define/private (display-oops show-syntax?) (define/private (display-oops show-syntax?)

33
collects/macro-debugger/view/view.rkt
View File

@ -1,7 +1,7 @@
#lang racket/base #lang racket/base
(require racket/class (require racket/class
racket/pretty racket/pretty
racket/gui racket/gui/base
framework framework
unstable/class-iop unstable/class-iop
"interfaces.rkt" "interfaces.rkt"
@ -9,8 +9,7 @@
"prefs.rkt" "prefs.rkt"
"../model/trace.rkt") "../model/trace.rkt")
(provide macro-stepper-director% (provide macro-stepper-director%
macro-stepper-frame% macro-stepper-frame%)
go)
(define macro-stepper-director% (define macro-stepper-director%
(class* object% (director<%>) (class* object% (director<%>)
@ -24,24 +23,26 @@
(hash-remove! stepper-frames s)) (hash-remove! stepper-frames s))
(define/public (add-obsoleted-warning) (define/public (add-obsoleted-warning)
(hash-for-each stepper-frames (for ([(stepper-frame flags) (in-hash stepper-frames)])
(lambda (stepper-frame flags)
(unless (memq 'no-obsolete flags) (unless (memq 'no-obsolete flags)
(send/i stepper-frame stepper-frame<%> add-obsoleted-warning))))) (send/i stepper-frame stepper-frame<%> add-obsoleted-warning))))
(define/public (add-trace events) (define/public (add-trace events)
(hash-for-each stepper-frames (for ([(stepper-frame flags) (in-hash stepper-frames)])
(lambda (stepper-frame flags)
(unless (memq 'no-new-traces flags) (unless (memq 'no-new-traces flags)
(send/i (send/i stepper-frame stepper-frame<%> get-widget) widget<%> (send/i (send/i stepper-frame stepper-frame<%> get-widget) widget<%>
add-trace events))))) add-trace events))))
(define/public (add-deriv deriv) (define/public (add-deriv deriv)
(hash-for-each stepper-frames (for ([(stepper-frame flags) (in-hash stepper-frames)])
(lambda (stepper-frame flags)
(unless (memq 'no-new-traces flags) (unless (memq 'no-new-traces flags)
(send/i (send/i stepper-frame stepper-frame<%> get-widget) widget<%> (send/i (send/i stepper-frame stepper-frame<%> get-widget) widget<%>
add-deriv deriv))))) add-deriv deriv))))
;; PRE: current thread = current eventspace's handler thread
(define/public (new-stepper [flags '()]) (define/public (new-stepper [flags '()])
(unless (eq? (current-thread)
(eventspace-handler-thread (current-eventspace)))
(error 'macro-stepper-director
"new-stepper method called from wrong thread"))
(define stepper-frame (new-stepper-frame)) (define stepper-frame (new-stepper-frame))
(define stepper (send/i stepper-frame stepper-frame<%> get-widget)) (define stepper (send/i stepper-frame stepper-frame<%> get-widget))
(send stepper-frame show #t) (send stepper-frame show #t)
@ -59,11 +60,3 @@
(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
(define (go stx)
(define director (new macro-stepper-director%))
(define stepper (send/i director director<%> new-stepper))
(send/i director director<%> add-deriv (trace stx))
(void))