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

35
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
location.
@section{Macro stepper}
@defmodule[macro-debugger/stepper]
@defproc[(expand/step [stx any/c])
(is-a/c macro-stepper<%>)]{
void?]{
Expands the syntax (or S-expression) and opens a macro stepper frame
for stepping through the expansion.
Expands the syntax (or S-expression) and opens a macro stepper frame
for stepping through the expansion.
}
@definterface[macro-stepper<%> ()]{
@defproc[(expand-module/step [mod module-path?])
void?]{
@defmethod[(at-start?) boolean?]
@defmethod[(at-end?) boolean?]
@defmethod[(navigate-to-start) void?]
@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?]
Expands the source file named by @racket[mod], which must contains a
single module declaration, and opens a macro stepper frame for
stepping through the expansion.
}
@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.)
}
@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
of macro hiding.
}
@section{Macro stepper text interface}
@defmodule[macro-debugger/stepper-text]
@ -188,6 +182,7 @@ of macro hiding.
@scheme['all] to print out all remaining steps.
}
@section{Syntax browser}
@defmodule[macro-debugger/syntax-browser]
@ -208,14 +203,6 @@ of macro hiding.
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}

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-provide (prov) #: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)
;; contents : (listof (U string syntax))

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

@ -43,6 +43,7 @@
enter-check exit-check
local-post exit-local exit-local/expr
local-bind enter-bind exit-bind
local-value-result
phase-up module-body
renames-lambda
renames-case-lambda
@ -201,6 +202,10 @@
(make local-bind $1 $2 $3 #f)]
[(local-bind rename-list (? BindSyntaxes))
(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)
(make local-remark $1)]
[(local-artificial-step)

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

@ -61,6 +61,10 @@
local-remark ; (listof (U string 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
@ -175,8 +179,10 @@
(149 prim-varref)
(150 lift-require ,token-lift-require)
(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)
(if (symbol? sig)

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

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

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

@ -1,5 +1,3 @@
#lang racket/base
(require racket/contract
syntax/stx
"deriv-c.rkt")
(require "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
(require (for-syntax racket/base)
racket/match
(require racket/match
"reductions-config.rkt"
"../util/mpi.rkt")
(provide policy->predicate)

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

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

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

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

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

@ -1,5 +1,6 @@
#lang racket/base
(require racket/match
"../util/eomap.rkt"
"stx-util.rkt"
"deriv-util.rkt"
"deriv.rkt"
@ -15,10 +16,13 @@
(let-values ([(steps binders definites estx exn) (reductions+ d)])
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)
(parameterize ((current-definites null)
(current-binders null)
(parameterize ((current-definites (empty-eomap))
(current-binders #hasheq())
(current-frontier null)
(hides-flags (list (box #f)))
(sequence-number 0))
@ -454,6 +458,19 @@
;; FIXME: use renames
[#:binders names]
[#: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))
(R [#:reductions (list (walk/talk 'remark contents))])]))

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

@ -1,6 +1,4 @@
#lang racket/base
(require "deriv.rkt"
"deriv-util.rkt")
(provide (struct-out protostep)
(struct-out step)
(struct-out misstep)
@ -92,6 +90,7 @@
(splice-module-lifts . "Splice lifted module declarations")
(remark . "Macro made a remark")
(track-origin . "Macro called syntax-track-origin")
(error . "Error")))
@ -111,7 +110,8 @@
rename-case-lambda
rename-let-values
rename-letrec-values
rename-lsv)))
rename-lsv
track-origin)))
(define (rewrite-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)])
;; FIXME
(unless (= (length new-parts) (length old-parts))
(printf "** syntax/restamp~n~s~n" (quote-syntax #,stx))
(printf "pattern : ~s~n" (syntax->datum #'(pa (... ...))))
(printf "old parts: ~s~n" (map syntax->datum old-parts))
(printf "new parts: ~s~n" (map syntax->datum new-parts)))
(printf "** syntax/restamp\n~s\n" (quote-syntax #,stx))
(printf "pattern : ~s\n" (syntax->datum #'(pa (... ...))))
(printf "old parts: ~s\n" (map syntax->datum old-parts))
(printf "new parts: ~s\n" (map syntax->datum new-parts)))
(d->so
old-expr
(map (lambda (new old) (syntax/restamp pa new old))
@ -49,10 +49,10 @@
;; FIXME
#'(begin
(unless (and (stx-pair? new-expr) (stx-pair? old-expr))
(printf "** syntax/restamp~n~s~n" (quote-syntax #,stx))
(printf "pattern : ~s~n" (syntax->datum (quote-syntax (pa . pb))))
(printf "old parts: ~s~n" old-expr)
(printf "new parts: ~s~n" new-expr))
(printf "** syntax/restamp\n~s\n" (quote-syntax #,stx))
(printf "pattern : ~s\n" (syntax->datum (quote-syntax (pa . pb))))
(printf "old parts: ~s\n" old-expr)
(printf "new parts: ~s\n" new-expr))
(let ([na (stx-car new-expr)]
[nb (stx-cdr new-expr)]
[oa (stx-car old-expr)]

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

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

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

@ -1,12 +1,15 @@
#lang racket/base
(require racket/promise
syntax/modcode
syntax/modresolve
parser-tools/lex
"deriv.rkt"
"deriv-parser.rkt"
"deriv-tokens.rkt")
(provide trace
trace*
trace-module
trace*-module
trace/result
trace-verbose?
events->token-generator
@ -26,6 +29,11 @@
(let-values ([(result events derivp) (trace* stx expander)])
(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
(define (trace/result stx [expander expand/compile-time-evals])
(let-values ([(result events derivp) (trace* stx expander)])
@ -40,6 +48,13 @@
(delay (parse-derivation
(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)
(define (events->token-generator events)
(let ([pos 1])
@ -50,7 +65,7 @@
[val (cdr sig+val)]
[t (tokenize sig val pos)])
(when (trace-verbose?)
(printf "~s: ~s~n" pos
(printf "~s: ~s\n" pos
(token-name (position-token-token t))))
(set! pos (add1 pos))
t))))

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

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

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

@ -1,6 +1,25 @@
#lang racket/base
(require "view/view.rkt")
(provide expand/step)
(require racket/class
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)
(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?)])

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

@ -1,8 +1,10 @@
#lang racket/base
(require racket/class
racket/gui
racket/gui/base
racket/list
racket/block
racket/pretty
racket/promise
data/interval-map
framework
unstable/class-iop
"pretty-printer.rkt"
@ -12,46 +14,52 @@
(provide print-syntax-to-editor
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)
(if TIME-PRINTING?
(current-inexact-milliseconds)
0))
(define (now) (current-inexact-milliseconds))
;; FIXME: assumes text never moves
;; print-syntax-to-editor : syntax text controller<%> config number number
;; -> display<%>
;; Note: must call display<%>::refresh to finish styling.
(define (print-syntax-to-editor stx text controller config columns
[insertion-point (send text last-position)])
(block
(define output-port (open-output-string/count-lines))
(define range
(pretty-print-syntax stx output-port
(send/i controller controller<%> get-primary-partition)
(length (send/i config config<%> get-colors))
(send/i config config<%> get-suffix-option)
(send config get-pretty-styles)
columns))
(define output-string (get-output-string output-port))
(define output-length (sub1 (string-length output-string))) ;; skip final newline
(fixup-parentheses output-string range)
(send text begin-edit-sequence #f)
(send text insert output-length output-string insertion-point)
(define display
(new display%
(text text)
(controller controller)
(config config)
(range range)
(start-position insertion-point)
(end-position (+ insertion-point output-length))))
(send display initialize)
(send text end-edit-sequence)
display))
(define output-port (open-output-string/count-lines))
(define range
(pretty-print-syntax stx output-port
(send/i controller controller<%> get-primary-partition)
(length (send/i config config<%> get-colors))
(send/i config config<%> get-suffix-option)
(send config get-pretty-styles)
columns))
(define output-string (get-output-string output-port))
(define output-length (sub1 (string-length output-string))) ;; skip final newline
(fixup-parentheses output-string range)
(with-unlock text
(uninterruptible
(send text insert output-length output-string insertion-point))
(new display%
(text text)
(controller controller)
(config config)
(range range)
(start-position insertion-point)
(end-position (+ insertion-point output-length)))))
;; display%
;; Note: must call refresh method to finish styling.
(define display%
(class* object% (display<%>)
(init-field/i [controller controller<%>]
@ -64,57 +72,69 @@
(define base-style
(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))
;; 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
(define/public (initialize)
(send text change-style base-style start-position end-position #f)
(apply-primary-partition-styles)
(add-clickbacks)
(refresh))
(define/private (initialize)
(uninterruptible
(send text change-style base-style start-position end-position #f))
(uninterruptible (apply-primary-partition-styles))
(uninterruptible (add-clickbacks)))
;; add-clickbacks : -> void
(define/private (add-clickbacks)
(define (the-clickback editor start end)
(define mapping (send text get-region-mapping 'syntax))
(define lazy-interval-map-init
(delay
(uninterruptible
(for ([range (send/i range range<%> all-ranges)])
(let ([stx (range-obj range)]
[start (range-start range)]
[end (range-end range)])
(interval-map-set! mapping (+ start-position start) (+ start-position end) stx))))))
(define (the-callback position)
(force lazy-interval-map-init)
(send/i controller selection-manager<%> set-selected-syntax
(clickback->stx
(- start start-position) (- end start-position))))
(for ([range (send/i range range<%> all-ranges)])
(let ([stx (range-obj range)]
[start (range-start range)]
[end (range-end range)])
(send text set-clickback (+ start-position start) (+ start-position end)
the-clickback))))
;; clickback->stx : num num -> syntax
;; FIXME: use vectors for treerange-subs and do binary search to narrow?
(define/private (clickback->stx start end)
(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])))))
(interval-map-ref mapping position #f)))
(send text set-clickregion start-position end-position the-callback))
;; refresh : -> void
;; Clears all highlighting and reapplies all non-foreground styles.
(define/public (refresh)
(with-unlock text
(send* text
(begin-edit-sequence #f)
(change-style (unhighlight-d) start-position end-position))
(apply-extra-styles)
(uninterruptible
(let ([undo-select/highlight-d (get-undo-select/highlight-d)])
(for ([r (in-list to-undo-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
(send/i controller selection-manager<%>
get-selected-syntax)])
(apply-secondary-relation-styles selected-syntax)
(apply-selection-styles selected-syntax))
(send* text
(end-edit-sequence))))
get-selected-syntax)])
(uninterruptible
(apply-secondary-relation-styles selected-syntax))
(uninterruptible
(apply-selection-styles selected-syntax)))))
;; get-range : -> range<%>
(define/public (get-range) range)
@ -127,22 +147,16 @@
;; highlight-syntaxes : (list-of syntax) string -> void
(define/public (highlight-syntaxes stxs hi-color)
(let ([style-delta (highlight-style-delta hi-color #f)])
(for ([stx stxs])
(add-extra-styles stx (list style-delta))))
(refresh))
(let ([delta (highlight-style-delta hi-color)])
(for ([stx (in-list stxs)])
(hash-set! extra-styles stx
(cons delta (hash-ref extra-styles stx null))))))
;; underline-syntaxes : (listof syntax) -> void
(define/public (underline-syntaxes stxs)
(for ([stx stxs])
(add-extra-styles stx (list underline-style-delta)))
(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)))
(for ([stx (in-list stxs)])
(set! on-next-refresh
(cons (cons stx underline-d) on-next-refresh))))
;; Primary styles
;; (Done once on initialization, never repeated)
@ -194,10 +208,16 @@
;; apply-extra-styles : -> void
;; Applies externally-added styles (such as highlighting)
(define/private (apply-extra-styles)
(for ([(stx style-deltas) extra-styles])
(for ([r (send/i range range<%> get-ranges stx)])
(for ([style-delta style-deltas])
(restyle-range r style-delta)))))
(for ([(stx deltas) (in-hash extra-styles)])
(for ([r (in-list (send/i range range<%> get-ranges stx))])
(for ([delta (in-list deltas)])
(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
;; If the selected syntax is an identifier, then styles all identifiers
@ -207,25 +227,17 @@
(let* ([name+relation
(send/i controller secondary-relation<%>
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
(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)
(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
;; Styles subterms eq to the selected syntax
(define/private (apply-selection-styles selected-syntax)
(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)
;; restyle-range : (cons num num) style-delta% boolean -> void
(define/private (restyle-range r style need-undo?)
(when need-undo? (set! to-undo-styles (cons r to-undo-styles)))
(send text change-style style
(relative->text-position (car r))
(relative->text-position (cdr r))))
@ -236,7 +248,8 @@
;; Initialize
(super-new)
(send/i controller controller<%> add-syntax-display this)))
(send/i controller controller<%> add-syntax-display this)
(initialize)))
;; fixup-parentheses : string range -> void
(define (fixup-parentheses string range)
@ -358,34 +371,38 @@
;; Styles
(define (highlight-style-delta raw-color em?
#:translate-color? [translate-color? #t])
(let* ([sd (new style-delta%)])
(unless em?
(send sd set-delta-background
(if translate-color? (translate-color raw-color) raw-color)))
(when em? (send sd set-weight-on 'bold))
(unless em?
;; (send sd set-underlined-off #t)
(send sd set-weight-off 'bold))
(define select-d
(make-object style-delta% 'change-weight 'bold))
(define underline-d
(make-object style-delta% 'change-underline #t))
(define (highlight-style-delta raw-color #:translate-color? [translate-color? #t])
(let ([sd (new style-delta%)]
[color (if translate-color? (translate-color raw-color) raw-color)])
(send sd set-delta-background color)
sd))
(define underline-style-delta
(let ([sd (new style-delta%)])
(send sd set-underlined-on #t)
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)])
(define (mk-2-constant-style bow-color [wob-color (translate-color bow-color)])
(let ([wob-version (highlight-style-delta wob-color #:translate-color? #f)]
[bow-version (highlight-style-delta bow-color #:translate-color? #f)])
(λ ()
(if (pref:invert-colors?)
wob-version
bow-version))))
(define select-highlight-d
(mk-2-constant-style "yellow" #t "darkgoldenrod"))
(define select-sub-highlight-d
(mk-2-constant-style "yellow" #f "darkgoldenrod"))
(define get-secondary-highlight-d
(mk-2-constant-style "yellow" "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
(require racket/class
racket/gui
racket/gui/base
racket/list
framework
unstable/class-iop
"interfaces.rkt"
"partition.rkt"

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

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

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

@ -1,11 +1,12 @@
#lang racket/base
(require racket/contract
racket/class
racket/gui
racket/gui/base
framework
"prefs.rkt"
"controller.rkt"
"display.rkt")
"display.rkt"
"text.rkt")
#|
@ -36,12 +37,10 @@ TODO: tacked arrows
;; print-syntax-columns : (parameter-of (U number 'infinity))
(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
(define (print-syntax-to-png stx file
#: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))
(void))
@ -49,8 +48,8 @@ TODO: tacked arrows
(define (print-syntax-to-bitmap stx
#:columns [columns (print-syntax-columns)])
(define t (prepare-editor stx columns))
(define f (new frame% [label "dummy"]))
(define ec (new editor-canvas% (editor t) (parent f)))
(define admin (new dummy-admin%))
(send t set-admin admin)
(define dc (new bitmap-dc% (bitmap (make-object bitmap% 1 1))))
(define char-width
(let* ([sl (send t get-style-list)]
@ -87,10 +86,20 @@ TODO: tacked arrows
(send t print #f #f 'postscript #f #f #t)))
(define (prepare-editor stx columns)
(define t (new standard-text%))
(define t (new browser-text%))
(define sl (send t get-style-list))
(send t change-style (send sl find-named-style (editor:get-default-color-style-name)))
(print-syntax-to-editor stx t
(new controller%) (new syntax-prefs/readonly%)
columns (send t last-position))
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
(require racket/class
racket/gui
racket/gui/base
racket/pretty
unstable/gui/notify
"interfaces.rkt"
"partition.rkt")
"interfaces.rkt")
(provide syntax-keymap%)
(define keymap/popup%
@ -119,7 +118,7 @@
(demand-callback
(lambda (i)
(let ([stx (selected-syntax)])
(when stx
(when (identifier? stx)
(send i set-label
(format "Format ~s ~a" (syntax-e stx) (cadr sym+desc)))))))
(callback

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

@ -1,6 +1,5 @@
#lang racket/base
(require racket/class
syntax/stx
"interfaces.rkt"
"../util/stxobj.rkt")
(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:PropertiesPanelPercentage 1/3 number?)
(preferences:set-default 'SyntaxBrowser:PropertiesPanelShown #t boolean?)
(preferences:set-default 'SyntaxBrowser:DrawArrows? #t boolean?)
(define pref:width (pref:get/set 'SyntaxBrowser:Width))
(define pref:height (pref:get/set 'SyntaxBrowser:Height))
(define pref:props-percentage (pref:get/set 'SyntaxBrowser:PropertiesPanelPercentage))
(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?))
@ -68,7 +70,8 @@
(width pref:width)
(height pref:height)
(props-percentage pref:props-percentage)
(props-shown? pref:props-shown?))
(props-shown? pref:props-shown?)
(draw-arrows? pref:draw-arrows?))
(super-new)))

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

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

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

@ -2,7 +2,8 @@
(require racket/list
racket/class
racket/pretty
racket/gui
racket/gui/base
racket/promise
"pretty-helper.rkt"
"interfaces.rkt")
(provide pretty-print-syntax)
@ -86,7 +87,9 @@
(map cdr basic-styles)))
(define basic-styles
'((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 :(
(let* ([pref (pref:tabify)]

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

@ -1,6 +1,6 @@
#lang racket/base
(require racket/class
racket/gui
racket/gui/base
framework
unstable/class-iop
"interfaces.rkt"
@ -59,17 +59,12 @@
;; refresh : -> void
(define/public (refresh)
(send* text
(lock #f)
(begin-edit-sequence #f)
(erase))
(if (syntax? selected-syntax)
(refresh/mode mode)
(refresh/mode #f))
(send* text
(end-edit-sequence)
(lock #t)
(scroll-to-position 0)))
(with-unlock text
(send text erase)
(if (syntax? selected-syntax)
(refresh/mode mode)
(refresh/mode #f)))
(send text scroll-to-position 0))
;; refresh/mode : symbol -> void
(define/public (refresh/mode mode)
@ -255,19 +250,19 @@
;; display-kv : any any -> void
(define/private (display-kv key value)
(display (format "~a~n" key) key-sd)
(display (format "~s~n~n" value) #f))
(display (format "~a\n" key) key-sd)
(display (format "~s\n\n" value) #f))
;; display-subkv : any any -> void
(define/public (display-subkv k v)
(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)
(display-subkv k v)
#;
(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))]
[value-snip (new editor-snip% (editor value-text))]
[value-port (make-text-port value-text)])

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

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

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

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

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

@ -1,11 +1,11 @@
#lang racket/base
(require racket/list
racket/class
racket/gui
racket/gui/base
data/interval-map
drracket/arrow
framework/framework
unstable/interval-map
unstable/gui/notify
data/interval-map
"interfaces.rkt")
(provide text:hover<%>
@ -15,7 +15,12 @@
text:hover-mixin
text:hover-drawings-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
(send the-brush-list find-or-create-brush "white" 'solid))
@ -27,14 +32,15 @@
(define white (send the-color-database find-color "white"))
;; A Drawing is (make-drawing number number (??? -> void) (box boolean))
(define-struct drawing (start end draw tacked?))
;; A Drawing is (make-drawing (??? -> void) (box boolean))
(define-struct drawing (draw tacked?))
(define-struct idloc (start end id))
(define (mean x y)
(/ (+ x y) 2))
;; save+restore pen, brush, also smoothing
(define-syntax with-saved-pen&brush
(syntax-rules ()
[(with-saved-pen&brush dc . body)
@ -42,10 +48,13 @@
(define (save-pen&brush dc thunk)
(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)
(send dc set-pen old-pen)
(send dc set-brush old-brush))))
(send* dc
(set-pen old-pen)
(set-brush old-brush)
(set-smoothing old-smoothing)))))
(define-syntax with-saved-text-config
(syntax-rules ()
@ -58,10 +67,17 @@
[old-background (send dc get-text-background)]
[old-mode (send dc get-text-mode)])
(begin0 (thunk)
(send dc set-font old-font)
(send dc set-text-foreground old-color)
(send dc set-text-background old-background)
(send dc set-text-mode old-mode))))
(send* dc
(set-font old-font)
(set-text-foreground old-color)
(set-text-background old-background)
(set-text-mode old-mode)))))
;; Interfaces
(define text:region-data<%>
(interface (text:basic<%>)
get-region-mapping))
(define text:hover<%>
(interface (text:basic<%>)
@ -70,29 +86,51 @@
(define text:hover-drawings<%>
(interface (text:basic<%>)
add-hover-drawing
get-position-drawings
delete-all-drawings))
get-position-drawings))
(define text:arrows<%>
(interface (text:hover-drawings<%>)
add-arrow
add-question-arrow
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
(mixin (text:basic<%>) (text:hover<%>)
(inherit dc-location-to-editor-location
find-position)
(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)
(case (send ev get-event-type)
((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)
(void))
@ -100,13 +138,15 @@
(super-new)))
(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
find-position
invalidate-bitmap-cache)
invalidate-bitmap-cache
get-region-mapping)
(super-new)
;; interval-map of Drawings
(define drawings-list (make-numeric-interval-map))
(define drawings-list (get-region-mapping 'hover-drawings))
(field [hover-position #f])
@ -118,15 +158,12 @@
(invalidate-bitmap-cache 0.0 0.0 +inf.0 +inf.0)))
(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
start (add1 end)
drawing
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)
(super on-paint before? dc left top right bottom dx dy draw-caret)
(unless before?
@ -139,9 +176,7 @@
(define/private (same-drawings? old-pos pos)
;; relies on order drawings added & list-of-eq?-struct equality
(equal? (get-position-drawings old-pos)
(get-position-drawings pos)))
(super-new)))
(get-position-drawings pos)))))
(define text:tacking-mixin
(mixin (text:basic<%> text:hover-drawings<%>) ()
@ -153,17 +188,26 @@
(define tacked-table (make-hasheq))
(define/override (on-event ev)
(define/override (on-local-event ev)
(case (send ev get-event-type)
((right-down)
(if (pair? (get-position-drawings hover-position))
(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-y))
(super on-event ev)))
(super on-local-event ev)))
(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)
(super on-paint before? dc left top right bottom dx dy draw-caret)
@ -171,26 +215,32 @@
(for ([draw (in-hash-keys tacked-table)])
(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 keymap (get-keymap))
(new menu-item% (label "Tack")
(parent menu)
(callback (lambda _ (tack))))
(new menu-item% (label "Untack")
(parent menu)
(callback (lambda _ (untack))))
(define tack-item
(new menu-item% (label "Tack")
(parent menu)
(callback (lambda _ (tack drawings)))))
(define untack-item
(new menu-item% (label "Untack")
(parent menu)
(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<%>)
(new separator-menu-item% (parent menu))
(send keymap add-context-menu-items menu))
menu)
(define/private (tack)
(for ([d (get-position-drawings hover-position)])
(define/private (tack drawings)
(for ([d (in-list drawings)])
(hash-set! tacked-table (drawing-draw d) #t)
(set-box! (drawing-tacked? d) #t)))
(define/private (untack)
(for ([d (get-position-drawings hover-position)])
(define/private (untack drawings)
(for ([d (in-list drawings)])
(hash-remove! tacked-table (drawing-draw d))
(set-box! (drawing-tacked? d) #f)))))
@ -200,12 +250,6 @@
add-hover-drawing
find-wordbreak)
(define/public (add-arrow from1 from2 to1 to2 color)
(internal-add-arrow from1 from2 to1 to2 color #f))
(define/public (add-question-arrow from1 from2 to1 to2 color)
(internal-add-arrow from1 from2 to1 to2 color #t))
(define/public (add-billboard pos1 pos2 str color-name)
(define color (send the-color-database find-color color-name))
(let ([draw
@ -224,6 +268,7 @@
[(adj-y) fh]
[(mini) _d])
(send* dc
(set-smoothing 'smoothed)
(draw-rounded-rectangle
(+ x dx)
(+ y dy adj-y)
@ -232,7 +277,7 @@
(draw-text str (+ x dx mini) (+ y dy mini adj-y))))))))])
(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 tack-box (box #f))
(unless (and (= from1 to1) (= from2 to2))
@ -240,7 +285,8 @@
(lambda (text dc left top right bottom dx dy)
(let-values ([(startx starty) (range->mean-loc from1 from2)]
[(endx endy) (range->mean-loc to1 to2)]
[(fw fh _d _v) (send dc get-text-extent "x")])
[(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-text-config dc
(send dc set-pen color 1 'solid)
@ -253,13 +299,17 @@
endx
(+ endy (/ fh 2))
dx dy)
(send dc set-text-mode 'transparent)
(when question?
(send dc set-font (?-font dc))
(send dc set-text-foreground color)
(send dc draw-text "?"
(+ endx dx fw)
(- (+ endy dy) fh)))))))])
(when label
(let* ([lx (+ endx dx fw)]
[ly (- (+ endy dy) fh)])
(send* dc
(set-brush billboard-brush)
(set-font (billboard-font dc))
(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 to1 to2 draw tack-box))))
@ -286,15 +336,65 @@
(super-new)))
(define text:hover-drawings%
(text:hover-drawings-mixin
(text:hover-mixin
text:standard-style-list%)))
#|
text:clickregion-mixin
(define text:arrows%
(text:arrows-mixin
(text:tacking-mixin
text:hover-drawings%)))
Like clickbacks, but:
- use interval-map to avoid linear search
(major problem w/ macro stepper and large expansions!)
- 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))])))
(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))))

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

@ -10,13 +10,16 @@
[(with-unlock text . body)
(let* ([t text]
[locked? (send t is-locked?)])
(send* t
(lock #f)
(begin-edit-sequence #f))
(begin0 (let () . body)
(send* t
(end-edit-sequence)
(lock locked?))))]))
(dynamic-wind
(lambda ()
(send* t
(begin-edit-sequence #f)
(lock #f)))
(lambda () . body)
(lambda ()
(send* t
(lock locked?)
(end-edit-sequence)))))]))
;; make-text-port : text (-> number) -> port
;; builds a port from a text object.

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

@ -1,6 +1,6 @@
#lang racket/base
(require racket/class
racket/gui
racket/gui/base
racket/list
racket/match
framework
@ -14,6 +14,7 @@
"properties.rkt"
"text.rkt"
"util.rkt"
"../util/eomap.rkt"
"../util/mpi.rkt")
(provide widget%)
@ -106,87 +107,101 @@
(send -text change-style clickback-style a b)))))
(define/public (add-syntax stx
#:binders [binders null]
#:binders [binders #f]
#:shift-table [shift-table #f]
#:definites [definites null]
#:definites [definites #f]
#:hi-colors [hi-colors null]
#:hi-stxss [hi-stxss null]
#:substitutions [substitutions null])
(let ([display (internal-add-syntax stx)]
[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
(send -text insert (cdr subst)
(+ offset (car r))
(+ offset (cdr r))
#f)
(send -text change-style
(code-style -text (send/i config config<%> get-syntax-font-size))
(+ offset (car r))
(+ offset (cdr r)))))))
(for ([hi-stxs hi-stxss] [hi-color hi-colors])
(define (get-shifted id) (hash-ref shift-table id null))
(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)
(+ offset (car r))
(+ offset (cdr r))
#f)
(send -text change-style
(code-style -text (send/i config config<%> get-syntax-font-size))
(+ offset (car r))
(+ offset (cdr r))
#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))
(for ([definite definites])
(hash-set! definite-table definite #t)
(when shift-table
(for ([shifted-definite (hash-ref shift-table definite null)])
(hash-set! definite-table shifted-definite #t))))
(let ([binder-table (make-free-id-table)])
(define range (send/i display display<%> get-range))
(define start (send/i display display<%> get-start-position))
(define (get-binders id)
(let ([binder (free-id-table-ref binder-table id #f)])
(cond [(not binder) null]
[shift-table (cons binder (get-shifted binder))]
[else (list binder)])))
(define (get-shifted id)
(hash-ref shift-table id null))
;; Populate table
(for ([binder binders])
(free-id-table-set! binder-table binder binder))
;; Underline binders (and shifted binders)
(send/i display display<%> underline-syntaxes
(append (apply append (map get-shifted binders))
binders))
;; Make arrows (& billboards, when enabled)
(for ([id (send/i range range<%> get-identifier-list)])
(define definite? (hash-ref definite-table id #f))
;; Underline binders (and shifted binders)
(send/i display display<%> underline-syntaxes
(let ([binder-list (hash-map binders (lambda (k v) k))])
(append (apply append (map get-shifted binder-list))
binder-list)))
(send display refresh)
;; Make arrows (& billboards, when enabled)
(when (send config get-draw-arrows?)
(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]
[shift-table (cons binder (get-shifted binder))]
[else (list binder)])))
(cond [phase (for-one-table (get-binder-table phase) id)]
[else
(apply append
(for/list ([table (in-hash-values phase-binder-table)])
(for-one-table table id)))]))
(for ([id (in-list (send/i range range<%> get-identifier-list))])
(define phase (definite-phase id))
(when #f ;; DISABLED
(add-binding-billboard start range id definite?))
(for ([binder (get-binders id)])
(for ([binder-r (send/i range range<%> get-ranges binder)])
(for ([id-r (send/i range range<%> get-ranges id)])
(add-binding-arrow start binder-r id-r definite?))))))
(add-binding-billboard offset range id phase))
(for ([binder (in-list (get-binders id phase))])
(for ([binder-r (in-list (send/i range range<%> get-ranges binder))])
(for ([id-r (in-list (send/i range range<%> get-ranges id))])
(add-binding-arrow offset binder-r id-r phase))))))
(void)))
(define/private (add-binding-arrow start binder-r id-r definite?)
(if definite?
(send -text add-arrow
(+ start (car binder-r))
(+ start (cdr binder-r))
(+ start (car id-r))
(+ start (cdr id-r))
"blue")
(send -text add-question-arrow
(+ start (car binder-r))
(+ start (cdr binder-r))
(+ start (car id-r))
(+ start (cdr id-r))
"purple")))
(define/private (add-binding-arrow start binder-r id-r phase)
;; phase = #f means not definite binding (ie, "?" arrow)
(send -text add-arrow
(+ start (car binder-r))
(+ start (cdr binder-r))
(+ start (car id-r))
(+ start (cdr id-r))
(if phase "blue" "purple")
(cond [(equal? phase 0) #f]
[phase (format "phase ~s" phase)]
[else "?"])
(if phase 'end 'start)))
(define/private (add-binding-billboard start range id definite?)
(match (identifier-binding id)
[(list-rest src-mod src-name nom-mod nom-name _)
(for-each (lambda (id-r)
(send -text add-billboard
(+ start (car id-r))
(+ start (cdr id-r))
(string-append "from " (mpi->string src-mod))
(if definite? "blue" "purple")))
(send/i range range<%> get-ranges id))]
(for ([id-r (in-list (send/i range range<%> get-ranges id))])
(send -text add-billboard
(+ start (car id-r))
(+ start (cdr id-r))
(string-append "from " (mpi->string src-mod))
(if definite? "blue" "purple")))]
[_ (void)]))
(define/public (add-separator)
@ -197,25 +212,11 @@
(define/public (erase-all)
(with-unlock -text
(send -text erase)
(send -text delete-all-drawings))
(send -text erase))
(send/i controller displays-manager<%> remove-all-syntax-displays))
(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 style (code-style -text (send/i config config<%> get-syntax-font-size)))
(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-foreground "red")
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
"interfaces.rkt"
"debug-format.rkt"
"prefs.rkt"
"view.rkt")
(provide debug-file)

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

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

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

@ -3,21 +3,15 @@
racket/unit
racket/list
racket/file
racket/path
racket/match
racket/gui
racket/gui/base
framework
unstable/class-iop
"interfaces.rkt"
"stepper.rkt"
"prefs.rkt"
"hiding-panel.rkt"
(prefix-in sb: "../syntax-browser/embed.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)
(provide macro-stepper-frame-mixin)
@ -64,7 +58,8 @@
(send/i config config<%> set-width w)
(send/i config config<%> set-height 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)))
(define warning-panel
@ -198,26 +193,26 @@
(menu-option/notify-box extras-menu
"Highlight redex/contractum"
(get-field highlight-foci? config))
#|
(menu-option/notify-box extras-menu
"Highlight frontier"
(get-field highlight-frontier? config))
|#
(menu-option/notify-box extras-menu
"Include renaming steps"
(get-field show-rename-steps? config))
(menu-option/notify-box extras-menu
"One term at a time"
(get-field one-by-one? config))
(menu-option/notify-box extras-menu
"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
"Extra navigation"
(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))
|#)
(get-field extra-navigation? config)))
;; fixup-menu : menu -> void
;; 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
(require racket/class
racket/gui
racket/gui/base
racket/list
racket/match
unstable/class-iop
"interfaces.rkt"
"../model/hiding-policies.rkt"

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

@ -4,7 +4,9 @@
(provide (all-defined-out))
(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?
identifier=?
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:PropertiesShown? #f boolean?)
(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:ShowHidingPanel? #t boolean?)
(preferences:set-default 'MacroStepper:IdentifierComparison "bound-identifier=?" string?)
@ -27,11 +29,14 @@
(preferences:set-default 'MacroStepper:SplitContext? #f boolean?)
(preferences:set-default 'MacroStepper:MacroStepLimit 40000
(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:height (pref:get/set 'MacroStepper:Frame:Height))
(define pref:props-shown? (pref:get/set 'MacroStepper:PropertiesShown?))
(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:show-hiding-panel? (pref:get/set 'MacroStepper:ShowHidingPanel?))
(define pref:identifier=? (pref:get/set 'MacroStepper:IdentifierComparison))
@ -44,7 +49,7 @@
(define pref:debug-catch-errors? (pref:get/set 'MacroStepper:DebugCatchErrors?))
(define pref:split-context? (pref:get/set 'MacroStepper:SplitContext?))
(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%
(class* prefs-base% (config<%>)
@ -58,6 +63,7 @@
(height pref:height)
(props-percentage pref:props-percentage)
(props-shown? pref:props-shown?)
(draw-arrows? pref:draw-arrows?)
(macro-hiding-mode pref:macro-hiding-mode)
(show-hiding-panel? pref:show-hiding-panel?)
(identifier=? pref:identifier=?)
@ -68,7 +74,8 @@
(one-by-one? pref:one-by-one?)
(extra-navigation? pref:extra-navigation?)
(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)))
(define macro-stepper-config/prefs%

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

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

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

@ -3,11 +3,10 @@
racket/unit
racket/list
racket/match
racket/gui
framework
racket/gui/base
racket/pretty
unstable/class-iop
"interfaces.rkt"
"prefs.rkt"
"extensions.rkt"
"hiding-panel.rkt"
"term-record.rkt"
@ -15,10 +14,9 @@
(prefix-in sb: "../syntax-browser/interfaces.rkt")
"../model/deriv.rkt"
"../model/deriv-util.rkt"
"../model/trace.rkt"
"../model/reductions.rkt"
"../model/steps.rkt"
"cursor.rkt"
"gui-util.rkt"
"../syntax-browser/util.rkt"
unstable/gui/notify
(only-in mzscheme [#%top-interaction mz-top-interaction]))
(provide macro-stepper-widget%
@ -33,6 +31,13 @@
(init-field config)
(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
;; all-terms : (list-of TermRecord)
@ -61,16 +66,17 @@
(add trec)))
;; add : TermRecord -> void
(define/public (add trec)
(set! all-terms (cons trec all-terms))
(let ([display-new-term? (cursor:at-end? terms)]
[invisible? (send/i trec term-record<%> get-deriv-hidden?)])
(unless invisible?
(cursor:add-to-end! terms (list trec))
(trim-navigator)
(if display-new-term?
(refresh)
(update)))))
(define/private (add trec)
(with-eventspace
(set! all-terms (cons trec all-terms))
(let ([display-new-term? (cursor:at-end? terms)]
[invisible? (send/i trec term-record<%> get-deriv-hidden?)])
(unless invisible?
(cursor:add-to-end! terms (list trec))
(trim-navigator)
(if display-new-term?
(refresh)
(update))))))
;; remove-current-term : -> void
(define/public (remove-current-term)
@ -103,7 +109,11 @@
(send/i sbc sb:controller<%> reset-primary-partition)
(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
(new horizontal-panel%
(parent area)
@ -135,12 +145,18 @@
(send/i sbview sb:syntax-browser<%> get-controller))
(define control-pane
(new vertical-panel% (parent area) (stretchable-height #f)))
(define/i macro-hiding-prefs hiding-prefs<%>
(new macro-hiding-prefs-widget%
(parent control-pane)
(stepper this)
(config config)))
(define status-area
(new status-area%
(parent superarea)
(stop-callback (lambda _ (stop-processing)))))
(send/i sbc sb:controller<%>
listen-selected-syntax
(lambda (stx) (send/i macro-hiding-prefs hiding-prefs<%> set-syntax stx)))
@ -243,28 +259,25 @@
(list navigator extra-navigator)
(list navigator)))))
(define/public (change-status msg)
(send status-area set-status msg))
;; 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)
(send/i (focused-term) term-record<%> navigate-to-start)
(update/save-position))
(update/preserve-lines-view))
(define/public-final (navigate-to-end)
(send/i (focused-term) term-record<%> navigate-to-end)
(update/save-position))
(update/preserve-lines-view))
(define/public-final (navigate-previous)
(send/i (focused-term) term-record<%> navigate-previous)
(update/save-position))
(update/preserve-lines-view))
(define/public-final (navigate-next)
(send/i (focused-term) term-record<%> navigate-next)
(update/save-position))
(update/preserve-lines-view))
(define/public-final (navigate-to n)
(send/i (focused-term) term-record<%> navigate-to n)
(update/save-position))
(update/preserve-lines-view))
(define/public-final (navigate-up)
(when (focused-term)
@ -277,108 +290,159 @@
(cursor:move-next terms)
(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
(define/private (update/save-position)
(update/preserve-lines-view))
;; Async update & refresh
(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
(define/public (update/preserve-lines-view)
(define text (send/i sbview sb:syntax-browser<%> get-text))
(define start-box (box 0))
(define end-box (box 0))
(send text get-visible-line-range start-box end-box)
(update)
(send text scroll-to-position
(send text line-start-position (unbox start-box))
#f
(send text line-start-position (unbox end-box))
'start))
(with-update-thread
(define text (send/i sbview sb:syntax-browser<%> get-text))
(define start-box (box 0))
(define end-box (box 0))
(send text get-visible-line-range start-box end-box)
(update*)
(send text scroll-to-position
(send text line-start-position (unbox start-box))
#f
(send text line-start-position (unbox end-box))
'start)))
;; update/preserve-view : -> void
(define/public (update/preserve-view)
(define text (send/i sbview sb:syntax-browser<%> get-text))
(define start-box (box 0))
(define end-box (box 0))
(send text get-visible-position-range start-box end-box)
(update)
(send text scroll-to-position (unbox start-box) #f (unbox end-box) 'start))
(with-update-thread
(define text (send/i sbview sb:syntax-browser<%> get-text))
(define start-box (box 0))
(define end-box (box 0))
(send text get-visible-position-range start-box end-box)
(update*)
(send text scroll-to-position (unbox start-box) #f (unbox end-box) 'start)))
;; update : -> void
;; Updates the terms in the syntax browser to the current step
(define/private (update)
(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 position-of-interest 0)
(define multiple-terms? (> (length (cursor->list terms)) 1))
(send text begin-edit-sequence #f)
(send/i sbview sb:syntax-browser<%> erase-all)
(update:show-prefix)
(when multiple-terms? (send/i sbview sb:syntax-browser<%> add-separator))
(set! position-of-interest (send text last-position))
(update:show-current-step)
(when multiple-terms? (send/i sbview sb:syntax-browser<%> add-separator))
(update:show-suffix)
(send text end-edit-sequence)
(with-unlock text
(send/i sbview sb:syntax-browser<%> erase-all)
(update:show-prefix)
(when multiple-terms? (send/i sbview sb:syntax-browser<%> add-separator))
(set! position-of-interest (send text last-position))
(update:show-current-step)
(when multiple-terms? (send/i sbview sb:syntax-browser<%> add-separator))
(update:show-suffix))
(send text scroll-to-position
position-of-interest
#f
(send text last-position)
'start)
(update-nav-index)
(enable/disable-buttons))
;; 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)))
(change-status #f))
;; --
;; refresh/resynth : -> void
;; Macro hiding policy has changed; invalidate cached parts of trec
(define/public (refresh/resynth)
(for-each (lambda (trec) (send/i trec term-record<%> invalidate-synth!))
(cursor->list terms))
(for ([trec (in-list (cursor->list terms))])
(send/i trec term-record<%> invalidate-synth!))
(refresh))
;; refresh/re-reduce : -> void
;; Reduction config has changed; invalidate cached parts of trec
(define/private (refresh/re-reduce)
(for-each (lambda (trec) (send/i trec term-record<%> invalidate-steps!))
(cursor->list terms))
(for ([trec (in-list (cursor->list terms))])
(send/i trec term-record<%> invalidate-steps!))
(refresh))
;; refresh/move : -> void
@ -388,18 +452,17 @@
;; refresh : -> void
(define/public (refresh)
(when (focused-term)
(send/i (focused-term) term-record<%> on-get-focus))
(send nav:step-count set-label "")
(let ([term (focused-term)])
(when term
(let ([step-count (send/i term term-record<%> get-step-count)])
(when step-count
;; +1 for end of expansion "step"
(send nav:step-count set-label (format "of ~s" (add1 step-count)))))))
(update))
(define/private (foci x) (if (list? x) x (list x)))
(with-update-thread
(when (focused-term)
(send/i (focused-term) term-record<%> on-get-focus))
(send nav:step-count set-label "")
(let ([term (focused-term)])
(when term
(let ([step-count (send/i term term-record<%> get-step-count)])
(when step-count
;; +1 for end of expansion "step"
(send nav:step-count set-label (format "of ~s" (add1 step-count)))))))
(update*)))
;; Hiding policy
@ -415,7 +478,6 @@
(super-new)
(show-macro-hiding-panel (send/i config config<%> get-show-hiding-panel?))
(show-extra-navigation (send/i config config<%> get-extra-navigation?))
(refresh/move)
))
(define (macro-stepper-widget/process-mixin %)

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

@ -3,15 +3,11 @@
racket/unit
racket/list
racket/match
racket/gui
framework
racket/gui/base
syntax/stx
unstable/find
unstable/class-iop
"interfaces.rkt"
"prefs.rkt"
"extensions.rkt"
"hiding-panel.rkt"
"step-display.rkt"
"../model/deriv.rkt"
"../model/deriv-util.rkt"
@ -20,9 +16,7 @@
"../model/reductions-config.rkt"
"../model/reductions.rkt"
"../model/steps.rkt"
unstable/gui/notify
"cursor.rkt"
"debug-format.rkt")
"cursor.rkt")
(provide term-record%)
@ -38,7 +32,7 @@
(send/i stepper widget<%> get-step-displayer))
;; Data
(init-field [events #f])
(init-field [raw-deriv #f])
@ -58,9 +52,15 @@
(define steps #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)
(define-syntax define-guarded-getters
@ -120,22 +120,24 @@
(with-handlers ([(lambda (e) #t)
(lambda (e)
(set! raw-deriv-oops e))])
(set! raw-deriv
(parse-derivation
(events->token-generator events))))))
(with-status "Parsing expansion derivation"
(set! raw-deriv
(parse-derivation
(events->token-generator events)))))))
;; recache-deriv! : -> void
(define/private (recache-deriv!)
(unless (or deriv deriv-hidden?)
(recache-raw-deriv!)
(when raw-deriv
(let ([process (send/i stepper widget<%> get-preprocess-deriv)])
(let ([d (process raw-deriv)])
(when (not d)
(set! deriv-hidden? #t))
(when d
(set! deriv d)
(set! shift-table (compute-shift-table d))))))))
(with-status "Processing expansion derivation"
(let ([process (send/i stepper widget<%> get-preprocess-deriv)])
(let ([d (process raw-deriv)])
(when (not d)
(set! deriv-hidden? #t))
(when d
(set! deriv d)
(set! shift-table (compute-shift-table d)))))))))
;; recache-synth! : -> void
(define/private (recache-synth!)
@ -146,38 +148,40 @@
(unless (or raw-steps raw-steps-oops)
(recache-synth!)
(when deriv
(let ([show-macro? (or (send/i stepper widget<%> get-show-macro?)
(lambda (id) #t))])
(with-handlers ([(lambda (e) #t)
(lambda (e)
(set! raw-steps-oops e))])
(let-values ([(raw-steps* binders* definites* estx* error*)
(parameterize ((macro-policy show-macro?))
(reductions+ deriv))])
(set! raw-steps raw-steps*)
(set! raw-steps-estx estx*)
(set! raw-steps-exn error*)
(set! raw-steps-binders binders*)
(set! raw-steps-definites definites*)))))))
(with-status "Computing reduction steps"
(let ([show-macro? (or (send/i stepper widget<%> get-show-macro?)
(lambda (id) #t))])
(with-handlers ([(lambda (e) #t)
(lambda (e)
(set! raw-steps-oops e))])
(let-values ([(raw-steps* binders* definites* estx* error*)
(parameterize ((macro-policy show-macro?))
(reductions+ deriv))])
(set! raw-steps raw-steps*)
(set! raw-steps-estx estx*)
(set! raw-steps-exn error*)
(set! raw-steps-binders binders*)
(set! raw-steps-definites definites*))))))))
;; recache-steps! : -> void
(define/private (recache-steps!)
(unless (or steps)
(recache-raw-steps!)
(when raw-steps
(set! steps
(and raw-steps
(let* ([filtered-steps
(if (send/i config config<%> get-show-rename-steps?)
raw-steps
(filter (lambda (x) (not (rename-step? x)))
raw-steps))]
[processed-steps
(if (send/i config config<%> get-one-by-one?)
(reduce:one-by-one filtered-steps)
filtered-steps)])
(cursor:new processed-steps))))
(restore-position))))
(with-status "Processing reduction steps"
(set! steps
(and raw-steps
(let* ([filtered-steps
(if (send/i config config<%> get-show-rename-steps?)
raw-steps
(filter (lambda (x) (not (rename-step? x)))
raw-steps))]
[processed-steps
(if (send/i config config<%> get-one-by-one?)
(reduce:one-by-one filtered-steps)
filtered-steps)])
(cursor:new processed-steps))))
(restore-position)))))
;; reduce:one-by-one : (list-of step) -> (list-of step)
(define/private (reduce:one-by-one rs)
@ -274,37 +278,40 @@
;; display-initial-term : -> void
(define/public (display-initial-term)
(cond [raw-deriv-oops
(send/i displayer step-display<%> add-internal-error
"derivation" raw-deriv-oops #f events)]
[else
(send/i displayer step-display<%> add-syntax (wderiv-e1 deriv))]))
(with-status "Rendering term"
(cond [raw-deriv-oops
(send/i displayer step-display<%> add-internal-error
"derivation" raw-deriv-oops #f events)]
[else
(send/i displayer step-display<%> add-syntax (wderiv-e1 deriv))])))
;; display-final-term : -> void
(define/public (display-final-term)
(recache-steps!)
(cond [(syntax? raw-steps-estx)
(send/i displayer step-display<%> add-syntax raw-steps-estx
#:binders raw-steps-binders
#:shift-table shift-table
#:definites raw-steps-definites)]
[(exn? raw-steps-exn)
(send/i displayer step-display<%> add-error raw-steps-exn)]
[else (display-oops #f)]))
(with-status "Rendering term"
(cond [(syntax? raw-steps-estx)
(send/i displayer step-display<%> add-syntax raw-steps-estx
#:binders raw-steps-binders
#:shift-table shift-table
#:definites raw-steps-definites)]
[(exn? raw-steps-exn)
(send/i displayer step-display<%> add-error raw-steps-exn)]
[else (display-oops #f)])))
;; display-step : -> void
(define/public (display-step)
(recache-steps!)
(cond [steps
(let ([step (cursor:next steps)])
(if step
(send/i displayer step-display<%> add-step step
#:shift-table shift-table)
(send/i displayer step-display<%> add-final raw-steps-estx raw-steps-exn
#:binders raw-steps-binders
#:shift-table shift-table
#:definites raw-steps-definites)))]
[else (display-oops #t)]))
(with-status "Rendering step"
(cond [steps
(let ([step (cursor:next steps)])
(if step
(send/i displayer step-display<%> add-step step
#:shift-table shift-table)
(send/i displayer step-display<%> add-final raw-steps-estx raw-steps-exn
#:binders raw-steps-binders
#:shift-table shift-table
#:definites raw-steps-definites)))]
[else (display-oops #t)])))
;; display-oops : boolean -> void
(define/private (display-oops show-syntax?)

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

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