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

macro-stepper: correctly render new letrec transformation

Browse Source 
original commit: cf195b633bc23cbd126ab35ddab7184b3575f798
This commit is contained in:
Ryan Culpepper 2010-07-09 15:56:12 -06:00
commit 05391541ad
57 changed files with 1049 additions and 1292 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
collects/macro-debugger/emit.rkt Normal file
View File

@ -0,0 +1,32 @@
#lang racket/base
(require racket/contract/base)
(provide/contract
[emit-remark
(->* () (#:unmark? any/c) #:rest (listof (or/c string? syntax?))
any)]
[emit-local-step
(-> syntax? syntax? #:id identifier? any)])
(define current-expand-observe
(dynamic-require ''#%expobs 'current-expand-observe))
(define (emit-remark #:unmark? [unmark? #t] . args)
(let ([observe (current-expand-observe)])
(when observe
(let ([args
(if unmark?
(for/list ([arg (in-list args)])
(if (syntax? arg)
(syntax-local-introduce arg)
arg))
args)])
(observe 'local-remark args)))))
(define (emit-local-step before after #:id id)
(let ([observe (current-expand-observe)])
(when observe
(observe 'local-artificial-step
(list (list id)
before (syntax-local-introduce before)
(syntax-local-introduce after) after)))))

10
collects/macro-debugger/expand.rkt
View File

@ -1,8 +1,8 @@
#lang scheme/base
(require scheme/contract
"model/trace.ss"
"model/reductions-config.ss"
"model/reductions.ss")
#lang racket/base
(require racket/contract
"model/trace.rkt"
"model/reductions-config.rkt"
"model/reductions.rkt")
(provide/contract
[expand-only

2
collects/macro-debugger/info.rkt
View File

@ -1,5 +1,5 @@
#lang setup/infotab
(define tools '(["tool.ss"]))
(define tools '(["tool.rkt"]))
(define tool-names '("Macro Stepper"))
(define scribblings '(("macro-debugger.scrbl" () (tool-library))))

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

@ -4,6 +4,7 @@
scribble/eval
(for-label scheme/base
macro-debugger/expand
macro-debugger/emit
macro-debugger/stepper
macro-debugger/stepper-text
macro-debugger/syntax-browser
@ -101,6 +102,58 @@ thing as the original syntax.
(lambda (id) (memq (syntax-e id) '(or #%app))))))
}
@section{Macro stepper API for macros}
@defmodule[macro-debugger/emit]
Macros can explicitly send information to a listening macro stepper by
using the procedures in this module.
@defproc[(emit-remark [fragment (or/c syntax? string?)] ...
[#:unmark? unmark? boolean? #t])
void?]{
Emits an event to the macro stepper (if one is listening) containing
the given strings and syntax objects. The macro stepper displays a
remark by printing the strings and syntax objects above a rendering of
the macro's context. The remark is only displayed if the macro that
emits it is considered transparent by the hiding policy.
By default, syntax objects in remarks have the transformer's mark
applied (using @scheme[syntax-local-introduce]) so that their
appearance in the macro stepper matches their appearance after the
transformer returns. Unmarking is suppressed if @scheme[unmark?] is
@scheme[#f].
@schemeblock[
(define-syntax (mymac stx)
(syntax-case stx ()
[(_ x y)
(emit-remark "I got some arguments!"
#'x
"and"
#'y)
#'(list 'x 'y)]))
(mymac 37 (+ 1 2))
]
(Run the fragment above in the macro stepper.)
}
@defproc[(emit-local-step [before syntax?] [after syntax?]
[#:id id identifier?])
void?]{
Emits an event that simulates a local expansion step from
@scheme[before] to @scheme[after].
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]

3
collects/macro-debugger/model/context.rkt
View File

@ -1,5 +1,4 @@
#lang scheme/base
#lang racket/base
(require syntax/stx)
(provide (struct-out ref)
(struct-out tail)

35
collects/macro-debugger/model/debug.rkt
View File

@ -1,19 +1,18 @@
#lang scheme/base
#lang racket/base
(require racket/match
"trace.rkt"
"reductions.rkt"
"reductions-config.rkt"
"deriv-util.rkt"
"hiding-policies.rkt"
"deriv.rkt"
"steps.rkt")
(require scheme/match
"trace.ss"
"reductions.ss"
"reductions-config.ss"
"deriv-util.ss"
"hiding-policies.ss"
"deriv.ss"
"steps.ss")
(provide (all-from-out "trace.ss")
(all-from-out "reductions.ss")
(all-from-out "reductions-config.ss")
(all-from-out "deriv.ss")
(all-from-out "deriv-util.ss")
(all-from-out "hiding-policies.ss")
(all-from-out "steps.ss")
(all-from-out scheme/match))
(provide (all-from-out "trace.rkt")
(all-from-out "reductions.rkt")
(all-from-out "reductions-config.rkt")
(all-from-out "deriv.rkt")
(all-from-out "deriv-util.rkt")
(all-from-out "hiding-policies.rkt")
(all-from-out "steps.rkt")
(all-from-out racket/match))

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

@ -1,5 +1,4 @@
#lang scheme/base
#lang racket/base
(provide (all-defined-out))
;; A Node(a) is:
@ -40,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-remark (contents) #:transparent)
;; contents : (listof (U string syntax))
;; A PrimDeriv is one of
(define-struct (prule base) () #:transparent)

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

@ -1,12 +1,11 @@
#lang scheme/base
(require (for-syntax scheme/base)
#lang racket/base
(require (for-syntax racket/base)
syntax/stx
"yacc-ext.ss"
"yacc-interrupted.ss"
"deriv.ss"
"deriv-util.ss"
"deriv-tokens.ss")
"yacc-ext.rkt"
"yacc-interrupted.rkt"
"deriv.rkt"
"deriv-util.rkt"
"deriv-tokens.rkt")
(provide parse-derivation)
(define (deriv-error ok? name value start end)
@ -202,6 +201,20 @@
(make local-bind $1 $2 $3 #f)]
[(local-bind rename-list (? BindSyntaxes))
(make local-bind $1 #f $2 $3)]
[(local-remark)
(make local-remark $1)]
[(local-artificial-step)
(let ([ids (list-ref $1 0)]
[before (list-ref $1 1)]
[mbefore (list-ref $1 2)]
[mafter (list-ref $1 3)]
[after (list-ref $1 4)])
(make local-expansion
before after #f mbefore
(make mrule mbefore mafter ids #f
before null after #f mafter
(make p:stop mafter mafter null #f))
#f after #f))]
;; -- Not really local actions, but can occur during evaluation
;; called 'expand' (not 'local-expand') within transformer
[(start (? EE)) #f]

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

@ -1,7 +1,6 @@
#lang scheme/base
#lang racket/base
(require parser-tools/lex
"deriv.ss")
"deriv.rkt")
(provide (all-defined-out))
(define-tokens basic-tokens
@ -59,6 +58,9 @@
top-begin ; identifier
top-non-begin ; .
local-remark ; (listof (U string syntax))
local-artificial-step ; (list syntax syntax syntax syntax)
))
(define-tokens renames-tokens
@ -93,6 +95,8 @@
(#f start ,token-start)
(#f top-begin ,token-top-begin)
(#f top-non-begin ,token-top-non-begin)
(#f local-remark ,token-local-remark)
(#f local-artificial-step ,token-local-artificial-step)
;; Standard signals
(0 visit ,token-visit)

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

@ -1,11 +1,10 @@
#lang scheme/base
(require (for-syntax scheme/base)
#lang racket/base
(require (for-syntax racket/base)
(for-syntax racket/private/struct-info)
scheme/list
scheme/match
racket/list
racket/match
unstable/struct
"deriv.ss")
"deriv.rkt")
(provide make

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

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

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

@ -1,10 +1,8 @@
#lang scheme/base
(require (for-syntax scheme/base)
scheme/match
syntax/boundmap
"reductions-config.ss"
"../util/mpi.ss")
#lang racket/base
(require (for-syntax racket/base)
racket/match
"reductions-config.rkt"
"../util/mpi.rkt")
(provide policy->predicate)
;; A Policy is one of

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

@ -1,14 +1,13 @@
#lang scheme/base
(require (for-syntax scheme/base)
scheme/list
scheme/contract
scheme/match
"deriv.ss"
"deriv-util.ss"
"stx-util.ss"
"context.ss"
"steps.ss")
#lang racket/base
(require (for-syntax racket/base)
racket/list
racket/contract
racket/match
"deriv.rkt"
"deriv-util.rkt"
"stx-util.rkt"
"context.rkt"
"steps.rkt")
(define-syntax-rule (STRICT-CHECKS form ...)
(when #f
@ -45,9 +44,6 @@
[macro-policy (parameter/c (identifier? . -> . any))]
[subterms-table (parameter/c (or/c subterms-table/c false/c))]
[hides-flags (list-parameter/c boolean?)]
[block-syntax-bindings (parameter/c (listof syntaxish?))]
[block-value-bindings (parameter/c (listof syntaxish?))]
[block-expressions (parameter/c syntaxish?)]
[learn-binders ((listof identifier?) . -> . any)]
[learn-definites ((listof identifier?) . -> . any)]
@ -60,6 +56,9 @@
[#:foci1 syntaxish? #:foci2 syntaxish?]
. ->* . step?)]
[stumble ([syntaxish? exn?] [#:focus syntaxish?] . ->* . misstep?)]
[walk/talk
(-> (or/c symbol? string?) (listof (or/c syntax? string? 'arrow))
remarkstep?)]
[current-pass-hides? (parameterlike/c boolean?)]
@ -112,13 +111,6 @@
;; hides-flags : (parameterof (listof (boxof boolean)))
(define hides-flags (make-parameter null))
;; block-syntax-bindings : (parameter/c (listof stx))
;; block-value-bindings : (parameter/c (listof stx))
;; block-expressions : (parameter/c (listof stx))
(define block-value-bindings (make-parameter null))
(define block-syntax-bindings (make-parameter null))
(define block-expressions (make-parameter null))
;; lift params
(define available-lift-stxs (make-parameter null))
(define visible-lift-stxs (make-parameter null))
@ -343,6 +335,11 @@
(current-state-with stx focus)
exn))
(define (walk/talk type contents)
(make remarkstep type
(current-state-with #f null)
contents))
(define (foci x)
(cond [(syntax? x)
(list x)]

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

@ -1,16 +1,16 @@
#lang scheme/base
(require (for-syntax scheme/base)
(for-syntax syntax/parse)
scheme/list
scheme/contract
"deriv.ss"
"deriv-util.ss"
"stx-util.ss"
"context.ss"
"steps.ss"
"reductions-config.ss")
(provide (all-from-out "steps.ss")
(all-from-out "reductions-config.ss")
#lang racket/base
(require (for-syntax racket/base
syntax/parse)
racket/list
racket/contract
"deriv.rkt"
"deriv-util.rkt"
"stx-util.rkt"
"context.rkt"
"steps.rkt"
"reductions-config.rkt")
(provide (all-from-out "steps.rkt")
(all-from-out "reductions-config.rkt")
DEBUG
R
!)
@ -46,8 +46,6 @@
;; [#:let var expr]
;; [#:left-foot]
;; [#:walk term2 description]
;; [#:walk/ctx pattern term2 description]
;; [#:walk/foci term2 foci1 foci2 description]
;; [#:rename pattern rename [description]]
;; [#:rename/no-step pattern stx stx]
;; [#:reductions expr]

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

@ -1,10 +1,9 @@
#lang scheme/base
(require scheme/match
"stx-util.ss"
"deriv-util.ss"
"deriv.ss"
"reductions-engine.ss")
#lang racket/base
(require racket/match
"stx-util.rkt"
"deriv-util.rkt"
"deriv.rkt"
"reductions-engine.rkt")
(provide reductions
reductions+)
@ -419,7 +418,15 @@
;; FIXME: add action
(R [#:do (take-lift!)]
[#:binders ids]
[#:reductions (list (walk expr ids 'local-lift))])]
[#:reductions
(list
(walk/talk 'local-lift
(list "The macro lifted an expression"
""
"Expression:"
expr
"Identifiers:"
(datum->syntax #f ids))))])]
[(struct local-lift-end (decl))
;; (walk/mono decl 'module-lift)
@ -436,7 +443,9 @@
[R [! ?1]
;; FIXME: use renames
[#:binders names]
[#:when bindrhs => (BindSyntaxes bindrhs)]]]))
[#:when bindrhs => (BindSyntaxes bindrhs)]]]
[(struct local-remark (contents))
(R [#:reductions (list (walk/talk 'remark contents))])]))
;; List : ListDerivation -> RST
(define (List ld)
@ -453,32 +462,15 @@
(match/count bd
[(Wrap bderiv (es1 es2 pass1 trans pass2))
(R [#:pattern ?block]
[#:parameterize ((block-syntax-bindings null)
(block-value-bindings null)
(block-expressions null))
[#:pass1]
[BlockPass ?block pass1]
[#:pass2]
[#:when (eq? trans 'letrec)
[#:walk
(let* ([pass2-stxs (wlderiv-es1 pass2)]
[letrec-form (car pass2-stxs)]
[letrec-kw (stx-car letrec-form)]
[stx-bindings (reverse (block-syntax-bindings))]
[val-bindings (reverse (block-value-bindings))]
[exprs (block-expressions)]
[mk-letrec-form (lambda (x) (datum->syntax #f x))])
(list
(mk-letrec-form
`(,letrec-kw ,@(if (pair? stx-bindings)
(list stx-bindings)
null)
,val-bindings
. ,exprs))))
'block->letrec]]
[#:rename ?block (wlderiv-es1 pass2)]
[#:set-syntax (wlderiv-es1 pass2)]
[List ?block pass2]])]
[#:pass1]
[BlockPass ?block pass1]
[#:pass2]
[#:if (eq? trans 'letrec)
(;; FIXME: foci (difficult because of renaming?)
[#:walk (wlderiv-es1 pass2) 'block->letrec])
([#:rename ?block (wlderiv-es1 pass2)]
[#:set-syntax (wlderiv-es1 pass2)])]
[List ?block pass2])]
[#f
(R)]))
@ -515,13 +507,11 @@
[#:pass1]
[Expr ?first head]
[! ?1]
[#:pass2]
[#:pattern ((?define-values ?vars . ?body) . ?rest)]
[#:rename (?vars . ?body) rename]
[#:binders #'?vars]
[! ?2]
[#:do (block-value-bindings
(cons (cons #'?vars #'?body) (block-value-bindings)))]
[#:pass2]
[#:pattern (?first . ?rest)]
[BlockPass ?rest rest])]
[(cons (Wrap b:defstx (renames head ?1 rename ?2 bindrhs)) rest)
@ -530,13 +520,11 @@
[#:pass1]
[Expr ?first head]
[! ?1]
[#:pass2]
[#:pattern ((?define-syntaxes ?vars . ?body) . ?rest)]
[#:rename (?vars . ?body) rename]
[#:binders #'?vars]
[! ?2]
[#:do (block-syntax-bindings
(cons (cons #'?vars #'?body) (block-syntax-bindings)))]
[#:pass2]
[#:pattern ((?define-syntaxes ?vars ?rhs) . ?rest)]
[BindSyntaxes ?rhs bindrhs]
[#:pattern (?first . ?rest)]
@ -545,8 +533,6 @@
(R [#:pattern (?first . ?rest)]
[#:rename/no-step ?first (car renames) (cdr renames)]
[Expr ?first head]
[#:do (block-expressions #'(?first . ?rest))]
;; rest better be empty
[BlockPass ?rest rest])]
))

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

@ -1,10 +1,10 @@
#lang scheme/base
(require "deriv.ss"
"deriv-util.ss")
#lang racket/base
(require "deriv.rkt"
"deriv-util.rkt")
(provide (struct-out protostep)
(struct-out step)
(struct-out misstep)
(struct-out remarkstep)
(struct-out state)
(struct-out bigframe)
context-fill
@ -22,9 +22,11 @@
;; A Step is one of
;; - (make-step StepType State State)
;; - (make-misstep StepType State exn)
;; - (make-remarkstep StepType State (listof (U string syntax 'arrow)))
(define-struct protostep (type s1) #:transparent)
(define-struct (step protostep) (s2) #:transparent)
(define-struct (misstep protostep) (exn) #:transparent)
(define-struct (remarkstep protostep) (contents) #:transparent)
;; A State is
;; (make-state stx stxs Context BigContext (listof id) (listof id) (listof stx) nat/#f)
@ -89,6 +91,8 @@
(splice-lifts . "Splice definitions from lifted expressions")
(splice-module-lifts . "Splice lifted module declarations")
(remark . "Macro made a remark")
(error . "Error")))
(define (step-type->string x)

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

@ -1,6 +1,5 @@
#lang scheme/base
(require (for-syntax scheme/base)
#lang racket/base
(require (for-syntax racket/base)
syntax/stx)
(provide (all-defined-out)

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

@ -1,10 +1,9 @@
#lang scheme/base
(require scheme/class
#lang racket/base
(require racket/class
parser-tools/lex
"deriv-tokens.ss"
"deriv-parser.ss"
"../syntax-browser.ss")
"deriv-tokens.rkt"
"deriv-parser.rkt"
"../syntax-browser.rkt")
(provide (all-defined-out))
(define current-expand-observe

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

@ -1,10 +1,9 @@
#lang scheme/base
(require scheme/promise
#lang racket/base
(require racket/promise
parser-tools/lex
"deriv.ss"
"deriv-parser.ss"
"deriv-tokens.ss")
"deriv.rkt"
"deriv-parser.rkt"
"deriv-tokens.rkt")
(provide trace
trace*

7
collects/macro-debugger/model/yacc-ext.rkt
View File

@ -1,7 +1,6 @@
#lang scheme/base
(require (prefix-in yacc: parser-tools/yacc)
(for-syntax scheme/base))
#lang racket/base
(require (for-syntax racket/base)
(prefix-in yacc: parser-tools/yacc))
(provide parser
options
productions

8
collects/macro-debugger/model/yacc-interrupted.rkt
View File

@ -1,9 +1,7 @@
#lang scheme/base
(require (for-syntax scheme/base
mzlib/etc
#lang racket/base
(require (for-syntax racket/base
unstable/syntax)
"yacc-ext.ss")
"yacc-ext.rkt")
(provide ! ? !!
define-production-splitter
skipped-token-values

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

@ -1,13 +1,12 @@
#lang scheme/base
(require scheme/list
scheme/pretty
"model/trace.ss"
"model/reductions.ss"
"model/reductions-config.ss"
"model/steps.ss"
"syntax-browser/partition.ss"
"syntax-browser/pretty-helper.ss")
#lang racket/base
(require racket/list
racket/pretty
"model/trace.rkt"
"model/reductions.rkt"
"model/reductions-config.rkt"
"model/steps.rkt"
"syntax-browser/partition.rkt"
"syntax-browser/pretty-helper.rkt")
(provide expand/step-text
stepper-text)

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

@ -1,6 +1,5 @@
#lang scheme/base
(require "view/view.ss")
#lang racket/base
(require "view/view.rkt")
(provide expand/step)
(define (expand/step stx)

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

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

34
collects/macro-debugger/syntax-browser/controller.rkt
View File

@ -1,10 +1,8 @@
#lang scheme/base
(require scheme/class
(rename-in unstable/class-iop
[send/i send:]
[init-field/i init-field:])
"interfaces.ss"
"partition.ss"
#lang racket/base
(require racket/class
unstable/class-iop
"interfaces.rkt"
"partition.rkt"
unstable/gui/notify)
(provide controller%)
@ -33,13 +31,13 @@
(super-new)
(listen-selected-syntax
(lambda (new-value)
(for-each (lambda (display) (send: display display<%> refresh))
(for-each (lambda (display) (send/i display display<%> refresh))
displays)))))
;; mark-manager-mixin
(define mark-manager-mixin
(mixin () (mark-manager<%>)
(init-field: [primary-partition partition<%> (new-bound-partition)])
(init-field/i [primary-partition partition<%> (new-bound-partition)])
(super-new)
;; get-primary-partition : -> partition
@ -50,26 +48,20 @@
(define/public-final (reset-primary-partition)
(set! primary-partition (new-bound-partition)))))
;; secondary-partition-mixin
(define secondary-partition-mixin
(mixin (displays-manager<%>) (secondary-partition<%>)
;; secondary-relation-mixin
(define secondary-relation-mixin
(mixin (displays-manager<%>) (secondary-relation<%>)
(inherit-field displays)
(define-notify identifier=? (new notify-box% (value #f)))
(define-notify secondary-partition (new notify-box% (value #f)))
(listen-identifier=?
(lambda (name+proc)
(set-secondary-partition
(and name+proc
(new partition% (relation (cdr name+proc)))))))
(listen-secondary-partition
(lambda (p)
(for ([d displays])
(send: d display<%> refresh))))
(for ([d (in-list displays)])
(send/i d display<%> refresh))))
(super-new)))
(define controller%
(class* (secondary-partition-mixin
(class* (secondary-relation-mixin
(selection-manager-mixin
(mark-manager-mixin
(displays-manager-mixin

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

@ -1,14 +1,14 @@
#lang scheme/base
(require scheme/class
scheme/gui
scheme/list
(rename-in unstable/class-iop
[send/i send:]
[init-field/i init-field:])
(only-in mzlib/etc begin-with-definitions)
"pretty-printer.ss"
"interfaces.ss"
"util.ss")
#lang racket/base
(require racket/class
racket/gui
racket/list
racket/block
framework
unstable/class-iop
"pretty-printer.rkt"
"interfaces.rkt"
"prefs.rkt"
"util.rkt")
(provide print-syntax-to-editor
code-style)
@ -25,13 +25,13 @@
;; -> display<%>
(define (print-syntax-to-editor stx text controller config columns
[insertion-point (send text last-position)])
(begin-with-definitions
(block
(define output-port (open-output-string/count-lines))
(define range
(pretty-print-syntax stx output-port
(send: controller controller<%> get-primary-partition)
(length (send: config config<%> get-colors))
(send: config config<%> get-suffix-option)
(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))
@ -54,15 +54,15 @@
;; display%
(define display%
(class* object% (display<%>)
(init-field: [controller controller<%>]
[config config<%>]
[range range<%>])
(init-field/i [controller controller<%>]
[config config<%>]
[range range<%>])
(init-field text
start-position
end-position)
(define base-style
(code-style text (send: config config<%> get-syntax-font-size)))
(code-style text (send/i config config<%> get-syntax-font-size)))
(define extra-styles (make-hasheq))
@ -76,10 +76,10 @@
;; add-clickbacks : -> void
(define/private (add-clickbacks)
(define (the-clickback editor start end)
(send: controller selection-manager<%> set-selected-syntax
(send/i controller selection-manager<%> set-selected-syntax
(clickback->stx
(- start start-position) (- end start-position))))
(for ([range (send: range range<%> all-ranges)])
(for ([range (send/i range range<%> all-ranges)])
(let ([stx (range-obj range)]
[start (range-start range)]
[end (range-end range)])
@ -89,7 +89,7 @@
;; 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: range range<%> get-treeranges)])
(let ([treeranges (send/i range range<%> get-treeranges)])
(let loop* ([treeranges treeranges])
(for/or ([tr treeranges])
(cond [(and (= (treerange-start tr) start)
@ -106,12 +106,12 @@
(with-unlock text
(send* text
(begin-edit-sequence #f)
(change-style unhighlight-d start-position end-position))
(change-style (unhighlight-d) start-position end-position))
(apply-extra-styles)
(let ([selected-syntax
(send: controller selection-manager<%>
(send/i controller selection-manager<%>
get-selected-syntax)])
(apply-secondary-partition-styles selected-syntax)
(apply-secondary-relation-styles selected-syntax)
(apply-selection-styles selected-syntax))
(send* text
(end-edit-sequence))))
@ -157,13 +157,16 @@
(send delta set-delta-foreground color)
(send style-list find-or-create-style base-style delta)))
(define color-styles
(list->vector (map color-style (send: config config<%> get-colors))))
(define overflow-style (color-style "darkgray"))
(list->vector
(map color-style
(map translate-color
(send/i config config<%> get-colors)))))
(define overflow-style (color-style (translate-color "darkgray")))
(define color-partition
(send: controller mark-manager<%> get-primary-partition))
(send/i controller mark-manager<%> get-primary-partition))
(define offset start-position)
;; Optimization: don't call change-style when new style = old style
(let tr*loop ([trs (send: range range<%> get-treeranges)] [old-style #f])
(let tr*loop ([trs (send/i range range<%> get-treeranges)] [old-style #f])
(for ([tr trs])
(define stx (treerange-obj tr))
(define start (treerange-start tr))
@ -179,7 +182,7 @@
;; primary-style : syntax partition (vector-of style-delta%) style-delta%
;; -> style-delta%
(define/private (primary-style stx partition color-vector overflow)
(let ([n (send: partition partition<%> get-partition stx)])
(let ([n (send/i partition partition<%> get-partition stx)])
(cond [(< n (vector-length color-vector))
(vector-ref color-vector n)]
[else
@ -192,34 +195,34 @@
;; Applies externally-added styles (such as highlighting)
(define/private (apply-extra-styles)
(for ([(stx style-deltas) extra-styles])
(for ([r (send: range range<%> get-ranges stx)])
(for ([r (send/i range range<%> get-ranges stx)])
(for ([style-delta style-deltas])
(restyle-range r style-delta)))))
;; apply-secondary-partition-styles : selected-syntax -> void
;; apply-secondary-relation-styles : selected-syntax -> void
;; If the selected syntax is an identifier, then styles all identifiers
;; in the same partition in blue.
(define/private (apply-secondary-partition-styles selected-syntax)
;; in the relation with it.
(define/private (apply-secondary-relation-styles selected-syntax)
(when (identifier? selected-syntax)
(let ([partition
(send: controller secondary-partition<%>
get-secondary-partition)])
(when partition
(for ([id (send: range range<%> get-identifier-list)])
(when (send: partition partition<%>
same-partition? selected-syntax id)
(let* ([name+relation
(send/i controller secondary-relation<%>
get-identifier=?)]
[relation (and name+relation (cdr name+relation))])
(when relation
(for ([id (send/i range range<%> get-identifier-list)])
(when (relation selected-syntax id)
(draw-secondary-connection id)))))))
;; apply-selection-styles : syntax -> void
;; Styles subterms eq to the selected syntax
(define/private (apply-selection-styles selected-syntax)
(for ([r (send: range range<%> get-ranges selected-syntax)])
(restyle-range r select-highlight-d)))
(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: range range<%> get-ranges stx2)])
(restyle-range r select-sub-highlight-d)))
(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)
@ -233,11 +236,11 @@
;; Initialize
(super-new)
(send: controller controller<%> add-syntax-display this)))
(send/i controller controller<%> add-syntax-display this)))
;; fixup-parentheses : string range -> void
(define (fixup-parentheses string range)
(for ([r (send: range range<%> all-ranges)])
(for ([r (send/i range range<%> all-ranges)])
(let ([stx (range-obj r)]
[start (range-start r)]
[end (range-end r)])
@ -258,7 +261,7 @@
;; code-style : text<%> number/#f -> style<%>
(define (code-style text font-size)
(let* ([style-list (send text get-style-list)]
[style (send style-list find-named-style "Standard")])
[style (send style-list find-named-style (editor:get-default-color-style-name))])
(if font-size
(send style-list find-or-create-style
style
@ -272,13 +275,98 @@
(make-object string-snip% ""))
(super-instantiate ())))
;; Color translation
;; translate-color : color-string -> color%
(define (translate-color color-string)
(let ([c (make-object color% color-string)])
(if (pref:invert-colors?)
(let-values ([(r* g* b*)
(lightness-invert (send c red) (send c green) (send c blue))])
#|
(printf "translate: ~s -> ~s\n"
(list (send c red) (send c green) (send c blue))
(list r* g* b*))
|#
(make-object color% r* g* b*))
c)))
;; lightness-invert : uint8 uint8 uint8 -> (values uint8 uint8 uint8)
(define (lightness-invert r g b)
(define (c x)
(/ (exact->inexact x) 255.0))
(define (d x)
(inexact->exact (round (* x 255))))
(let-values ([(r g b) (lightness-invert* (c r) (c g) (c b))])
(values (d r) (d g) (d b))))
(define (lightness-invert* R G B)
(let-values ([(Hp Sl L) (rgb->hsl* R G B)])
(hsl*->rgb Hp Sl (- 1.0 L))))
(define (rgb->hsl* R G B)
(define M (max R G B))
(define m (min R G B))
(define C (- M m))
(define Hp
(cond [(zero? C)
;; Undefined, but use 0
0.0]
[(= M R)
(realmod* (/ (- G B) C) 6)]
[(= M G)
(+ (/ (- B R) C) 2)]
[(= M B)
(+ (/ (- R G) C) 4)]))
(define L (* 0.5 (+ M m)))
(define Sl
(cond [(zero? C) 0.0]
[(>= L 0.5) (/ C (* 2 L))]
[else (/ C (- 2 (* 2 L)))]))
(values Hp Sl L))
(define (hsl*->rgb Hp Sl L)
(define C
(cond [(>= L 0.5) (* 2 L Sl)]
[else (* (- 2 (* 2 L)) Sl)]))
(define X (* C (- 1 (abs (- (realmod Hp 2) 1)))))
(define-values (R1 G1 B1)
(cond [(< Hp 1) (values C X 0)]
[(< Hp 2) (values X C 0)]
[(< Hp 3) (values 0 C X)]
[(< Hp 4) (values 0 X C)]
[(< Hp 5) (values X 0 C)]
[(< Hp 6) (values C 0 X)]))
(define m (- L (* 0.5 C)))
(values (+ R1 m) (+ G1 m) (+ B1 m)))
;; realmod : real integer -> real
;; Adjusts a real number to [0, base]
(define (realmod x base)
(define xint (ceiling x))
(define m (modulo xint base))
(realmod* (- m (- xint x)) base))
;; realmod* : real real -> real
;; Adjusts a number in [-base, base] to [0,base]
;; Not a real mod, but faintly reminiscent.
(define (realmod* x base)
(if (negative? x)
(+ x base)
x))
;; Styles
(define (highlight-style-delta color em?)
(let ([sd (new style-delta%)])
(unless em? (send sd set-delta-background color))
(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)
(unless em?
;; (send sd set-underlined-off #t)
(send sd set-weight-off 'bold))
sd))
@ -287,10 +375,17 @@
(send sd set-underlined-on #t)
sd))
(define selection-color "yellow")
(define subselection-color "yellow")
(define (mk-2-constant-style bow-color em? [wob-color (translate-color bow-color)])
(let ([wob-version (highlight-style-delta wob-color em? #:translate-color? #f)]
[bow-version (highlight-style-delta bow-color em? #:translate-color? #f)])
(λ ()
(if (pref:invert-colors?)
wob-version
bow-version))))
(define select-highlight-d (highlight-style-delta selection-color #t))
(define select-sub-highlight-d (highlight-style-delta subselection-color #f))
(define select-highlight-d
(mk-2-constant-style "yellow" #t "darkgoldenrod"))
(define select-sub-highlight-d
(mk-2-constant-style "yellow" #f "darkgoldenrod"))
(define unhighlight-d (highlight-style-delta "white" #f))
(define unhighlight-d (mk-2-constant-style "white" #f #|"black"|#))

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

@ -1,11 +1,10 @@
#lang racket/base
(require "interfaces.rkt"
"widget.rkt"
"keymap.rkt"
"partition.rkt")
#lang scheme/base
(require "interfaces.ss"
"widget.ss"
"keymap.ss"
"partition.ss")
(provide (all-from-out "interfaces.ss")
(all-from-out "widget.ss")
(all-from-out "keymap.ss")
(provide (all-from-out "interfaces.rkt")
(all-from-out "widget.rkt")
(all-from-out "keymap.rkt")
identifier=-choices)

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

@ -1,17 +1,13 @@
#lang scheme/base
(require scheme/class
(rename-in unstable/class-iop
[define/i define:]
[send/i send:]
[send*/i send*:]
[init-field/i init-field:])
scheme/gui
framework/framework
scheme/list
"interfaces.ss"
"partition.ss"
"prefs.ss"
"widget.ss")
#lang racket/base
(require racket/class
racket/gui
racket/list
framework
unstable/class-iop
"interfaces.rkt"
"partition.rkt"
"prefs.rkt"
"widget.rkt")
(provide browse-syntax
browse-syntaxes
make-syntax-browser
@ -26,7 +22,7 @@
(define (browse-syntaxes stxs)
(let ((w (make-syntax-browser)))
(for ([stx stxs])
(send*: w syntax-browser<%>
(send*/i w syntax-browser<%>
(add-syntax stx)
(add-separator)))))
@ -41,17 +37,17 @@
(class* frame% ()
(inherit get-width
get-height)
(init-field: [config config<%> (new syntax-prefs%)])
(init-field/i [config config<%> (new syntax-prefs%)])
(super-new (label "Syntax Browser")
(width (send: config config<%> get-width))
(height (send: config config<%> get-height)))
(define: widget syntax-browser<%>
(width (send/i config config<%> get-width))
(height (send/i config config<%> get-height)))
(define/i widget syntax-browser<%>
(new syntax-widget/controls%
(parent this)
(config config)))
(define/public (get-widget) widget)
(define/augment (on-close)
(send*: config config<%>
(send*/i config config<%>
(set-width (get-width))
(set-height (get-height)))
(send widget shutdown)
@ -81,22 +77,22 @@
(choices (map car -identifier=-choices))
(callback
(lambda (c e)
(send: (get-controller) controller<%> set-identifier=?
(send/i (get-controller) controller<%> set-identifier=?
(assoc (send c get-string-selection)
-identifier=-choices))))))
(new button%
(label "Clear")
(parent -control-panel)
(callback (lambda _ (send: (get-controller) controller<%> set-selected-syntax #f))))
(callback (lambda _ (send/i (get-controller) controller<%> set-selected-syntax #f))))
(new button%
(label "Properties")
(parent -control-panel)
(callback
(lambda _
(send: config config<%> set-props-shown?
(not (send: config config<%> get-props-shown?))))))
(send/i config config<%> set-props-shown?
(not (send/i config config<%> get-props-shown?))))))
(send: (get-controller) controller<%> listen-identifier=?
(send/i (get-controller) controller<%> listen-identifier=?
(lambda (name+func)
(send -choice set-selection
(or (send -choice find-string (car name+func)) 0))))

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

@ -1,8 +1,6 @@
#lang scheme/base
(require scheme/class
scheme/gui)
#lang racket/base
(require racket/class
racket/gui)
(provide hrule-snip%)
;; hrule-snip%
@ -53,5 +51,5 @@
(define snip-class (new hrule-snipclass%))
(send snip-class set-version 1)
(send snip-class set-classname
(format "~s" '(lib "hrule-snip.ss" "macro-debugger" "syntax-browser")))
(format "~s" '(lib "hrule-snip.rkt" "macro-debugger" "syntax-browser")))
(send (get-the-snip-class-list) add snip-class)

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

@ -1,11 +1,11 @@
#lang scheme/base
(require scheme/contract
scheme/class
scheme/gui
#lang racket/base
(require racket/contract
racket/class
racket/gui
framework
"prefs.ss"
"controller.ss"
"display.ss")
"prefs.rkt"
"controller.rkt"
"display.rkt")
#|
@ -36,7 +36,7 @@ TODO: tacked arrows
;; print-syntax-columns : (parameter-of (U number 'infinity))
(define print-syntax-columns (make-parameter 40))
(define standard-text% (editor:standard-style-list-mixin text%))
(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
@ -54,7 +54,7 @@ TODO: tacked arrows
(define dc (new bitmap-dc% (bitmap (make-object bitmap% 1 1))))
(define char-width
(let* ([sl (send t get-style-list)]
[style (send sl find-named-style "Standard")]
[style (send sl find-named-style (editor:get-default-color-style-name))]
[font (send style get-font)])
(send dc set-font font)
(send dc get-char-width)))
@ -89,7 +89,7 @@ TODO: tacked arrows
(define (prepare-editor stx columns)
(define t (new standard-text%))
(define sl (send t get-style-list))
(send t change-style (send sl find-named-style "Standard"))
(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))

20
collects/macro-debugger/syntax-browser/interfaces.rkt
View File

@ -1,7 +1,7 @@
#lang scheme/base
(require scheme/class
#lang racket/base
(require racket/class
unstable/class-iop
(for-syntax scheme/base))
(for-syntax racket/base))
(provide (all-defined-out))
;; Helpers
@ -14,7 +14,7 @@
[else (error '->string)]))
(string->symbol (apply string-append (map ->string args))))
;; not in notify.ss because notify depends on scheme/gui
;; not in notify.rkt because notify depends on gui
(define-interface-expander methods:notify
(lambda (stx)
(syntax-case stx ()
@ -61,18 +61,16 @@
;; reset-primary-partition : -> void
reset-primary-partition))
;; secondary-partition<%>
(define-interface secondary-partition<%> ()
(;; secondary-partition : notify-box of partition<%>
;; identifier=? : notify-box of (cons string procedure)
(methods:notify secondary-partition
identifier=?)))
;; secondary-relation<%>
(define-interface secondary-relation<%> ()
(;; identifier=? : notify-box of (cons string (U #f (id id -> bool)))
(methods:notify identifier=?)))
;; controller<%>
(define-interface controller<%> (displays-manager<%>
selection-manager<%>
mark-manager<%>
secondary-partition<%>)
secondary-relation<%>)
())

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

@ -1,10 +1,10 @@
#lang scheme/base
(require scheme/class
scheme/gui
scheme/pretty
#lang racket/base
(require racket/class
racket/gui
racket/pretty
unstable/gui/notify
"interfaces.ss"
"partition.ss")
"interfaces.rkt"
"partition.rkt")
(provide syntax-keymap%)
(define keymap/popup%

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

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

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

@ -1,13 +1,15 @@
#lang scheme/base
(require scheme/class
framework/framework
"interfaces.ss"
#lang racket/base
(require racket/class
framework
"interfaces.rkt"
unstable/gui/notify
unstable/gui/prefs)
(provide prefs-base%
syntax-prefs-base%
syntax-prefs%
syntax-prefs/readonly%)
syntax-prefs/readonly%
pref:invert-colors?)
(preferences:set-default 'SyntaxBrowser:Width 700 number?)
(preferences:set-default 'SyntaxBrowser:Height 600 number?)
@ -19,6 +21,8 @@
(define pref:props-percentage (pref:get/set 'SyntaxBrowser:PropertiesPanelPercentage))
(define pref:props-shown? (pref:get/set 'SyntaxBrowser:PropertiesPanelShown))
(define pref:invert-colors? (pref:get/set 'framework:white-on-black?))
(define prefs-base%
(class object%
;; suffix-option : SuffixOption

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

@ -1,11 +1,10 @@
#lang scheme/base
(require scheme/class
scheme/pretty
(rename-in unstable/class-iop
[send/i send:])
#lang racket/base
(require racket/class
racket/pretty
unstable/class-iop
syntax/stx
unstable/struct
"interfaces.ss")
"interfaces.rkt")
(provide (all-defined-out))
;; Problem: If stx1 and stx2 are two distinguishable syntax objects, it
@ -32,7 +31,7 @@
[print-vector-length #f]
[print-hash-table #t]
[print-honu #f])
(pretty-print datum port)))
(pretty-write datum port)))
(define-struct syntax-dummy (val))
(define-struct (id-syntax-dummy syntax-dummy) (remap))
@ -64,12 +63,12 @@
((never)
(make-id-syntax-dummy sym sym))
((always)
(let ([n (send: partition partition<%> get-partition id)])
(let ([n (send/i partition partition<%> get-partition id)])
(if (zero? n)
(make-id-syntax-dummy sym sym)
(make-id-syntax-dummy (suffix sym n) sym))))
((over-limit)
(let ([n (send: partition partition<%> get-partition id)])
(let ([n (send/i partition partition<%> get-partition id)])
(if (<= n limit)
(make-id-syntax-dummy sym sym)
(make-id-syntax-dummy (suffix sym n) sym))))))
@ -82,7 +81,7 @@
=> (lambda (datum) datum)]
[(and partition (identifier? obj))
(when (and (eq? suffixopt 'all-if-over-limit)
(> (send: partition partition<%> count) limit))
(> (send/i partition partition<%> count) limit))
(call-with-values (lambda () (table stx partition #f 'always))
escape))
(let ([lp-datum (make-identifier-proxy obj)])
@ -91,7 +90,7 @@
lp-datum)]
[(and (syntax? obj) (check+convert-special-expression obj))
=> (lambda (newobj)
(when partition (send: partition partition<%> get-partition obj))
(when partition (send/i partition partition<%> get-partition obj))
(let* ([inner (cadr newobj)]
[lp-inner-datum (loop inner)]
[lp-datum (list (car newobj) lp-inner-datum)])
@ -101,7 +100,7 @@
(hash-set! stx=>flat obj lp-datum)
lp-datum))]
[(syntax? obj)
(when partition (send: partition partition<%> get-partition obj))
(when partition (send/i partition partition<%> get-partition obj))
(let ([lp-datum (loop (syntax-e obj))])
(hash-set! flat=>stx lp-datum obj)
(hash-set! stx=>flat obj lp-datum)

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

@ -1,10 +1,10 @@
#lang scheme/base
(require scheme/list
scheme/class
scheme/pretty
scheme/gui
"pretty-helper.ss"
"interfaces.ss")
#lang racket/base
(require racket/list
racket/class
racket/pretty
racket/gui
"pretty-helper.rkt"
"interfaces.rkt")
(provide pretty-print-syntax)
;; FIXME: Need to disable printing of structs with custom-write property

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

@ -1,14 +1,32 @@
#lang scheme/base
(require scheme/class
scheme/gui
(rename-in unstable/class-iop
[send/i send:])
"interfaces.ss"
"util.ss"
"../util/mpi.ss")
#lang racket/base
(require racket/class
racket/gui
framework
unstable/class-iop
"interfaces.rkt"
"util.rkt"
"../util/mpi.rkt"
"../util/stxobj.rkt")
(provide properties-view%
properties-snip%)
(define color-text-default-style-name
"macro-debugger/syntax-browser/properties color-text% basic")
(define color-text%
(class (editor:standard-style-list-mixin text:basic%)
(inherit get-style-list)
(define/override (default-style-name)
color-text-default-style-name)
(super-new)
(let* ([sl (get-style-list)]
[standard
(send sl find-named-style (editor:get-default-color-style-name))]
[basic
(send sl find-or-create-style standard
(make-object style-delta% 'change-family 'default))])
(send sl new-named-style color-text-default-style-name basic))))
;; properties-view-base-mixin
(define properties-view-base-mixin
(mixin () ()
@ -22,13 +40,13 @@
(define mode 'term)
;; text : text%
(field (text (new text%)))
(field (text (new color-text%)))
(field (pdisplayer (new properties-displayer% (text text))))
(send: controller selection-manager<%> listen-selected-syntax
(lambda (stx)
(set! selected-syntax stx)
(refresh)))
(send/i controller selection-manager<%> listen-selected-syntax
(lambda (stx)
(set! selected-syntax stx)
(refresh)))
(super-new)
;; get-mode : -> symbol
@ -122,7 +140,7 @@
(callback
(lambda (tp e)
(set-mode (cdr (list-ref tab-choices (send tp get-selection))))))))
(define ecanvas (new editor-canvas% (editor text) (parent tab-panel)))))
(define ecanvas (new canvas:color% (editor text) (parent tab-panel)))))
;; properties-displayer%
(define properties-displayer%
@ -188,7 +206,8 @@
(define/public (display-stxobj-info stx)
(display-source-info stx)
(display-extra-source-info stx)
(display-symbol-property-info stx))
(display-symbol-property-info stx)
(display-marks stx))
;; display-source-info : syntax -> void
(define/private (display-source-info stx)
@ -226,7 +245,13 @@
(display "No additional properties available.\n" n/a-sd))
(when (pair? keys)
(for-each (lambda (k) (display-subkv/value k (syntax-property stx k)))
keys))))
keys))
(display "\n" #f)))
;; display-marks : syntax -> void
(define/private (display-marks stx)
(display "Marks: " key-sd)
(display (format "~s\n" (simplify-marks (get-marks stx))) #f))
;; display-kv : any any -> void
(define/private (display-kv key value)

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

@ -1,14 +1,13 @@
#lang scheme/base
(require scheme/class
(rename-in unstable/class-iop
[send/i send:])
mzlib/string
mred
"interfaces.ss"
"controller.ss"
"properties.ss"
"prefs.ss"
(except-in "snip.ss"
#lang racket/base
(require racket/class
racket/gui
(only-in mzlib/string read-from-string)
unstable/class-iop
"interfaces.rkt"
"controller.rkt"
"properties.rkt"
"prefs.rkt"
(except-in "snip.rkt"
snip-class))
(provide decorated-syntax-snip%
@ -145,8 +144,8 @@
(define/public (read-special src line col pos)
(send the-syntax-snip read-special src line col pos))
(send: config config<%> listen-props-shown?
(lambda (?) (refresh-contents)))
(send/i config config<%> listen-props-shown?
(lambda (?) (refresh-contents)))
(super-new)
(set-snipclass snip-class)
@ -198,7 +197,7 @@
;; SNIPCLASS
;; COPIED AND MODIFIED from mrlib/syntax-browser.ss
;; COPIED AND MODIFIED from mrlib/syntax-browser.rkt
(define decorated-syntax-snipclass%
(class snip-class%
(define/override (read stream)
@ -210,4 +209,4 @@
(define snip-class (make-object decorated-syntax-snipclass%))
(send snip-class set-version 2)
(send snip-class set-classname
(format "~s" '(lib "macro-debugger/syntax-browser/snip-decorated.ss")))
(format "~s" '(lib "macro-debugger/syntax-browser/snip-decorated.rkt")))

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

@ -1,16 +1,14 @@
#lang scheme/base
(require scheme/class
(rename-in unstable/class-iop
[send/i send:])
scheme/match
mzlib/string
mred
#lang racket/base
(require racket/class
racket/gui
racket/match
(only-in mzlib/string read-from-string)
framework
"interfaces.ss"
"display.ss"
"controller.ss"
"keymap.ss"
"prefs.ss")
"interfaces.rkt"
"display.rkt"
"controller.rkt"
"keymap.rkt"
"prefs.rkt")
(provide syntax-snip%
marshall-syntax
@ -167,7 +165,7 @@
;; SNIPCLASS
;; COPIED AND MODIFIED from mrlib/syntax-browser.ss
;; COPIED AND MODIFIED from mrlib/syntax-browser.rkt
(define syntax-snipclass%
(class snip-class%
(define/override (read stream)
@ -178,4 +176,4 @@
(define snip-class (new syntax-snipclass%))
(send snip-class set-version 2)
(send snip-class set-classname
(format "~s" '(lib "macro-debugger/syntax-browser/snip.ss")))
(format "~s" '(lib "macro-debugger/syntax-browser/snip.rkt")))

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

@ -1,12 +1,12 @@
#lang scheme/base
(require scheme/list
scheme/class
scheme/gui
#lang racket/base
(require racket/list
racket/class
racket/gui
drracket/arrow
framework/framework
unstable/interval-map
unstable/gui/notify
"interfaces.ss")
"interfaces.rkt")
(provide text:hover<%>
text:hover-drawings<%>

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

@ -1,6 +1,5 @@
#lang scheme/base
(require scheme/class)
#lang racket/base
(require racket/class)
(provide with-unlock
make-text-port)

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

@ -1,21 +1,20 @@
#lang scheme/base
(require scheme/class
mred
framework/framework
scheme/list
scheme/match
#lang racket/base
(require racket/class
racket/gui
racket/list
racket/match
framework
syntax/id-table
(rename-in unstable/class-iop
[send/i send:])
"interfaces.ss"
"controller.ss"
"display.ss"
"keymap.ss"
"hrule-snip.ss"
"properties.ss"
"text.ss"
"util.ss"
"../util/mpi.ss")
unstable/class-iop
"interfaces.rkt"
"controller.rkt"
"display.rkt"
"keymap.rkt"
"hrule-snip.rkt"
"properties.rkt"
"text.rkt"
"util.rkt"
"../util/mpi.rkt")
(provide widget%)
;; widget%
@ -33,7 +32,7 @@
(new panel:horizontal-dragable% (parent -main-panel)))
(define -text (new browser-text%))
(define -ecanvas
(new editor-canvas% (parent -split-panel) (editor -text)))
(new canvas:color% (parent -split-panel) (editor -text)))
(define -props-panel (new horizontal-panel% (parent -split-panel)))
(define props
(new properties-view%
@ -55,7 +54,7 @@
(define/private (internal-show-props show?)
(if show?
(unless (send -props-panel is-shown?)
(let ([p (send: config config<%> get-props-percentage)])
(let ([p (send/i config config<%> get-props-percentage)])
(send -split-panel add-child -props-panel)
(update-props-percentage p))
(send -props-panel show #t))
@ -82,7 +81,7 @@
(define/public (shutdown)
(when (props-panel-shown?)
(send: config config<%> set-props-percentage
(send/i config config<%> set-props-percentage
(cadr (send -split-panel get-percentages)))))
;; syntax-browser<%> Methods
@ -115,29 +114,29 @@
#:substitutions [substitutions null])
(let ([display (internal-add-syntax stx)]
[definite-table (make-hasheq)])
(let ([range (send: display display<%> get-range)]
[offset (send: display display<%> get-start-position)])
(let ([range (send/i display display<%> get-range)]
[offset (send/i display display<%> get-start-position)])
(for ([subst substitutions])
(for ([r (send: range range<%> get-ranges (car subst))])
(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: config config<%> get-syntax-font-size))
(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])
(send: display display<%> highlight-syntaxes hi-stxs hi-color))
(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: display display<%> get-range))
(define start (send: display display<%> get-start-position))
(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]
@ -149,17 +148,17 @@
(for ([binder binders])
(free-id-table-set! binder-table binder binder))
;; Underline binders (and shifted binders)
(send: display display<%> underline-syntaxes
(send/i display display<%> underline-syntaxes
(append (apply append (map get-shifted binders))
binders))
;; Make arrows (& billboards, when enabled)
(for ([id (send: range range<%> get-identifier-list)])
(for ([id (send/i range range<%> get-identifier-list)])
(define definite? (hash-ref definite-table id #f))
(when #f ;; DISABLED
(add-binding-billboard start range id definite?))
(for ([binder (get-binders id)])
(for ([binder-r (send: range range<%> get-ranges binder)])
(for ([id-r (send: range range<%> get-ranges 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?))))))
(void)))
@ -187,7 +186,7 @@
(+ start (cdr id-r))
(string-append "from " (mpi->string src-mod))
(if definite? "blue" "purple")))
(send: range range<%> get-ranges id))]
(send/i range range<%> get-ranges id))]
[_ (void)]))
(define/public (add-separator)
@ -200,7 +199,7 @@
(with-unlock -text
(send -text erase)
(send -text delete-all-drawings))
(send: controller displays-manager<%> remove-all-syntax-displays))
(send/i controller displays-manager<%> remove-all-syntax-displays))
(define/public (get-text) -text)
@ -218,7 +217,7 @@
display)))
(define/private (calculate-columns)
(define style (code-style -text (send: config config<%> get-syntax-font-size)))
(define style (code-style -text (send/i config config<%> get-syntax-font-size)))
(define char-width (send style get-text-width (send -ecanvas get-dc)))
(define-values (canvas-w canvas-h) (send -ecanvas get-client-size))
(sub1 (inexact->exact (floor (/ canvas-w char-width)))))
@ -227,13 +226,13 @@
(super-new)
(setup-keymap)
(send: config config<%> listen-props-shown?
(send/i config config<%> listen-props-shown?
(lambda (show?)
(show-props show?)))
(send: config config<%> listen-props-percentage
(send/i config config<%> listen-props-percentage
(lambda (p)
(update-props-percentage p)))
(internal-show-props (send: config config<%> get-props-shown?))))
(internal-show-props (send/i config config<%> get-props-shown?))))
(define clickback-style
@ -251,13 +250,20 @@
;; Specialized classes for widget
(define browser-text%
(class (text:arrows-mixin
(text:tacking-mixin
(text:hover-drawings-mixin
(text:hover-mixin
(text:hide-caret/selection-mixin
(editor:standard-style-list-mixin text:basic%))))))
(inherit set-autowrap-bitmap)
(define/override (default-style-name) "Basic")
(super-new (auto-wrap #t))
(set-autowrap-bitmap #f)))
(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))))

23
collects/macro-debugger/util/mpi.rkt
View File

@ -1,9 +1,12 @@
#lang scheme/base
(require scheme/match)
#lang racket/base
(require racket/match
racket/string)
(provide mpi->list
mpi->string)
mpi->string
self-mpi?)
;; mpi->list : module-path-index -> list
(define (mpi->list mpi)
(cond [(module-path-index? mpi)
(let-values ([(path relto) (module-path-index-split mpi)])
@ -18,12 +21,16 @@
(if (module-path-index? mpi)
(let ([mps (mpi->list mpi)])
(cond [(pair? mps)
(apply string-append
(format "~s" (car mps))
(map (lambda (x) (format " <= ~s" x)) (cdr mps)))]
(string-join (map (lambda (x) (format "~s" x)) mps)
" <= ")]
[(null? mps) "this module"]))
(format "~s" mpi)))
;; self-mpi? : module-path-index -> bool
(define (self-mpi? mpi)
(let-values ([(path relto) (module-path-index-split mpi)])
(eq? path #f)))
;; --
(provide mpi->mpi-sexpr
@ -169,7 +176,7 @@
[package (string-append (caddr m) ".plt")]
[version (and (cadddr m) (parse-version (cadddr m)))]
[path (list-ref m 4)])
`(planet ,(string-append (or path "main") ".ss")
`(planet ,(string-append (or path "main") ".rkt")
(,owner ,package . ,version)))))
(define (parse-version str)
@ -179,7 +186,7 @@
(define (split-mods* path)
(let ([mods (split-mods path)])
(if (and (pair? mods) (null? (cdr mods)))
(append mods (list "main.ss"))
(append mods (list "main.rkt"))
mods)))
(define (split-mods path [more null])

30
collects/macro-debugger/util/stxobj.rkt Normal file
View File

@ -0,0 +1,30 @@
#lang racket/base
(require (rename-in racket/contract [-> c:->])
ffi/unsafe)
(define lib (ffi-lib #f))
(define get-marks
(get-ffi-obj "scheme_stx_extract_marks" lib
(_fun _scheme -> _scheme)))
(define (simplify-marks marklist)
(simplify* (sort marklist <)))
(define (simplify* marklist)
(cond [(null? marklist) marklist]
[(null? (cdr marklist)) marklist]
[(= (car marklist) (cadr marklist))
(simplify* (cddr marklist))]
[else
(let ([result (simplify* (cdr marklist))])
(if (eq? result (cdr marklist))
marklist
(cons (car marklist) result)))]))
(provide/contract
[get-marks
;; syntax? check needed for safety!
(c:-> syntax? any)])
(provide simplify-marks)

7
collects/macro-debugger/view/cursor.rkt
View File

@ -1,6 +1,4 @@
#lang scheme/base
(require scheme/promise)
#lang racket/base
(provide cursor?
cursor-position
cursor:new
@ -24,7 +22,8 @@
cursor->list
cursor:prefix->list
cursor:suffix->list)
cursor:suffix->list
cursor-count)
(define-struct cursor (vector count position)
#:mutable)

5
collects/macro-debugger/view/debug-format.rkt
View File

@ -1,6 +1,5 @@
#lang scheme/base
(require scheme/pretty)
#lang racket/base
(require racket/pretty)
(provide write-debug-file
load-debug-file)

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

@ -1,12 +1,11 @@
#lang scheme/base
(require scheme/pretty
scheme/class
(rename-in unstable/class-iop
[send/i send:])
"interfaces.ss"
"debug-format.ss"
"prefs.ss"
"view.ss")
#lang racket/base
(require racket/pretty
racket/class
unstable/class-iop
"interfaces.rkt"
"debug-format.rkt"
"prefs.rkt"
"view.rkt")
(provide debug-file)
(define (widget-mixin %)
@ -30,5 +29,5 @@
(pretty-print msg)
(pretty-print ctx)
(let* ([w (make-stepper)])
(send: w widget<%> add-trace events)
(send/i w widget<%> add-trace events)
w)))

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

@ -1,27 +1,22 @@
#lang scheme/base
(require scheme/class
(rename-in unstable/class-iop
[send/i send:]
[send*/i send*:]
[init-field/i init-field:])
scheme/unit
scheme/list
scheme/match
scheme/gui
framework/framework
syntax/boundmap
"interfaces.ss"
"prefs.ss"
"warning.ss"
"hiding-panel.ss"
(prefix-in s: "../syntax-browser/widget.ss")
(prefix-in s: "../syntax-browser/keymap.ss")
(prefix-in s: "../syntax-browser/interfaces.ss")
"../model/deriv.ss"
"../model/deriv-util.ss"
"../model/trace.ss"
"../model/steps.ss"
"cursor.ss"
#lang racket/base
(require racket/class
racket/unit
racket/list
racket/match
racket/gui
framework
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)
(provide stepper-keymap%
stepper-syntax-widget%)
@ -30,7 +25,7 @@
(define stepper-keymap%
(class s:syntax-keymap%
(init-field: (macro-stepper widget<%>))
(init-field/i (macro-stepper widget<%>))
(inherit-field config
controller)
(inherit add-function
@ -42,17 +37,17 @@
(super-new)
(define/public (get-hiding-panel)
(send: macro-stepper widget<%> get-macro-hiding-prefs))
(send/i macro-stepper widget<%> get-macro-hiding-prefs))
(add-function "hiding:show-macro"
(lambda (i e)
(send*: (get-hiding-panel) hiding-prefs<%>
(send*/i (get-hiding-panel) hiding-prefs<%>
(add-show-identifier)
(refresh))))
(add-function "hiding:hide-macro"
(lambda (i e)
(send*: (get-hiding-panel) hiding-prefs<%>
(send*/i (get-hiding-panel) hiding-prefs<%>
(add-hide-identifier)
(refresh))))
@ -78,21 +73,21 @@
(define stepper-syntax-widget%
(class s:widget%
(init-field: (macro-stepper widget<%>))
(init-field/i (macro-stepper widget<%>))
(inherit get-text)
(inherit-field controller)
(define/override (setup-keymap)
(new stepper-keymap%
(editor (get-text))
(config (send: macro-stepper widget<%> get-config))
(config (send/i macro-stepper widget<%> get-config))
(controller controller)
(macro-stepper macro-stepper)))
(define/override (show-props show?)
(super show-props show?)
(send: macro-stepper widget<%> update/preserve-view))
(send/i macro-stepper widget<%> update/preserve-view))
(super-new
(config (send: macro-stepper widget<%> get-config)))))
(config (send/i macro-stepper widget<%> get-config)))))

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

@ -1,27 +1,23 @@
#lang scheme/base
(require scheme/class
(rename-in unstable/class-iop
[define/i define:]
[send/i send:])
scheme/unit
scheme/list
scheme/file
scheme/match
scheme/gui
framework/framework
syntax/boundmap
"interfaces.ss"
"stepper.ss"
"prefs.ss"
"warning.ss"
"hiding-panel.ss"
(prefix-in sb: "../syntax-browser/embed.ss")
(prefix-in sb: "../syntax-browser/interfaces.ss")
"../model/deriv.ss"
"../model/deriv-util.ss"
"../model/trace.ss"
"../model/steps.ss"
"cursor.ss"
#lang racket/base
(require racket/class
racket/unit
racket/list
racket/file
racket/match
racket/gui
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)
@ -49,8 +45,8 @@
get-help-menu)
(super-new (label (make-label))
(width (send: config config<%> get-width))
(height (send: config config<%> get-height)))
(width (send/i config config<%> get-width))
(height (send/i config config<%> get-height)))
(define/private (make-label)
(if filename
@ -65,10 +61,10 @@
;; to doing something. Avoid unnecessary updates.
(define-values (w0 h0) (get-size))
(define/override (on-size w h)
(send: config config<%> set-width w)
(send: config config<%> set-height h)
(send/i config config<%> set-width w)
(send/i config config<%> set-height h)
(unless (and (= w0 w) (= h0 h))
(send: widget widget<%> update/preserve-view))
(send/i widget widget<%> update/preserve-view))
(set!-values (w0 h0) (values w h)))
(define warning-panel
@ -80,13 +76,13 @@
(define/public (get-macro-stepper-widget%)
macro-stepper-widget%)
(define: widget widget<%>
(define/i widget widget<%>
(new (get-macro-stepper-widget%)
(parent (get-area-container))
(director director)
(config config)))
(define: controller sb:controller<%>
(send: widget widget<%> get-controller))
(define/i controller sb:controller<%>
(send/i widget widget<%> get-controller))
(define/public (get-widget) widget)
(define/public (get-controller) controller)
@ -128,11 +124,11 @@
(new (get-menu-item%)
(label "Duplicate stepper")
(parent file-menu)
(callback (lambda _ (send: widget widget<%> duplicate-stepper))))
(callback (lambda _ (send/i widget widget<%> duplicate-stepper))))
(new (get-menu-item%)
(label "Duplicate stepper (current term only)")
(parent file-menu)
(callback (lambda _ (send: widget widget<%> show-in-new-frame)))))
(callback (lambda _ (send/i widget widget<%> show-in-new-frame)))))
(menu-option/notify-box stepper-menu
"View syntax properties"
@ -149,23 +145,23 @@
(parent id-menu)
(callback
(lambda _
(send: controller sb:controller<%> set-identifier=? p))))])
(send: controller sb:controller<%> listen-identifier=?
(send/i controller sb:controller<%> set-identifier=? p))))])
(send/i controller sb:controller<%> listen-identifier=?
(lambda (name+func)
(send this-choice check
(eq? (car name+func) (car p)))))))
(sb:identifier=-choices)))
(let ([identifier=? (send: config config<%> get-identifier=?)])
(let ([identifier=? (send/i config config<%> get-identifier=?)])
(when identifier=?
(let ([p (assoc identifier=? (sb:identifier=-choices))])
(send: controller sb:controller<%> set-identifier=? p))))
(send/i controller sb:controller<%> set-identifier=? p))))
(new (get-menu-item%)
(label "Clear selection")
(parent stepper-menu)
(callback
(lambda _ (send: controller sb:controller<%>
(lambda _ (send/i controller sb:controller<%>
set-selected-syntax #f))))
(new separator-menu-item% (parent stepper-menu))
@ -177,11 +173,11 @@
(new (get-menu-item%)
(label "Remove selected term")
(parent stepper-menu)
(callback (lambda _ (send: widget widget<%> remove-current-term))))
(callback (lambda _ (send/i widget widget<%> remove-current-term))))
(new (get-menu-item%)
(label "Reset mark numbering")
(parent stepper-menu)
(callback (lambda _ (send: widget widget<%> reset-primary-partition))))
(callback (lambda _ (send/i widget widget<%> reset-primary-partition))))
(let ([extras-menu
(new (get-menu%)
(label "Extra options")
@ -191,11 +187,11 @@
(parent extras-menu)
(callback
(lambda (i e)
(send: config config<%> set-suffix-option
(send/i config config<%> set-suffix-option
(if (send i is-checked?)
'always
'over-limit))
(send: widget widget<%> update/preserve-view))))
(send/i widget widget<%> update/preserve-view))))
(menu-option/notify-box extras-menu
"Factor out common context?"
(get-field split-context? config))

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

@ -1,14 +1,11 @@
#lang scheme/base
(require scheme/class
(rename-in unstable/class-iop
[send/i send:]
[init-field/i init-field:])
scheme/gui
scheme/list
syntax/boundmap
"interfaces.ss"
"../model/hiding-policies.ss"
"../util/mpi.ss"
#lang racket/base
(require racket/class
racket/gui
racket/list
unstable/class-iop
"interfaces.rkt"
"../model/hiding-policies.rkt"
"../util/mpi.rkt"
unstable/gui/notify)
(provide macro-hiding-prefs-widget%)
@ -16,12 +13,21 @@
(define mode:standard "Standard")
(define mode:custom "Custom ...")
#|
TODO
- allow entry of more policies
- visual feedback on rules applying to selected identifier
(need to switch from list to editor)
|#
;; macro-hiding-prefs-widget%
(define macro-hiding-prefs-widget%
(class* object% (hiding-prefs<%>)
(init parent)
(init-field: (stepper widget<%>))
(init-field/i (stepper widget<%>))
(init-field config)
(define/public (get-policy)
@ -80,7 +86,7 @@
(style '(deleted))))
(define/private (get-mode)
(send: config config<%> get-macro-hiding-mode))
(send/i config config<%> get-macro-hiding-mode))
(define/private (macro-hiding-enabled?)
(let ([mode (get-mode)])
@ -90,7 +96,7 @@
(define/private (ensure-custom-mode)
(unless (equal? (get-mode) mode:custom)
(send: config config<%> set-macro-hiding-mode mode:custom)))
(send/i config config<%> set-macro-hiding-mode mode:custom)))
(define/private (update-visibility)
(let ([customizing (equal? (get-mode) mode:custom)])
@ -105,10 +111,10 @@
(list customize-panel)
null))))))
(send: config config<%> listen-macro-hiding-mode
(lambda (value)
(update-visibility)
(force-refresh)))
(send/i config config<%> listen-macro-hiding-mode
(lambda (value)
(update-visibility)
(force-refresh)))
(define box:hiding
(new check-box%
@ -176,11 +182,11 @@
;; refresh : -> void
(define/public (refresh)
(when (macro-hiding-enabled?)
(send: stepper widget<%> refresh/resynth)))
(send/i stepper widget<%> refresh/resynth)))
;; force-refresh : -> void
(define/private (force-refresh)
(send: stepper widget<%> refresh/resynth))
(send/i stepper widget<%> refresh/resynth))
;; set-syntax : syntax/#f -> void
(define/public (set-syntax lstx)
@ -255,11 +261,13 @@
(match condition
[`(free=? ,id)
(let ([b (identifier-binding id)])
(or #;(identifier->string id)
(or #| (identifier->string id) |#
(cond [(list? b)
(let ([mod (caddr b)]
[name (cadddr b)])
(format "'~s' from ~a" name (mpi->string mod)))]
(if (self-mpi? mod)
(format "'~a' defined in this module" name)
(format "'~s' imported from ~a" name (mpi->string mod))))]
[else
(symbol->string (syntax-e id))])))]
[_

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

@ -1,6 +1,6 @@
#lang scheme/base
#lang racket/base
(require unstable/class-iop
(prefix-in sb: "../syntax-browser/interfaces.ss"))
(prefix-in sb: "../syntax-browser/interfaces.rkt"))
(provide (all-defined-out))
(define-interface config<%> (sb:config<%>)
@ -62,6 +62,7 @@
(get-raw-deriv
get-deriv-hidden?
get-step-index
get-step-count
invalidate-synth!
invalidate-steps!

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

@ -1,8 +1,8 @@
#lang scheme/base
(require scheme/class
framework/framework
"interfaces.ss"
"../syntax-browser/prefs.ss"
#lang racket/base
(require racket/class
framework
"interfaces.rkt"
"../syntax-browser/prefs.rkt"
unstable/gui/notify
unstable/gui/prefs)
(provide pref:macro-step-limit

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

@ -1,31 +1,26 @@
#lang scheme/base
(require scheme/class
(rename-in unstable/class-iop
[send/i send:]
[send*/i send*:]
[init-field/i init-field:])
scheme/unit
scheme/list
scheme/match
scheme/gui
framework/framework
syntax/boundmap
"interfaces.ss"
"prefs.ss"
"extensions.ss"
"warning.ss"
"hiding-panel.ss"
"../model/deriv.ss"
"../model/deriv-util.ss"
"../model/deriv-parser.ss"
"../model/trace.ss"
"../model/reductions-config.ss"
"../model/reductions.ss"
"../model/steps.ss"
#lang racket/base
(require racket/class
racket/unit
racket/list
racket/match
racket/gui
framework
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.ss")
"cursor.ss"
"debug-format.ss")
(prefix-in sb: "../syntax-browser/interfaces.rkt")
"cursor.rkt"
"debug-format.rkt")
#;
(provide step-display%
@ -42,23 +37,23 @@
(define step-display%
(class* object% (step-display<%>)
(init-field: (config config<%>))
(init-field/i (config config<%>))
(init-field ((sbview syntax-widget)))
(super-new)
(define/public (add-internal-error part exn stx events)
(send: sbview sb:syntax-browser<%> add-text
(if part
(format "Macro stepper error (~a)" part)
"Macro stepper error"))
(send/i sbview sb:syntax-browser<%> add-text
(if part
(format "Macro stepper error (~a)" part)
"Macro stepper error"))
(when (exn? exn)
(send: sbview sb:syntax-browser<%> add-text " ")
(send: sbview sb:syntax-browser<%> add-clickback "[details]"
(lambda _ (show-internal-error-details exn events))))
(send: sbview sb:syntax-browser<%> add-text ". ")
(when stx (send: sbview sb:syntax-browser<%> add-text "Original syntax:"))
(send: sbview sb:syntax-browser<%> add-text "\n")
(when stx (send: sbview sb:syntax-browser<%> add-syntax stx)))
(send/i sbview sb:syntax-browser<%> add-text " ")
(send/i sbview sb:syntax-browser<%> add-clickback "[details]"
(lambda _ (show-internal-error-details exn events))))
(send/i sbview sb:syntax-browser<%> add-text ". ")
(when stx (send/i sbview sb:syntax-browser<%> add-text "Original syntax:"))
(send/i sbview sb:syntax-browser<%> add-text "\n")
(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"
@ -77,7 +72,7 @@
((3 #f) (void))))
(define/public (add-error exn)
(send*: sbview sb:syntax-browser<%>
(send*/i sbview sb:syntax-browser<%>
(add-error-text (exn-message exn))
(add-text "\n")))
@ -87,6 +82,8 @@
(show-step step shift-table)]
[(misstep? step)
(show-misstep step shift-table)]
[(remarkstep? step)
(show-remarkstep step shift-table)]
[(prestep? step)
(show-prestep step shift-table)]
[(poststep? step)
@ -96,17 +93,17 @@
#:binders [binders null]
#:definites [definites null]
#:shift-table [shift-table #f])
(send: sbview sb:syntax-browser<%> add-syntax stx
#:binders binders
#:definites definites
#:shift-table shift-table))
(send/i sbview sb:syntax-browser<%> add-syntax stx
#:binders binders
#:definites definites
#:shift-table shift-table))
(define/public (add-final stx error
#:binders binders
#:definites definites
#:shift-table [shift-table #f])
(when stx
(send*: sbview sb:syntax-browser<%>
(send*/i sbview sb:syntax-browser<%>
(add-text "Expansion finished\n")
(add-syntax stx
#:binders binders
@ -120,8 +117,8 @@
(define state (protostep-s1 step))
(define lctx (state-lctx state))
(for ([bf lctx])
(send: sbview sb:syntax-browser<%> add-text
"\nwhile executing macro transformer in:\n")
(send/i sbview sb:syntax-browser<%> add-text
"\nwhile executing macro transformer in:\n")
(insert-syntax/redex (bigframe-term bf)
(bigframe-foci bf)
(state-binders state)
@ -150,7 +147,7 @@
(show-lctx step shift-table)))
(define/private (factor-common-context state1 state2)
(if (send: config config<%> get-split-context?)
(if (send/i config config<%> get-split-context?)
(factor-common-context* state1 state2)
(values null state1 state2)))
@ -177,7 +174,7 @@
(when (pair? ctx)
(let* ([hole-stx #'~~HOLE~~]
[the-syntax (context-fill ctx hole-stx)])
(send*: sbview sb:syntax-browser<%>
(send*/i sbview sb:syntax-browser<%>
(add-text "\nin context:\n")
(add-syntax the-syntax
#:definites uses1
@ -218,30 +215,46 @@
(define state (protostep-s1 step))
(show-state/redex state shift-table)
(separator step)
(send*: sbview sb:syntax-browser<%>
(send*/i sbview sb:syntax-browser<%>
(add-error-text (exn-message (misstep-exn step)))
(add-text "\n"))
(when (exn:fail:syntax? (misstep-exn step))
(for ([e (exn:fail:syntax-exprs (misstep-exn step))])
(send: sbview sb:syntax-browser<%> add-syntax e
#:binders (or (state-binders state) null)
#:definites (or (state-uses state) null)
#:shift-table shift-table)))
(send/i sbview sb:syntax-browser<%> add-syntax e
#:binders (or (state-binders state) null)
#:definites (or (state-uses state) null)
#:shift-table shift-table)))
(show-lctx step shift-table))
(define/private (show-remarkstep step shift-table)
(define state (protostep-s1 step))
(for ([content (in-list (remarkstep-contents step))])
(cond [(string? content)
(send*/i sbview sb:syntax-browser<%>
(add-text content)
(add-text "\n"))]
[(syntax? content)
(send*/i sbview sb:syntax-browser<%>
(add-syntax content
#:binders (or (state-binders state) null)
#:definites (or (state-uses state) null)
#:shift-table shift-table)
(add-text "\n"))]))
(show-lctx step shift-table))
;; insert-syntax/color
(define/private (insert-syntax/color stx foci binders shift-table
definites frontier hi-color)
(define highlight-foci? (send: config config<%> get-highlight-foci?))
(define highlight-frontier? (send: config config<%> get-highlight-frontier?))
(send: sbview sb:syntax-browser<%> add-syntax stx
#:definites (or definites null)
#:binders binders
#:shift-table shift-table
#:hi-colors (list hi-color
"WhiteSmoke")
#:hi-stxss (list (if highlight-foci? foci null)
(if highlight-frontier? frontier null))))
(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)
#:binders binders
#:shift-table shift-table
#:hi-colors (list hi-color
"WhiteSmoke")
#:hi-stxss (list (if highlight-foci? foci null)
(if highlight-frontier? frontier null))))
;; insert-syntax/redex
(define/private (insert-syntax/redex stx foci binders shift-table
@ -257,7 +270,7 @@
;; insert-step-separator : string -> void
(define/private (insert-step-separator text)
(send*: sbview sb:syntax-browser<%>
(send*/i sbview sb:syntax-browser<%>
(add-text "\n ")
(add-text
(make-object image-snip%
@ -269,14 +282,14 @@
;; insert-as-separator : string -> void
(define/private (insert-as-separator text)
(send*: sbview sb:syntax-browser<%>
(send*/i sbview sb:syntax-browser<%>
(add-text "\n ")
(add-text text)
(add-text "\n\n")))
;; insert-step-separator/small : string -> void
(define/private (insert-step-separator/small text)
(send*: sbview sb:syntax-browser<%>
(send*/i sbview sb:syntax-browser<%>
(add-text " ")
(add-text
(make-object image-snip%

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

@ -1,30 +1,24 @@
#lang scheme/base
(require scheme/class
(rename-in unstable/class-iop
[define/i define:]
[send/i send:]
[send*/i send*:]
[init-field/i init-field:])
scheme/unit
scheme/list
scheme/match
scheme/gui
framework/framework
syntax/boundmap
"interfaces.ss"
"prefs.ss"
"extensions.ss"
"warning.ss"
"hiding-panel.ss"
"term-record.ss"
"step-display.ss"
(prefix-in sb: "../syntax-browser/interfaces.ss")
"../model/deriv.ss"
"../model/deriv-util.ss"
"../model/trace.ss"
"../model/reductions.ss"
"../model/steps.ss"
"cursor.ss"
#lang racket/base
(require racket/class
racket/unit
racket/list
racket/match
racket/gui
framework
unstable/class-iop
"interfaces.rkt"
"prefs.rkt"
"extensions.rkt"
"hiding-panel.rkt"
"term-record.rkt"
"step-display.rkt"
(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"
unstable/gui/notify
(only-in mzscheme [#%top-interaction mz-top-interaction]))
(provide macro-stepper-widget%
@ -37,7 +31,7 @@
(class* object% (widget<%>)
(init-field parent)
(init-field config)
(init-field: (director director<%>))
(init-field/i (director director<%>))
;; Terms
@ -70,7 +64,7 @@
(define/public (add trec)
(set! all-terms (cons trec all-terms))
(let ([display-new-term? (cursor:at-end? terms)]
[invisible? (send: trec term-record<%> get-deriv-hidden?)])
[invisible? (send/i trec term-record<%> get-deriv-hidden?)])
(unless invisible?
(cursor:add-to-end! terms (list trec))
(trim-navigator)
@ -88,26 +82,25 @@
(define/public (show-in-new-frame)
(let ([term (focused-term)])
(when term
(let ([new-stepper (send: director director<%> new-stepper '(no-new-traces))])
(send: new-stepper widget<%> add-deriv (send: term term-record<%> get-raw-deriv))
(let ([new-stepper (send/i director director<%> new-stepper '(no-new-traces))])
(send/i new-stepper widget<%> add-deriv (send/i term term-record<%> get-raw-deriv))
(void)))))
;; duplicate-stepper : -> void
(define/public (duplicate-stepper)
(let ([new-stepper (send: director director<%> new-stepper)])
(let ([new-stepper (send/i director director<%> new-stepper)])
(for ([term (cursor->list terms)])
(send: new-stepper widget<%> add-deriv
(send: term term-record<%> get-raw-deriv)))))
(send/i new-stepper widget<%> add-deriv
(send/i term term-record<%> get-raw-deriv)))))
(define/public (get-config) config)
(define/public (get-controller) sbc)
(define/public (get-view) sbview)
(define/public (get-step-displayer) step-displayer)
(define/public (get-warnings-area) warnings-area)
(define/public (get-macro-hiding-prefs) macro-hiding-prefs)
(define/public (reset-primary-partition)
(send: sbc sb:controller<%> reset-primary-partition)
(send/i sbc sb:controller<%> reset-primary-partition)
(update/preserve-view))
(define area (new vertical-panel% (parent parent)))
@ -129,31 +122,29 @@
(stretchable-height #f)
(alignment '(left center))
(style '(deleted))))
(define warnings-area (new stepper-warnings% (parent area)))
(define: sbview sb:syntax-browser<%>
(define/i sbview sb:syntax-browser<%>
(new stepper-syntax-widget%
(parent area)
(macro-stepper this)))
(define: step-displayer step-display<%>
(define/i step-displayer step-display<%>
(new step-display%
(config config)
(syntax-widget sbview)))
(define: sbc sb:controller<%>
(send: sbview sb:syntax-browser<%> get-controller))
(define/i sbc sb:controller<%>
(send/i sbview sb:syntax-browser<%> get-controller))
(define control-pane
(new vertical-panel% (parent area) (stretchable-height #f)))
(define: macro-hiding-prefs hiding-prefs<%>
(define/i macro-hiding-prefs hiding-prefs<%>
(new macro-hiding-prefs-widget%
(parent control-pane)
(stepper this)
(config config)))
(send: sbc sb:controller<%>
(send/i sbc sb:controller<%>
listen-selected-syntax
(lambda (stx) (send: macro-hiding-prefs hiding-prefs<%> set-syntax stx)))
(send*: config config<%>
(lambda (stx) (send/i macro-hiding-prefs hiding-prefs<%> set-syntax stx)))
(send*/i config config<%>
(listen-show-hiding-panel?
(lambda (show?) (show-macro-hiding-panel show?)))
(listen-split-context?
@ -206,7 +197,16 @@
(navigate-to (sub1 step))]
[(equal? value "end")
(navigate-to-end)])))))))
(define nav:step-count
(new message%
(label "")
(parent extra-navigator)
(auto-resize #t)
(stretchable-width #f)
(stretchable-height #f)))
(send nav:text set-value "")
(listen-current-step-index
(lambda (n)
(send nav:text set-value
@ -246,34 +246,34 @@
;; Navigation
#|
(define/public-final (at-start?)
(send: (focused-term) term-record<%> at-start?))
(send/i (focused-term) term-record<%> at-start?))
(define/public-final (at-end?)
(send: (focused-term) term-record<%> at-end?))
(send/i (focused-term) term-record<%> at-end?))
|#
(define/public-final (navigate-to-start)
(send: (focused-term) term-record<%> navigate-to-start)
(send/i (focused-term) term-record<%> navigate-to-start)
(update/save-position))
(define/public-final (navigate-to-end)
(send: (focused-term) term-record<%> navigate-to-end)
(send/i (focused-term) term-record<%> navigate-to-end)
(update/save-position))
(define/public-final (navigate-previous)
(send: (focused-term) term-record<%> navigate-previous)
(send/i (focused-term) term-record<%> navigate-previous)
(update/save-position))
(define/public-final (navigate-next)
(send: (focused-term) term-record<%> navigate-next)
(send/i (focused-term) term-record<%> navigate-next)
(update/save-position))
(define/public-final (navigate-to n)
(send: (focused-term) term-record<%> navigate-to n)
(send/i (focused-term) term-record<%> navigate-to n)
(update/save-position))
(define/public-final (navigate-up)
(when (focused-term)
(send: (focused-term) term-record<%> on-lose-focus))
(send/i (focused-term) term-record<%> on-lose-focus))
(cursor:move-prev terms)
(refresh/move))
(define/public-final (navigate-down)
(when (focused-term)
(send: (focused-term) term-record<%> on-lose-focus))
(send/i (focused-term) term-record<%> on-lose-focus))
(cursor:move-next terms)
(refresh/move))
@ -285,7 +285,7 @@
;; update/preserve-lines-view : -> void
(define/public (update/preserve-lines-view)
(define text (send: sbview sb:syntax-browser<%> get-text))
(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)
@ -298,7 +298,7 @@
;; update/preserve-view : -> void
(define/public (update/preserve-view)
(define text (send: sbview sb:syntax-browser<%> get-text))
(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)
@ -308,17 +308,17 @@
;; update : -> void
;; Updates the terms in the syntax browser to the current step
(define/private (update)
(define text (send: sbview sb:syntax-browser<%> get-text))
(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: sbview sb:syntax-browser<%> erase-all)
(send/i sbview sb:syntax-browser<%> erase-all)
(update:show-prefix)
(when multiple-terms? (send: sbview sb:syntax-browser<%> add-separator))
(when multiple-terms? (send/i sbview sb:syntax-browser<%> add-separator))
(set! position-of-interest (send text last-position))
(update:show-current-step)
(when multiple-terms? (send: sbview sb:syntax-browser<%> add-separator))
(when multiple-terms? (send/i sbview sb:syntax-browser<%> add-separator))
(update:show-suffix)
(send text end-edit-sequence)
(send text scroll-to-position
@ -332,35 +332,35 @@
;; update:show-prefix : -> void
(define/private (update:show-prefix)
;; Show the final terms from the cached synth'd derivs
(for-each (lambda (trec) (send: trec term-record<%> display-final-term))
(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: (focused-term) term-record<%> display-step)))
(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: trec term-record<%> display-initial-term))
(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: term term-record<%> get-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: term term-record<%> has-prev?)))
(send nav:previous enable (and term (send: term term-record<%> has-prev?)))
(send nav:next enable (and term (send: term term-record<%> has-next?)))
(send nav:end enable (and term (send: term term-record<%> has-next?)))
(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)))
@ -370,14 +370,14 @@
;; refresh/resynth : -> void
;; Macro hiding policy has changed; invalidate cached parts of trec
(define/public (refresh/resynth)
(for-each (lambda (trec) (send: trec term-record<%> invalidate-synth!))
(for-each (lambda (trec) (send/i trec term-record<%> invalidate-synth!))
(cursor->list terms))
(refresh))
;; refresh/re-reduce : -> void
;; Reduction config has changed; invalidate cached parts of trec
(define/private (refresh/re-reduce)
(for-each (lambda (trec) (send: trec term-record<%> invalidate-steps!))
(for-each (lambda (trec) (send/i trec term-record<%> invalidate-steps!))
(cursor->list terms))
(refresh))
@ -388,9 +388,15 @@
;; refresh : -> void
(define/public (refresh)
(send warnings-area clear)
(when (focused-term)
(send: (focused-term) term-record<%> on-get-focus))
(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)))
@ -398,7 +404,7 @@
;; Hiding policy
(define/public (get-show-macro?)
(send: macro-hiding-prefs hiding-prefs<%> get-policy))
(send/i macro-hiding-prefs hiding-prefs<%> get-policy))
;; Derivation pre-processing
@ -407,8 +413,8 @@
;; Initialization
(super-new)
(show-macro-hiding-panel (send: config config<%> get-show-hiding-panel?))
(show-extra-navigation (send: config config<%> get-extra-navigation?))
(show-macro-hiding-panel (send/i config config<%> get-show-hiding-panel?))
(show-extra-navigation (send/i config config<%> get-extra-navigation?))
(refresh/move)
))

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

@ -1,33 +1,28 @@
#lang scheme/base
(require scheme/class
(rename-in unstable/class-iop
[define/i define:]
[send/i send:]
[init-field/i init-field:])
scheme/unit
scheme/list
scheme/match
scheme/gui
framework/framework
syntax/boundmap
#lang racket/base
(require racket/class
racket/unit
racket/list
racket/match
racket/gui
framework
syntax/stx
unstable/find
"interfaces.ss"
"prefs.ss"
"extensions.ss"
"warning.ss"
"hiding-panel.ss"
"step-display.ss"
"../model/deriv.ss"
"../model/deriv-util.ss"
"../model/deriv-parser.ss"
"../model/trace.ss"
"../model/reductions-config.ss"
"../model/reductions.ss"
"../model/steps.ss"
unstable/class-iop
"interfaces.rkt"
"prefs.rkt"
"extensions.rkt"
"hiding-panel.rkt"
"step-display.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
"cursor.ss"
"debug-format.ss")
"cursor.rkt"
"debug-format.rkt")
(provide term-record%)
@ -35,12 +30,12 @@
(define term-record%
(class* object% (term-record<%>)
(init-field: (stepper widget<%>))
(init-field/i (stepper widget<%>))
(define: config config<%>
(send: stepper widget<%> get-config))
(define: displayer step-display<%>
(send: stepper widget<%> get-step-displayer))
(define/i config config<%>
(send/i stepper widget<%> get-config))
(define/i displayer step-display<%>
(send/i stepper widget<%> get-step-displayer))
;; Data
@ -134,7 +129,7 @@
(unless (or deriv deriv-hidden?)
(recache-raw-deriv!)
(when raw-deriv
(let ([process (send: stepper widget<%> get-preprocess-deriv)])
(let ([process (send/i stepper widget<%> get-preprocess-deriv)])
(let ([d (process raw-deriv)])
(when (not d)
(set! deriv-hidden? #t))
@ -151,7 +146,7 @@
(unless (or raw-steps raw-steps-oops)
(recache-synth!)
(when deriv
(let ([show-macro? (or (send: stepper widget<%> get-show-macro?)
(let ([show-macro? (or (send/i stepper widget<%> get-show-macro?)
(lambda (id) #t))])
(with-handlers ([(lambda (e) #t)
(lambda (e)
@ -173,12 +168,12 @@
(set! steps
(and raw-steps
(let* ([filtered-steps
(if (send: config config<%> get-show-rename-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: config config<%> get-one-by-one?)
(if (send/i config config<%> get-one-by-one?)
(reduce:one-by-one filtered-steps)
filtered-steps)])
(cursor:new processed-steps))))
@ -207,7 +202,11 @@
(and (get-steps) (not (cursor:at-end? (get-steps)))))
(define/public-final (get-step-index)
(and (get-steps) (cursor-position (get-steps))))
(let ([steps (get-steps)])
(and steps (cursor-position steps))))
(define/public-final (get-step-count)
(let ([steps (get-steps)])
(and steps (cursor-count steps))))
(define/public-final (navigate-to-start)
(cursor:move-to-start (get-steps))
@ -276,21 +275,21 @@
;; display-initial-term : -> void
(define/public (display-initial-term)
(cond [raw-deriv-oops
(send: displayer step-display<%> add-internal-error
"derivation" raw-deriv-oops #f events)]
(send/i displayer step-display<%> add-internal-error
"derivation" raw-deriv-oops #f events)]
[else
(send: displayer step-display<%> add-syntax (wderiv-e1 deriv))]))
(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: displayer step-display<%> add-syntax raw-steps-estx
#:binders raw-steps-binders
#:shift-table shift-table
#:definites raw-steps-definites)]
(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: displayer step-display<%> add-error raw-steps-exn)]
(send/i displayer step-display<%> add-error raw-steps-exn)]
[else (display-oops #f)]))
;; display-step : -> void
@ -299,24 +298,24 @@
(cond [steps
(let ([step (cursor:next steps)])
(if step
(send: displayer step-display<%> add-step step
#:shift-table shift-table)
(send: displayer step-display<%> add-final raw-steps-estx raw-steps-exn
#:binders raw-steps-binders
#:shift-table shift-table
#:definites raw-steps-definites)))]
(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?)
(cond [raw-steps-oops
(send: displayer step-display<%> add-internal-error
"steps" raw-steps-oops
(and show-syntax? (wderiv-e1 deriv))
events)]
(send/i displayer step-display<%> add-internal-error
"steps" raw-steps-oops
(and show-syntax? (wderiv-e1 deriv))
events)]
[raw-deriv-oops
(send: displayer step-display<%> add-internal-error
"derivation" raw-deriv-oops #f events)]
(send/i displayer step-display<%> add-internal-error
"derivation" raw-deriv-oops #f events)]
[else
(error 'term-record::display-oops "internal error")]))
))

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

@ -1,14 +1,13 @@
#lang scheme/base
(require scheme/class
(rename-in unstable/class-iop
[send/i send:])
scheme/pretty
scheme/gui
framework/framework
"interfaces.ss"
"frame.ss"
"prefs.ss"
"../model/trace.ss")
#lang racket/base
(require racket/class
racket/pretty
racket/gui
framework
unstable/class-iop
"interfaces.rkt"
"frame.rkt"
"prefs.rkt"
"../model/trace.rkt")
(provide macro-stepper-director%
macro-stepper-frame%
go)
@ -28,23 +27,23 @@
(hash-for-each stepper-frames
(lambda (stepper-frame flags)
(unless (memq 'no-obsolete flags)
(send: stepper-frame stepper-frame<%> add-obsoleted-warning)))))
(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: (send: stepper-frame stepper-frame<%> get-widget) widget<%>
(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: (send: stepper-frame stepper-frame<%> get-widget) widget<%>
(send/i (send/i stepper-frame stepper-frame<%> get-widget) widget<%>
add-deriv deriv)))))
(define/public (new-stepper [flags '()])
(define stepper-frame (new-stepper-frame))
(define stepper (send: stepper-frame stepper-frame<%> get-widget))
(define stepper (send/i stepper-frame stepper-frame<%> get-widget))
(send stepper-frame show #t)
(add-stepper! stepper-frame flags)
stepper)
@ -65,6 +64,6 @@
(define (go stx)
(define director (new macro-stepper-director%))
(define stepper (send: director director<%> new-stepper))
(send: director director<%> add-deriv (trace stx))
(define stepper (send/i director director<%> new-stepper))
(send/i director director<%> add-deriv (trace stx))
(void))

1
collects/unstable/find.rkt
View File

@ -70,4 +70,3 @@
(if (procedure? default)
(default)
default)))
;; Eli: Note that this is documented "Like `find-first'".